~ chicken-core (chicken-5) 529032c1d98cf5eda3caeb80bcf46dfaa7fff28f
commit 529032c1d98cf5eda3caeb80bcf46dfaa7fff28f
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Nov 25 10:10:35 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Nov 25 10:10:35 2009 +0100
reverted incorrect merge
diff --git a/README b/README
index 66b5517c..eb9baf56 100644
--- a/README
+++ b/README
@@ -124,6 +124,13 @@
option you can still enable symbol GC at runtime by passing
the `-:w' runtime option when running the program.
+ NOAPPLYHOOK=1
+ For maximum performance this will disable support for
+ breakpoints, but speed up procedure invocation in safe
+ code. Smaller binaries can be obtained by also giving
+ "NOPTABLES=1", but that means serialization (available
+ as a separate package) of procedures will not be available.
+
OPTIMIZE_FOR_SPEED=1
Use C optimization options that prefer speed over size. For
the GNU C compiler this will currently select "-O3" (the
diff --git a/csi.scm b/csi.scm
index c5184965..02eea351 100644
--- a/csi.scm
+++ b/csi.scm
@@ -56,7 +56,7 @@ EOF
##sys#windows-platform)
(hide parse-option-string bytevector-data member* canonicalize-args do-trace do-untrace
traced-procedures describer-table dirseparator? resolve-var
- findall trace-indent command-table) )
+ findall trace-indent command-table do-break do-unbreak broken-procedures) )
;;; Parameters:
@@ -254,6 +254,7 @@ EOF
(let ((eval eval)
(load-noisily load-noisily)
(read read)
+ (singlestep singlestep)
(read-line read-line)
(length length)
(display display)
@@ -316,13 +317,37 @@ EOF
(apply values rs) ) ) )
((tr) (do-trace (map resolve-var (string-split (read-line)))))
((utr) (do-untrace (map resolve-var (string-split (read-line)))))
+ ((br) (do-break (map resolve-var (string-split (read-line)))))
+ ((ubr) (do-unbreak (map resolve-var (string-split (read-line)))))
+ ((uba) (do-unbreak-all))
+ ((breakall)
+ (set! ##sys#break-in-thread #f) )
+ ((breakonly)
+ (set! ##sys#break-in-thread (eval (read))) )
((info)
(when (pair? traced-procedures)
- (printf "Traced: ~s~%" (map car traced-procedures)) ) )
+ (printf "Traced: ~s~%" (map car traced-procedures)) )
+ (when (pair? broken-procedures)
+ (printf "Breakpoints: ~s~%" (map car broken-procedures)) ) )
+ ((c)
+ (cond (##sys#last-breakpoint
+ (let ((exn ##sys#last-breakpoint))
+ (set! ##sys#last-breakpoint #f)
+ (##sys#break-resume exn) ) )
+ (else (display "no breakpoint pending\n") ) ) )
((exn)
(when ##sys#last-exception
(history-add (list ##sys#last-exception))
(describe ##sys#last-exception) ) )
+ ((step)
+ (let ((x (read)))
+ (read-line)
+ (singlestep (eval `(lambda () ,x))) ) )
+ ((s)
+ (let* ((str (read-line))
+ (r (system str)) )
+ (history-add (list r))
+ r) )
((?)
(display
"Toplevel commands:
@@ -339,7 +364,14 @@ EOF
,s TEXT ... Execute shell-command
,tr NAME ... Trace procedures
,utr NAME ... Untrace procedures
- ,info List traced procedures
+ ,br NAME ... Set breakpoints
+ ,ubr NAME ... Remove breakpoints
+ ,uba Remove all breakpoints
+ ,breakall Break in all threads (default)
+ ,breakonly THREAD Break only in specified thread
+ ,c Continue from breakpoint
+ ,info List traced procedures and breakpoints
+ ,step EXPR Execute EXPR in single-stepping mode
,exn Describe last exception
,t EXP Evaluate form and print elapsed time
,x EXP Pretty print expanded expression EXP\n")
@@ -416,6 +448,8 @@ EOF
(let ((s (expand s)))
(cond ((assq s traced-procedures)
(##sys#warn "procedure already traced" s) )
+ ((assq s broken-procedures)
+ (##sys#warn "procedure already has breakpoint") )
(else
(let ((old (##sys#slot s 0)))
(cond ((not (procedure? old)) (##sys#error "cannot trace non-procedure" s))
@@ -443,6 +477,49 @@ EOF
(set! traced-procedures (del p traced-procedures eq?) ) ) ) ) )
names) ) )
+(define do-break
+ (lambda (names)
+ (if (null? names)
+ (for-each (lambda (b) (print (car a))) broken-procedures)
+ (for-each
+ (lambda (s)
+ (let* ((s (expand s))
+ (a (assq s traced-procedures)))
+ (when a
+ (##sys#warn "un-tracing procedure" s)
+ (##sys#setslot s 0 (cdr a))
+ (set! traced-procedures (del a traced-procedures eq?)) )
+ (let ((old (##sys#slot s 0)))
+ (cond ((not (procedure? old)) (##sys#error "cannot set breakpoint on non-procedure" s))
+ (else
+ (set! broken-procedures (cons (cons s old) broken-procedures))
+ (##sys#setslot
+ s 0
+ (lambda args
+ (##sys#break-entry s args)
+ (##sys#apply old args) ) ) ) ) ) ) )
+ names) ) ) )
+
+(define do-unbreak
+ (lambda (names)
+ (for-each
+ (lambda (s)
+ (let* ((s (expand s))
+ (p (assq s broken-procedures)) )
+ (cond ((not p) (##sys#warn "procedure has no breakpoint" s))
+ (else
+ (##sys#setslot s 0 (cdr p))
+ (set! broken-procedures (del p broken-procedures eq?) ) ) ) ) )
+ names) ) )
+
+(define do-unbreak-all
+ (lambda ()
+ (for-each (lambda (bp)
+ (##sys#setslot (car bp) 0 (cdr bp)))
+ broken-procedures)
+ (set! broken-procedures '())
+ (##sys#void)))
+
;;; Parse options from string:
(define (parse-option-string str)
diff --git a/library.scm b/library.scm
index 3da58977..54aae68c 100644
--- a/library.scm
+++ b/library.scm
@@ -159,7 +159,7 @@ EOF
##sys#memory-info ##sys#make-c-string ##sys#find-symbol-table display
newline string-append ##sys#with-print-length-limit write print vector-fill! ##sys#context-switch
##sys#set-finalizer! open-output-string get-output-string read ##sys#make-pointer
- ##sys#pointer->address number->string ##sys#flush-output
+ ##sys#pointer->address number->string ##sys#flush-output ##sys#break-entry ##sys#step
##sys#apply-values ##sys#get-call-chain ##sys#really-print-call-chain
string->keyword keyword? string->keyword get-environment-variable ##sys#number->string ##sys#copy-bytes
call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
@@ -3302,6 +3302,7 @@ EOF
(if (##sys#fudge 24) " dload" "")
(if (##sys#fudge 28) " ptables" "")
(if (##sys#fudge 32) " gchooks" "")
+ (if (##sys#fudge 35) " applyhook" "")
(if (##sys#fudge 39) " cross" "") ) ) )
(string-append
"Version " +build-version+ "\n"
@@ -3351,6 +3352,7 @@ EOF
(when (##sys#fudge 40) (set! ##sys#features (cons #:manyargs ##sys#features)))
(when (##sys#fudge 24) (set! ##sys#features (cons #:dload ##sys#features)))
(when (##sys#fudge 28) (set! ##sys#features (cons #:ptables ##sys#features)))
+(when (##sys#fudge 35) (set! ##sys#features (cons #:applyhook ##sys#features)))
(when (##sys#fudge 39) (set! ##sys#features (cons #:cross-chicken ##sys#features)))
(define (register-feature! . fs)
@@ -3448,6 +3450,105 @@ EOF
(##sys#setslot ##sys#primordial-thread 1 break) ) )
+;;; Breakpoints
+
+(define ##sys#last-breakpoint #f)
+(define ##sys#break-in-thread #f)
+
+(define (##sys#break-entry name args)
+ ;; Does _not_ unwind!
+ (##sys#call-with-current-continuation
+ (lambda (c)
+ (let ((exn (##sys#make-structure
+ 'condition
+ '(exn breakpoint)
+ (list '(exn . message) "*** breakpoint ***"
+ '(exn . arguments) (list (cons name args))
+ '(exn . location) name
+ '(exn . continuation) c) ) ) )
+ (set! ##sys#last-breakpoint exn)
+ (##sys#signal exn) ) ) ) )
+
+(define (##sys#break-resume exn)
+ (let ((a (member '(exn . continuation) (##sys#slot exn 2))))
+ (if a
+ ((cadr a) (##core#undefined))
+ (##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
+
+(define (breakpoint #!optional name)
+ (##sys#break-entry (or name 'breakpoint) '()) )
+
+
+;;; Single stepping
+
+(define ##sys#stepped-thread #f)
+(define ##sys#step-ports (cons ##sys#standard-input ##sys#standard-output))
+
+(define (##sys#step thunk)
+ (when (eq? ##sys#stepped-thread ##sys#current-thread)
+ (##sys#call-with-values
+ (lambda ()
+ (set! ##sys#apply-hook ##sys#step-hook)
+ (##core#app thunk) )
+ (lambda vals
+ (set! ##sys#apply-hook #f)
+ (set! ##sys#stepped-thread #f)
+ (##sys#apply-values vals) ) ) ) )
+
+(define (singlestep thunk)
+ (unless (##sys#fudge 35)
+ (##sys#signal-hook #:runtime-error 'singlestep "apply-hook not available") )
+ (##sys#check-closure thunk 'singlestep)
+ (set! ##sys#stepped-thread ##sys#current-thread)
+ (##sys#step thunk) )
+
+(define (##sys#step-hook . args)
+ (set! ##sys#apply-hook #f)
+ (let ((o (##sys#slot ##sys#step-ports 1))
+ (i (##sys#slot ##sys#step-ports 0))
+ (p ##sys#last-applied-procedure))
+ (define (skip-to-nl)
+ (let ((c (##sys#read-char-0 i)))
+ (unless (or (eof-object? c) (char=? #\newline c))
+ (sip-to-nl) ) ) )
+ (define (cont)
+ (set! ##sys#stepped-thread #f)
+ (##sys#apply p args) )
+ (##sys#print "\n " #f o)
+ (##sys#with-print-length-limit
+ 1024
+ (lambda () (##sys#print (cons p args) #t o)) )
+ (flush-output o)
+ (let loop ()
+ (##sys#print "\n step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
+ (let ((c (##sys#read-char-0 i)))
+ (if (eof-object? c)
+ (cont)
+ (case c
+ ((#\newline)
+ (set! ##sys#apply-hook ##sys#step-hook)
+ (##core#app ##sys#apply p args))
+ ((#\return #\tab #\space) (loop))
+ ((#\c) (skip-to-nl) (cont))
+ ((#\s)
+ (skip-to-nl)
+ (##sys#call-with-values
+ (lambda () (##core#app ##sys#apply p args))
+ (lambda results
+ (set! ##sys#apply-hook ##sys#step-hook)
+ (##core#app ##sys#apply-values results) ) ) )
+ ((#\b)
+ (skip-to-nl)
+ (set! ##sys#stepped-thread #f)
+ (##sys#break-entry '<step> '())
+ (##sys#apply p args) )
+ (else
+ (cond ((eof-object? c) (cont))
+ (else
+ (skip-to-nl)
+ (loop))))))))))
+
+
;;; Default handlers
(define ##sys#break-on-error (##sys#fudge 25))
diff --git a/lolevel.import.scm b/lolevel.import.scm
index 77aa16aa..58ea8f22 100644
--- a/lolevel.import.scm
+++ b/lolevel.import.scm
@@ -31,6 +31,7 @@
allocate
block-ref
block-set!
+ clear-unbound-variable-value!
extend-procedure
extended-procedure?
free
@@ -38,6 +39,7 @@
global-make-unbound!
global-ref
global-set!
+ invalid-procedure-call-handler
locative->object
locative-ref
locative-set!
@@ -90,6 +92,12 @@
record-instance-slot
record-instance-slot-set!
record-instance-type
+ set-invalid-procedure-call-handler!
set-procedure-data!
+ set-unbound-variable-value!
tag-pointer
- tagged-pointer?))
+ tagged-pointer?
+ unbound-variable-value
+ unbound-variable-given-value
+ unbound-variable-signals-error?
+ vector-like?))
diff --git a/lolevel.scm b/lolevel.scm
index 32628bfa..b27036a2 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -440,6 +440,9 @@ EOF
(define block-set! ##sys#block-set!)
(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
+(define (vector-like? x)
+ (%generic-vector? x) )
+
(define (number-of-slots x)
(##sys#check-generic-vector x 'number-of-slots)
(##sys#size x) )
@@ -644,6 +647,38 @@ EOF
new ) )
+;;; Hooks:
+
+; we need this because `##sys#invalid-procedure-call-hook' cannot
+; have free variables.
+(define ipc-hook-0 #f)
+
+(define (invalid-procedure-call-handler) ipc-hook-0)
+
+(define (set-invalid-procedure-call-handler! proc)
+ (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
+ (set! ipc-hook-0 proc)
+ (set! ##sys#invalid-procedure-call-hook
+ (lambda args (ipc-hook-0 ##sys#last-invalid-procedure args))) )
+
+(define (unbound-variable-signals-error?) (not ##sys#unbound-variable-value-hook))
+
+; result only trusted when (unbound-variable-signals-error?) is #f
+(define (unbound-variable-given-value)
+ (and ##sys#unbound-variable-value-hook
+ (vector-ref ##sys#unbound-variable-value-hook 0)) )
+
+(define (set-unbound-variable-value! val) (set! ##sys#unbound-variable-value-hook (vector val)))
+
+(define (clear-unbound-variable-value!) (set! ##sys#unbound-variable-value-hook #f))
+
+; this should be the current value procedure
+(define (unbound-variable-value . val)
+ (set! ##sys#unbound-variable-value-hook
+ (and (pair? val)
+ (vector (car val)))) )
+
+
;;; Access computed globals:
(define (global-ref sym)
diff --git a/manual/Unit library b/manual/Unit library
index bf1638eb..e6c2ad40 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -420,6 +420,14 @@ context as the {{condition-case}} form.
</enscript>
+==== breakpoint
+
+<procedure>(breakpoint [NAME])</procedure>
+
+Programmatically triggers a breakpoint (similar to the {{,br}} top-level csi
+command).
+
+
==== get-condition-property
<procedure>(get-condition-property CONDITION KIND PROPERTY [DEFAULT])</procedure>
@@ -481,6 +489,10 @@ Signaled on errors raised by failed matches (see the section on {{match}}).
Signaled on syntax errors.
+</td></tr><tr><td> (exn breakpoint)
+
+Signaled when a breakpoint is reached.
+
</td></tr>
</table>
diff --git a/manual/Unit lolevel b/manual/Unit lolevel
index d145c033..ff57013d 100644
--- a/manual/Unit lolevel
+++ b/manual/Unit lolevel
@@ -434,6 +434,14 @@ These procedures operate with what are known as {{vector-like objects}}. A
Note that strings and blobs are not considered vector-like.
+==== vector-like?
+
+ [procedure] (vector-like? X)
+
+Returns {{#t}} when {{X}} is a vector-like object, returns {{#f}}
+otherwise.
+
+
==== block-ref
[procedure] (block-ref VECTOR* INDEX)
@@ -695,6 +703,47 @@ Returns a new vector with the type and the elements of the record structure
{{RECORD}}. Signals an error if {{RECORD}} is not a record structure.
+
+=== Procedure-call- and variable reference hooks
+
+
+==== set-invalid-procedure-call-handler!
+
+ [procedure] (set-invalid-procedure-call-handler! PROC)
+
+Sets an internal hook that is invoked when a call to an object other than a
+procedure is executed at runtime. The procedure {{PROC}} will in that case be
+called with two arguments: the object being called and a list of the passed
+arguments.
+
+<enscript highlight=scheme>
+;;; Access sequence-elements as in ARC:
+
+(set-invalid-procedure-call-handler!
+ (lambda (proc args)
+ (cond [(string? proc) (apply string-ref proc args)]
+ [(vector? proc) (apply vector-ref proc args)]
+ [else (error "call of non-procedure" proc)] ) ) )
+
+("hello" 4) ==> #\o
+</enscript>
+
+This facility does not work in code compiled with the ''unsafe'' setting.
+
+
+==== unbound-variable-value
+
+ [procedure] (unbound-variable-value [X])
+
+Defines the value that is returned for unbound variables. Normally an error is
+signalled, use this procedure to override the check and return {{X}} instead.
+To set the default behavior (of signalling an error), call
+{{unbound-variable-value}} with no arguments.
+
+This facility does not work in code compiled with the ''unsafe'' setting.
+
+
+
=== Magic
diff --git a/manual/Using the interpreter b/manual/Using the interpreter
index 701a9c06..e9f878c3 100644
--- a/manual/Using the interpreter
+++ b/manual/Using the interpreter
@@ -172,7 +172,19 @@ k
; ,utr SYMBOL ... : Disables tracing of the given toplevel procedures.
-; ,info : Lists traced procedures.
+; ,br SYMBOL ... : Sets a breakpoint at the procedures named {{SYMBOL ...}}. Breakpoint can also be trigged using the {{breakpoint}} procedure.
+
+; ,ubr SYMBOL ... : Removes breakpoints.
+
+; ,c : Continues execution from the last invoked breakpoint.
+
+; ,breakall : Enable breakpoints for all threads (this is the default).
+
+; ,breakonly THREAD : Enable breakpoints only for the thread returned by the expression {{THREAD}}.
+
+; ,info : Lists traced procedures and breakpoints.
+
+; ,step EXPR : Evaluates {{EXPR}} in single-stepping mode. On each procedure call you will be presented with a menu that allows stepping to the next call, leaving single-stepping mode or triggering a breakpoint. Note that you will see some internal calls, and unsafe or heavily optimized compiled code might not be stepped at all. Single-stepping mode is also possible by invoking the {{singlestep}} procedure.
You can define your own toplevel commands using the {{toplevel-command}}
procedure:
diff --git a/runtime.c b/runtime.c
index a67db235..3e8d5a43 100644
--- a/runtime.c
+++ b/runtime.c
@@ -334,6 +334,7 @@ C_TLS void *C_restart_address;
C_TLS int C_entry_point_status;
C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
+C_TLS C_word(*C_get_unbound_variable_value_hook)(C_word sym);
C_TLS void (*C_panic_hook)(C_char *msg) = NULL;
C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
C_TLS void (*C_post_gc_hook)(int mode, long ms) = NULL;
@@ -404,6 +405,12 @@ static C_TLS C_word
interrupt_hook_symbol,
current_thread_symbol,
error_hook_symbol,
+ invalid_procedure_call_hook_symbol,
+ unbound_variable_value_hook_symbol,
+ last_invalid_procedure_symbol,
+ identity_unbound_value_symbol,
+ apply_hook_symbol,
+ last_applied_procedure_symbol,
pending_finalizers_symbol,
callback_continuation_stack_symbol,
*forwarding_table;
@@ -489,6 +496,7 @@ static void C_fcall remark_system_globals(void) C_regparm;
static void C_fcall remark(C_word *x) C_regparm;
static C_word C_fcall intern0(C_char *name) C_regparm;
static void C_fcall update_locative_table(int mode) C_regparm;
+static C_word get_unbound_variable_value(C_word sym);
static LF_LIST *find_module_handle(C_char *name);
static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
@@ -625,6 +633,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;
C_gc_mutation_hook = NULL;
C_gc_trace_hook = NULL;
+ C_get_unbound_variable_value_hook = get_unbound_variable_value;
/* Allocate weak item table: */
if(C_enable_gcweak) {
@@ -972,7 +981,13 @@ void initialize_symbol_table(void)
error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
pending_finalizers_symbol = C_intern2(C_heaptop, C_text("\003syspending-finalizers"));
+ invalid_procedure_call_hook_symbol = C_intern3(C_heaptop, C_text("\003sysinvalid-procedure-call-hook"), C_SCHEME_FALSE);
+ unbound_variable_value_hook_symbol = C_intern3(C_heaptop, C_text("\003sysunbound-variable-value-hook"), C_SCHEME_FALSE);
+ last_invalid_procedure_symbol = C_intern3(C_heaptop, C_text("\003syslast-invalid-procedure"), C_SCHEME_FALSE);
+ identity_unbound_value_symbol = C_intern3(C_heaptop, C_text("\003sysidentity-unbound-value"), C_SCHEME_FALSE);
current_thread_symbol = C_intern3(C_heaptop, C_text("\003syscurrent-thread"), C_SCHEME_FALSE);
+ apply_hook_symbol = C_intern3(C_heaptop, C_text("\003sysapply-hook"), C_SCHEME_FALSE);
+ last_applied_procedure_symbol = C_intern2(C_heaptop, C_text("\003syslast-applied-procedure"));
}
@@ -2958,7 +2973,13 @@ C_regparm void C_fcall mark_system_globals(void)
mark(&error_hook_symbol);
mark(&callback_continuation_stack_symbol);
mark(&pending_finalizers_symbol);
+ mark(&invalid_procedure_call_hook_symbol);
+ mark(&unbound_variable_value_hook_symbol);
+ mark(&last_invalid_procedure_symbol);
+ mark(&identity_unbound_value_symbol);
mark(¤t_thread_symbol);
+ mark(&apply_hook_symbol);
+ mark(&last_applied_procedure_symbol);
}
@@ -3263,7 +3284,13 @@ C_regparm void C_fcall remark_system_globals(void)
remark(&error_hook_symbol);
remark(&callback_continuation_stack_symbol);
remark(&pending_finalizers_symbol);
+ remark(&invalid_procedure_call_hook_symbol);
+ remark(&unbound_variable_value_hook_symbol);
+ remark(&last_invalid_procedure_symbol);
+ remark(&identity_unbound_value_symbol);
remark(¤t_thread_symbol);
+ remark(&apply_hook_symbol);
+ remark(&last_applied_procedure_symbol);
}
@@ -3537,12 +3564,24 @@ C_regparm C_word C_fcall C_retrieve(C_word sym)
C_word val = C_block_item(sym, 0);
if(val == C_SCHEME_UNBOUND)
- barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
+ return C_get_unbound_variable_value_hook(sym);
return val;
}
+C_word get_unbound_variable_value(C_word sym)
+{
+ C_word x = C_block_item(unbound_variable_value_hook_symbol, 0);
+
+ if(x == identity_unbound_value_symbol) return sym;
+ else if(x == C_SCHEME_FALSE)
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
+
+ return C_block_item(x, 0);
+}
+
+
C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
{
C_word *p;
@@ -3553,7 +3592,7 @@ C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
/* this is ok: we won't return from `C_retrieve2'
* (or the value isn't needed). */
p = C_alloc(C_SIZEOF_STRING(len));
- barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));
+ return get_unbound_variable_value(C_string2(&p, name));
}
return val;
@@ -3566,7 +3605,13 @@ static C_word resolve_procedure(C_word closure, C_char *where)
C_word s;
if(C_immediatep(closure) || C_header_bits(closure) != C_CLOSURE_TYPE) {
- barf(C_NOT_A_CLOSURE_ERROR, where, closure);
+ s = C_block_item(invalid_procedure_call_hook_symbol, 0);
+
+ if(s == C_SCHEME_FALSE)
+ barf(C_NOT_A_CLOSURE_ERROR, where, closure);
+
+ C_mutate(&C_block_item(last_invalid_procedure_symbol, 0), closure);
+ closure = s;
}
return closure;
@@ -3577,6 +3622,14 @@ static C_word resolve_procedure(C_word closure, C_char *where)
C_regparm void *C_fcall C_retrieve_proc(C_word closure)
{
closure = resolve_procedure(closure, NULL);
+
+#ifndef C_NO_APPLY_HOOK
+ if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
+ C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
+ return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
+ }
+#endif
+
return (void *)C_block_item(closure, 0);
}
@@ -3587,9 +3640,17 @@ C_regparm void *C_fcall C_retrieve_symbol_proc(C_word sym)
C_word closure;
if(val == C_SCHEME_UNBOUND)
- barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
+ val = C_get_unbound_variable_value_hook(sym);
closure = resolve_procedure(val, NULL);
+
+#ifndef C_NO_APPLY_HOOK
+ if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
+ C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
+ return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
+ }
+#endif
+
return (void *)C_block_item(closure, 0);
}
@@ -3604,10 +3665,18 @@ C_regparm void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name)
len = C_strlen(name);
/* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */
p = C_alloc(C_SIZEOF_STRING(len));
- barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));
+ val = get_unbound_variable_value(C_string2(&p, name));
}
closure = resolve_procedure(val, NULL);
+
+#ifndef C_NO_APPLY_HOOK
+ if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
+ C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
+ return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
+ }
+#endif
+
return (void *)C_block_item(closure, 0);
}
@@ -4191,8 +4260,11 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
#endif
case C_fix(35):
- /* used to be apply-hook indicator */
+#ifndef C_NO_APPLY_HOOK
+ return C_SCHEME_TRUE;
+#else
return C_SCHEME_FALSE;
+#endif
case C_fix(36):
debug_mode = !debug_mode;
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 94040a5c..96d93574 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -265,3 +265,25 @@
(assert (not (eq? foo new-foo)))
(assert (equal? '(hello 1 2) (foo 1 2)))
+
+; set-invalid-procedure-call-handler!
+
+(set-invalid-procedure-call-handler!
+ (lambda (proc args)
+ (cond [(string? proc) (apply string-ref proc args)]
+ [(vector? proc) (apply vector-ref proc args)]
+ [else
+ (error 'lolevel-test:invalid-procedure-call-handler
+ "bad argument type - not a procedure" proc args)])))
+
+(assert (char=? #\b ("abc" 1)))
+
+(assert (char=? #\b ('#(#\a #\b #\c) 1)))
+
+; unbound-variable-value
+
+(unbound-variable-value '23skidoo)
+
+(assert (eq? '23skidoo skidoo))
+
+(unbound-variable-value)
Trap