/* -*-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
#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 */
/* -*-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
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\
"(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\
-<symbol>) is built on top of this.")
+for SYMBOL starting in ENVIRONMENT.")
{
PRIMITIVE_HEADER (2);
CHECK_ARG (1, ENVIRONMENT_P);
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);
{
/* -*-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
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));
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);
}
return (PRIM_DONE);
case ERR_UNASSIGNED_VARIABLE:
+ case ERR_MACRO_BINDING:
case PRIM_DONE:
(*value_ret) = SHARP_F;
return (PRIM_DONE);
{
case ERR_UNBOUND_VARIABLE:
case ERR_UNASSIGNED_VARIABLE:
+ case ERR_MACRO_BINDING:
(*value_ret) = SHARP_T;
return (PRIM_DONE);
break;
return (ERR_UNBOUND_VARIABLE);
+ case TRAP_MACRO:
+ if (force_p)
+ break;
+ return (ERR_MACRO_BINDING);
+
case TRAP_COMPILER_CACHED:
return
(assign_variable_cache
break;
return (ERR_UNBOUND_VARIABLE);
+ case TRAP_MACRO:
+ if (force_p)
+ break;
+ return (ERR_MACRO_BINDING);
+
default:
return (ERR_ILLEGAL_REFERENCE_TRAP);
}
case NON_TRAP_KIND:
case TRAP_UNASSIGNED:
+ case TRAP_MACRO:
unbind_variable_1 (cell, frame, symbol);
(*value_ret) = SHARP_T;
return (PRIM_DONE);
case NON_TRAP_KIND:
case TRAP_UNASSIGNED:
+ case TRAP_MACRO:
if (PROCEDURE_FRAME_P (frame))
{
RETURN_IF_ERROR
/* -*-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
#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
/* -*-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
/* 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.
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
;;; -*-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
;;;
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
;;; 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 $"
/* -*-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
/* Scheme system release version */
#ifndef SCHEME_RELEASE
-#define SCHEME_RELEASE "7.5.18"
+#define SCHEME_RELEASE "7.7.0"
#endif
/* Microcode release version */
#define SCHEME_VERSION 14
#endif
#ifndef SCHEME_SUBVERSION
-#define SCHEME_SUBVERSION 7
+#define SCHEME_SUBVERSION 8
#endif
#| -*-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
(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)
(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)
(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)
(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)
\f
#| -*-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
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?
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
(export (runtime stream)
ordinal-number-string
write-operator)
+ (export (runtime environment)
+ error:macro-binding)
(initialization (initialize-package!)))
(define-package (runtime event-distributor)
(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?
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")
#| -*-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
(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))))
+\f
(define (environment-bindings environment)
(cond ((system-global-environment? environment)
(system-global-environment/bindings))
'()
(list value)))))
(environment-bound-names environment)))))
-\f
+
(define (environment-arguments environment)
(cond ((ic-environment? environment)
(ic-environment/arguments environment))
(closure-ccenv/assigned? environment name))
(else
(illegal-environment environment 'ENVIRONMENT-ASSIGNED?))))
-
+\f
(define (environment-lookup environment name)
(cond ((interpreter-environment? environment)
(interpreter-environment/lookup environment name))
(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)
(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))
\f
(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 '()))
(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))))))
result)))))
(define (special-unbound-name? name)
- (or (eq? name package-name-tag)
- (eq? name syntax-table-tag)))
+ (eq? name package-name-tag))
\f
;;;; Interpreter Environments
(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)))
(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)
(local-assignment environment name value)
unspecific)
+(define (interpreter-environment/define-macro environment name value)
+ (local-assignment environment name (macro->unmapped-reference-trap value))
+ unspecific)
+\f
(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)
(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)
(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))))
\f
(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)))
(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)
(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)
#| -*-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
(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))))))))
-\f
+ (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))))))))
+\f
+(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))))))
\f
;;;; Argument Errors
#| -*-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
((2) 'UNBOUND)
((6) 'EXPENSIVE)
((14) 'COMPILER-CACHED)
+ ((15) 'MACRO)
(else #f)))
\f
(define (make-unassigned-reference-trap)
(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
projects / mit-scheme.git / commitdiff