From: Chris Hanson Date: Fri, 21 Dec 2001 18:22:57 +0000 (+0000) Subject: Store macro definitions in environments rather than in syntax tables. X-Git-Tag: 20090517-FFI~2321 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=23537e49b462bc04b933f10d9839e31ddc672922;p=mit-scheme.git Store macro definitions in environments rather than in syntax tables. --- diff --git a/v7/src/runtime/macros.scm b/v7/src/runtime/macros.scm index 79ec406cd..4bbc6f871 100644 --- a/v7/src/runtime/macros.scm +++ b/v7/src/runtime/macros.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: macros.scm,v 1.5 2001/12/20 18:03:05 cph Exp $ +$Id: macros.scm,v 1.6 2001/12/21 18:22:15 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -27,9 +27,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (initialize-package!) (for-each (lambda (keyword transform) - (syntax-table/define system-global-environment - keyword - transform)) + (environment-define-macro system-global-environment + keyword + transform)) '(AND CASE CONS-STREAM diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index ede9c70b2..f6e697316 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: make.scm,v 14.79 2001/12/21 05:17:59 cph Exp $ +$Id: make.scm,v 14.80 2001/12/21 18:22:20 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -62,8 +62,6 @@ USA. names) parent) values)))) - -(define environment-define-macro) (let ((environment-for-package (*make-environment system-global-environment @@ -119,15 +117,6 @@ 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)) @@ -444,7 +433,6 @@ 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) @@ -487,7 +475,6 @@ USA. (RUNTIME SYNTAXER) (RUNTIME ILLEGAL-DEFINITIONS) (RUNTIME MACROS) - (RUNTIME SYSTEM-MACROS) ((RUNTIME DEFSTRUCT) INITIALIZE-DEFINE-STRUCTURE-MACRO! #t) (RUNTIME UNSYNTAXER) (RUNTIME PRETTY-PRINTER) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 4245e125f..1bae82768 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.399 2001/12/21 05:18:12 cph Exp $ +$Id: runtime.pkg,v 14.400 2001/12/21 18:22:33 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -1326,8 +1326,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA environment-bound-names environment-bound? environment-define - ;; Defined in "make.scm": - ;; environment-define-macro + environment-define-macro environment-has-parent? environment-lambda environment-lookup @@ -2119,6 +2118,18 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime macros) (files "macros") (parent (runtime)) + #| + (export () + and + case + cons-stream + define-integrable + do + let* + letrec + quasiquote + sequence) + |# (initialization (initialize-package!))) (define-package (runtime microcode-errors) @@ -2666,22 +2677,23 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (export () cached-reference-trap-value cached-reference-trap? - macro->reference-trap + macro-reference-trap-transformer macro-reference-trap? - macro->unmapped-reference-trap + make-macro-reference-trap make-unassigned-reference-trap make-unbound-reference-trap + make-unmapped-macro-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? unassigned-reference-trap? unbound-reference-trap? unmap-reference-trap + unmapped-macro-reference-trap? unmapped-unassigned-reference-trap? unmapped-unbound-reference-trap?)) @@ -3743,17 +3755,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (files "syntab") (parent (runtime)) (export () - environment-syntax-table guarantee-syntax-table make-syntax-table - set-environment-syntax-table! - syntax-table/copy syntax-table/define - syntax-table/defined-names - syntax-table/extend - syntax-table/parent syntax-table/ref - syntax-table?)) + syntax-table?) + (export (runtime syntaxer) + syntax-table/environment + syntax-table/extend)) (define-package (runtime syntaxer) (files "syntax") @@ -3811,7 +3820,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define-package (runtime system-macros) (files "sysmac") (parent (runtime)) - (initialization (initialize-package!))) + (export (runtime) + define-primitives + ucode-primitive + ucode-return-address + ucode-type)) (define-package (runtime truncated-string-output) (files "strott") diff --git a/v7/src/runtime/syntab.scm b/v7/src/runtime/syntab.scm index a5fb76276..742c20aed 100644 --- a/v7/src/runtime/syntab.scm +++ b/v7/src/runtime/syntab.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: syntab.scm,v 14.8 2001/12/20 06:52:49 cph Exp $ +$Id: syntab.scm,v 14.9 2001/12/21 18:22:36 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -29,67 +29,53 @@ USA. (predicate %syntax-table?) (conc-name syntax-table/)) alist - (%parent #f read-only #t)) + (parent #f read-only #t)) (define (syntax-table? object) (or (%syntax-table? object) - (interpreter-environment? object))) + (environment? object))) -(define (make-syntax-table #!optional parent) - (%make-syntax-table '() - (if (default-object? parent) - #f - (guarantee-syntax-table parent 'MAKE-SYNTAX-TABLE)))) +(define (make-syntax-table parent) + (guarantee-syntax-table parent 'MAKE-SYNTAX-TABLE) + (%make-syntax-table '() parent)) (define (guarantee-syntax-table table procedure) - (cond ((%syntax-table? table) table) - ((interpreter-environment? table) (environment-syntax-table table)) - (else (error:wrong-type-argument table "syntax table" procedure)))) - -(define (syntax-table/parent table) - (syntax-table/%parent (guarantee-syntax-table table 'SYNTAX-TABLE/PARENT))) + (if (not (syntax-table? table)) + (error:wrong-type-argument table "syntax table" procedure)) + table) (define (syntax-table/ref table name) - (let loop ((table (guarantee-syntax-table table 'SYNTAX-TABLE/REF))) - (and table - (let ((entry (assq name (syntax-table/alist table)))) - (if entry - (cdr entry) - (loop (syntax-table/%parent table))))))) + (guarantee-syntax-table table 'SYNTAX-TABLE/REF) + (let loop ((table table)) + (if (%syntax-table? table) + (let ((entry (assq name (syntax-table/alist table)))) + (if entry + (cdr entry) + (let ((parent (syntax-table/parent table))) + (if (eq? parent 'NONE) + #f + (loop parent))))) + (and (environment-bound? table name) + (environment-lookup-macro table name))))) (define (syntax-table/define table name transform) - (let ((table (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE))) - (let ((entry (assq name (syntax-table/alist table)))) - (if entry - (set-cdr! entry transform) - (set-syntax-table/alist! table - (cons (cons name transform) - (syntax-table/alist table))))))) - -(define (syntax-table/defined-names table) - (map car - (syntax-table/alist - (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINED-NAMES)))) - -(define (syntax-table/copy table) - (let loop ((table (guarantee-syntax-table table 'SYNTAX-TABLE/COPY))) - (and table - (%make-syntax-table (alist-copy (syntax-table/alist table)) - (loop (syntax-table/%parent table)))))) + (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE) + (if (%syntax-table? table) + (let ((entry (assq name (syntax-table/alist table)))) + (if entry + (set-cdr! entry transform) + (set-syntax-table/alist! table + (cons (cons name transform) + (syntax-table/alist table))))) + (environment-define-macro table name transform))) (define (syntax-table/extend table alist) - (%make-syntax-table (alist-copy alist) - (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND))) - -(define (environment-syntax-table environment) - (environment-lookup environment syntax-table-tag)) - -(define (set-environment-syntax-table! environment table) - (environment-define environment - syntax-table-tag - (guarantee-syntax-table table - 'SET-ENVIRONMENT-SYNTAX-TABLE!))) - -(define-integrable syntax-table-tag - ((ucode-primitive string->symbol) - "#[(runtime syntax-table)syntax-table-tag]")) \ No newline at end of file + (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND) + (%make-syntax-table (alist-copy alist) table)) + +(define (syntax-table/environment table) + (guarantee-syntax-table table 'SYNTAX-TABLE/ENVIRONMENT) + (let loop ((table table)) + (if (%syntax-table? table) + (loop (syntax-table/parent table)) + table))) \ No newline at end of file diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index 49828eb5b..ef9516f77 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: syntax.scm,v 14.47 2001/12/21 05:18:17 cph Exp $ +$Id: syntax.scm,v 14.48 2001/12/21 18:22:41 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -30,13 +30,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (enable-scan-defines!) (set! *disallow-illegal-definitions?* #t) (set! hook/syntax-expression default/syntax-expression) - (set-environment-syntax-table! system-global-environment (make-syntax-table)) - (install-system-global-syntax!) - (set-environment-syntax-table! user-initial-environment - (make-syntax-table system-global-environment)) - (set! syntaxer/default-environment - (extend-interpreter-environment system-global-environment)) - unspecific) + (install-system-global-syntax!)) (define *syntax-table*) (define *current-keyword* #f) @@ -44,39 +38,40 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define *disallow-illegal-definitions?*) (define (install-system-global-syntax!) - (for-each (lambda (entry) - (syntax-table/define system-global-environment - (car entry) - (make-primitive-syntaxer (cadr entry)))) - `( - ;; R*RS special forms - (BEGIN ,syntax/begin) - (COND ,syntax/cond) - (DEFINE ,syntax/define) - (DELAY ,syntax/delay) - (IF ,syntax/if) - (LAMBDA ,syntax/lambda) - (LET ,syntax/let) - (OR ,syntax/or) - (QUOTE ,syntax/quote) - (SET! ,syntax/set!) - - ;; Syntax extensions - (DEFINE-SYNTAX ,syntax/define-syntax) - (LET-SYNTAX ,syntax/let-syntax) - - ;; Environment extensions - (ACCESS ,syntax/access) - (THE-ENVIRONMENT ,syntax/the-environment) - (UNASSIGNED? ,syntax/unassigned?) - ;; To facilitate upgrade to new option argument mechanism. - (DEFAULT-OBJECT? ,syntax/unassigned?) - - ;; Miscellaneous extensions - (DECLARE ,syntax/declare) - (FLUID-LET ,syntax/fluid-let) - (LOCAL-DECLARE ,syntax/local-declare) - (NAMED-LAMBDA ,syntax/named-lambda)))) + (for-each + (lambda (entry) + (environment-define-macro system-global-environment + (car entry) + (make-primitive-syntaxer (cadr entry)))) + `( + ;; R*RS special forms + (BEGIN ,syntax/begin) + (COND ,syntax/cond) + (DEFINE ,syntax/define) + (DELAY ,syntax/delay) + (IF ,syntax/if) + (LAMBDA ,syntax/lambda) + (LET ,syntax/let) + (OR ,syntax/or) + (QUOTE ,syntax/quote) + (SET! ,syntax/set!) + + ;; Syntax extensions + (DEFINE-SYNTAX ,syntax/define-syntax) + (LET-SYNTAX ,syntax/let-syntax) + + ;; Environment extensions + (ACCESS ,syntax/access) + (THE-ENVIRONMENT ,syntax/the-environment) + (UNASSIGNED? ,syntax/unassigned?) + ;; To facilitate upgrade to new option argument mechanism. + (DEFAULT-OBJECT? ,syntax/unassigned?) + + ;; Miscellaneous extensions + (DECLARE ,syntax/declare) + (FLUID-LET ,syntax/fluid-let) + (LOCAL-DECLARE ,syntax/local-declare) + (NAMED-LAMBDA ,syntax/named-lambda)))) ;;;; Top Level Syntaxers @@ -93,8 +88,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (fluid-let ((*syntax-table* (if (eq? table 'DEFAULT) (if (unassigned? *syntax-table*) - (environment-syntax-table - (nearest-repl/environment)) + (nearest-repl/environment) *syntax-table*) (guarantee-syntax-table table name))) (*current-keyword* #f)) @@ -139,7 +133,9 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ((pair? expression) (if (not (list? expression)) (error "syntax-expression: not a valid expression" expression)) - (let ((transform (syntax-table/ref syntax-table (car expression)))) + (let ((transform + (and (symbol? (car expression)) + (syntax-table/ref syntax-table (car expression))))) (if transform (if (primitive-syntaxer? transform) (transform-apply (primitive-syntaxer/transform transform) @@ -298,8 +294,6 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA top-level? (let ((make-definition (lambda (name value) - (if (syntax-table/ref *syntax-table* name) - (syntax-error "redefinition of syntactic keyword" name)) (make-definition name value)))) (cond ((symbol? pattern) (make-definition @@ -439,19 +433,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (syntax/define-syntax top-level? name value) (if (not (symbol? name)) (syntax-error "illegal name" 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)) - -(define syntaxer/default-environment) + (let ((value (syntax-subexpression value))) + (syntax-table/define *syntax-table* name (syntax-eval value)) + (if top-level? + (make-definition name (make-macro-reference-trap value)) + name))) + +(define (syntax-eval scode) + (extended-scode-eval scode (syntax-table/environment *syntax-table*))) ;;;; FLUID-LET diff --git a/v7/src/runtime/sysmac.scm b/v7/src/runtime/sysmac.scm index 3269a4edc..1fba90ba6 100644 --- a/v7/src/runtime/sysmac.scm +++ b/v7/src/runtime/sysmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: sysmac.scm,v 14.5 2001/12/19 21:41:14 cph Exp $ +$Id: sysmac.scm,v 14.6 2001/12/21 18:22:44 cph Exp $ Copyright (c) 1988, 1999, 2001 Massachusetts Institute of Technology @@ -25,18 +25,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (declare (usual-integrations)) -(define (initialize-package!) - (let ((environment (->environment '(RUNTIME)))) - (set-environment-syntax-table! environment - (make-syntax-table (->environment '()))) - (for-each (lambda (entry) - (syntax-table/define environment (car entry) (cadr entry))) - `((DEFINE-PRIMITIVES ,transform/define-primitives) - (UCODE-PRIMITIVE ,transform/ucode-primitive) - (UCODE-RETURN-ADDRESS ,transform/ucode-return-address) - (UCODE-TYPE ,transform/ucode-type))))) - -(define transform/define-primitives +(define-syntax define-primitives (let ((primitive-definition (lambda (variable-name primitive-args) `(DEFINE-INTEGRABLE ,variable-name @@ -51,14 +40,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (primitive-definition (car name) (cdr name))))) names))))) -(define transform/ucode-type +(define-syntax ucode-type (lambda arguments (apply microcode-type arguments))) -(define transform/ucode-primitive +(define-syntax ucode-primitive (lambda arguments (apply make-primitive-procedure arguments))) -(define transform/ucode-return-address +(define-syntax ucode-return-address (lambda arguments (make-return-address (apply microcode-return arguments)))) \ No newline at end of file diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 425052a38..e1268d093 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: uenvir.scm,v 14.49 2001/12/21 05:18:22 cph Exp $ +$Id: uenvir.scm,v 14.50 2001/12/21 18:22:49 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -25,12 +25,6 @@ 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) @@ -195,15 +189,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (else (illegal-environment environment 'ENVIRONMENT-DEFINE)))) -(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 (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,7 +304,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (interpreter-environment/lookup-macro environment name) (let ((value (safe-lexical-reference environment name))) (and (macro-reference-trap? value) - (reference-trap->macro value)))) + (macro-reference-trap-transformer value)))) (define (interpreter-environment/assign! environment name value) (lexical-assignment environment name value) @@ -321,7 +314,8 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (local-assignment environment name value)) (define (interpreter-environment/define-macro environment name value) - (local-assignment environment name (macro->unmapped-reference-trap value))) + (local-assignment environment name + (make-unmapped-macro-reference-trap value))) (define (ic-environment/bound-names environment) (map-ic-environment-bindings environment @@ -655,9 +649,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (define (stack-ccenv/bound? environment name) (or (dbg-block/find-name (stack-ccenv/block environment) name) - (let ((parent (stack-ccenv/parent environment))) - (and parent - (environment-bound? parent name))))) + (environment-bound? (stack-ccenv/parent environment) name))) (define (stack-ccenv/assigned? environment name) (and (stack-ccenv/lookup environment name) #t)) @@ -771,9 +763,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (closure-ccenv/variable-bound? environment (vector-ref (dbg-block/layout-vector block) index))))) - (let ((parent (closure-ccenv/parent environment))) - (and parent - (environment-bound? parent name))))) + (environment-bound? (closure-ccenv/parent environment) name))) (define (closure-ccenv/assigned? environment name) (and (closure-ccenv/lookup environment name) #t)) diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index ac79e4cfd..2899be465 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: unsyn.scm,v 14.24 2001/12/20 20:32:02 cph Exp $ +$Id: unsyn.scm,v 14.25 2001/12/21 18:22:53 cph Exp $ Copyright (c) 1988-2001 Massachusetts Institute of Technology @@ -163,17 +163,21 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA `(SET! ,name ,@(unexpand-binding-value value))))) (define (unexpand-definition name value) - (if (and (eq? #t unsyntaxer:macroize?) - (lambda? value) - (not (has-substitution? value))) - (lambda-components** value - (lambda (lambda-name required optional rest body) - (if (eq? lambda-name name) - `(DEFINE (,name . ,(lambda-list required optional rest '())) - ,@(with-bindings required optional rest - unsyntax-sequence body)) - `(DEFINE ,name ,@(unexpand-binding-value value))))) - `(DEFINE ,name ,@(unexpand-binding-value value)))) + (cond ((macro-reference-trap? value) + `(DEFINE-SYNTAX ,name + ,(macro-reference-trap-transformer value))) + ((and (eq? #t unsyntaxer:macroize?) + (lambda? value) + (not (has-substitution? value))) + (lambda-components** value + (lambda (lambda-name required optional rest body) + (if (eq? lambda-name name) + `(DEFINE (,name . ,(lambda-list required optional rest '())) + ,@(with-bindings required optional rest + unsyntax-sequence body)) + `(DEFINE ,name ,@(unexpand-binding-value value)))))) + (else + `(DEFINE ,name ,@(unexpand-binding-value value))))) (define (unexpand-binding-value value) (if (unassigned-reference-trap? value) diff --git a/v7/src/runtime/urtrap.scm b/v7/src/runtime/urtrap.scm index 3c23bf69a..6c0d6cb32 100644 --- a/v7/src/runtime/urtrap.scm +++ b/v7/src/runtime/urtrap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: urtrap.scm,v 14.8 2001/12/21 04:37:56 cph Exp $ +$Id: urtrap.scm,v 14.9 2001/12/21 18:22:57 cph Exp $ Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology @@ -120,19 +120,25 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA (cached-reference-trap-value value) value))) -(define (macro->reference-trap transformer) +(define (make-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) +(define (macro-reference-trap-transformer trap) (if (not (macro-reference-trap? trap)) (error:wrong-type-argument trap "macro reference trap" - 'MACRO-REFERENCE-TRAP-VALUE)) + 'MACRO-REFERENCE-TRAP-TRANSFORMER)) (reference-trap-extra trap)) -(define (macro->unmapped-reference-trap transformer) +(define (make-unmapped-macro-reference-trap transformer) (primitive-object-set-type (ucode-type reference-trap) - (cons 15 transformer))) \ No newline at end of file + (cons 15 transformer))) + +(define (unmapped-macro-reference-trap? getter) + (and (primitive-object-type? (ucode-type reference-trap) (getter)) + (let ((index (object-datum (getter)))) + (and (> index trap-max-immediate) + (fix:= 15 (primitive-object-ref (getter) 0)))))) \ No newline at end of file