Import Upstream version 2c3upstream/2c3

1 files changed, 17 insertions, 0 deletions

diff --git a/mwexpand.scm b/mwexpand.scm
index 10083a3..a53f0da 100644
--- a/mwexpand.scm
+++ b/mwexpand.scm
@@ -146,6 +146,8 @@
 	    ((eq? keyword mw:denote-of-let-syntax)    (mw:let-syntax exp env))
 	    ((eq? keyword mw:denote-of-letrec-syntax)
 	     (mw:letrec-syntax exp env))
+     ; @@ case has a nontrivial syntax also -- wdc
+     ((eq? keyword mw:denote-of-case)          (mw:case   exp env))
 	    ; @@ let, let*, letrec, paint within quasiquotation -- kend
 	    ((eq? keyword mw:denote-of-let)           (mw:let    exp env))
 	    ((eq? keyword mw:denote-of-let*)          (mw:let*   exp env))
@@ -394,6 +396,21 @@
     exp)
 )
 
+; CASE -- added by wdc
+(define (mw:case exp env)
+  (let ((expand (lambda (exp)
+                  (mw:expand exp env))))
+    (if (< (mw:safe-length exp) 3)
+        (mw:error "Malformed case expression" exp env)
+        `(case ,(expand (cadr exp))
+               ,@(map (lambda (clause)
+                        (if (< (mw:safe-length exp) 2)
+                            (mw:error "Malformed case clause" exp env)
+                            (cons (mw:strip (car clause))
+                                  (map expand (cdr clause)))))
+                      (cddr exp))))))
+
+
 ; LET
 (define (mw:let exp env)
   (let* ( (name (if (or (pair? (cadr exp)) (null? (cadr exp)))