[Guile-commits] 02/02: Update (ice-9 match) to include selected bug fixes from upstream.

[Mark H. Weaver]

mhw pushed a commit to branch stable-2.2
in repository guile.

commit 8e86dd93a0640161fe0098a80ccc9b814dddd280
Author: Mark H Weaver <address@hidden>
Date:   Sun Nov 11 23:07:47 2018 -0500

    Update (ice-9 match) to include selected bug fixes from upstream.
    
    Fixes <https://bugs.gnu.org/22925> and other bugs.
    
    * module/ice-9/match.upstream.scm: Apply selected fixes from the
    upstream match.scm in Chibi-Scheme.
    * test-suite/tests/match.test.upstream: Add more tests from upstream.
---
 module/ice-9/match.upstream.scm      | 19 ++++++++++++-------
 test-suite/tests/match.test.upstream |  9 +++++++++
 2 files changed, 21 insertions(+), 7 deletions(-)

diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm
index 350c01e..1983c1e 100644
--- a/module/ice-9/match.upstream.scm
+++ b/module/ice-9/match.upstream.scm
@@ -210,6 +210,11 @@
 ;; performance can be found at
 ;;   http://synthcode.com/scheme/match-cond-expand.scm
 ;;
+;; 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
+;; 2012/12/26 - wrapping match-let&co body in lexical closure
+;; 2012/11/28 - fixing typo s/vetor/vector in largely unused set! code
 ;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
 ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
 ;;              the pattern (thanks to Stefan Israelsson Tampe)
@@ -675,7 +680,7 @@
        (if (>= j len)
          (let ((id (reverse id-ls)) ...) (sk ... i))
          (let ((w (vector-ref v j)))
-           (match-one w p ((vector-ref v j) (vetor-set! v j))
+           (match-one w p ((vector-ref v j) (vector-set! v j))
                       (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
                       fk i)))))))
 
@@ -765,13 +770,13 @@
      (match-extract-vars x k i v))
     ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
      (match-extract-quasiquote-vars x k i v d))
-    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+    ((match-extract-quasiquote-vars (x . y) k i v d)
      (match-extract-quasiquote-vars
       x
-      (match-extract-quasiquote-vars-step y k i v d) i ()))
-    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+      (match-extract-quasiquote-vars-step y k i v d) i () d))
+    ((match-extract-quasiquote-vars #(x ...) k i v d)
      (match-extract-quasiquote-vars (x ...) k i v d))
-    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+    ((match-extract-quasiquote-vars x (k ...) i v d)
      (k ... v))
     ))
 
@@ -812,7 +817,7 @@
     ((_ ((var value) ...) . body)
      (match-let/helper let () () ((var value) ...) . body))
     ((_ loop ((var init) ...) . body)
-     (match-named-let loop ((var init) ...) . body))))
+     (match-named-let loop () ((var init) ...) . body))))
 
 ;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
 ;;> matches and binds the variables with all match variables in scope.
@@ -857,7 +862,7 @@
 (define-syntax match-let*
   (syntax-rules ()
     ((_ () . body)
-     (begin . body))
+     (let () . body))
     ((_ ((pat expr) . rest) . body)
      (match expr (pat (match-let* rest . body))))))
 
diff --git a/test-suite/tests/match.test.upstream 
b/test-suite/tests/match.test.upstream
index e1e106e..7cbb804 100644
--- a/test-suite/tests/match.test.upstream
+++ b/test-suite/tests/match.test.upstream
@@ -28,6 +28,7 @@
 (test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 
'ok)))
 (test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . 
x) x)))
 (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 "ellipses" '((a b c) (1 2 3))
   (match '((a . 1) (b . 2) (c . 3))
@@ -166,4 +167,12 @@
       (((and x (? symbol?)) ..1) x)
       (else #f)))
 
+(test "match-named-let" 6
+    (match-let loop (((x . rest) '(1 2 3))
+                     (sum 0))
+      (let ((sum (+ x sum)))
+        (if (null? rest)
+            sum
+            (loop rest sum)))))
+
 (test-end)