simplified when, unless, and case macros and added better handler

for (if (not e) e e).

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)])

scheme/last-revision

@@ -1 +1 @@
-1565
+1566

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)]

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
+  (define when-macro
-    (lambda (e r mr)
+    (lambda (e)
       (syntax-match e ()
-        ((_ test e e* ...)
+        [(_ test e e* ...)
-         (build-conditional no-source
+         (bless `(if ,test (begin ,e . ,e*)))])))
-           (chi-expr test r mr)
-           (build-sequence no-source
-             (chi-expr* (cons e e*) r mr))
-           (build-void))))))
 
-  (define unless-transformer ;;; go away
+  (define unless-macro
-    (lambda (e r mr)
+    (lambda (e)
       (syntax-match e ()
-        ((_ test e e* ...)
+        [(_ test e e* ...)
-         (build-conditional no-source
+         (bless `(if (not ,test) (begin ,e . ,e*)))])))
-           (chi-expr test r mr)
+
-           (build-void)
-           (build-sequence no-source
-             (chi-expr* (cons e e*) r mr)))))))
-  
   (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
+  (define case-macro
-    (lambda (e r mr)
+    (lambda (e)
-      (define build-one
+      (define (build-last cls)
-        (lambda (t cls rest)
+        (syntax-match cls (else)
-          (syntax-match cls ()
+          [(else e e* ...) `(begin ,e . ,e*)]
-            (((d* ...) e e* ...)
+          [_ (build-one cls '(if #f #f))]))
-             (build-conditional no-source
+      (define (build-one cls k)
-               (build-application no-source
+        (syntax-match cls ()
-                 (build-primref no-source 'memv)
+          [((d* ...) e e* ...) 
-                 (list t (build-data no-source (stx->datum d*))))
+           `(if (memv t ',d*) (begin ,e . ,e*) ,k)]))
-               (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)))))
       (syntax-match e ()
         ((_ expr)
-         (build-sequence no-source
+         (bless `(let ([t ,expr]) (if #f #f))))
-           (list (chi-expr expr r mr) (build-void))))
         ((_ expr cls cls* ...)
-         (let ((t (gen-lexical 't)))
+         (bless 
-           (build-let no-source
+           `(let ([t ,expr])
-              (list t) (list (chi-expr expr r mr))
+              ,(let f ([cls cls] [cls* cls*])
-              (let f ((cls cls) (cls* cls*))
+                 (if (null? cls*) 
-                (cond
+                     (build-last cls)
-                  ((null? cls*) (build-last t cls))
+                     (build-one cls (f (car cls*) (cdr cls*)))))))))))
-                  (else
+
-                   (build-one t 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)