* working on librarifying syntax.ss

src/libcompile.ss

@@ -1293,6 +1293,7 @@
      (make-bind lhs* rhs* (mk-mvcall body c))]
     [else (error 'mk-mvcall "invalid producer ~s" (unparse p))]))
 
+
 (define (copy-propagate x)
   (define who 'copy-propagate)
   (define the-void (make-primcall 'void '()))
@@ -5293,6 +5294,16 @@
   (lambda (x)
     ((current-eval) x)))
 
+(primitive-set! 'compile-time-core-eval
+  (make-parameter 
+    (lambda (x) 
+      (parameterize ([current-expand (lambda (x) x)])
+        (compile-expr x)))
+    (lambda (f)
+      (unless (procedure? f) 
+        (error 'compile-time-core-eval "~s is not a procedure" f))
+      f)))
+
 
 )
 

src/libtoplevel.ss

@@ -88,6 +88,8 @@
     string->number exact->inexact
     flonum? flonum->string string->flonum
     sin cos atan sqrt
+    chi-top-library
+    compile-time-core-eval
     ))
 
 (define (system-primitives)
@@ -231,7 +233,10 @@
        (load script)
        (exit 0)]
       [else
-       (printf "Ikarus Scheme (Build ~a)\n" "NO TIME STRING")
+       (let ()
+         (define-syntax compile-time-string
+           (lambda (x) (date-string)))
+         (printf "Ikarus Scheme (Build ~a)\n" (compile-time-string)))
        ;(printf "Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
        (display "Copyright (c) 2006-2007 Abdulaziz Ghuloum\n\n")
        (command-line-arguments args)

src/makefile.ss

@@ -100,6 +100,8 @@
 
     flonum? flonum->string string->flonum
     sin cos atan sqrt
+
+    chi-top-library compile-time-core-eval
     ))
 
 (define system-primitives
@@ -228,7 +230,7 @@
 (whack-system-env #t)
 
 (define scheme-library-files
-  '(  ["libhandlers.ss"   "libhandlers.fasl"  p0 onepass]
+  '(["libhandlers.ss"   "libhandlers.fasl"  p0 onepass]
     ["libcontrol.ss"   "libcontrol.fasl"  p0 onepass]
     ["libcollect.ss"    "libcollect.fasl"   p0 onepass]
     ["librecord.ss"     "librecord.fasl"    p0 onepass]

src/psyntax-7.1.ss

@@ -586,6 +586,10 @@
   (lambda (x)
     (eval `(,noexpand ,x))))
 
+(define compile-time-eval-hook
+  (lambda (x)
+    (eval `(,noexpand ,x))))
+
 (define define-top-level-value-hook
   (lambda (sym val)
     (top-level-eval-hook
@@ -2050,9 +2054,11 @@
                                     (else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
                             (loop bs))))))))))))
 
-
+(define chi-top-library
-(include "syntax.ss")
+  (let ()
-
+    (include "syntax.ss")
+    (primitive-set! 'chi-top-library library-expander)
+    library-expander))
 
 (define id-set-diff
   (lambda (exports defs)
@@ -3079,6 +3085,7 @@
      ))
 
 
+
 ;;; core transformers
 
 (global-extend 'local-syntax 'letrec-syntax #t)

src/syntax.ss

@@ -1,37 +1,19 @@
 
 
-(define chi-top-library
-  (let ()
-    ;(define my-map
-    ;  (lambda (ctxt f ls . ls*)
-    ;    (cond
-    ;      [(and (list? ls) 
-    ;            (andmap list? ls*)
-    ;            (let ([n (length ls)])
-    ;              (andmap (lambda (ls) (= (length ls) n)) ls*)))
-    ;       (let loop ([ls ls] [ls* ls*])
-    ;         (cond
-    ;           [(null? ls) '()]
-    ;           [else
-    ;            (cons (apply f (car ls) (#%map car ls*))
-    ;                  (loop (cdr ls) (#%map cdr ls*)))]))]
-    ;      [else (error ctxt "invalid args ~s" (cons ls ls*))])))
-    ;(define-syntax map
-    ;  (syntax-rules ()
-    ;    [(_ f ls ls* ...)
-    ;     (my-map '(map f ls ls* ...) f ls ls* ...)]))
-    (define-syntax build-let
-      (syntax-rules ()
-        [(_ ae lhs* rhs* body)
-         (build-application ae
-           (build-lambda ae lhs* body)
-           rhs*)]))
   (define who 'chi-top-library)
+  (define-syntax build-let
+    (lambda (x)
+      (syntax-case x ()
+        [(_ ae lhs* rhs* body)
+         #'(build-application ae
+             (build-lambda ae lhs* body)
+             rhs*)])))
   (define-syntax assert
-      (syntax-rules ()
+    (lambda (x)
+      (syntax-case x ()
         [(_ name pred* ...)
-         (unless (and pred* ...)
+         #'(unless (and pred* ...)
-           (error 'name "assertion ~s failed" '(pred* ...)))]))
+             (error 'name "assertion ~s failed" '(pred* ...)))])))
   (define top-mark* '(top))
   (define top-marked?
     (lambda (m*) (memq 'top m*)))
@@ -47,7 +29,7 @@
   (define make-rib
     (lambda (sym* mark** label*)
       (vector 'rib sym* mark** label*)))
-    (define id/label-rib
+  (define make-full-rib
     (lambda (id* label*)
       (make-rib (map id->sym id*) (map stx-mark* id*) label*)))
   (define make-empty-rib
@@ -149,6 +131,8 @@
           (p? x))))
   (define syntax-pair?
     (lambda (x) (syntax-kind? x pair?)))
+  (define syntax-vector? 
+    (lambda (x) (syntax-kind? x vector?)))
   (define syntax-null?
     (lambda (x) (syntax-kind? x null?)))
   (define syntax-list?
@@ -218,6 +202,15 @@
   (define self-evaluating?
     (lambda (x) 
       (or (number? x) (string? x) (char? x) (boolean? x))))
+  (define stx->datum
+    (lambda (x)
+      (strip x '())))
+  (define extend-env
+    (lambda (lab b r) 
+      (cons (cons lab b) r)))
+  (define extend-env* 
+    (lambda (lab* b* r)
+      (append (map cons lab* b*) r)))
   (define strip
     (lambda (x m*)
       (if (top-marked? m*) 
@@ -311,12 +304,10 @@
              (error who "malformed library ~s" e))]
         [_ (error who "malformed library ~s" e)])))
   (define-syntax stx-error 
-      (syntax-rules ()
+    (lambda (x)
-        [(_ stx) (error 'chi "invalid syntax ~s" (strip stx '()))]
+      (syntax-case x ()
-        [(_ stx msg) (error 'chi "~a: ~s" msg (strip stx '()))]))
+        [(_ stx) #'(error 'chi "invalid syntax ~s" (strip stx '()))]
-    ;(define stx-error
+        [(_ stx msg) #'(error 'chi "~a: ~s" msg (strip stx '()))])))
-    ;  (lambda (stx . args)
-    ;    (error 'chi "invalid syntax ~s" (strip stx '()))))
   (define sanitize-binding
     (lambda (x)
       (cond
@@ -327,7 +318,7 @@
         [else (error 'expand "invalid transformer ~s" x)])))
   (define make-eval-transformer
     (lambda (x)
-        (sanitize-binding (local-eval-hook x)))) 
+      (sanitize-binding (compile-time-eval-hook x)))) 
   (define-syntax syntax-match-test
     (lambda (stx)
       (define dots?
@@ -511,9 +502,13 @@
       [begin         begin-label         (begin)]
       [set!          set!-label          (set!)]
       [define-record define-record-label (macro . define-record)]
+      [include       include-label       (macro . include)]
+      [with-syntax   with-syntax-label   (macro . with-syntax)]
       [case          case-label          (core-macro .  case)]
       [foreign-call  foreign-call-label  (core-macro .  foreign-call)]
       [quote         quote-label         (core-macro . quote)]
+      [syntax-case   syntax-case-label   (core-macro . syntax-case)]
+      [syntax        syntax-label        (core-macro . syntax)]
       [lambda        lambda-label        (core-macro . lambda)]
       [case-lambda   case-lambda-label   (core-macro . case-lambda)]
       [let-values    let-values-label    (core-macro . let-values)]
@@ -794,6 +789,10 @@
       [$make-record $make-record-label (core-prim . $make-record)]
       [$record?     $record?-label     (core-prim . $record?)]
       [$record/rtd? $record/rtd?-label (core-prim . $record/rtd?)]
+      ;;; syntax-case
+      [identifier?          identifier?-label          (core-prim . identifier?)]
+      [generate-temporaries generate-temporaries-label (core-prim . generate-temporaries)]
+      [free-identifier=?    free-identifier=?-label    (core-prim . free-identifier=?)]
       ;;; codes
       [$closure-code  $closure-code-label (core-prim . $closure-code)]
       [$code? $code?-label (core-prim . $code?)]
@@ -875,7 +874,7 @@
                     [(null? lex**) 
                      (chi-internal 
                        (add-subst 
-                           (id/label-rib fml* lab*)
+                         (make-full-rib fml* lab*)
                          (cons b b*))
                        (add-lexicals lab* lex* r)
                        mr)]
@@ -897,14 +896,14 @@
              [(null? lhs*) 
               (chi-internal
                 (add-subst 
-                    (id/label-rib subst-lhs* subst-lab*)
+                  (make-full-rib subst-lhs* subst-lab*)
                   (cons b b*))
                 r mr)]
              [else
               (let ([lhs (car lhs*)]
                     [rhs (chi-expr
                            (add-subst
-                               (id/label-rib subst-lhs* subst-lab*)
+                             (make-full-rib subst-lhs* subst-lab*)
                              (car rhs*))
                            r mr)])
                 (unless (id? lhs)
@@ -924,7 +923,7 @@
              (stx-error e)
              (let ([lex* (map gen-lexical lhs*)]
                    [lab* (map gen-label lhs*)])
-                 (let ([rib (id/label-rib lhs* lab*)]
+               (let ([rib (make-full-rib lhs* lab*)]
                      [r (add-lexicals lab* lex* r)])
                  (let ([body (chi-internal 
                                (add-subst rib (cons b b*))
@@ -947,7 +946,7 @@
                    [lab* (map gen-label lhs*)])
                (let ([body (chi-internal 
                              (add-subst 
-                                 (id/label-rib lhs* lab*)
+                               (make-full-rib lhs* lab*)
                                (cons b b*))
                              (add-lexicals lab* lex* r)
                              mr)])
@@ -961,8 +960,8 @@
                    [lab* (map gen-label lhs*)]
                    [looplex (gen-lexical loop)]
                    [looplab (gen-label loop)])
-                 (let ([b* (add-subst (id/label-rib (list loop) (list looplab))
+               (let ([b* (add-subst (make-full-rib (list loop) (list looplab))
-                             (add-subst (id/label-rib lhs* lab*)
+                           (add-subst (make-full-rib lhs* lab*)
                              (cons b b*)))]
                      [r (add-lexicals 
                           (cons looplab lab*)
@@ -1125,6 +1124,28 @@
             [(symbol? x) 
              (make-stx x top-mark* (list rib))]
             [else x])))))
+  (define with-syntax-macro
+    (lambda (e)
+      (syntax-match e
+        [(_ ([fml* expr*] ...) b b* ...) 
+         (bless
+           `(syntax-case (list . ,expr*) ()
+              [,fml* (begin ,b . ,b*)]))])))
+  (define include-macro
+    (lambda (e)
+      (syntax-match e
+        [(id filename)
+         (let ([filename (stx->datum filename)])
+           (unless (string? filename) (stx-error e))
+           (with-input-from-file filename
+             (lambda ()
+               (let f ([ls '()])
+                 (let ([x (read)])
+                   (cond
+                     [(eof-object? x) 
+                      (cons (bless 'begin) 
+                        (datum->stx id (reverse ls)))]
+                     [else (f (cons x ls))]))))))])))
   (define define-record-macro
     (lambda (e)
       (define enumerate
@@ -1252,6 +1273,357 @@
          (build-foreign-call no-source
            (chi-expr name r mr)
            (chi-expr* arg* r mr))])))
+  ;; p in pattern:                        matches:
+  ;;   ()                                 empty list
+  ;;   _                                  anything (no binding created)
+  ;;   any                                anything
+  ;;   (p1 . p2)                          pair
+  ;;   #(free-id <key>)                   <key> with free-identifier=?
+  ;;   each-any                           any proper list
+  ;;   #(each p)                          (p*)
+  ;;   #(each+ p1 (p2_1 ... p2_n) p3)      (p1* (p2_n ... p2_1) . p3)
+  ;;   #(vector p)                        #(x ...) if p matches (x ...)
+  ;;   #(atom <object>)                   <object> with "equal?"
+  (define convert-pattern
+   ; returns syntax-dispatch pattern & ids
+    (lambda (pattern keys)
+      (define cvt*
+        (lambda (p* n ids)
+          (if (null? p*)
+              (values '() ids)
+              (let-values (((y ids) (cvt* (cdr p*) n ids)))
+                (let-values (((x ids) (cvt (car p*) n ids)))
+                  (values (cons x y) ids))))))
+      (define id-dots?
+        (lambda (x) 
+          (and (syntax-pair? x)
+               (let ([d (syntax-cdr x)])
+                 (and (syntax-pair? d) 
+                      (syntax-null? (syntax-cdr d))
+                      (ellipsis? (syntax-car d)))))))
+      (define id-dots-id
+        (lambda (x) (syntax-car x)))
+      (define syntax-foo?
+        (lambda (x)
+          (and (syntax-pair? x)
+               (let ((d (syntax-cdr x)))
+                 (and (syntax-pair? d)
+                      (ellipsis? (syntax-car d)))))))
+      (define syntax-foo-z
+        (lambda (x)
+          (let f ([x (syntax-cdr (syntax-cdr x))])
+            (cond
+              ((syntax-pair? x) (f (syntax-cdr x)))
+              (else x)))))
+      (define syntax-foo-ys
+        (lambda (x)
+          (let f ([x (syntax-cdr (syntax-cdr x))])
+            (cond
+              [(syntax-pair? x)
+               (cons (syntax-car x) (f (syntax-cdr x)))]
+              [else '()]))))
+      (define syntax-foo-x
+        (lambda (x) (syntax-car x)))
+      (define cvt
+        (lambda (p n ids)
+          (cond
+            [(not (id? p))
+             (cond
+               [(id-dots? p)
+                (let-values ([(p ids) (cvt (id-dots-id p) (+ n 1) ids)])
+                  (values
+                    (if (eq? p 'any) 'each-any (vector 'each p))
+                    ids))]
+               [(syntax-foo? p) ; (x dots y ... . z)
+                (let-values ([(z ids) (cvt (syntax-foo-z p) n ids)])
+                  (let-values ([(y ids) (cvt* (syntax-foo-ys p) n ids)])
+                    (let-values ([(x ids) (cvt (syntax-foo-x p) (+ n 1) ids)])
+                      (values (vector 'each+ x (reverse y) z) ids))))]
+               [(syntax-pair? p)
+                (let-values ([(y ids) (cvt (syntax-cdr p) n ids)])
+                  (let-values ([(x ids) (cvt (syntax-car p) n ids)])
+                    (values (cons x y) ids)))]
+               [(syntax-null? p) (values '() ids)]
+               [(syntax-vector? p)
+                (let-values ([(p ids) (cvt (syntax-vector->list p) n ids)])
+                  (values (vector 'vector p) ids))]
+               [else (values (vector 'atom (strip p '())) ids)])]
+            [(bound-id-member? p keys)
+             (values (vector 'free-id p) ids)]
+            [(free-id=? p (sym->free-id '_))
+             (values '_ ids)]
+            [else (values 'any (cons (cons p n) ids))])))
+      (cvt pattern 0 '())))
+ 
+  (define ellipsis?
+    (lambda (x) 
+      (and (id? x) (free-id=? x (sym->free-id '...)))))
+  (define syntax-case-transformer
+    (let ()
+      (define build-dispatch-call
+        (lambda (pvars expr y r mr)
+          (let ([ids (map car pvars)] 
+                [levels (map cdr pvars)])
+            (let ([labels (map gen-label ids)]
+                  [new-vars (map gen-lexical ids)])
+              (let ([body
+                     (chi-expr
+                       (add-subst (make-full-rib ids labels) expr)
+                       (extend-env*
+                         labels
+                         (map (lambda (var level)
+                                (make-binding 'syntax (cons var level)))
+                              new-vars
+                              (map cdr pvars))
+                         r)
+                       mr)])
+                (build-application no-source
+                  (build-primref no-source 'apply)
+                  (list (build-lambda no-source new-vars body) y)))))))
+      (define gen-clause
+        (lambda (x keys clauses r mr pat fender expr)
+          (let-values (((p pvars) (convert-pattern pat keys)))
+            (cond
+              ((not (distinct-bound-ids? (map car pvars)))
+               (invalid-ids-error (map car pvars) pat "pattern variable"))
+              ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
+               (stx-error pat "3misplaced ellipsis in syntax-case pattern"))
+              (else
+               (let ((y (gen-lexical 'tmp)))
+                 (let ([test 
+                        (cond
+                          [(eq? fender #t) y]
+                          [else
+                           (let ([call
+                                  (build-dispatch-call
+                                     pvars fender y r mr)])
+                             (build-conditional no-source
+                                (build-lexical-reference no-source y)
+                                call
+                                (build-data no-source #f)))])])
+                    (let ([conseq
+                           (build-dispatch-call pvars expr
+                             (build-lexical-reference no-source y)
+                             r mr)])
+                      (let ([altern
+                             (gen-syntax-case x keys clauses r mr)])
+                        (build-application no-source
+                          (build-lambda no-source (list y) 
+                            (build-conditional no-source test conseq altern))
+                          (list
+                            (build-application no-source
+                              (build-primref no-source '$syntax-dispatch)
+                              (list
+                                (build-lexical-reference no-source x)
+                                (build-data no-source p))))))))))))))
+      (define gen-syntax-case
+        (lambda (x keys clauses r mr)
+          (if (null? clauses)
+              (build-application no-source
+                (build-primref no-source 'syntax-error)
+                (list (build-lexical-reference no-source x)))
+              (syntax-match (car clauses)
+                [(pat expr)
+                 (if (and (id? pat)
+                          (not (bound-id-member? pat keys))
+                          (not (ellipsis? pat)))
+                     (if (free-id=? pat (sym->free-id '_))
+                         (chi-expr expr r mr)
+                         (let ([lab (gen-label pat)]
+                               [lex (gen-lexical pat)])
+                           (let ([body
+                                  (chi-expr
+                                    (add-subst
+                                       (make-full-rib (list pat) (list lab))
+                                       expr)
+                                     (extend-env lab 
+                                       (make-binding 'syntax (cons lex 0))
+                                       r)
+                                     mr)])
+                              (build-application no-source
+                                (build-lambda no-source (list lex) body)
+                                (list (build-lexical-reference no-source x))))))
+                     (gen-clause x keys (cdr clauses) r mr pat #t expr))]
+                [(pat fender expr)
+                 (gen-clause x keys (cdr clauses) r mr pat fender expr)]))))
+      (lambda (e r mr)
+        (syntax-match e
+          [(_ expr (keys ...) clauses ...)
+           (unless (andmap (lambda (x) (and (id? x) (not (ellipsis?  x)))) keys)
+             (stx-error e))
+           (let ((x (gen-lexical 'tmp)))
+             (let ([body (gen-syntax-case x keys clauses r mr)])
+               (build-application no-source
+                 (build-lambda no-source (list x) body)
+                 (list (chi-expr expr r mr)))))]))))
+    (define syntax-transformer
+      (let ()
+        (define match2
+          (lambda (e f? sk fk)
+            (if (syntax-list? e)
+                (let ((e (syntax->list e)))
+                  (if (= (length e) 2)
+                      (let ((e0 (car e)) (e1 (cadr e)))
+                        (if (or (eq? f? #t) (f? e0 e1))
+                            (sk e0 e1)
+                            (fk)))
+                      (fk)))
+                (fk))))
+        (define gen-syntax
+          (lambda (src e r maps ellipsis? vec?)
+            (if (id? e)
+                (let ((label (id->label e)))
+                  (let ((b (label->binding label r)))
+                    (if (eq? (binding-type b) 'syntax)
+                        (let-values (((var maps)
+                                      (let ((var.lev (binding-value b)))
+                                        (gen-ref src (car var.lev) (cdr var.lev) maps))))
+                          (values (list 'ref var) maps))
+                        (if (ellipsis? e)
+                            (syntax-error src "1misplaced ellipsis in syntax form")
+                            (begin
+                              (values (list 'quote e) maps))))))
+                (match2 e (lambda (dots e) (ellipsis? dots))
+                  (lambda (dots e)
+                    (if vec?
+                       (syntax-error src "2misplaced ellipsis in syntax form")
+                       (gen-syntax src e r maps (lambda (x) #f) #f)))
+                  (lambda ()
+                    (cond
+                      ((and (syntax-pair? e)   ;(x dots . y)
+                            (let ((t (syntax-cdr e)))
+                              (and (syntax-pair? t)
+                                   (ellipsis? (syntax-car t)))))
+                       (let f ((y (syntax-cdr (syntax-cdr e)))
+                               (k (lambda (maps)
+                                    (let-values (((x maps)
+                                                  (gen-syntax src (syntax-car e) r 
+                                                    (cons '() maps) ellipsis? #f)))
+                                      (if (null? (car maps))
+                                          (syntax-error src
+                                            "extra ellipsis in syntax form")
+                                          (values (gen-map x (car maps)) (cdr maps)))))))
+                         (cond
+                           ((syntax-null? y) (k maps))
+                           ((and (syntax-pair? y) (ellipsis? (syntax-car y)))
+                            ; (dots . y)
+                            (f (syntax-cdr y)
+                               (lambda (maps)
+                                 (let-values (((x maps) (k (cons '() maps))))
+                                   (if (null? (car maps))
+                                       (syntax-error src "extra ellipsis in syntax form")
+                                       (values (gen-mappend x (car maps)) (cdr maps)))))))
+                           (else 
+                            (let-values (((y maps) 
+                                          (gen-syntax src y r maps ellipsis? vec?)))
+                              (let-values (((x maps) (k maps)))
+                                (values (gen-append x y) maps)))))))
+                      ((syntax-pair? e) ;(x . y)
+                       (let-values (((xnew maps)
+                                     (gen-syntax src (syntax-car e) r 
+                                                 maps ellipsis? #f)))
+                         (let-values (((ynew maps)
+                                       (gen-syntax src (syntax-cdr e) r 
+                                                   maps ellipsis? vec?)))
+                           (values (gen-cons e (syntax-car e) (syntax-cdr e) xnew ynew)
+                                   maps))))
+                      ((syntax-vector? e) ;#(x1 x2 ...)
+                       (let ((ls (syntax-vector->list e)))
+                         (let-values (((lsnew maps)
+                                       (gen-syntax src ls r maps ellipsis? #t)))
+                           (values (gen-vector e ls lsnew) maps))))
+                      ((and (syntax-null? e) vec?) (values '(quote ()) maps))
+                      (else (values `(quote ,e) maps))))))))
+        (define gen-ref
+          (lambda (src var level maps)
+            (if (= level 0)
+                (values var maps)
+                (if (null? maps)
+                    (syntax-error src "missing ellipsis in syntax form")
+                    (let-values (((outer-var outer-maps)
+                                  (gen-ref src var (- level 1) (cdr maps))))
+                      (cond
+                        ((assq outer-var (car maps)) =>
+                         (lambda (b) (values (cdr b) maps)))
+                        (else
+                         (let ((inner-var (gen-var 'tmp)))
+                           (values
+                             inner-var
+                             (cons
+                               (cons (cons outer-var inner-var) (car maps))
+                               outer-maps))))))))))
+        (define gen-append
+          (lambda (x y)
+            (if (equal? y '(quote ())) x (list 'append x y))))
+        (define gen-mappend
+          (lambda (e map-env)
+            (list 'apply '(primitive append) (gen-map e map-env))))
+        (define gen-map
+          (lambda (e map-env)
+            (let ((formals (map cdr map-env))
+                  (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
+              (cond
+               ; identity map equivalence:
+               ; (map (lambda (x) x) y) == y
+                ((eq? (car e) 'ref)
+                 (car actuals))
+               ; eta map equivalence:
+               ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
+                ((andmap
+                   (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
+                   (cdr e))
+                 (list* 'map (list 'primitive (car e))
+                       (map (let ((r (map cons formals actuals)))
+                              (lambda (x) (cdr (assq (cadr x) r))))
+                            (cdr e))))
+                (else (list* 'map (list 'lambda formals e) actuals))))))
+        (define gen-cons
+          (lambda (e x y xnew ynew)
+            (case (car ynew)
+              ((quote)
+               (if (eq? (car xnew) 'quote)
+                   (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
+                     (if (and (eq? xnew x) (eq? ynew y))
+                         (list 'quote e)
+                         (list 'quote (cons xnew ynew))))
+                   (if (eq? (cadr ynew) '())
+                       (list 'list xnew)
+                       (list 'cons xnew ynew))))
+              ((list) (list* 'list xnew (cdr ynew)))
+              (else (list 'cons xnew ynew)))))
+        (define gen-vector
+          (lambda (e ls lsnew)
+            (cond
+              ((eq? (car lsnew) 'quote)
+               (if (eq? (cadr lsnew) ls)
+                   (list 'quote e)
+                   (list 'quote (list->vector (cadr lsnew)))))
+                   ;`(quote #(,@(cadr lsnew)))))
+              ((eq? (car lsnew) 'list) 
+               (cons 'vector (cdr lsnew)))
+              (else (list 'list->vector lsnew)))))
+        (define regen
+          (lambda (x)
+            (case (car x)
+              ((ref) (build-lexical-reference no-source (cadr x)))
+              ((primitive) (build-primref no-source (cadr x)))
+              ((quote) (build-data no-source (cadr x)))
+              ((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
+              ((map)
+               (let ((ls (map regen (cdr x))))
+                 (build-application no-source
+                   (build-primref no-source 'map)
+                   ls)))
+              (else
+               (build-application no-source
+                 (build-primref no-source (car x))
+                 (map regen (cdr x)))))))
+        (lambda (e r mr)
+          (match2 e #t
+            (lambda (_ x)
+              (let-values (((e maps) (gen-syntax e x r '() ellipsis? #f)))
+                (regen e)))
+            (lambda () (syntax-error e))))))
   (define core-macro-transformer
     (lambda (name)
       (case name
@@ -1271,6 +1643,8 @@
         [(or)            or-transformer]
         [(parameterize)  parameterize-transformer]
         [(foreign-call)  foreign-call-transformer]
+        [(syntax-case)   syntax-case-transformer]
+        [(syntax)        syntax-transformer]
         [else (error 'macro-transformer "cannot find ~s" name)])))
   (define macro-transformer
     (lambda (x)
@@ -1279,6 +1653,8 @@
         [(symbol? x)
          (case x
            [(define-record) define-record-macro]
+           [(include)       include-macro]
+           [(with-syntax)   with-syntax-macro]
            [else (error 'macro-transformer 
                         "invalid macro ~s" x)])]
         [else (error 'core-macro-transformer 
@@ -1354,7 +1730,7 @@
                  lex*
                  (chi-internal 
                    (add-subst 
-                       (id/label-rib x* lab*)
+                     (make-full-rib x* lab*)
                      body*)
                    (add-lexicals lab* lex* r)
                    mr)))
@@ -1369,7 +1745,7 @@
                  (append lex* lex)
                  (chi-internal 
                    (add-subst 
-                       (id/label-rib (cons x x*) (cons lab lab*))
+                     (make-full-rib (cons x x*) (cons lab lab*))
                      body*)
                    (add-lexicals (cons lab lab*)
                                  (cons lex lex*)
@@ -1452,6 +1828,22 @@
                              (cons lex lex*)
                              (cons rhs rhs*)
                              kwd*)))]
+                     [(define-syntax)
+                      (let-values ([(id rhs) (parse-define-syntax e)])
+                        (when (bound-id-member? id kwd*)
+                          (syntax-error id "undefined identifier"))
+                        (let ([lab (gen-label id)])
+                          (let ([expanded-rhs (chi-expr rhs mr mr)])
+                            (extend-rib! rib id lab)
+                            (let ([b (make-eval-transformer expanded-rhs)])
+                              (f (cdr e*)
+                                 module-init**
+                                 (cons (cons lab b) r)
+                                 (cons (cons lab b) mr) 
+                                 lhs* lex* rhs* kwd*)))))] 
+                     [(macro)
+                      (f (cons (add-subst rib (chi-macro value e)) (cdr e*))
+                         module-init** r mr lhs* lex* rhs* kwd*)]
                      [(module)
                       (let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*)
                                     (chi-internal-module e r mr kwd*)])
@@ -1574,7 +1966,7 @@
                        r mr lhs* lex* rhs* kwd*)]
                    [else 
                     (return e* r mr lhs* lex* rhs*)]))))]))))
-    (define chi-top-library
+  (define library-expander
     (lambda (e)
       (let-values ([(name exp* b*) (parse-library e)])
         (let ([rib (make-scheme-rib)]
@@ -1591,8 +1983,3 @@
                     (chi-void)
                     (build-sequence no-source 
                       (chi-expr* init* r mr))))))))))
-    (lambda (x) 
-      (let ([x (chi-top-library x)])
-    ;    (pretty-print x)
-        x))
-    ))