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

match fix for (a ...) patterns where a was already bound - thanks to Andy Wingo

Browse source
This commit is contained in:
Alex Shinn 2021-06-21 16:44:02 +09:00
parent 5207bdfde2
commit 05c546e38d
2 changed files with 89 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -50,7 +50,17 @@
(test "duplicate quasiquote" 'ok
(match '(a b) ((or `(a ,x) `(,x b)) 'ok) (_ #f)))
(test "duplicate before ellipsis" #f
(match '(1 2) ((a a ...) a) (else #f)))
(match '(1 2) ((a a ...) a) (else #f)))
(test "duplicate ellipsis pass" '(1 2)
(match '((1 2) (1 2)) (((x ...) (x ...)) x) (else #f)))
(test "duplicate ellipsis fail" #f
(match '((1 2) (1 2 3)) (((x ...) (x ...)) x) (else #f)))
(test "duplicate ellipsis trailing" '(1 2)
(match '((1 2 3) (1 2 3)) (((x ... 3) (x ... 3)) x) (else #f)))
(test "duplicate ellipsis trailing fail" #f
(match '((1 2 3) (1 1 3)) (((x ... 3) (x ... 3)) x) (else #f)))
(test "duplicate ellipsis fail trailing" #f
(match '((1 2 3) (1 2 4)) (((x ... 3) (x ... 3)) x) (else #f)))
(test "ellipses" '((a b c) (1 2 3))
(match '((a . 1) (b . 2) (c . 3))
@ -69,6 +79,9 @@
(((? odd? n) ___) n)
(((? number? n) ___) n)))
(test "ellipsis trailing" '(3 1 2)
(match '(1 2 3) ((x ... y) (cons y x)) (else #f)))
(test "failure continuation" 'ok
(match '(1 2)
((a . b) (=> next) (if (even? a) 'fail (next)))

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

@ -242,6 +242,8 @@
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2021/06/21 - fix for `(a ...)' patterns where `a' is already bound
;; (thanks to Andy Wingo)
;; 2020/09/04 - perf fix for `not`; rename `..=', `..=', `..1' per SRFI 204
;; 2020/08/21 - fixing match-letrec with unhygienic insertion
;; 2020/07/06 - adding `..=' and `..=' patterns; fixing ,@ patterns
@ -565,37 +567,54 @@
(define-syntax match-gen-ellipsis
(syntax-rules ()
;; TODO: restore fast path when p is not already bound
;; ((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
;; (match-check-identifier p
;; ;; simplest case equivalent to (p ...), just bind the list
;; (let ((p v))
;; (if (list? p)
;; (sk ... i)
;; fk))
;; ;; simple case, match all elements of the list
;; (let loop ((ls v) (id-ls '()) ...)
;; (cond
;; ((null? ls)
;; (let ((id (reverse id-ls)) ...) (sk ... i)))
;; ((pair? ls)
;; (let ((w (car ls)))
;; (match-one w p ((car ls) (set-car! ls))
;; (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
;; fk i)))
;; (else
;; fk)))))
((_ v p () g+s (sk ...) fk i ((id id-ls) ...))
(match-check-identifier p
;; simplest case equivalent to (p ...), just match the list
(let ((w v))
(if (list? w)
(match-one w p g+s (sk ...) fk i)
fk))
;; simple case, match all elements of the list
(let loop ((ls v) (id-ls '()) ...)
(cond
((null? ls)
(let ((id (reverse id-ls)) ...) (sk ... i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
fk i)))
(else
fk)))))
((_ v p r g+s sk fk (i ...) ((id id-ls) ...))
;; general case, trailing patterns to match, keep track of the
;; remaining list length so we don't need any backtracking
(match-verify-no-ellipsis
r
(let* ((tail-len (length 'r))
(ls v)
(len (and (list? ls) (length ls))))
(if (or (not len) (< len tail-len))
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
(match-bound-identifier-memv
p
(i ...)
;; p is bound, match the list up to the known length, then
;; match the trailing patterns
(let loop ((ls v) (expect p))
(cond
((null? expect)
(match-one ls r (#f #f) sk fk (i ...)))
((pair? ls)
(let ((w (car ls))
(e (car expect)))
(if (equal? (car ls) (car expect))
(match-drop-ids (loop (cdr ls) (cdr expect)))
fk)))
(else
fk)))
;; general case, trailing patterns to match, keep track of
;; the remaining list length so we don't need any backtracking
(let* ((tail-len (length 'r))
(ls v)
(len (and (list? ls) (length ls))))
(if (or (not len) (< len tail-len))
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one ls r (#f #f) sk fk (i ... id ...))))
@ -607,7 +626,8 @@
fk
(i ...))))
(else
fk)))))))))
fk)))
)))))))
;; Variant of the above where the rest pattern is in a quasiquote.
@ -1095,6 +1115,12 @@
(er-macro-transformer
(lambda (expr rename compare)
(if (eq? (cadr expr) (car (cddr expr)))
(cadr (cddr expr))
(car (cddr (cddr expr)))))))
(define-syntax match-bound-identifier-memv
(er-macro-transformer
(lambda (expr rename compare)
(if (memv (cadr expr) (car (cddr expr)))
(cadr (cddr expr))
(car (cddr (cddr expr))))))))
@ -1115,6 +1141,12 @@
(er-macro-transformer
(lambda (expr rename compare)
(if (eq? (cadr expr) (car (cddr expr)))
(cadr (cddr expr))
(car (cddr (cddr expr)))))))
(define-syntax match-bound-identifier-memv
(er-macro-transformer
(lambda (expr rename compare)
(if (memv (cadr expr) (car (cddr expr)))
(cadr (cddr expr))
(car (cddr (cddr expr))))))))
@ -1177,4 +1209,18 @@
((eq b) sk)
((eq _) fk))))
(eq a))))))
;; Variant of above for a list of ids.
(define-syntax match-bound-identifier-memv
(syntax-rules ()
((match-bound-identifier-memv a (id ...) sk fk)
(match-check-identifier
a
(let-syntax
((memv?
(syntax-rules (id ...)
((memv? a sk2 fk2) fk2)
((memv? anything-else sk2 fk2) sk2))))
(memv? random-sym-to-match sk fk))
fk))))
))