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

* in syntax-match, _ now matches anything and does not bind a 

variable.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 05:15:30 -04:00
parent 1355665e55
commit 9bcfbf0664
2 changed files with 19 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

29
src/ikarus.syntax.ss
View File

@ -425,14 +425,17 @@
(define (parse-pat pat) (define (parse-pat pat)
(syntax-case pat () (syntax-case pat ()
[id (sys:identifier? #'id) [id (sys:identifier? #'id)
(if (free-identifier-member? #'id lits) (cond
(values '() [(free-identifier-member? #'id lits)
#'(lambda (x) (values '()
(if (and (id? x) (free-id=? x (scheme-stx 'id))) #'(lambda (x)
'() (and (id? x)
#f))) (free-id=? x (scheme-stx 'id))
(values (list #'id) '())))]
#'(lambda (x) (list x))))] [(sys:free-identifier=? #'id #'_)
(values '() #'(lambda (x) '()))]
[else
(values (list #'id) #'(lambda (x) (list x)))])]
[(pat dots) (dots? #'dots) [(pat dots) (dots? #'dots)
(let-values ([(pvars decon) (parse-pat #'pat)]) (let-values ([(pvars decon) (parse-pat #'pat)])
(with-syntax ([(v* ...) pvars] [decon decon]) (with-syntax ([(v* ...) pvars] [decon decon])
@ -502,6 +505,12 @@
(with-syntax ([(v* ...) pvars]) (with-syntax ([(v* ...) pvars])
(values decon (values decon
#'(lambda (v* ...) #t) #'(lambda (v* ...) #t)
#'(lambda (v* ...) body))))]
[(pat guard body)
(let-values ([(pvars decon) (parse-pat #'pat)])
(with-syntax ([(v* ...) pvars])
(values decon
#'(lambda (v* ...) guard)
#'(lambda (v* ...) body))))])) #'(lambda (v* ...) body))))]))
(syntax-case ctx () (syntax-case ctx ()
[(_ expr (lits ...)) (andmap sys:identifier? #'(lits ...)) [(_ expr (lits ...)) (andmap sys:identifier? #'(lits ...))
@ -520,12 +529,12 @@
(define parse-define (define parse-define
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()
[(__ (id . fmls) b b* ...) [(_ (id . fmls) b b* ...)
(if (id? id) (if (id? id)
(values id (values id
(cons 'defun (cons fmls (cons b b*)))) (cons 'defun (cons fmls (cons b b*))))
(stx-error x))] (stx-error x))]
[(__ id val) [(_ id val)
(if (id? id) (if (id? id)
(values id (cons 'expr val)) (values id (cons 'expr val))
(stx-error x))]))) (stx-error x))])))