Change DEFINE-SYNTAX so that it emits code to define the macro at run

time when written at top level.

diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm
index a9c9db94eda6f443927b3e7cf19f512592d6d45c..ede9c70b2e8a8a9303aa04214a24a48ad9e6d41c 100644 (file)
--- a/v7/src/runtime/make.scm
+++ b/v7/src/runtime/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 14.78 2001/12/21 01:56:48 cph Exp $
+$Id: make.scm,v 14.79 2001/12/21 05:17:59 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -62,6 +62,8 @@ USA.
                                               names)
                             parent)
           values))))
+
+(define environment-define-macro)
 \f
 (let ((environment-for-package
        (*make-environment system-global-environment
@@ -71,6 +73,10 @@ USA.
   (lambda arguments
     (apply make-primitive-procedure arguments)))
 
+(define-syntax ucode-type
+  (lambda (name)
+    (microcode-type name)))
+
 (define-integrable + (ucode-primitive integer-add))
 (define-integrable - (ucode-primitive integer-subtract))
 (define-integrable < (ucode-primitive integer-less?))
@@ -113,6 +119,15 @@ USA.
 (define-integrable substring-move-right!
   (ucode-primitive substring-move-right!))
 
+;; This definition is replaced later in the boot sequence.
+(set! environment-define-macro
+      (lambda (environment name transformer)
+       (local-assignment environment
+                         name
+                         ((ucode-primitive primitive-object-set-type)
+                          (ucode-type reference-trap)
+                          (cons 15 transformer)))))
+
 (define microcode-identification (microcode-identify))
 (define os-name-string (vector-ref microcode-identification 8))
 (define tty-output-descriptor (tty-output-channel))
@@ -429,6 +444,7 @@ USA.
    (RUNTIME SCODE-WALKER)
    (RUNTIME CONTINUATION-PARSER)
    (RUNTIME PROGRAM-COPIER)
+   (RUNTIME ENVIRONMENT)
    ;; Generic Procedures
    ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING! #t)
    ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES! #t)

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 242aacb398221dc3908d082ac9e0322e021e812d..4245e125fde51da420740de1a00447c2c05b415b 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.398 2001/12/21 04:37:41 cph Exp $
+$Id: runtime.pkg,v 14.399 2001/12/21 05:18:12 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -1326,7 +1326,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
          environment-bound-names
          environment-bound?
          environment-define
-         environment-define-macro
+         ;; Defined in "make.scm":
+         ;; environment-define-macro
          environment-has-parent?
          environment-lambda
          environment-lookup
@@ -1344,7 +1345,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
          ic-environment/arguments
          ic-environment/procedure)
   (export (runtime debugging-info)
-         stack-frame/environment))
+         stack-frame/environment)
+  (initialization (initialize-package!)))
 
 (define-package (runtime environment-inspector)
   (files "where")

diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm
index 9a9ce08b736316853613ff7a59dc4dccdbf5594a..49828eb5b7398f5c5a14ec0ceb872b5ff9307184 100644 (file)
--- a/v7/src/runtime/syntax.scm
+++ b/v7/src/runtime/syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: syntax.scm,v 14.46 2001/12/20 21:28:41 cph Exp $
+$Id: syntax.scm,v 14.47 2001/12/21 05:18:17 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -437,12 +437,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
        (syntax-sequence top-level? body)))))
 
 (define (syntax/define-syntax top-level? name value)
-  top-level?
   (if (not (symbol? name))
       (syntax-error "illegal name" name))
-  (syntax-table/define *syntax-table* name
-    (syntax-eval (syntax-subexpression value)))
-  name)
+  (syntax-table/define *syntax-table*
+                      name
+                      (syntax-eval (syntax-subexpression value)))
+  (if top-level?
+      (syntax-expression
+       top-level?
+       `((ACCESS ENVIRONMENT-DEFINE-MACRO #F) (THE-ENVIRONMENT) ',name ,value))
+      name))
 
 (define-integrable (syntax-eval scode)
   (extended-scode-eval scode syntaxer/default-environment))

diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm
index 383512f8d28bdc3634200a67d95a89a3d868f5d0..425052a38bb2deb5158516fd871b88c7fe4c2832 100644 (file)
--- a/v7/src/runtime/uenvir.scm
+++ b/v7/src/runtime/uenvir.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: uenvir.scm,v 14.48 2001/12/21 04:37:46 cph Exp $
+$Id: uenvir.scm,v 14.49 2001/12/21 05:18:22 cph Exp $
 
 Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
@@ -25,6 +25,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 
 (declare (usual-integrations))
 \f
+(define (initialize-package!)
+  ;; This variable is predefined in "make.scm" for the boot sequence.
+  ;; Otherwise it would be defined here.
+  (set! environment-define-macro real-environment-define-macro)
+  unspecific)
+
 (define (environment? object)
   (or (system-global-environment? object)
       (ic-environment? object)
@@ -189,14 +195,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
        (else
         (illegal-environment environment 'ENVIRONMENT-DEFINE))))
 
-(define (environment-define-macro environment name value)
-  (cond ((interpreter-environment? environment)
-        (interpreter-environment/define-macro environment name value))
-       ((or (stack-ccenv? environment)
-            (closure-ccenv? environment))
-        (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO))
-       (else
-        (illegal-environment environment 'ENVIRONMENT-DEFINE-MACRO))))
+(define real-environment-define-macro
+  (named-lambda (environment-define-macro environment name value)
+    (cond ((interpreter-environment? environment)
+          (interpreter-environment/define-macro environment name value))
+         ((or (stack-ccenv? environment)
+              (closure-ccenv? environment))
+          (error:bad-range-argument environment 'ENVIRONMENT-DEFINE-MACRO))
+         (else
+          (illegal-environment environment 'ENVIRONMENT-DEFINE-MACRO)))))
 
 (define (illegal-environment object procedure)
   (error:wrong-type-argument object "environment" procedure))
@@ -311,12 +318,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
   unspecific)
 
 (define (interpreter-environment/define environment name value)
-  (local-assignment environment name value)
-  unspecific)
+  (local-assignment environment name value))
 
 (define (interpreter-environment/define-macro environment name value)
-  (local-assignment environment name (macro->unmapped-reference-trap value))
-  unspecific)
+  (local-assignment environment name (macro->unmapped-reference-trap value)))
 \f
 (define (ic-environment/bound-names environment)
   (map-ic-environment-bindings environment