stage2.patch

--- psyntax-patched.scm
+++ psyntax-patched.scm
@@ -138,12 +138,12 @@
 (eval-when (compile)
   (set-current-module (resolve-module '(guile))))
 
-(let ((syntax? (module-ref (current-module) 'syntax?))
-      (make-syntax (module-ref (current-module) 'make-syntax))
-      (syntax-expression (module-ref (current-module) 'syntax-expression))
-      (syntax-wrap (module-ref (current-module) 'syntax-wrap))
-      (syntax-module (module-ref (current-module) 'syntax-module))
-      (syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
+(define syntax? (module-ref (current-module) 'syntax?))
+(define make-syntax (module-ref (current-module) 'make-syntax))
+(define syntax-expression (module-ref (current-module) 'syntax-expression))
+(define syntax-wrap (module-ref (current-module) 'syntax-wrap))
+(define syntax-module (module-ref (current-module) 'syntax-module))
+(define syntax-sourcev (module-ref (current-module) 'syntax-sourcev))
 
   (define-syntax define-expansion-constructors
     (lambda (x)
@@ -194,6 +194,7 @@
 
   (define-syntax define-structure
     (lambda (x)
+     (s5*-letrec-defines () 
       (define construct-name
         (lambda (template-identifier . args)
           (datum->syntax
@@ -241,9 +242,9 @@
                (define assign
                  (lambda (x update)
                    (vector-set! x index update)))
-               ...))))))
+               ...)))))))
 
-  (let ()
+;;  (let ()
     (define-expansion-constructors)
     (define-expansion-accessors lambda meta)
 
@@ -272,11 +273,12 @@
     (define (sourcev-line s) (vector-ref s 1))
     (define (sourcev-column s) (vector-ref s 2))
     (define (sourcev->alist sourcev)
+     (s5*-letrec-defines ()
       (define (maybe-acons k v tail) (if v (acons k v tail) tail))
       (and sourcev
            (maybe-acons 'filename (sourcev-filename sourcev)
                         `((line . ,(sourcev-line sourcev))
-                          (column . ,(sourcev-column sourcev))))))
+                          (column . ,(sourcev-column sourcev)))))))
 
     (define (decorate-source e s)
       (when (and s (supports-source-properties? e))
@@ -702,6 +704,8 @@
                  (eq? (car x) (car y))
                  (same-marks? (cdr x) (cdr y))))))
 
+    (define-syntax-rule (id-var-name-first e) e)
+    
     (define id-var-name
       ;; Syntax objects use wraps to associate names with marked
       ;; identifiers.  This function returns the name corresponding to
@@ -728,9 +732,7 @@
       ;; a string label.
       ;;
       (lambda (id w mod)
-        (define-syntax-rule (first e)
-          ;; Rely on Guile's multiple-values truncation.
-          e)
+        (s5*-letrec-defines () 
         (define search
           (lambda (sym subst marks mod)
             (if (null? subst)
@@ -773,7 +775,7 @@
                  (else (f (fx+ i 1))))))))
         (cond
          ((symbol? id)
-          (or (first (search id (wrap-subst w) (wrap-marks w) mod)) id))
+          (or (id-var-name-first (search id (wrap-subst w) (wrap-marks w) mod)) id))
          ((syntax? id)
           (let ((id (syntax-expression id))
                 (w1 (syntax-wrap id))
@@ -782,9 +784,9 @@
               (call-with-values (lambda () (search id (wrap-subst w) marks mod))
                 (lambda (new-id marks)
                   (or new-id
-                      (first (search id (wrap-subst w1) marks mod))
+                      (id-var-name-first (search id (wrap-subst w1) marks mod))
                       id))))))
-         (else (syntax-violation 'id-var-name "invalid id" id)))))
+         (else (syntax-violation 'id-var-name "invalid id" id))))))
 
     ;; A helper procedure for syntax-locally-bound-identifiers, which
     ;; itself is a helper for transformer procedures.
@@ -800,6 +802,7 @@
     ;;
     (define locally-bound-identifiers
       (lambda (w mod)
+       (s5*-letrec-defines ()
         (define scan
           (lambda (subst results)
             (if (null? subst)
@@ -833,11 +836,12 @@
                                    (anti-mark (make-wrap (vector-ref marks i) subst))
                                    mod)
                              results)))))))
-        (scan (wrap-subst w) '())))
+        (scan (wrap-subst w) '()))))
 
     ;; Returns three values: binding type, binding value, and the module
     ;; (for resolving toplevel vars).
     (define (resolve-identifier id w r mod resolve-syntax-parameters?)
+     (s5*-letrec-defines ()
       (define (resolve-global var mod)
         (when (and (not mod) (current-module))
           (warn "module system is booted, we should have a module" var))
@@ -930,7 +934,7 @@
                                       (syntax-module id))
                                  mod)))
          (else
-          (error "unexpected id-var-name" id w n)))))
+          (error "unexpected id-var-name" id w n))))))
 
     (define transformer-environment
       (make-fluid
@@ -949,6 +953,7 @@
                (mj (and (syntax? j) (syntax-module j)))
                (ni (id-var-name i empty-wrap mi))
                (nj (id-var-name j empty-wrap mj)))
+         (s5*-letrec-defines ()
           (define (id-module-binding id mod)
             (module-variable
              (if mod
@@ -976,7 +981,7 @@
            (else
             ;; Otherwise `i' is bound, so check that `j' is bound, and
             ;; bound to the same thing.
-            (equal? ni nj))))))
+            (equal? ni nj)))))))
     
     ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
     ;; long as the missing portion of the wrap is common to both of the ids
@@ -1075,6 +1080,7 @@
         (let* ((r (cons '("placeholder" . (placeholder)) r))
                (ribcage (make-empty-ribcage))
                (w (make-wrap (wrap-marks w) (cons ribcage (wrap-subst w)))))
+         (s5*-letrec-defines ()
           (define (record-definition! id var)
             (let ((mod (cons 'hygiene (module-name (current-module)))))
               ;; Ribcages map symbol+marks to names, mostly for
@@ -1108,6 +1114,7 @@
                       (append (parse1 (car body) r w s m esew mod)
                               exps)))))
           (define (parse1 x r w s m esew mod)
+           (s5*-letrec-defines ()
             (define (current-module-for-expansion mod)
               (case (car mod)
                 ;; If the module was just put in place for hygiene, in a
@@ -1188,6 +1195,7 @@
                      ((_ (x ...) e1 e2 ...)
                       (let ((when-list (parse-when-list e #'(x ...)))
                             (body #'(e1 e2 ...)))
+                       (s5*-letrec-defines ()
                         (define (recurse m esew)
                           (parse body r w s m esew mod))
                         (cond
@@ -1217,7 +1225,7 @@
                            mod)
                           '())
                          (else
-                          '()))))))
+                          '())))))))
                   (else
                    (list
                     (if (eq? m 'c&e)
@@ -1225,12 +1233,12 @@
                           (top-level-eval-hook x mod)
                           (lambda () x))
                         (lambda ()
-                          (expand-expr type value form e r w s mod)))))))))
+                          (expand-expr type value form e r w s mod))))))))))
           (let ((exps (map (lambda (x) (x))
                            (reverse (parse body r w s m esew mod)))))
             (if (null? exps)
                 (build-void s)
-                (build-sequence s exps))))))
+                (build-sequence s exps)))))))
     
     (define expand-install-global
       (lambda (mod name type e)
@@ -1513,6 +1521,7 @@
     ;; possible.
     (define expand-macro
       (lambda (p e r w s rib mod)
+       (s5*-letrec-defines ()
         (define rebuild-macro-output
           (lambda (x m)
             (cond ((pair? x)
@@ -1544,18 +1553,21 @@
                   ((vector? x)
                    (let* ((n (vector-length x))
                           (v (decorate-source (make-vector n) s)))
-                     (do ((i 0 (fx+ i 1)))
-                         ((fx= i n) v)
-                       (vector-set! v i
-                                    (rebuild-macro-output (vector-ref x i) m)))))
+                     (let ldo ((i 0))
+                        (if (fx= i n) 
+                            v
+                            (begin
+                              (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
+                              (ldo (fx+ i 1)))))))
                   ((symbol? x)
                    (syntax-violation #f "encountered raw symbol in macro output"
                                      (source-wrap e w (wrap-subst w) mod) x))
                   (else (decorate-source x s)))))
-        (with-fluids ((transformer-environment
-                       (lambda (k) (k e r w s rib mod))))
-          (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
-                                (new-mark)))))
+        (with-fluid* transformer-environment
+                     (lambda (k) (k e r w s rib mod))
+                     (lambda ()
+                       (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
+                                             (new-mark)))))))
 
     (define expand-body
       ;; In processing the forms of the body, we create a new, empty wrap.
@@ -1785,6 +1797,7 @@
 
     (define lambda-formals
       (lambda (orig-args)
+       (s5*-letrec-defines ()
         (define (req args rreq)
           (syntax-case args ()
             (()
@@ -1802,7 +1815,7 @@
            (else
             (syntax-violation 'lambda "duplicate identifier in argument list"
                               orig-args))))
-        (req orig-args '())))
+        (req orig-args '()))))
 
     (define expand-simple-lambda
       (lambda (e r w s mod req rest meta body)
@@ -1820,6 +1833,7 @@
 
     (define lambda*-formals
       (lambda (orig-args)
+       (s5*-letrec-defines ()
         (define (req args rreq)
           (syntax-case args ()
             (()
@@ -1897,10 +1911,11 @@
            (else
             (syntax-violation 'lambda* "duplicate identifier in argument list"
                               orig-args))))
-        (req orig-args '())))
+        (req orig-args '()))))
 
     (define expand-lambda-case
       (lambda (e r w s mod get-formals clauses)
+       (s5*-letrec-defines ()
         (define (parse-req req opt rest kw body)
           (let ((vars (map gen-var req))
                 (labels (gen-labels req)))
@@ -1988,13 +2003,14 @@
                        (values
                         (append meta meta*)
                         (build-lambda-case s req opt rest kw inits vars
-                                           body else*))))))))))))
+                                           body else*)))))))))))))
 
     ;; data
 
     ;; strips syntax objects, recursively.
 
     (define (strip x)
+     (s5*-letrec-defines ()
       (define (annotate proc datum)
         (decorate-source datum (proc x)))
       (cond
@@ -2004,7 +2020,7 @@
         (annotate datum-sourcev (cons (strip (car x)) (strip (cdr x)))))
        ((vector? x)
         (annotate datum-sourcev (list->vector (strip (vector->list x)))))
-       (else x)))
+       (else x))))
 
     ;; lexical variables
 
@@ -2087,8 +2103,7 @@
                        ((_ e) (build-data s #'e))
                        (e (syntax-violation 'quote "bad syntax" #'e)))))
 
-    (global-extend
-     'core 'syntax
+    (define *next*-syntax
      (let ()
        (define gen-syntax
          (lambda (src e r maps ellipsis? mod)
@@ -2282,6 +2297,7 @@
 
     (global-extend 'core 'case-lambda
                    (lambda (e r w s mod)
+                    (s5*-letrec-defines ()
                      (define (build-it meta clauses)
                        (call-with-values
                            (lambda ()
@@ -2298,10 +2314,11 @@
                         (build-it `((documentation
                                      . ,(syntax->datum #'docstring)))
                                   #'((args e1 e2 ...) ...)))
-                       (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
+                       (_ (syntax-violation 'case-lambda "bad case-lambda" e))))))
 
     (global-extend 'core 'case-lambda*
                    (lambda (e r w s mod)
+                     (s5*-letrec-defines ()
                      (define (build-it meta clauses)
                        (call-with-values
                            (lambda ()
@@ -2318,7 +2335,7 @@
                         (build-it `((documentation
                                      . ,(syntax->datum #'docstring)))
                                   #'((args e1 e2 ...) ...)))
-                       (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+                       (_ (syntax-violation 'case-lambda "bad case-lambda*" e))))))
 
     (global-extend 'core 'with-ellipsis
                    (lambda (e r w s mod)
@@ -2477,6 +2494,7 @@
 
     (global-extend 'module-ref '@@
                    (lambda (e r w mod)
+                    (s5*-letrec-defines ()
                      (define remodulate
                        (lambda (x mod)
                          (cond ((pair? x)
@@ -2491,9 +2509,11 @@
                                  (syntax-sourcev x)))
                                ((vector? x)
                                 (let* ((n (vector-length x)) (v (make-vector n)))
-                                  (do ((i 0 (fx+ i 1)))
-                                      ((fx= i n) v)
-                                    (vector-set! v i (remodulate (vector-ref x i) mod)))))
+                                  (let ldo ((i 0))
+                                     (if (fx= i n) v
+                                         (begin
+                                         (vector-set! v i (remodulate (vector-ref x i) mod))
+                                         (ldo (fx+ i 1)))))))
                                (else x))))
                      (syntax-case e (@@ primitive)
                        ((_ primitive id)
@@ -2521,7 +2541,7 @@
                         (let ((mod (syntax->datum #'(private mod ...))))
                           (values (remodulate #'exp mod)
                                   r w (source-annotation #'exp)
-                                  mod))))))
+                                  mod)))))))
   
     (global-extend 'core 'if
                    (lambda (e r w s mod)
@@ -2539,21 +2559,27 @@
                          (expand #'then r w mod)
                          (expand #'else r w mod))))))
 
-    (global-extend 'begin 'begin '())
+(define-syntax define*
+  (lambda (x)
+    (syntax-case x ()
+      ((_ (id . args) b0 b1 ...)
+       #'(define id (lambda* args b0 b1 ...)))
+      ((_ id val) (identifier? #'id)
+       #'(define id val)))))
 
-    (global-extend 'define 'define '())
+    (global-extend 'begin 'begin '())
 
-    (global-extend 'define-syntax 'define-syntax '())
     (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
 
     (global-extend 'eval-when 'eval-when '())
 
-    (global-extend 'core 'syntax-case
-                   (let ()
+    (define *next*-syntax-case
+                   (s5*-letrec-defines ()
                      (define convert-pattern
                        ;; accepts pattern & keys
                        ;; returns $sc-dispatch pattern & ids
                        (lambda (pattern keys ellipsis?)
+                        (s5*-letrec-defines ()
                          (define cvt*
                            (lambda (p* n ids)
                              (syntax-case p* ()
@@ -2618,7 +2644,7 @@
                                         (lambda () (cvt (syntax (x ...)) n ids))
                                       (lambda (p ids) (values (vector 'vector p) ids))))
                                    (x (values (vector 'atom (strip p)) ids))))))
-                         (cvt pattern 0 '())))
+                         (cvt pattern 0 '()))))
 
                      (define build-dispatch-call
                        (lambda (pvars exp y r mod)
@@ -2735,7 +2761,7 @@
     ;; syntactic definitions are evaluated immediately after they are
     ;; expanded, and the expanded definitions are also residualized into
     ;; the object file if we are compiling a file.
-    (set! macroexpand
+    (define *next*-macroexpand
           (lambda* (x #:optional (m 'e) (esew '(eval)))
             (expand-top-sequence (list x) null-env top-wrap #f m esew
                                  (cons 'hygiene (module-name (current-module))))))
@@ -2810,6 +2836,7 @@
         (arg-check nonsymbol-id? id 'syntax-local-binding)
         (with-transformer-environment
          (lambda (e r w s rib mod)
+          (s5*-letrec-defines ()
            (define (strip-anti-mark w)
              (let ((ms (wrap-marks w)) (s (wrap-subst w)))
                (if (and (pair? ms) (eq? (car ms) the-anti-mark))
@@ -2839,7 +2866,7 @@
                   (values 'ellipsis
                           (wrap-syntax value (anti-mark (syntax-wrap value))
                                        mod)))
-                 (else (values 'other #f))))))))
+                 (else (values 'other #f)))))))))
 
       (define (syntax-locally-bound-identifiers id)
         (arg-check nonsymbol-id? id 'syntax-locally-bound-identifiers)
@@ -2877,7 +2904,7 @@
     ;; not, should convert to:
     ;;   #(vector <pattern>*)               #(<pattern>*)
 
-    (let ()
+    (s5*-letrec-defines ()
 
       (define match-each
         (lambda (e p w mod)
@@ -3016,8 +3043,36 @@
                ((syntax? e)
                 (match* (syntax-expression e)
                         p (syntax-wrap e) '() (syntax-module e)))
-               (else (match* e p empty-wrap '() #f))))))))
+               (else (match* e p empty-wrap '() #f))))))
+;; )
+
+;;; now do the switch!
 
+(global-extend 'core 'syntax *next*-syntax)
+(global-extend 'define 'define '())
+(global-extend 'define-syntax 'define-syntax '())
+(global-extend 'core 'syntax-case *next*-syntax-case)
+(set! s4*-$sc-dispatch $sc-dispatch)
+(set! s5*-letrec-defines letrec)
+(set! macroexpand *next*-macroexpand)
+
+;;; based on boot-9.scm, without using syntax-rules
+
+(define-syntax and
+ (lambda (x)
+  (syntax-case x ()
+    ((_) #'#t)
+    ((_ x) #'x)
+    ((_ x . y) #'(if x (and . y) #f)))))
+
+(define-syntax or
+ (lambda (x) 
+  (syntax-case x ()
+    ((_) #'#f)
+    ((_ x) #'x)
+    ((_ x . y) #'(let ((t x)) (if t t (or . y)))))))
+
+;;; end from boot-9.scm
 
 (define-syntax with-syntax
    (lambda (x)
@@ -3095,6 +3150,73 @@
        (and (identifier? #'dots) (string? (syntax->datum #'docstring)))
        (expand-syntax-rules #'dots #'(k ...) #'(docstring) #'(((keyword . pattern) template) ...))))))
 
+;;; from quasisyntax.scm
+
+(define-syntax quasisyntax
+  (lambda (e)
+
+    ;; Expand returns a list of the form
+    ;;    [template[t/e, ...] (replacement ...)]
+    ;; Here template[t/e ...] denotes the original template
+    ;; with unquoted expressions e replaced by fresh
+    ;; variables t, followed by the appropriate ellipses
+    ;; if e is also spliced.
+    ;; The second part of the return value is the list of
+    ;; replacements, each of the form (t e) if e is just
+    ;; unquoted, or ((t ...) e) if e is also spliced.
+    ;; This will be the list of bindings of the resulting
+    ;; with-syntax expression.
+
+    (define (expand x level)
+      (syntax-case x (quasisyntax unsyntax unsyntax-splicing)
+        ((quasisyntax e)
+         (with-syntax (((k _)     x) ;; original identifier must be copied
+                       ((e* reps) (expand (syntax e) (+ level 1))))
+           (syntax ((k e*) reps))))
+        ((unsyntax e)
+         (= level 0)
+         (with-syntax (((t) (generate-temporaries '(t))))
+           (syntax (t ((t e))))))
+        (((unsyntax e ...) . r)
+         (= level 0)
+         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+                       ((t ...)        (generate-temporaries (syntax (e ...)))))
+           (syntax ((t ... . r*)
+                    ((t e) ... rep ...)))))
+        (((unsyntax-splicing e ...) . r)
+         (= level 0)
+         (with-syntax (((r* (rep ...)) (expand (syntax r) 0))
+                       ((t ...)        (generate-temporaries (syntax (e ...)))))
+           (with-syntax ((((t ...) ...) (syntax ((t (... ...)) ...))))
+             (syntax ((t ... ... . r*)
+                      (((t ...) e) ... rep ...))))))
+        ((k . r)
+         (and (> level 0)
+              (identifier? (syntax k))
+              (or (free-identifier=? (syntax k) (syntax unsyntax))
+                  (free-identifier=? (syntax k) (syntax unsyntax-splicing))))
+         (with-syntax (((r* reps) (expand (syntax r) (- level 1))))
+           (syntax ((k . r*) reps))))
+        ((h . t)
+         (with-syntax (((h* (rep1 ...)) (expand (syntax h) level))
+                       ((t* (rep2 ...)) (expand (syntax t) level)))
+           (syntax ((h* . t*)
+                    (rep1 ... rep2 ...)))))
+        (#(e ...)
+         (with-syntax ((((e* ...) reps)
+                        (expand (vector->list (syntax #(e ...))) level)))
+           (syntax (#(e* ...) reps))))
+        (other
+         (syntax (other ())))))
+
+    (syntax-case e ()
+      ((_ template)
+       (with-syntax (((template* replacements) (expand (syntax template) 0)))
+         (syntax
+          (with-syntax replacements (syntax template*))))))))
+
+;;; end from quasisyntax.scm
+
 (define-syntax define-syntax-rule
   (lambda (x)
     (syntax-case x ()
@@ -3109,6 +3231,152 @@
              docstring
              ((_ . pattern) template)))))))
 
+
+;;; from boot-9.scm, with replaced define*
+
+(define-syntax-rule (when test stmt stmt* ...)
+  (if test (begin stmt stmt* ...)))
+
+(define-syntax-rule (unless test stmt stmt* ...)
+  (if (not test) (begin stmt stmt* ...)))
+
+(define-syntax cond
+  (lambda (whole-expr)
+    (define (fold f seed xs)
+      (let loop ((xs xs) (seed seed))
+        (if (null? xs) seed
+            (loop (cdr xs) (f (car xs) seed)))))
+    (define (reverse-map f xs)
+      (fold (lambda (x seed) (cons (f x) seed))
+            '() xs))
+    (syntax-case whole-expr ()
+      ((_ clause clauses ...)
+       #`(begin
+           #,@(fold (lambda (clause-builder tail)
+                      (clause-builder tail))
+                    #'()
+                    (reverse-map
+                     (lambda (clause)
+                       (define (bad-clause msg)
+                         (syntax-violation 'cond msg whole-expr clause))
+                       (syntax-case clause (=> else)
+                         ((else e e* ...)
+                          (lambda (tail)
+                            (if (null? tail)
+                                #'((begin e e* ...))
+                                (bad-clause "else must be the last clause"))))
+                         ((else . _) (bad-clause "invalid clause"))
+                         ((test => receiver)
+                          (lambda (tail)
+                            #`((let ((t test))
+                                 (if t
+                                     (receiver t)
+                                     #,@tail)))))
+                         ((test => receiver ...)
+                          (bad-clause "wrong number of receiver expressions"))
+                         ((generator guard => receiver)
+                          (lambda (tail)
+                            #`((call-with-values (lambda () generator)
+                                 (lambda vals
+                                   (if (apply guard vals)
+                                       (apply receiver vals)
+                                       #,@tail))))))
+                         ((generator guard => receiver ...)
+                          (bad-clause "wrong number of receiver expressions"))
+                         ((test)
+                          (lambda (tail)
+                            #`((let ((t test))
+                                 (if t t #,@tail)))))
+                         ((test e e* ...)
+                          (lambda (tail)
+                            #`((if test
+                                   (begin e e* ...)
+                                   #,@tail))))
+                         (_ (bad-clause "invalid clause"))))
+                     #'(clause clauses ...))))))))
+
+(define-syntax case
+  (lambda (whole-expr)
+    (define (fold f seed xs)
+      (let loop ((xs xs) (seed seed))
+        (if (null? xs) seed
+            (loop (cdr xs) (f (car xs) seed)))))
+    (define (fold2 f a b xs)
+      (let loop ((xs xs) (a a) (b b))
+        (if (null? xs) (values a b)
+            (call-with-values
+                (lambda () (f (car xs) a b))
+              (lambda (a b)
+                (loop (cdr xs) a b))))))
+    (define (reverse-map-with-seed f seed xs)
+      (fold2 (lambda (x ys seed)
+               (call-with-values
+                   (lambda () (f x seed))
+                 (lambda (y seed)
+                   (values (cons y ys) seed))))
+             '() seed xs))
+    (syntax-case whole-expr ()
+      ((_ expr clause clauses ...)
+       (with-syntax ((key #'key))
+         #`(let ((key expr))
+             #,@(fold
+                 (lambda (clause-builder tail)
+                   (clause-builder tail))
+                 #'()
+                 (reverse-map-with-seed
+                  (lambda (clause seen)
+                    (define (bad-clause msg)
+                      (syntax-violation 'case msg whole-expr clause))
+                    (syntax-case clause ()
+                      ((test . rest)
+                       (with-syntax
+                           ((clause-expr
+                             (syntax-case #'rest (=>)
+                               ((=> receiver) #'(receiver key))
+                               ((=> receiver ...)
+                                (bad-clause
+                                 "wrong number of receiver expressions"))
+                               ((e e* ...) #'(begin e e* ...))
+                               (_ (bad-clause "invalid clause")))))
+                         (syntax-case #'test (else)
+                           ((datums ...)
+                            (let ((seen
+                                   (fold
+                                    (lambda (datum seen)
+                                      (define (warn-datum type)
+                                        ((@ (system base message)
+                                            warning)
+                                         type
+                                         (append (source-properties datum)
+                                                 (source-properties
+                                                  (syntax->datum #'test)))
+                                         datum
+                                         (syntax->datum clause)
+                                         (syntax->datum whole-expr)))
+                                      (when (memv datum seen)
+                                        (warn-datum 'duplicate-case-datum))
+                                      (when (or (pair? datum) (array? datum))
+                                        (warn-datum 'bad-case-datum))
+                                      (cons datum seen))
+                                    seen
+                                    (map syntax->datum #'(datums ...)))))
+                              (values (lambda (tail)
+                                        #`((if (memv key '(datums ...))
+                                               clause-expr
+                                               #,@tail)))
+                                      seen)))
+                           (else (values (lambda (tail)
+                                           (if (null? tail)
+                                               #'(clause-expr)
+                                               (bad-clause
+                                                "else must be the last clause")))
+                                         seen))
+                           (_ (bad-clause "invalid clause")))))
+                      (_ (bad-clause "invalid clause"))))
+                  '() #'(clause clauses ...)))))))))
+
+;;; end from boot-9.scm
+
 (define-syntax let*
   (lambda (x)
     (syntax-case x ()