;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Eval/expanders.scm           */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Thu Nov  3 09:58:05 1994                          */
;*    Last change :  Wed Apr  2 15:36:31 2003 (serrano)                */
;*    Copyright   :  2002-03 Manuel Serrano                            */
;*    -------------------------------------------------------------    */
;*    Expanders installation.                                          */
;*=====================================================================*/
 
;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __install_expanders

   (import  __error
	    __macro
	    __expander_quote
	    __expander_let
	    __expander_bool
	    __expander_case
	    __expander_define
	    __expander_do
	    __expander_try
	    __expander_struct
	    __expander_record
	    __expander_srfi-0
	    __expander_args
	    __eval
	    __progn
	    __lalr_expand
	    __rgc_expand
	    __match_expand
	    
	    __r5_macro_4_3_syntax
	    __r5_macro_4_3_hygiene)
   
   (use     __type
	    __bigloo
	    __tvector
	    __structure
	    __tvector
	    __bexit
	    __os
	    
	    __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
	    __r5_control_features_6_4
	    
	    __evenv)
	    
   (export  (install-all-expanders!)))

;*---------------------------------------------------------------------*/
;*    expand-test ...                                                  */
;*---------------------------------------------------------------------*/
(define (expand-test x e)
   (if *nil*
       (e x e)
       `((lambda (test-aux-for-nil)
	    (if test-aux-for-nil
		(if (null? test-aux-for-nil)
		    #f
		    #t)
		#f))
	 ,(e x e)))) 

;*---------------------------------------------------------------------*/
;*    install-all-expanders! ...                                       */
;*    -------------------------------------------------------------    */
;*    !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!! WARNING !!!  */
;*    -------------------------------------------------------------    */
;*    It is mandatory to define the closure associated to expanders    */
;*    in *this* module in order to avoid module initialization         */
;*    order problems.                                                  */
;*---------------------------------------------------------------------*/
(define (install-all-expanders!)

;*---------------------------------------------------------------------*/
;*    Expanders shared by the compiler and the interpreter             */
;*---------------------------------------------------------------------*/
   ;; quote
   (install-expander 'quote (lambda (x e) (expand-quote x e)))
   
   ;; quasiquote
   (install-expander 'quasiquote (lambda (x e) (e (quasiquotation 1 x) e)))
   
   ;; define-macro  
   (install-expander 'define-macro (lambda (x e)
				      (expand-define-macro x e)))
   
   ;; define-hygiene-macro  
   (install-expander 'define-hygiene-macro (lambda (x e)
					     (expand-define-hygiene-macro x e)))
   
   ;; define-expander
   (install-expander 'define-expander (lambda (x e)
					 (expand-define-expander x e)))
   
   ;; or
   (install-expander 'or (lambda (x e) (e (expand-or x) e)))
   
   ;; and
   (install-expander 'and (lambda (x e) (e (expand-and x) e)))
   
   ;; cond
   (install-expander 'cond (lambda (x e) (e (expand-cond x) e)))
   
   ;; do
   (install-expander 'do (lambda (x e) (expand-do x e)))
   
   ;; try
   (install-expander 'try (lambda (x e) (expand-try x e)))
   
   ;; match-case
   (install-expander 'match-case (lambda (x e) (e (expand-match-case x) e)))
   
   ;; match-lambda
   (install-expander 'match-lambda (lambda (x e)
				      (e (expand-match-lambda x) e)))
   
   ;; define-pattern
   (install-expander 'define-pattern (lambda (x e)
					(e (expand-define-pattern x) e)))
   
   ;; delay
   (install-expander 'delay (lambda (x e)
			       (match-case x
				  ((?- ?exp)
				   `(make-promise (lambda () ,(e exp e))))
				  (else
				   (error "delay"
					  "Illegal form"
					  x)))))
   ;; regular-grammar
   (install-expander 'regular-grammar expand-regular-grammar)
   
   ;; string-case
   (install-expander 'string-case expand-string-case)
   
   ;; lalr-grammar
   (install-expander 'lalr-grammar expand-lalr-grammar)
   
   ;; begin
   (install-expander 'begin (lambda (x e)
			       (match-case x
				  ((?- . ?body)
				   (let loop ((l body))
				      (cond
					 ((null? l)
					  (let ((new `(begin
							 ,@(map
							    (lambda (x)
							       (e x e))
							    body))))
					     (set-car! x (car new))
					     (set-cdr! x (cdr new))
					     x))
					 ((pair? l)
					  (loop (cdr l)))
					 (else
					  (error "begin" "Illegal form" x)))))
				  (else
				   (error "begin"
					  "Illegal form"
					  x)))))
   
   ;; failure
   (install-expander 'failure (lambda (x e)
				 (match-case x
				    ((?- ?proc ?msg ?obj)
				     `(failure ,(e proc e)
					       ,(e msg e)
					       ,(e obj e)))
				    (else
				     (error "failure"
					    "Illegal `failure' form"
					    x)))))
   
   
   ;; multiple-value-bind
   (install-expander 'multiple-value-bind
		     (lambda (x e)
			(match-case x
			   ((?- ?vars ?call . ?exprs)
			    (e `(call-with-values (lambda () ,call)
						  (lambda ,vars ,@exprs))
			       e))
			   (else
			    (error "multiple-value-bind"
				   "Illegal form"
				   x)))))
   ;; receive
   (install-expander 'receive
		     (lambda (x e)
			(match-case x
			   ((?- ?vars ?call . ?exprs)
			    (e `(call-with-values (lambda () ,call)
						  (lambda ,vars ,@exprs))
			       e))
			   (else
			    (error "receive"
				   "Illegal form"
				   x)))))

   ;; when
   (install-expander 'when
		     (lambda (x e)
			(match-case x
			   ((?- ?si . ?body)
			    (e `(if ,si
				    (begin ,@body)
				    #unspecified)
			       e))
			   (else
			    (error "when" "Illegal form" x)))))

   ;; unless
   (install-expander 'unless
		     (lambda (x e)
			(match-case x
			   ((?- ?si . ?body)
			    (e `(if ,si
				    #unspecified
				    (begin ,@body))
			       e))
			   (else
			    (error "unless" "Illegal form" x)))))
   ;; define-record-type
   (install-expander 'define-record-type expand-define-record-type)

   ;; args-parse
   (install-expander 'args-parse expand-args-parse)
   
   ;; tprint
   (install-expander 'tprint (lambda (x e)
				(set-car! x 'print)
				(e (if (epair? x)
				       (match-case (cer x)
					  ((at ?name ?- ?line)
					   (set-cdr! x
						     (cons* name
							    ","
							    line
							    ":"
							    (cdr x)))
					   x)
					  (else
					   (set-car! x 'print)
					   x))
				       (begin
					  (set-car! x 'print)
					  x))
				   e)))

   ;; and-let*
   (install-expander 'and-let*
		     (lambda (x e)
			(define (and-let-error)
			   (error #f "Illegal `and-let*' form" x))
			(match-case
			      x
			   ((?- (and (? pair-or-null?) ?bindings) .
				(and ?body (not ())))
			    (if (null? bindings)
				`(begin ,(e (normalize-progn body) e))
				(let ((first-binding (car bindings)))
				   (unless (pair? first-binding)
				      (and-let-error))
				   (let ((sl `(and-let* ,(cdr bindings)
							,@body)))
				      (match-case first-binding
					 (((and (? symbol?)?varname) ?expr)
					  (e `(let (,first-binding)
						 (and ,varname ,sl))
					     e))
					 ((?expr)
					  (e `(and ,expr ,sl) e))
					 (else
					  (and-let-error)))))))
			   (else (and-let-error)))))

   ;; define-syntax
   (install-expander 'define-syntax (lambda (x e) (expand-define-syntax x e)))
   (install-expander 'letrec-syntax (lambda (x e) (expand-letrec-syntax x e)))
   (install-expander 'let-syntax (lambda (x e) (expand-let-syntax x e)))

;*---------------------------------------------------------------------*/
;*    Interpreter macros                                               */
;*---------------------------------------------------------------------*/
   ;; bind-exit
   (install-eval-expander 'bind-exit (lambda (x e)
					(match-case x
					   ((?- (?exit) . (and ?body (not ())))
					    `(bind-exit (,exit)
						,(e (normalize-progn body)
						    e)))
					   (else
		    			    (error "bind-exit"
						   "Illegal form"
						   x)))))
   
   ;; unwind-protect
   (install-eval-expander 'unwind-protect (lambda (x e)
					     (match-case x
						((?- ?body . ?exp)
						 `(unwind-protect
						     ,(e body e)
						     ,@(map (lambda (x)
							       (e x e))
							    exp)))
						(else
						 (error "unwind-protect"
							"Illegal form"
							x)))))
   
   ;; module
   (install-eval-expander 'module (lambda (x e) x))
   
   ;; if
   (install-eval-expander 'if (lambda (x e)
				 (match-case x
				    ((if ?si ?alors ?sinon)
				     `(if ,(expand-test si e)
					  ,(e alors e)
					  ,(e sinon e)))
				    ((if ?si ?alors)
				     `(if ,(expand-test si e)
					  ,(e alors e)
					  #f))
				    (else
				     (error "if" "Illegal form" x)))))
   
   ;; lambda
   (install-eval-expander 'lambda (lambda (x e) (expand-eval-lambda x e)))
   
   ;; let
   (install-eval-expander 'let (lambda (x e) (expand-eval-let x e)))
   
   ;; let*
   (install-eval-expander 'let* (lambda (x e) (expand-eval-let* x e)))
   
   ;; letrec
   (install-eval-expander 'letrec (lambda (x e) (expand-eval-letrec x e)))
   
   ;; labels
   (install-eval-expander 'labels (lambda (x e) (expand-eval-labels x e)))
   
   ;; define
   (install-eval-expander 'define (lambda (x e) (expand-eval-define x e)))
   
   ;; define-inline
   (install-eval-expander 'define-inline (lambda (x e)
					    (expand-eval-define-inline x e)))
   
   ;; define-struct
   (install-eval-expander 'define-struct (lambda (x e)
					    (expand-eval-define-struct x e)))
   
   ;; case
   (install-eval-expander 'case (lambda (x e) (expand-eval-case x e)))
   
   ;; cond-expand
   (install-eval-expander 'cond-expand (lambda (x e)
					  (expand-cond-expand x e)))
   
   ;; profile
   (install-eval-expander 'profile
			  (lambda (x e)
			     (match-case x
				((?- (and (? symbol?) ?lbl) . ?exprs)
				 (let* ((la  `(lambda () ,@exprs))
					(lam (if (epair? x)
						 (econs (car la)
							(cdr la)
							(cer x))
						 la))
					(val (let ((sym (gensym 'value)))
						sym))
					(aux `(let ((,lbl ,lam))
						 (GC-profile-push
						  ,(symbol->string lbl)
						  ,lbl)
						 (let ((,val (,lbl)))
						    (GC-profile-pop)
						    ,val)))
					(res (if (epair? x)
						 (econs (car aux)
							(cdr aux)
							(cer x))
						 aux)))
				    (e aux e)))
				(else
				 (error "profile" "Illegal form" x))))))
   
   
