;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Eval/expdtry.scm             */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel SERRANO                                    */
;*    Creation    :  Tue Sep  1 16:21:59 1992                          */
;*    Last change :  Mon May 20 06:21:02 2002 (serrano)                */
;*    -------------------------------------------------------------    */
;*    Try form expansion                                               */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __expander_try
   
   (import  __error
	    __bigloo
	    __tvector
	    __structure
	    __tvector
	    __bexit
	    
	    __r4_numbers_6_5
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_characters_6_6
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r4_pairs_and_lists_6_3
	    __r4_input_6_10_2
	    __r4_control_features_6_9
	    __r4_vectors_6_8
	    __r4_ports_6_10_1
	    __r4_output_6_10_3
	    
	    __progn)
   
   (use     __type
	    __evenv)
   
   (export  (expand-try <expression> <expander>)))

;*---------------------------------------------------------------------*/
;*    expand-try ...                                                   */
;*    -------------------------------------------------------------    */
;*    This is a fixed version of expand-try. The fix has been          */
;*    proposed by:                                                     */
;*       Christopher Oliver  -- oliver@fritz.co.traverse.com           */
;*    Many thanks ...                                                  */
;*---------------------------------------------------------------------*/
(define (expand-try x e)
   (define (gensym-non-user pref)
      ;; the non user annotation is used for better bdb code production.
      ;; the non-user property is used by the compiler function
      ;; mark-symbol-non-user! (inside the ast_ident module).
      ;; @ref ../../comptime/Ast/ident.scm:mark-symbol-non-user!@
      (let ((sym (gensym pref)))
	 (putprop! sym 'non-user #t)
	 sym))
   (match-case x
      ((?- (and ?body (not ())) ?handler)
       (let ((nhandler (gensym-non-user 'handler))
	     (rhandler (gensym-non-user 'rhandler))
             (nbody    (gensym-non-user 'body))
	     (armed    (gensym-non-user 'armed)))
	  (e `(letrec ((,armed    #t)
		       (,nhandler ,handler)
		       (,rhandler (lambda (esc obj proc msg)
				     (set! ,armed #f)
				     (remove-error-handler!)
				     (,nhandler esc obj proc msg)))
		       (,nbody    (lambda () ,body)))
		 (bind-exit (escape)
		    (dynamic-wind
		       (lambda () (add-error-handler! ,rhandler escape))
		       ,nbody
		       (lambda () (if ,armed
				      (begin
					 (set! ,armed #f)
					 (remove-error-handler!)))))))
	     e)))
      (else
       (error "try" "Illegal form" x))))




