From d6ede0477ae35d34cdb97d0775c5c773769ca6fa Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 21 Dec 2001 04:37:56 +0000 Subject: [PATCH] Implement support for storing macro transformers in environments. --- v7/src/microcode/errors.h | 4 +- v7/src/microcode/lookprm.c | 75 +++++++++++++++-- v7/src/microcode/lookup.c | 24 +++++- v7/src/microcode/sdata.h | 6 +- v7/src/microcode/trap.h | 8 +- v7/src/microcode/utabmd.scm | 6 +- v7/src/microcode/version.h | 6 +- v7/src/runtime/error.scm | 14 +++- v7/src/runtime/runtime.pkg | 16 +++- v7/src/runtime/uenvir.scm | 136 ++++++++++++++++++++++++------ v7/src/runtime/uerror.scm | 159 +++++++++++++++++++----------------- v7/src/runtime/urtrap.scm | 22 ++++- 12 files changed, 350 insertions(+), 126 deletions(-) diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h index 56e29fe67..35babcc53 100644 --- a/v7/src/microcode/errors.h +++ b/v7/src/microcode/errors.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: errors.h,v 9.43 2001/03/08 17:03:30 cph Exp $ +$Id: errors.h,v 9.44 2001/12/21 04:35:57 cph Exp $ Copyright (c) 1987-2001 Massachusetts Institute of Technology @@ -48,7 +48,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. #define ERR_ARG_1_BAD_RANGE 0x10 #define ERR_ARG_2_BAD_RANGE 0x11 #define ERR_ARG_3_BAD_RANGE 0x12 -/* #define ERR_BAD_COMBINATION 0x13 */ +#define ERR_MACRO_BINDING 0x13 /* #define ERR_FASDUMP_OVERFLOW 0x14 */ #define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */ /* #define ERR_NO_ERRORS 0x16 */ diff --git a/v7/src/microcode/lookprm.c b/v7/src/microcode/lookprm.c index e8af96e82..6e324ab17 100644 --- a/v7/src/microcode/lookprm.c +++ b/v7/src/microcode/lookprm.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookprm.c,v 1.16 2001/08/22 05:01:25 cph Exp $ +$Id: lookprm.c,v 1.17 2001/12/21 04:36:01 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -108,6 +108,72 @@ Indistinguishable from evaluating (define SYMBOL VALUE) in ENVIRONMENT.") PRIMITIVE_RETURN (ARG_REF (2)); } +DEFINE_PRIMITIVE ("LEXICAL-REFERENCE-TYPE", Prim_lexical_reference_type, 2, 2, + "(ENVIRONMENT SYMBOL)\n\ +Returns a index integer indicating the type of object stored in the\n\ +binding of SYMBOL within ENVIRONMENT. The following values are defined:\n\ +\n\ +0 means unbound +1 means unassigned +2 means a normal binding +3 means a macro binding") +{ + PRIMITIVE_HEADER (2); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + { + SCHEME_OBJECT value; + long result = (lookup_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); + switch (result) + { + case ERR_UNBOUND_VARIABLE: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0)); + case ERR_UNASSIGNED_VARIABLE: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1)); + case PRIM_DONE: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (2)); + case ERR_MACRO_BINDING: + PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (3)); + case PRIM_INTERRUPT: + signal_interrupt_from_primitive (); + break; + default: + signal_error_from_primitive (result); + break; + } + } +} + +DEFINE_PRIMITIVE ("SAFE-LEXICAL-REFERENCE", Prim_safe_lexical_reference, 2, 2, + "(ENVIRONMENT SYMBOL)\n\ +Looks up SYMBOL in ENVIRONMENT and returns its value.\n\ +If the variable is unbound, signals an error.\n\ +If the variable is unassigned or holds a macro transformer, + returns the appropriate trap object.") +{ + PRIMITIVE_HEADER (2); + CHECK_ARG (1, ENVIRONMENT_P); + CHECK_ARG (2, SYMBOL_P); + { + SCHEME_OBJECT value; + long result = (lookup_variable ((ARG_REF (1)), (ARG_REF (2)), (&value))); + switch (result) + { + case PRIM_DONE: + case ERR_MACRO_BINDING: + PRIMITIVE_RETURN (value); + case ERR_UNASSIGNED_VARIABLE: + PRIMITIVE_RETURN (UNASSIGNED_OBJECT); + case PRIM_INTERRUPT: + signal_interrupt_from_primitive (); + break; + default: + signal_error_from_primitive (result); + break; + } + } +} + DEFINE_PRIMITIVE ("LEXICAL-UNASSIGNED?", Prim_unassigned_test, 2, 2, "(ENVIRONMENT SYMBOL)\n\ Returns #T if the variable corresponding to SYMBOL is bound\n\ @@ -131,8 +197,7 @@ DEFINE_PRIMITIVE ("LEXICAL-UNBOUND?", Prim_unbound_test, 2, 2, "(ENVIRONMENT SYMBOL)\n\ Returns #T if the variable corresponding to SYMBOL has no binding in\n\ ENVIRONMENT. Returns #F otherwise. Does a complete lexical search\n\ -for SYMBOL starting in ENVIRONMENT. The special form (unbound?\n\ -) is built on top of this.") +for SYMBOL starting in ENVIRONMENT.") { PRIMITIVE_HEADER (2); CHECK_ARG (1, ENVIRONMENT_P); @@ -146,8 +211,8 @@ for SYMBOL starting in ENVIRONMENT. The special form (unbound?\n\ DEFINE_PRIMITIVE ("LEXICAL-UNREFERENCEABLE?", Prim_unreferenceable_test, 2, 2, "(ENVIRONMENT SYMBOL)\n\ -Returns #T if evaluating SYMBOL in ENVIRONMENT would cause a\n\ -variable lookup error (unbound or unassigned).") +Returns #T if looking up SYMBOL in ENVIRONMENT would cause an error.\n\ +Returns #F otherwise.") { PRIMITIVE_HEADER (2); { diff --git a/v7/src/microcode/lookup.c b/v7/src/microcode/lookup.c index e0bdd2b82..283d2872a 100644 --- a/v7/src/microcode/lookup.c +++ b/v7/src/microcode/lookup.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: lookup.c,v 9.66 2001/12/07 03:57:00 cph Exp $ +$Id: lookup.c,v 9.67 2001/12/21 04:36:07 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -209,6 +209,10 @@ lookup_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, case TRAP_UNBOUND: return (ERR_UNBOUND_VARIABLE); + case TRAP_MACRO: + (*value_ret) = value; + return (ERR_MACRO_BINDING); + case TRAP_COMPILER_CACHED: return (lookup_variable_cache ((GET_TRAP_CACHE (value)), value_ret)); @@ -233,6 +237,10 @@ lookup_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT * value_ret) case TRAP_UNBOUND: return (ERR_UNBOUND_VARIABLE); + case TRAP_MACRO: + (*value_ret) = (GET_TRAP_EXTRA (value)); + return (ERR_MACRO_BINDING); + default: return (ERR_ILLEGAL_REFERENCE_TRAP); } @@ -285,6 +293,7 @@ variable_unbound_p (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, return (PRIM_DONE); case ERR_UNASSIGNED_VARIABLE: + case ERR_MACRO_BINDING: case PRIM_DONE: (*value_ret) = SHARP_F; return (PRIM_DONE); @@ -304,6 +313,7 @@ variable_unreferenceable_p (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, { case ERR_UNBOUND_VARIABLE: case ERR_UNASSIGNED_VARIABLE: + case ERR_MACRO_BINDING: (*value_ret) = SHARP_T; return (PRIM_DONE); @@ -351,6 +361,11 @@ assign_variable_end (SCHEME_OBJECT * cell, SCHEME_OBJECT value, break; return (ERR_UNBOUND_VARIABLE); + case TRAP_MACRO: + if (force_p) + break; + return (ERR_MACRO_BINDING); + case TRAP_COMPILER_CACHED: return (assign_variable_cache @@ -380,6 +395,11 @@ assign_variable_cache (SCHEME_OBJECT cache, SCHEME_OBJECT value, break; return (ERR_UNBOUND_VARIABLE); + case TRAP_MACRO: + if (force_p) + break; + return (ERR_MACRO_BINDING); + default: return (ERR_ILLEGAL_REFERENCE_TRAP); } @@ -611,6 +631,7 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, case NON_TRAP_KIND: case TRAP_UNASSIGNED: + case TRAP_MACRO: unbind_variable_1 (cell, frame, symbol); (*value_ret) = SHARP_T; return (PRIM_DONE); @@ -626,6 +647,7 @@ unbind_variable (SCHEME_OBJECT environment, SCHEME_OBJECT symbol, case NON_TRAP_KIND: case TRAP_UNASSIGNED: + case TRAP_MACRO: if (PROCEDURE_FRAME_P (frame)) { RETURN_IF_ERROR diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h index 9305634b3..62acaa931 100644 --- a/v7/src/microcode/sdata.h +++ b/v7/src/microcode/sdata.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: sdata.h,v 9.38 2001/08/07 01:27:09 cph Exp $ +$Id: sdata.h,v 9.39 2001/12/21 04:36:11 cph Exp $ Copyright (c) 1987-1989, 1999, 2001 Massachusetts Institute of Technology @@ -425,9 +425,11 @@ USA. #define GET_TRAP_TAG(object) \ (MEMORY_REF ((object), TRAP_TAG)) -#define GET_TRAP_CACHE(object) \ +#define GET_TRAP_EXTRA(object) \ (MEMORY_REF ((object), TRAP_EXTRA)) +#define GET_TRAP_CACHE GET_TRAP_EXTRA + #define CACHE_CELL HUNK3_CXR0 #define CACHE_CLONE HUNK3_CXR1 #define CACHE_REFERENCES HUNK3_CXR2 diff --git a/v7/src/microcode/trap.h b/v7/src/microcode/trap.h index 5234adb2d..c1342804c 100644 --- a/v7/src/microcode/trap.h +++ b/v7/src/microcode/trap.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: trap.h,v 9.48 2001/08/07 01:27:13 cph Exp $ +$Id: trap.h,v 9.49 2001/12/21 04:36:15 cph Exp $ Copyright (c) 1987-1989, 1999-2001 Massachusetts Institute of Technology @@ -42,6 +42,7 @@ typedef unsigned long trap_kind_t; /* The following are non-immediate traps: */ #define TRAP_COMPILER_CACHED 14 +#define TRAP_MACRO 15 /* Usages of the above traps: TRAP_UNASSIGNED can appear in a value cell or a cache. @@ -60,7 +61,10 @@ typedef unsigned long trap_kind_t; assignments to this cache to trap out to the microcode, where the updating of the variable's associated UUO links can be performed. TRAP_COMPILER_CACHED can only appear in a value cell. It is used - to associate a cache with the variable. */ + to associate a cache with the variable. + TRAP_MACRO can appear in a value cell or a cache. It is used for + storage of macro transformers in the environment structure. +*/ /* The following never appear in value cells. */ /* NON_TRAP_KIND is returned by get_trap_kind when its argument is not diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index aaa4ba83a..60896637e 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Id: utabmd.scm,v 9.80 2001/12/20 20:51:16 cph Exp $ +;;; $Id: utabmd.scm,v 9.81 2001/12/21 04:36:19 cph Exp $ ;;; ;;; Copyright (c) 1987-2001 Massachusetts Institute of Technology ;;; @@ -493,7 +493,7 @@ BAD-RANGE-ARGUMENT-0 ;10 BAD-RANGE-ARGUMENT-1 ;11 BAD-RANGE-ARGUMENT-2 ;12 - #F ;13 + MACRO-BINDING ;13 #F ;14 BAD-INTERRUPT-CODE ;15 #F ;16 @@ -607,4 +607,4 @@ ;;; This identification string is saved by the system. -"$Id: utabmd.scm,v 9.80 2001/12/20 20:51:16 cph Exp $" +"$Id: utabmd.scm,v 9.81 2001/12/21 04:36:19 cph Exp $" diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 309258c23..8c74ae13c 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: version.h,v 11.182 2001/12/16 06:01:33 cph Exp $ +$Id: version.h,v 11.183 2001/12/21 04:36:27 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -25,7 +25,7 @@ USA. /* Scheme system release version */ #ifndef SCHEME_RELEASE -#define SCHEME_RELEASE "7.5.18" +#define SCHEME_RELEASE "7.7.0" #endif /* Microcode release version */ @@ -34,5 +34,5 @@ USA. #define SCHEME_VERSION 14 #endif #ifndef SCHEME_SUBVERSION -#define SCHEME_SUBVERSION 7 +#define SCHEME_SUBVERSION 8 #endif diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 97890d62f..313474877 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.53 2001/12/20 20:51:16 cph Exp $ +$Id: error.scm,v 14.54 2001/12/21 04:37:29 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -676,6 +676,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define condition-type:floating-point-underflow) (define condition-type:illegal-datum) (define condition-type:illegal-pathname-component) +(define condition-type:macro-binding) (define condition-type:no-such-restart) (define condition-type:port-error) (define condition-type:serious-condition) @@ -703,6 +704,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define error:derived-port) (define error:derived-thread) (define error:illegal-pathname-component) +(define error:macro-binding) (define error:wrong-number-of-arguments) (define error:wrong-type-argument) (define error:wrong-type-datum) @@ -1058,6 +1060,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (write-string "Unassigned variable: " port) (write (access-condition condition 'LOCATION) port)))) + (set! condition-type:macro-binding + (make-condition-type 'MACRO-BINDING condition-type:variable-error '() + (lambda (condition port) + (write-string "Variable reference to a syntactic keyword: " port) + (write (access-condition condition 'LOCATION) port)))) + (let ((arithmetic-error-report (lambda (description) (lambda (condition port) @@ -1126,6 +1134,10 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (condition-signaller condition-type:no-such-restart '(NAME) standard-error-handler)) + (set! error:macro-binding + (condition-signaller condition-type:macro-binding + '(ENVIRONMENT LOCATION) + standard-error-handler)) unspecific) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 8ba47922c..242aacb39 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.397 2001/12/21 01:57:19 cph Exp $ +$Id: runtime.pkg,v 14.398 2001/12/21 04:37:41 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -1326,9 +1326,12 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA environment-bound-names environment-bound? environment-define + environment-define-macro environment-has-parent? environment-lambda environment-lookup + environment-lookup-macro + environment-macro-names environment-parent environment-procedure-name environment? @@ -1387,6 +1390,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA condition-type:floating-point-underflow condition-type:illegal-datum condition-type:illegal-pathname-component + condition-type:macro-binding condition-type:no-such-restart condition-type:port-error condition-type:serious-condition @@ -1469,6 +1473,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (export (runtime stream) ordinal-number-string write-operator) + (export (runtime environment) + error:macro-binding) (initialization (initialize-package!))) (define-package (runtime event-distributor) @@ -2658,12 +2664,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (export () cached-reference-trap-value cached-reference-trap? + macro->reference-trap + macro-reference-trap? + macro->unmapped-reference-trap make-unassigned-reference-trap make-unbound-reference-trap make-unmapped-unassigned-reference-trap make-unmapped-unbound-reference-trap map-reference-trap map-reference-trap-value + reference-trap->macro reference-trap-kind reference-trap-kind-name reference-trap? @@ -3741,9 +3751,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA syntax-table/extend syntax-table/parent syntax-table/ref - syntax-table?) - (export (runtime environment) - syntax-table-tag)) + syntax-table?)) (define-package (runtime syntaxer) (files "syntax") diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index a7d81893c..383512f8d 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: uenvir.scm,v 14.47 2001/12/19 04:18:37 cph Exp $ +$Id: uenvir.scm,v 14.48 2001/12/21 04:37:46 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -67,6 +67,17 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (else (illegal-environment environment 'ENVIRONMENT-BOUND-NAMES)))) +(define (environment-macro-names environment) + (cond ((system-global-environment? environment) + (system-global-environment/macro-names)) + ((ic-environment? environment) + (ic-environment/macro-names environment)) + ((or (stack-ccenv? environment) + (closure-ccenv? environment)) + '()) + (else + (illegal-environment environment 'ENVIRONMENT-MACRO-NAMES)))) + (define (environment-bindings environment) (cond ((system-global-environment? environment) (system-global-environment/bindings)) @@ -80,7 +91,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA '() (list value))))) (environment-bound-names environment))))) - + (define (environment-arguments environment) (cond ((ic-environment? environment) (ic-environment/arguments environment)) @@ -128,7 +139,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (closure-ccenv/assigned? environment name)) (else (illegal-environment environment 'ENVIRONMENT-ASSIGNED?)))) - + (define (environment-lookup environment name) (cond ((interpreter-environment? environment) (interpreter-environment/lookup environment name)) @@ -139,6 +150,16 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (else (illegal-environment environment 'ENVIRONMENT-LOOKUP)))) +(define (environment-lookup-macro environment name) + (cond ((interpreter-environment? environment) + (interpreter-environment/lookup-macro environment name)) + ((stack-ccenv? environment) + (stack-ccenv/lookup-macro environment name)) + ((closure-ccenv? environment) + (closure-ccenv/lookup-macro environment name)) + (else + (illegal-environment environment 'ENVIRONMENT-LOOKUP-MACRO)))) + (define (environment-assignable? environment name) (cond ((interpreter-environment? environment) #t) @@ -168,6 +189,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 (illegal-environment object procedure) (error:wrong-type-argument object "environment" procedure)) @@ -177,22 +207,32 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (eq? system-global-environment object)) (define (system-global-environment/bound-names) - (walk-global map-entry/bound-names)) + (walk-global not-macro-reference-trap? map-entry/name)) + +(define (system-global-environment/macro-names) + (walk-global macro-reference-trap? map-entry/name)) (define (system-global-environment/bindings) - (walk-global map-entry/bindings)) + (walk-global not-macro-reference-trap? map-entry/binding)) -(define (map-entry/bound-names name value) +(define (not-macro-reference-trap? v) + (not (macro-reference-trap? v))) + +(define (map-entry/name name value) value name) -(define (map-entry/bindings name value) +(define (map-entry/value name value) + name + value) + +(define (map-entry/binding name value) (cons name (if (unassigned-reference-trap? value) '() (list value)))) -(define (walk-global map-entry) +(define (walk-global keep? map-entry) (let ((obarray (fixed-objects-item 'OBARRAY))) (let ((n-buckets (vector-length obarray))) (let per-bucket ((index 0) (result '())) @@ -209,7 +249,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (map-reference-trap-value (lambda () (system-pair-cdr name))))) - (if (unbound-reference-trap? value) + (if (or (unbound-reference-trap? value) + (not (keep? value))) result (cons (map-entry name value) result)))))) @@ -217,8 +258,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA result))))) (define (special-unbound-name? name) - (or (eq? name package-name-tag) - (eq? name syntax-table-tag))) + (eq? name package-name-tag)) ;;;; Interpreter Environments @@ -234,6 +274,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (error:wrong-type-datum object "interpreter environment")) object) +#| +(define (lexical-reference-type environment name) + (let ((i ((ucode-primitive lexical-reference-type 2) environment name)) + (v '#(UNBOUND UNASSIGNED NORMAL MACRO))) + (if (not (fix:< i (vector-length v))) + (error "Unknown reference type:" i 'LEXICAL-REFERENCE-TYPE)) + (vector-ref v i))) +|# + +(define (safe-lexical-reference environment name) + (let ((cell (list #f))) + (set-car! cell + ((ucode-primitive safe-lexical-reference 2) environment name)) + (map-reference-trap (lambda () (car cell))))) + (define (interpreter-environment/bound? environment name) (not (lexical-unbound? environment name))) @@ -241,7 +296,15 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (not (lexical-unassigned? environment name))) (define (interpreter-environment/lookup environment name) - (lexical-reference environment name)) + (let ((value (safe-lexical-reference environment name))) + (if (macro-reference-trap? value) + (error:macro-binding environment name)) + value)) + +(define (interpreter-environment/lookup-macro environment name) + (let ((value (safe-lexical-reference environment name))) + (and (macro-reference-trap? value) + (reference-trap->macro value)))) (define (interpreter-environment/assign! environment name value) (lexical-assignment environment name value) @@ -251,28 +314,42 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (local-assignment environment name value) unspecific) +(define (interpreter-environment/define-macro environment name value) + (local-assignment environment name (macro->unmapped-reference-trap value)) + unspecific) + (define (ic-environment/bound-names environment) - (map-ic-environment-bindings map-entry/bound-names environment)) + (map-ic-environment-bindings environment + not-macro-reference-trap? + map-entry/name)) + +(define (ic-environment/macro-names environment) + (map-ic-environment-bindings environment + macro-reference-trap? + map-entry/name)) (define (ic-environment/bindings environment) - (map-ic-environment-bindings map-entry/bindings environment)) + (map-ic-environment-bindings environment + not-macro-reference-trap? + map-entry/binding)) -(define (map-ic-environment-bindings map-entry environment) +(define (map-ic-environment-bindings environment keep? map-entry) (let ((external (ic-external-frame environment)) (do-frame (lambda (frame) (let ((procedure (ic-frame-procedure frame))) (if (vector? procedure) - (append! (walk-ic-frame-extension procedure map-entry) + (append! (walk-ic-frame-extension procedure keep? map-entry) (walk-ic-procedure-args frame (vector-ref procedure 1) + keep? map-entry)) - (walk-ic-procedure-args frame procedure map-entry)))))) + (walk-ic-procedure-args frame procedure keep? map-entry)))))) (if (eq? external environment) (do-frame environment) (append! (do-frame environment) (do-frame external))))) -(define (walk-ic-procedure-args frame procedure map-entry) +(define (walk-ic-procedure-args frame procedure keep? map-entry) (let ((name-vector (system-pair-cdr (procedure-lambda procedure)))) (let loop ((index (vector-length name-vector)) (result '())) (if (fix:> index 1) @@ -282,12 +359,13 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (if (special-unbound-name? name) result (let ((value (ic-frame-arg frame index))) - (if (unbound-reference-trap? value) + (if (or (unbound-reference-trap? value) + (not (keep? value))) result (cons (map-entry name value) result))))))) result)))) -(define (walk-ic-frame-extension extension map-entry) +(define (walk-ic-frame-extension extension keep? map-entry) (let ((limit (fix:+ 3 (object-datum (vector-ref extension 2))))) (let loop ((index 3) (result '())) (if (fix:< index limit) @@ -296,17 +374,19 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((name (car p))) (if (special-unbound-name? name) result - (cons (map-entry name - (map-reference-trap-value - (lambda () (cdr p)))) - result))))) + (let ((value + (map-reference-trap-value (lambda () (cdr p))))) + (if (keep? value) + (cons (map-entry name value) result) + result)))))) result)))) (define (ic-environment/arguments environment) (let ((environment (ic-external-frame environment))) (walk-ic-procedure-args environment (ic-frame-procedure* environment) - (lambda (name value) name value)))) + not-macro-reference-trap? + map-entry/value))) (define (ic-environment/has-parent? environment) (interpreter-environment? (ic-frame-parent environment))) @@ -585,6 +665,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (environment-lookup (stack-ccenv/parent environment) name)))) +(define (stack-ccenv/lookup-macro environment name) + (environment-lookup-macro (stack-ccenv/parent environment) name)) + (define (stack-ccenv/assignable? environment name) (assignable-dbg-variable? (stack-ccenv/block environment) name (lambda (name) @@ -704,6 +787,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (environment-lookup (closure-ccenv/parent environment) name)))) +(define (closure-ccenv/lookup-macro environment name) + (environment-lookup-macro (closure-ccenv/parent environment) name)) + (define (closure-ccenv/assignable? environment name) (assignable-dbg-variable? (closure-ccenv/closure-block environment) name (lambda (name) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index e64d72b1d..802a5b160 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: uerror.scm,v 14.49 2001/12/19 01:40:12 cph Exp $ +$Id: uerror.scm,v 14.50 2001/12/21 04:37:52 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -460,86 +460,93 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (condition-signaller condition-type:unbound-variable '(ENVIRONMENT LOCATION)))) (lambda (continuation) - (let ((signal-reference - (lambda (environment name) - (unbound-variable/store-value continuation environment name - (lambda () - (variable/use-value continuation environment name - (lambda () - (signal continuation environment name))))))) - (signal-other - (lambda (environment name) - (unbound-variable/store-value continuation environment name - (lambda () - (signal continuation environment name))))) - (frame (continuation/first-subproblem continuation))) - (case (frame/type frame) - ((EVAL-ERROR) - (let ((expression (eval-frame/expression frame))) - (if (variable? expression) - (signal-reference (eval-frame/environment frame) - (variable-name expression))))) - ((ASSIGNMENT-CONTINUE) - (signal-other (eval-frame/environment frame) - (assignment-name (eval-frame/expression frame)))) - ((ACCESS-CONTINUE) - (signal-reference (pop-return-frame/value continuation) - (access-name (eval-frame/expression frame)))) - ((INTERNAL-APPLY INTERNAL-APPLY-VAL) - (let ((operator (apply-frame/operator frame))) - (cond ((eq? (ucode-primitive lexical-reference) operator) - (signal-reference (apply-frame/operand frame 0) - (apply-frame/operand frame 1))) - ((eq? (ucode-primitive lexical-assignment) operator) - (signal-other (apply-frame/operand frame 0) - (apply-frame/operand frame 1))) - ((eq? (ucode-primitive link-variables 4) operator) - (signal-other (apply-frame/operand frame 0) - (apply-frame/operand frame 1))) - ((eq? (ucode-primitive lexical-unassigned?) operator) - (signal-other (apply-frame/operand frame 0) - (apply-frame/operand frame 1)))))) - ((COMPILER-REFERENCE-TRAP-RESTART - COMPILER-SAFE-REFERENCE-TRAP-RESTART) - (signal-reference (reference-trap-frame/environment frame) - (reference-trap-frame/name frame))) - ((COMPILER-ASSIGNMENT-TRAP-RESTART - COMPILER-UNASSIGNED?-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) - (signal-other (reference-trap-frame/environment frame) - (reference-trap-frame/name frame)))))))) - + (signal-variable-error + continuation + (lambda (environment name) + (unbound-variable/store-value continuation environment name + (lambda () + (variable/use-value continuation environment name + (lambda () + (signal continuation environment name)))))) + (lambda (environment name) + (unbound-variable/store-value continuation environment name + (lambda () + (signal continuation environment name)))))))) + (define-error-handler 'UNASSIGNED-VARIABLE (let ((signal (condition-signaller condition-type:unassigned-variable '(ENVIRONMENT LOCATION)))) (lambda (continuation) - (let ((signal - (lambda (environment name) - (unassigned-variable/store-value continuation environment name - (lambda () - (variable/use-value continuation environment name - (lambda () - (signal continuation environment name))))))) - (frame (continuation/first-subproblem continuation))) - (case (frame/type frame) - ((EVAL-ERROR) - (let ((expression (eval-frame/expression frame))) - (if (variable? expression) - (signal (eval-frame/environment frame) - (variable-name expression))))) - ((ACCESS-CONTINUE) - (signal (pop-return-frame/value continuation) - (access-name (eval-frame/expression frame)))) - ((INTERNAL-APPLY INTERNAL-APPLY-VAL) - (if (eq? (ucode-primitive lexical-reference) - (apply-frame/operator frame)) - (signal (apply-frame/operand frame 0) - (apply-frame/operand frame 1)))) - ((COMPILER-REFERENCE-TRAP-RESTART - COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) - (signal (reference-trap-frame/environment frame) - (reference-trap-frame/name frame)))))))) + (signal-variable-error + continuation + (lambda (environment name) + (unassigned-variable/store-value continuation environment name + (lambda () + (variable/use-value continuation environment name + (lambda () + (signal continuation environment name)))))) + (lambda (environment name) + environment name + unspecific))))) + +(define-error-handler 'MACRO-BINDING + (let ((signal + (condition-signaller condition-type:macro-binding + '(ENVIRONMENT LOCATION)))) + (lambda (continuation) + (signal-variable-error + continuation + (lambda (environment name) + (unbound-variable/store-value continuation environment name + (lambda () + (variable/use-value continuation environment name + (lambda () + (signal continuation environment name)))))) + (lambda (environment name) + (unbound-variable/store-value continuation environment name + (lambda () + (signal continuation environment name)))))))) + +(define (signal-variable-error continuation signal-reference signal-other) + (let ((frame (continuation/first-subproblem continuation))) + (case (frame/type frame) + ((EVAL-ERROR) + (let ((expression (eval-frame/expression frame))) + (if (variable? expression) + (signal-reference (eval-frame/environment frame) + (variable-name expression))))) + ((ASSIGNMENT-CONTINUE) + (signal-other (eval-frame/environment frame) + (assignment-name (eval-frame/expression frame)))) + ((ACCESS-CONTINUE) + (signal-reference (pop-return-frame/value continuation) + (access-name (eval-frame/expression frame)))) + ((INTERNAL-APPLY INTERNAL-APPLY-VAL) + (let ((operator (apply-frame/operator frame))) + (cond ((or (eq? (ucode-primitive lexical-reference) operator) + (eq? (ucode-primitive safe-lexical-reference 2) + operator)) + (signal-reference (apply-frame/operand frame 0) + (apply-frame/operand frame 1))) + ((eq? (ucode-primitive lexical-assignment) operator) + (signal-other (apply-frame/operand frame 0) + (apply-frame/operand frame 1))) + ((eq? (ucode-primitive link-variables 4) operator) + (signal-other (apply-frame/operand frame 0) + (apply-frame/operand frame 1))) + ((eq? (ucode-primitive lexical-unassigned?) operator) + (signal-other (apply-frame/operand frame 0) + (apply-frame/operand frame 1)))))) + ((COMPILER-REFERENCE-TRAP-RESTART + COMPILER-SAFE-REFERENCE-TRAP-RESTART) + (signal-reference (reference-trap-frame/environment frame) + (reference-trap-frame/name frame))) + ((COMPILER-ASSIGNMENT-TRAP-RESTART + COMPILER-UNASSIGNED?-TRAP-RESTART + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) + (signal-other (reference-trap-frame/environment frame) + (reference-trap-frame/name frame)))))) ;;;; Argument Errors diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm index 3fcac1e54..3c23bf69a 100644 --- a/v7/src/runtime/urtrap.scm +++ b/v7/src/runtime/urtrap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: urtrap.scm,v 14.7 2001/12/18 20:46:59 cph Exp $ +$Id: urtrap.scm,v 14.8 2001/12/21 04:37:56 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -70,6 +70,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((2) 'UNBOUND) ((6) 'EXPENSIVE) ((14) 'COMPILER-CACHED) + ((15) 'MACRO) (else #f))) (define (make-unassigned-reference-trap) @@ -117,4 +118,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (let ((value (map-reference-trap getter))) (if (cached-reference-trap? value) (cached-reference-trap-value value) - value))) \ No newline at end of file + value))) + +(define (macro->reference-trap transformer) + (make-reference-trap 15 transformer)) + +(define (macro-reference-trap? object) + (and (reference-trap? object) + (fix:= 15 (reference-trap-kind object)))) + +(define (reference-trap->macro trap) + (if (not (macro-reference-trap? trap)) + (error:wrong-type-argument trap "macro reference trap" + 'MACRO-REFERENCE-TRAP-VALUE)) + (reference-trap-extra trap)) + +(define (macro->unmapped-reference-trap transformer) + (primitive-object-set-type (ucode-type reference-trap) + (cons 15 transformer))) \ No newline at end of file -- 2.25.1