[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Update (ice-9 match) to include selected bug fixe
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 02/02: Update (ice-9 match) to include selected bug fixes from upstream. |
Date: |
Sun, 11 Nov 2018 23:17:41 -0500 (EST) |
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)