;;;
;;; DOM: The DO and DO* macros
;;;
;;; ----------------------------------------------------------------------
;;;
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1994-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;

(defmacro do (bindings final-form rest: body)
  ;; A parallel DO loop.
  (.expand-do bindings final-form body ()))

(defmacro do* (bindings final-form rest: body)
  ;; A sequential DO loop.
  (.expand-do bindings final-form body t))

(defun .expand-do (bindings final-form body sequentialp)
  ;; Returns a form to execute a DO or DO*.
  ;;  BINDINGS is a list of lists, each sublist containing the name of
  ;;   a bound variable as its car, an initial value as its cadr, and a
  ;;   form to reset the value on each iteration as the caddr (optional).
  ;;  FINAL-FORM is a list of (test-form result-form).  The TEST-FORM
  ;;   is a form which is executed on each loop to test whether to
  ;;   stop; the RESULT-FORM is executed to determine a return value
  ;;   for the loop.
  ;;  BODY is a list of expressions executed on each iteration.
  ;;  SEQUENTIALP, if non-(), indicates that the bound variables are
  ;;   to be set in cascading environments; else, they are bound in
  ;;   parallel.
  (let ((binder (if sequentialp 'let* 'let))
	(test-form (car final-form))
	(block (gensym "_doblk_" 'internal))
	(result-form (cdr final-form)))
    `(block ,block
       (,binder ,(collecting
		   (for ((binding in: bindings))
		     ;; Initiappl values.
		     (collect (list (car binding) (cadr binding)))))
		(for ()
		  (when ,test-form
		    (return-from ,block (progn ,@result-form)))
		  ;; The body
		  ,@(.generate-tagbody body)
		  ;; Reset the bound variables.
		  ,@(let ((new-binds
			   (collecting
			     (for ((binding in: bindings))
			       (when (consp (cddr binding))
				 (collect (car binding))
				 (collect (caddr binding)))))))
		      (when new-binds
			(if sequentialp
			    (collecting
			      (for ((binding in: new-binds))
				(collect
				 `(setf ,(car binding) ,(cadr binding)))))
			  `((psetf ,@new-binds))))))))))

(defun .generate-tagbody (body)
  ;; If BODY contains a label, put TAGBODY around it; else, just
  ;; return it.
  (labels ((.gettb-aux (forms)
	     (cond ((null forms) ())
		   ((symbolp (car forms)) t)
		   (t (.gettb-aux (cdr forms))))))
    (when body
      (if (.gettb-aux body)
	  ;; extra paren level cuz we're always going to splice it in.
	  `((tagbody ,@body))
	body))))
