diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp sbcl-0.9.9-pristine/src/code/fdefinition.lisp sbcl-0.9.9-undefined-fun-restart/src/code/fdefinition.lisp --- sbcl-0.9.9-pristine/src/code/fdefinition.lisp 2005-07-14 12:30:34.000000000 -0400 +++ sbcl-0.9.9-undefined-fun-restart/src/code/fdefinition.lisp 2006-02-06 00:05:47.000000000 -0500 @@ -67,7 +67,13 @@ (defun %coerce-name-to-fun (name) (let ((fdefn (fdefinition-object name nil))) (or (and fdefn (fdefn-fun fdefn)) - (error 'undefined-function :name name)))) + (restart-case + (error 'undefined-function :name name) + (use-value (new-value) + :report (lambda (stream) + (format stream "Supply a value to use in place of ~S." name)) + :interactive sb!kernel::read-evaluated-form + (%coerce-callable-to-fun new-value)))))) (defun (setf %coerce-name-to-fun) (function name) (let ((fdefn (fdefinition-object name t))) (setf (fdefn-fun fdefn) function))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp sbcl-0.9.9-pristine/src/code/interr.lisp sbcl-0.9.9-undefined-fun-restart/src/code/interr.lisp --- sbcl-0.9.9-pristine/src/code/interr.lisp 2005-09-21 11:00:37.000000000 -0400 +++ sbcl-0.9.9-undefined-fun-restart/src/code/interr.lisp 2006-02-05 23:46:13.000000000 -0500 @@ -25,7 +25,40 @@ (fp (gensym)) (context (gensym)) (sc-offsets (gensym)) - (fn-name (symbolicate name "-HANDLER"))) + (fn-name (symbolicate name "-HANDLER")) + (required-arg-forms + (let ((offset -1)) + (mapcar (lambda (var) + `(,var () + (sb!di::sub-access-debug-var-slot + ,fp + (nth ,(incf offset) ,sc-offsets) + ,context))) + required))) + (rest-arg-form + (when rest-pos + `((,(nth (1+ rest-pos) args) + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + ,fp + sc-offset + ,context)) + (nthcdr ,rest-pos ,sc-offsets)))))) + (write-required-arg-forms + (let ((offset -1)) + (mapcar (lambda (var) + `((setf ,var) (value) + (sb!di::sub-set-debug-var-slot + ,fp + (nth ,(incf offset) + ,sc-offsets) + value + ,context))) + required))) + (arg-symbols + (mapcar (lambda (var) + `(,var (,var))) + required))) `(progn ;; FIXME: Having a separate full DEFUN for each error doesn't ;; seem to add much value, and it takes a lot of space. Perhaps @@ -37,23 +70,11 @@ ;; where his error was detected instead of telling him where ;; he ended up inside the system error-handling logic. (declare (ignorable name ,fp ,context ,sc-offsets)) - (let (,@(let ((offset -1)) - (mapcar (lambda (var) - `(,var (sb!di::sub-access-debug-var-slot - ,fp - (nth ,(incf offset) - ,sc-offsets) - ,context))) - required)) - ,@(when rest-pos - `((,(nth (1+ rest-pos) args) - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - ,fp - sc-offset - ,context)) - (nthcdr ,rest-pos ,sc-offsets)))))) - ,@body)) + (let (,@rest-arg-form) + (flet (,@required-arg-forms + ,@write-required-arg-forms) + (symbol-macrolet (,@arg-symbols) + ,@body)))) (setf (svref *internal-errors* ,(error-number-or-lose name)) #',fn-name)))) @@ -179,27 +200,33 @@ :datum object :expected-type 'symbol)) -(deferr undefined-fun-error (fdefn-or-symbol) - (error 'undefined-function - :name (etypecase fdefn-or-symbol - (symbol fdefn-or-symbol) - (fdefn (fdefn-name fdefn-or-symbol))))) +(deferr undefined-fun-error (fdefn-or-symbol return-value) + (restart-case + (error 'undefined-function + :name (etypecase fdefn-or-symbol + (symbol fdefn-or-symbol) + (fdefn (fdefn-name fdefn-or-symbol)))) + (use-value (new-value) + :report (lambda (stream) + (format stream "Supply a value to use in place of ~S." fdefn-or-symbol)) + :interactive sb!kernel::read-evaluated-form + (setf return-value (sb!kernel::%coerce-callable-to-fun new-value))))) (deferr invalid-arg-count-error (nargs) (error 'simple-program-error :format-control "invalid number of arguments: ~S" :format-arguments (list nargs))) -(deferr bogus-arg-to-values-list-error (list) +(deferr bogus-arg-to-values-list-error (input-list) (error 'simple-type-error - :datum list + :datum input-list :expected-type 'list :format-control "~@" - :format-arguments (list list))) + :format-arguments (list input-list))) -(deferr unbound-symbol-error (symbol) - (error 'unbound-variable :name symbol)) +(deferr unbound-symbol-error (input-symbol) + (error 'unbound-variable :name input-symbol)) (deferr object-not-character-error (object) (error 'type-error @@ -222,28 +249,28 @@ :format-control "attempt to THROW to a tag that does not exist: ~S" :format-arguments (list tag))) -(deferr nil-fun-returned-error (function) +(deferr nil-fun-returned-error (fun) (error 'simple-control-error :format-control "A function with declared result type NIL returned:~% ~S" - :format-arguments (list function))) + :format-arguments (list fun))) -(deferr nil-array-accessed-error (array) +(deferr nil-array-accessed-error (nil-array) (error 'nil-array-accessed-error - :datum array :expected-type '(not (array nil)))) + :datum nil-array :expected-type '(not (array nil)))) (deferr division-by-zero-error (this that) (error 'division-by-zero :operation 'division :operands (list this that))) -(deferr object-not-type-error (object type) +(deferr object-not-type-error (object data-type) (error (if (and (%instancep object) (layout-invalid (%instance-layout object))) 'layout-invalid 'type-error) :datum object - :expected-type type)) + :expected-type data-type)) (deferr layout-invalid-error (object layout) (error 'layout-invalid @@ -259,11 +286,11 @@ :format-control "unknown &KEY argument: ~S" :format-arguments (list key-name))) -(deferr invalid-array-index-error (array bound index) +(deferr invalid-array-index-error (input-array bound index) (error 'simple-type-error :format-control "invalid array index ~W for ~S (should be nonnegative and <~W)" - :format-arguments (list index array bound) + :format-arguments (list index input-array bound) :datum index :expected-type `(integer 0 (,bound)))) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp sbcl-0.9.9-pristine/src/compiler/assembly/alpha/alloc.lisp sbcl-0.9.9-undefined-fun-restart/src/compiler/assembly/alpha/alloc.lisp --- sbcl-0.9.9-pristine/src/compiler/x86/cell.lisp 2005-11-28 08:20:58.000000000 -0500 +++ sbcl-0.9.9-undefined-fun-restart/src/compiler/x86/cell.lisp 2006-02-05 23:55:28.000000000 -0500 @@ -239,10 +239,15 @@ (:vop-var vop) (:save-p :compute-only) (:generator 10 - (loadw value object fdefn-fun-slot other-pointer-lowtag) - (inst cmp value nil-value) - (let ((err-lab (generate-error-code vop undefined-fun-error object))) - (inst jmp :e err-lab)))) + (assemble (nil nil :labels (error)) + (loadw value object fdefn-fun-slot other-pointer-lowtag) + (inst cmp value nil-value) + (inst jmp :e ERROR) + DONE + (assemble (*elsewhere*) + ERROR + (cerror-call vop undefined-fun-error object value) + (inst jmp DONE))))) (define-vop (set-fdefn-fun) (:policy :fast-safe) diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp sbcl-0.9.9-pristine/src/compiler/x86/macros.lisp sbcl-0.9.9-undefined-fun-restart/src/compiler/x86/macros.lisp --- sbcl-0.9.9-pristine/src/compiler/x86/macros.lisp 2005-11-28 08:20:59.000000000 -0500 +++ sbcl-0.9.9-undefined-fun-restart/src/compiler/x86/macros.lisp 2006-02-05 23:54:03.000000000 -0500 @@ -305,6 +305,12 @@ (cons 'progn (emit-error-break vop error-trap error-code values))) +(defmacro cerror-call (vop error-code &rest values) + #!+sb-doc + "Cause a continuable error. ERROR-CODE is the error to cause." + (cons 'progn + (emit-error-break vop cerror-trap error-code values))) + (defmacro generate-error-code (vop error-code &rest values) #!+sb-doc "Generate-Error-Code Error-code Value* diff -Nur -x '*.trace' -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x target -x CVS -x 'target-*.h' -x output -x genesis -x '*.o' -x '*.nm' -x '*.core' -x '*.map' -x '*.d' -x '*~' -x '*.lisp-obj' -x '*.fasl' -x '*.lisp-temp' -x systems -x '*.tmp' -x local-target-features.lisp-expr -x a.out -x '*.so' -x foo.c -x sbcl -x grovel-headers -x customize-target-features.lisp sbcl-0.9.9-pristine/src/runtime/x86-assem.S sbcl-0.9.9-undefined-fun-restart/src/runtime/x86-assem.S --- sbcl-0.9.9-pristine/src/runtime/x86-assem.S 2006-01-24 12:15:51.000000000 -0500 +++ sbcl-0.9.9-undefined-fun-restart/src/runtime/x86-assem.S 2006-02-05 23:31:34.000000000 -0500 @@ -17,6 +17,7 @@ #include "sbcl.h" #include "validate.h" #include "genesis/closure.h" +#include "genesis/simple-fun.h" #include "genesis/fdefn.h" #include "genesis/static-symbols.h" #include "genesis/symbol.h" @@ -314,11 +315,12 @@ .byte 0, 0, 0, SIMPLE_FUN_HEADER_WIDETAG GNAME(undefined_tramp): int3 - .byte trap_Error - .byte 2 + .byte trap_Cerror + .byte 3 .byte UNDEFINED_FUN_ERROR .byte sc_DescriptorReg # eax in the Descriptor-reg SC - ret + .byte sc_DescriptorReg # same again, for return path + jmp *SIMPLE_FUN_SELF_OFFSET(%eax) SIZE(GNAME(undefined_tramp)) /*