~ chicken-core (chicken-5) 6e5eb38f11a2a8f9a82d1009563e371139a76438
commit 6e5eb38f11a2a8f9a82d1009563e371139a76438
Author: Felix <bunny351@gmail.com>
AuthorDate: Sun Oct 11 00:45:40 2009 +0200
Commit: Felix <bunny351@gmail.com>
CommitDate: Wed Oct 14 23:28:56 2009 +0200
removed apply-, unbound-value- and invalid procedure call hooks.
These are just complicated hacks with very little value.
diff --git a/README b/README
index 370677fe..a4e454aa 100644
--- a/README
+++ b/README
@@ -124,13 +124,6 @@
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 02eea351..c5184965 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 do-break do-unbreak broken-procedures) )
+ findall trace-indent command-table) )
;;; Parameters:
@@ -254,7 +254,6 @@ EOF
(let ((eval eval)
(load-noisily load-noisily)
(read read)
- (singlestep singlestep)
(read-line read-line)
(length length)
(display display)
@@ -317,37 +316,13 @@ 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)) )
- (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") ) ) )
+ (printf "Traced: ~s~%" (map car traced-procedures)) ) )
((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:
@@ -364,14 +339,7 @@ EOF
,s TEXT ... Execute shell-command
,tr NAME ... Trace procedures
,utr NAME ... Untrace 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
+ ,info List traced procedures
,exn Describe last exception
,t EXP Evaluate form and print elapsed time
,x EXP Pretty print expanded expression EXP\n")
@@ -448,8 +416,6 @@ 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))
@@ -477,49 +443,6 @@ 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 be990fd5..4a65a7c0 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#break-entry ##sys#step
+ ##sys#pointer->address number->string ##sys#flush-output
##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
@@ -3305,7 +3305,6 @@ 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"
@@ -3354,7 +3353,6 @@ 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)
@@ -3452,105 +3450,6 @@ 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 58ea8f22..77aa16aa 100644
--- a/lolevel.import.scm
+++ b/lolevel.import.scm
@@ -31,7 +31,6 @@
allocate
block-ref
block-set!
- clear-unbound-variable-value!
extend-procedure
extended-procedure?
free
@@ -39,7 +38,6 @@
global-make-unbound!
global-ref
global-set!
- invalid-procedure-call-handler
locative->object
locative-ref
locative-set!
@@ -92,12 +90,6 @@
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?
- unbound-variable-value
- unbound-variable-given-value
- unbound-variable-signals-error?
- vector-like?))
+ tagged-pointer?))
diff --git a/lolevel.scm b/lolevel.scm
index b27036a2..32628bfa 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -440,9 +440,6 @@ 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) )
@@ -647,38 +644,6 @@ 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 e6c2ad40..bf1638eb 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -420,14 +420,6 @@ 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>
@@ -489,10 +481,6 @@ 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 ff57013d..d145c033 100644
--- a/manual/Unit lolevel
+++ b/manual/Unit lolevel
@@ -434,14 +434,6 @@ 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)
@@ -703,47 +695,6 @@ 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 e9f878c3..701a9c06 100644
--- a/manual/Using the interpreter
+++ b/manual/Using the interpreter
@@ -172,19 +172,7 @@ k
; ,utr SYMBOL ... : Disables tracing of the given toplevel 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.
+; ,info : Lists traced procedures.
You can define your own toplevel commands using the {{toplevel-command}}
procedure:
diff --git a/runtime.c b/runtime.c
index 3e8d5a43..a67db235 100644
--- a/runtime.c
+++ b/runtime.c
@@ -334,7 +334,6 @@ 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;
@@ -405,12 +404,6 @@ 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;
@@ -496,7 +489,6 @@ 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;
@@ -633,7 +625,6 @@ 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) {
@@ -981,13 +972,7 @@ 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"));
}
@@ -2973,13 +2958,7 @@ 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);
}
@@ -3284,13 +3263,7 @@ 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);
}
@@ -3564,21 +3537,9 @@ C_regparm C_word C_fcall C_retrieve(C_word sym)
C_word val = C_block_item(sym, 0);
if(val == C_SCHEME_UNBOUND)
- 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);
+ return val;
}
@@ -3592,7 +3553,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));
- return get_unbound_variable_value(C_string2(&p, name));
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, C_string2(&p, name));
}
return val;
@@ -3605,13 +3566,7 @@ 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) {
- 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;
+ barf(C_NOT_A_CLOSURE_ERROR, where, closure);
}
return closure;
@@ -3622,14 +3577,6 @@ 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);
}
@@ -3640,17 +3587,9 @@ C_regparm void *C_fcall C_retrieve_symbol_proc(C_word sym)
C_word closure;
if(val == C_SCHEME_UNBOUND)
- val = C_get_unbound_variable_value_hook(sym);
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, 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);
}
@@ -3665,18 +3604,10 @@ 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));
- val = get_unbound_variable_value(C_string2(&p, name));
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, 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);
}
@@ -4260,11 +4191,8 @@ C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
#endif
case C_fix(35):
-#ifndef C_NO_APPLY_HOOK
- return C_SCHEME_TRUE;
-#else
+ /* used to be apply-hook indicator */
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 96d93574..94040a5c 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -265,25 +265,3 @@
(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