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

bug fix

This commit is contained in:
Yuito Murase 2014-04-02 01:16:56 +09:00
parent 62e887e89c
commit 7ad3782f3f
1 changed files with 7 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
piclib/syntax-rules.scm
View File

@ -54,11 +54,13 @@
(define _lambda (r 'lambda)) (define _lambda (r 'lambda))
(define _set! (r 'set!)) (define _set! (r 'set!))
(define _not (r 'not)) (define _not (r 'not))
(define _and (r 'and))
(define _car (r 'car)) (define _car (r 'car))
(define _cdr (r 'cdr)) (define _cdr (r 'cdr))
(define _cons (r 'cons)) (define _cons (r 'cons))
(define _pair? (r 'pair?)) (define _pair? (r 'pair?))
(define _null? (r 'null?)) (define _null? (r 'null?))
(define _symbol? (r 'symbol?))
(define _eqv? (r 'eqv?)) (define _eqv? (r 'eqv?))
(define _map (r 'map)) (define _map (r 'map))
(define _quote (r 'quote)) (define _quote (r 'quote))
@ -72,12 +74,12 @@
(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 ((eq? pattern '_) (values #f '())) (cond ((compare pattern (r '_)) (values #f '()))
((member pattern literals) ((member pattern literals)
(values (values
`(,_if (cmp ',pattern (rename expr)) `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern)))
(exit #f) #f
#f) (exit #f))
'())) '()))
((eq? pattern ellipsis) ((eq? pattern ellipsis)
(values `(,_syntax-error "invalid pattern") '())) (values `(,_syntax-error "invalid pattern") '()))
@ -119,7 +121,7 @@
(values (values
`(,_begin ,@(reverse matches) `(,_begin ,@(reverse matches)
(,_let ((expr (,_let loop ((a ()) (,_let ((expr (,_let loop ((a ())
(d expr)) (d ,accessor))
(,_if (,_pair? d) (,_if (,_pair? d)
(loop (,_cons (,_car d) a) (,_cdr d)) (loop (,_cons (,_car d) a) (,_cdr d))
(,_cons d a))))) (,_cons d a)))))