From: Chris Hanson Date: Fri, 21 Dec 2001 05:18:22 +0000 (+0000) Subject: Change DEFINE-SYNTAX so that it emits code to define the macro at run X-Git-Tag: 20090517-FFI~2323 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=07b06ee3d2e9d8c3a7b1428ebf8320521346280e;p=mit-scheme.git 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 a9c9db94e..ede9c70b2 100644 --- 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) (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 242aacb39..4245e125f 100644 --- 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 9a9ce08b7..49828eb5b 100644 --- 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 383512f8d..425052a38 100644 --- 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)) +(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))) (define (ic-environment/bound-names environment) (map-ic-environment-bindings environment