;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Llib/bexit.scm               */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Tue Jan 31 15:00:41 1995                          */
;*    Last change :  Mon May 26 18:03:48 2003 (serrano)                */
;*    -------------------------------------------------------------    */
;*    The `bind-exit' manipulation.                                    */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __bexit

   ;; disable debugging traces when compiling this module otherwise
   ;; the Bigloo error handling is all wrong
   (option  (set! *compiler-debug* 0))
   
   (import  __error)
   
   (use     __type
	    __bigloo
	    __tvector
	    __structure
	    __r4_equivalence_6_2
	    __r4_vectors_6_8
	    __r4_booleans_6_1
	    __r4_pairs_and_lists_6_3
	    __r4_control_features_6_9
	    __r4_strings_6_7
	    __r4_symbols_6_4
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __evenv)

   (use     __r4_output_6_10_3
	    __r4_ports_6_10_1)
   
   (extern  (macro push-exit!::obj (::exit ::bool) "PUSH_EXIT")
	    (macro pop-exit!::obj () "POP_EXIT")
	    (macro exitd->exit::exit (::obj) "EXITD_TO_EXIT")
	    (macro exitd-user?::bool (::obj) "EXITD_USERP")
	    (macro exitd-stamp::bint (::obj) "EXITD_STAMP")
	    (macro %get-exitd-top::obj () "BGL_EXITD_TOP")
	    (macro %set-exitd-top!::obj (::obj) "BGL_EXITD_TOP_SET")
	    
	    (export unwind-stack-until! "unwind_stack_until")
	    (export unwind-stack-value? "unwind_stack_value_p"))

   (java    (class foreign
	       (method static push-exit!::obj (::exit ::bool)
		       "PUSH_EXIT")
	       (method static pop-exit!::obj ()
		       "POP_EXIT")
	       (method static exitd->exit::exit (::obj)
		       "EXITD_TO_EXIT")
	       (method static exitd-user?::bool (::obj)
		       "EXITD_USERP")
	       (method static exitd-stamp::bint (::obj)
		       "EXITD_STAMP")
	       (method static %get-exitd-top::obj ()
		       "BGL_EXITD_TOP")
	       (method static %set-exitd-top!::obj (::obj)
		       "BGL_EXITD_TOP_SET")))
   
   (export  (val-from-exit? ::obj)
	    (unwind-stack-value?::bool ::obj)
	    (unwind-until! exitd ::obj)
	    (unwind-stack-until! exitd ::obj ::obj ::obj)))

;*---------------------------------------------------------------------*/
;*    *protected-val* ...                                              */
;*---------------------------------------------------------------------*/
(define *protected-val* (cons #unspecified #unspecified))

;*---------------------------------------------------------------------*/
;*    val-from-exit? ...                                               */
;*---------------------------------------------------------------------*/
(define (val-from-exit? val)
   (eq? val *protected-val*))

;*---------------------------------------------------------------------*/
;*    unwind-stack-value? ...                                          */
;*    -------------------------------------------------------------    */
;*    I have introduced this function just because it helps the        */
;*    bootstrap. val-from-exit? is used inside the compiler with       */
;*    the prototype obj->obj and I wanted to use this function         */
;*    inside callcc.c with the prototype obj->bool.                    */
;*---------------------------------------------------------------------*/
(define (unwind-stack-value? val)
   (val-from-exit? val))

;*---------------------------------------------------------------------*/
;*    unwind-until! ...                                                */
;*    -------------------------------------------------------------    */
;*    This function is used by unwind-protect and bind-exit. It just   */
;*    unwind a stack is must not be used by call/cc. The former should */
;*    directly use unwind-stack-until!                                 */
;*---------------------------------------------------------------------*/
(define (unwind-until! exitd val)
   (if (pair? exitd)
       (unwind-stack-until! (car exitd) #f val (cdr exitd))
       (unwind-stack-until! exitd #f val #f)))

;*---------------------------------------------------------------------*/
;*    unwind-stack-until! ...                                          */
;*    -------------------------------------------------------------    */
;*    This function unwind a stack until an exit is found or the       */
;*    stack bottom is reached. In such a case, the proc arg is called. */
;*    This function is used by unwind-until! (introduced by any        */
;*    unwind-protect) and by call/cc.                                  */
;*---------------------------------------------------------------------*/
(define (unwind-stack-until! exitd estamp val proc)
   (let loop ()
      (if (eq? (%get-exitd-top) #f)
	  (if (procedure? proc)
	      (proc val)
	      (error "unwind-until!"
		     "exit out of dynamic scope"
		     #unspecified))
	  (let ((exit-top (%get-exitd-top)))
	     (pop-exit!)
	     (cond  
		((and (eq? exit-top exitd) 
		      (or (not (fixnum? estamp))
			  (=fx (exitd-stamp exit-top) estamp)))
		 (jump-exit (exitd->exit exit-top) val))
		((not (exitd-user? exit-top))
		 (set-car! *protected-val* (cons exitd proc))
		 (set-cdr! *protected-val* val)
		 (jump-exit (exitd->exit exit-top) *protected-val*))
		(else
		 (loop)))))))

(define (dbg-unwind-stack-until! exitd estamp val proc)
   (print "==========================================")
   (print "unwind-stack-until!: estamp: " estamp " val: " val " proc: " proc)
   (let loop ()
      (if (eq? (%get-exitd-top) #f)
	  (begin
	     (print "J'ai touche le fond: " val " proc: " proc)
	     (print "==========================================")
	  (if (procedure? proc)
	      (proc val)
	      (error "unwind-until!"
		     "exit out of dynamic scope"
		     #unspecified))
	  )
	  (let ((exit-top (%get-exitd-top)))
	     (pop-exit!)
	     (cond  
		((and (eq? exit-top exitd) 
		      (or (not (fixnum? estamp))
			  (=fx (exitd-stamp exit-top) estamp)))
		 (print "unwind-stack-until: je l'ai val: " val " stamp: " (exitd-stamp exit-top))
		 (print "==========================================")
		 (jump-exit (exitd->exit exit-top) val))
		((not (exitd-user? exit-top))
		 (print "J'ai un system: " val)
		 (set-car! *protected-val* (cons exitd proc))
		 (set-cdr! *protected-val* val)
		 (jump-exit (exitd->exit exit-top) *protected-val*))
		(else
		 (loop)))))))
