;;; -*- 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 '() '() '())))

;;; $$$ Don't bother with this since we don't download do yet. <18-Nov-88 JIM>
;;+++ The fleabit very likely is not compiling this correctly!!! --wkf
;(defun expand-do-macro (let-type setq-type)
;  (error "Expand-do-macro does not compile correctly using fleabit." let-type setq-type) ;;||| 10/20/88 --wkf
;  #'(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))))))))))

;;; $$$ Don't download macros yet. <18-Nov-88 JIM>
;(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)))