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

fixing ,@ patterns

Browse source
This commit is contained in:
Alex Shinn 2020-07-06 14:24:22 +09:00
parent cb5f523532
commit 72668b6d26
2 changed files with 43 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -117,6 +117,15 @@
(test "Riastradh quasiquote" '(2 3) (test "Riastradh quasiquote" '(2 3)
(match '(1 2 3) (`(1 ,b ,c) (list b c)))) (match '(1 2 3) (`(1 ,b ,c) (list b c))))
(test "unquote-splicing" '(2 3)
(match '(1 2 3) (`(1 ,@ls) ls)))
(test "unquote-splicing tail" '(b c)
(match '(a b c d) (`(a ,@ls d) ls)))
(test "unquote-splicing tail fail" #f
(match '(a b c e) (`(a ,@ls d) ls) (else #f)))
(test "trivial tree search" '(1 2 3) (test "trivial tree search" '(1 2 3)
(match '(1 2 3) ((_ *** (a b c)) (list a b c)))) (match '(1 2 3) ((_ *** (a b c)) (list a b c))))

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

@ -235,7 +235,7 @@
;; performance can be found at ;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm ;; http://synthcode.com/scheme/match-cond-expand.scm
;; ;;
;; 2020/07/06 - adding `..=' and `..*' patterns ;; 2020/07/06 - adding `..=' and `..*' patterns; fixing ,@ patterns
;; 2016/10/05 - treat keywords as literals, not identifiers, in Chicken ;; 2016/10/05 - treat keywords as literals, not identifiers, in Chicken
;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe) ;; 2016/03/06 - fixing named match-let (thanks to Stefan Israelsson Tampe)
;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns ;; 2015/05/09 - fixing bug in var extraction of quasiquote patterns
@ -460,17 +460,15 @@
;; QUASIQUOTE patterns ;; QUASIQUOTE patterns
(define-syntax match-quasiquote (define-syntax match-quasiquote
(syntax-rules (unquote unquote-splicing quasiquote) (syntax-rules (unquote unquote-splicing quasiquote or)
((_ v (unquote p) g+s sk fk i) ((_ v (unquote p) g+s sk fk i)
(match-one v p g+s sk fk i)) (match-one v p g+s sk fk i))
((_ v ((unquote-splicing p) . rest) g+s sk fk i) ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
(if (pair? v) ;; TODO: it is an error to have another unquote-splicing in rest,
(match-one v ;; check this and signal explicitly
(p . tmp) (match-extract-vars
(match-quasiquote tmp rest g+s sk fk) p
fk (match-gen-ellipsis/qq v p rest g+s sk fk i) i ()))
i)
fk))
((_ v (quasiquote p) g+s sk fk i . depth) ((_ v (quasiquote p) g+s sk fk i . depth)
(match-quasiquote v p g+s sk fk i #f . depth)) (match-quasiquote v p g+s sk fk i #f . depth))
((_ v (unquote p) g+s sk fk i x . depth) ((_ v (unquote p) g+s sk fk i x . depth)
@ -599,6 +597,33 @@
(else (else
fk))))))))) fk)))))))))
;; Variant of the above where the rest pattern is in a quasiquote.
(define-syntax match-gen-ellipsis/qq
(syntax-rules ()
((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
(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
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-quasiquote ls r g+s (sk ...) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
(match-drop-ids
(loop (cdr ls) (- n 1) (cons id id-ls) ...))
fk
i)))
(else
fk)))))))))
;; Variant of above which takes an n/m range for the number of ;; Variant of above which takes an n/m range for the number of
;; repetitions. At least n elements much match, and up to m elements ;; repetitions. At least n elements much match, and up to m elements
;; are greedily consumed. ;; are greedily consumed.