Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

fix a ... match pattern when a is already bound

Browse source
This commit is contained in:
Alex Shinn 2020-09-06 22:59:42 +09:00
parent 9c6020e22d
commit 993a6469fe
2 changed files with 22 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
lib/chibi/match-test.sld
View file

@ -49,6 +49,8 @@
(let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f)))) (let ((a '(1 2))) (match a ((and (a 2) (1 b)) (+ a b)) (_ #f))))
(test "duplicate quasiquote" 'ok (test "duplicate quasiquote" 'ok
(match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f))) (match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f)))
(test "duplicate before ellipsis" #f
(match '(1 2) ((a a ...) a) (else #f)))
(test "ellipses" '((a b c) (1 2 3)) (test "ellipses" '((a b c) (1 2 3))
(match '((a . 1) (b . 2) (c . 3)) (match '((a . 1) (b . 2) (c . 3))

39
lib/chibi/match/match.scm
View file

@ -564,25 +564,26 @@
(define-syntax match-gen-ellipsis (define-syntax match-gen-ellipsis
(syntax-rules () (syntax-rules ()
((_ v p () g+s (sk ...) fk i ((id id-ls) ...)) ;; TODO: restore fast path when p is not already bound
(match-check-identifier p ;; ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
;; simplest case equivalent to (p ...), just bind the list ;; (match-check-identifier p
(let ((p v)) ;; ;; simplest case equivalent to (p ...), just bind the list
(if (list? p) ;; (let ((p v))
(sk ... i) ;; (if (list? p)
fk)) ;; (sk ... i)
;; simple case, match all elements of the list ;; fk))
(let loop ((ls v) (id-ls '()) ...) ;; ;; simple case, match all elements of the list
(cond ;; (let loop ((ls v) (id-ls '()) ...)
((null? ls) ;; (cond
(let ((id (reverse id-ls)) ...) (sk ... i))) ;; ((null? ls)
((pair? ls) ;; (let ((id (reverse id-ls)) ...) (sk ... i)))
(let ((w (car ls))) ;; ((pair? ls)
(match-one w p ((car ls) (set-car! ls)) ;; (let ((w (car ls)))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...)) ;; (match-one w p ((car ls) (set-car! ls))
fk i))) ;; (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
(else ;; fk i)))
fk))))) ;; (else
;; fk)))))
((_ v p r g+s sk fk (i ...) ((id id-ls) ...)) ((_ v p r g+s sk fk (i ...) ((id id-ls) ...))
;; general case, trailing patterns to match, keep track of the ;; general case, trailing patterns to match, keep track of the
;; remaining list length so we don't need any backtracking ;; remaining list length so we don't need any backtracking