simplified when, unless, and case macros and added better handler
for (if (not e) e e).
This commit is contained in:
Abdulaziz Ghuloum
parent
39e84d1395
commit
0da4e99a12
|
|
@ -707,6 +707,18 @@
|
|||
(set-prelex-residual-referenced?! x #t)
|
||||
x)
|
||||
;;;
|
||||
(define (build-conditional e0 e1 e2)
|
||||
(or (struct-case e0
|
||||
[(funcall rator rand*)
|
||||
(struct-case rator
|
||||
[(primref op)
|
||||
(and (eq? op 'not)
|
||||
(= (length rand*) 1)
|
||||
(build-conditional (car rand*) e2 e1))]
|
||||
[else #f])]
|
||||
[else #f])
|
||||
(make-conditional e0 e1 e2)))
|
||||
|
||||
(define (E x ctxt env ec sc)
|
||||
(decrement ec 1)
|
||||
(struct-case x
|
||||
|
|
@ -727,7 +739,7 @@
|
|||
(mkseq e0 e1)
|
||||
(begin
|
||||
(decrement sc 1)
|
||||
(make-conditional e0 e1 e2)))))]))]
|
||||
(build-conditional e0 e1 e2)))))]))]
|
||||
[(assign x v)
|
||||
(mkseq
|
||||
(let ([x (lookup x env)])
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1565
|
||||
1566
|
||||
|
|
|
|||
|
|
@ -128,15 +128,13 @@
|
|||
[letrec (core-macro . letrec)]
|
||||
[letrec* (core-macro . letrec*)]
|
||||
[if (core-macro . if)]
|
||||
[when (core-macro . when)]
|
||||
[unless (core-macro . unless)]
|
||||
[case (core-macro . case)]
|
||||
[fluid-let-syntax (core-macro . fluid-let-syntax)]
|
||||
[record-type-descriptor (core-macro . record-type-descriptor)]
|
||||
[record-constructor-descriptor (core-macro . record-constructor-descriptor)]
|
||||
[let-values (macro . let-values)]
|
||||
[let*-values (macro . let*-values)]
|
||||
[define-struct (macro . define-struct)]
|
||||
[case (macro . case)]
|
||||
[include (macro . include)]
|
||||
[include-into (macro . include-into)]
|
||||
[syntax-rules (macro . syntax-rules)]
|
||||
|
|
@ -145,6 +143,8 @@
|
|||
[with-syntax (macro . with-syntax)]
|
||||
[identifier-syntax (macro . identifier-syntax)]
|
||||
[parameterize (macro . parameterize)]
|
||||
[when (macro . when)]
|
||||
[unless (macro . unless)]
|
||||
[let (macro . let)]
|
||||
[let* (macro . let*)]
|
||||
[cond (macro . cond)]
|
||||
|
|
|
|||
|
|
@ -990,26 +990,18 @@
|
|||
(stx-error e "invalid type"))
|
||||
(chi-expr (cadr (binding-value b)) r mr))))))
|
||||
|
||||
(define when-transformer ;;; go away
|
||||
(lambda (e r mr)
|
||||
(define when-macro
|
||||
(lambda (e)
|
||||
(syntax-match e ()
|
||||
((_ test e e* ...)
|
||||
(build-conditional no-source
|
||||
(chi-expr test r mr)
|
||||
(build-sequence no-source
|
||||
(chi-expr* (cons e e*) r mr))
|
||||
(build-void))))))
|
||||
[(_ test e e* ...)
|
||||
(bless `(if ,test (begin ,e . ,e*)))])))
|
||||
|
||||
(define unless-transformer ;;; go away
|
||||
(lambda (e r mr)
|
||||
(define unless-macro
|
||||
(lambda (e)
|
||||
(syntax-match e ()
|
||||
((_ test e e* ...)
|
||||
(build-conditional no-source
|
||||
(chi-expr test r mr)
|
||||
(build-void)
|
||||
(build-sequence no-source
|
||||
(chi-expr* (cons e e*) r mr)))))))
|
||||
|
||||
[(_ test e e* ...)
|
||||
(bless `(if (not ,test) (begin ,e . ,e*)))])))
|
||||
|
||||
(define if-transformer
|
||||
(lambda (e r mr)
|
||||
(syntax-match e ()
|
||||
|
|
@ -1024,46 +1016,27 @@
|
|||
(chi-expr e1 r mr)
|
||||
(build-void))))))
|
||||
|
||||
(define case-transformer ;;; go away
|
||||
(lambda (e r mr)
|
||||
(define build-one
|
||||
(lambda (t cls rest)
|
||||
(syntax-match cls ()
|
||||
(((d* ...) e e* ...)
|
||||
(build-conditional no-source
|
||||
(build-application no-source
|
||||
(build-primref no-source 'memv)
|
||||
(list t (build-data no-source (stx->datum d*))))
|
||||
(build-sequence no-source
|
||||
(chi-expr* (cons e e*) r mr))
|
||||
rest))
|
||||
(else (stx-error e)))))
|
||||
(define build-last
|
||||
(lambda (t cls)
|
||||
(syntax-match cls ()
|
||||
(((d* ...) e e* ...)
|
||||
(build-one t cls (build-void)))
|
||||
((else-kwd x x* ...)
|
||||
(if (and (id? else-kwd)
|
||||
(free-id=? else-kwd (scheme-stx 'else)))
|
||||
(build-sequence no-source
|
||||
(chi-expr* (cons x x*) r mr))
|
||||
(stx-error e)))
|
||||
(else (stx-error e)))))
|
||||
(define case-macro
|
||||
(lambda (e)
|
||||
(define (build-last cls)
|
||||
(syntax-match cls (else)
|
||||
[(else e e* ...) `(begin ,e . ,e*)]
|
||||
[_ (build-one cls '(if #f #f))]))
|
||||
(define (build-one cls k)
|
||||
(syntax-match cls ()
|
||||
[((d* ...) e e* ...)
|
||||
`(if (memv t ',d*) (begin ,e . ,e*) ,k)]))
|
||||
(syntax-match e ()
|
||||
((_ expr)
|
||||
(build-sequence no-source
|
||||
(list (chi-expr expr r mr) (build-void))))
|
||||
(bless `(let ([t ,expr]) (if #f #f))))
|
||||
((_ expr cls cls* ...)
|
||||
(let ((t (gen-lexical 't)))
|
||||
(build-let no-source
|
||||
(list t) (list (chi-expr expr r mr))
|
||||
(let f ((cls cls) (cls* cls*))
|
||||
(cond
|
||||
((null? cls*) (build-last t cls))
|
||||
(else
|
||||
(build-one t cls
|
||||
(f (car cls*) (cdr cls*))))))))))))
|
||||
(bless
|
||||
`(let ([t ,expr])
|
||||
,(let f ([cls cls] [cls* cls*])
|
||||
(if (null? cls*)
|
||||
(build-last cls)
|
||||
(build-one cls (f (car cls*) (cdr cls*)))))))))))
|
||||
|
||||
|
||||
(define quote-transformer
|
||||
(lambda (e r mr)
|
||||
|
|
@ -2580,10 +2553,7 @@
|
|||
((case-lambda) case-lambda-transformer)
|
||||
((letrec) letrec-transformer)
|
||||
((letrec*) letrec*-transformer)
|
||||
((case) case-transformer)
|
||||
((if) if-transformer)
|
||||
((when) when-transformer)
|
||||
((unless) unless-transformer)
|
||||
((foreign-call) foreign-call-transformer)
|
||||
((syntax-case) syntax-case-transformer)
|
||||
((syntax) syntax-transformer)
|
||||
|
|
@ -2633,6 +2603,9 @@
|
|||
((quasiquote) quasiquote-macro)
|
||||
((quasisyntax) quasisyntax-macro)
|
||||
((with-syntax) with-syntax-macro)
|
||||
((when) when-macro)
|
||||
((unless) unless-macro)
|
||||
((case) case-macro)
|
||||
((identifier-syntax) identifier-syntax-macro)
|
||||
((time) time-macro)
|
||||
((delay) delay-macro)
|
||||
|
|
|
|||
Loading…
Reference in New Issue