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.13-pristine/src/code/fdefinition.lisp sbcl-0.9.13-restarts/src/code/fdefinition.lisp --- sbcl-0.9.13-pristine/src/code/fdefinition.lisp 2005-07-14 12:30:34.000000000 -0400 +++ sbcl-0.9.13-restarts/src/code/fdefinition.lisp 2006-06-06 13:35:17.000000000 -0400 @@ -67,7 +67,16 @@ (defun %coerce-name-to-fun (name) (let ((fdefn (fdefinition-object name nil))) (or (and fdefn (fdefn-fun fdefn)) - (error 'undefined-function :name name)))) + #!-(or x86) + (error 'undefined-function :name name) + #!+(or x86) + (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.13-pristine/src/code/interr.lisp sbcl-0.9.13-restarts/src/code/interr.lisp --- sbcl-0.9.13-pristine/src/code/interr.lisp 2005-09-09 10:16:18.000000000 -0400 +++ sbcl-0.9.13-restarts/src/code/interr.lisp 2006-06-06 13:38:07.000000000 -0400 @@ -19,12 +19,67 @@ (eval-when (:compile-toplevel :execute) +;; This has been hacked up a bit to support an extra lambda-list- +;; keyword, available nowhere else, called &write. &write arguments +;; are not available for reading, but are available to be setf in +;; order to pass information back to resumable compiled code. +;; +;; At present, there is no way to change the value of a normal +;; parameter. It would not be hard to add support for this if it +;; turns out to be needed, but may make for a noisy patch due to +;; using symbol-macrolet on each value (not allowed for symbols in +;; the CL package). +;; +;; FIXME: &write and &rest are mutually exclusive, but this isn't +;; checked for. (sb!xc:defmacro deferr (name args &rest body) - (let* ((rest-pos (position '&rest args)) - (required (if rest-pos (subseq args 0 rest-pos) args)) + (let* ((fp (gensym)) (fp (gensym)) (context (gensym)) (sc-offsets (gensym)) + (rest-pos (position '&rest args)) + (write-pos (position '&write args)) + (end-of-required-args (or write-pos rest-pos)) + (write-args (and write-pos (if rest-pos + (subseq args (1+ write-pos) rest-pos) + (nthcdr (1+ write-pos) args)))) + (required (if end-of-required-args + (subseq args 0 end-of-required-args) + args)) + (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-arg-forms + (when write-pos + (let ((offset (1- write-pos))) + (mapcar (lambda (var) + `((setf ,var) (value) + (sb!di::sub-set-debug-var-slot + ,fp + (nth ,(incf offset) + ,sc-offsets) + value + ,context))) + write-args)))) + (write-arg-symbols + (mapcar (lambda (var) + `(,var (,var))) + write-args)) (fn-name (symbolicate name "-HANDLER"))) `(progn ;; FIXME: Having a separate full DEFUN for each error doesn't @@ -37,23 +92,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 (,@required-arg-forms + ,@rest-arg-form) + (flet (,@write-arg-forms) + (symbol-macrolet (,@write-arg-symbols) + ,@body)))) (setf (svref *internal-errors* ,(error-number-or-lose name)) #',fn-name)))) @@ -179,11 +222,25 @@ :datum object :expected-type 'symbol)) +#!-(or x86) (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))))) + :name (etypecase fdefn-or-symbol + (symbol fdefn-or-symbol) + (fdefn (fdefn-name fdefn-or-symbol))))) + +#!+(or x86) +(deferr undefined-fun-error (fdefn-or-symbol &write 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 @@ -198,9 +255,37 @@ "~@" :format-arguments (list list))) +#!-(or x86) (deferr unbound-symbol-error (symbol) (error 'unbound-variable :name symbol)) +#!+(or x86) +(deferr unbound-symbol-error (symbol &write value) + (restart-case (error 'unbound-variable :name symbol) + ;; Okay, here's the magic: If an internal-error handler + ;; returns, the runtime moves the instruction pointer in the + ;; erring context past the encoded error information and + ;; returns, resuming execution of the old code. The compiler + ;; has graciously arranged for a small amount of recovery + ;; code to be placed at the point where execution will resume. + ;; This recovery code will check to see if VALUE is still the + ;; unbound marker. If it is, it will retry reading the symbol. + ;; Otherwise, it uses the new VALUE in place of the symbol + ;; value. + (reevaluate-symbol () + :report (lambda (stream) + (format stream "Reevaluate ~S." symbol))) + (store-value (new-value) + :report (lambda (stream) + (format stream "Supply a new value for ~S." symbol)) + :interactive sb!kernel::read-evaluated-form + (set symbol new-value)) + (use-value (new-value) + :report (lambda (stream) + (format stream "Supply a value to use in place of ~S." symbol)) + :interactive sb!kernel::read-evaluated-form + (setf value new-value)))) + (deferr object-not-character-error (object) (error 'type-error :datum object 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.13-pristine/src/compiler/assembly/alpha/alloc.lisp sbcl-0.9.13-restarts/src/compiler/assembly/alpha/alloc.lisp --- sbcl-0.9.13-pristine/src/compiler/x86/cell.lisp 2006-05-15 07:56:21.000000000 -0400 +++ sbcl-0.9.13-restarts/src/compiler/x86/cell.lisp 2006-06-06 10:37:23.000000000 -0400 @@ -107,19 +107,24 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let* ((check-unbound-label (gen-label)) - (err-lab (generate-error-code vop unbound-symbol-error object)) - (ret-lab (gen-label))) + (assemble (nil nil :labels (error)) + RETRY (loadw value object symbol-tls-index-slot other-pointer-lowtag) (inst fs-segment-prefix) (inst mov value (make-ea :dword :base value)) (inst cmp value no-tls-value-marker-widetag) - (inst jmp :ne check-unbound-label) + (inst jmp :ne CHECK-UNBOUND) (loadw value object symbol-value-slot other-pointer-lowtag) - (emit-label check-unbound-label) + CHECK-UNBOUND (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab) - (emit-label ret-lab)))) + (inst jmp :e ERROR) + DONE + (assemble (*elsewhere*) + ERROR + (cerror-call vop unbound-symbol-error object value) + (inst cmp value unbound-marker-widetag) + (inst jmp :e RETRY) + (inst jmp DONE))))) #!+sb-thread (define-vop (fast-symbol-value symbol-value) @@ -149,10 +154,18 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let ((err-lab (generate-error-code vop unbound-symbol-error object))) - (loadw value object symbol-value-slot other-pointer-lowtag) - (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab)))) + (assemble (nil nil :labels (error)) + RETRY + (loadw value object symbol-value-slot other-pointer-lowtag) + (inst cmp value unbound-marker-widetag) + (inst jmp :e ERROR) + DONE + (assemble (*elsewhere*) + ERROR + (cerror-call vop unbound-symbol-error object value) + (inst cmp value unbound-marker-widetag) + (inst jmp :e RETRY) + (inst jmp DONE))))) #!-sb-thread (define-vop (fast-symbol-value cell-ref) @@ -238,10 +251,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.13-pristine/src/compiler/x86/macros.lisp sbcl-0.9.13-restarts/src/compiler/x86/macros.lisp --- sbcl-0.9.13-pristine/src/compiler/x86/macros.lisp 2006-03-19 21:49:16.000000000 -0500 +++ sbcl-0.9.13-restarts/src/compiler/x86/macros.lisp 2006-06-06 09:27:36.000000000 -0400 @@ -313,6 +313,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.13-pristine/src/runtime/x86-assem.S sbcl-0.9.13-restarts/src/runtime/x86-assem.S --- sbcl-0.9.13-pristine/src/runtime/x86-assem.S 2006-03-15 00:40:17.000000000 -0500 +++ sbcl-0.9.13-restarts/src/runtime/x86-assem.S 2006-06-06 09:30:08.000000000 -0400 @@ -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" @@ -335,11 +336,12 @@ .byte 0, 0, 0, SIMPLE_FUN_HEADER_WIDETAG GNAME(undefined_tramp): TRAP - .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 # eax in the Descriptor-reg SC + jmp *SIMPLE_FUN_SELF_OFFSET(%eax) SIZE(GNAME(undefined_tramp)) /*