;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.62
;;; Reason:
;;;  Fix the DO macros for the postultimate time.
;;; Written 4-May-87 10:50:39 by rauen at site LMI Cambridge
;;; while running on Debtor in Possession from band 2
;;; with Experimental System 121.60, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, microcode 1730, SDU Boot Tape 3.14, SDU ROM 103, 121.53.



; From file DJ: L.SYS2; CLMAC.LISP#20 at 4-May-87 10:50:46
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; CLMAC  "

(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))))))))))
))