;*---------------------------------------------------------------------*/
;*    serrano/prgm/project/bigloo/runtime/Eval/expdlet.scm             */
;*                                                                     */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Mon Jan  4 17:10:13 1993                          */
;*    Last change :  Sat Jun 15 16:51:24 2002 (serrano)                */
;*                                                                     */
;*    Les expanseurs des formes `let's                                 */
;*---------------------------------------------------------------------*/

;*---------------------------------------------------------------------*/
;*    Le module                                                        */
;*---------------------------------------------------------------------*/
(module __expander_let
   
   (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-eval-let    <expression> <expander>)
	    (expand-eval-let*   <expression> <expander>)
	    (expand-eval-letrec <expression> <expander>)
	    (expand-eval-labels <expression> <expander>)))

;*---------------------------------------------------------------------*/
;*    expand-eval-let ...                                              */
;*---------------------------------------------------------------------*/
(define (expand-eval-let x e)
   (let ((res (match-case x
		 ((?- () . (and ?body (not ())))
		  (e `((lambda () ,(normalize-progn body))) e))
		 ((?- (and (? symbol?) ?loop) ?bindings . (and ?body (not ())))
		  (if (not (or (null? bindings) (pair? bindings)))
		      (error "let" "Illegal `let' form" x)
		      (e `(letrec ((,loop (lambda
						,(map
						  (lambda (b)
						     (if (pair? b)
							 (car b)
							 (error
							  "expand-let"
							  "Illegal `let' form"
							  x)))
						  bindings)
					     ,(normalize-progn body))))
			     (,loop ,@(map (lambda (b)
					      (if (and (pair? b)
						       (pair? (cdr b))
						       (null? (cddr b)))
						  (cadr b)
						  (error
						   "expand-let"
						   "Illegal `let' form"
						   x)))
					   bindings)))
			 e)))
		 ((?- (and (? pair?) ?bindings) . (and ?body (not ())))
		  (let ((body      (normalize-progn body))
			(vars.vals (let loop ((bindings bindings)
					      (vars     '())
					      (vals     '()))
				      (cond
					 ((null? bindings)
					  (cons vars vals))
					 ((not (pair? (car bindings)))
					  (loop (cdr bindings)
						(cons (car bindings) vars)
						(cons '(unspecified) vals)))
					 ((not (pair? (cdr (car bindings))))
					  (error "expand-let"
						 "Illegal `let' form"
						 x))
					 (else
					  (loop (cdr bindings)
						(cons (car (car bindings))
						      vars)
						(cons (normalize-progn
						       (cdr (car bindings)))
						      vals)))))))
		     (e `((lambda ,(car vars.vals) ,body)
			  ,@(cdr vars.vals)) e)))
		 (else
		  (error "expand-let" "Illegal `let' form" x)))))
      (replace! x res)))
	   
;*---------------------------------------------------------------------*/
;*    expand-eval-let* ...                                             */
;*---------------------------------------------------------------------*/
(define (expand-eval-let* x e)
   (let ((res (match-case x
		 ((?- () . (and ?body (not ())))
		  (e `((lambda () ,(normalize-progn body))) e))
		 ((?- (and (? pair?) ?bindings) . (and ?body (not ())))
		  (e `(let (,(car bindings))
			 (let* ,(cdr bindings)
			    ,(normalize-progn body))) e))
		 (else
		  (error "expand-let*" "Illegal form" x)))))
      (replace! x res)))
   
;*---------------------------------------------------------------------*/
;*    expand-eval-letrec ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-eval-letrec x e)
   (let ((res (match-case x
		 ((?- () . (and ?body (not ())))
		  (e `((lambda () ,(normalize-progn body))) e))
		 ((?- (and (? pair?) ?bindings) . (and ?body (not ())))
		  (let ((body      (normalize-progn body))
			(vars.vals (let loop ((bindings bindings)
					      (vars     '())
					      (vals     '()))
				      (cond
					 ((null? bindings)
					  (cons vars vals))
					 ((not (pair? (car bindings)))
					  (error "letrec" "Illegal form" x))
					 (else
					  (loop (cdr bindings)
						(cons (car (car bindings))
						      vars)
						(cons (normalize-progn
						       (cdr (car bindings)))
						      vals)))))))
		     (e `((lambda ,(car vars.vals)
			     ,(normalize-progn
			       (let loop ((vars (car vars.vals))
					  (vals (cdr vars.vals))
					  (res  (list body)))
				  (if (null? vars)
				      res
				      (loop (cdr vars)
					    (cdr vals)
					    (cons `(set! ,(car vars)
							 ,(car vals))
						  res))))))
			  ,@(map (lambda (v) '(unspecified)) bindings)) e)))
		 (else
		  (error "letrec" "Illegal form" x)))))
      (replace! x res)))

;*---------------------------------------------------------------------*/
;*    expand-eval-labels ...                                           */
;*---------------------------------------------------------------------*/
(define (expand-eval-labels x e)
   (let ((res (match-case x
		 ((?- () . (and ?body (not ())))
		  (e `((lambda () ,(normalize-progn body))) e))
		 ((?- ?bindings . (and ?body (not ())))
		  (let ((new (let loop ((bindings bindings))
				(cond
				   ((null? bindings)
				    '())
				   ((not (pair? bindings))
				    (error "expand-labels" "Illegal form" x))
				   (else
				    (match-case (car bindings)
				       ((?name ?args . ?lbody)
					(cons `(,name (lambda ,args ,@lbody))
					      (loop (cdr bindings))))
				       (else
					(error "expand-labels"
					       "Illegal form"
					       x))))))))
		     (e `(letrec ,new ,@body) e)))
		 (else
		  (error "expand-labels" "Illegal form" x)))))
      (replace! x res)))
