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

fix bug of matching symbol literal

This commit is contained in:
Yuito Murase 2014-04-03 01:49:23 +09:00
parent cb28c52e9b
commit cf8bf2c32b
1 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
piclib/syntax-rules.scm
View File

@ -78,13 +78,13 @@
(letrec ((compile-match-base (letrec ((compile-match-base
(lambda (pattern) (lambda (pattern)
(cond ((compare pattern (r '_)) (values #f '())) (cond ((compare pattern (r '_)) (values #f '()))
((member pattern literals) ((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))
'())) '()))
((eq? pattern ellipsis) ((compare pattern ellipsis)
(values `(,_syntax-error "invalid pattern") '())) (values `(,_syntax-error "invalid pattern") '()))
((symbol? pattern) ((symbol? pattern)
(values `(,_set! ,(var->sym pattern) expr) (list pattern))) (values `(,_set! ,(var->sym pattern) expr) (list pattern)))
@ -124,7 +124,7 @@
(exit #f))) (exit #f)))
(append vars (append vars1 vars2))))) (append vars (append vars1 vars2)))))
;; (hoge ... rest args) ;; (hoge ... rest args)
((eq? (cadr pattern) ellipsis) ((compare (cadr pattern) ellipsis)
(let-values (((match-r vars-r) (compile-match-list-reverse pattern))) (let-values (((match-r vars-r) (compile-match-list-reverse pattern)))
(values (values
`(,_begin ,@(reverse matches) `(,_begin ,@(reverse matches)
@ -152,7 +152,7 @@
(matches '()) (matches '())
(vars '()) (vars '())
(accessor 'expr)) (accessor 'expr))
(cond ((eq? (car pattern) ellipsis) (cond ((compare (car pattern) ellipsis)
(let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern))))
(values (values
`(,_begin ,@(reverse matches) `(,_begin ,@(reverse matches)
@ -201,7 +201,7 @@
(define (compile-expand ellipsis reserved template) (define (compile-expand ellipsis reserved template)
(letrec ((compile-expand-base (letrec ((compile-expand-base
(lambda (template ellipsis-valid) (lambda (template ellipsis-valid)
(cond ((member template reserved) (cond ((member template reserved compare)
(values (var->sym template) (list template))) (values (var->sym template) (list template)))
((symbol? template) ((symbol? template)
(values `(rename ',template) '())) (values `(rename ',template) '()))
@ -220,7 +220,7 @@
(cond ;; (... hoge) (cond ;; (... hoge)
((and ellipsis-valid ((and ellipsis-valid
(pair? template) (pair? template)
(eq? (car template) ellipsis)) (compare (car template) ellipsis))
(if (and (pair? (cdr template)) (null? (cddr template))) (if (and (pair? (cdr template)) (null? (cddr template)))
(compile-expand-base (cadr template) #f) (compile-expand-base (cadr template) #f)
(values '(,_syntax-error "invalid template") '()))) (values '(,_syntax-error "invalid template") '())))
@ -234,7 +234,7 @@
;; (a ... rest syms) ;; (a ... rest syms)
((and ellipsis-valid ((and ellipsis-valid
(pair? (cdr template)) (pair? (cdr template))
(eq? (cadr template) ellipsis)) (compare (cadr template) ellipsis))
(let-values (((expand1 vars1) (let-values (((expand1 vars1)
(compile-expand-base (car template) ellipsis-valid))) (compile-expand-base (car template) ellipsis-valid)))
(loop (cddr template) (loop (cddr template)
@ -280,7 +280,7 @@
(define (expand-clauses clauses rename) (define (expand-clauses clauses rename)
(cond ((null? clauses) (cond ((null? clauses)
`(,_quote (syntax-error "no matching pattern"))) `(,_quote (syntax-error "no matching pattern")))
((eq? (car clauses) 'mismatch) ((compare (car clauses) 'mismatch)
`(,_syntax-error "invalid rule")) `(,_syntax-error "invalid rule"))
(else (else
(let ((vars (car (car clauses))) (let ((vars (car (car clauses)))