diff options
author | Andy Wingo <wingo@pobox.com> | 2021-06-17 21:25:31 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2021-09-30 15:47:41 +0200 |
commit | d4d4336ede625d14434cca98fdb60eb1b282d8a8 (patch) | |
tree | 60f3fc0825eead9cbc99c4d76f9f3bc9ea4bba69 | |
parent | 74abae04aa68dc18676bd84c4a73324b0613475d (diff) | |
download | guile-d4d4336ede625d14434cca98fdb60eb1b282d8a8.tar.gz |
Hotfix to unify (x ...) patterns in match
* module/ice-9/match.upstream.scm (match-gen-ellipsis): Instead of just
binding the identifier when matching (x ...), go through match-one so
that if the id is already bound, we unify instead.
* test-suite/tests/match.test ("unify in list patterns"): Add test.
* test-suite/tests/match.test.upstream: Add additional tests from
upstream.
See commit 05c546e38 in Chibi Scheme. Thanks to Alex Shinn for help
here!
-rw-r--r-- | module/ice-9/match.upstream.scm | 69 | ||||
-rw-r--r-- | test-suite/tests/match.test | 13 | ||||
-rw-r--r-- | test-suite/tests/match.test.upstream | 16 |
3 files changed, 81 insertions, 17 deletions
diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm index b1fc371b8..ff5e535db 100644 --- a/module/ice-9/match.upstream.scm +++ b/module/ice-9/match.upstream.scm @@ -210,6 +210,12 @@ ;; performance can be found at ;; http://synthcode.com/scheme/match-cond-expand.scm ;; +;; 2021/06/21 - fix for `(a ...)' patterns where `a' is already bound +;; (thanks to Andy Wingo) +;; 2020/09/04 - [OMITTED IN GUILE] perf fix for `not`; rename `..=', `..=', `..1' per SRFI 204 +;; 2020/08/21 - [OMITTED IN GUILE] fixing match-letrec with unhygienic insertion +;; 2020/07/06 - [OMITTED IN GUILE] adding `..=' and `..=' patterns; fixing ,@ patterns +;; 2016/10/05 - [OMITTED IN GUILE] treat keywords as literals, not identifiers, in Chicken ;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe) ;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns ;; 2014/11/24 - [OMITTED IN GUILE] adding Gauche's `@' pattern for named record field matching @@ -509,9 +515,9 @@ ((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) (match-check-identifier p ;; simplest case equivalent to (p ...), just bind the list - (let ((p v)) - (if (list? p) - (sk ... i) + (let ((w v)) + (if (list? w) + (match-one w p g+s (sk ...) fk i) fk)) ;; simple case, match all elements of the list (let loop ((ls v) (id-ls '()) ...) @@ -525,30 +531,47 @@ fk i))) (else fk))))) - ((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) - ;; general case, trailing patterns to match, keep track of the - ;; remaining list length so we don't need any backtracking + ((_ v p r g+s sk fk (i ...) ((id id-ls) ...)) (match-verify-no-ellipsis r - (let* ((tail-len (length 'r)) - (ls v) - (len (and (list? ls) (length ls)))) - (if (or (not len) (< len tail-len)) - fk - (let loop ((ls ls) (n len) (id-ls '()) ...) - (cond + (match-bound-identifier-memv + p + (i ...) + ;; p is bound, match the list up to the known length, then + ;; match the trailing patterns + (let loop ((ls v) (expect p)) + (cond + ((null? expect) + (match-one ls r (#f #f) sk fk (i ...))) + ((pair? ls) + (let ((w (car ls)) + (e (car expect))) + (if (equal? (car ls) (car expect)) + (match-drop-ids (loop (cdr ls) (cdr expect))) + fk))) + (else + fk))) + ;; general case, trailing patterns to match, keep track of the + ;; remaining list length so we don't need any backtracking + (let* ((tail-len (length 'r)) + (ls v) + (len (and (list? ls) (length ls)))) + (if (or (not len) (< len tail-len)) + fk + (let loop ((ls ls) (n len) (id-ls '()) ...) + (cond ((= n tail-len) (let ((id (reverse id-ls)) ...) - (match-one ls r (#f #f) (sk ...) fk i))) + (match-one ls r (#f #f) sk fk (i ... id ...)))) ((pair? ls) (let ((w (car ls))) (match-one w p ((car ls) (set-car! ls)) (match-drop-ids (loop (cdr ls) (- n 1) (cons id id-ls) ...)) fk - i))) + (i ...)))) (else - fk))))))))) + fk)))))))))) ;; This is just a safety check. Although unlike syntax-rules we allow ;; trailing patterns after an ellipsis, we explicitly disable multiple @@ -915,3 +938,17 @@ ;; otherwise x is a non-symbol datum ((sym? y sk fk) fk)))) (sym? abracadabra success-k failure-k))))) + +(define-syntax match-bound-identifier-memv + (syntax-rules () + ((match-bound-identifier-memv a (id ...) sk fk) + (match-check-identifier + a + (let-syntax + ((memv? + (syntax-rules (id ...) + ((memv? a sk2 fk2) fk2) + ((memv? anything-else sk2 fk2) sk2)))) + (memv? random-sym-to-match sk fk)) + fk)))) + diff --git a/test-suite/tests/match.test b/test-suite/tests/match.test index 6bf5bdd2c..b5dface86 100644 --- a/test-suite/tests/match.test +++ b/test-suite/tests/match.test @@ -1,6 +1,6 @@ ;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2021 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -189,6 +189,17 @@ (($ rtd-3-slots a b c d) #f)))))) +(with-test-prefix "unify in list patterns" + (pass-if-equal "matching" '(1 2 3) + (match '((1 2 3) (1 2 3)) + (((x ...) (x ...)) x) + (_ #f))) + + (pass-if-equal "not matching" #f + (match '((1 2 3) (1 2 3 4)) + (((x ...) (x ...)) x) + (_ #f)))) + ;;; ;;; Upstream tests, from Chibi-Scheme (3-clause BSD license). diff --git a/test-suite/tests/match.test.upstream b/test-suite/tests/match.test.upstream index 7cbb80433..8dd73b566 100644 --- a/test-suite/tests/match.test.upstream +++ b/test-suite/tests/match.test.upstream @@ -30,6 +30,22 @@ (test "duplicate symbols bound" 3 (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f)))) (test "duplicate quasiquote" 'ok (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f))) +(test "duplicate before ellipsis" #f + (match '(1 2) ((a a ...) a) (else #f))) +(test "duplicate ellipsis pass" '(1 2) + (match '((1 2) (1 2)) (((x ...) (x ...)) x) (else #f))) +(test "duplicate ellipsis fail" #f + (match '((1 2) (1 2 3)) (((x ...) (x ...)) x) (else #f))) +(test "duplicate ellipsis trailing" '(1 2) + (match '((1 2 3) (1 2 3)) (((x ... 3) (x ... 3)) x) (else #f))) +(test "duplicate ellipsis trailing fail" #f + (match '((1 2 3) (1 1 3)) (((x ... 3) (x ... 3)) x) (else #f))) +(test "duplicate ellipsis fail trailing" #f + (match '((1 2 3) (1 2 4)) (((x ... 3) (x ... 3)) x) (else #f))) +(test "ellipsis trailing" '(3 1 2) + (match '(1 2 3) ((x ... y) (cons y x)) (else #f))) + + (test "ellipses" '((a b c) (1 2 3)) (match '((a . 1) (b . 2) (c . 3)) (((x . y) ___) (list x y)))) |