;;; -*- Mode:LISP; Package:LISP-INTERNALS; Readtable:CL; Base:10 -*-

;;;; THROW

;(in-package 'lisp-internals)


;;; Throw can take multiple values in the way that MVBIND-n does.  It
;;; checks the MV flag to see if it received multiple values, calling
;;; throw-sv or throw-mv.  THROW can often be optimized at compile time
;;; into THROW-SV or THROW-MV. Thrown values are passed like return
;;; values with the first value coming back in O5.  Any additional
;;; values are passed in the return registers and the MV flag will be
;;; set.
(defun throw-internal (tag value-1)
  (if (hw:return-code-mv-p)
      (throw-mv tag value-1)
    (throw-sv tag value-1)))

(defun get-CS-OA ()
  ;; Return the open and active frame numbers
  ;; from the top of the call stack.
  (let ((OA))
    (trap:without-traps
      ;; turn off traps because we don't want anything
      ;; bashing the stack while we have the pointer frotzed
      #'(lambda ()
	  (setq gr:*trap-temp1* (hw:read-open-active-return))
	  (setq gr:*trap-temp2* (hw:read-call-sp-hp))
	  (hw:ch-return)   ;pop things pushed by our call
	  (hw:nop) 	   ;prevent return-return
	  (hw:ch-return)   ;pop oar we are interested in
	  (hw:nop) 	   ;wait for delayed OAR
	  (setq gr:*trap-temp3* (hw:ldb (hw:read-open-active-return) (byte 24. 0.) 0))	   ;save OA
	  (hw:write-call-sp-hp gr:*trap-temp2*)	           ;put back stack and heap
	  (hw:write-open-active-return gr:*trap-temp1*)	   ;put back saved oar
	  (hw:nop) (hw:nop) (hw:nop) (hw:nop) (hw:nop)	   ;wait for those
	  (setq OA gr:*trap-temp3*)))
    OA))


;;; Throw a single value
;;;
;;; A catch frame contains:
;;; ----------------------
;;; O0: li:unwind-marker
;;; O1: <tag> li:unwind-protect-tag for unwind protect
;;; O2: *special-pdl*
;;; O3: *stack-pointer*
;;; O4: <pc> if throw <cleanup closure> if unwind protect
;;;
;;; Temporarily used:
;;; O5: <value> of catch or unwind body
;;;
;;; gr:*arg-1*    is throw tag
;;; gr:*arg-2*    is throw value
;;; 
(defun throw-sv (tag value)
;  (if (memq tag *sg-established-tags*)
    (progn
      (setq gr:*arg-1* tag)
      (setq gr:*arg-2* value)
      (do () (())
	;; or until we hopefully hit an
	;; unwind protect at top of stack
	;; ** scroll stack when hit bottom
	(if (trap:without-traps
	      #'(lambda ()
		  (= (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-active 0)
		     (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-open 0))))
	    ;; was a call, pop it
	    (hw:ch-return)
	  ;; was open or topen, check it
	  (progn
	    (when (eq (hw:O0) 'LI:UNWIND-MARKER)
	      (unbind-to (hw:O2))
	      (setq gr:*stack-pointer* (hw:O3))
	      (if (eq (hw:O1) gr:*arg-1*)
		  (progn
		    ;; clear the mv bit
		    ;; and return to the catch continuation
		    ;; with the value in O5
		    (setf (hw:O5) (single-value gr:*arg-2*))
		    (hw:dispatch (hw:O4)))
		(when (eq (hw:O1) 'LI:UNWIND-PROTECT-TAG)
		  (setf (hw:O0) NIL)	   ;don't lose if cleanup throws
		  (setf (hw:O1) gr:*arg-1*)	   ;save tag and value
		  (setf (hw:O5) gr:*arg-2*)
		  (funcall (hw:O4))	   ;execute cleanup forms
		  (setq gr:*arg-2* (hw:O5))	   ;and restore tag and value
		  (setq gr:*arg-1*   (hw:O1)))))
	    (hw:nop)
	    (if (trap:without-traps
		  #'(lambda ()
		      (= (hw:ldb (hw:read-open-active-return) hw:%%ch-oar-active 0)
			 (hw:ldb (get-CS-OA) hw:%%ch-oar-active 0))))
		(hw:call 'trap:flush-open-frame 0)
	      (hw:ch-tcall))
	    ))))
;   (tail-error "There was no pending CATCH for the tag ~s" tag)
      )

(defun single-value (v)
  v)

(defun throw-mv (tag value1)
;  (if (memq tag *sg-established-tags*)
    (progn
      (setq gr:*arg-1* tag)
      (setq gr:*arg-2* value1)
      (do-forever
	;; or until we hopefully hit an
	;; unwind protect at top of stack
	;; ** scroll stack when hit bottom
	(if (= (hw:ldb hw:%%ch-oar-active (hw:read-open-active-return) 0)
	       (hw:ldb hw:%%ch-oar-open (hw:read-open-active-return) 0))
	    ;; was a call, pop it
	    (hw:ch-return)
	  ;; was open or topen, check it
	  (when (eq (hw:O0) 'LI:UNWIND-MARKER)
	    (unbind-to (hw:O2))
	    (setq gr:*stack-pointer* (hw:O3))
	    (if (eq (hw:O1) gr:*arg-1*)
		(progn
		  ;; set the mv bit and return to catch continuation
		  ;; with value in O5
		  (setf (hw:O5) (multiple-values gr:*arg-2*))
		  (hw:dispatch (hw:O4)))
	      (progn
		(when (eq (hw:O1) 'LI:UNWIND-PROTECT-TAG)
		  (setf (hw:O0) nil)		;don't lose if cleanup throws
		  (setf (hw:O1) gr:*arg-1*)	;save tag and value
		  (setf (hw:O5) gr:*arg-2*)
		  ;; *** save rest of return values
		  (funcall (hw:O4))		;execute cleanup forms
		  ;; *** restore rest of return values
		  (setq gr:*arg-2* (hw:O5))	;and restore tag and value
		  (setq gr:*arg-1*   (hw:O1)))
		(if (= (hw:ldb hw:%%ch-oar-active (hw:read-open-active-return) 0)
		       (hw:ldb hw:%%ch-oar-active (get-CS-OA) 0))
		    (hw:ch-call)
		  (hw:ch-tcall))
		(hw:ch-return))))))
;   (error "There was no pending CATCH for the tag ~s" tag)
      ))

(defun multiple-values (v1)
  ;; Return v1 setting the mv bit
  (hw:return-mv v1))


;;; The various versions of catch-continue flush the catch frame,
;;; and may modify the mv bit.
;;; The catch frame is just an open frame and is flushed by the
;;; normal call and return mechanism as catch-continue is called.

(defun catch-continue (marker tag spdl sptr pc body-value)
  (hw:return-tail body-value))

(defun catch-continue-sv (marker tag spdl sptr pc body-value)
  body-value)

(defun catch-continue-mv (marker tag spdl sptr pc body-value)
  (hw:return-mv body-value))




;;; (unwind-protect
;;;     <form>
;;;   <cleanup>)
;;; 
;;; (unwind-protect-continue
;;;      'li:unwind-marker
;;;      'li:unwind-protect-tag
;;;      gr:*special-pdl-ptr*
;;;      gr:*stack-pointer*
;;;      #'(lambda ()
;;; 	     <cleanup>)
;;;      <form>)
;;;

;;;;; Note - These 4 functions are to force the compiler to evaluate the
;;;;;        unwind-protect arguments in order. Do not try to put these
;;;;;        inline in the macro or change them to macros!

(defun get-unwind-marker () 'li:unwind-marker)
(defun get-unwind-protect-tag () 'li:unwind-protect-tag)
(defun get-special-pdl-ptr () gr:*special-pdl-ptr*)
(defun get-stack-pointer () gr:*stack-pointer*)

(defmacro unwind-protect (protected-form &body cleanup-forms)
  `(unwind-protect-continue
     (get-unwind-marker)
     (get-unwind-protect-tag)
     (get-special-pdl-ptr)
     (get-stack-pointer)
     #'(lambda ()
	 ,@cleanup-forms)
     ,protected-form))


(defun unwind-protect-continue (marker tag spdl sptr cleanup-closure form-value)
  (funcall cleanup-closure)
  form-value)




;;; progv 
;;;
;;; I'm putting this here, because I don't have anywhere better to put
;;; it.  -- Jim Rauen 2/5/88


;; made PROGV correctly return the result of the last form 27sept88 pfc

(defmacro progv (variables values &body body)
  (let ((variable-list-temp (gensym 'VARIABLE-LIST-))
	(value-list-temp    (gensym 'VALUE-LIST-))
	(vars-temp          (gensym 'VARS-))
	(vals-temp          (gensym 'VALS-)))
    (gensym 'G)
    `(LET ((,variable-list-temp ,variables)
	   (,value-list-temp    ,values))
       (DO ((,vars-temp ,variable-list-temp (CDR ,vars-temp))
	    (,vals-temp ,value-list-temp    (CDR ,vals-temp)))
	   ((NULL ,vars-temp))
	 (IF ,vals-temp
	     (BIND (CAR ,vars-temp) (CAR ,vals-temp))
	   (BIND (CAR ,vars-temp) :UNBOUND)))	; how do I make this unbound?
       (prog1
	 (progn
	   ,@body)
	 (when ,variable-list-temp
	   (UNBIND (LENGTH ,variable-list-temp))))
       )))