cleanups to boot-9

[bpt/guile.git] / module / ice-9 / psyntax.scm

diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 2518fc9..9033a60 100644 (file)
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -49,7 +49,7 @@
 ;;; also documented in the R4RS and draft R5RS.
 ;;;
 ;;;   bound-identifier=?
 ;;; also documented in the R4RS and draft R5RS.
 ;;;
 ;;;   bound-identifier=?

-;;;   datum->syntax-object
+;;;   datum->syntax

 ;;;   define-syntax
 ;;;   fluid-let-syntax
 ;;;   free-identifier=?
 ;;;   define-syntax
 ;;;   fluid-let-syntax
 ;;;   free-identifier=?


@@ -60,7 +60,7 @@
 ;;;   letrec-syntax
 ;;;   syntax
 ;;;   syntax-case
 ;;;   letrec-syntax
 ;;;   syntax
 ;;;   syntax-case

-;;;   syntax-object->datum
+;;;   syntax->datum

 ;;;   syntax-rules
 ;;;   with-syntax
 ;;;
 ;;;   syntax-rules
 ;;;   with-syntax
 ;;;


@@ -79,11 +79,9 @@
 ;;;      conditionally evaluates expr ... at compile-time or run-time
 ;;;      depending upon situations (see the Chez Scheme System Manual,
 ;;;      Revision 3, for a complete description)
 ;;;      conditionally evaluates expr ... at compile-time or run-time
 ;;;      depending upon situations (see the Chez Scheme System Manual,
 ;;;      Revision 3, for a complete description)

-;;;   (syntax-error object message)
+;;;   (syntax-violation who message form [subform])

 ;;;      used to report errors found during expansion
 ;;;      used to report errors found during expansion

-;;;   (install-global-transformer symbol value)
-;;;      used by expanded code to install top-level syntactic abstractions
-;;;   (syntax-dispatch e p)
+;;;   ($sc-dispatch e p)

 ;;;      used by expanded code to handle syntax-case matching
 
 ;;; The following nonstandard procedures must be provided by the
 ;;;      used by expanded code to handle syntax-case matching
 
 ;;; The following nonstandard procedures must be provided by the


@@ -209,7 +207,7 @@
 
 ;;; Objects with no standard print syntax, including objects containing
 ;;; cycles and syntax object, are allowed in quoted data as long as they
 
 ;;; Objects with no standard print syntax, including objects containing
 ;;; cycles and syntax object, are allowed in quoted data as long as they

-;;; are contained within a syntax form or produced by datum->syntax-object.
+;;; are contained within a syntax form or produced by datum->syntax.

 ;;; Such objects are never copied.
 
 ;;; All identifiers that don't have macro definitions and are not bound
 ;;; Such objects are never copied.
 
 ;;; All identifiers that don't have macro definitions and are not bound


@@ -256,19 +254,22 @@
 
 
 
 
 
 

+(eval-when (compile)
+  (set-current-module (resolve-module '(guile))))
+

 (let ()
 (define-syntax define-structure
   (lambda (x)
     (define construct-name
       (lambda (template-identifier . args)
 (let ()
 (define-syntax define-structure
   (lambda (x)
     (define construct-name
       (lambda (template-identifier . args)

-        (datum->syntax-object
+        (datum->syntax

           template-identifier
           (string->symbol
             (apply string-append
                    (map (lambda (x)
                           (if (string? x)
                               x
           template-identifier
           (string->symbol
             (apply string-append
                    (map (lambda (x)
                           (if (string? x)
                               x

-                              (symbol->string (syntax-object->datum x))))
+                              (symbol->string (syntax->datum x))))

                         args))))))
     (syntax-case x ()
       ((_ (name id1 ...))
                         args))))))
     (syntax-case x ()
       ((_ (name id1 ...))


@@ -320,13 +321,11 @@
 
 (define top-level-eval-hook
   (lambda (x mod)
 
 (define top-level-eval-hook
   (lambda (x mod)

-    (eval `(,noexpand ,x) (if mod (resolve-module mod)
-                              (interaction-environment)))))
+    (primitive-eval `(,noexpand ,x))))

 
 (define local-eval-hook
   (lambda (x mod)
 
 (define local-eval-hook
   (lambda (x mod)

-    (eval `(,noexpand ,x) (if mod (resolve-module mod)
-                              (interaction-environment)))))
+    (primitive-eval `(,noexpand ,x))))

 
 (define error-hook
   (lambda (who why what)
 
 (define error-hook
   (lambda (who why what)


@@ -337,34 +336,33 @@
     ((_) (gensym))))
 
 (define put-global-definition-hook
     ((_) (gensym))))
 
 (define put-global-definition-hook

-  (lambda (symbol binding module)
-    (let* ((module (if module
-                       (resolve-module module)
-                       (warn "wha" symbol (current-module))))
-           (v (or (module-variable module symbol)
-                  (let ((v (make-variable sc-macro)))
-                    (module-add! module symbol v)
-                    v))))
-      ;; Don't destroy Guile macros corresponding to primitive syntax
-      ;; when syncase boots.
-      (if (not (and (symbol-property symbol 'primitive-syntax)
-                    (eq? module the-syncase-module)))
-          (variable-set! v sc-macro))
-      ;; Properties are tied to variable objects
-      (set-object-property! v '*sc-expander* binding))))
+  (lambda (symbol type val)
+    (let ((existing (let ((v (module-variable (current-module) symbol)))
+                      (and v (variable-bound? v)
+                           (let ((val (variable-ref v)))
+                             (and (macro? val)
+                                  (not (syncase-macro-type val))
+                                  val))))))
+      (module-define! (current-module)
+                      symbol
+                      (if existing
+                          (make-extended-syncase-macro existing type val)
+                          (make-syncase-macro type val))))))

 
 (define get-global-definition-hook
   (lambda (symbol module)
 
 (define get-global-definition-hook
   (lambda (symbol module)

-    (let* ((module (if module
-                       (resolve-module module)
-                       (warn "wha" symbol (current-module))))
-           (v (module-variable module symbol)))
-      (and v
-           (or (object-property v '*sc-expander*)
-               (and (variable-bound? v)
-                    (macro? (variable-ref v))
-                    (macro-transformer (variable-ref v)) ;non-primitive
-                    guile-macro))))))
+    (if (and (not module) (current-module))
+        (warn "module system is booted, we should have a module" symbol))
+    (let ((v (module-variable (if module
+                                  (resolve-module (cdr module))
+                                  (current-module))
+                              symbol)))
+      (and v (variable-bound? v)
+           (let ((val (variable-ref v)))
+             (and (macro? val) (syncase-macro-type val)
+                  (cons (syncase-macro-type val)
+                        (syncase-macro-binding val))))))))
+

 )
 
 
 )
 
 


@@ -397,14 +395,20 @@
 (define-syntax build-global-reference
   (syntax-rules ()
     ((_ source var mod)
 (define-syntax build-global-reference
   (syntax-rules ()
     ((_ source var mod)

-     (build-annotated source
-      (make-module-ref mod var #f)))))
+     (build-annotated
+      source
+      (if mod
+          (make-module-ref (cdr mod) var (car mod))
+          (make-module-ref mod var 'bare))))))

 
 (define-syntax build-global-assignment
   (syntax-rules ()
     ((_ source var exp mod)
      (build-annotated source
 
 (define-syntax build-global-assignment
   (syntax-rules ()
     ((_ source var exp mod)
      (build-annotated source

-       `(set! ,(make-module-ref mod var #f) ,exp)))))
+       `(set! ,(if mod
+                   (make-module-ref (cdr mod) var (car mod))
+                   (make-module-ref mod var 'bare))
+              ,exp)))))

 
 (define-syntax build-global-definition
   (syntax-rules ()
 
 (define-syntax build-global-definition
   (syntax-rules ()


@@ -413,6 +417,9 @@
 
 (define-syntax build-lambda
   (syntax-rules ()
 
 (define-syntax build-lambda
   (syntax-rules ()

+    ((_ src vars docstring exp)
+     (build-annotated src `(lambda ,vars ,@(if docstring (list docstring) '())
+                                   ,exp)))

     ((_ src vars exp)
      (build-annotated src `(lambda ,vars ,exp)))))
 
     ((_ src vars exp)
      (build-annotated src `(lambda ,vars ,exp)))))
 


@@ -508,6 +515,7 @@
 ;;; <binding> ::= (macro . <procedure>)           macros
 ;;;               (core . <procedure>)            core forms
 ;;;               (external-macro . <procedure>)  external-macro
 ;;; <binding> ::= (macro . <procedure>)           macros
 ;;;               (core . <procedure>)            core forms
 ;;;               (external-macro . <procedure>)  external-macro

+;;;               (module-ref . <procedure>)      @ or @@

 ;;;               (begin)                         begin
 ;;;               (define)                        define
 ;;;               (define-syntax)                 define-syntax
 ;;;               (begin)                         begin
 ;;;               (define)                        define
 ;;;               (define-syntax)                 define-syntax


@@ -592,8 +600,7 @@
 
 (define global-extend
   (lambda (type sym val)
 
 (define global-extend
   (lambda (type sym val)

-    (put-global-definition-hook sym (make-binding type val)
-                                (module-name (current-module)))))
+    (put-global-definition-hook sym type val)))

 
 
 ;;; Conceptually, identifiers are always syntax objects.  Internally,
 
 
 ;;; Conceptually, identifiers are always syntax objects.  Internally,


@@ -900,8 +907,25 @@
 (define chi-install-global
   (lambda (name e)
     (build-application no-source
 (define chi-install-global
   (lambda (name e)
     (build-application no-source

-      (build-primref no-source 'install-global-transformer)
-      (list (build-data no-source name) e))))
+      (build-primref no-source 'define)
+      (list
+       name
+       ;; FIXME: seems nasty to call current-module here
+       (if (let ((v (module-variable (current-module) name)))
+             ;; FIXME use primitive-macro?
+             (and v (variable-bound? v) (macro? (variable-ref v))
+                  (not (eq? (macro-type (variable-ref v)) 'syncase-macro))))
+           (build-application no-source
+                              (build-primref no-source 'make-extended-syncase-macro)
+                              (list (build-application no-source
+                                                       (build-primref no-source 'module-ref)
+                                                       (list (build-application no-source 'current-module '())
+                                                             (build-data no-source name)))
+                                    (build-data no-source 'macro)
+                                    e))
+           (build-application no-source
+                              (build-primref no-source 'make-syncase-macro)
+                              (list (build-data no-source 'macro) e)))))))

 
 (define chi-when-list
   (lambda (e when-list w)
 
 (define chi-when-list
   (lambda (e when-list w)


@@ -915,8 +939,9 @@
                        ((free-id=? x (syntax compile)) 'compile)
                        ((free-id=? x (syntax load)) 'load)
                        ((free-id=? x (syntax eval)) 'eval)
                        ((free-id=? x (syntax compile)) 'compile)
                        ((free-id=? x (syntax load)) 'load)
                        ((free-id=? x (syntax eval)) 'eval)

-                       (else (syntax-error (wrap x w #f)
-                               "invalid eval-when situation"))))
+                       (else (syntax-violation 'eval-when
+                                               "invalid situation"
+                                               e (wrap x w #f)))))

                    situations))))))
 
 ;;; syntax-type returns six values: type, value, e, w, s, and mod. The
                    situations))))))
 
 ;;; syntax-type returns six values: type, value, e, w, s, and mod. The


@@ -926,6 +951,7 @@
 ;;;    -------------------------------------------------------------------
 ;;;    core                   procedure     core form (including singleton)
 ;;;    external-macro         procedure     external macro
 ;;;    -------------------------------------------------------------------
 ;;;    core                   procedure     core form (including singleton)
 ;;;    external-macro         procedure     external macro

+;;;    module-ref             procedure     @ or @@ form

 ;;;    lexical                name          lexical variable reference
 ;;;    global                 name          global variable reference
 ;;;    begin                  none          begin keyword
 ;;;    lexical                name          lexical variable reference
 ;;;    global                 name          global variable reference
 ;;;    begin                  none          begin keyword


@@ -984,7 +1010,7 @@
                  ((macro)
                   (syntax-type (chi-macro (binding-value b) e r w rib mod)
                     r empty-wrap s rib mod))
                  ((macro)
                   (syntax-type (chi-macro (binding-value b) e r w rib mod)
                     r empty-wrap s rib mod))

-                 ((core external-macro)
+                 ((core external-macro module-ref)

                   (values type (binding-value b) e w s mod))
                  ((local-syntax)
                   (values 'local-syntax-form (binding-value b) e w s mod))
                   (values type (binding-value b) e w s mod))
                  ((local-syntax)
                   (values 'local-syntax-form (binding-value b) e w s mod))


@@ -1099,19 +1125,16 @@
            (let* ((n (id-var-name value w))
                  (type (binding-type (lookup n r mod))))
              (case type
            (let* ((n (id-var-name value w))
                  (type (binding-type (lookup n r mod))))
              (case type

-               ((global)
+               ((global core macro module-ref)

                 (eval-if-c&e m
                   (build-global-definition s n (chi e r w mod) mod)
                   mod))
                ((displaced-lexical)
                 (eval-if-c&e m
                   (build-global-definition s n (chi e r w mod) mod)
                   mod))
                ((displaced-lexical)

-                (syntax-error (wrap value w mod) "identifier out of context"))
+                (syntax-violation #f "identifier out of context"
+                                  e (wrap value w mod)))

                (else
                (else

-               (if (eq? type 'external-macro)
-                   (eval-if-c&e m
-                      (build-global-definition s n (chi e r w mod) mod)
-                      mod)
-                   (syntax-error (wrap value w mod)
-                                 "cannot define keyword at top level"))))))
+                (syntax-violation #f "cannot define keyword at top level"
+                                  e (wrap value w mod))))))

           (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
 
 (define chi
           (else (eval-if-c&e m (chi-expr type value e r w s mod) mod)))))))
 
 (define chi


@@ -1129,6 +1152,10 @@
       ((core external-macro)
        ;; apply transformer
        (value e r w s mod))
       ((core external-macro)
        ;; apply transformer
        (value e r w s mod))

+      ((module-ref)
+       (call-with-values (lambda () (value e))
+         ;; we could add a public? arg here
+         (lambda (id mod) (build-global-reference s id mod))))

       ((lexical-call)
        (chi-application
          (build-lexical-reference 'fun (source-annotation (car e)) value)
       ((lexical-call)
        (chi-application
          (build-lexical-reference 'fun (source-annotation (car e)) value)


@@ -1156,14 +1183,16 @@
                 (chi-sequence (syntax (e1 e2 ...)) r w s mod)
                 (chi-void))))))
       ((define-form define-syntax-form)
                 (chi-sequence (syntax (e1 e2 ...)) r w s mod)
                 (chi-void))))))
       ((define-form define-syntax-form)

-       (syntax-error (wrap value w mod) "invalid context for definition of"))
+       (syntax-violation #f "definition in expression context"
+                         e (wrap value w mod)))

       ((syntax)
       ((syntax)

-       (syntax-error (source-wrap e w s mod)
-         "reference to pattern variable outside syntax form"))
+       (syntax-violation #f "reference to pattern variable outside syntax form"
+                         (source-wrap e w s mod)))

       ((displaced-lexical)
       ((displaced-lexical)

-       (syntax-error (source-wrap e w s mod)
-         "reference to identifier outside its scope"))
-      (else (syntax-error (source-wrap e w s mod))))))
+       (syntax-violation #f "reference to identifier outside its scope"
+                          (source-wrap e w s mod)))
+      (else (syntax-violation #f "unexpected syntax"
+                              (source-wrap e w s mod))))))

 
 (define chi-application
   (lambda (x e r w s mod)
 
 (define chi-application
   (lambda (x e r w s mod)


@@ -1195,7 +1224,14 @@
                                    (if rib
                                        (cons rib (cons 'shift s))
                                        (cons 'shift s)))
                                    (if rib
                                        (cons rib (cons 'shift s))
                                        (cons 'shift s)))

-                        (module-name (procedure-module p))))))) ;; hither the hygiene
+                        (let ((pmod (procedure-module p)))
+                          (if pmod
+                              ;; hither the hygiene
+                              (cons 'hygiene (module-name pmod))
+                              ;; but it's possible for the proc to have
+                              ;; no mod, if it was made before modules
+                              ;; were booted
+                              '(hygiene guile))))))))

               ((vector? x)
                (let* ((n (vector-length x)) (v (make-vector n)))
                  (do ((i 0 (fx+ i 1)))
               ((vector? x)
                (let* ((n (vector-length x)) (v (make-vector n)))
                  (do ((i 0 (fx+ i 1)))


@@ -1203,7 +1239,8 @@
                      (vector-set! v i
                        (rebuild-macro-output (vector-ref x i) m)))))
               ((symbol? x)
                      (vector-set! v i
                        (rebuild-macro-output (vector-ref x i) m)))))
               ((symbol? x)

-               (syntax-error x "encountered raw symbol in macro output"))
+               (syntax-violation #f "encountered raw symbol in macro output"
+                                 (source-wrap e w s mod) x))

               (else x))))
     (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
 
               (else x))))
     (rebuild-macro-output (p (wrap e (anti-mark w) mod)) (new-mark))))
 


@@ -1253,7 +1290,7 @@
       (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
                   (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
         (if (null? body)
       (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
                   (ids '()) (labels '()) (vars '()) (vals '()) (bindings '()))
         (if (null? body)

-            (syntax-error outer-form "no expressions in body")
+            (syntax-violation #f "no expressions in body" outer-form)

             (let ((e (cdar body)) (er (caar body)))
               (call-with-values
                 (lambda () (syntax-type e er empty-wrap no-source ribcage mod))
             (let ((e (cdar body)) (er (caar body)))
               (call-with-values
                 (lambda () (syntax-type e er empty-wrap no-source ribcage mod))


@@ -1302,8 +1339,9 @@
                                       (cdr body))))
                          (begin
                            (if (not (valid-bound-ids? ids))
                                       (cdr body))))
                          (begin
                            (if (not (valid-bound-ids? ids))

-                               (syntax-error outer-form
-                                 "invalid or duplicate identifier in definition"))
+                               (syntax-violation
+                                #f "invalid or duplicate identifier in definition"
+                                outer-form))

                            (let loop ((bs bindings) (er-cache #f) (r-cache #f))
                              (if (not (null? bs))
                                  (let* ((b (car bs)))
                            (let loop ((bs bindings) (er-cache #f) (r-cache #f))
                              (if (not (null? bs))
                                  (let* ((b (car bs)))


@@ -1332,15 +1370,19 @@
                                           (cdr body)))))))))))))))))
 
 (define chi-lambda-clause
                                           (cdr body)))))))))))))))))
 
 (define chi-lambda-clause

-  (lambda (e c r w mod k)
+  (lambda (e docstring c r w mod k)

     (syntax-case c ()
     (syntax-case c ()

+      ((args doc e1 e2 ...)
+       (and (string? (syntax->datum (syntax doc))) (not docstring))
+       (chi-lambda-clause e (syntax doc) (syntax (args e1 e2 ...)) r w mod k))

       (((id ...) e1 e2 ...)
        (let ((ids (syntax (id ...))))
          (if (not (valid-bound-ids? ids))
       (((id ...) e1 e2 ...)
        (let ((ids (syntax (id ...))))
          (if (not (valid-bound-ids? ids))

-             (syntax-error e "invalid parameter list in")
+             (syntax-violation 'lambda "invalid parameter list" e)

              (let ((labels (gen-labels ids))
                    (new-vars (map gen-var ids)))
                (k new-vars
              (let ((labels (gen-labels ids))
                    (new-vars (map gen-var ids)))
                (k new-vars

+                  docstring

                   (chi-body (syntax (e1 e2 ...))
                             e
                             (extend-var-env labels new-vars r)
                   (chi-body (syntax (e1 e2 ...))
                             e
                             (extend-var-env labels new-vars r)


@@ -1349,19 +1391,20 @@
       ((ids e1 e2 ...)
        (let ((old-ids (lambda-var-list (syntax ids))))
          (if (not (valid-bound-ids? old-ids))
       ((ids e1 e2 ...)
        (let ((old-ids (lambda-var-list (syntax ids))))
          (if (not (valid-bound-ids? old-ids))

-             (syntax-error e "invalid parameter list in")
+             (syntax-violation 'lambda "invalid parameter list" e)

              (let ((labels (gen-labels old-ids))
                    (new-vars (map gen-var old-ids)))
                (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
                     (if (null? ls1)
                         ls2
                         (f (cdr ls1) (cons (car ls1) ls2))))
              (let ((labels (gen-labels old-ids))
                    (new-vars (map gen-var old-ids)))
                (k (let f ((ls1 (cdr new-vars)) (ls2 (car new-vars)))
                     (if (null? ls1)
                         ls2
                         (f (cdr ls1) (cons (car ls1) ls2))))

+                  docstring

                   (chi-body (syntax (e1 e2 ...))
                             e
                             (extend-var-env labels new-vars r)
                             (make-binding-wrap old-ids labels w)
                             mod))))))
                   (chi-body (syntax (e1 e2 ...))
                             e
                             (extend-var-env labels new-vars r)
                             (make-binding-wrap old-ids labels w)
                             mod))))))

-      (_ (syntax-error e)))))
+      (_ (syntax-violation 'lambda "bad lambda" e)))))

 
 (define chi-local-syntax
   (lambda (rec? e r w s mod k)
 
 (define chi-local-syntax
   (lambda (rec? e r w s mod k)


@@ -1369,7 +1412,7 @@
       ((_ ((id val) ...) e1 e2 ...)
        (let ((ids (syntax (id ...))))
          (if (not (valid-bound-ids? ids))
       ((_ ((id val) ...) e1 e2 ...)
        (let ((ids (syntax (id ...))))
          (if (not (valid-bound-ids? ids))

-             (syntax-error e "duplicate bound keyword in")
+             (syntax-violation #f "duplicate bound keyword" e)

              (let ((labels (gen-labels ids)))
                (let ((new-w (make-binding-wrap ids labels w)))
                  (k (syntax (e1 e2 ...))
              (let ((labels (gen-labels ids)))
                (let ((new-w (make-binding-wrap ids labels w)))
                  (k (syntax (e1 e2 ...))


@@ -1387,14 +1430,15 @@
                     new-w
                     s
                     mod))))))
                     new-w
                     s
                     mod))))))

-      (_ (syntax-error (source-wrap e w s mod))))))
+      (_ (syntax-violation #f "bad local syntax definition"
+                           (source-wrap e w s mod))))))

 
 (define eval-local-transformer
   (lambda (expanded mod)
     (let ((p (local-eval-hook expanded mod)))
       (if (procedure? p)
           p
 
 (define eval-local-transformer
   (lambda (expanded mod)
     (let ((p (local-eval-hook expanded mod)))
       (if (procedure? p)
           p

-          (syntax-error p "nonprocedure transformer")))))
+          (syntax-violation #f "nonprocedure transformer" p)))))

 
 (define chi-void
   (lambda ()
 
 (define chi-void
   (lambda ()


@@ -1499,8 +1543,10 @@
            (lambda (id n)
              (case (binding-type (lookup n r mod))
                ((displaced-lexical)
            (lambda (id n)
              (case (binding-type (lookup n r mod))
                ((displaced-lexical)

-                (syntax-error (source-wrap id w s mod)
-                  "identifier out of context"))))
+                (syntax-violation 'fluid-let-syntax
+                                  "identifier out of context"
+                                  e
+                                  (source-wrap id w s mod)))))

            (syntax (var ...))
            names)
          (chi-body
            (syntax (var ...))
            names)
          (chi-body


@@ -1517,13 +1563,15 @@
              r)
            w
            mod)))
              r)
            w
            mod)))

-      (_ (syntax-error (source-wrap e w s mod))))))
+      (_ (syntax-violation 'fluid-let-syntax "bad syntax"
+                           (source-wrap e w s mod))))))

 
 (global-extend 'core 'quote
    (lambda (e r w s mod)
       (syntax-case e ()
          ((_ e) (build-data s (strip (syntax e) w)))
 
 (global-extend 'core 'quote
    (lambda (e r w s mod)
       (syntax-case e ()
          ((_ e) (build-data s (strip (syntax e) w)))

-         (_ (syntax-error (source-wrap e w s mod))))))
+         (_ (syntax-violation 'quote "bad syntax"
+                              (source-wrap e w s mod))))))

 
 (global-extend 'core 'syntax
   (let ()
 
 (global-extend 'core 'syntax
   (let ()


@@ -1539,7 +1587,7 @@
                           (gen-ref src (car var.lev) (cdr var.lev) maps)))
                       (lambda (var maps) (values `(ref ,var) maps)))
                     (if (ellipsis? e)
                           (gen-ref src (car var.lev) (cdr var.lev) maps)))
                       (lambda (var maps) (values `(ref ,var) maps)))
                     (if (ellipsis? e)

-                        (syntax-error src "misplaced ellipsis in syntax form")
+                        (syntax-violation 'syntax "misplaced ellipsis" src)

                         (values `(quote ,e) maps)))))
             (syntax-case e ()
               ((dots e)
                         (values `(quote ,e) maps)))))
             (syntax-case e ()
               ((dots e)


@@ -1557,8 +1605,8 @@
                                   (cons '() maps) ellipsis? mod))
                               (lambda (x maps)
                                 (if (null? (car maps))
                                   (cons '() maps) ellipsis? mod))
                               (lambda (x maps)
                                 (if (null? (car maps))

-                                    (syntax-error src
-                                      "extra ellipsis in syntax form")
+                                    (syntax-violation 'syntax "extra ellipsis"
+                                                      src)

                                     (values (gen-map x (car maps))
                                             (cdr maps))))))))
                  (syntax-case y ()
                                     (values (gen-map x (car maps))
                                             (cdr maps))))))))
                  (syntax-case y ()


@@ -1570,8 +1618,7 @@
                            (lambda () (k (cons '() maps)))
                            (lambda (x maps)
                              (if (null? (car maps))
                            (lambda () (k (cons '() maps)))
                            (lambda (x maps)
                              (if (null? (car maps))

-                                 (syntax-error src
-                                   "extra ellipsis in syntax form")
+                                 (syntax-violation 'syntax "extra ellipsis" src)

                                  (values (gen-mappend x (car maps))
                                          (cdr maps))))))))
                    (_ (call-with-values
                                  (values (gen-mappend x (car maps))
                                          (cdr maps))))))))
                    (_ (call-with-values


@@ -1600,7 +1647,7 @@
         (if (fx= level 0)
             (values var maps)
             (if (null? maps)
         (if (fx= level 0)
             (values var maps)
             (if (null? maps)

-                (syntax-error src "missing ellipsis in syntax form")
+                (syntax-violation 'syntax "missing ellipsis" src)

                 (call-with-values
                   (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
                   (lambda (outer-var outer-maps)
                 (call-with-values
                   (lambda () (gen-ref src var (fx- level 1) (cdr maps)))
                   (lambda (outer-var outer-maps)


@@ -1688,22 +1735,22 @@
            (call-with-values
              (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
              (lambda (e maps) (regen e))))
            (call-with-values
              (lambda () (gen-syntax e (syntax x) r '() ellipsis? mod))
              (lambda (e maps) (regen e))))

-          (_ (syntax-error e)))))))
+          (_ (syntax-violation 'syntax "bad `syntax' form" e)))))))

 
 
 (global-extend 'core 'lambda
    (lambda (e r w s mod)
       (syntax-case e ()
          ((_ . c)
 
 
 (global-extend 'core 'lambda
    (lambda (e r w s mod)
       (syntax-case e ()
          ((_ . c)

-          (chi-lambda-clause (source-wrap e w s mod) (syntax c) r w mod
-            (lambda (vars body) (build-lambda s vars body)))))))
+          (chi-lambda-clause (source-wrap e w s mod) #f (syntax c) r w mod
+            (lambda (vars docstring body) (build-lambda s vars docstring body)))))))

 
 
 (global-extend 'core 'let
   (let ()
     (define (chi-let e r w s mod constructor ids vals exps)
       (if (not (valid-bound-ids? ids))
 
 
 (global-extend 'core 'let
   (let ()
     (define (chi-let e r w s mod constructor ids vals exps)
       (if (not (valid-bound-ids? ids))

-         (syntax-error e "duplicate bound variable in")
+         (syntax-violation 'let "duplicate bound variable" e)

          (let ((labels (gen-labels ids))
                (new-vars (map gen-var ids)))
            (let ((nw (make-binding-wrap ids labels w))
          (let ((labels (gen-labels ids))
                (new-vars (map gen-var ids)))
            (let ((nw (make-binding-wrap ids labels w))


@@ -1728,7 +1775,7 @@
                  (syntax (f id ...))
                  (syntax (val ...))
                  (syntax (e1 e2 ...))))
                  (syntax (f id ...))
                  (syntax (val ...))
                  (syntax (e1 e2 ...))))

-       (_ (syntax-error (source-wrap e w s mod)))))))
+       (_ (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))

 
 
 (global-extend 'core 'letrec
 
 
 (global-extend 'core 'letrec


@@ -1737,7 +1784,7 @@
       ((_ ((id val) ...) e1 e2 ...)
        (let ((ids (syntax (id ...))))
          (if (not (valid-bound-ids? ids))
       ((_ ((id val) ...) e1 e2 ...)
        (let ((ids (syntax (id ...))))
          (if (not (valid-bound-ids? ids))

-             (syntax-error e "duplicate bound variable in")
+             (syntax-violation 'letrec "duplicate bound variable" e)

              (let ((labels (gen-labels ids))
                    (new-vars (map gen-var ids)))
                (let ((w (make-binding-wrap ids labels w))
              (let ((labels (gen-labels ids))
                    (new-vars (map gen-var ids)))
                (let ((w (make-binding-wrap ids labels w))


@@ -1747,7 +1794,7 @@
                    (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
                    (chi-body (syntax (e1 e2 ...)) 
                              (source-wrap e w s mod) r w mod)))))))
                    (map (lambda (x) (chi x r w mod)) (syntax (val ...)))
                    (chi-body (syntax (e1 e2 ...)) 
                              (source-wrap e w s mod) r w mod)))))))

-      (_ (syntax-error (source-wrap e w s mod))))))
+      (_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))

 
 
 (global-extend 'core 'set!
 
 
 (global-extend 'core 'set!


@@ -1763,15 +1810,44 @@
               (build-lexical-assignment s (binding-value b) val))
              ((global) (build-global-assignment s n val mod))
              ((displaced-lexical)
               (build-lexical-assignment s (binding-value b) val))
              ((global) (build-global-assignment s n val mod))
              ((displaced-lexical)

-              (syntax-error (wrap (syntax id) w mod)
-                "identifier out of context"))
-             (else (syntax-error (source-wrap e w s mod)))))))
-      ((_ (getter arg ...) val)
-       (build-application s
-                         (chi (syntax (setter getter)) r w mod)
-                         (map (lambda (e) (chi e r w mod))
-                              (syntax (arg ... val)))))
-      (_ (syntax-error (source-wrap e w s mod))))))
+              (syntax-violation 'set! "identifier out of context"
+                                (wrap (syntax id) w mod)))
+             (else (syntax-violation 'set! "bad set!"
+                                     (source-wrap e w s mod)))))))
+      ((_ (head tail ...) val)
+       (call-with-values
+           (lambda () (syntax-type (syntax head) r empty-wrap no-source #f mod))
+         (lambda (type value ee ww ss modmod)
+           (case type
+             ((module-ref)
+              (let ((val (chi (syntax val) r w mod)))
+                (call-with-values (lambda () (value (syntax (head tail ...))))
+                  (lambda (id mod)
+                    (build-global-assignment s id val mod)))))
+             (else
+              (build-application s
+                                 (chi (syntax (setter head)) r w mod)
+                                 (map (lambda (e) (chi e r w mod))
+                                      (syntax (tail ... val)))))))))
+      (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
+
+(global-extend 'module-ref '@
+   (lambda (e)
+     (syntax-case e ()
+        ((_ (mod ...) id)
+         (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
+         (values (syntax->datum (syntax id))
+                 (syntax->datum
+                  (syntax (public mod ...))))))))
+
+(global-extend 'module-ref '@@
+   (lambda (e)
+     (syntax-case e ()
+        ((_ (mod ...) id)
+         (and (andmap id? (syntax (mod ...))) (id? (syntax id)))
+         (values (syntax->datum (syntax id))
+                 (syntax->datum
+                  (syntax (private mod ...))))))))

 
 (global-extend 'begin 'begin '())
 
 
 (global-extend 'begin 'begin '())
 


@@ -1785,7 +1861,7 @@
   (let ()
     (define convert-pattern
       ; accepts pattern & keys
   (let ()
     (define convert-pattern
       ; accepts pattern & keys

-      ; returns syntax-dispatch pattern & ids
+      ; returns $sc-dispatch pattern & ids

       (lambda (pattern keys)
         (let cvt ((p pattern) (n 0) (ids '()))
           (if (id? p)
       (lambda (pattern keys)
         (let cvt ((p pattern) (n 0) (ids '()))
           (if (id? p)


@@ -1841,11 +1917,9 @@
           (lambda (p pvars)
             (cond
               ((not (distinct-bound-ids? (map car pvars)))
           (lambda (p pvars)
             (cond
               ((not (distinct-bound-ids? (map car pvars)))

-               (syntax-error pat
-                 "duplicate pattern variable in syntax-case pattern"))
+               (syntax-violation 'syntax-case "duplicate pattern variable" pat))

               ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
               ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))

-               (syntax-error pat
-                 "misplaced ellipsis in syntax-case pattern"))
+               (syntax-violation 'syntax-case "misplaced ellipsis" pat))

               (else
                (let ((y (gen-var 'tmp)))
                  ; fat finger binding and references to temp variable y
               (else
                (let ((y (gen-var 'tmp)))
                  ; fat finger binding and references to temp variable y


@@ -1866,15 +1940,15 @@
                                (build-primref no-source 'list)
                                (list x))
                              (build-application no-source
                                (build-primref no-source 'list)
                                (list x))
                              (build-application no-source

-                               (build-primref no-source 'syntax-dispatch)
+                               (build-primref no-source '$sc-dispatch)

                                (list x (build-data no-source p)))))))))))))
 
     (define gen-syntax-case
       (lambda (x keys clauses r mod)
         (if (null? clauses)
             (build-application no-source
                                (list x (build-data no-source p)))))))))))))
 
     (define gen-syntax-case
       (lambda (x keys clauses r mod)
         (if (null? clauses)
             (build-application no-source

-              (build-primref no-source 'syntax-error)
-              (list x))
+              (build-primref no-source 'syntax-violation)
+              (list #f "source expression failed to match any pattern" x))

             (syntax-case (car clauses) ()
               ((pat exp)
                (if (and (id? (syntax pat))
             (syntax-case (car clauses) ()
               ((pat exp)
                (if (and (id? (syntax pat))


@@ -1897,7 +1971,8 @@
               ((pat fender exp)
                (gen-clause x keys (cdr clauses) r
                  (syntax pat) (syntax fender) (syntax exp) mod))
               ((pat fender exp)
                (gen-clause x keys (cdr clauses) r
                  (syntax pat) (syntax fender) (syntax exp) mod))

-              (_ (syntax-error (car clauses) "invalid syntax-case clause"))))))
+              (_ (syntax-violation 'syntax-case "invalid clause"
+                                   (car clauses)))))))

 
     (lambda (e r w s mod)
       (let ((e (source-wrap e w s mod)))
 
     (lambda (e r w s mod)
       (let ((e (source-wrap e w s mod)))


@@ -1914,7 +1989,7 @@
                        r
                        mod))
                    (list (chi (syntax val) r empty-wrap mod))))
                        r
                        mod))
                    (list (chi (syntax val) r empty-wrap mod))))

-               (syntax-error e "invalid literals list in"))))))))
+               (syntax-violation 'syntax-case "invalid literals list" e))))))))

 
 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
 ;;; evaluating) and esew (which stands for "eval syntax expanders
 
 ;;; The portable sc-expand seeds chi-top's mode m with 'e (for
 ;;; evaluating) and esew (which stands for "eval syntax expanders


@@ -1931,7 +2006,7 @@
       (if (and (pair? x) (equal? (car x) noexpand))
           (cadr x)
           (chi-top x null-env top-wrap m esew
       (if (and (pair? x) (equal? (car x) noexpand))
           (cadr x)
           (chi-top x null-env top-wrap m esew

-                   (module-name (current-module)))))))
+                   (cons 'hygiene (module-name (current-module))))))))

 
 (set! sc-expand3
   (let ((m 'e) (esew '(eval)))
 
 (set! sc-expand3
   (let ((m 'e) (esew '(eval)))


@@ -1945,17 +2020,17 @@
                   (if (or (null? rest) (null? (cdr rest)))
                       esew
                       (cadr rest))
                   (if (or (null? rest) (null? (cdr rest)))
                       esew
                       (cadr rest))

-                   (module-name (current-module)))))))
+                   (cons 'hygiene (module-name (current-module))))))))

 
 (set! identifier?
   (lambda (x)
     (nonsymbol-id? x)))
 
 
 (set! identifier?
   (lambda (x)
     (nonsymbol-id? x)))
 

-(set! datum->syntax-object
+(set! datum->syntax

   (lambda (id datum)
     (make-syntax-object datum (syntax-object-wrap id) #f)))
 
   (lambda (id datum)
     (make-syntax-object datum (syntax-object-wrap id) #f)))
 

-(set! syntax-object->datum
+(set! syntax->datum

   ; accepts any object, since syntax objects may consist partially
   ; or entirely of unwrapped, nonsymbolic data
   (lambda (x)
   ; accepts any object, since syntax objects may consist partially
   ; or entirely of unwrapped, nonsymbolic data
   (lambda (x)


@@ -1978,21 +2053,23 @@
       (arg-check nonsymbol-id? y 'bound-identifier=?)
       (bound-id=? x y)))
 
       (arg-check nonsymbol-id? y 'bound-identifier=?)
       (bound-id=? x y)))
 

-(set! syntax-error
-  (lambda (object . messages)
-    (for-each (lambda (x) (arg-check string? x 'syntax-error)) messages)
-    (let ((message (if (null? messages)
-                       "invalid syntax"
-                       (apply string-append messages))))
-      (error-hook #f message (strip object empty-wrap)))))
-
-(set! install-global-transformer
-  (lambda (sym v)
-    (arg-check symbol? sym 'define-syntax)
-    (arg-check procedure? v 'define-syntax)
-    (global-extend 'macro sym v)))
-
-;;; syntax-dispatch expects an expression and a pattern.  If the expression
+(set! syntax-violation
+  (lambda (who message form . subform)
+    (arg-check (lambda (x) (or (not x) (string? x) (symbol? x)))
+               who 'syntax-violation)
+    (arg-check string? message 'syntax-violation)
+    (scm-error 'syntax-error 'sc-expand
+               (string-append
+                (if who "~a: " "")
+                "~a "
+                (if (null? subform) "in ~a" "in subform `~s' of `~s'"))
+               (let ((tail (cons message
+                                 (map (lambda (x) (strip x empty-wrap))
+                                      (append subform (list form))))))
+                 (if who (cons who tail) tail))
+               #f)))
+
+;;; $sc-dispatch expects an expression and a pattern.  If the expression

 ;;; matches the pattern a list of the matching expressions for each
 ;;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
 ;;; not work on r4rs implementations that violate the ieee requirement
 ;;; matches the pattern a list of the matching expressions for each
 ;;; "any" is returned.  Otherwise, #f is returned.  (This use of #f will
 ;;; not work on r4rs implementations that violate the ieee requirement


@@ -2103,7 +2180,7 @@
          (syntax-object-module e)))
       (else (match* (unannotate e) p w r mod)))))
 
          (syntax-object-module e)))
       (else (match* (unannotate e) p w r mod)))))
 

-(set! syntax-dispatch
+(set! $sc-dispatch

   (lambda (e p)
     (cond
       ((eq? p 'any) (list e))
   (lambda (e p)
     (cond
       ((eq? p 'any) (list e))


@@ -2112,7 +2189,6 @@
          p (syntax-object-wrap e) '() (syntax-object-module e)))
       (else (match* (unannotate e) p empty-wrap '() #f)))))
 
          p (syntax-object-wrap e) '() (syntax-object-module e)))
       (else (match* (unannotate e) p empty-wrap '() #f)))))
 

-(set! sc-chi chi)

 ))
 )
 
 ))
 )
 


@@ -2157,7 +2233,9 @@
                                  (syntax-case s ()
                                     (() v)
                                     ((e) (syntax e))
                                  (syntax-case s ()
                                     (() v)
                                     ((e) (syntax e))

-                                    (_ (syntax-error orig-x))))
+                                    (_ (syntax-violation
+                                        'do "bad step expression" 
+                                        orig-x s))))

                               (syntax (var ...))
                               (syntax (step ...)))))
              (syntax-case (syntax (e1 ...)) ()
                               (syntax (var ...))
                               (syntax (step ...)))))
              (syntax-case (syntax (e1 ...)) ()


@@ -2230,11 +2308,11 @@
           (let f ((x (read p)))
             (if (eof-object? x)
                 (begin (close-input-port p) '())
           (let f ((x (read p)))
             (if (eof-object? x)
                 (begin (close-input-port p) '())

-                (cons (datum->syntax-object k x)
+                (cons (datum->syntax k x)

                       (f (read p))))))))
     (syntax-case x ()
       ((k filename)
                       (f (read p))))))))
     (syntax-case x ()
       ((k filename)

-       (let ((fn (syntax-object->datum (syntax filename))))
+       (let ((fn (syntax->datum (syntax filename))))

          (with-syntax (((exp ...) (read-file fn (syntax k))))
            (syntax (begin exp ...))))))))
 
          (with-syntax (((exp ...) (read-file fn (syntax k))))
            (syntax (begin exp ...))))))))
 


@@ -2244,7 +2322,7 @@
          ((_ e)
           (error 'unquote
                 "expression ,~s not valid outside of quasiquote"
          ((_ e)
           (error 'unquote
                 "expression ,~s not valid outside of quasiquote"

-                (syntax-object->datum (syntax e)))))))
+                (syntax->datum (syntax e)))))))

 
 (define-syntax unquote-splicing
    (lambda (x)
 
 (define-syntax unquote-splicing
    (lambda (x)


@@ -2252,7 +2330,7 @@
          ((_ e)
           (error 'unquote-splicing
                 "expression ,@~s not valid outside of quasiquote"
          ((_ e)
           (error 'unquote-splicing
                 "expression ,@~s not valid outside of quasiquote"

-                (syntax-object->datum (syntax e)))))))
+                (syntax->datum (syntax e)))))))

 
 (define-syntax case
   (lambda (x)
 
 (define-syntax case
   (lambda (x)


@@ -2265,14 +2343,15 @@
                         ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
                         (((k ...) e1 e2 ...)
                          (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))
                         ((else e1 e2 ...) (syntax (begin e1 e2 ...)))
                         (((k ...) e1 e2 ...)
                          (syntax (if (memv t '(k ...)) (begin e1 e2 ...))))

-                        (_ (syntax-error x)))
+                        (_ (syntax-violation 'case "bad clause" x clause)))

                       (with-syntax ((rest (f (car clauses) (cdr clauses))))
                         (syntax-case clause (else)
                           (((k ...) e1 e2 ...)
                            (syntax (if (memv t '(k ...))
                                        (begin e1 e2 ...)
                                        rest)))
                       (with-syntax ((rest (f (car clauses) (cdr clauses))))
                         (syntax-case clause (else)
                           (((k ...) e1 e2 ...)
                            (syntax (if (memv t '(k ...))
                                        (begin e1 e2 ...)
                                        rest)))

-                          (_ (syntax-error x))))))))
+                          (_ (syntax-violation 'case "bad clause" x
+                                               clause))))))))

          (syntax (let ((t e)) body)))))))
 
 (define-syntax identifier-syntax
          (syntax (let ((t e)) body)))))))
 
 (define-syntax identifier-syntax