;;;
;;; frame-return-test.lisp
;;;
;;; Test for SBCL debugger frame-return machinery
;;;

(in-package :cl-user)

(defun foo1 (fun)
  (funcall fun)
  (format t "foo1~%"))

(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.

  ;; FIXME: Make this work on non-x86 systems.

  (let* ((frame-pointer (sb-di::frame-pointer frame))
	 (current-uwp (sb-sys:int-sap
			(ash (logand (logior (1+ most-positive-fixnum)
					     most-positive-fixnum)
				     sb-vm::*current-unwind-protect-block*)
			     2)))
	 (enclosing-uwp (loop for uwp-block = current-uwp
			          then (sb-sys:sap-ref-sap
					uwp-block sb-vm:unwind-block-current-uwp-slot)
			      when (or (zerop (sb-sys:sap-int uwp-block))
				       (sb-sys:sap> uwp-block frame-pointer))
			      return uwp-block)))
    (format t "find-enclosing-uwp: fp ~X current-uwp ~X enclosing-uwp ~X~%"
	    (sb-sys:sap-int frame-pointer)
	    (sb-sys:sap-int current-uwp)
	    (sb-sys:sap-int enclosing-uwp))
    enclosing-uwp))

;; FIXME: May want to turn this into an ir1-translator.
(defmacro frame-return (frame values)
  `(multiple-value-call #'sb-c::%frame-return (sb-di::frame-pointer ,frame)
    (find-enclosing-uwp ,frame) ,values))

(defun bar ()
  (format t "bar~%")
  (loop for frame = (sb-di:top-frame) #+nil (sb-kernel:%caller-frame-and-pc)
	    then (sb-di:frame-down frame)
	while frame
	when (eq (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)) #'foo1)
	do (progn
	     (format t "bar frame ~A fun ~A~%" frame
		     (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame)))
	     (frame-return frame (values 1 'two "three"))))
  (format t "bar returning normally~%"))

(defun foo2 ()
  (unwind-protect
       (bar)
    (format t "foo2 UWP~%"))
  (format t "foo2 post-UWP~%"))

(defun test-return ()
  (unwind-protect
       (prog1
	 (foo1 #'foo2)
	 (format t "test-return: foo1 returned~%"))
    (format t "test-return UWP~%")))

;;; EOF