From 0da4e99a12b73c6f3f66eabc576983ec9bb340c4 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Sat, 2 Aug 2008 11:09:22 -0700 Subject: [PATCH] simplified when, unless, and case macros and added better handler for (if (not e) e e). --- scheme/ikarus.compiler.source-optimizer.ss | 14 +++- scheme/last-revision | 2 +- scheme/makefile.ss | 6 +- scheme/psyntax.expander.ss | 87 ++++++++-------------- 4 files changed, 47 insertions(+), 62 deletions(-) diff --git a/scheme/ikarus.compiler.source-optimizer.ss b/scheme/ikarus.compiler.source-optimizer.ss index cf2907f..450771f 100644 --- a/scheme/ikarus.compiler.source-optimizer.ss +++ b/scheme/ikarus.compiler.source-optimizer.ss @@ -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)]) diff --git a/scheme/last-revision b/scheme/last-revision index a145571..7a0f242 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1565 +1566 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index b4fd617..973ffd6 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -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)] diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 1421ccc..013be17 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -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)