--- /dev/null
+;;; -*- Mode: LISP; Package: ANSI-LOOP; Syntax: Common-lisp; Base: 10; Lowercase:T -*-
+;;;
+;;; This file is included with CLSQL to be used by CLISP which does not
+;;; have an extensible LOOP macro. It was copied from the CMUCL 19c source.
+;;; Minor porting changes have been made Copyright (c) 2006 Kevin M. Rosenberg
+;;;
+;;;>
+;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology.
+;;;> All Rights Reserved.
+;;;>
+;;;> Permission to use, copy, modify and distribute this software and its
+;;;> documentation for any purpose and without fee is hereby granted,
+;;;> provided that the M.I.T. copyright notice appear in all copies and that
+;;;> both that copyright notice and this permission notice appear in
+;;;> supporting documentation. The names "M.I.T." and "Massachusetts
+;;;> Institute of Technology" may not be used in advertising or publicity
+;;;> pertaining to distribution of the software without specific, written
+;;;> prior permission. Notice must be given in supporting documentation that
+;;;> copying distribution is by permission of M.I.T. M.I.T. makes no
+;;;> representations about the suitability of this software for any purpose.
+;;;> It is provided "as is" without express or implied warranty.
+;;;>
+;;;> Massachusetts Institute of Technology
+;;;> 77 Massachusetts Avenue
+;;;> Cambridge, Massachusetts 02139
+;;;> United States of America
+;;;> +1-617-253-1000
+;;;>
+;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc.
+;;;> All Rights Reserved.
+;;;>
+;;;> Permission to use, copy, modify and distribute this software and its
+;;;> documentation for any purpose and without fee is hereby granted,
+;;;> provided that the Symbolics copyright notice appear in all copies and
+;;;> that both that copyright notice and this permission notice appear in
+;;;> supporting documentation. The name "Symbolics" may not be used in
+;;;> advertising or publicity pertaining to distribution of the software
+;;;> without specific, written prior permission. Notice must be given in
+;;;> supporting documentation that copying distribution is by permission of
+;;;> Symbolics. Symbolics makes no representations about the suitability of
+;;;> this software for any purpose. It is provided "as is" without express
+;;;> or implied warranty.
+;;;>
+;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera,
+;;;> and Zetalisp are registered trademarks of Symbolics, Inc.
+;;;>
+;;;> Symbolics, Inc.
+;;;> 8 New England Executive Park, East
+;;;> Burlington, Massachusetts 01803
+;;;> United States of America
+;;;> +1-617-221-1000
+
+;; $aclHeader: loop.cl,v 1.5 91/12/04 01:13:48 cox acl4_1 $
+#+cmu
+(ext:file-comment
+ "$Header: /project/cmucl/cvsroot/src/code/loop.lisp,v 1.27 2004/10/21 02:31:08 rtoy Exp $")
+
+
+;;;; LOOP Iteration Macro
+
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (ext:package-lock (find-package "COMMON-LISP")) nil))
+(defpackage ansi-loop (:use :common-lisp)
+ (:shadowing-import-from "COMMON-LISP" "LOOP" "LOOP-FINISH"))
+(in-package ansi-loop)
+
+;;; Technology.
+;;;
+;;; The LOOP iteration macro is one of a number of pieces of code
+;;; originally developed at MIT and licensed as set out above. This
+;;; version of LOOP, which is almost entirely rewritten both as a
+;;; clean-up and to conform with the ANSI Lisp LOOP standard, started
+;;; life as MIT LOOP version 829 (which was a part of NIL, possibly
+;;; never released).
+;;;
+;;; A "light revision" was performed by Glenn Burke while at Palladian
+;;; Software in April 1986, to make the code run in Common Lisp. This
+;;; revision was informally distributed to a number of people, and was
+;;; sort of the "MIT" version of LOOP for running in Common Lisp.
+;;;
+;;; A later more drastic revision was performed at Palladian perhaps a
+;;; year later. This version was more thoroughly Common Lisp in
+;;; style, with a few miscellaneous internal improvements and
+;;; extensions. Glenn Burke lost track of this source, apparently
+;;; never having moved it to the MIT distribution point; and does not
+;;; remember if it was ever distributed.
+;;;
+;;; This revision for the ANSI standard is based on the code of Glenn
+;;; Burke's April 1986 version, with almost everything redesigned
+;;; and/or rewritten.
+\f
+
+;;; The design of this LOOP is intended to permit, using mostly the same
+;;; kernel of code, up to three different "loop" macros:
+;;;
+;;; (1) The unextended, unextensible ANSI standard LOOP;
+;;;
+;;; (2) A clean "superset" extension of the ANSI LOOP which provides
+;;; functionality similar to that of the old LOOP, but "in the style of"
+;;; the ANSI LOOP. For instance, user-definable iteration paths, with a
+;;; somewhat cleaned-up interface.
+;;;
+;;; (3) Extensions provided in another file which can make this LOOP
+;;; kernel behave largely compatibly with the Genera-vintage LOOP macro,
+;;; with only a small addition of code (instead of two whole, separate,
+;;; LOOP macros).
+;;;
+;;; Each of the above three LOOP variations can coexist in the same LISP
+;;; environment.
+;;;
+\f
+
+;;;; Miscellaneous Environment Things
+
+
+
+;;;@@@@The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or
+;;; its obvious expansion (prog1 (car x) (setq x (cdr x))). Usually this involves
+;;; shifting fenceposts in an iteration or series of carcdr operations. This is
+;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's
+;;; destructuring setq code.
+(eval-when (compile load eval)
+ #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*)
+ )
+
+
+;;; The uses of this macro are retained in the CL version of loop, in
+;;; case they are needed in a particular implementation. Originally
+;;; dating from the use of the Zetalisp COPYLIST* function, this is used
+;;; in situations where, were cdr-coding in use, having cdr-NIL at the
+;;; end of the list might be suboptimal because the end of the list will
+;;; probably be RPLACDed and so cdr-normal should be used instead.
+(defmacro loop-copylist* (l)
+ #+Genera `(lisp:copy-list ,l nil t) ; arglist = (list &optional area force-dotted)
+ ;;@@@@Explorer??
+ #-Genera `(copy-list ,l)
+ )
+
+
+(defvar *loop-gentemp* t)
+
+(defun loop-gentemp (&optional (pref 'loopvar-))
+ (if *loop-gentemp*
+ (gensym (string pref))
+ (gensym)))
+
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *loop-real-data-type* 'real))
+
+
+(defun loop-optimization-quantities (env)
+ ;;@@@@ The ANSI conditionalization here is for those lisps that implement
+ ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS).
+ ;; It is really commentary on how this code could be written. I don't
+ ;; actually expect there to be an ANSI #+-conditional -- it should be
+ ;; replaced with the appropriate conditional name for your
+ ;; implementation/dialect.
+ (declare #-ANSI (ignore env)
+ #+Genera (values speed space safety compilation-speed debug))
+ #+ANSI (let ((stuff (declaration-information 'optimize env)))
+ (values (or (cdr (assoc 'speed stuff)) 1)
+ (or (cdr (assoc 'space stuff)) 1)
+ (or (cdr (assoc 'safety stuff)) 1)
+ (or (cdr (assoc 'compilation-speed stuff)) 1)
+ (or (cdr (assoc 'debug stuff)) 1)))
+ #+CLOE-Runtime (values compiler::time compiler::space
+ compiler::safety compiler::compilation-speed 1)
+ #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1))
+
+
+;;;@@@@ The following form takes a list of variables and a form which presumably
+;;; references those variables, and wraps it somehow so that the compiler does not
+;;; consider those variables have been referenced. The intent of this is that
+;;; iteration variables can be flagged as unused by the compiler, e.g. I in
+;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage
+;;; of it is "invisible" or "not to be considered".
+;;;We implicitly assume that a setq does not count as a reference. That is, the
+;;; kind of form generated for the above loop construct to step I, simplified, is
+;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))).
+(defun hide-variable-references (variable-list form)
+ (declare #-Genera (ignore variable-list))
+ #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form)
+ #-Genera form)
+
+
+;;;@@@@ The following function takes a flag, a variable, and a form which presumably
+;;; references that variable, and wraps it somehow so that the compiler does not
+;;; consider that variable to have been referenced. The intent of this is that
+;;; iteration variables can be flagged as unused by the compiler, e.g. I in
+;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage
+;;; of it is "invisible" or "not to be considered".
+;;;We implicitly assume that a setq does not count as a reference. That is, the
+;;; kind of form generated for the above loop construct to step I, simplified, is
+;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))).
+;;;Certain cases require that the "invisibility" of the reference be conditional upon
+;;; something. This occurs in cases of "named" variables (the USING clause). For instance,
+;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...)
+;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is
+;;; not referenced. However, if no USING clause is present, we definitely do not
+;;; want to be informed that some random gensym is not used.
+;;;It is easier for the caller to do this conditionally by passing a flag (which
+;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than
+;;; for all callers to contain the conditional invisibility construction.
+(defun hide-variable-reference (really-hide variable form)
+ (declare #-Genera (ignore really-hide variable))
+ #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns
+ `(compiler:invisible-references (,variable) ,form)
+ form)
+ #-Genera form)
+\f
+
+;;;; List Collection Macrology
+
+
+(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var)
+ &body body)
+ ;;@@@@ TI? Exploder?
+ #+LISPM (let ((head-place (or user-head-var head-var)))
+ `(let* ((,head-place nil)
+ (,tail-var
+ ,(hide-variable-reference
+ user-head-var user-head-var
+ `(progn #+Genera (scl:locf ,head-place)
+ #-Genera (system:variable-location ,head-place)))))
+ ,@body))
+ #-LISPM (let ((l (and user-head-var (list (list user-head-var nil)))))
+ #+CLOE `(sys::with-stack-list* (,head-var nil nil)
+ (let ((,tail-var ,head-var) ,@l)
+ ,@body))
+ #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
+ ,@body)))
+
+
+(defmacro loop-collect-rplacd (&environment env
+ (head-var tail-var &optional user-head-var) form)
+ (declare
+ #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail.
+ )
+ (setq form (macroexpand form env))
+ (flet ((cdr-wrap (form n)
+ (declare (fixnum n))
+ (do () ((<= n 4) (setq form `(,(case n
+ (1 'cdr)
+ (2 'cddr)
+ (3 'cdddr)
+ (4 'cddddr))
+ ,form)))
+ (setq form `(cddddr ,form) n (- n 4)))))
+ (let ((tail-form form) (ncdrs nil))
+ ;;Determine if the form being constructed is a list of known length.
+ (when (consp form)
+ (cond ((eq (car form) 'list)
+ (setq ncdrs (1- (length (cdr form))))
+ ;;@@@@ Because the last element is going to be RPLACDed,
+ ;; we don't want the cdr-coded implementations to use
+ ;; cdr-nil at the end (which would just force copying
+ ;; the whole list again).
+ #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
+ ((member (car form) '(list* cons))
+ (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
+ (setq ncdrs (- (length (cdr form)) 2))))))
+ (let ((answer
+ (cond ((null ncdrs)
+ `(when (setf (cdr ,tail-var) ,tail-form)
+ (setq ,tail-var (last (cdr ,tail-var)))))
+ ((< ncdrs 0) (return-from loop-collect-rplacd nil))
+ ((= ncdrs 0)
+ ;;@@@@ Here we have a choice of two idioms:
+ ;; (rplacd tail (setq tail tail-form))
+ ;; (setq tail (setf (cdr tail) tail-form)).
+ ;;Genera and most others I have seen do better with the former.
+ `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
+ (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
+ ncdrs))))))
+ ;;If not using locatives or something similar to update the user's
+ ;; head variable, we've got to set it... It's harmless to repeatedly set it
+ ;; unconditionally, and probably faster than checking.
+ #-LISPM (when user-head-var
+ (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
+ answer))))
+
+
+(defmacro loop-collect-answer (head-var &optional user-head-var)
+ (or user-head-var
+ (progn
+ ;;If we use locatives to get tail-updating to update the head var,
+ ;; then the head var itself contains the answer. Otherwise we
+ ;; have to cdr it.
+ #+LISPM head-var
+ #-LISPM `(cdr ,head-var))))
+\f
+
+;;;; Maximization Technology
+
+
+#|
+The basic idea of all this minimax randomness here is that we have to
+have constructed all uses of maximize and minimize to a particular
+"destination" before we can decide how to code them. The goal is to not
+have to have any kinds of flags, by knowing both that (1) the type is
+something which we can provide an initial minimum or maximum value for
+and (2) know that a MAXIMIZE and MINIMIZE are not being combined.
+
+SO, we have a datastructure which we annotate with all sorts of things,
+incrementally updating it as we generate loop body code, and then use
+a wrapper and internal macros to do the coding when the loop has been
+constructed.
+|#
+
+
+(defstruct (loop-minimax
+ (:constructor make-loop-minimax-internal)
+ (:copier nil)
+ (:predicate nil))
+ answer-variable
+ type
+ temp-variable
+ flag-variable
+ operations
+ infinity-data)
+
+
+(defvar *loop-minimax-type-infinities-alist*
+ ;;@@@@ This is the sort of value this should take on for a Lisp that has
+ ;; "eminently usable" infinities. n.b. there are neither constants nor
+ ;; printed representations for infinities defined by CL.
+ ;;@@@@ This grotesque read-from-string below is to help implementations
+ ;; which croak on the infinity character when it appears in a token, even
+ ;; conditionalized out.
+ #+Genera
+ '#.(read-from-string
+ "((fixnum most-positive-fixnum most-negative-fixnum)
+ (short-float +1s\ e -1s\ e)
+ (single-float +1f\ e -1f\ e)
+ (double-float +1d\ e -1d\ e)
+ (long-float +1l\ e -1l\ e))")
+ ;;This is how the alist should look for a lisp that has no infinities. In
+ ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive.
+ #+(or CLOE-Runtime Minima)
+ '((fixnum most-positive-fixnum most-negative-fixnum)
+ (short-float most-positive-short-float most-negative-short-float)
+ (single-float most-positive-single-float most-negative-single-float)
+ (double-float most-positive-double-float most-negative-double-float)
+ (long-float most-positive-long-float most-negative-long-float))
+ ;; CMUCL has infinities so let's use them.
+ #+CMU
+ '((fixnum most-positive-fixnum most-negative-fixnum)
+ (short-float ext:single-float-positive-infinity ext:single-float-negative-infinity)
+ (single-float ext:single-float-positive-infinity ext:single-float-negative-infinity)
+ (double-float ext:double-float-positive-infinity ext:double-float-negative-infinity)
+ (long-float ext:long-float-positive-infinity ext:long-float-negative-infinity))
+ ;; If we don't know, then we cannot provide "infinite" initial values for any of the
+ ;; types but FIXNUM:
+ #-(or Genera CLOE-Runtime Minima CMU)
+ '((fixnum most-positive-fixnum most-negative-fixnum))
+ )
+
+
+(defun make-loop-minimax (answer-variable type)
+ (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep))))
+ (make-loop-minimax-internal
+ :answer-variable answer-variable
+ :type type
+ :temp-variable (loop-gentemp 'loop-maxmin-temp-)
+ :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-))
+ :operations nil
+ :infinity-data infinity-data)))
+
+
+(defun loop-note-minimax-operation (operation minimax)
+ (pushnew (the symbol operation) (loop-minimax-operations minimax))
+ (when (and (cdr (loop-minimax-operations minimax))
+ (not (loop-minimax-flag-variable minimax)))
+ (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-)))
+ operation)
+
+
+(defmacro with-minimax-value (lm &body body)
+ (let ((init (loop-typed-init (loop-minimax-type lm)))
+ (which (car (loop-minimax-operations lm)))
+ (infinity-data (loop-minimax-infinity-data lm))
+ (answer-var (loop-minimax-answer-variable lm))
+ (temp-var (loop-minimax-temp-variable lm))
+ (flag-var (loop-minimax-flag-variable lm))
+ (type (loop-minimax-type lm)))
+ (if flag-var
+ `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil))
+ (declare (type ,type ,answer-var ,temp-var))
+ ,@body)
+ `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data)))
+ (,temp-var ,init))
+ (declare (type ,type ,answer-var ,temp-var))
+ ,@body))))
+
+
+(defmacro loop-accumulate-minimax-value (lm operation form)
+ (let* ((answer-var (loop-minimax-answer-variable lm))
+ (temp-var (loop-minimax-temp-variable lm))
+ (flag-var (loop-minimax-flag-variable lm))
+ (test
+ (hide-variable-reference
+ t (loop-minimax-answer-variable lm)
+ `(,(ecase operation
+ (min '<)
+ (max '>))
+ ,temp-var ,answer-var))))
+ `(progn
+ (setq ,temp-var ,form)
+ (when ,(if flag-var `(or (not ,flag-var) ,test) test)
+ (setq ,@(and flag-var `(,flag-var t))
+ ,answer-var ,temp-var)))))
+\f
+
+
+;;;; Loop Keyword Tables
+
+
+#|
+LOOP keyword tables are hash tables string keys and a test of EQUAL.
+
+The actual descriptive/dispatch structure used by LOOP is called a "loop
+universe" contains a few tables and parameterizations. The basic idea is
+that we can provide a non-extensible ANSI-compatible loop environment,
+an extensible ANSI-superset loop environment, and (for such environments
+as CLOE) one which is "sufficiently close" to the old Genera-vintage
+LOOP for use by old user programs without requiring all of the old LOOP
+code to be loaded.
+|#
+
+
+;;;; 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= x1 x2)))
+
+
+(defun loop-tassoc (kwd alist)
+ (and (symbolp kwd) (assoc kwd alist :test #'string=)))
+
+
+(defun loop-tmember (kwd list)
+ (and (symbolp kwd) (member kwd list :test #'string=)))
+
+
+(defun loop-lookup-keyword (loop-token table)
+ (and (symbolp loop-token)
+ (values (gethash (symbol-name loop-token) table))))
+
+
+(defmacro loop-store-table-data (symbol table datum)
+ `(setf (gethash (symbol-name ,symbol) ,table) ,datum))
+
+
+(defstruct (loop-universe
+ (:print-function print-loop-universe)
+ (:copier nil)
+ (:predicate nil))
+ keywords ;hash table, value = (fn-name . extra-data).
+ iteration-keywords ;hash table, value = (fn-name . extra-data).
+ for-keywords ;hash table, value = (fn-name . extra-data).
+ path-keywords ;hash table, value = (fn-name . extra-data).
+ type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier.
+ type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec.
+ ansi ;NIL, T, or :EXTENDED.
+ implicit-for-required ;see loop-hack-iteration
+ )
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun print-loop-universe (u stream level)
+ (declare (ignore level))
+ (let ((str (case (loop-universe-ansi u)
+ ((nil) "Non-ANSI")
+ ((t) "ANSI")
+ (:extended "Extended-ANSI")
+ (t (loop-universe-ansi u)))))
+ ;;Cloe could be done with the above except for bootstrap lossage...
+ #+CLOE
+ (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u))
+ (print-unreadable-object (u stream :type t :identity t)
+ (princ str stream))
+ )))
+
+
+;;;This is the "current" loop context in use when we are expanding a
+;;;loop. It gets bound on each invocation of LOOP.
+(defvar *loop-universe*)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords
+ type-keywords type-symbols ansi)
+ #-(and CLOE Source-Bootstrap) (check-type ansi (member nil t :extended))
+ (flet ((maketable (entries)
+ (let* ((size (length entries))
+ (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal)))
+ (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x)))
+ ht)))
+ (make-loop-universe
+ :keywords (maketable keywords)
+ :for-keywords (maketable for-keywords)
+ :iteration-keywords (maketable iteration-keywords)
+ :path-keywords (maketable path-keywords)
+ :ansi ansi
+ :implicit-for-required (not (null ansi))
+ :type-keywords (maketable type-keywords)
+ :type-symbols (let* ((size (length type-symbols))
+ (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq)))
+ (dolist (x type-symbols)
+ (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x))))
+ ht)))))
+
+\f
+
+;;;; Setq Hackery
+
+
+(defvar *loop-destructuring-hooks*
+ nil
+ "If not NIL, this must be a list of two things:
+a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.")
+
+
+(defun loop-make-psetq (frobs)
+ (and frobs
+ (loop-make-desetq
+ (list (car frobs)
+ (if (null (cddr frobs)) (cadr frobs)
+ `(prog1 ,(cadr frobs)
+ ,(loop-make-psetq (cddr frobs))))))))
+
+
+(defun loop-make-desetq (var-val-pairs)
+ (if (null var-val-pairs)
+ nil
+ (cons (if *loop-destructuring-hooks*
+ (cadr *loop-destructuring-hooks*)
+ 'loop-really-desetq)
+ var-val-pairs)))
+
+
+(defvar *loop-desetq-temporary*
+ (make-symbol "LOOP-DESETQ-TEMP"))
+
+
+(defmacro loop-really-desetq (&environment env &rest var-val-pairs)
+ (labels ((find-non-null (var)
+ ;; see if there's any non-null thing here
+ ;; recurse if the list element is itself a list
+ (do ((tail var)) ((not (consp tail)) tail)
+ (when (find-non-null (pop tail)) (return t))))
+ (loop-desetq-internal (var val &optional temp)
+ ;; returns a list of actions to be performed
+ (typecase var
+ (null
+ (when (consp val)
+ ;; don't lose possible side-effects
+ (if (eq (car val) 'prog1)
+ ;; these can come from psetq or desetq below.
+ ;; throw away the value, keep the side-effects.
+ ;;Special case is for handling an expanded POP.
+ (mapcan #'(lambda (x)
+ (and (consp x)
+ (or (not (eq (car x) 'car))
+ (not (symbolp (cadr x)))
+ (not (symbolp (setq x (macroexpand x env)))))
+ (cons x nil)))
+ (cdr val))
+ `(,val))))
+ (cons
+ (let* ((car (car var))
+ (cdr (cdr var))
+ (car-non-null (find-non-null car))
+ (cdr-non-null (find-non-null cdr)))
+ (when (or car-non-null cdr-non-null)
+ (if cdr-non-null
+ (let* ((temp-p temp)
+ (temp (or temp *loop-desetq-temporary*))
+ (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
+ car
+ `(prog1 (car ,temp)
+ (setq ,temp (cdr ,temp))))
+ ,@(loop-desetq-internal cdr temp temp))
+ #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
+ (setq ,temp (cdr ,temp))
+ ,@(loop-desetq-internal cdr temp temp))))
+ (if temp-p
+ `(,@(unless (eq temp val)
+ `((setq ,temp ,val)))
+ ,@body)
+ `((let ((,temp ,val))
+ ,@body))))
+ ;; no cdring to do
+ (loop-desetq-internal car `(car ,val) temp)))))
+ (otherwise
+ (unless (eq var val)
+ `((setq ,var ,val)))))))
+ (do ((actions))
+ ((null var-val-pairs)
+ (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
+ (setq actions (revappend
+ (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
+ actions)))))
+\f
+
+;;;; LOOP-local variables
+
+;;;This is the "current" pointer into the LOOP source code.
+(defvar *loop-source-code*)
+
+
+;;;This is the pointer to the original, for things like NAMED that
+;;;insist on being in a particular position
+(defvar *loop-original-source-code*)
+
+
+;;;This is *loop-source-code* as of the "last" clause. It is used
+;;;primarily for generating error messages (see loop-error, loop-warn).
+(defvar *loop-source-context*)
+
+
+;;;List of names for the LOOP, supplied by the NAMED clause.
+(defvar *loop-names*)
+
+;;;The macroexpansion environment given to the macro.
+(defvar *loop-macro-environment*)
+
+;;;This holds variable names specified with the USING clause.
+;;; See LOOP-NAMED-VARIABLE.
+(defvar *loop-named-variables*)
+
+;;; LETlist-like list being accumulated for one group of parallel bindings.
+(defvar *loop-variables*)
+
+;;;List of declarations being accumulated in parallel with
+;;;*loop-variables*.
+(defvar *loop-declarations*)
+
+;;;Used by LOOP for destructuring binding, if it is doing that itself.
+;;; See loop-make-variable.
+(defvar *loop-desetq-crocks*)
+
+;;; List of wrapping forms, innermost first, which go immediately inside
+;;; the current set of parallel bindings being accumulated in
+;;; *loop-variables*. The wrappers are appended onto a body. E.g.,
+;;; this list could conceivably has as its value ((with-open-file (g0001
+;;; g0002 ...))), with g0002 being one of the bindings in
+;;; *loop-variables* (this is why the wrappers go inside of the variable
+;;; bindings).
+(defvar *loop-wrappers*)
+
+;;;This accumulates lists of previous values of *loop-variables* and the
+;;;other lists above, for each new nesting of bindings. See
+;;;loop-bind-block.
+(defvar *loop-bind-stack*)
+
+;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause
+;;;which inhibits LOOP from actually outputting a type declaration for
+;;;an iteration (or any) variable.
+(defvar *loop-nodeclare*)
+
+;;;This is simply a list of LOOP iteration variables, used for checking
+;;;for duplications.
+(defvar *loop-iteration-variables*)
+
+
+;;;List of prologue forms of the loop, accumulated in reverse order.
+(defvar *loop-prologue*)
+
+(defvar *loop-before-loop*)
+(defvar *loop-body*)
+(defvar *loop-after-body*)
+
+;;;This is T if we have emitted any body code, so that iteration driving
+;;;clauses can be disallowed. This is not strictly the same as
+;;;checking *loop-body*, because we permit some clauses such as RETURN
+;;;to not be considered "real" body (so as to permit the user to "code"
+;;;an abnormal return value "in loop").
+(defvar *loop-emitted-body*)
+
+
+;;;List of epilogue forms (supplied by FINALLY generally), accumulated
+;;; in reverse order.
+(defvar *loop-epilogue*)
+
+;;;List of epilogue forms which are supplied after the above "user"
+;;;epilogue. "normal" termination return values are provide by putting
+;;;the return form in here. Normally this is done using
+;;;loop-emit-final-value, q.v.
+(defvar *loop-after-epilogue*)
+
+;;;The "culprit" responsible for supplying a final value from the loop.
+;;;This is so loop-emit-final-value can moan about multiple return
+;;;values being supplied.
+(defvar *loop-final-value-culprit*)
+
+;;;If not NIL, we are in some branch of a conditional. Some clauses may
+;;;be disallowed.
+(defvar *loop-inside-conditional*)
+
+;;;If not NIL, this is a temporary bound around the loop for holding the
+;;;temporary value for "it" in things like "when (f) collect it". It
+;;;may be used as a supertemporary by some other things.
+(defvar *loop-when-it-variable*)
+
+;;;Sometimes we decide we need to fold together parts of the loop, but
+;;;some part of the generated iteration code is different for the first
+;;;and remaining iterations. This variable will be the temporary which
+;;;is the flag used in the loop to tell whether we are in the first or
+;;;remaining iterations.
+(defvar *loop-never-stepped-variable*)
+
+;;;List of all the value-accumulation descriptor structures in the loop.
+;;; See loop-get-collection-info.
+(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc)
+\f
+
+;;;; Code Analysis Stuff
+
+
+(defun loop-constant-fold-if-possible (form &optional expected-type)
+ #+Genera (declare (values new-form constantp constant-value))
+ (let ((new-form form) (constantp nil) (constant-value nil))
+ #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment*
+ :repeat t
+ :do-macro-expansion t
+ :do-named-constants t
+ :do-inline-forms t
+ :do-optimizers t
+ :do-constant-folding t
+ :do-function-args t)
+ constantp (constantp new-form *loop-macro-environment*)
+ constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*)))
+ #-Genera (when (setq constantp (constantp new-form))
+ (setq constant-value (eval new-form)))
+ (when (and constantp expected-type)
+ (unless (typep constant-value expected-type)
+ (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+ form constant-value expected-type)
+ (setq constantp nil constant-value nil)))
+ (values new-form constantp constant-value)))
+
+
+(defun loop-constantp (form)
+ #+Genera (constantp form *loop-macro-environment*)
+ #-Genera (constantp form))
+\f
+
+;;;; LOOP Iteration Optimization
+
+(defvar *loop-duplicate-code*
+ nil)
+
+
+(defvar *loop-iteration-flag-variable*
+ (make-symbol "LOOP-NOT-FIRST-TIME"))
+
+
+(defun loop-code-duplication-threshold (env)
+ (multiple-value-bind (speed space) (loop-optimization-quantities env)
+ (+ 40 (* (- speed space) 10))))
+
+
+(defmacro loop-body (&environment env
+ prologue
+ before-loop
+ main-body
+ after-loop
+ epilogue
+ &aux rbefore rafter flagvar)
+ (unless (= (length before-loop) (length after-loop))
+ (error "LOOP-BODY called with non-synched before- and after-loop lists."))
+ ;;All our work is done from these copies, working backwards from the end:
+ (setq rbefore (reverse before-loop) rafter (reverse after-loop))
+ (labels ((psimp (l)
+ (let ((ans nil))
+ (dolist (x l)
+ (when x
+ (push x ans)
+ (when (and (consp x) (member (car x) '(go return return-from)))
+ (return nil))))
+ (nreverse ans)))
+ (pify (l) (if (null (cdr l)) (car l) `(progn ,@l)))
+ (makebody ()
+ (let ((form `(tagbody
+ ;; ANSI CL 6.1.7.2 says that initially clauses are
+ ;; evaluated in the loop prologue, which precedes
+ ;; all loop code except for the initial settings
+ ;; provided by with, for, or as.
+ ,@(psimp (append (nreverse rbefore) prologue))
+ next-loop
+ ,@(psimp (append main-body (nreconc rafter `((go next-loop)))))
+ end-loop
+ ,@(psimp epilogue))))
+ (if flagvar `(let ((,flagvar nil)) ,form) form))))
+ (when (or *loop-duplicate-code* (not rbefore))
+ (return-from loop-body (makebody)))
+ ;; This outer loop iterates once for each not-first-time flag test generated
+ ;; plus once more for the forms that don't need a flag test
+ (do ((threshold (loop-code-duplication-threshold env))) (nil)
+ (declare (fixnum threshold))
+ ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent
+ ;; forms into the body.
+ (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
+ (push (pop rbefore) main-body)
+ (pop rafter))
+ (unless rbefore (return (makebody)))
+ ;; The first forms in rbefore & rafter (which are the chronologically
+ ;; last forms in the list) differ, therefore they cannot be moved
+ ;; into the main body. If everything that chronologically precedes
+ ;; them either differs or is equal but is okay to duplicate, we can
+ ;; just put all of rbefore in the prologue and all of rafter after
+ ;; the body. Otherwise, there is something that is not okay to
+ ;; duplicate, so it and everything chronologically after it in
+ ;; rbefore and rafter must go into the body, with a flag test to
+ ;; distinguish the first time around the loop from later times.
+ ;; What chronologically precedes the non-duplicatable form will
+ ;; be handled the next time around the outer loop.
+ (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil))
+ ((null bb) (return-from loop-body (makebody))) ;Did it.
+ (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
+ ((or (not (setq inc (estimate-code-size (car bb) env)))
+ (> (incf count inc) threshold))
+ ;; Ok, we have found a non-duplicatable piece of code. Everything
+ ;; chronologically after it must be in the central body.
+ ;; Everything chronologically at and after lastdiff goes into the
+ ;; central body under a flag test.
+ (let ((then nil) (else nil))
+ (do () (nil)
+ (push (pop rbefore) else)
+ (push (pop rafter) then)
+ (when (eq rbefore (cdr lastdiff)) (return)))
+ (unless flagvar
+ (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else))
+ (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
+ main-body))
+ ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb)
+ ;; is the same in rbefore and rafter so just copy it into the body
+ (do () (nil)
+ (pop rafter)
+ (push (pop rbefore) main-body)
+ (when (eq rbefore (cdr bb)) (return)))
+ (return)))))))
+\f
+
+
+(defun duplicatable-code-p (expr env)
+ (if (null expr) 0
+ (let ((ans (estimate-code-size expr env)))
+ (declare (fixnum ans))
+ ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of
+ ;; optimize quantities back to help quantify how much code we are willing to
+ ;; duplicate.
+ ans)))
+
+
+(defvar *special-code-sizes*
+ '((return 0) (progn 0)
+ (null 1) (not 1) (eq 1) (car 1) (cdr 1)
+ (when 1) (unless 1) (if 1)
+ (caar 2) (cadr 2) (cdar 2) (cddr 2)
+ (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
+ (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
+ (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
+ (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
+ (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
+
+
+(defvar *estimate-code-size-punt*
+ '(block
+ do do* dolist
+ flet
+ labels lambda let let* locally
+ macrolet multiple-value-bind
+ prog prog*
+ symbol-macrolet
+ tagbody
+ unwind-protect
+ with-open-file))
+
+
+(defun destructuring-size (x)
+ (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n)))
+ ((atom x) (+ n (if (null x) 0 1)))))
+
+
+(defun estimate-code-size (x env)
+ (catch 'estimate-code-size
+ (estimate-code-size-1 x env)))
+
+
+(defun estimate-code-size-1 (x env)
+ (flet ((list-size (l)
+ (let ((n 0))
+ (declare (fixnum n))
+ (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
+ ;;@@@@ ???? (declare (function list-size (list) fixnum))
+ (cond ((constantp x #+Genera env) 1)
+ ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
+ (if expanded-p (estimate-code-size-1 new-form env) 1)))
+ ((atom x) 1) ;??? self-evaluating???
+ ((symbolp (car x))
+ (let ((fn (car x)) (tem nil) (n 0))
+ (declare (symbol fn) (fixnum n))
+ (macrolet ((f (overhead &optional (args nil args-p))
+ `(the fixnum (+ (the fixnum ,overhead)
+ (the fixnum (list-size ,(if args-p args '(cdr x))))))))
+ (cond ((setq tem (get fn 'estimate-code-size))
+ (typecase tem
+ (fixnum (f tem))
+ (t (funcall tem x env))))
+ ((setq tem (assoc fn *special-code-sizes*)) (f (second tem)))
+ #+Genera
+ ((eq fn 'compiler:invisible-references) (list-size (cddr x)))
+ ((eq fn 'cond)
+ (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n)))
+ ((eq fn 'desetq)
+ (do ((l (cdr x) (cdr l))) ((null l) n)
+ (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env)))))
+ ((member fn '(setq psetq))
+ (do ((l (cdr x) (cdr l))) ((null l) n)
+ (setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
+ ((eq fn 'go) 1)
+ ((eq fn 'function)
+ ;;This skirts the issue of implementationally-defined lambda macros
+ ;; by recognizing CL function names and nothing else.
+ #-cmu 1
+ #+cmu (if (ext:valid-function-name-p (cadr x))
+ 1
+ (throw 'duplicatable-code-p nil)))
+ ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x)))
+ ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env)))
+ ((or (special-operator-p fn) (member fn *estimate-code-size-punt*))
+ (throw 'estimate-code-size nil))
+ (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
+ (if expanded-p
+ (estimate-code-size-1 new-form env)
+ (f 3))))))))
+ (t (throw 'estimate-code-size nil)))))
+\f
+
+;;;; Loop Errors
+
+
+(defun loop-context ()
+ (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new)))
+ ((eq l (cdr *loop-source-code*)) (nreverse new))))
+
+
+(defun loop-error (format-string &rest format-args)
+ #+(or Genera CLOE) (declare (dbg:error-reporter))
+ #+Genera (setq format-args (copy-list format-args)) ;Don't ask.
+ #+cmu
+ (kernel:simple-program-error "~?~%Current LOOP context:~{ ~S~}."
+ format-string format-args (loop-context))
+ #-cmu
+ (error "~?~%Current LOOP context:~{ ~S~}."
+ format-string format-args (loop-context)))
+
+
+(defun loop-warn (format-string &rest format-args)
+ (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
+
+
+(defun loop-check-data-type (specified-type required-type
+ &optional (default-type required-type))
+ (if (null specified-type)
+ default-type
+ (multiple-value-bind (a b) (subtypep specified-type required-type)
+ (cond ((not b)
+ (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
+ specified-type required-type))
+ ((not a)
+ (loop-error "Specified data type ~S is not a subtype of ~S."
+ specified-type required-type)))
+ specified-type)))
+\f
+
+;;;INTERFACE: Traditional, ANSI, Lucid.
+(defmacro loop-finish ()
+ "Causes the iteration to terminate \"normally\", the same as implicit
+termination by an iteration driving clause, or by use of WHILE or
+UNTIL -- the epilogue code (if any) will be run, and any implicitly
+collected result will be returned as the value of the LOOP."
+ '(go end-loop))
+
+
+\f
+(defun subst-gensyms-for-nil (tree)
+ (declare (special *ignores*))
+ (cond
+ ((null tree) (car (push (loop-gentemp) *ignores*)))
+ ((atom tree) tree)
+ (t (cons (subst-gensyms-for-nil (car tree))
+ (subst-gensyms-for-nil (cdr tree))))))
+
+(defun loop-build-destructuring-bindings (crocks forms)
+ (if crocks
+ (let ((*ignores* ()))
+ (declare (special *ignores*))
+ `((destructuring-bind ,(subst-gensyms-for-nil (car crocks))
+ ,(cadr crocks)
+ (declare (ignore ,@*ignores*))
+ ,@(loop-build-destructuring-bindings (cddr crocks) forms))))
+ forms))
+
+(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*)
+ (let ((*loop-original-source-code* *loop-source-code*)
+ (*loop-source-context* nil)
+ (*loop-iteration-variables* nil)
+ (*loop-variables* nil)
+ (*loop-nodeclare* nil)
+ (*loop-named-variables* nil)
+ (*loop-declarations* nil)
+ (*loop-desetq-crocks* nil)
+ (*loop-bind-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-final-value-culprit* nil)
+ (*loop-inside-conditional* nil)
+ (*loop-when-it-variable* nil)
+ (*loop-never-stepped-variable* nil)
+ (*loop-names* nil)
+ (*loop-collection-cruft* nil))
+ (loop-iteration-driver)
+ (loop-bind-block)
+ (let ((answer `(loop-body
+ ,(nreverse *loop-prologue*)
+ ,(nreverse *loop-before-loop*)
+ ,(nreverse *loop-body*)
+ ,(nreverse *loop-after-body*)
+ ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
+ (dolist (entry *loop-bind-stack*)
+ (let ((vars (first entry))
+ (dcls (second entry))
+ (crocks (third entry))
+ (wrappers (fourth entry)))
+ (dolist (w wrappers)
+ (setq answer (append w (list answer))))
+ (when (or vars dcls crocks)
+ (let ((forms (list answer)))
+ ;;(when crocks (push crocks forms))
+ (when dcls (push `(declare ,@dcls) forms))
+ (setq answer `(,(cond ((not vars) 'locally)
+ (*loop-destructuring-hooks* (first *loop-destructuring-hooks*))
+ (t 'let))
+ ,vars
+ ,@(loop-build-destructuring-bindings crocks forms)))))))
+ (if *loop-names*
+ (do () ((null (car *loop-names*)) answer)
+ (setq answer `(block ,(pop *loop-names*) ,answer)))
+ `(block nil ,answer)))))
+
+
+(defun loop-iteration-driver ()
+ (do () ((null *loop-source-code*))
+ (let ((keyword (car *loop-source-code*)) (tem nil))
+ (cond ((not (symbolp keyword))
+ (loop-error "~S found where LOOP keyword expected." keyword))
+ (t (setq *loop-source-context* *loop-source-code*)
+ (loop-pop-source)
+ (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*)))
+ ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.)
+ (apply (symbol-function (first tem)) (rest tem)))
+ ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*)))
+ (loop-hack-iteration tem))
+ ((loop-tmember keyword '(and else))
+ ;; Alternative is to ignore it, ie let it go around to the next keyword...
+ (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
+ keyword (car *loop-source-code*) (cadr *loop-source-code*)))
+ (t (loop-error "~S is an unknown keyword in LOOP macro." keyword))))))))
+\f
+
+
+(defun loop-pop-source ()
+ (if *loop-source-code*
+ (pop *loop-source-code*)
+ (loop-error "LOOP source code ran out when another token was expected.")))
+
+
+(defun loop-get-compound-form ()
+ (let ((form (loop-get-form)))
+ (unless (consp form)
+ (loop-error "Compound form expected, but found ~A." form))
+ form))
+
+(defun loop-get-progn ()
+ (do ((forms (list (loop-get-compound-form))
+ (cons (loop-get-compound-form) forms))
+ (nextform (car *loop-source-code*)
+ (car *loop-source-code*)))
+ ((atom nextform)
+ (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
+
+
+(defun loop-get-form ()
+ (if *loop-source-code*
+ (loop-pop-source)
+ (loop-error "LOOP code ran out where a form was expected.")))
+
+
+(defun loop-construct-return (form)
+ `(return-from ,(car *loop-names*) ,form))
+
+
+(defun loop-pseudo-body (form)
+ (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*))
+ (t (push form *loop-before-loop*) (push form *loop-after-body*))))
+
+(defun loop-emit-body (form)
+ (setq *loop-emitted-body* t)
+ (loop-pseudo-body form))
+
+(defun loop-emit-final-value (&optional (form nil form-supplied-p))
+ (when form-supplied-p
+ (push (loop-construct-return form) *loop-after-epilogue*))
+ (when *loop-final-value-culprit*
+ (loop-warn "LOOP clause is providing a value for the iteration,~@
+ however one was already established by a ~S clause."
+ *loop-final-value-culprit*))
+ (setq *loop-final-value-culprit* (car *loop-source-context*)))
+
+
+(defun loop-disallow-conditional (&optional kwd)
+ #+(or Genera CLOE) (declare (dbg:error-reporter))
+ (when *loop-inside-conditional*
+ (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
+
+(defun loop-disallow-anonymous-collectors ()
+ (when (find-if-not 'loop-collector-name *loop-collection-cruft*)
+ (loop-error "This LOOP clause is not permitted with anonymous collectors.")))
+
+(defun loop-disallow-aggregate-booleans ()
+ (when (loop-tmember *loop-final-value-culprit* '(always never thereis))
+ (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans.")))
+
+\f
+
+;;;; Loop Types
+
+
+(defun loop-typed-init (data-type)
+ (when (and data-type (subtypep data-type 'number))
+ (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
+ (coerce 0 data-type)
+ 0)))
+
+
+(defun loop-optional-type (&optional variable)
+ ;;No variable specified implies that no destructuring is permissible.
+ (and *loop-source-code* ;Don't get confused by NILs...
+ (let ((z (car *loop-source-code*)))
+ (cond ((loop-tequal z 'of-type)
+ ;;This is the syntactically unambigous form in that the form of the
+ ;; type specifier does not matter. Also, it is assumed that the
+ ;; type specifier is unambiguously, and without need of translation,
+ ;; a common lisp type specifier or pattern (matching the variable) thereof.
+ (loop-pop-source)
+ (loop-pop-source))
+
+ ((symbolp z)
+ ;;This is the (sort of) "old" syntax, even though we didn't used to support all of
+ ;; these type symbols.
+ (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*))
+ (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*)))))
+ (when type-spec
+ (loop-pop-source)
+ type-spec)))
+ (t
+ ;;This is our sort-of old syntax. But this is only valid for when we are destructuring,
+ ;; so we will be compulsive (should we really be?) and require that we in fact be
+ ;; doing variable destructuring here. We must translate the old keyword pattern typespec
+ ;; into a fully-specified pattern of real type specifiers here.
+ (if (consp variable)
+ (unless (consp z)
+ (loop-error
+ "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected."
+ z))
+ (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z))
+ (loop-pop-source)
+ (labels ((translate (k v)
+ (cond ((null k) nil)
+ ((atom k)
+ (replicate
+ (or (gethash k (loop-universe-type-symbols *loop-universe*))
+ (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*))
+ (loop-error
+ "Destructuring type pattern ~S contains unrecognized type keyword ~S."
+ z k))
+ v))
+ ((atom v)
+ (loop-error
+ "Destructuring type pattern ~S doesn't match variable pattern ~S."
+ z variable))
+ (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v))))))
+ (replicate (typ v)
+ (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v))))))
+ (translate z variable)))))))
+\f
+
+
+;;;; Loop Variables
+
+
+(defun loop-bind-block ()
+ (when (or *loop-variables* *loop-declarations* *loop-wrappers*)
+ (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*)
+ *loop-bind-stack*)
+ (setq *loop-variables* nil
+ *loop-declarations* nil
+ *loop-desetq-crocks* nil
+ *loop-wrappers* nil)))
+
+(defun loop-variable-p (name)
+ (do ((entry *loop-bind-stack* (cdr entry))) (nil)
+ (cond ((null entry)
+ (return nil))
+ ((assoc name (caar entry) :test #'eq)
+ (return t)))))
+
+(defun loop-make-variable (name initialization dtype &optional iteration-variable-p)
+ (cond ((null name)
+ (cond ((not (null initialization))
+ (push (list (setq name (loop-gentemp 'loop-ignore-))
+ initialization)
+ *loop-variables*)
+ (push `(ignore ,name) *loop-declarations*))))
+ ((atom name)
+ (cond (iteration-variable-p
+ (if (member name *loop-iteration-variables*)
+ (loop-error "Duplicated LOOP iteration variable ~S." name)
+ (push name *loop-iteration-variables*)))
+ ((assoc name *loop-variables*)
+ (loop-error "Duplicated variable ~S in LOOP parallel binding." name)))
+ (unless (symbolp name)
+ (loop-error "Bad variable ~S somewhere in LOOP." name))
+ (loop-declare-variable name dtype)
+ ;; We use ASSOC 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
+ (cond (*loop-destructuring-hooks*
+ (loop-declare-variable name dtype)
+ (push (list name initialization) *loop-variables*))
+ (t (let ((newvar (loop-gentemp 'loop-destructure-)))
+ (loop-declare-variable name dtype)
+ (push (list newvar initialization) *loop-variables*)
+ ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
+ (setq *loop-desetq-crocks*
+ (list* name newvar *loop-desetq-crocks*))
+ #+ignore
+ (loop-make-variable name nil dtype iteration-variable-p)))))
+ (t (let ((tcar nil) (tcdr nil))
+ (if (atom dtype) (setq tcar (setq tcdr dtype))
+ (setq tcar (car dtype) tcdr (cdr dtype)))
+ (loop-make-variable (car name) nil tcar iteration-variable-p)
+ (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
+ name)
+
+
+(defun loop-make-iteration-variable (name initialization dtype)
+ (when (and name (loop-variable-p name))
+ (loop-error "Variable ~S has already been used" name))
+ (loop-make-variable name initialization dtype t))
+
+
+(defun loop-declare-variable (name dtype)
+ (cond ((or (null name) (null dtype) (eq dtype t)) nil)
+ ((symbolp name)
+ (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
+ (let ((dtype (let ((init (loop-typed-init dtype)))
+ (if (typep init dtype)
+ dtype
+ `(or (member ,init) ,dtype)))))
+ (push `(type ,dtype ,name) *loop-declarations*))))
+ ((consp name)
+ (cond ((consp 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 (error "Invalid LOOP variable passed in: ~S." name))))
+
+
+(defun loop-maybe-bind-form (form data-type)
+ (if (loop-constantp form)
+ form
+ (loop-make-variable (loop-gentemp 'loop-bind-) form data-type)))
+\f
+
+
+(defun loop-do-if (for negatep)
+ (let ((form (loop-get-form))
+ (it-p nil)
+ (first-clause-p t) then else)
+ (let ((*loop-inside-conditional* t))
+ (flet ((get-clause (for)
+ (do ((body nil)) (nil)
+ (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
+ (cond ((not (symbolp key))
+ (loop-error
+ "~S found where keyword expected getting LOOP clause after ~S."
+ key for))
+ (t (setq *loop-source-context* *loop-source-code*)
+ (loop-pop-source)
+ (when (and (loop-tequal (car *loop-source-code*) 'it)
+ first-clause-p)
+ (setq *loop-source-code*
+ (cons (or it-p (setq it-p (loop-when-it-variable)))
+ (cdr *loop-source-code*))))
+ (cond ((or (not (setq data (loop-lookup-keyword
+ key (loop-universe-keywords *loop-universe*))))
+ (progn (apply (symbol-function (car data)) (cdr data))
+ (null *loop-body*)))
+ (loop-error
+ "~S does not introduce a LOOP clause that can follow ~S."
+ key for))
+ (t (setq body (nreconc *loop-body* body)))))))
+ (setq first-clause-p nil)
+ (if (loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
+ (setq then (get-clause for))
+ (setq else (when (loop-tequal (car *loop-source-code*) :else)
+ (loop-pop-source)
+ (list (get-clause :else)))))
+ (when (loop-tequal (car *loop-source-code*) :end)
+ (loop-pop-source))
+ (when it-p
+ (setq form `(setq ,it-p ,form))))
+ (loop-pseudo-body
+ `(if ,(if negatep `(not ,form) form)
+ ,then
+ ,@else))))
+
+
+(defun loop-do-initially ()
+ (loop-disallow-conditional :initially)
+ (push (loop-get-progn) *loop-prologue*))
+
+(defun loop-do-finally ()
+ (loop-disallow-conditional :finally)
+ (push (loop-get-progn) *loop-epilogue*))
+
+(defun loop-do-do ()
+ (loop-emit-body (loop-get-progn)))
+
+(defun loop-do-named ()
+ (let ((name (loop-pop-source)))
+ (unless (symbolp name)
+ (loop-error "~S is an invalid name for your LOOP." name))
+ (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*)
+ (loop-error "The NAMED ~S clause occurs too late." name))
+ (when *loop-names*
+ (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
+ (car *loop-names*) name))
+ (setq *loop-names* (list name nil))))
+
+(defun loop-do-return ()
+ (loop-pseudo-body (loop-construct-return (loop-get-form))))
+\f
+
+;;;; Value Accumulation: List
+
+
+(defstruct (loop-collector
+ (:copier nil)
+ (:predicate nil))
+ name
+ class
+ (history nil)
+ (tempvars nil)
+ dtype
+ (data nil)) ;collector-specific data
+
+
+(defun loop-get-collection-info (collector class default-type)
+ (let ((form (loop-get-form))
+ (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
+ (name (when (loop-tequal (car *loop-source-code*) 'into)
+ (loop-pop-source)
+ (loop-pop-source))))
+ (when (not (symbolp name))
+ (loop-error "Value accumulation recipient name, ~S, is not a symbol." name))
+ (unless name
+ (loop-disallow-aggregate-booleans))
+ (unless dtype
+ (setq dtype (or (loop-optional-type) default-type)))
+ (let ((cruft (find (the symbol name) *loop-collection-cruft*
+ :key #'loop-collector-name)))
+ (cond ((not cruft)
+ (when (and name (loop-variable-p name))
+ (loop-error "Variable ~S cannot be used in INTO clause" name))
+ (push (setq cruft (make-loop-collector
+ :name name :class class
+ :history (list collector) :dtype dtype))
+ *loop-collection-cruft*))
+ (t (unless (eq (loop-collector-class cruft) class)
+ (loop-error
+ "Incompatible kinds of LOOP value accumulation specified for collecting~@
+ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S."
+ name (car (loop-collector-history cruft)) collector))
+ (unless (equal dtype (loop-collector-dtype cruft))
+ (loop-warn
+ "Unequal datatypes specified in different LOOP value accumulations~@
+ into ~S: ~S and ~S."
+ name dtype (loop-collector-dtype cruft))
+ (when (eq (loop-collector-dtype cruft) t)
+ (setf (loop-collector-dtype cruft) dtype)))
+ (push collector (loop-collector-history cruft))))
+ (values cruft form))))
+
+
+(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND
+ (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list)
+ (let ((tempvars (loop-collector-tempvars lc)))
+ (unless tempvars
+ (setf (loop-collector-tempvars lc)
+ (setq tempvars (list* (loop-gentemp 'loop-list-head-)
+ (loop-gentemp 'loop-list-tail-)
+ (and (loop-collector-name lc)
+ (list (loop-collector-name lc))))))
+ (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars)))))
+ (ecase specifically
+ (list (setq form `(list ,form)))
+ (nconc nil)
+ (append (unless (and (consp form) (eq (car form) 'list))
+ (setq form `(loop-copylist* ,form)))))
+ (loop-emit-body `(loop-collect-rplacd ,tempvars ,form)))))
+\f
+
+;;;; Value Accumulation: max, min, sum, count.
+
+
+
+(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT
+ (multiple-value-bind (lc form)
+ (loop-get-collection-info specifically 'sum default-type)
+ (loop-check-data-type (loop-collector-dtype lc) required-type)
+ (let ((tempvars (loop-collector-tempvars lc)))
+ (unless tempvars
+ (setf (loop-collector-tempvars lc)
+ (setq tempvars (list (loop-make-variable
+ (or (loop-collector-name lc)
+ (loop-gentemp 'loop-sum-))
+ nil (loop-collector-dtype lc)))))
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value (car (loop-collector-tempvars lc)))))
+ (loop-emit-body
+ (if (eq specifically 'count)
+ `(when ,form
+ (setq ,(car tempvars)
+ ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars)))))
+ `(setq ,(car tempvars)
+ (+ ,(hide-variable-reference t (car tempvars) (car tempvars))
+ ,form)))))))
+
+
+
+(defun loop-maxmin-collection (specifically)
+ (multiple-value-bind (lc form)
+ (loop-get-collection-info specifically 'maxmin *loop-real-data-type*)
+ (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
+ (let ((data (loop-collector-data lc)))
+ (unless data
+ (setf (loop-collector-data lc)
+ (setq data (make-loop-minimax
+ (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
+ (loop-collector-dtype lc))))
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value (loop-minimax-answer-variable data))))
+ (loop-note-minimax-operation specifically data)
+ (push `(with-minimax-value ,data) *loop-wrappers*)
+ (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form))
+ )))
+\f
+
+;;;; Value Accumulation: Aggregate Booleans
+
+;;;ALWAYS and NEVER.
+;;; Under ANSI these are not permitted to appear under conditionalization.
+(defun loop-do-always (restrictive negate)
+ (let ((form (loop-get-form)))
+ (when restrictive (loop-disallow-conditional))
+ (loop-disallow-anonymous-collectors)
+ (loop-emit-body `(,(if negate 'when 'unless) ,form
+ ,(loop-construct-return nil)))
+ (loop-emit-final-value t)))
+
+
+
+;;;THERIS.
+;;; Under ANSI this is not permitted to appear under conditionalization.
+(defun loop-do-thereis (restrictive)
+ (when restrictive (loop-disallow-conditional))
+ (loop-disallow-anonymous-collectors)
+ (loop-emit-final-value)
+ (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
+ ,(loop-construct-return *loop-when-it-variable*))))
+\f
+
+(defun loop-do-while (negate kwd &aux (form (loop-get-form)))
+ (loop-disallow-conditional kwd)
+ (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
+
+
+(defun loop-do-with ()
+ (loop-disallow-conditional :with)
+ (do ((var) (val) (dtype)) (nil)
+ (setq var (loop-pop-source)
+ dtype (loop-optional-type var)
+ val (cond ((loop-tequal (car *loop-source-code*) :=)
+ (loop-pop-source)
+ (loop-get-form))
+ (t nil)))
+ (when (and var (loop-variable-p var))
+ (loop-error "Variable ~S has already been used" var))
+ (loop-make-variable var val dtype)
+ (if (loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (return (loop-bind-block)))))
+\f
+
+;;;; The iteration driver
+
+(defun loop-hack-iteration (entry)
+ (flet ((make-endtest (list-of-forms)
+ (cond ((null list-of-forms) nil)
+ ((member t list-of-forms) '(go end-loop))
+ (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
+ (car list-of-forms)
+ (cons 'or list-of-forms))
+ (go end-loop))))))
+ (do ((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))
+ (nil)
+ ;; Note we collect endtests in reverse order, but steps in correct
+ ;; order. MAKE-ENDTEST does the nreverse for us.
+ (setq tem (setq data (apply (symbol-function (first entry)) (rest 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))
+ (when *loop-emitted-body*
+ (loop-error "Iteration in LOOP follows body code."))
+ (unless tem (setq tem data))
+ (when (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))))))
+ (when (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))))
+ (unless (loop-tequal (car *loop-source-code*) :and)
+ (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps)
+ (make-endtest pre-loop-post-step-tests)
+ (loop-make-psetq pre-loop-steps)
+ (make-endtest pre-loop-pre-step-tests)
+ *loop-before-loop*)
+ *loop-after-body* (list* (loop-make-desetq pseudo-steps)
+ (make-endtest post-step-tests)
+ (loop-make-psetq steps)
+ (make-endtest pre-step-tests)
+ *loop-after-body*))
+ (loop-bind-block)
+ (return nil))
+ (loop-pop-source) ; flush the "AND"
+ (when (and (not (loop-universe-implicit-for-required *loop-universe*))
+ (setq tem (loop-lookup-keyword
+ (car *loop-source-code*)
+ (loop-universe-iteration-keywords *loop-universe*))))
+ ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied.
+ (loop-pop-source)
+ (setq entry tem)))))
+\f
+
+;;;; Main Iteration Drivers
+
+
+;FOR variable keyword ..args..
+(defun loop-do-for ()
+ (let* ((var (or (loop-pop-source) (loop-gentemp 'loop-do-for-anon-)))
+ (data-type (loop-optional-type var))
+ (keyword (loop-pop-source))
+ (first-arg nil)
+ (tem nil))
+ (setq first-arg (loop-get-form))
+ (unless (and (symbolp keyword)
+ (setq tem (loop-lookup-keyword
+ keyword
+ (loop-universe-for-keywords *loop-universe*))))
+ (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword))
+ (apply (car tem) var first-arg data-type (cdr tem))))
+
+(defun loop-do-repeat ()
+ (loop-disallow-conditional :repeat)
+ (let ((form (loop-get-form))
+ (type 'real))
+ (let ((var (loop-make-variable (loop-gentemp) form type)))
+ (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*)
+ (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*)
+ ;; FIXME: What should
+ ;; (loop count t into a
+ ;; repeat 3
+ ;; count t into b
+ ;; finally (return (list a b)))
+ ;; return: (3 3) or (4 3)? PUSHes above are for the former
+ ;; variant, L-P-B below for the latter.
+ #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop))))))
+
+(defun loop-when-it-variable ()
+ (or *loop-when-it-variable*
+ (setq *loop-when-it-variable*
+ (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
+\f
+
+;;;; Various FOR/AS Subdispatches
+
+
+;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
+;;; is omitted (other than being more stringent in its placement), and like
+;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first
+;;; initialization occurs in the loop body (first-step), not in the variable binding
+;;; phase.
+(defun loop-ansi-for-equals (var val data-type)
+ (loop-make-iteration-variable var nil data-type)
+ (cond ((loop-tequal (car *loop-source-code*) :then)
+ ;;Then we are the same as "FOR x FIRST y THEN z".
+ (loop-pop-source)
+ `(() (,var ,(loop-get-form)) () ()
+ () (,var ,val) () ()))
+ (t ;;We are the same as "FOR x = y".
+ ;; Let me document here what this is returning. Look at
+ ;; loop-hack-iteration for more info. But anyway, we return a list of
+ ;; 8 items, in this order: PRE-STEP-TESTS, STEPS, POST-STEP-TESTS,
+ ;; PSEUDO-STEPS, PRE-LOOP-PRE-STEP-TESTS, PRE-LOOP-STEPS,
+ ;; PRE-LOOP-POST-STEP-TESTS, PRE-LOOP-PSEUDO-STEPS. (We should add
+ ;; something to make it easier to figure out what these args are!)
+ ;;
+ ;; For a "FOR x = y" clause without the THEN, we want the STEPS item to
+ ;; step the variable VAR with the value VAL. This gets placed in the
+ ;; body of the loop. The original code just did that. It seems that
+ ;; the STEPS form is placed in *loop-before-loop* and in
+ ;; *loop-after-loop*. Loop optimization would then see the same form
+ ;; in both, and move them into the beginning of body. This is ok,
+ ;; except that if there are :initially forms that were placed into the
+ ;; loop prologue, the :initially forms might refer to incorrectly
+ ;; initialized variables, because the optimizer moved STEPS from from
+ ;; *loop-before-loop* into the body.
+ ;;
+ ;; To solve this, we add a PRE-LOOP-PSEUDO-STEP form that is identical
+ ;; to the STEPS form. This gets placed in *loop-before-loop*. But
+ ;; this won't match any *loop-after-loop* form, so it won't get moved,
+ ;; and we maintain the proper sequencing such that the
+ ;; PRE-LOOP-PSEUDO-STEP form is in *loop-before-loop*, before any
+ ;; :initially clauses that might refer to this. So all is well. Whew.
+ ;;
+ ;; I hope this doesn't break anything else.
+ `(() (,var ,val) () ()
+ () () () (,var ,val))
+ )))
+
+
+(defun loop-for-across (var val data-type)
+ (loop-make-iteration-variable var nil data-type)
+ (let ((vector-var (loop-gentemp 'loop-across-vector-))
+ (index-var (loop-gentemp 'loop-across-index-)))
+ (multiple-value-bind (vector-form constantp vector-value)
+ (loop-constant-fold-if-possible val 'vector)
+ (loop-make-variable
+ vector-var vector-form
+ (if (and (consp vector-form) (eq (car vector-form) 'the))
+ (cadr vector-form)
+ 'vector))
+ #+Genera (push `(system:array-register ,vector-var) *loop-declarations*)
+ (loop-make-variable index-var 0 'fixnum)
+ (let* ((length 0)
+ (length-form (cond ((not constantp)
+ (let ((v (loop-gentemp 'loop-across-limit-)))
+ ;; This used to just push the length
+ ;; computation into the prologue code. I
+ ;; (rtoy) don't think that's right,
+ ;; especially since the prologue is supposed
+ ;; to happen AFTER other initializations.
+ ;; So, this puts the computation in
+ ;; *loop-before-body*. We need a matching
+ ;; entry for *loop-after-body*, so stuff a
+ ;; NIL there.
+ (push `(setq ,v (length ,vector-var)) *loop-before-loop*)
+ (push nil *loop-after-body*)
+ (loop-make-variable v 0 'fixnum)))
+ (t (setq length (length vector-value)))))
+ (first-test `(>= ,index-var ,length-form))
+ (other-test first-test)
+ (step `(,var (aref ,vector-var ,index-var)))
+ (pstep `(,index-var (1+ ,index-var))))
+ (declare (fixnum length))
+ (when constantp
+ (setq first-test (= length 0))
+ (when (<= length 1)
+ (setq other-test t)))
+ `(,other-test ,step () ,pstep
+ ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep)))))))
+\f
+
+
+;;;; List Iteration
+
+
+(defun loop-list-step (listvar)
+ ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any
+ ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used
+ ;; as the stepping function.
+ ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not
+ ;; recognizing FOO may defeat some LOOP optimizations.
+ (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by)
+ (loop-pop-source)
+ (loop-get-form))
+ (t '(function cdr)))))
+ (cond ((and (consp stepper) (eq (car stepper) 'quote))
+ (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
+ (values `(funcall ,stepper ,listvar) nil))
+ ((and (consp stepper) (eq (car stepper) 'function))
+ (values (list (cadr stepper) listvar) (cadr stepper)))
+ (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function)
+ ,listvar)
+ nil)))))
+
+
+(defun loop-for-on (var val data-type)
+ (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
+ (let ((listvar var))
+ (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type))
+ (t (loop-make-variable (setq listvar (loop-gentemp)) list 't)
+ (loop-make-iteration-variable var nil data-type)))
+ (multiple-value-bind (list-step step-function) (loop-list-step listvar)
+ (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))
+ ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
+ (let* ((first-endtest
+ (hide-variable-reference
+ (eq var listvar)
+ listvar
+ ;; the following should use `atom' instead of `endp', per
+ ;; [bug2428]
+ `(atom ,listvar)))
+ (other-endtest first-endtest))
+ (when (and constantp (listp list-value))
+ (setq first-endtest (null list-value)))
+ (cond ((eq var listvar)
+ ;;Contour of the loop is different because we use the user's variable...
+ `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest
+ () () () ,first-endtest ()))
+ #+LOOP-Prefer-POP
+ ((and step-function
+ (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2)
+ (cdddr . 3) (cddddr . 4))))))
+ (and n (do ((l var (cdr l)) (i 0 (1+ i)))
+ ((atom l) (and (null l) (= i n)))
+ (declare (fixnum i))))))
+ (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var)))
+ `(,other-endtest () () ,step ,first-endtest () () ,step)))
+ (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
+ `(,other-endtest ,step () ,pseudo
+ ,@(and (not (eq first-endtest other-endtest))
+ `(,first-endtest ,step () ,pseudo)))))))))))
+
+
+(defun loop-for-in (var val data-type)
+ (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
+ (let ((listvar (loop-gentemp 'loop-list-)))
+ (loop-make-iteration-variable var nil data-type)
+ (loop-make-variable listvar list 'list)
+ (multiple-value-bind (list-step step-function) (loop-list-step listvar)
+ #-LOOP-Prefer-POP (declare (ignore step-function))
+ (let* ((first-endtest `(endp ,listvar))
+ (other-endtest first-endtest)
+ (step `(,var (car ,listvar)))
+ (pseudo-step `(,listvar ,list-step)))
+ (when (and constantp (listp list-value))
+ (setq first-endtest (null list-value)))
+ #+LOOP-Prefer-POP (when (eq step-function 'cdr)
+ (setq step `(,var (pop ,listvar)) pseudo-step nil))
+ `(,other-endtest ,step () ,pseudo-step
+ ,@(and (not (eq first-endtest other-endtest))
+ `(,first-endtest ,step () ,pseudo-step))))))))
+\f
+
+;;;; Iteration Paths
+
+
+(defstruct (loop-path
+ (:copier nil)
+ (:predicate nil))
+ names
+ preposition-groups
+ inclusive-permitted
+ function
+ user-data)
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data)
+ (unless (listp names) (setq names (list names)))
+ ;; Can't do this due to CLOS bootstrapping problems.
+ #-(or Genera (and CLOE Source-Bootstrap)) (check-type universe loop-universe)
+ (let ((ht (loop-universe-path-keywords universe))
+ (lp (make-loop-path
+ :names (mapcar #'symbol-name names)
+ :function function
+ :user-data user-data
+ :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups)
+ :inclusive-permitted inclusive-permitted)))
+ (dolist (name names) (setf (gethash (symbol-name name) ht) lp))
+ lp)))
+\f
+
+;;; 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 each/the pathname prep-phrases using-stuff...
+ ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn.
+ (let ((path nil)
+ (data nil)
+ (inclusive nil)
+ (stuff nil)
+ (initial-prepositions nil))
+ (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source)))
+ ((loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (setq inclusive t)
+ (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her))
+ (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax."
+ (car *loop-source-code*)))
+ (loop-pop-source)
+ (setq path (loop-pop-source))
+ (setq initial-prepositions `((:in ,val))))
+ (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?")))
+ (cond ((not (symbolp path))
+ (loop-error "~S found where a LOOP iteration path name was expected." path))
+ ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
+ (loop-error "~S is not the name of a LOOP iteration path." path))
+ ((and inclusive (not (loop-path-inclusive-permitted data)))
+ (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path)))
+ (let ((fun (loop-path-function data))
+ (preps (nconc initial-prepositions
+ (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t)))
+ (user-data (loop-path-user-data data)))
+ (when (symbolp fun) (setq fun (symbol-function fun)))
+ (setq stuff (if inclusive
+ (apply fun var data-type preps :inclusive t user-data)
+ (apply fun var data-type preps user-data))))
+ (when *loop-named-variables*
+ (loop-error "Unused USING variables: ~S." *loop-named-variables*))
+ ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user
+ ;; and the user from himself.
+ (unless (member (length stuff) '(6 10))
+ (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
+ path))
+ (do ((l (car stuff) (cdr l)) (x)) ((null l))
+ (if (atom (setq x (car l)))
+ (loop-make-iteration-variable x nil nil)
+ (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
+ (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
+ (cddr stuff)))
+\f
+
+
+;;;INTERFACE: Lucid, exported.
+;;; i.e., this is part of our extended ansi-loop interface.
+(defun named-variable (name)
+ (let ((tem (loop-tassoc name *loop-named-variables*)))
+ (declare (list tem))
+ (cond ((null tem) (values (loop-gentemp) nil))
+ (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
+ (values (cdr tem) t)))))
+
+
+(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases)
+ (flet ((in-group-p (x group) (car (loop-tmember x group))))
+ (do ((token nil)
+ (prepositional-phrases initial-phrases)
+ (this-group nil nil)
+ (this-prep nil nil)
+ (disallowed-prepositions
+ (mapcan #'(lambda (x)
+ (loop-copylist*
+ (find (car x) preposition-groups :test #'in-group-p)))
+ initial-phrases))
+ (used-prepositions (mapcar #'car initial-phrases)))
+ ((null *loop-source-code*) (nreverse prepositional-phrases))
+ (declare (symbol this-prep))
+ (setq token (car *loop-source-code*))
+ (dolist (group preposition-groups)
+ (when (setq this-prep (in-group-p token group))
+ (return (setq this-group group))))
+ (cond (this-group
+ (when (member this-prep disallowed-prepositions)
+ (loop-error
+ (if (member this-prep used-prepositions)
+ "A ~S prepositional phrase occurs multiply for some LOOP clause."
+ "Preposition ~S used when some other preposition has subsumed it.")
+ token))
+ (setq used-prepositions (if (listp this-group)
+ (append this-group used-prepositions)
+ (cons this-group used-prepositions)))
+ (loop-pop-source)
+ (push (list this-prep (loop-get-form)) prepositional-phrases))
+ ((and USING-allowed (loop-tequal token 'using))
+ (loop-pop-source)
+ (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
+ (when (cadr z)
+ (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
+ (loop-error
+ "The variable substitution for ~S occurs twice in a USING phrase,~@
+ with ~S and ~S."
+ (car z) (cadr z) (cadr tem))
+ (push (cons (car z) (cadr z)) *loop-named-variables*)))
+ (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*)))
+ (return nil))))
+ (t (return (nreverse prepositional-phrases)))))))
+\f
+
+;;;; Master Sequencer Function
+
+
+(defun loop-sequencer (indexv indexv-type indexv-user-specified-p
+ variable variable-type
+ sequence-variable sequence-type
+ step-hack default-top
+ prep-phrases)
+ (let ((endform nil) ;Form (constant or variable) with limit value.
+ (sequencep nil) ;T if sequence arg has been provided.
+ (testfn nil) ;endtest function
+ (test nil) ;endtest form.
+ (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment.
+ (stepby-constantp t)
+ (step nil) ;step form.
+ (dir nil) ;Direction of stepping: NIL, :UP, :DOWN.
+ (inclusive-iteration nil) ;T if include last index.
+ (start-given nil) ;T when prep phrase has specified start
+ (start-value nil)
+ (start-constantp nil)
+ (limit-given nil) ;T when prep phrase has specified end
+ (limit-constantp nil)
+ (limit-value nil)
+ )
+ (when variable (loop-make-iteration-variable variable nil variable-type))
+ (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
+ (setq prep (caar l) form (cadar l))
+ (case prep
+ ((:of :in)
+ (setq sequencep t)
+ (loop-make-variable sequence-variable form sequence-type))
+ ((:from :downfrom :upfrom)
+ (setq start-given t)
+ (cond ((eq prep :downfrom) (setq dir ':down))
+ ((eq prep :upfrom) (setq dir ':up)))
+ (multiple-value-setq (form start-constantp start-value)
+ (loop-constant-fold-if-possible form indexv-type))
+ (loop-make-iteration-variable indexv form indexv-type))
+ ((:upto :to :downto :above :below)
+ (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)))
+ (setq limit-given t)
+ (multiple-value-setq (form limit-constantp limit-value)
+ (loop-constant-fold-if-possible form indexv-type))
+ (setq endform (if limit-constantp
+ `',limit-value
+ (loop-make-variable
+ (loop-gentemp 'loop-limit-) form indexv-type))))
+ (:by
+ (multiple-value-setq (form stepby-constantp stepby)
+ (loop-constant-fold-if-possible form indexv-type))
+ (unless stepby-constantp
+ (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type)))
+ (t (loop-error
+ "~S invalid preposition in sequencing or sequence path.~@
+ Invalid prepositions specified in iteration path descriptor or something?"
+ prep)))
+ (when (and odir dir (not (eq dir odir)))
+ (loop-error "Conflicting stepping directions in LOOP sequencing path"))
+ (setq odir dir))
+ (when (and sequence-variable (not sequencep))
+ (loop-error "Missing OF or IN phrase in sequence path"))
+ ;; Now fill in the defaults.
+ (unless start-given
+ (loop-make-iteration-variable
+ indexv
+ (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0))
+ indexv-type))
+ (cond ((member dir '(nil :up))
+ (when (or limit-given default-top)
+ (unless limit-given
+ (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-))
+ nil indexv-type)
+ (push `(setq ,endform ,default-top) *loop-prologue*))
+ (setq testfn (if inclusive-iteration '> '>=)))
+ (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
+ (t (unless start-given
+ (unless default-top
+ (loop-error "Don't know where to start stepping."))
+ (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
+ (when (and default-top (not endform))
+ (setq endform (loop-typed-init indexv-type) inclusive-iteration t))
+ (when endform (setq testfn (if inclusive-iteration '< '<=)))
+ (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
+ (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
+ (when step-hack
+ (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack))))
+ (let ((first-test test) (remaining-tests test))
+ (when (and stepby-constantp start-constantp limit-constantp)
+ (when (setq first-test (funcall (symbol-function testfn) start-value limit-value))
+ (setq remaining-tests t)))
+ `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack
+ () () ,first-test ,step-hack))))
+\f
+
+;;;; Interfaces to the Master Sequencer
+
+
+
+(defun loop-for-arithmetic (var val data-type kwd)
+ (loop-sequencer
+ var (loop-check-data-type data-type 'number) t
+ nil nil nil nil nil nil
+ (loop-collect-prepositional-phrases
+ '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
+ nil (list (list kwd val)))))
+
+
+(defun loop-sequence-elements-path (variable data-type prep-phrases
+ &key fetch-function size-function sequence-type element-type)
+ (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
+ (let ((sequencev (named-variable 'sequence)))
+ #+Genera (when (and sequencev
+ (symbolp sequencev)
+ sequence-type
+ (subtypep sequence-type 'vector)
+ (not (member (the symbol sequencev) *loop-nodeclare*)))
+ (push `(sys:array-register ,sequencev) *loop-declarations*))
+ (list* nil nil ; dummy bindings and prologue
+ (loop-sequencer
+ indexv 'fixnum indexv-user-specified-p
+ variable (or data-type element-type)
+ sequencev sequence-type
+ `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev)
+ prep-phrases)))))
+\f
+
+;;;; Builtin LOOP Iteration Paths
+
+
+#||
+(loop for v being the hash-values of ht do (print v))
+(loop for k being the hash-keys of ht do (print k))
+(loop for v being the hash-values of ht using (hash-key k) do (print (list k v)))
+(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v)))
+||#
+
+(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which)
+ (check-type which (member hash-key hash-value))
+ (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
+ (loop-error "Too many prepositions!"))
+ ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path.")))
+ (let ((ht-var (loop-gentemp 'loop-hashtab-))
+ (next-fn (loop-gentemp 'loop-hashtab-next-))
+ (dummy-predicate-var nil)
+ (post-steps nil))
+ (multiple-value-bind (other-var other-p)
+ (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
+ ;;@@@@ named-variable returns a second value of T if the name was actually
+ ;; specified, so clever code can throw away the gensym'ed up variable if
+ ;; it isn't really needed.
+ ;;The following is for those implementations in which we cannot put dummy NILs
+ ;; into multiple-value-setq variable lists.
+ #-Genera (setq other-p t
+ dummy-predicate-var (loop-when-it-variable))
+ (let* ((key-var nil)
+ (val-var nil)
+ (temp-val-var (loop-gentemp 'loop-hash-val-temp-))
+ (temp-key-var (loop-gentemp 'loop-hash-key-temp-))
+ (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-))
+ (variable (or variable (loop-gentemp)))
+ (bindings `((,variable nil ,data-type)
+ (,ht-var ,(cadar prep-phrases))
+ ,@(and other-p other-var `((,other-var nil))))))
+ (if (eq which 'hash-key)
+ (setq key-var variable val-var (and other-p other-var))
+ (setq key-var (and other-p other-var) val-var variable))
+ (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
+ (when (consp key-var)
+ (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
+ ,@post-steps))
+ (push `(,key-var nil) bindings))
+ (when (consp val-var)
+ (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
+ ,@post-steps))
+ (push `(,val-var nil) bindings))
+ `(,bindings ;bindings
+ () ;prologue
+ () ;pre-test
+ () ;parallel steps
+ (not
+ (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var)
+ (,next-fn)
+ ;; We use M-V-BIND instead of M-V-SETQ because we only
+ ;; want to assign values to the key and val vars when we
+ ;; are in the hash table. When we reach the end,
+ ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and
+ ;; temp-val-var. This might break any type declarations
+ ;; on the key and val vars.
+ (when ,temp-predicate-var
+ (setq ,val-var ,temp-val-var)
+ (setq ,key-var ,temp-key-var))
+ (setq ,dummy-predicate-var ,temp-predicate-var)
+ )) ;post-test
+ ,post-steps)))))
+
+
+(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types)
+ (cond ((and prep-phrases (cdr prep-phrases))
+ (loop-error "Too many prepositions!"))
+ ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
+ (loop-error "Unknow preposition ~S" (caar prep-phrases))))
+ (unless (symbolp variable)
+ (loop-error "Destructuring is not valid for package symbol iteration."))
+ (let ((pkg-var (loop-gentemp 'loop-pkgsym-))
+ (next-fn (loop-gentemp 'loop-pkgsym-next-))
+ (variable (or variable (loop-gentemp)))
+ (pkg (or (cadar prep-phrases) '*package*)))
+ (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
+ `(((,variable nil ,data-type) (,pkg-var ,pkg))
+ ()
+ ()
+ ()
+ (not (multiple-value-setq (,(progn
+ ;;@@@@ If an implementation can get away without actually
+ ;; using a variable here, so much the better.
+ #+Genera NIL
+ #-Genera (loop-when-it-variable))
+ ,variable)
+ (,next-fn)))
+ ())))
+\f
+;;;; ANSI Loop
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (defun make-ansi-loop-universe (extended-p)
+ (let ((w (make-standard-loop-universe
+ :keywords `((named (loop-do-named))
+ (initially (loop-do-initially))
+ (finally (loop-do-finally))
+ (do (loop-do-do))
+ (doing (loop-do-do))
+ (return (loop-do-return))
+ (collect (loop-list-collection list))
+ (collecting (loop-list-collection list))
+ (append (loop-list-collection append))
+ (appending (loop-list-collection append))
+ (nconc (loop-list-collection nconc))
+ (nconcing (loop-list-collection nconc))
+ (count (loop-sum-collection count ,*loop-real-data-type* fixnum))
+ (counting (loop-sum-collection count ,*loop-real-data-type* fixnum))
+ (sum (loop-sum-collection sum number number))
+ (summing (loop-sum-collection sum number number))
+ (maximize (loop-maxmin-collection max))
+ (minimize (loop-maxmin-collection min))
+ (maximizing (loop-maxmin-collection max))
+ (minimizing (loop-maxmin-collection min))
+ (always (loop-do-always t nil)) ; Normal, do always
+ (never (loop-do-always t t)) ; Negate the test on always.
+ (thereis (loop-do-thereis t))
+ (while (loop-do-while nil :while)) ; Normal, do while
+ (until (loop-do-while t :until)) ; Negate the test on while
+ (when (loop-do-if when nil)) ; Normal, do when
+ (if (loop-do-if if nil)) ; synonymous
+ (unless (loop-do-if unless t)) ; Negate the test on when
+ (with (loop-do-with))
+ (repeat (loop-do-repeat)))
+ :for-keywords '((= (loop-ansi-for-equals))
+ (across (loop-for-across))
+ (in (loop-for-in))
+ (on (loop-for-on))
+ (from (loop-for-arithmetic :from))
+ (downfrom (loop-for-arithmetic :downfrom))
+ (upfrom (loop-for-arithmetic :upfrom))
+ (below (loop-for-arithmetic :below))
+ (above (loop-for-arithmetic :above))
+ (to (loop-for-arithmetic :to))
+ (upto (loop-for-arithmetic :upto))
+ (downto (loop-for-arithmetic :downto))
+ (by (loop-for-arithmetic :by))
+ (being (loop-for-being)))
+ :iteration-keywords '((for (loop-do-for))
+ (as (loop-do-for)))
+ :type-symbols '(array atom bignum bit bit-vector character compiled-function
+ complex cons double-float fixnum float
+ function hash-table integer keyword list long-float
+ nil null number package pathname random-state
+ ratio rational readtable sequence short-float
+ simple-array simple-bit-vector simple-string
+ simple-vector single-float standard-char
+ stream string base-char
+ symbol t vector)
+ :type-keywords nil
+ :ansi (if extended-p :extended t))))
+ (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:which hash-key))
+ (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:which hash-value))
+ (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:symbol-types (:internal :external :inherited)))
+ (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:symbol-types (:external)))
+ (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:symbol-types (:internal :external)))
+ w))
+
+
+ (defparameter *loop-ansi-universe*
+ (make-ansi-loop-universe nil))
+
+ (defun loop-standard-expansion (keywords-and-forms environment universe)
+ (if (and keywords-and-forms (symbolp (car keywords-and-forms)))
+ (loop-translate keywords-and-forms environment universe)
+ (let ((tag (gensym)))
+ `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
+
+ ) ;; eval-when
+
+
+;;;INTERFACE: ANSI
+(defmacro loop (&environment env &rest keywords-and-forms)
+ #+Genera (declare (compiler:do-not-record-macroexpansions)
+ (zwei:indentation . zwei:indent-loop))
+ (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
+
+#+allegro
+(defun excl::complex-loop-expander (body env)
+ (loop-standard-expansion body env *loop-ansi-universe*))
+
+;; Replace the CL::LOOP macro with this macro for use with CLSQL
+;; LOOP extensions
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (shadowing-import '(loop loop-finish) (find-package "COMMON-LISP"))
+ (setf (ext:package-lock (find-package "COMMON-LISP")) t))
+
projects / clsql.git / commitdiff