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

* made better use of the new guard ability of syntax-match

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 05:31:04 -04:00
parent 9bcfbf0664
commit 0f5fbd6380
2 changed files with 44 additions and 55 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.

99
src/ikarus.syntax.ss
View File

@ -430,9 +430,9 @@
(values '() (values '()
#'(lambda (x) #'(lambda (x)
(and (id? x) (and (id? x)
(free-id=? x (scheme-stx 'id)) (free-id=? x (scheme-stx 'id))
'())))] '())))]
[(sys:free-identifier=? #'id #'_) [(sys:free-identifier=? #'id #'_)
(values '() #'(lambda (x) '()))] (values '() #'(lambda (x) '()))]
[else [else
(values (list #'id) #'(lambda (x) (list x)))])] (values (list #'id) #'(lambda (x) (list x)))])]
@ -518,9 +518,7 @@
[(_ expr (lits ...) cls cls* ...) (andmap sys:identifier? #'(lits ...)) [(_ expr (lits ...) cls cls* ...) (andmap sys:identifier? #'(lits ...))
(let-values ([(decon guard body) (let-values ([(decon guard body)
(parse-clause #'(lits ...) #'cls)]) (parse-clause #'(lits ...) #'cls)])
(with-syntax ([decon decon] (with-syntax ([decon decon] [guard guard] [body body])
[guard guard]
[body body])
#'(let ([t expr]) #'(let ([t expr])
(let ([ls/false (decon t)]) (let ([ls/false (decon t)])
(if (and ls/false (apply guard ls/false)) (if (and ls/false (apply guard ls/false))
@ -529,22 +527,14 @@
(define parse-define (define parse-define
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()
[(_ (id . fmls) b b* ...) [(_ (id . fmls) b b* ...) (id? id)
(if (id? id) (values id (cons 'defun (cons fmls (cons b b*))))]
(values id [(_ id val) (id? id)
(cons 'defun (cons fmls (cons b b*)))) (values id (cons 'expr val))])))
(stx-error x))]
[(_ id val)
(if (id? id)
(values id (cons 'expr val))
(stx-error x))])))
(define parse-define-syntax (define parse-define-syntax
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()
[(_ id val) [(_ id val) (id? id) (values id val)])))
(if (id? id)
(values id val)
(stx-error x))])))
(define scheme-stx (define scheme-stx
(lambda (sym) (lambda (sym)
(let ([subst (let ([subst
@ -602,7 +592,7 @@
(syntax-match e () (syntax-match e ()
[(_ ([lhs* rhs*] ...) b b* ...) [(_ ([lhs* rhs*] ...) b b* ...)
(if (not (valid-bound-ids? lhs*)) (if (not (valid-bound-ids? lhs*))
(stx-error e) (stx-error e "duplicate identifiers")
(let ([lex* (map gen-lexical lhs*)] (let ([lex* (map gen-lexical lhs*)]
[lab* (map gen-label lhs*)]) [lab* (map gen-label lhs*)])
(let ([rib (make-full-rib lhs* lab*)] (let ([rib (make-full-rib lhs* lab*)]
@ -620,17 +610,15 @@
(define type-descriptor-transformer (define type-descriptor-transformer
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
[(_ id) [(_ id) (id? id)
(begin (let* ([lab (id->label id)]
(unless (id? id) (stx-error e)) [b (label->binding lab r)]
(let* ([lab (id->label id)] [type (binding-type b)])
[b (label->binding lab r)] (unless lab (stx-error e "unbound identifier"))
[type (binding-type b)]) (case type
(unless lab (stx-error e "unbound identifier")) [($rtd)
(case type (build-data no-source (binding-value b))]
[($rtd) [else (stx-error e "invalid type")]))])))
(build-data no-source (binding-value b))]
[else (stx-error e "invalid type")])))])))
(define when-transformer ;;; go away (define when-transformer ;;; go away
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
@ -744,23 +732,21 @@
[(_ ([lhs* rhs*] ...) b b* ...) [(_ ([lhs* rhs*] ...) b b* ...)
(if (valid-bound-ids? lhs*) (if (valid-bound-ids? lhs*)
(bless `((lambda ,lhs* ,b . ,b*) . ,rhs*)) (bless `((lambda ,lhs* ,b . ,b*) . ,rhs*))
(stx-error stx "invalid syntax"))] (stx-error stx "duplicate bindings"))]
[(_ f ([lhs* rhs*] ...) b b* ...) [(_ f ([lhs* rhs*] ...) b b* ...) (id? f)
(if (and (id? f) (valid-bound-ids? lhs*)) (if (valid-bound-ids? lhs*)
(bless `(letrec ([,f (lambda ,lhs* ,b . ,b*)]) (bless `(letrec ([,f (lambda ,lhs* ,b . ,b*)])
(,f . ,rhs*))) (,f . ,rhs*)))
(stx-error stx "invalid syntax"))]))) (stx-error stx "invalid syntax"))])))
(define let*-macro (define let*-macro
(lambda (stx) (lambda (stx)
(syntax-match stx () (syntax-match stx ()
[(_ ([lhs* rhs*] ...) b b* ...) [(_ ([lhs* rhs*] ...) b b* ...) (andmap id? lhs*)
(if (andmap id? lhs*) (bless
(bless (let f ([x* (map list lhs* rhs*)])
(let f ([x* (map list lhs* rhs*)]) (cond
(cond [(null? x*) `(let () ,b . ,b*)]
[(null? x*) `(let () ,b . ,b*)] [else `(let (,(car x*)) ,(f (cdr x*)))])))])))
[else `(let (,(car x*)) ,(f (cdr x*)))])))
(stx-error stx "invalid bindings"))])))
(define or-macro (define or-macro
(lambda (stx) (lambda (stx)
(syntax-match stx () (syntax-match stx ()
@ -1346,7 +1332,7 @@
[(_ expr (keys ...) clauses ...) [(_ expr (keys ...) clauses ...)
(begin (begin
(unless (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) keys) (unless (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) keys)
(stx-error e)) (stx-error e "invalid literals"))
(let ((x (gen-lexical 'tmp))) (let ((x (gen-lexical 'tmp)))
(let ([body (gen-syntax-case x keys clauses r mr)]) (let ([body (gen-syntax-case x keys clauses r mr)])
(build-application no-source (build-application no-source
@ -1633,16 +1619,15 @@
(define chi-set! (define chi-set!
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
[(_ x v) [(_ x v) (id? x)
(if (id? x) (let-values ([(type value kwd) (syntax-type x r)])
(let-values ([(type value kwd) (syntax-type x r)]) (case type
(case type [(lexical)
[(lexical) (build-lexical-assignment no-source
(build-lexical-assignment no-source value
value (chi-expr v r mr))]
(chi-expr v r mr))] ;;; FIXME: handle macro!
[else (stx-error e)])) [else (stx-error e)]))])))
(stx-error e))])))
(define chi-lambda-clause (define chi-lambda-clause
(lambda (fmls body* r mr) (lambda (fmls body* r mr)
(syntax-match fmls () (syntax-match fmls ()
@ -1753,11 +1738,15 @@
(syntax-match e () (syntax-match e ()
[(_ (export* ...) b* ...) [(_ (export* ...) b* ...)
(begin (begin
(unless (andmap id? export*) (stx-error e)) (unless (andmap id? export*)
(stx-error e "module exports must be identifiers"))
(values #f export* b*))] (values #f export* b*))]
[(_ name (export* ...) b* ...) [(_ name (export* ...) b* ...)
(begin (begin
(unless (and (id? name) (andmap id? export*)) (stx-error e)) (unless (id? name)
(stx-error e "module name must be an identifier"))
(unless (andmap id? export*)
(stx-error e "module exports must be identifiers"))
(values name export* b*))]))) (values name export* b*))])))
(let-values ([(name exp-id* e*) (parse-module e)]) (let-values ([(name exp-id* e*) (parse-module e)])
(let* ([rib (make-empty-rib)] (let* ([rib (make-empty-rib)]