diff -Nur -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x assembly -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 sbcl-0.9.8.38-pristine/src/code/interr.lisp sbcl-0.9.8.38-symbol-value-2/src/code/interr.lisp --- sbcl-0.9.8.38-pristine/src/code/interr.lisp 2005-09-09 10:16:18.000000000 -0400 +++ sbcl-0.9.8.38-symbol-value-2/src/code/interr.lisp 2006-01-16 20:29:35.000000000 -0500 @@ -19,12 +19,64 @@ (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. +;; +;; 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)) - (fp (gensym)) + (let* ((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 +89,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)))) @@ -198,8 +238,34 @@ "~@" :format-arguments (list list))) -(deferr unbound-symbol-error (symbol) - (error 'unbound-variable :name symbol)) +(deferr unbound-symbol-error #!-x86 (symbol) #!+x86 (symbol &write value) + #!-x86 + (error 'unbound-variable :name symbol) + #!+x86 + (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 diff -Nur -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x assembly -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 sbcl-0.9.8.38-pristine/src/compiler/x86/cell.lisp sbcl-0.9.8.38-symbol-value-2/src/compiler/x86/cell.lisp --- sbcl-0.9.8.38-pristine/src/compiler/x86/cell.lisp 2005-11-17 07:13:38.000000000 -0500 +++ sbcl-0.9.8.38-symbol-value-2/src/compiler/x86/cell.lisp 2006-01-16 18:38:07.000000000 -0500 @@ -109,8 +109,14 @@ (:save-p :compute-only) (:generator 9 (let* ((check-unbound-label (gen-label)) - (err-lab (generate-error-code vop unbound-symbol-error object)) + (restart-label (gen-label)) + (err-lab (generate-error-code vop unbound-symbol-error object value)) (ret-lab (gen-label))) + (assemble (*elsewhere*) + (inst cmp value unbound-marker-widetag) + (inst jmp :e restart-label) + (inst jmp ret-lab)) + (emit-label restart-label) (loadw value object symbol-tls-index-slot other-pointer-lowtag) (inst fs-segment-prefix) (inst mov value (make-ea :dword :index value :scale 1)) @@ -150,10 +156,18 @@ (:vop-var vop) (:save-p :compute-only) (:generator 9 - (let ((err-lab (generate-error-code vop unbound-symbol-error object))) + (let ((restart-label (gen-label)) + (return-label (gen-label)) + (err-lab (generate-error-code vop unbound-symbol-error object value))) + (assemble (*elsewhere*) + (inst cmp value unbound-marker-widetag) + (inst jmp :e restart-label) + (inst jmp return-label)) + (emit-label restart-label) (loadw value object symbol-value-slot other-pointer-lowtag) (inst cmp value unbound-marker-widetag) - (inst jmp :e err-lab)))) + (inst jmp :e err-lab) + (emit-label return-label)))) #!-sb-thread (define-vop (fast-symbol-value cell-ref) diff -Nur -x '*.rej' -x '*.orig' -x sbcl.h -x ldso-stubs.S -x Config -x assembly -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 sbcl-0.9.8.38-pristine/src/runtime/interrupt.c sbcl-0.9.8.38-symbol-value-2/src/runtime/interrupt.c --- sbcl-0.9.8.38-pristine/src/runtime/interrupt.c 2006-01-05 09:13:14.000000000 -0500 +++ sbcl-0.9.8.38-symbol-value-2/src/runtime/interrupt.c 2006-01-16 17:42:20.000000000 -0500 @@ -345,8 +345,12 @@ continuable ? T : NIL); undo_fake_foreign_function_call(context); /* blocks signals again */ - if (continuable) - arch_skip_instruction(context); + + /* In general, if we return here, we're going to try and restart + * the original code. In which case, we -have- to skip the error + * trap information. */ + /* if (continuable) */ + arch_skip_instruction(context); } void