* 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

Binary file not shown.

View File

@ -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,9 +610,7 @@
(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
(unless (id? id) (stx-error e))
(let* ([lab (id->label id)] (let* ([lab (id->label id)]
[b (label->binding lab r)] [b (label->binding lab r)]
[type (binding-type b)]) [type (binding-type b)])
@ -630,7 +618,7 @@
(case type (case type
[($rtd) [($rtd)
(build-data no-source (binding-value b))] (build-data no-source (binding-value b))]
[else (stx-error e "invalid type")])))]))) [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))]
[else (stx-error e)])) ;;; FIXME: handle macro!
(stx-error e))]))) [else (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)]