conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #186 from zeptometer/fix-syntax-rules 

fix bugs in syntax-rules
This commit is contained in:
Yuichi Nishiwaki 2014-08-06 23:08:55 +09:00
parent b0c9c468c0 a35dd8463c
commit f4aceb1c2a
1 changed files with 12 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
piclib/scheme/base.scm
View File

@ -383,6 +383,7 @@
(define _pair? (r 'pair?)) (define _pair? (r 'pair?))
(define _null? (r 'null?)) (define _null? (r 'null?))
(define _symbol? (r 'symbol?)) (define _symbol? (r 'symbol?))
(define _vector? (r 'vector?))
(define _eqv? (r 'eqv?)) (define _eqv? (r 'eqv?))
(define _string=? (r 'string=?)) (define _string=? (r 'string=?))
(define _map (r 'map)) (define _map (r 'map))
@ -409,13 +410,13 @@
(define (compile-match ellipsis literals pattern) (define (compile-match ellipsis literals pattern)
(letrec ((compile-match-base (letrec ((compile-match-base
(lambda (pattern) (lambda (pattern)
(cond ((compare pattern (r '_)) (values #f '())) (cond ((member pattern literals compare)
((member pattern literals compare)
(values (values
`(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
#f #f
(exit #f)) (exit #f))
'())) '()))
((compare pattern (r '_)) (values #f '()))
((and ellipsis (compare pattern ellipsis)) ((and ellipsis (compare pattern ellipsis))
(values `(,_syntax-error "invalid pattern") '())) (values `(,_syntax-error "invalid pattern") '()))
((symbol? pattern) ((symbol? pattern)
@ -517,10 +518,12 @@
(compile-match-vector (compile-match-vector
(lambda (pattern) (lambda (pattern)
(let-values (((match vars) (compile-match-list (vector->list pattern)))) (let-values (((match vars) (compile-match-base (vector->list pattern))))
(values (values
`(,_let ((expr (,_vector->list expr))) `(,_if (,_vector? expr)
(,_let ((expr (,_vector->list expr)))
,match) ,match)
(exit #f))
vars))))) vars)))))
(let-values (((match vars) (compile-match-base (cdr pattern)))) (let-values (((match vars) (compile-match-base (cdr pattern))))
@ -588,9 +591,10 @@
(compile-expand-vector (compile-expand-vector
(lambda (template ellipsis-valid) (lambda (template ellipsis-valid)
(let-values (((expand1 vars1) (let-values (((expand1 vars1)
(compile-expand-list (vector->list template) ellipsis-valid))) (compile-expand-base (vector->list template) ellipsis-valid)))
(values
`(,_list->vector ,expand1) `(,_list->vector ,expand1)
vars1)))) vars1)))))
(compile-expand-base template ellipsis))) (compile-expand-base template ellipsis)))