mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-11 15:07:34 +02:00
track head ids in ellipsis tail
This commit is contained in:
parent
dda71763a5
commit
5860a65368
2 changed files with 14 additions and 9 deletions
|
@ -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))))
|
||||||
|
|
|
@ -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))))))
|
||||||
|
|
Loading…
Add table
Reference in a new issue