# if we're building for x86. -- CSR, 2002-02-21 Then we do something
# similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
if [ "$sbcl_arch" = "x86" ]; then
- printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
+ printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :unwind-to-frame-and-call-vop' >> $ltf
printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ] || [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "darwin" ] || [ "$sbcl_os" = "win32" ]; then
printf ' :linkage-table' >> $ltf
printf ' :os-provides-dlopen' >> $ltf
fi
elif [ "$sbcl_arch" = "x86-64" ]; then
- printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
+ printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table :unwind-to-frame-and-call-vop' >> $ltf
printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
elif [ "$sbcl_arch" = "mips" ]; then
printf ' :linkage-table' >> $ltf
(loop while (read-char-no-hang *standard-input*)))
(defun unwind-to-frame-and-call (frame thunk)
+ #!+unwind-to-frame-and-call-vop
+ (flet ((sap-int/fixnum (sap)
+ ;; On unithreaded X86 *BINDING-STACK-POINTER* and
+ ;; *CURRENT-CATCH-BLOCK* are negative, so we need to jump through
+ ;; some hoops to make these calculated values negative too.
+ (ash (truly-the (signed-byte #.sb!vm:n-word-bits)
+ (sap-int sap))
+ (- sb!vm::n-fixnum-tag-bits))))
+ ;; To properly unwind the stack, we need three pieces of information:
+ ;; * The unwind block that should be active after the unwind
+ ;; * The catch block that should be active after the unwind
+ ;; * The values that the binding stack pointer should have after the
+ ;; unwind.
+ (let* ((block (sap-int/fixnum (find-enclosing-catch-block frame)))
+ (unbind-to (sap-int/fixnum (find-binding-stack-pointer frame))))
+ ;; This VOP will run the neccessary cleanup forms, reset the fp, and
+ ;; then call the supplied function.
+ (sb!vm::%primitive sb!vm::unwind-to-frame-and-call
+ (sb!di::frame-pointer frame)
+ (find-enclosing-uwp frame)
+ (lambda ()
+ ;; Before calling the user-specified
+ ;; function, we need to restore the binding
+ ;; stack and the catch block. The unwind block
+ ;; is taken care of by the VOP.
+ (sb!vm::%primitive sb!vm::unbind-to-here
+ unbind-to)
+ (setf sb!vm::*current-catch-block* block)
+ (funcall thunk)))))
+ #!-unwind-to-frame-and-call-vop
(let ((tag (gensym)))
(sb!di:replace-frame-catch-tag frame
'sb!c:debug-catch-tag
tag)
(throw tag thunk)))
+(defun find-binding-stack-pointer (frame)
+ #!-stack-grows-downward-not-upward
+ (error "Not implemented on this architecture")
+ #!+stack-grows-downward-not-upward
+ (let ((bsp (sb!vm::binding-stack-pointer-sap))
+ (unbind-to nil)
+ (fp (sb!di::frame-pointer frame))
+ (start (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
+ (ash sb!vm:*binding-stack-start*
+ sb!vm:n-fixnum-tag-bits)))))
+ ;; Walk the binding stack looking for an entry where the symbol is
+ ;; an unbound-symbol marker and the value is equal to the frame
+ ;; pointer. These entries are inserted into the stack by the
+ ;; BIND-SENTINEL VOP and removed by UNBIND-SENTINEL (inserted into
+ ;; the function during IR2). If an entry wasn't found, the
+ ;; function that the frame corresponds to wasn't compiled with a
+ ;; high enough debug setting, and can't be restarted / returned
+ ;; from.
+ (loop until (sap= bsp start)
+ do (progn
+ (setf bsp (sap+ bsp
+ (- (* sb!vm:binding-size sb!vm:n-word-bytes))))
+ (let ((symbol (sap-ref-word bsp (* sb!vm:binding-symbol-slot
+ sb!vm:n-word-bytes)))
+ (value (sap-ref-sap bsp (* sb!vm:binding-value-slot
+ sb!vm:n-word-bytes))))
+ (when (eql symbol sb!vm:unbound-marker-widetag)
+ (when (sap= value fp)
+ (setf unbind-to bsp))))))
+ unbind-to))
+
+(defun find-enclosing-catch-block (frame)
+ ;; Walk the catch block chain looking for the first entry with an address
+ ;; higher than the pointer for FRAME or a null pointer.
+ (let* ((frame-pointer (sb!di::frame-pointer frame))
+ (current-block (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
+ (ash sb!vm::*current-catch-block*
+ sb!vm:n-fixnum-tag-bits))))
+ (enclosing-block (loop for block = current-block
+ then (sap-ref-sap block
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm::n-word-bytes))
+ when (or (zerop (sap-int block))
+ (sap> block frame-pointer))
+ return block)))
+ enclosing-block))
+
+(defun find-enclosing-uwp (frame)
+ ;; Walk the UWP chain looking for the first entry with an address
+ ;; higher than the pointer for FRAME or a null pointer.
+ (let* ((frame-pointer (sb!di::frame-pointer frame))
+ (current-uwp (int-sap (ldb (byte #.sb!vm:n-word-bits 0)
+ (ash sb!vm::*current-unwind-protect-block*
+ sb!vm:n-fixnum-tag-bits))))
+ (enclosing-uwp (loop for uwp-block = current-uwp
+ then (sap-ref-sap uwp-block
+ sb!vm:unwind-block-current-uwp-slot)
+ when (or (zerop (sap-int uwp-block))
+ (sap> uwp-block frame-pointer))
+ return uwp-block)))
+ enclosing-uwp))
+
(!def-debug-command "RETURN" (&optional
(return (read-prompting-maybe
"return: ")))
and recompiling)~:@>")))
(defun frame-has-debug-tag-p (frame)
+ #!+unwind-to-frame-and-call-vop
+ (not (null (find-binding-stack-pointer frame)))
+ #!-unwind-to-frame-and-call-vop
(find 'sb!c:debug-catch-tag (sb!di::frame-catches frame) :key #'car))
\f
;;; versions which break binary compatibility. But it certainly should
;;; be incremented for release versions which break binary
;;; compatibility.
-(def!constant +fasl-file-version+ 73)
+(def!constant +fasl-file-version+ 74)
;;; (description of versions before 0.9.0.1 deleted in 0.9.17)
;;; 56: (2005-05-22) Something between 0.9.0.1 and 0.9.0.14. My money is
;;; on 0.9.0.6 (MORE CASE CONSISTENCY).
;;; 71: (2006-11-19) CLOS calling convention changes
;;; 72: (2006-12-05) Added slot to the primitive function type
;;; 73: (2007-04-13) Changed a hash function
+;;; 74: (2007-06-05) UNWIND-TO-FRAME-AND-CALL
;;; the conventional file extension for our fasl files
(declaim (type simple-string *fasl-file-type*))
;;; -- It appears to be more efficient to use the standard convention,
;;; since there are no non-TR local calls that could benefit from
;;; a non-standard convention.
+;;; -- We're compiling with RETURN-FROM-FRAME instrumentation, which
+;;; only works (on x86 and x86-64) for the standard convention.
(defun use-standard-returns (tails)
(declare (type tail-set tails))
(let ((funs (tail-set-funs tails)))
(or (and (find-if #'xep-p funs)
(find-if #'has-full-call-use funs))
+ (some (lambda (fun) (policy fun (>= insert-debug-catch 2))) funs)
(block punt
(dolist (fun funs t)
(dolist (ref (leaf-refs fun))
res))))
(defun wrap-forms-in-debug-catch (forms)
+ #!+unwind-to-frame-and-call-vop
+ `((multiple-value-prog1
+ (progn
+ ,@forms)
+ ;; Just ensure that there won't be any tail-calls, IR2 magic will
+ ;; handle the rest.
+ (values)))
+ #!-unwind-to-frame-and-call-vop
`( ;; Normally, we'll return from this block with the below RETURN-FROM.
(block
return-value-tag
(ir2-physenv-return-pc-pass env)
(ir2-physenv-return-pc env))
+ #!+unwind-to-frame-and-call-vop
+ (when (and (policy fun (>= insert-debug-catch 2))
+ (lambda-return fun))
+ (vop sb!vm::bind-sentinel node block))
+
(let ((lab (gen-label)))
(setf (ir2-physenv-environment-start env) lab)
(vop note-environment-start node block lab)))
(old-fp (ir2-physenv-old-fp env))
(return-pc (ir2-physenv-return-pc env))
(returns (tail-set-info (lambda-tail-set fun))))
+ #!+unwind-to-frame-and-call-vop
+ (when (policy fun (>= insert-debug-catch 2))
+ (vop sb!vm::unbind-sentinel node block))
(cond
((and (eq (return-info-kind returns) :fixed)
(not (xep-p fun)))
(loadw symbol bsp (- binding-symbol-slot binding-size))
(inst or symbol symbol)
(inst jmp :z SKIP)
+ ;; Bind stack debug sentinels have the unbound marker in the symbol slot
+ (inst cmp symbol unbound-marker-widetag)
+ (inst jmp :eq SKIP)
(loadw value bsp (- binding-value-slot binding-size))
#!-sb-thread
(storew value symbol symbol-value-slot other-pointer-lowtag)
(store-binding-stack-pointer bsp)
DONE))
+
+(define-vop (bind-sentinel)
+ (:temporary (:sc unsigned-reg) bsp)
+ (:generator 1
+ (load-binding-stack-pointer bsp)
+ (inst add bsp (* binding-size n-word-bytes))
+ (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
+ (storew rbp-tn bsp (- binding-value-slot binding-size))
+ (store-binding-stack-pointer bsp)))
+
+(define-vop (unbind-sentinel)
+ (:temporary (:sc unsigned-reg) bsp)
+ (:generator 1
+ (load-binding-stack-pointer bsp)
+ (storew 0 bsp (- binding-value-slot binding-size))
+ (storew 0 bsp (- binding-symbol-slot binding-size))
+ (inst sub bsp (* binding-size n-word-bytes))
+ (store-binding-stack-pointer bsp)))
+
\f
\f
(:generator 0
(emit-label label)
(note-this-location vop :non-local-entry)))
+
+(define-vop (unwind-to-frame-and-call)
+ (:args (ofp :scs (descriptor-reg))
+ (uwp :scs (descriptor-reg))
+ (function :scs (descriptor-reg)))
+ (:arg-types system-area-pointer system-area-pointer t)
+ (:temporary (:sc sap-reg) temp)
+ (:temporary (:sc unsigned-reg :offset rax-offset) block)
+ (:generator 22
+ ;; Store the function into a non-stack location, since we'll be
+ ;; unwinding the stack and destroying register contents before we
+ ;; use it.
+ (store-tl-symbol-value function
+ *unwind-to-frame-function*
+ temp)
+
+ ;; Allocate space for magic UWP block.
+ (inst sub rsp-tn unwind-block-size)
+ ;; Set up magic catch / UWP block.
+ (move block rsp-tn)
+ (loadw temp uwp sap-pointer-slot other-pointer-lowtag)
+ (storew temp block unwind-block-current-uwp-slot)
+ (loadw temp ofp sap-pointer-slot other-pointer-lowtag)
+ (storew temp block unwind-block-current-cont-slot)
+
+ (inst lea temp-reg-tn (make-fixup nil :code-object entry-label))
+ (storew temp-reg-tn
+ block
+ catch-block-entry-pc-slot)
+
+ ;; Run any required UWPs.
+ (inst lea temp-reg-tn (make-fixup 'unwind :assembly-routine))
+ (inst jmp temp-reg-tn)
+ ENTRY-LABEL
+
+ ;; Load function from symbol
+ (load-tl-symbol-value block *unwind-to-frame-function*)
+
+ ;; No parameters
+ (zeroize rcx-tn)
+
+ ;; Clear the stack
+ (inst lea rsp-tn
+ (make-ea :qword :base rbp-tn :disp (* -3 n-word-bytes)))
+
+ ;; Push the return-pc so it looks like we just called.
+ (pushw rbp-tn -2)
+
+ ;; Call it
+ (inst jmp (make-ea :qword :base block
+ :disp (- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag)))))
;; For GC-AND-SAVE
*restart-lisp-function*
+ ;; For the UNWIND-TO-FRAME-AND-CALL VOP
+ *unwind-to-frame-function*
+
;; Needed for callbacks to work across saving cores. see
;; ALIEN-CALLBACK-ASSEMBLER-WRAPPER in c-call.lisp for gory
;; details.
(loadw symbol bsp (- binding-symbol-slot binding-size))
(inst or symbol symbol)
(inst jmp :z skip)
+ ;; Bind stack debug sentinels have the unbound marker in the symbol slot
+ (inst cmp symbol unbound-marker-widetag)
+ (inst jmp :eq skip)
(loadw value bsp (- binding-value-slot binding-size))
#!-sb-thread (storew value symbol symbol-value-slot other-pointer-lowtag)
(store-binding-stack-pointer bsp)
DONE))
+
+(define-vop (bind-sentinel)
+ (:temporary (:sc unsigned-reg) bsp)
+ (:generator 1
+ (load-binding-stack-pointer bsp)
+ (inst add bsp (* binding-size n-word-bytes))
+ (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
+ (storew ebp-tn bsp (- binding-value-slot binding-size))
+ (store-binding-stack-pointer bsp)))
+
+(define-vop (unbind-sentinel)
+ (:temporary (:sc unsigned-reg) bsp)
+ (:generator 1
+ (load-binding-stack-pointer bsp)
+ (storew 0 bsp (- binding-value-slot binding-size))
+ (storew 0 bsp (- binding-symbol-slot binding-size))
+ (inst sub bsp (* binding-size n-word-bytes))
+ (store-binding-stack-pointer bsp)))
\f
\f
(:generator 0
(emit-label label)
(note-this-location vop :non-local-entry)))
+
+(define-vop (unwind-to-frame-and-call)
+ (:args (ofp :scs (descriptor-reg))
+ (uwp :scs (descriptor-reg))
+ (function :scs (descriptor-reg)))
+ (:arg-types system-area-pointer system-area-pointer t)
+ (:temporary (:sc sap-reg) temp)
+ (:temporary (:sc unsigned-reg :offset eax-offset) block)
+ (:generator 22
+ ;; Store the function into a non-stack location, since we'll be
+ ;; unwinding the stack and destroying register contents before we
+ ;; use it.
+ (store-tl-symbol-value function
+ *unwind-to-frame-function*
+ temp)
+
+ ;; Allocate space for magic UWP block.
+ (inst sub esp-tn unwind-block-size)
+ ;; Set up magic catch / UWP block.
+ (move block esp-tn)
+ (loadw temp uwp sap-pointer-slot other-pointer-lowtag)
+ (storew temp block unwind-block-current-uwp-slot)
+ (loadw temp ofp sap-pointer-slot other-pointer-lowtag)
+ (storew temp block unwind-block-current-cont-slot)
+
+ (storew (make-fixup nil :code-object entry-label)
+ block
+ catch-block-entry-pc-slot)
+
+ ;; Run any required UWPs.
+ (inst jmp (make-fixup 'unwind :assembly-routine))
+ ENTRY-LABEL
+
+ ;; Load function from symbol
+ (load-tl-symbol-value block *unwind-to-frame-function*)
+
+ ;; No parameters
+ (inst xor ecx-tn ecx-tn)
+
+ ;; Clear the stack
+ (inst lea esp-tn
+ (make-ea :dword :base ebp-tn :disp (* -3 n-word-bytes)))
+
+ ;; Push the return-pc so it looks like we just called.
+ (pushw ebp-tn -2)
+
+ ;; Call it
+ (inst jmp (make-ea :dword :base block
+ :disp (- (* closure-fun-slot n-word-bytes)
+ fun-pointer-lowtag)))))
;; For GC-AND-SAVE
*restart-lisp-function*
+ ;; For the UNWIND-TO-FRAME-AND-CALL VOP
+ *unwind-to-frame-function*
+
;; Needed for callbacks to work across saving cores. see
;; ALIEN-CALLBACK-ASSEMBLER-WRAPPER in c-call.lisp for gory
;; details.
--- /dev/null
+;;;; This file is for testing UNWIND-TO-FRAME-AND-CALL, used for
+;;;; implementing RESTART-FRAME and RETURN-FROM-FRAME in the debugger.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; The debugger doesn't have any native knowledge of the interpreter
+(when (eq sb-ext:*evaluator-mode* :interpret)
+ (sb-ext:quit :unix-status 104))
+
+(declaim (optimize debug))
+
+(defun return-from-frame (frame-name &rest values)
+ (let ((frame (sb-di::top-frame)))
+ (loop until (equal (sb-debug::frame-call frame)
+ frame-name)
+ do (setf frame (sb-di::frame-down frame)))
+ (assert frame)
+ (assert (sb-debug::frame-has-debug-tag-p frame))
+ (sb-debug::unwind-to-frame-and-call frame
+ (lambda ()
+ (values-list values)))))
+
+(defun restart-frame (frame-name)
+ (let ((frame (sb-di::top-frame)))
+ (loop until (equal (sb-debug::frame-call frame)
+ frame-name)
+ do (setf frame (sb-di::frame-down frame)))
+ (assert frame)
+ (assert (sb-debug::frame-has-debug-tag-p frame))
+ (let* ((call-list (sb-debug::frame-call-as-list frame))
+ (fun (fdefinition (car call-list))))
+ (sb-debug::unwind-to-frame-and-call frame
+ (lambda ()
+ (apply fun (cdr call-list)))))))
+
+(defvar *foo*)
+(defvar *a*)
+(defvar *b*)
+(defvar *c*)
+
+\f
+;;;; Test RESTART-FRAME
+
+(define-condition restart-condition () ())
+
+(defvar *count* 0)
+
+(defun restart/special (*foo*)
+ (incf *count*)
+ (unless *a*
+ (setf *a* t)
+ (signal 'restart-condition))
+ *foo*)
+
+(defun restart/optional-special (&optional (*foo* 1))
+ (incf *count*)
+ (unless *a*
+ (setf *a* t)
+ (signal 'restart-condition))
+ *foo*)
+
+(defun restart/normal (foo)
+ (incf *count*)
+ (unless *a*
+ (setf *a* t)
+ (signal 'restart-condition))
+ foo)
+
+(defun test-restart (name)
+ (setf *a* nil)
+ (let ((*foo* 'x))
+ (let ((*foo* 'y)
+ (*count* 0))
+ (handler-bind ((restart-condition (lambda (c)
+ (declare (ignore c))
+ (restart-frame name))))
+ (assert (eql (funcall name 1) 1))
+ (assert (eql *count* 2))))
+ ;; Check that the binding stack was correctly unwound.
+ (assert (eql *foo* 'x))))
+
+(with-test (:name (:restart-frame :special))
+ (test-restart 'restart/special))
+
+(with-test (:name (:restart-frame :optional-special))
+ (test-restart 'restart/optional-special))
+
+(with-test (:name (:restart-frame :normal))
+ (test-restart 'restart/normal))
+
+\f
+;;;; Test RETURN-FROM-FRAME with normal functions
+
+(define-condition return-condition () ())
+
+(defun return/special (*foo*)
+ (unless *a*
+ (setf *a* t)
+ (signal 'return-condition))
+ *foo*)
+
+(defun return/optional-special (&optional (*foo* 1))
+ (unless *a*
+ (setf *a* t)
+ (signal 'return-condition))
+ *foo*)
+
+(defun return/normal (foo)
+ (unless *a*
+ (setf *a* t)
+ (signal 'return-condition))
+ foo)
+
+(defun do-signal ()
+ (signal 'return-condition))
+
+(defun return/catch (foo)
+ (catch 'y
+ (do-signal))
+ foo)
+
+(defun test-return (name)
+ (setf *a* nil)
+ (let ((*foo* 'x))
+ (let ((*foo* 'y))
+ (handler-bind ((return-condition (lambda (c)
+ (declare (ignore c))
+ (return-from-frame name 1 2 3 4))))
+ (assert (equal (multiple-value-list (funcall name 0))
+ (list 1 2 3 4)))))
+ ;; Check that the binding stack was correctly unwound.
+ (assert (eql *foo* 'x))))
+
+(with-test (:name (:return-from-frame :special))
+ (test-return 'return/special))
+
+(with-test (:name (:return-from-frame :optional-special))
+ (test-return 'return/optional-special))
+
+(with-test (:name (:return-from-frame :normal))
+ (test-return 'return/normal))
+
+(defun throw-y () (throw 'y 'y))
+
+;; Check that *CURRENT-CATCH-BLOCK* was correctly restored.
+(assert (eql (catch 'y
+ (test-return 'return/catch)
+ (throw-y))
+ 'y))
+
+\f
+;;;; Test RETURN-FROM-FRAME with local functions
+
+(define-condition in-a () ())
+(define-condition in-b () ())
+
+(defun locals ()
+ (flet ((a ()
+ (signal 'in-a)
+ (values 1 2))
+ (b ()
+ (signal 'in-b)
+ 1))
+ (setf *a* (multiple-value-list (a)))
+ (setf *b* (multiple-value-list (b)))))
+
+(defun hairy-locals ()
+ (let ((*c* :bad))
+ (flet ((a (&optional *c*)
+ (signal 'in-a)
+ (values 1 2))
+ (b (&key *c*)
+ (signal 'in-b)
+ 1))
+ ;; Ensure that A and B actually appear in the backtrace; the
+ ;; compiler for some reason likes to optimize away single-use
+ ;; local functions with hairy lambda-lists even on high debug
+ ;; levels.
+ (setf *a* (a :good))
+ (setf *b* (b :*c* :good))
+ ;; Do the real tests
+ (setf *a* (multiple-value-list (a :good)))
+ (setf *b* (multiple-value-list (b :*c* :good))))))
+
+(defun test-locals (name)
+ (handler-bind ((in-a (lambda (c)
+ (declare (ignore c))
+ (return-from-frame '(flet a) 'x 'y)))
+ (in-b (lambda (c)
+ (declare (ignore c))
+ (return-from-frame '(flet b) 'z))))
+ (funcall name))
+ ;; We're intentionally not testing for returning a different amount
+ ;; of values than the local functions are normally returning. It's
+ ;; hard to think of practical cases where that'd be useful, but
+ ;; allowing it (as in the old fully CATCH-based implementation of
+ ;; UNWIND-TO-FRAME-AND-CALL) will make it harder for the compiler to
+ ;; work well.
+ (let ((*foo* 'x))
+ (let ((*foo* 'y))
+ (assert (equal *a* '(x y)))
+ (assert (equal *b* '(z))))
+ (assert (eql *foo* 'x))))
+
+(with-test (:name (:return-from-frame :local-function))
+ (test-locals 'locals))
+
+(with-test (:name (:return-from-frame :hairy-local-function))
+ (test-locals 'hairy-locals))
+
+\f
+;;;; Test RETURN-FROM-FRAME with anonymous functions
+
+(define-condition anon-condition () ())
+
+(defparameter *anon-1*
+ (lambda (foo)
+ (signal 'anon-condition)
+ foo))
+
+(defparameter *anon-2*
+ (lambda (*foo*)
+ (signal 'anon-condition)
+ *foo*))
+
+(defun make-anon-3 ()
+ (let ((a (lambda (foo)
+ (signal 'anon-condition)
+ foo)))
+ (funcall a 1)
+ a))
+
+(defun make-anon-4 ()
+ (let ((a (lambda (*foo*)
+ (signal 'anon-condition)
+ *foo*)))
+ (funcall a 1)
+ a))
+
+(defparameter *anon-3* (make-anon-3))
+(defparameter *anon-4* (make-anon-4))
+
+(defun test-anon (fun var-name)
+ (handler-bind ((anon-condition (lambda (c)
+ (declare (ignore c))
+ (return-from-frame `(lambda (,var-name))
+ 'x 'y))))
+ (let ((*foo* 'x))
+ (let ((*foo* 'y))
+ (assert (equal (multiple-value-list (funcall fun 1))
+ '(x y)))
+ (assert (eql *foo* 'y)))
+ (assert (eql *foo* 'x)))))
+
+(with-test (:name (:return-from-frame :anonymous :toplevel))
+ (test-anon *anon-1* 'foo))
+
+(with-test (:name (:return-from-frame :anonymous :toplevel-special))
+ (test-anon *anon-2* '*foo*))
+
+(with-test (:name (:return-from-frame :anonymous))
+ (test-anon *anon-3* 'foo))
+
+(with-test (:name (:return-from-frame :anonymous :special))
+ (test-anon *anon-4* '*foo*))
+
+\f
+;;;; Test that unwind cleanups are executed
+
+(defvar *unwind-state* nil)
+(defvar *signal* nil)
+
+(defun unwind-1 ()
+ (unwind-protect
+ (when *signal*
+ (signal 'return-condition))
+ (push :unwind-1 *unwind-state*)))
+
+(defun unwind-2 ()
+ (unwind-protect
+ (unwind-1)
+ (push :unwind-2 *unwind-state*)))
+
+(defun test-unwind (fun wanted)
+ (handler-bind ((return-condition (lambda (c)
+ (declare (ignore c))
+ (return-from-frame fun
+ 'x 'y))))
+ (dolist (*signal* (list nil t))
+ (let ((*foo* 'x)
+ (*unwind-state* nil))
+ (let ((*foo* 'y))
+ (if *signal*
+ (assert (equal (multiple-value-list (funcall fun))
+ '(x y)))
+ (funcall fun))
+ (assert (equal *unwind-state* wanted))
+ (assert (eql *foo* 'y)))
+ (assert (eql *foo* 'x))))))
+
+(test-unwind 'unwind-1 '(:unwind-1))
+(test-unwind 'unwind-2 '(:unwind-2 :unwind-1))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.6.23"
+"1.0.6.24"
projects / sbcl.git / commitdiff