;*=====================================================================*/
;*    serrano/prgm/project/bigloo/comptime/Expand/map.scm              */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Fri Dec  4 18:08:53 1992                          */
;*    Last change :  Fri May 16 09:45:40 2003 (serrano)                */
;*    Copyright   :  1992-2003 Manuel Serrano, see LICENSE file        */
;*    -------------------------------------------------------------    */
;*    `map' and `for-each' compile-time macro expansion.               */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module expand_map
   (import tools_misc
	   engine_param
	   type_type
	   ast_ident)
   (export (expand-map      ::obj ::procedure)
	   (expand-for-each ::obj ::procedure)
	   (expand-any?     ::obj ::procedure)
	   (expand-every?   ::obj ::procedure)))

;*---------------------------------------------------------------------*/
;*    expand-map ...                                                   */
;*---------------------------------------------------------------------*/
(define (expand-map x e)
   (match-case x
      ((?- ?fun ?list)
       (let* ((l     (mark-symbol-non-user! (gensym 'l)))
	      (lname (mark-symbol-non-user! (gensym 'map)))
	      (head  (mark-symbol-non-user! (gensym 'head)))
	      (tail  (mark-symbol-non-user! (gensym 'tail)))
	      (ntail (mark-symbol-non-user! (gensym 'newtail)))
	      (loop  (if *unsafe-type*
			 `(let ((,l ,list))
			     (if ((@ null? __r4_pairs_and_lists_6_3) ,l)
				 '()
				 ,(match-case fun
				     ((not (?- . ?-))
				      ;; la fonction n'est pas un appel
				      ;; fonctionnel,on peut donc generer
				      ;; du code qui ne cons
				      ;; pas trop!
				      `(let ((,head ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
										       '())))
					  (let ,lname ((,l   ((@ cdr __r4_pairs_and_lists_6_3) ,l))
						       (,tail ,head))
					       (if ((@ null? __r4_pairs_and_lists_6_3) ,l)
						   ,head
						   (let ((,ntail 
							  ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
											     '())))
						      ((@ set-cdr! __r4_pairs_and_lists_6_3) ,tail
											     ,ntail)
						      (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)
							      ,ntail))))))
				     (else
				      `(let ((,head ((@ cons __r4_pairs_and_lists_6_3) '() '())))
					  (let ,lname ((,l    ,l)
						       (,tail ,head))
					       (if ((@ null? __r4_pairs_and_lists_6_3) ,l)
						   ((@ cdr __r4_pairs_and_lists_6_3) ,head)
						   (let ((,ntail 
							  ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
											     '())))
						      ((@ set-cdr! __r4_pairs_and_lists_6_3) ,tail ,ntail)
						      (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)
							      ,ntail)))))))))
			 `(let ((,l ,list))
			     (if ((@ null? __r4_pairs_and_lists_6_3) ,l)
				 '()
				 ,(match-case fun
				     ((not (?- . ?-))
				      ;; meme remarque que ci-dessus.
				      `(let ((,head ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,l)) '())))
					  (let ,lname ((,l    ((@ cdr __r4_pairs_and_lists_6_3) ,l))
						       (,tail ,head))
					       (cond
						  (((@ pair? __r4_pairs_and_lists_6_3) ,l)
						   (let ((,ntail 
							  ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
											     '())))
						      ((@ set-cdr! __r4_pairs_and_lists_6_3) ,tail ,ntail)
						      (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)
							      ,ntail)))
						  (((@ null? __r4_pairs_and_lists_6_3) ,l)
						   ,head)
						  (else
						   ((@ error __error)
						    "map"
						    "argument not a list"
						    ,l))))))
				     (else
				      `(let ((,head ((@ cons __r4_pairs_and_lists_6_3) '() '())))
					  (let ,lname ((,l    ,l)
						       (,tail ,head))
					       (cond
						  (((@ pair? __r4_pairs_and_lists_6_3) ,l)
						   (let ((,ntail 
							  ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
											     '())))
						      ((@ set-cdr! __r4_pairs_and_lists_6_3) ,tail ,ntail)
						      (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)
							      ,ntail)))
						  (((@ null? __r4_pairs_and_lists_6_3) ,l)
						   ((@ cdr __r4_pairs_and_lists_6_3) ,head))
						  (else
						   ((@ error __error)
						    "map"
						    "argument not a list"
						    ,l))))))))))))
	  (let ((res (e loop e)))
	     (replace! x res))))
      ((?- ?fun ?l1 ?l2)
       (let ((ll1   (mark-symbol-non-user! (gensym 'll)))
	     (ll2   (mark-symbol-non-user! (gensym 'll)))
	     (head  (mark-symbol-non-user! (gensym 'head)))
	     (tail  (mark-symbol-non-user! (gensym 'tail)))
	     (ntail (mark-symbol-non-user! (gensym 'newtail)))
	     (lname (mark-symbol-non-user! (gensym 'map))))
	  (let ((res
		 (e `(let ((,ll1 ,l1)
			   (,ll2 ,l2))
			(if ((@ null? __r4_pairs_and_lists_6_3) ,ll1)
			    '()
			    ,(match-case fun
				((not (?- . ?-))
				 ;; la fonction n'est pas un appel
				 ;; fonctionnel,
				 ;; on peut donc generer du code
				 ;; qui ne cons pas trop!
				 `(let ((,head ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,ll1)
											((@ car __r4_pairs_and_lists_6_3) ,ll2))
										  '())))
				     (let ,lname ((,ll1   ((@ cdr __r4_pairs_and_lists_6_3) ,ll1))
						  (,ll2   ((@ cdr __r4_pairs_and_lists_6_3) ,ll2))
						  (,tail ,head))
					  (if ((@ null? __r4_pairs_and_lists_6_3) ,ll1)
					      ,head
					      (let ((,ntail 
						     ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,ll1)
											      ((@ car __r4_pairs_and_lists_6_3) ,ll2))
											'())))
						 ((@ set-cdr! __r4_pairs_and_lists_6_3) ,tail ,ntail)
						 (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,ll1)
							 ((@ cdr __r4_pairs_and_lists_6_3) ,ll2)
							 ,ntail))))))
				(else
				 `(let ((,head ((@ cons __r4_pairs_and_lists_6_3) '() '())))
				     (let ,lname ((,ll1   ,ll1)
						  (,ll2   ,ll2)
						  (,tail ,head))
					  (if ((@ null? __r4_pairs_and_lists_6_3) ,ll1)
					      ((@ cdr __r4_pairs_and_lists_6_3) ,head)
					      (let ((,ntail 
						     ((@ cons __r4_pairs_and_lists_6_3) (,fun ((@ car __r4_pairs_and_lists_6_3) ,ll1)
											      ((@ car __r4_pairs_and_lists_6_3) ,ll2))
											'())))
						 ((@ set-cdr! __r4_pairs_and_lists_6_3) ,tail ,ntail)
						 (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,ll1)
							 ((@ cdr __r4_pairs_and_lists_6_3) ,ll2)
							 ,ntail)))))))))
		    e)))
	     (replace! x res))))
      ((?- ?fun . ?lists)
       (let ((res `(map ,(e fun e) ,@(map (lambda (l) (e l e)) lists))))
	  (replace! x res)))
      (else
       (error #f "Illegal `map' form" x))))

;*---------------------------------------------------------------------*/
;*    expand-for-each ...                                              */
;*---------------------------------------------------------------------*/
(define (expand-for-each x e)
   (match-case x
      ((?- ?fun ?list)
       (let* ((l     (mark-symbol-non-user! (gensym 'l)))
	      (lname (mark-symbol-non-user! (gensym 'for-each)))
	      (loop  (if *unsafe-type*
			 `(let ,lname ((,l ,list))
			       (cond
				  (((@ pair? __r4_pairs_and_lists_6_3) ,l)
				   (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
				   (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)))
				  (else
				   #t)))
			 `(let ,lname ((,l ,list))
			       (cond
				  (((@ pair? __r4_pairs_and_lists_6_3) ,l)
				   (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
				   (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)))
				  (((@ null? __r4_pairs_and_lists_6_3) ,l)
				   #t)
				  (else
				   ((@ error __error) "for-each"
						      "argument not a list"
						      ,l)))))))
	  (let ((res (e loop e)))
	     (replace! x res))))
      ((?- ?fun ?l1 ?l2)
       (let* ((ll1   (mark-symbol-non-user! (gensym 'll)))
	      (ll2   (mark-symbol-non-user! (gensym 'll)))
	      (lname (mark-symbol-non-user! (gensym 'for-each)))
	      (loop  `(let ,lname ((,ll1 ,l1)
				   (,ll2 ,l2))
			   (if ((@ null? __r4_pairs_and_lists_6_3) ,ll1)
			       #t
			       (begin
				  (,fun ((@ car __r4_pairs_and_lists_6_3) ,ll1) (car ,ll2))
				  (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,ll1) ((@ cdr __r4_pairs_and_lists_6_3) ,ll2)))))))
	  (let ((res (e loop e)))
	     (replace! x res))))
      ((?- ?fun . ?lists)
       (let ((res `(for-each ,(e fun e) ,@(map (lambda (l) (e l e)) lists))))
	  (replace! x res)))
      (else
       (error #f "Illegal `for-each' form" x))))

;*---------------------------------------------------------------------*/
;*    expand-any? ...                                                  */
;*---------------------------------------------------------------------*/
(define (expand-any? x e)
   (match-case x
      ((?- ?fun ?list)
       (let* ((l     (mark-symbol-non-user! (gensym 'l)))
	      (lname (mark-symbol-non-user! (gensym 'any)))
	      (loop  (if *unsafe-type*
			 `(let ,lname ((,l ,list))
			       (cond
				  (((@ null? __r4_pairs_and_lists_6_3) ,l)
				   #f)
				  ((,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
				   #t)
				  (else
				   (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)))))
			 `(let ,lname ((,l ,list))
			       (cond
				  (((@ null? __r4_pairs_and_lists_6_3) ,l)
				   #f)
				  (((@ pair? __r4_pairs_and_lists_6_3) ,l)
				   (if (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
				       #t
				       (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l))))
				  (else
				   ((@ error __error) "any?"
						      "argument not a list"
						      ,l)))))))
	  (let ((res (e loop e)))
	     (replace! x res))))
      ((?- ?fun . ?lists)
       (let ((res `(any? ,(e fun e) ,@(map (lambda (l) (e l e)) lists))))
	  (replace! x res)))
      (else
       (error #f "Illegal `any?' form" x))))
       
;*---------------------------------------------------------------------*/
;*    expand-every? ...                                                */
;*---------------------------------------------------------------------*/
(define (expand-every? x e)
   (match-case x
      ((?- ?fun ?list)
       (let* ((l     (mark-symbol-non-user! (gensym 'l)))
	      (lname (mark-symbol-non-user! (gensym 'every)))
	      (loop  (if *unsafe-type*
			 `(let ,lname ((,l ,list))
			       (cond
				  (((@ null? __r4_pairs_and_lists_6_3) ,l)
				   #t)
				  ((,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
				   (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l)))
				  (else
				   #f)))
			 `(let ,lname ((,l ,list))
			       (cond
				  (((@ null? __r4_pairs_and_lists_6_3) ,l)
				   #t)
				  (((@ pair? __r4_pairs_and_lists_6_3) ,l)
				   (if (,fun ((@ car __r4_pairs_and_lists_6_3) ,l))
				       (,lname ((@ cdr __r4_pairs_and_lists_6_3) ,l))
				       #f))
				  (else
				   ((@ error __error) "every?"
						      "argument not a list"
						      ,l)))))))
	  (let ((res (e loop e)))
	     (replace! x res))))
      ((?- ?fun . ?lists)
       (let ((res `(every? ,(e fun e) ,@(map (lambda (l) (e l e)) lists))))
	  (replace! x res)))
      (else
       (error #f "Illegal `every?' form" x))))
       
