Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 15:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

track head ids in ellipsis tail

Browse source
This commit is contained in:
Alex Shinn 2020-08-26 17:24:38 +09:00
parent dda71763a5
commit 5860a65368
2 changed files with 14 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -39,6 +39,8 @@
(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x))) (test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
(test "duplicate symbols fail" 'ok (test "duplicate symbols fail" 'ok
(match '(ok . bad) ((x . x) 'bad) (else 'ok))) (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
(test "duplicate symbols fail 2" 'ok
(match '(ok bad) ((x x) 'bad) (else 'ok)))
(test "duplicate symbols samth" 'ok (test "duplicate symbols samth" 'ok
(match '(ok . ok) ((x . 'bad) x) (('ok . x) x))) (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
(test "duplicate symbols bound" 3 (test "duplicate symbols bound" 3
@ -106,6 +108,9 @@
(match '((a . 1) (b . 2) 3) (match '((a . 1) (b . 2) 3)
(((x . y) ... last) (list x y last)))) (((x . y) ... last) (list x y last))))
(test "single duplicate tail" #f
(match '(1 2) ((foo ... foo) foo) (_ #f)))
(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5)) (test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
(match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5)) (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
(((x . y) ... u v w) (list x y u v w)))) (((x . y) ... u v w) (list x y u v w))))

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

@ -581,7 +581,7 @@
fk i))) fk i)))
(else (else
fk))))) 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
(match-verify-no-ellipsis (match-verify-no-ellipsis
@ -595,14 +595,14 @@
(cond (cond
((= n tail-len) ((= n tail-len)
(let ((id (reverse id-ls)) ...) (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) ((pair? ls)
(let ((w (car ls))) (let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls)) (match-one w p ((car ls) (set-car! ls))
(match-drop-ids (match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...)) (loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk fk
i))) (i ...))))
(else (else
fk))))))))) fk)))))))))
@ -610,7 +610,7 @@
(define-syntax match-gen-ellipsis/qq (define-syntax match-gen-ellipsis/qq
(syntax-rules () (syntax-rules ()
((_ v p r g+s (sk ...) fk i ((id id-ls) ...)) ((_ v p r g+s (sk ...) fk (i ...) ((id id-ls) ...))
(match-verify-no-ellipsis (match-verify-no-ellipsis
r r
(let* ((tail-len (length 'r)) (let* ((tail-len (length 'r))
@ -622,14 +622,14 @@
(cond (cond
((= n tail-len) ((= n tail-len)
(let ((id (reverse id-ls)) ...) (let ((id (reverse id-ls)) ...)
(match-quasiquote ls r g+s (sk ...) fk i))) (match-quasiquote ls r g+s (sk ...) fk (i ... id ...))))
((pair? ls) ((pair? ls)
(let ((w (car ls))) (let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls)) (match-one w p ((car ls) (set-car! ls))
(match-drop-ids (match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...)) (loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk fk
i))) (i ...))))
(else (else
fk))))))))) fk)))))))))
@ -639,7 +639,7 @@
(define-syntax match-gen-ellipsis/range (define-syntax match-gen-ellipsis/range
(syntax-rules () (syntax-rules ()
((_ %lo %hi v p r g+s (sk ...) fk i ((id id-ls) ...)) ((_ %lo %hi 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
(match-verify-no-ellipsis (match-verify-no-ellipsis
@ -654,14 +654,14 @@
(cond (cond
((= j len) ((= j len)
(let ((id (reverse id-ls)) ...) (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) ((pair? ls)
(let ((w (car ls))) (let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls)) (match-one w p ((car ls) (set-car! ls))
(match-drop-ids (match-drop-ids
(loop (cdr ls) (+ j 1) (cons id id-ls) ...)) (loop (cdr ls) (+ j 1) (cons id id-ls) ...))
fk fk
i))) (i ...))))
(else (else
fk))) fk)))
fk)))))) fk))))))