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

enforce bound-identifier=? for match rewrite

Browse source
This commit is contained in:
Alex Shinn 2020-08-27 17:06:51 +09:00
parent 9793fa0edf
commit 8a6af941ad
2 changed files with 20 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -243,6 +243,14 @@
(append (y) (b)))) (append (y) (b))))
(test "match-letrec quote" #t (test "match-letrec quote" #t
(match-letrec (((x 'x) (list #t 'x))) x)) (match-letrec (((x 'x) (list #t 'x))) x))
(let-syntax
((foo
(syntax-rules ()
((foo x)
(match-letrec (((x y) (list 1 (lambda () (list a x))))
((a b) (list 2 (lambda () (list x a)))))
(append (y) (b)))))))
(test "match-letrec mnieper" '(2 1 1 2) (foo a)))
(cond-expand (cond-expand
(chibi (chibi

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

@ -1058,7 +1058,7 @@
((match-rewrite p () (k ...)) ((match-rewrite p () (k ...))
(k ... p)) (k ... p))
((match-rewrite p ((id tmp) . rest) (k ...)) ((match-rewrite p ((id tmp) . rest) (k ...))
(match-identifier=? p id (k ... tmp) (match-rewrite p rest (k ...)))) (match-bound-identifier=? p id (k ... tmp) (match-rewrite p rest (k ...))))
)) ))
(define-syntax match-rewrite2 (define-syntax match-rewrite2
@ -1088,10 +1088,10 @@
(if (identifier? (cadr expr)) (if (identifier? (cadr expr))
(car (cddr expr)) (car (cddr expr))
(cadr (cddr expr)))))) (cadr (cddr expr))))))
(define-syntax match-identifier=? (define-syntax match-bound-identifier=?
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(if (compare (cadr expr) (car (cddr expr))) (if (eq? (cadr expr) (car (cddr expr)))
(cadr (cddr expr)) (cadr (cddr expr))
(car (cddr (cddr expr)))))))) (car (cddr (cddr expr))))))))
@ -1108,10 +1108,10 @@
(if (and (symbol? (cadr expr)) (not (keyword? (cadr expr)))) (if (and (symbol? (cadr expr)) (not (keyword? (cadr expr))))
(car (cddr expr)) (car (cddr expr))
(cadr (cddr expr)))))) (cadr (cddr expr))))))
(define-syntax match-identifier=? (define-syntax match-bound-identifier=?
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
(if (compare (cadr expr) (car (cddr expr))) (if (eq? (cadr expr) (car (cddr expr)))
(cadr (cddr expr)) (cadr (cddr expr))
(car (cddr (cddr expr)))))))) (car (cddr (cddr expr))))))))
@ -1166,11 +1166,12 @@
;; This check is inlined in some cases above, but included here for ;; This check is inlined in some cases above, but included here for
;; the convenience of match-rewrite. ;; the convenience of match-rewrite.
(define-syntax match-identifier=? (define-syntax match-bound-identifier=?
(syntax-rules () (syntax-rules ()
((match-identifier=? a b sk fk) ((match-bound-identifier=? a b sk fk)
(let-syntax ((eq (syntax-rules (b) (let-syntax ((b (syntax-rules ())))
((eq b) sk) (let-syntax ((eq (syntax-rules (b)
((eq _) fk)))) ((eq b) sk)
(eq a))))) ((eq _) fk))))
(eq a))))))
)) ))