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

fixinf identifier extraction in some ...' and ***' patterns

Browse source
This commit is contained in:
Alex Shinn 2010-09-07 11:13:17 +00:00
parent d38c6bc3e1
commit e474561f70
1 changed files with 8 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -28,6 +28,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
;; ;;
;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
;; 2009/11/25 - adding `***' tree search patterns ;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists ;; 2008/03/20 - fixing bug where (a ...) matched non-lists
;; 2008/03/15 - removing redundant check in vector patterns ;; 2008/03/15 - removing redundant check in vector patterns
@ -240,6 +241,11 @@
(syntax-rules () (syntax-rules ()
((_ expr ids ...) expr))) ((_ expr ids ...) expr)))
(define-syntax match-tuck-ids
(syntax-rules ()
((_ (letish args (expr ...)) ids ...)
(letish args (expr ... ids ...)))))
(define-syntax match-drop-first-arg (define-syntax match-drop-first-arg
(syntax-rules () (syntax-rules ()
((_ arg expr) expr))) ((_ arg expr) expr)))
@ -316,7 +322,7 @@
(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 ... i) fk i))) (match-one ls r (#f #f) (sk ...) fk i)))
((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))
@ -380,7 +386,7 @@
((match-gen-search v p q g+s sk fk i ((id id-ls) ...)) ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
(letrec ((try (lambda (w fail id-ls ...) (letrec ((try (lambda (w fail id-ls ...)
(match-one w q g+s (match-one w q g+s
(match-drop-ids (match-tuck-ids
(let ((id (reverse id-ls)) ...) (let ((id (reverse id-ls)) ...)
sk)) sk))
(next w fail id-ls ...) i))) (next w fail id-ls ...) i)))