;;; -*- cold-load:t; MODE:common-LISP; PACKAGE:SYSTEM-INTERNALS; BASE:10; -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.

;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151

;;;  (C) COPYRIGHT 1980,1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY
;;; Copyright (c) 1985-1989 Texas Instruments Incorporated  All Rights Reserved.

(export '(zlc:memq) "SYS") ; 5/8/89 DNG [not really related to LOOP but needs to be in aux-crash list.]

;;; LOOP Iteration Macro

;;;; Macro Environment Setup


(eval-when (eval compile)
(defmacro data-type? (frob)
  (declare (ignore frob))
  ;;should return something if frob is a datatype recognized by loop
  ;; returns nil right now.
  nil)
   )  



;(eval-when (eval compile)
;  (*lexpr variable-declarations) (*expr loop-when-it-variable)
;  (*expr initial-value primitive-type)
;  (setq open-code-map-switch t))


(defmacro loop-copylist* (l)
  `(copylist* ,l))  

;;;; Random Macros


(defmacro loop-simple-error (unquoted-message &optional (datum nil datump))
  `(ferror () ,(if datump (string-append "~S " unquoted-message) unquoted-message)
     ,@(and datump (list datum)))) 


(defmacro loop-pop-source ()
  '(pop loop-source-code)) 


(defmacro object-that-cares-p (x)
  `(consp ,x)) 

;;;; Setq Hackery

; Note:  LOOP-MAKE-PSETQ is NOT flushable depending on the existence
; of PSETQ, unless PSETQ handles destructuring.  Even then it is
; preferable for the code LOOP produces to not contain intermediate
; macros.


(defun loop-make-psetq (frobs)
  (and frobs
       (loop-make-setq
	(list (car frobs)
	      (if (null (cddr frobs)) (cadr frobs)
		  `(prog1
		    ,(cadr frobs)
		    ,(loop-make-psetq (cddr frobs)))))))) 


(defvar loop-desetq-temporary) 

; Do we want this???  It is, admittedly, useful...
;(defmacro loop-desetq (&rest x)
;  (let ((loop-desetq-temporary ()))
;     (let ((setq-form (loop-make-desetq x)))
;	(if loop-desetq-temporary
;	    `((lambda (,loop-desetq-temporary) ,setq-form) ())
;	    setq-form))))



(defun loop-make-desetq (x)
  (do ((x x (cddr x))
       (r nil)
       (var)
       (val))
      ((null x)
       (and r (cons 'setq r)))
    (setq var (car x) val (cadr x))
    (cond
      ((and (not (atom var)) (not (atom val))
	    (not
	     (and (member (car val) '(car cdr cadr cddr caar cdar) :test #'eq) (atom (cadr val)))))
       (setq x
	     (list* (or loop-desetq-temporary (setq loop-desetq-temporary (gensym))) val var
		    loop-desetq-temporary (cddr x)))))
    (setq r (nconc r (loop-desetq-internal (car x) (cadr x)))))) 


(defun loop-desetq-internal (var val)
  (cond
    ((null var) nil)
    ((atom var) (list var val))
    (t
     (nconc (loop-desetq-internal (car var) `(car ,val))
	    (loop-desetq-internal (cdr var) `(cdr ,val)))))) 


(defun loop-make-setq (pairs)
  (and pairs (loop-make-desetq pairs))) 


(defparameter loop-keyword-alist;clause introducers
	      
	      '((named loop-do-named) (initially loop-do-initially) (finally loop-do-finally)
	       (nodeclare loop-nodeclare) (do loop-do-do)
	       (doing loop-do-do) (return loop-do-return) (collect loop-do-collect list)
	       (collecting loop-do-collect list) (append loop-do-collect append)
	       (appending loop-do-collect append) (nconc loop-do-collect nconc)
	       (nconcing loop-do-collect nconc) (count loop-do-collect count)
	       (counting loop-do-collect count) (sum loop-do-collect sum)
	       (summing loop-do-collect sum) (maximize loop-do-collect max)
	       (minimize loop-do-collect min) (always loop-do-always or)
	       (never loop-do-always and) (thereis loop-do-thereis)
	       (while loop-do-while or while) (until loop-do-while and until)
	       (when loop-do-when
		 ())
	       (if loop-do-when ()) (unless loop-do-when
				      t)
	       (with loop-do-with))) 


(defparameter loop-iteration-keyword-alist
	      '((for loop-do-for) (as loop-do-for) (repeat loop-do-repeat))) 


(defparameter loop-for-keyword-alist;Types of FOR
	      
	      '((= loop-for-equals) (first loop-for-first) (in loop-list-stepper car)
	       (on loop-list-stepper nil) (from loop-for-arithmetic from)
	       (downfrom loop-for-arithmetic downfrom) (upfrom loop-for-arithmetic upfrom)
	       (below loop-for-arithmetic below) (to loop-for-arithmetic to)
	       (being loop-for-being))) 


(defvar loop-prog-names) 

(defvar loop-path-keyword-alist ()) 		; PATH functions

(defvar loop-named-variables) 			; see SI:LOOP-NAMED-VARIABLE

(defvar loop-collection-crocks) 		; see LOOP-DO-COLLECT etc

(defvar loop-variables) 			;Variables local to the loop

(defvar loop-declarations) 			; Local dcls for above

(defvar loop-nodeclare) 			; but don't declare these

(defvar loop-variable-stack) 

(defvar loop-declaration-stack) 

(defvar loop-desetq-crocks) 			; see loop-make-variable

(defvar loop-desetq-stack) 			; and loop-translate-1

(defvar loop-prologue) 				;List of forms in reverse order

(defvar loop-wrappers) 				;List of wrapping forms, innermost first

(defvar loop-before-loop) 

(defvar loop-body) 				;..

(defvar loop-after-body) 			;.. for FOR steppers

(defvar loop-epilogue) 				;..

(defvar loop-after-epilogue) 			;So COLLECT's RETURN comes after FINALLY

(defvar loop-conditionals) 			;If non-NIL, condition for next form in body
  ;The above is actually a list of entries of the form
  ;(cond (condition forms...))
  ;When it is output, each successive condition will get
  ;nested inside the previous one, but it is not built up
  ;that way because you wouldn't be able to tell a WHEN-generated
  ;COND from a user-generated COND.
  ;When ELSE is used, each cond can get a second clause


(defvar loop-when-it-variable) 			;See LOOP-DO-WHEN

(defvar loop-never-stepped-variable) 		; see LOOP-FOR-FIRST

(defvar loop-emitted-body?) 			; see LOOP-EMIT-BODY,
						; and LOOP-DO-FOR

(defvar loop-iteration-variables) 		; LOOP-MAKE-ITERATION-VARIABLE

(defvar loop-iteration-variablep) 		; ditto

(defvar loop-collect-cruft) 			; for multiple COLLECTs (etc)

(defvar loop-source-code) 

(defvar loop-duplicate-code ())   ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC

;;;; Construct a value return


(defmacro loop-construct-return (form)
  ``(return ,,form)) 

;;;; Token Hackery

;Compare two "tokens".  The first is the frob out of LOOP-SOURCE-CODE,
;the second a symbol to check against.


(defun loop-tequal (x1 x2)
  (and (symbolp x1) (string-equal x1 x2))) 


(defun loop-tassoc (kwd alist)
  (and (symbolp kwd) (assoc kwd alist :test #'string-equal))) 


(defun loop-tmember (kwd list)
  (and (symbolp kwd) (member kwd list :test #'string-equal))) 


(defmacro define-loop-macro (keyword)
  (or (eq keyword 'loop) (loop-tassoc keyword loop-keyword-alist)
      (loop-tassoc keyword loop-iteration-keyword-alist)
      (loop-simple-error "not a loop keyword - define-loop-macro" keyword))
  (subst keyword
	 'keyword
	 (copy-tree
	   '(eval-when (compile load eval)
	      (deff-macro keyword '(macro . loop-translate))))
	 :test
	 #'eq))


(define-loop-macro loop) 


(defmacro loop-finish ()
  '(go end-loop)) 


(defun loop-end-testify (list-of-forms)
  (if (null list-of-forms) ()
      `(and
       ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) (car list-of-forms)
	  (cons 'or list-of-forms))
       (go end-loop)))) 


(defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b lastdiff)
  (do ((l1 (nreverse loop-before-loop) (cdr l1))
       (l2 (nreverse loop-after-body) (cdr l2)))
      ((equal l1 l2)
       (setq loop-body (nconc (delete (quote ()) (the list l1) :test #'eq) (nreverse loop-body))))
    (push (car l1) before)
    (push (car l2) after))
  (cond
    ((not (null loop-duplicate-code))
     (setq loop-before-loop (nreverse (delete () (the list before) :test #'eq)) loop-after-body
	   (nreverse (delete () (the list after) :test #'eq))))
    (t
     (setq loop-before-loop () loop-after-body () before (nreverse before) after
	   (nreverse after))
     (do ((bb before (cdr bb))
	  (aa after (cdr aa)))
	 ((null aa))
       (cond
	 ((not (equal (car aa) (car bb))) (setq lastdiff aa))
	 ((not (loop-simplep (car aa)));Mustn't duplicate
	  
	  (return ()))))
     (cond
       (lastdiff;Down through lastdiff should be duplicated
	
	(do ()
	    (nil)
	  (and (car before) (push (car before) loop-before-loop))
	  (and (car after) (push (car after) loop-after-body))
	  (setq before (cdr before) after (cdr after))
	  (and (eq after (cdr lastdiff)) (return ())))
	(setq loop-before-loop (nreverse loop-before-loop) loop-after-body
	      (nreverse loop-after-body))))
     (do ((bb (nreverse before) (cdr bb))
	  (aa (nreverse after) (cdr aa)))
	 ((null aa))
       (setq a (car aa) b (car bb))
       (cond
	 ((and (null a) (null b)))
	 ((equal a b) (loop-output-group groupb groupa) (push a loop-body)
	  (setq groupb () groupa ()))
	 (t (and a (push a groupa)) (and b (push b groupb)))))
     (loop-output-group groupb groupa)))
  (and loop-never-stepped-variable
       (push `(setq ,loop-never-stepped-variable ()) loop-after-body))
  ()) 



(defun loop-output-group (before after)
  (and (or after before)
       (let ((v
	      (or loop-never-stepped-variable
		  (setq loop-never-stepped-variable (loop-make-variable (gensym) 't ())))))
	 (push
	  (cond
	    ((not before) `(or ,v (progn
				    . ,after)))
	    ((not after) `(and ,v (progn
				    . ,before)))
	    (t `(cond
		 (,v . ,before)
		 (t . ,after))))
	  loop-body)))) 

;;;12/03/87 CLM for PHD, fixed so that no longer uses a named PROG. 
;;;This was causing compiler warnings (SPR 6312 and 6827).
;;;12/16/87 CLM, fixed previous fix.  First, change the (SETQ TEM ...) form
;;;from a prog to an unnamed block containing a tagbody; second, if the loop
;;;is "named" wrap an outer named-block around the form.  Problems were encountered
;;;when there was a RETURN from within the LOOP.
(defun loop-translate (loop-source-code &optional environment)
  (declare (ignore environment))
  (and (member (car loop-source-code) '(loop :loop) :test #'eq)
       (setq loop-source-code (cdr loop-source-code)))
  (if (not (symbolp (car loop-source-code)))
      ;; This is Common Lisp's LOOP.
      
      `(do ()
	   (nil)
	 ,@loop-source-code)
      (do ((loop-iteration-variables nil)
	   (loop-iteration-variablep nil)
	   (loop-variables nil)
	   (loop-nodeclare ())
	   (loop-named-variables nil)
	   (loop-declarations nil)
	   (loop-desetq-crocks nil)
	   (loop-variable-stack nil)
	   (loop-declaration-stack nil)
	   (loop-desetq-stack nil)
	   (loop-prologue nil)
	   (loop-wrappers nil)
	   (loop-before-loop nil)
	   (loop-body nil)
	   (loop-emitted-body? nil)
	   (loop-after-body nil)
	   (loop-epilogue nil)
	   (loop-after-epilogue nil)
	   (loop-conditionals nil)
	   (loop-when-it-variable ())
	   (loop-never-stepped-variable nil)
	   (loop-desetq-temporary nil)
	   (loop-prog-names nil)
	   (loop-collect-cruft nil)
	   (loop-collection-crocks nil)
	   (keyword)
	   (tem)
	   (progvars))
	  ((null loop-source-code)
	   (and loop-conditionals
		(loop-simple-error "Hanging conditional in loop macro"
				   (caadar loop-conditionals)))
	   (loop-optimize-duplicated-code-etc)
	   (loop-bind-block)
	   (setq progvars loop-collection-crocks)
	   (and loop-desetq-temporary (push loop-desetq-temporary progvars))
	   (setq tem
		 `(block ()
		    (let 
		      ,progvars
		      (tagbody
			  ,.(do ((l loop-collection-crocks (cddr l))
				 (v nil (cons `(loop-collect-init ,(cadr l) ,(car l)) v)))
				((null l)
				 v))
			  ,.(nreverse loop-prologue)
			  ,.loop-before-loop
		       next-loop
			  ,.loop-body
			  ,.loop-after-body
			  (go next-loop)
		       end-loop
			  ,.(nreverse loop-epilogue)
		       . ,(nreverse loop-after-epilogue)))))
	   (when (and loop-prog-names (car loop-prog-names ))
	     (setq tem `(block ,(car loop-prog-names )
			  ,tem)))
	   (do ((vars)
		(dcls)
		(crocks))
	       ((null loop-variable-stack))
	     (setq vars (car loop-variable-stack) loop-variable-stack (cdr loop-variable-stack)
		   dcls (car loop-declaration-stack) loop-declaration-stack
		   (cdr loop-declaration-stack) tem (cons tem ()))
	     (and (setq crocks (pop loop-desetq-stack)) (push (loop-make-desetq crocks) tem))
	     (and dcls (push (cons 'declare dcls) tem))
	     (cond
	       ((do ((l vars (cdr l)))
		    ((null l)
		     nil)
		  (and (not (atom (car l))) (or (null (caar l)) (not (symbolp (caar l))))
		       (return t)))
		(setq tem `(let ,(nreverse
				 vars)
			     ,@tem)))
	       (t
		(let ((lambda-vars nil)
		      (lambda-vals nil))
		  (do ((l vars (cdr l))
		       (v))
		      ((null l))
		    (cond
		      ((atom (setq v (car l))) (push v lambda-vars) (push () lambda-vals))
		      (t (push (car v) lambda-vars) (push (cadr v) lambda-vals))))
		  ;; depending on the mode we must genarate common lisp or zetalisp lambda forms (Phd 4/16/85)
		  (setq tem
			`((,(if (zetalisp-on-p) 'global:lambda 'lambda) ,lambda-vars ,@tem)
			 . ,lambda-vals))))))
	   (dolist (w loop-wrappers)
	     (setq tem (append w (cons tem ()))))
	   tem)
	(if (symbolp (setq keyword (loop-pop-source)))
	    (if (setq tem (loop-tassoc keyword loop-keyword-alist))
		(apply (cadr tem) (cddr tem))
		(if (setq tem (loop-tassoc keyword loop-iteration-keyword-alist))
		    (loop-hack-iteration tem)
		    (if (loop-tmember keyword '(and else)); Alternative is to ignore it, ie let it go around to the
			; next keyword...
			
			(loop-simple-error
			 "secondary clause misplaced at top level in LOOP macro"
			 (list keyword (car loop-source-code) (cadr loop-source-code)))
			(loop-simple-error "unknown keyword in LOOP macro" keyword))))
	    (loop-simple-error "found where keyword expected in LOOP macro" keyword)))))  

(defun loop-bind-block ()
  (cond
    ((not (null loop-variables)) (push loop-variables loop-variable-stack)
     (push loop-declarations loop-declaration-stack)
     (setq loop-variables () loop-declarations ())
     (progn
       (push loop-desetq-crocks loop-desetq-stack)
       (setq loop-desetq-crocks ()))))) 

;Get FORM argument to a keyword.  Read up to atom.  PROGNify if necessary.

(defun loop-get-form ()
  (do ((forms (cons (loop-pop-source) ()) (cons (loop-pop-source) forms))
       (nextform (car loop-source-code) (car loop-source-code)))
      ((atom nextform)
       (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) 


(defun loop-typed-arith (substitutable-expression data-type)
  data-type
  substitutable-expression) 


(defun loop-typed-init (data-type)
  (cond
    ((data-type? data-type) (initial-value data-type))
    ((setq data-type (car (loop-tmember data-type '(fixnum flonum integer number small-flonum))))
     (cond
       ((eq data-type 'flonum) 0.0)
       ((eq data-type 'small-flonum) (small-float 0))
       (t 0))))) 


(defun loop-make-variable (name initialization dtype)
  (cond
    ((null name)
     (cond
       ((not (null initialization)) (push (list 'ignore initialization) loop-variables))))
    ((atom name)
     (cond
       (loop-iteration-variablep
	(if (member name loop-iteration-variables :test #'eq)
	    (loop-simple-error "Duplicated iteration variable somewhere in LOOP" name)
	    (push name loop-iteration-variables)))
       ((assoc name loop-variables :test #'eq)
	(loop-simple-error "Duplicated var in LOOP bind block" name)))
     (or (symbolp name) (loop-simple-error "Bad variable somewhere in LOOP" name))
     (loop-declare-variable name dtype); We use ASSQ on this list to check for duplications (above),
     ; so don't optimize out this list:
     
     (push (list name (or initialization (loop-typed-init dtype))) loop-variables))
    (initialization
     (let ((newvar (gensym)))
       (push (list newvar initialization) loop-variables); LOOP-DESETQ-CROCKS gathered in reverse order.
       
       (setq loop-desetq-crocks (list* name newvar loop-desetq-crocks))
       (loop-make-variable name () dtype)))
    ('t
     (let ((tcar)
	   (tcdr))
       (if (atom dtype) (setq tcar (setq tcdr dtype)) (setq tcar (car dtype) tcdr (cdr dtype)))
       (loop-make-variable (car name) () tcar)
       (loop-make-variable (cdr name) () tcdr))))
  name) 



(defun loop-make-iteration-variable (name initialization dtype)
  (let ((loop-iteration-variablep 't))
    (loop-make-variable name initialization dtype))) 



(defun loop-declare-variable (name dtype)
  (cond
    ((or (null name) (null dtype)) nil)
    ((symbolp name)
     (cond
       ((member name loop-nodeclare :test #'eq))
       ((data-type? dtype)
	(setq loop-declarations (append (variable-declarations dtype name) loop-declarations)))))
    ((object-that-cares-p name)
     (cond
       ((object-that-cares-p dtype) (loop-declare-variable (car name) (car dtype))
	(loop-declare-variable (cdr name) (cdr dtype)))
       ('t (loop-declare-variable (car name) dtype) (loop-declare-variable (cdr name) dtype))))
    ('t (loop-simple-error "can't hack this" (list 'loop-declare-variable name dtype))))) 


(defun loop-constantp (form)
  (or (null form) (eq form 't) (numberp form) (stringp form)
      (and (not (atom form)) (eq (car form) 'quote)))) 


(defun loop-maybe-bind-form (form data-type?); Consider implementations which will not keep EQ quoted constants
 ; EQ after compilation & loading.
 ; Note FUNCTION is not hacked, multiple occurences might cause the
 ; compiler to break the function off multiple times!
 ; Hacking it probably isn't too important here anyway.  The ones that
 ; matter are the ones that use it as a stepper (or whatever), which
 ; handle it specially.
 
  (if (loop-constantp form) form (loop-make-variable (gensym) form data-type?))) 



(defun loop-optional-type ()
  (let ((token (car loop-source-code)))
    (and (not (null token))
	 (or (not (atom token)) (data-type? token)
	     (loop-tmember token '(fixnum flonum integer number notype small-flonum)))
	 (loop-pop-source)))) 


;Incorporates conditional if necessary

(defun loop-make-conditionalization (form)
  (cond
    ((not (null loop-conditionals))
     (rplacd (last (car (last (car (last loop-conditionals))))) (cons form ()))
     (cond
       ((loop-tequal (car loop-source-code) 'and) (loop-pop-source) nil)
       ((loop-tequal (car loop-source-code) 'else)
	(loop-pop-source)
	;; If we are already inside an else clause, close it off
	;; and nest it inside the containing when clause
	
	(let ((innermost (car (last loop-conditionals))))
	  (cond
	    ((null (cddr innermost)));Now in a WHEN clause, OK
	    
	    ((null (cdr loop-conditionals))
	     (loop-simple-error "More ELSEs than WHENs"
				(list 'else (car loop-source-code) (cadr loop-source-code))))
	    ('t (setq loop-conditionals (cdr (nreverse loop-conditionals)))
	     (rplacd (last (car (last (car loop-conditionals)))) (cons innermost ()))
	     (setq loop-conditionals (nreverse loop-conditionals)))))
	;; Start a new else clause
	
	(rplacd (last (car (last loop-conditionals))) (cons (cons ''t ()) ())) nil)
       ('t;Nest up the conditionals and output them
	
	(do ((prev (car loop-conditionals) (car l))
	     (l (cdr loop-conditionals) (cdr l)))
	    ((null l))
	  (rplacd (last (car (last prev))) (cons (car l) ())))
	(prog1
	  (car loop-conditionals)
	  (setq loop-conditionals ())))))
    ('t form))) 


(defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form)))
  (cond
    ((not (null z))
     (cond
       (loop-emitted-body? (push z loop-body))
       ('t (push z loop-before-loop) (push z loop-after-body)))))) 


(defun loop-emit-body (form)
  (setq loop-emitted-body? 't)
  (loop-pseudo-body form)) 


(defun loop-do-named ()
  (let ((name (loop-pop-source)))
    (or (and name (symbolp name)) (loop-simple-error "Bad name for your loop construct" name));If this don't come first, LOOP will be confused about how to return
    ; from the prog when it tries to generate such code.
    ;Should this error check be made always?
    
    (and (cdr (setq loop-prog-names (cons name loop-prog-names)))
	 (loop-simple-error "Too many names for your loop construct" loop-prog-names)))) 


(defun loop-do-initially ()
  (push (loop-get-form) loop-prologue)) 


(defun loop-nodeclare (&aux (varlist (loop-pop-source)))
  (or (and varlist (typep varlist 'list))
      (loop-simple-error "Bad varlist to nodeclare loop clause" varlist))
  (setq loop-nodeclare (append varlist loop-nodeclare))) 


(defun loop-do-finally ()
  (push (loop-get-form) loop-epilogue)) 


(defun loop-do-do ()
  (loop-emit-body (loop-get-form))) 


(defun loop-do-return ()
  (loop-pseudo-body (loop-construct-return (loop-get-form)))) 

;;;; List Collection

; The way we collect (list-collect) things is to bind two variables.
; One is the final result, and is accessible for value during the
; loop compuation.  The second is the "tail".  In implementations where
; we can do so, the tail var is initialized to a locative of the first,
; such that it can be updated with RPLACD.  In other implementations,
; the update must be conditionalized (on whether or not the tail is NIL).


(defmacro loop-collect-init (var1 var2)
  `(setq ,var2 (variable-location ,var1))) 
		

(defun loop-do-collect (type)
  (let ((var)
	(form)
	(tem)
	(tail)
	(dtype)
	(cruft)
	(rvar)
	(ctype
	 (cond
	   ((member type '(max min) :test #'eq) 'maxmin)
	   ((member type '(nconc list append) :test #'eq) 'list)
	   ((member type '(count sum) :test #'eq) 'sum)
	   ('t (loop-simple-error "unrecognized LOOP collecting keyword" type)))))
    (setq form (loop-get-form) dtype (loop-optional-type))
    (cond
      ((loop-tequal (car loop-source-code) 'into) (loop-pop-source)
       (setq rvar (setq var (loop-pop-source))))); CRUFT will be (varname ctype dtype var tail (optional tem))
    
    (cond
      ((setq cruft (assoc var loop-collect-cruft :test #'eq))
       (cond
	 ((not (eq ctype (car (setq cruft (cdr cruft)))))
	  (loop-simple-error "incompatible LOOP collection types" (list ctype (car cruft))))
	 ((and dtype (not (eq dtype (cadr cruft))));Conditional should be on data-type reality
	  
	  (ferror () "~A and ~A Unequal data types into ~A" dtype (cadr cruft) (car cruft))))
       (setq dtype (car (setq cruft (cdr cruft))) var (car (setq cruft (cdr cruft))) tail
	     (car (setq cruft (cdr cruft))) tem (cadr cruft))
       (and (eq ctype 'maxmin) (not (atom form)) (null tem)
	    (rplaca (cdr cruft) (setq tem (loop-make-variable (gensym) () dtype)))))
      ('t
       (and (null dtype)
	    (setq dtype
		  (cond
		    ((eq type 'count) 'fixnum)
		    ((member type '(min max sum) :test #'eq) 'number))))
       (or var (push (loop-construct-return (setq var (gensym))) loop-after-epilogue))
       (or (eq ctype 'list) (loop-make-iteration-variable var () dtype))
       (setq tail
	     (cond
	       ((eq ctype 'list)
		(car (setq loop-collection-crocks (list* (gensym) var loop-collection-crocks))))
	       ((eq ctype 'maxmin)
		(or (atom form) (setq tem (loop-make-variable (gensym) () dtype)))
		(loop-make-variable (gensym) ''t ()))))
       (push (list rvar ctype dtype var tail tem) loop-collect-cruft)))
    (loop-emit-body
     (case type
       (count (setq tem `(setq ,var (,(loop-typed-arith '1+ dtype) ,var)))
	      (if (or (eq form 't) (equal form ''t)) tem `(and ,form ,tem)))
       (sum `(setq ,var (,(loop-typed-arith '+ dtype) ,form ,var)))
       ((max min)
	(let ((forms nil) (arglist ())); TEM is temporary, properly typed.
	      
	  (and tem (setq forms `((setq ,tem ,form)) form tem))
	  (setq arglist (list var form))
	  (push
	   (if (loop-tmember dtype '(fixnum flonum small-flonum)); no contagious arithmetic
	       
	       `(and
		(or ,tail
		    (,(loop-typed-arith (if (eq type 'max) '< '>) dtype) . ,arglist))
		(setq ,tail () ,@arglist)); potentially contagious arithmetic -- must use
	       ; MAX or MIN so that var will be contaminated
	       
	       `(setq ,var (cond
			     (,tail (setq ,tail ()) ,form)
			     ((,type . ,arglist)))))
	   forms)
	  (if (cdr forms) (cons 'progn (nreverse forms)) (car forms))))
       (t
	(case type
	  (list (setq form (list 'list form)))
	  (append
	   (or (and (not (atom form)) (eq (car form) 'list)) (setq form `(copylist* ,form)))))
	(let ((q `(rplacd ,tail ,form)))
	  (cond
	    ((and (not (atom form)) (eq (car form) 'list) (not (null (cdr form)))); RPLACD of cdr-coded list:
	     
	     (rplaca (cddr q) (if (cddr form) `(list* ,@(cdr form) ()) `(cons ,(cadr form) nil)))
	     (cond
	       ((null (cddr form)) (rplaca (cddr q) `(setq ,tail ,(caddr q))) q)
	       ('t `(setq ,tail ,(loop-cdrify (cdr form) q)))))
	    ('t `(and (cdr ,q) (setq ,tail (last (cdr ,tail)))))))))))) 


(defun loop-cdrify (arglist form &aux (size (length arglist)))
  (case size
	(0 form)
	(1 `(cdr ,form))
	(2 `(cddr ,form))
	(3 `(cdddr ,form))
	(4 `(cddddr ,form))
	(otherwise   `(nthcdr ,size ,form))))

;(defun loop-cdrify (arglist form)
;  (do ((size (length arglist) (- size 4)))
;      ((< size 4)
;       (if (zerop size) form (list (cond
;				     ((= size 1) 'cdr)
;				     ((= size 2) 'cddr)
;				     ('t 'cdddr))
;				   form)))
;    (setq form (list 'cddddr form)))) 


(defun loop-do-while (cond
   kwd
   &aux
   (form (loop-get-form)))
  (and loop-conditionals
       (loop-simple-error "not allowed inside LOOP conditional" (list kwd form)))
  (loop-pseudo-body `(,cond ,form (go end-loop)))) 



(defun loop-do-when (negate?)
  (let ((form (loop-get-form))
	(cond))
    (cond
      ((loop-tequal (cadr loop-source-code) 'it);WHEN foo RETURN IT and the like
       
       (setq cond `(setq ,(loop-when-it-variable) ,form))
       (setq loop-source-code;Plug in variable for IT
	     
	     (list* (car loop-source-code) loop-when-it-variable (cddr loop-source-code))))
      ('t (setq cond form)))
    (and negate? (setq cond `(not ,cond)))
    (setq loop-conditionals (nconc loop-conditionals `((cond
							 (,cond))))))) 


(defun loop-do-with ()
  (do ((var)
       (equals)
       (val)
       (dtype))
      (nil)
    (setq var (loop-pop-source) equals (car loop-source-code))
    (cond
      ((loop-tequal equals '=) (loop-pop-source) (setq val (loop-get-form) dtype ()))
      ((or (loop-tequal equals 'and) (loop-tassoc equals loop-keyword-alist)
	   (loop-tassoc equals loop-iteration-keyword-alist))
       (setq val () dtype ()))
      ('t (setq dtype (loop-pop-source) equals (car loop-source-code))
       (cond
	 ((loop-tequal equals '=) (loop-pop-source) (setq val (loop-get-form)))
	 ((and (not (null loop-source-code)) (not (loop-tassoc equals loop-keyword-alist))
	       (not (loop-tassoc equals loop-iteration-keyword-alist))
	       (not (loop-tequal equals 'and)))
	  (loop-simple-error "Garbage where = expected" equals))
	 ('t (setq val ())))))
    (loop-make-variable var val dtype)
    (if (not (loop-tequal (car loop-source-code) 'and)) (return ()) (loop-pop-source)))
  (loop-bind-block)) 


(defun loop-do-always (pred)
  (let ((form (loop-get-form)))
    (loop-emit-body `(,pred ,form ,(loop-construct-return ())))
    (push (loop-construct-return t) loop-after-epilogue))) 

;THEREIS expression
;If expression evaluates non-nil, return that value.

(defun loop-do-thereis ()
  (loop-emit-body
   `(and (setq ,(loop-when-it-variable) ,(loop-get-form))
      ,(loop-construct-return loop-when-it-variable)))) 


(defun loop-simplep (expr)
  (if (null expr) 0
      (catch 'loop-simplep
	(let ((ans (loop-simplep-1 expr)))
	  (and (< ans 24) ans))))) 


(defvar loop-simplep
	'(> < greaterp lessp plusp minusp typep zerop plus difference + - add1 sub1 1+ 1-
	   boole rot ash ldb equal atom setq prog1 prog2 and or = global:aref
	   global:ar-1 ar-1 aref ar-2 ar-3    <= /= >=)) 


(defun loop-simplep-1 (x)
  (let ((z 0))
    (cond
      ((loop-constantp x) 0)
      ((atom x) 1)
      ((eq (car x) 'cond)
       (do ((cl (cdr x) (cdr cl)))
	   ((null cl))
	 (do ((f (car cl) (cdr f)))
	     ((null f))
	   (setq z (+ (loop-simplep-1 (car f)) z 1))))
       z)
      ((symbolp (car x))
       (let ((fn (car x))
	     (tem nil))
	 (cond
	   ((setq tem (get fn 'loop-simplep))
	    (if (integerp tem) (setq z tem) (setq z (funcall tem x) x ())))
	   ((member fn '(null not eq go return progn) :test #'eq))
	   ((member fn '(car cdr) :test #'eq) (setq z 1))
	   ((member fn '(caar cadr cdar cddr) :test #'eq) (setq z 2))
	   ((member fn '(caaar caadr cadar caddr cdaar cdadr cddar cdddr) :test #'eq) (setq z 3))
	   ((member fn
		    '(caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr
		       cdadar cdaddr cddaar cddadr cdddar cddddr)
		    :test #'eq)
	    (setq z 4))
	   ((member fn loop-simplep :test #'eq) (setq z 2))
	   ((not (eq (setq tem (macroexpand-1 x)) x)) (setq z (loop-simplep-1 tem) x ()))
	   (t (throw 'loop-simplep
		     ())))
	 (do ((l (cdr x) (cdr l)))
	     ((null l))
	   (setq z (+ (loop-simplep-1 (car l)) 1 z)))
	 z))
      (t (throw 'loop-simplep
		()))))) 

;;;; The iteration driver

(defun loop-hack-iteration (entry)
  (do ((last-entry entry)
       (source loop-source-code loop-source-code)
       (pre-step-tests nil)
       (steps nil)
       (post-step-tests nil)
       (pseudo-steps nil)
       (pre-loop-pre-step-tests nil)
       (pre-loop-steps nil)
       (pre-loop-post-step-tests nil)
       (pre-loop-pseudo-steps nil)
       (tem)
       (data)
       (foo)
       (bar))
      (nil); Note we collect endtests in reverse order, but steps in correct
       ; order.  LOOP-END-TESTIFY does the nreverse for us.
       
    (setq tem (setq data (apply (cadr entry) (cddr entry))))
    (and (car tem) (push (car tem) pre-step-tests))
    (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
    (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
    (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
    (setq tem (cdr tem))
    (and (or loop-conditionals loop-emitted-body?)
	 (or tem pre-step-tests post-step-tests pseudo-steps)
	 (let ((cruft (list (car entry) (car source) (cadr source) (caddr source))))
	   (if loop-emitted-body?
	       (loop-simple-error "Iteration is not allowed to follow body code" cruft)
	       (loop-simple-error "Iteration starting inside of conditional in LOOP" cruft))))
    (or tem (setq tem data))
    (and (car tem) (push (car tem) pre-loop-pre-step-tests))
    (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
    (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
    (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
    (cond
      ((or (not (loop-tequal (car loop-source-code) 'and))
	   (and loop-conditionals
		(not (loop-tassoc (cadr loop-source-code) loop-iteration-keyword-alist))))
       (setq foo
	     (list (loop-end-testify pre-loop-pre-step-tests) (loop-make-psetq pre-loop-steps)
		   (loop-end-testify pre-loop-post-step-tests)
		   (loop-make-setq pre-loop-pseudo-steps))
	     bar
	     (list (loop-end-testify pre-step-tests) (loop-make-psetq steps)
		   (loop-end-testify post-step-tests) (loop-make-setq pseudo-steps)))
       (cond
	 ((not loop-conditionals)
	  (setq loop-before-loop (nreconc foo loop-before-loop) loop-after-body
		(nreconc bar loop-after-body)))
	 ('t
	  ((lambda (loop-conditionals)
	     (push (loop-make-conditionalization (cons 'progn (delete () (the list foo) :test #'eq) )) loop-before-loop))
	   (mapcar
	    '(lambda (x);Copy parts that will get rplacd'ed
			     
	       (cons (car x) (mapcar '(lambda (x)
					(loop-copylist* x))
				     (cdr x))))
	    loop-conditionals))
	  (push
	   (loop-make-conditionalization (cons 'progn (delete () (the list bar) :test #'eq)))
	   loop-after-body)))
       (loop-bind-block) (return ())))
    (loop-pop-source); flush the "AND"
    
    (setq entry
	  (cond
	    ((setq tem (loop-tassoc (car loop-source-code) loop-iteration-keyword-alist))
	     (loop-pop-source) (setq last-entry tem))
	    ('t last-entry))))) 

;FOR variable keyword ..args..

(defun loop-do-for ()
  (let ((var (loop-pop-source))
	(data-type? (loop-optional-type))
	(keyword (loop-pop-source))
	(first-arg (loop-get-form))
	(tem nil))
    (or (setq tem (loop-tassoc keyword loop-for-keyword-alist))
	(loop-simple-error "Unknown keyword in FOR or AS clause in LOOP" (list 'for var keyword)))
    (apply (cadr tem) var first-arg data-type? (cddr tem)))) 



(defun loop-do-repeat ()
  (let ((var (loop-make-variable (gensym) (loop-get-form) 'fixnum)))
    `((not (,(loop-typed-arith 'plusp 'fixnum) ,var)) nil nil
     (,var (,(loop-typed-arith '1- 'fixnum) ,var))))) 


(defun loop-when-it-variable ()
  (or loop-when-it-variable (setq loop-when-it-variable (loop-make-variable (gensym) () ())))) 


(defun loop-for-equals (var val data-type?)
  (cond
    ((loop-tequal (car loop-source-code) 'then);FOR var = first THEN next
     
     (loop-pop-source) (loop-make-iteration-variable var val data-type?)
     `(nil (,var ,(loop-get-form)) nil nil nil nil nil nil))
    ('t (loop-make-iteration-variable var () data-type?)
     (let ((varval (list var val)))
       (cond
	 (loop-emitted-body? (loop-emit-body (loop-make-setq varval)) '(nil nil nil nil))
	 (`(nil ,varval nil nil))))))) 


(defun loop-for-first (var val data-type?)
  (or (loop-tequal (car loop-source-code) 'then)
      (loop-simple-error "found where THEN expected in FOR ... FIRST" (car loop-source-code)))
  (loop-pop-source)
  (loop-make-iteration-variable var () data-type?)
  `(nil (,var ,(loop-get-form)) nil nil nil (,var ,val) nil nil)) 


(defun loop-list-stepper (var val data-type? fn)
  (let ((stepper
	 (cond
	   ((loop-tequal (car loop-source-code) 'by) (loop-pop-source) (loop-get-form))
	   ('t '#'cdr)))
	(var1 nil)
	(stepvar nil)
	(step ())
	(et nil)
	(pseudo nil))
    (setq step
	  (if (or (atom stepper) (not (member (car stepper) ''function :test #'eq)))
	      `(funcall ,(setq stepvar (gensym))) (list (cadr stepper))))
    (cond
      ((and (atom var)
	    ;; (eq (car step) 'cdr)
	    
	    (not fn)) (setq var1 (loop-make-iteration-variable var val data-type?)))
      ('t (loop-make-iteration-variable var () data-type?)
       (setq var1 (loop-make-variable (gensym) val ()))
       (setq pseudo (list var (if fn (list fn var1) var1)))))
    (rplacd (last step) (list var1))
    (and stepvar (loop-make-variable stepvar stepper ()))
    (setq stepper (list var1 step) et `(null ,var1))
    (if (not pseudo) `(nil ,stepper ,et nil nil nil ,et nil)
	(if (eq (car step) 'cdr) `(,et ,pseudo nil ,stepper)
	    `((null (setq . ,stepper)) nil nil ,pseudo ,et nil nil ,pseudo))))) 



(defun loop-for-arithmetic (var val data-type? kwd); Args to loop-sequencer:
 ; indexv indexv-type variable? vtype? sequencev? sequence-type
 ; stephack? default-top? crap prep-phrases
 
  (loop-sequencer var (or data-type? 'fixnum) () () () () () () `(for ,var ,kwd ,val)
		  (cons (list kwd val)
			(loop-gather-preps '(from upfrom downfrom to upto downto above below by)
					   ())))) 


(defun loop-named-variable (name)
  (let ((tem (loop-tassoc name loop-named-variables)))
    (cond
      ((null tem) (gensym))
      ('t (setq loop-named-variables (delete tem (the list loop-named-variables) :test #'eq))
       (cdr tem))))) 

; Note:  path functions are allowed to use loop-make-variable, hack
; the prologue, etc.

(defun loop-for-being (var val data-type?); FOR var BEING something ... - var = VAR, something = VAL.
 ; If what passes syntactically for a pathname isn't, then
 ; we trap to the DEFAULT-LOOP-PATH path;  the expression which looked like
 ; a path is given as an argument to the IN preposition.  Thus,
 ; by default, FOR var BEING EACH expr OF expr-2
 ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2.
 
  (let ((tem)
	(inclusive?)
	(ipps)
	(each?)
	(attachment))
    (if (or (loop-tequal val 'each) (loop-tequal val 'the))
	(setq each? 't val (car loop-source-code)) (push val loop-source-code))
    (cond
      ((and (setq tem (loop-tassoc val loop-path-keyword-alist))
	    (or each? (not (loop-tequal (cadr loop-source-code) 'and))))
       ;; FOR var BEING {each} path {prep expr}..., but NOT
       ;; FOR var BEING var-which-looks-like-path AND {ITS} ...
       
       (loop-pop-source))
      ('t (setq val (loop-get-form))
       (cond
	 ((loop-tequal (car loop-source-code) 'and)
	  ;; FOR var BEING value AND ITS path-or-ar
	  
	  (or (null each?) (loop-simple-error "Malformed BEING EACH clause in LOOP" var))
	  (setq ipps `((of ,val)) inclusive? 't) (loop-pop-source)
	  (or (loop-tmember (setq tem (loop-pop-source)) '(its his her their each))
	      (loop-simple-error "found where ITS or EACH expected in LOOP path" tem))
	  (if (setq tem (loop-tassoc (car loop-source-code) loop-path-keyword-alist))
	      (loop-pop-source) (push (setq attachment `(in ,(loop-get-form))) ipps)))
	 ((not (setq tem (loop-tassoc (car loop-source-code) loop-path-keyword-alist))); FOR var BEING {each} a-r ...
	  
	  (setq ipps (list (setq attachment (list 'in val)))))
	 ('t; FOR var BEING {each} pathname ...
	  ; Here, VAL should be just PATHNAME.
	  
	  (loop-pop-source)))))
    (cond
      ((not (null tem)))
      ((not (setq tem (loop-tassoc 'default-loop-path loop-path-keyword-alist)))
       (loop-simple-error "Undefined LOOP iteration path" (cadr attachment))))
    (setq tem
	  (funcall (cadr tem) (car tem) var data-type?
		   (nreconc ipps (loop-gather-preps (caddr tem) 't)) inclusive? (caddr tem)
		   (cdddr tem)))
    (and loop-named-variables (loop-simple-error "unused USING variables" loop-named-variables)); For error continuability (if there is any):
    
    (setq loop-named-variables ())
    ;; TEM is now (bindings prologue-forms . stuff-to-pass-back)
    
    (do ((l (car tem) (cdr l))
	 (x))
	((null l))
      (if (atom (setq x (car l))) (loop-make-iteration-variable x () ())
	  (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
    (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue))
    (cddr tem))) 


(defun loop-gather-preps (preps-allowed crockp)
  (do ((token (car loop-source-code) (car loop-source-code))
       (preps nil))
      (nil)
    (cond
      ((loop-tmember token preps-allowed) (push (list (loop-pop-source) (loop-get-form)) preps))
      ((loop-tequal token 'using) (loop-pop-source)
       (or crockp
	   (loop-simple-error "USING used in illegal context"
			      (list 'using (car loop-source-code))))
       (do ((z (car loop-source-code) (car loop-source-code))
	    (tem))
	   ((atom z))
	 (and
	  (or (atom (cdr z)) (not (null (cddr z))) (not (symbolp (car z)))
	      (and (cadr z) (not (symbolp (cadr z)))))
	  (loop-simple-error "bad variable pair in path USING phrase" z))
	 (cond
	   ((not (null (cadr z)))
	    (and (setq tem (loop-tassoc (car z) loop-named-variables))
		 (loop-simple-error "Duplicated var substitition in USING phrase" (list tem z)))
	    (push (cons (car z) (cadr z)) loop-named-variables)))
	 (loop-pop-source)))
      ('t (return (nreverse preps)))))) 


(defun loop-add-path (name data)
  (setq loop-path-keyword-alist
	(cons (cons name data); Don't change this to use DELASSQ in PDP10, the lsubr
	      ; calling sequence makes that lose.
	      
	      (delete (loop-tassoc name loop-path-keyword-alist)
		      (the list loop-path-keyword-alist) :test #'eq)))
  ()) 



(defmacro define-loop-path (names &rest cruft)
  (setq names (if (atom names) (list names) names))
  (let ((forms (mapcar #'(lambda (name)
			   `(loop-add-path ',name ',cruft))
		       names)))
    `(eval-when (eval load compile) ,@forms))) 


(defun loop-sequencer (indexv indexv-type variable? vtype? sequencev? sequence-type? stephack? default-top? crap
  prep-phrases)
  (let ((endform)
	(sequencep)
	(test)
	(step; Gross me out!
	 
	 (1+ (or (loop-typed-init indexv-type) 0)))
	(dir)
	(inclusive-iteration?)
	(start-given?)
	(limit-given?))
    (and variable? (loop-make-iteration-variable variable? () vtype?))
    (do ((l prep-phrases (cdr l))
	 (prep)
	 (form)
	 (odir))
	((null l))
      (setq prep (caar l) form (cadar l))
      (cond
	((loop-tmember prep '(of in))
	 (and sequencep
	      (loop-simple-error "Sequence duplicated in LOOP path" (list variable? (car l))))
	 (setq sequencep 't) (loop-make-variable sequencev? form sequence-type?))
	((loop-tmember prep '(from downfrom upfrom))
	 (and start-given?
	      (loop-simple-error "Iteration start redundantly specified in LOOP sequencing"
				 (append crap l)))
	 (setq start-given? 't)
	 (cond
	   ((loop-tequal prep 'downfrom) (setq dir 'down))
	   ((loop-tequal prep 'upfrom) (setq dir 'up)))
	 (loop-make-iteration-variable indexv form indexv-type))
	((cond
	   ((loop-tequal prep 'upto) (setq inclusive-iteration? (setq dir 'up)))
	   ((loop-tequal prep 'to) (setq inclusive-iteration? 't))
	   ((loop-tequal prep 'downto) (setq inclusive-iteration? (setq dir 'down)))
	   ((loop-tequal prep 'above) (setq dir 'down))
	   ((loop-tequal prep 'below) (setq dir 'up)))
	 (and limit-given?
	      (loop-simple-error "Endtest redundantly specified in LOOP sequencing path"
				 (append crap l)))
	 (setq limit-given? 't) (setq endform (loop-maybe-bind-form form indexv-type)))
	((loop-tequal prep 'by)
	 (setq step (if (loop-constantp form) form (loop-make-variable (gensym) form 'fixnum))))
	('t; This is a fatal internal error...
	 
	 (loop-simple-error "Illegal prep in sequence path" (append crap l))))
      (and odir dir (not (eq dir odir))
	   (loop-simple-error "Conflicting stepping directions in LOOP sequencing path"
			      (append crap l)))
      (setq odir dir))
    (and sequencev? (not sequencep)
	 (loop-simple-error "Missing OF phrase in sequence path" crap)); Now fill in the defaults.
    
    (setq step (list indexv step))
    (cond
      ((member dir '(nil up) :test #'eq)
       (or start-given? (loop-make-iteration-variable indexv 0 indexv-type))
       (and
	(or limit-given?
	    (cond
	      (default-top? (loop-make-variable (setq endform (gensym)) () indexv-type)
	       (push `(setq ,endform ,default-top?) loop-prologue))))
	(setq test (if inclusive-iteration? '(> . args) '(>= . args))))
       (push '+ step))
      ('t
       (cond
	 ((not start-given?)
	  (or default-top?
	      (loop-simple-error "Don't know where to start stepping" (append crap prep-phrases)))
	  (loop-make-iteration-variable indexv 0 indexv-type)
	  (push `(setq ,indexv (,(loop-typed-arith '1- indexv-type) ,default-top?))
		loop-prologue)))
       (cond
	 ((and default-top? (not endform))
	  (setq endform (loop-typed-init indexv-type) inclusive-iteration? 't)))
       (and (not (null endform))
	    (setq test (if inclusive-iteration? '(< . args) '(<= . args))))
       (push '- step)))
    (and (member (caddr step) '(1 1.0 (small-float 1)) :test #'equal)
	 (rplacd (cdr (rplaca step (if (eq (car step) '+) '1+ '1-))) ()))
    (rplaca step (loop-typed-arith (car step) indexv-type))
    (setq step (list indexv step))
    (setq test (loop-typed-arith test indexv-type))
    (setq test
	  (subst (list indexv endform)
		 'args
		 (copy-tree test)
		 :test  #'equal))
    (and stephack? (setq stephack? `(,variable? ,stephack?)))
    `(nil ,step ,test ,stephack? nil nil ,test ,stephack?))) 


; Although this function is no longer documented, the "SI:" is needed
; because compiled files may reference it that way (via
; DEFINE-LOOP-SEQUENCE-PATH).

;;AB for PHD 8/3/87.  Fix to generate zlc:AREF where appropriate.  [SPR 5304]
(defun loop-sequence-elements-path (path variable data-type prep-phrases inclusive? allowed-preps data)
  allowed-preps; unused
  
  (let ((indexv (loop-named-variable 'index))
	(sequencev (loop-named-variable 'sequence))
	(fetchfun nil)
	(sizefun nil)
	(type nil)
	(default-var-type nil)
	(crap `(for ,variable being the ,path))
	(fn (CAR data)))
    (cond
      ((not (null inclusive?)) (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path))
       (loop-simple-error "Can't step sequence inclusively" crap)))
    (setq fetchfun
	  (if (zetalisp-on-p) (OR (FIND-SYMBOL fn *global-package*) fn) fn)
	  sizefun (car (setq data (cdr data))) type
	  (car (setq data (cdr data))) default-var-type (cadr data))
    (list* () (); dummy bindings and prologue
	      
	   (loop-sequencer indexv 'fixnum variable (or data-type default-var-type) sequencev
			   type `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev) crap
			   prep-phrases)))) 


(defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun &optional sequence-type element-type)
  `(define-loop-path ,path-name-or-names loop-sequence-elements-path
     (of in from downfrom to downto below above by) ,fetchfun ,sizefun ,sequence-type
     ,element-type)) 


(defun loop-interned-symbols-path (path variable data-type prep-phrases inclusive? allowed-preps data &aux statev1 statev2
  statev3 statev4 (localp (car data)))
  path
  data-type
  allowed-preps; unused vars
  
  (and inclusive? (loop-simple-error "INTERNED-SYMBOLS path doesn't work inclusively" variable))
  (and (not (null prep-phrases))
       (or (cdr prep-phrases) (not (loop-tmember (caar prep-phrases) '(in of))))
       (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A" path variable prep-phrases))
  (loop-make-variable variable () data-type)
  (loop-make-variable (setq statev1 (gensym))
		      (if prep-phrases `(find-package ,(cadar prep-phrases)) 'package) ())
  (loop-make-variable (setq statev2 (gensym)) () ())
  (loop-make-variable (setq statev3 (gensym)) () ())
  (loop-make-variable (setq statev4 (gensym)) () ())
  (push
   `(multiple-value-setq (,statev1 ,statev2 ,statev3 ,statev4)
      (loop-initialize-mapatoms-state ,statev1 ,localp))
   loop-prologue)
  `(nil nil
   (multiple-value-setq (nil ,statev1 ,statev2 ,statev3 ,statev4)
		   (loop-test-and-step-mapatoms ,statev1 ,statev2 ,statev3 ,statev4))
   (,variable ,statev2) nil nil)) 


(defun loop-initialize-mapatoms-state (pkg localp)
 ;;; Return the initial values of the four state variables.
 ;;; This scheme uses them to be:
 ;;; (1)  Index into the package (decremented as we go)
 ;;; (2)  Temporary (to hold the symbol)
 ;;; (3)  the package
 ;;; (4)  a list of other packages to consider.

  (block nil					;changed from (prog nil  ;PMH
    (return (dont-optimize (p-number-of-entries (pack-symbol-table pkg)))
	    ()
	    pkg
	    (and localp (package-use-list pkg))))) 


(defun loop-test-and-step-mapatoms (index temp pkg other-packages)
  temp; ignored
  (prog ()
    lp
    (cond
      ((< (setq index (1- index)) 0)
       (cond
	 ((setq pkg (car other-packages)) (pop other-packages)
	  (setq index (dont-optimize (p-number-of-entries (pack-symbol-table pkg)))) (go lp))
	 (t (return t))))
      ((dont-optimize (p-active-entry (dont-optimize (p-word0 (pack-symbol-table pkg) index))))
       (return () index (dont-optimize (p-word1 (pack-symbol-table pkg) index)) pkg other-packages))
      (t (go lp))))) 

;;;; LOOP iteration path for hash tables


(define-loop-path hash-elements loop-hash-elements-path (of with-key)) 

;;Phd 4/10/86 Converted that function to the new hash table format.
;;AB for PHD 8/03/87. Fixed so it generates code similar to maphash. [SPR 6039]
;;CLM 6/1/88. Fixed incorrect parens after WITH-LOCK. [SPR 8062, 8158, 8224]
(defun loop-hash-elements-path (ignore variable ignore prep-phrases inclusive? ignore ignore)
  (if inclusive?
      (ferror () "Inclusive stepping not supported in HASH-ELEMENTS path for ~S." variable))
  (unless (loop-tassoc 'of prep-phrases)
    (ferror () "No OF phrase in HASH-ELEMENTS path for ~S." variable))
  (let (bindings
	prologue
	steps
	post-endtest
	pseudo-steps
	(blen-var (gensym))
	(ht-var (gensym))
	(i-var (gensym))
	(len-var (gensym))
	(tem (gensym))
	(key-var (or (cadr (loop-tassoc 'with-key prep-phrases)) (gensym)))
	(offset-var (gensym))
	(hash-table (cadr (loop-tassoc 'of prep-phrases))))
    (setq bindings
	  `((,ht-var (follow-structure ,ht-var ))
	    (,blen-var nil)
	    (,offset-var nil)
	    (,variable nil) (,i-var nil) (,key-var nil) (,len-var nil))
	  prologue
	  `((when (rehash-for-gc ,ht-var)	      
	      (funcall (hash-table-rehash-function ,ht-var) ,ht-var ()))
	    (setq ,blen-var (hash-table-block-length ,ht-var)) (setq ,i-var (- ,blen-var))
	   (setq ,offset-var (if (hash-table-hash-function ,ht-var) 1 0))
	   (setq ,len-var (array-total-size ,ht-var)))
	  steps
	  `(,i-var
	   (do ((,tem (+ ,blen-var ,i-var) (+ ,blen-var ,tem)))
	       ((or (>= ,tem ,len-var) (/= (%p-data-type (aloc ,ht-var ,tem)) dtp-null))
		,tem)))
	  post-endtest `(>= ,i-var ,len-var)
	  pseudo-steps
	  `(,key-var (aref ,ht-var (+ ,i-var ,offset-var))
	    ,variable (aref ,ht-var (+ ,i-var ,offset-var 1))) )
    (setf loop-wrappers (nconc loop-wrappers
			       `((with-lock ((hash-table-lock ,ht-var) :whostate "Hash Table Lock"))
				 (let ((,ht-var ,hash-table))))))
    (list bindings prologue () steps post-endtest pseudo-steps)))  

;;;; Setup stuff

; We don't want these defined in the compilation environment because
; the appropriate environment hasn't been set up.  So, we just bootstrap
; them up.

(mapc
 #'(lambda (x)
     (mapc
      #'(lambda (y)
	  (setq loop-path-keyword-alist
		(cons (cons y (cdr x))
		      (delete (loop-tassoc y loop-path-keyword-alist)
			      (the list loop-path-keyword-alist) :test #'eq))))
      (car x)))
 '(((interned-symbols interned-symbol) loop-interned-symbols-path (in))
  ((local-interned-symbols local-interned-symbol) loop-interned-symbols-path (in) t)))  


(mapc
 #'(lambda (x)
     (mapc
      #