;;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Patch-File:T; Base:8; Readtable:CL -*-
;;; Patch file for System version 121.42
;;; Reason:
;;;  Fix alternate macro definition of DO and its relatives for once and
;;;  for all.
;;; Written 4-Mar-87 18:23:09 by jrm (Joe Marshall) at site LMI Cambridge
;;; while running on Lambda Four A from band 2
;;; with Experimental System 121.39, 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, Experimental IMicro 20.0, microcode 1742, SDU Boot Tape 3.14, SDU ROM 102, 121.35.



; From file DJ: L.SYS2; CLMAC.LISP#12 at 4-Mar-87 18:23:44
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; CLMAC  "

(defmacro (macro alternate-macro-definition) (function-spec &rest def)
  (unless (symbolp function-spec)
    (setq function-spec (standardize-function-spec function-spec)))
  `(PROGN (fdefine ',function-spec
		   (CONS (QUOTE MACRO) (QUOTE (LAMBDA ,(car def) ,@(cdr def)))) t)
	  ',function-spec))

(defmacro (deff alternate-macro-definition) (function-spec definition)
  `(progn (fset-carefully ',function-spec ,definition)
	  ',function-spec))

))

; From file DJ: L.SYS2; CLMAC.LISP#12 at 4-Mar-87 18:23:17
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; CLMAC  "

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

))

; From file DJ: L.SYS2; CLMAC.LISP#12 at 4-Mar-87 18:23:22
#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))
		   (block-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 ,block-tag
		 (,let-type ,(mapcar #'list binding-names initial-values)
		  (TAGBODY
		      ,loop-tag
		      (WHEN ,test (RETURN-FROM ,block-tag ,result))
		      (PROGN ,@body)
		      (,setq-type ,@(interleave binding-names iteration-clauses))
		      (GO ,loop-tag))))))))))

))

; From file DJ: L.SYS2; CLMAC.LISP#12 at 4-Mar-87 18:23:29
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; CLMAC  "

(deff do-expander  (expand-do-macro 'let  'psetq))
(deff do*-expander (expand-do-macro 'let* 'setq))

(defprop do (macro . do-expander) alternate-macro-definition)
(defprop do* (macro . do-expander) alternate-macro-definition)
))

; From file DJ: L.SYS2; CLMAC.LISP#12 at 4-Mar-87 18:23:37
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; CLMAC  "

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

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