;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-

;; These are definitions of standard lisp macros for the falcon interpreter environment.
;; These were quick to implement and allow various cruft to ru on the K.
;; Eventually we should implement `special-form' versions because they run with
;; much less consing.  - smh 24aug88

;;; DO and DO*
(defun separate-do-bindings (binding-list receiver)
  (labels ((scan-bindings (tail binding-names initial-values iteration-clauses)
	     (if (null tail)
		 (funcall receiver
			  (reverse binding-names)
			  (reverse initial-values)
			  (reverse iteration-clauses))
	       (let ((this-clause (first tail)))
		 (if (symbolp this-clause)
		     (scan-bindings (rest tail)
				    (cons this-clause binding-names)
				    (cons 'nil initial-values)
				    (cons this-clause iteration-clauses))
		   (let
		     ((this-binding (first this-clause))
		      (init-and-step (rest this-clause)))
		     (if (null init-and-step)
			 (scan-bindings (rest tail)
					(cons this-binding binding-names)
					(cons 'nil initial-values)
					(cons this-binding iteration-clauses))
		       (let ((init (first init-and-step))
			     (step (rest init-and-step)))
			 (if (null step)
			     (scan-bindings (rest tail)
					    (cons this-binding binding-names)
					    (cons init initial-values)
					    (cons this-binding iteration-clauses))
			   (scan-bindings (rest tail)
					  (cons this-binding binding-names)
					  (cons init initial-values)
					  (cons (first step) iteration-clauses)))))))))))
    (scan-bindings binding-list '() '() '())))

(defun expand-do-macro (let-type setq-type)
  #'(lambda (do-form ignore)
      (separate-do-bindings
	(second do-form)
	#'(lambda (binding-names initial-values iteration-clauses)
	    (let* ((loop-tag (gensym))
		   (test-form (third do-form))
		   (test (first test-form))
		   (result (if (null (rest test-form)) '(PROGN NIL) `(PROGN ,@(rest test-form))))
		   (body (rest (rest (rest do-form)))))
	      (labels ((interleave (x y)
			 (cond ((null x) y)
			       ((null y) x)
			       (t (cons (car x) (interleave y (cdr x)))))))
		`(BLOCK NIL
		   (,let-type ,(mapcar #'list binding-names initial-values)
		    (TAGBODY
			,loop-tag
			(WHEN ,test (RETURN-FROM NIL ,result))
			(PROGN ,@body)
			(,setq-type ,@(interleave binding-names iteration-clauses))
			(GO ,loop-tag))))))))))

(defmacro do (&whole form &environment env)
  (funcall (expand-do-macro 'let  'psetq) form env))

(defmacro do* (&whole form &environment env)
  (funcall (expand-do-macro 'let* 'setq) form env))

;; Are these still used anywhere?

(defmacro do-named (name vars test-and-result &body body)
  `(BLOCK ,name
     (DO ,vars ,test-and-result ,@body)))

(defmacro do*-named (name vars test-and-result &body body)
  `(BLOCK ,name
     (DO* ,vars ,test-and-result ,@body)))