Changeset 5887


Ignore:
Timestamp:
02/21/04 16:00:22 (17 years ago)
Author:
piso
Message:

Use SBCL's LOOP.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/loop.lisp

    r5507 r5887  
    1 ;;;   -*- Mode: LISP; Package: ANSI-LOOP; Syntax: Common-lisp; Base: 10; Lowercase:T -*-
    2 ;;; $Id: loop.lisp,v 1.9 2004-01-20 00:13:51 piso Exp $
    3 ;;;>
    4 ;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology.
    5 ;;;> All Rights Reserved.
    6 ;;;>
    7 ;;;> Permission to use, copy, modify and distribute this software and its
    8 ;;;> documentation for any purpose and without fee is hereby granted,
    9 ;;;> provided that the M.I.T. copyright notice appear in all copies and that
    10 ;;;> both that copyright notice and this permission notice appear in
    11 ;;;> supporting documentation.  The names "M.I.T." and "Massachusetts
    12 ;;;> Institute of Technology" may not be used in advertising or publicity
    13 ;;;> pertaining to distribution of the software without specific, written
    14 ;;;> prior permission.  Notice must be given in supporting documentation that
    15 ;;;> copying distribution is by permission of M.I.T.  M.I.T. makes no
    16 ;;;> representations about the suitability of this software for any purpose.
    17 ;;;> It is provided "as is" without express or implied warranty.
    18 ;;;>
    19 ;;;>      Massachusetts Institute of Technology
    20 ;;;>      77 Massachusetts Avenue
    21 ;;;>      Cambridge, Massachusetts  02139
    22 ;;;>      United States of America
    23 ;;;>      +1-617-253-1000
    24 ;;;>
    25 ;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc.
    26 ;;;> All Rights Reserved.
    27 ;;;>
    28 ;;;> Permission to use, copy, modify and distribute this software and its
    29 ;;;> documentation for any purpose and without fee is hereby granted,
    30 ;;;> provided that the Symbolics copyright notice appear in all copies and
    31 ;;;> that both that copyright notice and this permission notice appear in
    32 ;;;> supporting documentation.  The name "Symbolics" may not be used in
    33 ;;;> advertising or publicity pertaining to distribution of the software
    34 ;;;> without specific, written prior permission.  Notice must be given in
    35 ;;;> supporting documentation that copying distribution is by permission of
    36 ;;;> Symbolics.  Symbolics makes no representations about the suitability of
    37 ;;;> this software for any purpose.  It is provided "as is" without express
    38 ;;;> or implied warranty.
    39 ;;;>
    40 ;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera,
    41 ;;;> and Zetalisp are registered trademarks of Symbolics, Inc.
    42 ;;;>
    43 ;;;>      Symbolics, Inc.
    44 ;;;>      8 New England Executive Park, East
    45 ;;;>      Burlington, Massachusetts  01803
    46 ;;;>      United States of America
    47 ;;;>      +1-617-221-1000
    48 
    49 ;;;; LOOP Iteration Macro
    50 
    51 #+armedbear
    52 (defpackage :ansi-loop (:use :cl))
    53 
    54 (in-package :ansi-loop)
    55 
    56 ;;; Technology.
     1;;; loop.lisp
    572;;;
    58 ;;; The LOOP iteration macro is one of a number of pieces of code
    59 ;;; originally developed at MIT and licensed as set out above. This
    60 ;;; version of LOOP, which is almost entirely rewritten both as a
    61 ;;; clean-up and to conform with the ANSI Lisp LOOP standard, started
    62 ;;; life as MIT LOOP version 829 (which was a part of NIL, possibly
    63 ;;; never released).
     3;;; Copyright (C) 2004 Peter Graves
     4;;; $Id: loop.lisp,v 1.10 2004-02-21 16:00:22 piso Exp $
    645;;;
    65 ;;; A "light revision" was performed by Glenn Burke while at Palladian
    66 ;;; Software in April 1986, to make the code run in Common Lisp.  This
    67 ;;; revision was informally distributed to a number of people, and was
    68 ;;; sort of the "MIT" version of LOOP for running in Common Lisp.
     6;;; This program is free software; you can redistribute it and/or
     7;;; modify it under the terms of the GNU General Public License
     8;;; as published by the Free Software Foundation; either version 2
     9;;; of the License, or (at your option) any later version.
    6910;;;
    70 ;;; A later more drastic revision was performed at Palladian perhaps a
    71 ;;; year later.  This version was more thoroughly Common Lisp in
    72 ;;; style, with a few miscellaneous internal improvements and
    73 ;;; extensions.  Glenn Burke lost track of this source, apparently
    74 ;;; never having moved it to the MIT distribution point; and does not
    75 ;;; remember if it was ever distributed.
     11;;; This program is distributed in the hope that it will be useful,
     12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     14;;; GNU General Public License for more details.
    7615;;;
    77 ;;; This revision for the ANSI standard is based on the code of Glenn
    78 ;;; Burke's April 1986 version, with almost everything redesigned
    79 ;;; and/or rewritten.
    80 
    81 
    82 
    83 ;;; The design of this LOOP is intended to permit, using mostly the same
    84 ;;; kernel of code, up to three different "loop" macros:
    85 ;;;
    86 ;;; (1) The unextended, unextensible ANSI standard LOOP;
    87 ;;;
    88 ;;; (2) A clean "superset" extension of the ANSI LOOP which provides
    89 ;;; functionality similar to that of the old LOOP, but "in the style of"
    90 ;;; the ANSI LOOP.  For instance, user-definable iteration paths, with a
    91 ;;; somewhat cleaned-up interface.
    92 ;;;
    93 ;;; (3) Extensions provided in another file which can make this LOOP
    94 ;;; kernel behave largely compatibly with the Genera-vintage LOOP macro,
    95 ;;; with only a small addition of code (instead of two whole, separate,
    96 ;;; LOOP macros).
    97 ;;;
    98 ;;; Each of the above three LOOP variations can coexist in the same LISP
    99 ;;; environment.
    100 ;;;
    101 
    102 
    103 
    104 ;;;; Miscellaneous Environment Things
    105 
    106 
    107 
    108 ;;;@@@@The LOOP-Prefer-POP feature makes LOOP generate code which "prefers" to use POP or
    109 ;;; its obvious expansion (prog1 (car x) (setq x (cdr x))).  Usually this involves
    110 ;;; shifting fenceposts in an iteration or series of carcdr operations.  This is
    111 ;;; primarily recognized in the list iterators (FOR .. {IN,ON}), and LOOP's
    112 ;;; destructuring setq code.
    113 (eval-when (compile load eval)
    114   #+(or Genera Minima) (pushnew :LOOP-Prefer-POP *features*)
    115   )
    116 
    117 
    118 ;;; The uses of this macro are retained in the CL version of loop, in
    119 ;;; case they are needed in a particular implementation.  Originally
    120 ;;; dating from the use of the Zetalisp COPYLIST* function, this is used
    121 ;;; in situations where, were cdr-coding in use, having cdr-NIL at the
    122 ;;; end of the list might be suboptimal because the end of the list will
    123 ;;; probably be RPLACDed and so cdr-normal should be used instead.
    124 (defmacro loop-copylist* (l)
    125   #+Genera `(lisp:copy-list ,l nil t)   ; arglist = (list &optional area force-dotted)
    126   ;;@@@@Explorer??
    127   #-Genera `(copy-list ,l)
    128   )
    129 
    130 
    131 (defvar *loop-gentemp*
    132   nil)
    133 
    134 (defun loop-gentemp (&optional (pref 'loopvar-))
    135   (if *loop-gentemp*
    136       (gensym (string pref))
    137       (gensym)))
    138 
    139 
    140 
    141 (defvar *loop-real-data-type* 'real)
    142 
    143 
    144 (defun loop-optimization-quantities (env)
    145   ;;@@@@ The ANSI conditionalization here is for those lisps that implement
    146   ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS).
    147   ;; It is really commentary on how this code could be written.  I don't
    148   ;; actually expect there to be an ANSI #+-conditional -- it should be
    149   ;; replaced with the appropriate conditional name for your
    150   ;; implementation/dialect.
    151   (declare #-ANSI (ignore env)
    152      #+Genera (values speed space safety compilation-speed debug))
    153   #+ANSI (let ((stuff (declaration-information 'optimize env)))
    154      (values (or (cdr (assoc 'speed stuff)) 1)
    155        (or (cdr (assoc 'space stuff)) 1)
    156        (or (cdr (assoc 'safety stuff)) 1)
    157        (or (cdr (assoc 'compilation-speed stuff)) 1)
    158        (or (cdr (assoc 'debug stuff)) 1)))
    159   #+CLOE-Runtime (values compiler::time compiler::space
    160        compiler::safety compiler::compilation-speed 1)
    161   #-(or ANSI CLOE-Runtime) (values 1 1 1 1 1))
    162 
    163 
    164 ;;;@@@@ The following form takes a list of variables and a form which presumably
    165 ;;; references those variables, and wraps it somehow so that the compiler does not
    166 ;;; consider those variables have been referenced.  The intent of this is that
    167 ;;; iteration variables can be flagged as unused by the compiler, e.g. I in
    168 ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage
    169 ;;; of it is "invisible" or "not to be considered".
    170 ;;;We implicitly assume that a setq does not count as a reference.  That is, the
    171 ;;; kind of form generated for the above loop construct to step I, simplified, is
    172 ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))).
    173 (defun hide-variable-references (variable-list form)
    174   (declare #-Genera (ignore variable-list))
    175   #+Genera (if variable-list `(compiler:invisible-references ,variable-list ,form) form)
    176   #-Genera form)
    177 
    178 
    179 ;;;@@@@ The following function takes a flag, a variable, and a form which presumably
    180 ;;; references that variable, and wraps it somehow so that the compiler does not
    181 ;;; consider that variable to have been referenced.  The intent of this is that
    182 ;;; iteration variables can be flagged as unused by the compiler, e.g. I in
    183 ;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage
    184 ;;; of it is "invisible" or "not to be considered".
    185 ;;;We implicitly assume that a setq does not count as a reference.  That is, the
    186 ;;; kind of form generated for the above loop construct to step I, simplified, is
    187 ;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))).
    188 ;;;Certain cases require that the "invisibility" of the reference be conditional upon
    189 ;;; something.  This occurs in cases of "named" variables (the USING clause).  For instance,
    190 ;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...)
    191 ;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is
    192 ;;; not referenced.  However, if no USING clause is present, we definitely do not
    193 ;;; want to be informed that some random gensym is not used.
    194 ;;;It is easier for the caller to do this conditionally by passing a flag (which
    195 ;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than
    196 ;;; for all callers to contain the conditional invisibility construction.
    197 (defun hide-variable-reference (really-hide variable form)
    198   (declare #-Genera (ignore really-hide variable))
    199   #+Genera (if (and really-hide variable (atom variable)) ;Punt on destructuring patterns
    200          `(compiler:invisible-references (,variable) ,form)
    201          form)
    202   #-Genera form)
    203 
    204 
    205 
    206 ;;;; List Collection Macrology
    207 
    208 
    209 (defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var)
    210             &body body)
    211   ;;@@@@ TI? Exploder?
    212   #+LISPM (let ((head-place (or user-head-var head-var)))
    213       `(let* ((,head-place nil)
    214         (,tail-var
    215           ,(hide-variable-reference
    216        user-head-var user-head-var
    217        `(progn #+Genera (scl:locf ,head-place)
    218          #-Genera (system:variable-location ,head-place)))))
    219          ,@body))
    220   #-LISPM (let ((l (and user-head-var (list (list user-head-var nil)))))
    221       #+CLOE `(sys::with-stack-list* (,head-var nil nil)
    222           (let ((,tail-var ,head-var) ,@l)
    223       ,@body))
    224       #-CLOE `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
    225           ,@body)))
    226 
    227 
    228 (defmacro loop-collect-rplacd (&environment env
    229              (head-var tail-var &optional user-head-var) form)
    230   (declare
    231     #+LISPM (ignore head-var user-head-var) ;use locatives, unconditionally update through the tail.
    232     )
     16;;; You should have received a copy of the GNU General Public License
     17;;; along with this program; if not, write to the Free Software
     18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
     19
     20;;; Adapted from SBCL.
     21
     22;;;; the LOOP iteration macro
     23
     24;;;; This software is part of the SBCL system. See the README file for
     25;;;; more information.
     26
     27;;;; This code was modified by William Harold Newman beginning
     28;;;; 19981106, originally to conform to the new SBCL bootstrap package
     29;;;; system and then subsequently to address other cross-compiling
     30;;;; bootstrap issues, SBCLification (e.g. DECLARE used to check
     31;;;; argument types), and other maintenance. Whether or not it then
     32;;;; supported all the environments implied by the reader conditionals
     33;;;; in the source code (e.g. #!+CLOE-RUNTIME) before that
     34;;;; modification, it sure doesn't now. It might perhaps, by blind
     35;;;; luck, be appropriate for some other CMU-CL-derived system, but
     36;;;; really it only attempts to be appropriate for SBCL.
     37
     38;;;; This software is derived from software originally released by the
     39;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and
     40;;;; release statements follow. Later modifications to the software are in
     41;;;; the public domain and are provided with absolutely no warranty. See the
     42;;;; COPYING and CREDITS files for more information.
     43
     44;;;; Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute
     45;;;; of Technology. All Rights Reserved.
     46;;;;
     47;;;; Permission to use, copy, modify and distribute this software and its
     48;;;; documentation for any purpose and without fee is hereby granted,
     49;;;; provided that the M.I.T. copyright notice appear in all copies and that
     50;;;; both that copyright notice and this permission notice appear in
     51;;;; supporting documentation. The names "M.I.T." and "Massachusetts
     52;;;; Institute of Technology" may not be used in advertising or publicity
     53;;;; pertaining to distribution of the software without specific, written
     54;;;; prior permission. Notice must be given in supporting documentation that
     55;;;; copying distribution is by permission of M.I.T. M.I.T. makes no
     56;;;; representations about the suitability of this software for any purpose.
     57;;;; It is provided "as is" without express or implied warranty.
     58;;;;
     59;;;;      Massachusetts Institute of Technology
     60;;;;      77 Massachusetts Avenue
     61;;;;      Cambridge, Massachusetts  02139
     62;;;;      United States of America
     63;;;;      +1-617-253-1000
     64
     65;;;; Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics,
     66;;;; Inc. All Rights Reserved.
     67;;;;
     68;;;; Permission to use, copy, modify and distribute this software and its
     69;;;; documentation for any purpose and without fee is hereby granted,
     70;;;; provided that the Symbolics copyright notice appear in all copies and
     71;;;; that both that copyright notice and this permission notice appear in
     72;;;; supporting documentation. The name "Symbolics" may not be used in
     73;;;; advertising or publicity pertaining to distribution of the software
     74;;;; without specific, written prior permission. Notice must be given in
     75;;;; supporting documentation that copying distribution is by permission of
     76;;;; Symbolics. Symbolics makes no representations about the suitability of
     77;;;; this software for any purpose. It is provided "as is" without express
     78;;;; or implied warranty.
     79;;;;
     80;;;; Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera,
     81;;;; and Zetalisp are registered trademarks of Symbolics, Inc.
     82;;;;
     83;;;;      Symbolics, Inc.
     84;;;;      8 New England Executive Park, East
     85;;;;      Burlington, Massachusetts  01803
     86;;;;      United States of America
     87;;;;      +1-617-221-1000
     88
     89(defpackage "LOOP" (:use "COMMON-LISP"))
     90
     91(in-package "LOOP")
     92
     93;;;; The design of this LOOP is intended to permit, using mostly the same
     94;;;; kernel of code, up to three different "loop" macros:
     95;;;;
     96;;;; (1) The unextended, unextensible ANSI standard LOOP;
     97;;;;
     98;;;; (2) A clean "superset" extension of the ANSI LOOP which provides
     99;;;; functionality similar to that of the old LOOP, but "in the style of"
     100;;;; the ANSI LOOP. For instance, user-definable iteration paths, with a
     101;;;; somewhat cleaned-up interface.
     102;;;;
     103;;;; (3) Extensions provided in another file which can make this LOOP
     104;;;; kernel behave largely compatibly with the Genera-vintage LOOP macro,
     105;;;; with only a small addition of code (instead of two whole, separate,
     106;;;; LOOP macros).
     107;;;;
     108;;;; Each of the above three LOOP variations can coexist in the same LISP
     109;;;; environment.
     110;;;;
     111;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality
     112;;;; for the other variants is wasted. -- WHN 20000121
     113
     114;;;; FIXME: the STEP-FUNCTION stuff in the code seems to've been
     115;;;; intended to support code which was conditionalized with
     116;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been
     117;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too.
     118
     119
     120;;;; list collection macrology
     121
     122(defmacro with-loop-list-collection-head
     123    ((head-var tail-var &optional user-head-var) &body body)
     124  (let ((l (and user-head-var (list (list user-head-var nil)))))
     125    `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l)
     126       ,@body)))
     127
     128(defmacro loop-collect-rplacd
     129    (&environment env (head-var tail-var &optional user-head-var) form)
    233130  (setq form (macroexpand form env))
    234131  (flet ((cdr-wrap (form n)
     
    242139       (setq form `(cddddr ,form) n (- n 4)))))
    243140    (let ((tail-form form) (ncdrs nil))
    244       ;;Determine if the form being constructed is a list of known length.
     141      ;; Determine whether the form being constructed is a list of known
     142      ;; length.
    245143      (when (consp form)
    246144  (cond ((eq (car form) 'list)
    247          (setq ncdrs (1- (length (cdr form))))
    248          ;;@@@@ Because the last element is going to be RPLACDed,
    249          ;; we don't want the cdr-coded implementations to use
    250          ;; cdr-nil at the end (which would just force copying
    251          ;; the whole list again).
    252          #+LISPM (setq tail-form `(list* ,@(cdr form) nil)))
     145         (setq ncdrs (1- (length (cdr form)))))
    253146        ((member (car form) '(list* cons))
    254147         (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
     
    260153        ((< ncdrs 0) (return-from loop-collect-rplacd nil))
    261154        ((= ncdrs 0)
    262          ;;@@@@ Here we have a choice of two idioms:
    263          ;; (rplacd tail (setq tail tail-form))
    264          ;; (setq tail (setf (cdr tail) tail-form)).
    265          ;;Genera and most others I have seen do better with the former.
     155         ;; @@@@ Here we have a choice of two idioms:
     156         ;;   (RPLACD TAIL (SETQ TAIL TAIL-FORM))
     157         ;;   (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)).
     158         ;; Genera and most others I have seen do better with the
     159         ;; former.
    266160         `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
    267         (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form)
     161        (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var)
     162                ,tail-form)
    268163               ncdrs))))))
    269   ;;If not using locatives or something similar to update the user's
    270   ;; head variable, we've got to set it...  It's harmless to repeatedly set it
    271   ;; unconditionally, and probably faster than checking.
    272   #-LISPM (when user-head-var
    273       (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var)))))
     164  ;; If not using locatives or something similar to update the
     165  ;; user's head variable, we've got to set it... It's harmless
     166  ;; to repeatedly set it unconditionally, and probably faster
     167  ;; than checking.
     168  (when user-head-var
     169    (setq answer
     170    `(progn ,answer
     171      (setq ,user-head-var (cdr ,head-var)))))
    274172  answer))))
    275173
    276 
    277 (defmacro loop-collect-answer (head-var &optional user-head-var)
     174(defmacro loop-collect-answer (head-var
     175              &optional user-head-var)
    278176  (or user-head-var
    279       (progn
    280   ;;If we use locatives to get tail-updating to update the head var,
    281   ;; then the head var itself contains the answer.  Otherwise we
    282   ;; have to cdr it.
    283   #+LISPM head-var
    284   #-LISPM `(cdr ,head-var))))
    285 
    286 
    287 
    288 ;;;; Maximization Technology
    289 
     177      `(cdr ,head-var)))
     178
     179
     180;;;; maximization technology
    290181
    291182#|
    292183The basic idea of all this minimax randomness here is that we have to
    293184have constructed all uses of maximize and minimize to a particular
    294 "destination" before we can decide how to code them.  The goal is to not
     185"destination" before we can decide how to code them. The goal is to not
    295186have to have any kinds of flags, by knowing both that (1) the type is
    296187something which we can provide an initial minimum or maximum value for
     
    302193constructed.
    303194|#
    304 
    305195
    306196(defstruct (loop-minimax
     
    315205  infinity-data)
    316206
    317 
    318207(defvar *loop-minimax-type-infinities-alist*
    319   ;;@@@@ This is the sort of value this should take on for a Lisp that has
    320   ;; "eminently usable" infinities.  n.b. there are neither constants nor
    321   ;; printed representations for infinities defined by CL.
    322   ;;@@@@ This grotesque read-from-string below is to help implementations
    323   ;; which croak on the infinity character when it appears in a token, even
    324   ;; conditionalized out.
    325   #+Genera
    326     '#.(read-from-string
    327         "((fixnum   most-positive-fixnum   most-negative-fixnum)
    328     (short-float  +1s       -1s)
    329     (single-float +1f       -1f)
    330     (double-float +1d       -1d)
    331     (long-float +1l       -1l))")
    332   ;;This is how the alist should look for a lisp that has no infinities.  In
    333   ;; that case, MOST-POSITIVE-x-FLOAT really IS the most positive.
    334   #+(or CLOE-Runtime Minima)
    335     '((fixnum       most-positive-fixnum    most-negative-fixnum)
    336       (short-float  most-positive-short-float most-negative-short-float)
    337       (single-float most-positive-single-float  most-negative-single-float)
    338       (double-float most-positive-double-float  most-negative-double-float)
    339       (long-float   most-positive-long-float  most-negative-long-float))
    340   ;; CMUCL has infinities so let's use them.
    341   #+CMU
    342     '((fixnum   most-positive-fixnum      most-negative-fixnum)
    343       (short-float  ext:single-float-positive-infinity  ext:single-float-negative-infinity)
    344       (single-float ext:single-float-positive-infinity  ext:single-float-negative-infinity)
    345       (double-float ext:double-float-positive-infinity  ext:double-float-negative-infinity)
    346       (long-float   ext:long-float-positive-infinity  ext:long-float-negative-infinity))
    347   ;; If we don't know, then we cannot provide "infinite" initial values for any of the
    348   ;; types but FIXNUM:
    349   #-(or Genera CLOE-Runtime Minima CMU)
    350     '((fixnum       most-positive-fixnum    most-negative-fixnum))
    351     )
    352 
     208  ;; FIXME: Now that SBCL supports floating point infinities again, we
     209  ;; should have floating point infinities here, as cmucl-2.4.8 did.
     210  '((fixnum most-positive-fixnum most-negative-fixnum)))
    353211
    354212(defun make-loop-minimax (answer-variable type)
    355   (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep))))
     213  (let ((infinity-data (cdr (assoc type
     214           *loop-minimax-type-infinities-alist*
     215           :test #'subtypep))))
    356216    (make-loop-minimax-internal
    357217      :answer-variable answer-variable
    358218      :type type
    359       :temp-variable (loop-gentemp 'loop-maxmin-temp-)
    360       :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-))
     219      :temp-variable (gensym "LOOP-MAXMIN-TEMP-")
     220      :flag-variable (and (not infinity-data)
     221        (gensym "LOOP-MAXMIN-FLAG-"))
    361222      :operations nil
    362223      :infinity-data infinity-data)))
    363 
    364224
    365225(defun loop-note-minimax-operation (operation minimax)
     
    367227  (when (and (cdr (loop-minimax-operations minimax))
    368228       (not (loop-minimax-flag-variable minimax)))
    369     (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-)))
     229    (setf (loop-minimax-flag-variable minimax)
     230    (gensym "LOOP-MAXMIN-FLAG-")))
    370231  operation)
    371 
    372232
    373233(defmacro with-minimax-value (lm &body body)
     
    383243     (declare (type ,type ,answer-var ,temp-var))
    384244     ,@body)
    385   `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data)))
     245  `(let ((,answer-var ,(if (eq which 'min)
     246         (first infinity-data)
     247         (second infinity-data)))
    386248         (,temp-var ,init))
    387249     (declare (type ,type ,answer-var ,temp-var))
    388250     ,@body))))
    389 
    390251
    391252(defmacro loop-accumulate-minimax-value (lm operation form)
     
    393254   (temp-var (loop-minimax-temp-variable lm))
    394255   (flag-var (loop-minimax-flag-variable lm))
    395    (test
    396      (hide-variable-reference
    397        t (loop-minimax-answer-variable lm)
    398        `(,(ecase operation
    399       (min '<)
    400       (max '>))
    401          ,temp-var ,answer-var))))
     256   (test `(,(ecase operation
     257        (min '<)
     258        (max '>))
     259     ,temp-var ,answer-var)))
    402260    `(progn
    403261       (setq ,temp-var ,form)
     
    407265
    408266
    409 
    410 
    411 ;;;; Loop Keyword Tables
    412 
     267;;;; LOOP keyword tables
    413268
    414269#|
     
    416271
    417272The actual descriptive/dispatch structure used by LOOP is called a "loop
    418 universe" contains a few tables and parameterizations.  The basic idea is
     273universe" contains a few tables and parameterizations. The basic idea is
    419274that we can provide a non-extensible ANSI-compatible loop environment,
    420275an extensible ANSI-superset loop environment, and (for such environments
     
    424279|#
    425280
    426 
    427 ;;;; Token Hackery
    428 
    429 
    430 ;;;Compare two "tokens".  The first is the frob out of *LOOP-SOURCE-CODE*,
     281;;;; token hackery
     282
     283;;; Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*,
    431284;;; the second a symbol to check against.
    432285(defun loop-tequal (x1 x2)
    433286  (and (symbolp x1) (string= x1 x2)))
    434287
    435 
    436288(defun loop-tassoc (kwd alist)
    437289  (and (symbolp kwd) (assoc kwd alist :test #'string=)))
    438290
    439 
    440291(defun loop-tmember (kwd list)
    441292  (and (symbolp kwd) (member kwd list :test #'string=)))
    442 
    443293
    444294(defun loop-lookup-keyword (loop-token table)
     
    446296       (values (gethash (symbol-name loop-token) table))))
    447297
    448 
    449298(defmacro loop-store-table-data (symbol table datum)
    450299  `(setf (gethash (symbol-name ,symbol) ,table) ,datum))
    451300
    452 
    453301(defstruct (loop-universe
    454        (:print-function print-loop-universe)
    455302       (:copier nil)
    456303       (:predicate nil))
    457   keywords          ;hash table, value = (fn-name . extra-data).
    458   iteration-keywords        ;hash table, value = (fn-name . extra-data).
    459   for-keywords          ;hash table, value = (fn-name . extra-data).
    460   path-keywords         ;hash table, value = (fn-name . extra-data).
    461   type-symbols          ;hash table of type SYMBOLS, test EQ, value = CL type specifier.
    462   type-keywords         ;hash table of type STRINGS, test EQUAL, value = CL type spec.
    463   ansi            ;NIL, T, or :EXTENDED.
    464   implicit-for-required       ;see loop-hack-iteration
    465   )
    466 
    467 
    468 (defun print-loop-universe (u stream level)
    469   (declare (ignore level))
    470   (let ((str (case (loop-universe-ansi u)
    471          ((nil) "Non-ANSI")
    472          ((t) "ANSI")
    473          (:extended "Extended-ANSI")
    474          (t (loop-universe-ansi u)))))
    475     ;;Cloe could be done with the above except for bootstrap lossage...
    476     #+CLOE
    477     (format stream "#<~S ~A ~X>" (type-of u) str (sys::address-of u))
    478     #+(or Genera cmu)         ;@@@@ This is reallly the ANSI definition.
    479     (print-unreadable-object (u stream :type t :identity t)
    480       (princ str stream))
    481     #-(or Genera CLOE cmu)
    482     (format stream "#<~S ~A>" (type-of u) str)
    483     ))
    484 
    485 
    486 ;;;This is the "current" loop context in use when we are expanding a
    487 ;;;loop.  It gets bound on each invocation of LOOP.
     304  keywords             ; hash table, value = (fn-name . extra-data)
     305  iteration-keywords   ; hash table, value = (fn-name . extra-data)
     306  for-keywords         ; hash table, value = (fn-name . extra-data)
     307  path-keywords        ; hash table, value = (fn-name . extra-data)
     308  type-symbols         ; hash table of type SYMBOLS, test EQ,
     309                       ; value = CL type specifier
     310  type-keywords        ; hash table of type STRINGS, test EQUAL,
     311                       ; value = CL type spec
     312  ansi                 ; NIL, T, or :EXTENDED
     313  implicit-for-required) ; see loop-hack-iteration
     314
     315#+sbcl
     316(sb!int:def!method print-object ((u loop-universe) stream)
     317  (let ((string (case (loop-universe-ansi u)
     318      ((nil) "non-ANSI")
     319      ((t) "ANSI")
     320      (:extended "extended-ANSI")
     321      (t (loop-universe-ansi u)))))
     322    (print-unreadable-object (u stream :type t)
     323      (write-string string stream))))
     324
     325;;; This is the "current" loop context in use when we are expanding a
     326;;; loop. It gets bound on each invocation of LOOP.
    488327(defvar *loop-universe*)
    489328
    490 
    491 (defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords
    492             type-keywords type-symbols ansi)
    493   #-(and CLOE Source-Bootstrap) (check-type ansi (member nil t :extended))
     329(defun make-standard-loop-universe (&key keywords for-keywords
     330          iteration-keywords path-keywords
     331          type-keywords type-symbols ansi)
     332  (declare (type (member nil t :extended) ansi))
    494333  (flet ((maketable (entries)
    495334     (let* ((size (length entries))
    496       (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal)))
    497        (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x)))
     335      (ht (make-hash-table :size (if (< size 10) 10 size)
     336               :test 'equal)))
     337       (dolist (x entries)
     338         (setf (gethash (symbol-name (car x)) ht) (cadr x)))
    498339       ht)))
    499340    (make-loop-universe
     
    506347      :type-keywords (maketable type-keywords)
    507348      :type-symbols (let* ((size (length type-symbols))
    508          (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq)))
     349         (ht (make-hash-table :size (if (< size 10) 10 size)
     350            :test 'eq)))
    509351          (dolist (x type-symbols)
    510       (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x))))
     352      (if (atom x)
     353          (setf (gethash x ht) x)
     354          (setf (gethash (car x) ht) (cadr x))))
    511355          ht))))
    512356
    513357
    514 
    515 ;;;; Setq Hackery
    516 
    517 
    518 (defvar *loop-destructuring-hooks*
    519   nil
    520   "If not NIL, this must be a list of two things:
    521 a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.")
    522 
     358;;;; SETQ hackery, including destructuring ("DESETQ")
    523359
    524360(defun loop-make-psetq (frobs)
     
    530366         ,(loop-make-psetq (cddr frobs))))))))
    531367
    532 
    533368(defun loop-make-desetq (var-val-pairs)
    534369  (if (null var-val-pairs)
    535370      nil
    536       (cons (if *loop-destructuring-hooks*
    537     (cadr *loop-destructuring-hooks*)
    538     'loop-really-desetq)
    539       var-val-pairs)))
    540 
     371      (cons 'loop-really-desetq var-val-pairs)))
    541372
    542373(defvar *loop-desetq-temporary*
    543374  (make-symbol "LOOP-DESETQ-TEMP"))
    544375
    545 
    546 (defmacro loop-really-desetq (&environment env &rest var-val-pairs)
     376(defmacro loop-really-desetq (&environment env
     377                      &rest var-val-pairs)
    547378  (labels ((find-non-null (var)
    548        ;; see if there's any non-null thing here
    549        ;; recurse if the list element is itself a list
     379       ;; See whether there's any non-null thing here. Recurse
     380       ;; if the list element is itself a list.
    550381       (do ((tail var)) ((not (consp tail)) tail)
    551382         (when (find-non-null (pop tail)) (return t))))
     
    555386         (null
    556387     (when (consp val)
    557        ;; don't lose possible side-effects
     388       ;; Don't lose possible side effects.
    558389       (if (eq (car val) 'prog1)
    559            ;; these can come from psetq or desetq below.
    560            ;; throw away the value, keep the side-effects.
    561            ;;Special case is for handling an expanded POP.
    562            (mapcan #'(lambda (x)
    563            (and (consp x)
    564           (or (not (eq (car x) 'car))
    565               (not (symbolp (cadr x)))
    566               (not (symbolp (setq x (macroexpand x env)))))
    567           (cons x nil)))
     390           ;; These can come from PSETQ or DESETQ below.
     391           ;; Throw away the value, keep the side effects.
     392           ;; Special case is for handling an expanded POP.
     393           (mapcan (lambda (x)
     394         (and (consp x)
     395              (or (not (eq (car x) 'car))
     396            (not (symbolp (cadr x)))
     397            (not (symbolp (setq x (macroexpand x env)))))
     398              (cons x nil)))
    568399             (cdr val))
    569400           `(,val))))
     
    577408       (let* ((temp-p temp)
    578409        (temp (or temp *loop-desetq-temporary*))
    579         (body #+LOOP-Prefer-POP `(,@(loop-desetq-internal
    580                     car
    581                     `(prog1 (car ,temp)
    582                       (setq ,temp (cdr ,temp))))
    583                 ,@(loop-desetq-internal cdr temp temp))
    584               #-LOOP-Prefer-POP `(,@(loop-desetq-internal car `(car ,temp))
    585                 (setq ,temp (cdr ,temp))
    586                 ,@(loop-desetq-internal cdr temp temp))))
     410        (body `(,@(loop-desetq-internal car
     411                `(car ,temp))
     412            (setq ,temp (cdr ,temp))
     413            ,@(loop-desetq-internal cdr
     414                  temp
     415                  temp))))
    587416         (if temp-p
    588417             `(,@(unless (eq temp val)
     
    591420             `((let ((,temp ,val))
    592421           ,@body))))
    593        ;; no cdring to do
     422       ;; no CDRing to do
    594423       (loop-desetq-internal car `(car ,val) temp)))))
    595424         (otherwise
     
    600429   (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
    601430      (setq actions (revappend
    602           (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs))
     431          (loop-desetq-internal (pop var-val-pairs)
     432              (pop var-val-pairs))
    603433          actions)))))
    604434
    605435
    606 
    607436;;;; LOOP-local variables
    608437
    609 ;;;This is the "current" pointer into the LOOP source code.
     438;;; This is the "current" pointer into the LOOP source code.
    610439(defvar *loop-source-code*)
    611440
    612 
    613 ;;;This is the pointer to the original, for things like NAMED that
    614 ;;;insist on being in a particular position
     441;;; This is the pointer to the original, for things like NAMED that
     442;;; insist on being in a particular position
    615443(defvar *loop-original-source-code*)
    616444
    617 
    618 ;;;This is *loop-source-code* as of the "last" clause.  It is used
    619 ;;;primarily for generating error messages (see loop-error, loop-warn).
     445;;; This is *loop-source-code* as of the "last" clause. It is used
     446;;; primarily for generating error messages (see loop-error, loop-warn).
    620447(defvar *loop-source-context*)
    621448
    622 
    623 ;;;List of names for the LOOP, supplied by the NAMED clause.
     449;;; list of names for the LOOP, supplied by the NAMED clause
    624450(defvar *loop-names*)
    625451
    626 ;;;The macroexpansion environment given to the macro.
     452;;; The macroexpansion environment given to the macro.
    627453(defvar *loop-macro-environment*)
    628454
    629 ;;;This holds variable names specified with the USING clause.
    630 ;;; See LOOP-NAMED-VARIABLE.
    631 (defvar *loop-named-variables*)
     455;;; This holds variable names specified with the USING clause.
     456;;; See LOOP-NAMED-VAR.
     457(defvar *loop-named-vars*)
    632458
    633459;;; LETlist-like list being accumulated for one group of parallel bindings.
    634 (defvar *loop-variables*)
    635 
    636 ;;;List of declarations being accumulated in parallel with
    637 ;;;*loop-variables*.
     460(defvar *loop-vars*)
     461
     462;;; list of declarations being accumulated in parallel with *LOOP-VARS*
    638463(defvar *loop-declarations*)
    639464
    640 ;;;Used by LOOP for destructuring binding, if it is doing that itself.
    641 ;;; See loop-make-variable.
     465;;; This is used by LOOP for destructuring binding, if it is doing
     466;;; that itself. See LOOP-MAKE-VAR.
    642467(defvar *loop-desetq-crocks*)
    643468
    644 ;;; List of wrapping forms, innermost first, which go immediately inside
    645 ;;; the current set of parallel bindings being accumulated in
    646 ;;; *loop-variables*.  The wrappers are appended onto a body. E.g.,
    647 ;;; this list could conceivably has as its value ((with-open-file (g0001
    648 ;;; g0002 ...))), with g0002 being one of the bindings in
    649 ;;; *loop-variables* (this is why the wrappers go inside of the variable
    650 ;;; bindings).
     469;;; list of wrapping forms, innermost first, which go immediately
     470;;; inside the current set of parallel bindings being accumulated in
     471;;; *LOOP-VARS*. The wrappers are appended onto a body. E.g.,
     472;;; this list could conceivably have as its value
     473;;;   ((WITH-OPEN-FILE (G0001 G0002 ...))),
     474;;; with G0002 being one of the bindings in *LOOP-VARS* (This is
     475;;; why the wrappers go inside of the variable bindings).
    651476(defvar *loop-wrappers*)
    652477
    653 ;;;This accumulates lists of previous values of *loop-variables* and the
    654 ;;;other lists  above, for each new nesting of bindings. See
    655 ;;;loop-bind-block.
     478;;; This accumulates lists of previous values of *LOOP-VARS* and
     479;;; the other lists above, for each new nesting of bindings. See
     480;;; LOOP-BIND-BLOCK.
    656481(defvar *loop-bind-stack*)
    657482
    658 ;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause
    659 ;;;which inhibits  LOOP from actually outputting a type declaration for
    660 ;;;an iteration (or any) variable.
    661 (defvar *loop-nodeclare*)
    662 
    663 ;;;This is simply a list of LOOP iteration variables, used for checking
    664 ;;;for duplications.
    665 (defvar *loop-iteration-variables*)
    666 
    667 
    668 ;;;List of prologue forms of the loop, accumulated in reverse order.
     483;;; This is simply a list of LOOP iteration variables, used for
     484;;; checking for duplications.
     485(defvar *loop-iteration-vars*)
     486
     487;;; list of prologue forms of the loop, accumulated in reverse order
    669488(defvar *loop-prologue*)
    670489
     
    673492(defvar *loop-after-body*)
    674493
    675 ;;;This is T if we have emitted any body code, so that iteration driving
    676 ;;;clauses can be disallowed.   This is not strictly the same as
    677 ;;;checking *loop-body*, because we permit some clauses  such as RETURN
    678 ;;;to not be considered "real" body (so as to permit the user to "code"
    679 ;;;an abnormal return value "in loop").
     494;;; This is T if we have emitted any body code, so that iteration
     495;;; driving clauses can be disallowed. This is not strictly the same
     496;;; as checking *LOOP-BODY*, because we permit some clauses such as
     497;;; RETURN to not be considered "real" body (so as to permit the user
     498;;; to "code" an abnormal return value "in loop").
    680499(defvar *loop-emitted-body*)
    681500
    682 
    683 ;;;List of epilogue forms (supplied by FINALLY generally), accumulated
    684 ;;; in reverse order.
     501;;; list of epilogue forms (supplied by FINALLY generally), accumulated
     502;;; in reverse order
    685503(defvar *loop-epilogue*)
    686504
    687 ;;;List of epilogue forms which are supplied after the above "user"
    688 ;;;epilogue.  "normal" termination return values are provide by putting
    689 ;;;the return form in here. Normally this is done using
    690 ;;;loop-emit-final-value, q.v.
     505;;; list of epilogue forms which are supplied after the above "user"
     506;;; epilogue. "Normal" termination return values are provide by
     507;;; putting the return form in here. Normally this is done using
     508;;; LOOP-EMIT-FINAL-VALUE, q.v.
    691509(defvar *loop-after-epilogue*)
    692510
    693 ;;;The "culprit" responsible for supplying a final value from the loop.
    694 ;;;This  is so loop-emit-final-value can moan about multiple return
    695 ;;;values being supplied.
     511;;; the "culprit" responsible for supplying a final value from the
     512;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple
     513;;; return values being supplied.
    696514(defvar *loop-final-value-culprit*)
    697515
    698 ;;;If not NIL, we are in some branch of a conditional.  Some clauses may
    699 ;;;be disallowed.
     516;;; If this is true, we are in some branch of a conditional. Some
     517;;; clauses may be disallowed.
    700518(defvar *loop-inside-conditional*)
    701519
    702 ;;;If not NIL, this is a temporary bound around the loop for holding the
    703 ;;;temporary  value for "it" in things like "when (f) collect it".  It
    704 ;;;may be used as a supertemporary by some other things.
    705 (defvar *loop-when-it-variable*)
    706 
    707 ;;;Sometimes we decide we need to fold together parts of the loop, but
    708 ;;;some part of the generated iteration  code is different for the first
    709 ;;;and remaining iterations.  This variable will be the temporary which
    710 ;;;is the flag used in the loop to tell whether we are in the first or
    711 ;;;remaining iterations.
    712 (defvar *loop-never-stepped-variable*)
    713 
    714 ;;;List of all the value-accumulation descriptor structures in the loop.
    715 ;;; See loop-get-collection-info.
    716 (defvar *loop-collection-cruft*)    ; for multiple COLLECTs (etc)
    717 
    718 
    719 
    720 ;;;; Code Analysis Stuff
    721 
     520;;; If not NIL, this is a temporary bound around the loop for holding
     521;;; the temporary value for "it" in things like "when (f) collect it".
     522;;; It may be used as a supertemporary by some other things.
     523(defvar *loop-when-it-var*)
     524
     525;;; Sometimes we decide we need to fold together parts of the loop,
     526;;; but some part of the generated iteration code is different for the
     527;;; first and remaining iterations. This variable will be the
     528;;; temporary which is the flag used in the loop to tell whether we
     529;;; are in the first or remaining iterations.
     530(defvar *loop-never-stepped-var*)
     531
     532;;; list of all the value-accumulation descriptor structures in the
     533;;; loop. See LOOP-GET-COLLECTION-INFO.
     534(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc.)
     535
     536
     537;;;; code analysis stuff
    722538
    723539(defun loop-constant-fold-if-possible (form &optional expected-type)
    724   #+Genera (declare (values new-form constantp constant-value))
    725540  (let ((new-form form) (constantp nil) (constant-value nil))
    726     #+Genera (setq new-form (compiler:optimize-form form *loop-macro-environment*
    727                 :repeat t
    728                 :do-macro-expansion t
    729                 :do-named-constants t
    730                 :do-inline-forms t
    731                 :do-optimizers t
    732                 :do-constant-folding t
    733                 :do-function-args t)
    734        constantp (constantp new-form *loop-macro-environment*)
    735        constant-value (and constantp (lt:evaluate-constant new-form *loop-macro-environment*)))
    736     #-Genera (when (setq constantp (constantp new-form))
    737          (setq constant-value (eval new-form)))
     541    (when (setq constantp (constantp new-form))
     542      (setq constant-value (eval new-form)))
    738543    (when (and constantp expected-type)
    739544      (unless (typep constant-value expected-type)
    740   (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
     545  (loop-warn "~@<The form ~S evaluated to ~S, which was not of ~
     546                    the anticipated type ~S.~:@>"
    741547       form constant-value expected-type)
    742548  (setq constantp nil constant-value nil)))
    743549    (values new-form constantp constant-value)))
    744550
    745 
    746551(defun loop-constantp (form)
    747   #+Genera (constantp form *loop-macro-environment*)
    748   #-Genera (constantp form))
    749 
    750 
    751 
    752 ;;;; LOOP Iteration Optimization
     552  (constantp form))
     553
     554
     555;;;; LOOP iteration optimization
    753556
    754557(defvar *loop-duplicate-code*
    755558  nil)
    756559
    757 
    758 (defvar *loop-iteration-flag-variable*
     560(defvar *loop-iteration-flag-var*
    759561  (make-symbol "LOOP-NOT-FIRST-TIME"))
    760562
    761 
    762563(defun loop-code-duplication-threshold (env)
    763   (multiple-value-bind (speed space) (loop-optimization-quantities env)
     564  (declare (ignore env))
     565  (let (;; If we could read optimization declaration information (as
     566  ;; with the DECLARATION-INFORMATION function (present in
     567  ;; CLTL2, removed from ANSI standard) we could set these
     568  ;; values flexibly. Without DECLARATION-INFORMATION, we have
     569  ;; to set them to constants.
     570  ;;
     571  ;; except FIXME: we've lost all pretence of portability,
     572  ;; considering this instead an internal implementation, so
     573  ;; we're free to couple to our own representation of the
     574  ;; environment.
     575  (speed 1)
     576  (space 1))
    764577    (+ 40 (* (- speed space) 10))))
    765578
    766 
    767579(defmacro loop-body (&environment env
    768         prologue
    769         before-loop
    770         main-body
    771         after-loop
    772         epilogue
    773         &aux rbefore rafter flagvar)
     580          prologue
     581          before-loop
     582          main-body
     583          after-loop
     584          epilogue
     585          &aux rbefore rafter flagvar)
    774586  (unless (= (length before-loop) (length after-loop))
    775     (error "LOOP-BODY called with non-synched before- and after-loop lists."))
     587    (error "LOOP-BODY called with non-synched before- and after-loop lists"))
    776588  ;;All our work is done from these copies, working backwards from the end:
    777589  (setq rbefore (reverse before-loop) rafter (reverse after-loop))
     
    781593     (when x
    782594       (push x ans)
    783        (when (and (consp x) (member (car x) '(go return return-from)))
     595       (when (and (consp x)
     596            (member (car x) '(go return return-from)))
    784597         (return nil))))
    785598         (nreverse ans)))
     
    789602          ,@(psimp (append prologue (nreverse rbefore)))
    790603       next-loop
    791           ,@(psimp (append main-body (nreconc rafter `((go next-loop)))))
     604          ,@(psimp (append main-body
     605               (nreconc rafter
     606                  `((go next-loop)))))
    792607       end-loop
    793608          ,@(psimp epilogue))))
     
    795610    (when (or *loop-duplicate-code* (not rbefore))
    796611      (return-from loop-body (makebody)))
    797     ;; This outer loop iterates once for each not-first-time flag test generated
    798     ;; plus once more for the forms that don't need a flag test
     612    ;; This outer loop iterates once for each not-first-time flag test
     613    ;; generated plus once more for the forms that don't need a flag test.
    799614    (do ((threshold (loop-code-duplication-threshold env))) (nil)
    800615      (declare (fixnum threshold))
    801       ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent
    802       ;; forms into the body.
     616      ;; Go backwards from the ends of before-loop and after-loop
     617      ;; merging all the equivalent forms into the body.
    803618      (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
    804619  (push (pop rbefore) main-body)
    805620  (pop rafter))
    806621      (unless rbefore (return (makebody)))
    807       ;; The first forms in rbefore & rafter (which are the chronologically
    808       ;; last forms in the list) differ, therefore they cannot be moved
    809       ;; into the main body.  If everything that chronologically precedes
    810       ;; them either differs or is equal but is okay to duplicate, we can
    811       ;; just put all of rbefore in the prologue and all of rafter after
    812       ;; the body.  Otherwise, there is something that is not okay to
    813       ;; duplicate, so it and everything chronologically after it in
    814       ;; rbefore and rafter must go into the body, with a flag test to
    815       ;; distinguish the first time around the loop from later times.
    816       ;; What chronologically precedes the non-duplicatable form will
    817       ;; be handled the next time around the outer loop.
    818       (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil))
    819     ((null bb) (return-from loop-body (makebody)))  ;Did it.
     622      ;; The first forms in RBEFORE & RAFTER (which are the
     623      ;; chronologically last forms in the list) differ, therefore
     624      ;; they cannot be moved into the main body. If everything that
     625      ;; chronologically precedes them either differs or is equal but
     626      ;; is okay to duplicate, we can just put all of rbefore in the
     627      ;; prologue and all of rafter after the body. Otherwise, there
     628      ;; is something that is not okay to duplicate, so it and
     629      ;; everything chronologically after it in rbefore and rafter
     630      ;; must go into the body, with a flag test to distinguish the
     631      ;; first time around the loop from later times. What
     632      ;; chronologically precedes the non-duplicatable form will be
     633      ;; handled the next time around the outer loop.
     634      (do ((bb rbefore (cdr bb))
     635     (aa rafter (cdr aa))
     636     (lastdiff nil)
     637     (count 0)
     638     (inc nil))
     639    ((null bb) (return-from loop-body (makebody)))  ; Did it.
    820640  (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
    821641        ((or (not (setq inc (estimate-code-size (car bb) env)))
    822642       (> (incf count inc) threshold))
    823          ;; Ok, we have found a non-duplicatable piece of code.  Everything
    824          ;; chronologically after it must be in the central body.
    825          ;; Everything chronologically at and after lastdiff goes into the
    826          ;; central body under a flag test.
     643         ;; Ok, we have found a non-duplicatable piece of code.
     644         ;; Everything chronologically after it must be in the
     645         ;; central body. Everything chronologically at and
     646         ;; after LASTDIFF goes into the central body under a
     647         ;; flag test.
    827648         (let ((then nil) (else nil))
    828649     (do () (nil)
     
    831652       (when (eq rbefore (cdr lastdiff)) (return)))
    832653     (unless flagvar
    833        (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else))
     654       (push `(setq ,(setq flagvar *loop-iteration-flag-var*)
     655        t)
     656       else))
    834657     (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
    835658           main-body))
    836          ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb)
    837          ;; is the same in rbefore and rafter so just copy it into the body
     659         ;; Everything chronologically before lastdiff until the
     660         ;; non-duplicatable form (CAR BB) is the same in
     661         ;; RBEFORE and RAFTER, so just copy it into the body.
    838662         (do () (nil)
    839663     (pop rafter)
     
    843667
    844668
    845 
    846 
    847669(defun duplicatable-code-p (expr env)
    848670  (if (null expr) 0
    849671      (let ((ans (estimate-code-size expr env)))
    850672  (declare (fixnum ans))
    851   ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of
    852   ;; optimize quantities back to help quantify how much code we are willing to
    853   ;; duplicate.
     673  ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to
     674  ;; get an alist of optimize quantities back to help quantify
     675  ;; how much code we are willing to duplicate.
    854676  ans)))
    855 
    856677
    857678(defvar *special-code-sizes*
     
    860681    (when 1) (unless 1) (if 1)
    861682    (caar 2) (cadr 2) (cdar 2) (cddr 2)
    862     (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
     683    (caaar 3) (caadr 3) (cadar 3) (caddr 3)
     684    (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
    863685    (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
    864686    (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
    865687    (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
    866688    (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
    867 
    868689
    869690(defvar *estimate-code-size-punt*
     
    879700     with-open-file))
    880701
    881 
    882702(defun destructuring-size (x)
    883703  (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n)))
    884704      ((atom x) (+ n (if (null x) 0 1)))))
    885705
    886 
    887706(defun estimate-code-size (x env)
    888707  (catch 'estimate-code-size
    889708    (estimate-code-size-1 x env)))
    890 
    891709
    892710(defun estimate-code-size-1 (x env)
     
    896714       (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
    897715    ;;@@@@ ???? (declare (function list-size (list) fixnum))
    898     (cond ((constantp x #+Genera env) 1)
    899     ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
    900        (if expanded-p (estimate-code-size-1 new-form env) 1)))
    901     ((atom x) 1)        ;??? self-evaluating???
     716    (cond ((constantp x) 1)
     717    ((symbolp x) (multiple-value-bind (new-form expanded-p)
     718         (macroexpand-1 x env)
     719       (if expanded-p
     720           (estimate-code-size-1 new-form env)
     721           1)))
     722    ((atom x) 1) ;; ??? self-evaluating???
    902723    ((symbolp (car x))
    903724     (let ((fn (car x)) (tem nil) (n 0))
     
    905726       (macrolet ((f (overhead &optional (args nil args-p))
    906727        `(the fixnum (+ (the fixnum ,overhead)
    907             (the fixnum (list-size ,(if args-p args '(cdr x))))))))
     728            (the fixnum
     729                 (list-size ,(if args-p
     730                     args
     731                   '(cdr x))))))))
    908732         (cond ((setq tem (get fn 'estimate-code-size))
    909733          (typecase tem
    910734      (fixnum (f tem))
    911735      (t (funcall tem x env))))
    912          ((setq tem (assoc fn *special-code-sizes*)) (f (second tem)))
    913          #+Genera
    914          ((eq fn 'compiler:invisible-references) (list-size (cddr x)))
     736         ((setq tem (assoc fn *special-code-sizes*))
     737          (f (second tem)))
    915738         ((eq fn 'cond)
    916           (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n)))
     739          (dolist (clause (cdr x) n)
     740      (incf n (list-size clause)) (incf n)))
    917741         ((eq fn 'desetq)
    918742          (do ((l (cdr x) (cdr l))) ((null l) n)
    919       (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env)))))
     743      (setq n (+ n
     744           (destructuring-size (car l))
     745           (estimate-code-size-1 (cadr l) env)))))
    920746         ((member fn '(setq psetq))
    921747          (do ((l (cdr x) (cdr l))) ((null l) n)
     
    923749         ((eq fn 'go) 1)
    924750         ((eq fn 'function)
    925           ;;This skirts the issue of implementationally-defined lambda macros
    926           ;; by recognizing CL function names and nothing else.
    927           (if (or (symbolp (cadr x))
     751          (if #+sbcl
     752                          (sb!int:legal-fun-name-p (cadr x))
     753                          #+armedbear
     754                          (or (symbolp (cadr x))
    928755            (and (consp (cadr x)) (eq (caadr x) 'setf)))
    929756        1
     757        ;; FIXME: This tag appears not to be present
     758        ;; anywhere.
    930759        (throw 'duplicatable-code-p nil)))
    931          ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x)))
    932          ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env)))
    933          ((or (special-operator-p fn) (member fn *estimate-code-size-punt*))
     760         ((eq fn 'multiple-value-setq)
     761          (f (length (second x)) (cddr x)))
     762         ((eq fn 'return-from)
     763          (1+ (estimate-code-size-1 (third x) env)))
     764         ((or (special-operator-p fn)
     765        (member fn *estimate-code-size-punt*))
    934766          (throw 'estimate-code-size nil))
    935          (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env)
     767         (t (multiple-value-bind (new-form expanded-p)
     768          (macroexpand-1 x env)
    936769        (if expanded-p
    937770            (estimate-code-size-1 new-form env)
     
    940773
    941774
    942 
    943 ;;;; Loop Errors
    944 
     775;;;; loop errors
    945776
    946777(defun loop-context ()
     
    948779      ((eq l (cdr *loop-source-code*)) (nreverse new))))
    949780
    950 
    951781(defun loop-error (format-string &rest format-args)
    952   #+(or Genera CLOE) (declare (dbg:error-reporter))
    953   #+Genera (setq format-args (copy-list format-args)) ;Don't ask.
    954   #-armedbear
    955   (error 'program-error "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))
    956   #+armedbear
    957   (error 'program-error :format-control format-string :format-arguments format-args))
    958 
     782  (error 'program-error
     783   :format-control "~?~%current LOOP context:~{ ~S~}."
     784   :format-arguments (list format-string format-args (loop-context))))
    959785
    960786(defun loop-warn (format-string &rest format-args)
    961   (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context)))
    962 
     787  (warn "~?~%current LOOP context:~{ ~S~}."
     788  format-string
     789  format-args
     790  (loop-context)))
    963791
    964792(defun loop-check-data-type (specified-type required-type
     
    971799        specified-type required-type))
    972800        ((not a)
    973          (loop-error "Specified data type ~S is not a subtype of ~S."
     801         (loop-error "The specified data type ~S is not a subtype of ~S."
    974802         specified-type required-type)))
    975803  specified-type)))
    976804
    977805
    978 
    979 ;;;INTERFACE: Traditional, ANSI, Lucid.
    980 (defmacro loop-finish ()
    981   "Causes the iteration to terminate \"normally\", the same as implicit
    982 termination by an iteration driving clause, or by use of WHILE or
    983 UNTIL -- the epilogue code (if any) will be run, and any implicitly
    984 collected result will be returned as the value of the LOOP."
    985   '(go end-loop))
    986 
    987 
    988 
    989 
    990 #+cmu
    991806(defun subst-gensyms-for-nil (tree)
    992807  (declare (special *ignores*))
    993808  (cond
    994     ((null tree) (car (push (loop-gentemp) *ignores*)))
     809    ((null tree) (car (push (gensym "LOOP-IGNORED-VAR-") *ignores*)))
    995810    ((atom tree) tree)
    996811    (t (cons (subst-gensyms-for-nil (car tree))
    997812       (subst-gensyms-for-nil (cdr tree))))))
    998813
    999 #+cmu
     814(defmacro loop-destructuring-bind
     815    (lambda-list arg-list &rest body)
     816  (let ((*ignores* nil))
     817    (declare (special *ignores*))
     818    (let ((d-var-lambda-list (subst-gensyms-for-nil lambda-list)))
     819      `(destructuring-bind ,d-var-lambda-list
     820     ,arg-list
     821   (declare (ignore ,@*ignores*))
     822         ,@body))))
     823
    1000824(defun loop-build-destructuring-bindings (crocks forms)
    1001825  (if crocks
    1002       (let ((*ignores* ()))
    1003   (declare (special *ignores*))
    1004   `((destructuring-bind ,(subst-gensyms-for-nil (car crocks))
    1005         ,(cadr crocks)
    1006       (declare (ignore ,@*ignores*))
    1007       ,@(loop-build-destructuring-bindings (cddr crocks) forms))))
     826      `((loop-destructuring-bind ,(car crocks) ,(cadr crocks)
     827        ,@(loop-build-destructuring-bindings (cddr crocks) forms)))
    1008828      forms))
    1009829
    1010 (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*)
     830(defun loop-translate (*loop-source-code*
     831           *loop-macro-environment*
     832           *loop-universe*)
    1011833  (let ((*loop-original-source-code* *loop-source-code*)
    1012834  (*loop-source-context* nil)
    1013   (*loop-iteration-variables* nil)
    1014   (*loop-variables* nil)
    1015   (*loop-nodeclare* nil)
    1016   (*loop-named-variables* nil)
     835  (*loop-iteration-vars* nil)
     836  (*loop-vars* nil)
     837  (*loop-named-vars* nil)
    1017838  (*loop-declarations* nil)
    1018839  (*loop-desetq-crocks* nil)
     
    1028849  (*loop-final-value-culprit* nil)
    1029850  (*loop-inside-conditional* nil)
    1030   (*loop-when-it-variable* nil)
    1031   (*loop-never-stepped-variable* nil)
     851  (*loop-when-it-var* nil)
     852  (*loop-never-stepped-var* nil)
    1032853  (*loop-names* nil)
    1033854  (*loop-collection-cruft* nil))
     
    1039860         ,(nreverse *loop-body*)
    1040861         ,(nreverse *loop-after-body*)
    1041          ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
     862         ,(nreconc *loop-epilogue*
     863             (nreverse *loop-after-epilogue*)))))
    1042864      (dolist (entry *loop-bind-stack*)
    1043865  (let ((vars (first entry))
     
    1051873        ;;(when crocks (push crocks forms))
    1052874        (when dcls (push `(declare ,@dcls) forms))
    1053               #+cmu
    1054         (setq answer `(,(cond ((not vars) 'locally)
    1055             (*loop-destructuring-hooks* (first *loop-destructuring-hooks*))
    1056             (t 'let))
     875        (setq answer `(,(if vars 'let 'locally)
    1057876           ,vars
    1058            ,@(loop-build-destructuring-bindings crocks forms)))
    1059               #+armedbear
    1060         (setq answer `(,(cond ((not vars) 'locally)
    1061             (*loop-destructuring-hooks* (first *loop-destructuring-hooks*))
    1062             (t 'let))
    1063                               ,vars
    1064                               ,@forms))))))
    1065       (if *loop-names*
    1066     (do () ((null (car *loop-names*)) answer)
    1067       (setq answer `(block ,(pop *loop-names*) ,answer)))
    1068     `(block nil ,answer)))))
    1069 
     877           ,@(loop-build-destructuring-bindings crocks
     878                  forms)))))))
     879      (do () (nil)
     880  (setq answer `(block ,(pop *loop-names*) ,answer))
     881  (unless *loop-names* (return nil)))
     882      answer)))
    1070883
    1071884(defun loop-iteration-driver ()
     
    1073886    (let ((keyword (car *loop-source-code*)) (tem nil))
    1074887      (cond ((not (symbolp keyword))
    1075        (loop-error "~S found where LOOP keyword expected." keyword))
     888       (loop-error "~S found where LOOP keyword expected" keyword))
    1076889      (t (setq *loop-source-context* *loop-source-code*)
    1077890         (loop-pop-source)
    1078          (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*)))
    1079           ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.)
     891         (cond ((setq tem
     892          (loop-lookup-keyword keyword
     893             (loop-universe-keywords
     894              *loop-universe*)))
     895          ;; It's a "miscellaneous" toplevel LOOP keyword (DO,
     896          ;; COLLECT, NAMED, etc.)
    1080897          (apply (symbol-function (first tem)) (rest tem)))
    1081          ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*)))
     898         ((setq tem
     899          (loop-lookup-keyword keyword
     900             (loop-universe-iteration-keywords *loop-universe*)))
    1082901          (loop-hack-iteration tem))
    1083902         ((loop-tmember keyword '(and else))
    1084           ;; Alternative is to ignore it, ie let it go around to the next keyword...
    1085           (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
    1086           keyword (car *loop-source-code*) (cadr *loop-source-code*)))
    1087          (t (loop-error "~S is an unknown keyword in LOOP macro." keyword))))))))
    1088 
    1089 
     903          ;; The alternative is to ignore it, i.e. let it go
     904          ;; around to the next keyword...
     905          (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
     906          keyword
     907          (car *loop-source-code*)
     908          (cadr *loop-source-code*)))
     909         (t (loop-error "unknown LOOP keyword: ~S" keyword))))))))
    1090910
    1091911
     
    1095915      (loop-error "LOOP source code ran out when another token was expected.")))
    1096916
     917(defun loop-get-form ()
     918  (if *loop-source-code*
     919      (loop-pop-source)
     920      (loop-error "LOOP code ran out where a form was expected.")))
    1097921
    1098922(defun loop-get-compound-form ()
    1099923  (let ((form (loop-get-form)))
    1100924    (unless (consp form)
    1101       (loop-error "Compound form expected, but found ~A." form))
     925      (loop-error "A compound form was expected, but ~S found." form))
    1102926    form))
    1103927
     
    1110934       (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
    1111935
    1112 
    1113 (defun loop-get-form ()
    1114   (if *loop-source-code*
    1115       (loop-pop-source)
    1116       (loop-error "LOOP code ran out where a form was expected.")))
    1117 
    1118 
    1119936(defun loop-construct-return (form)
    1120937  `(return-from ,(car *loop-names*) ,form))
    1121938
    1122 
    1123939(defun loop-pseudo-body (form)
    1124   (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*))
     940  (cond ((or *loop-emitted-body* *loop-inside-conditional*)
     941   (push form *loop-body*))
    1125942  (t (push form *loop-before-loop*) (push form *loop-after-body*))))
    1126943
     
    1133950    (push (loop-construct-return form) *loop-after-epilogue*))
    1134951  (when *loop-final-value-culprit*
    1135     (loop-warn "LOOP clause is providing a value for the iteration,~@
    1136           however one was already established by a ~S clause."
     952    (loop-warn "The LOOP clause is providing a value for the iteration;~@
     953    however, one was already established by a ~S clause."
    1137954         *loop-final-value-culprit*))
    1138955  (setq *loop-final-value-culprit* (car *loop-source-context*)))
    1139956
    1140 
    1141957(defun loop-disallow-conditional (&optional kwd)
    1142   #+(or Genera CLOE) (declare (dbg:error-reporter))
    1143958  (when *loop-inside-conditional*
    1144959    (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
     
    1153968
    1154969
    1155 
    1156 
    1157 ;;;; Loop Types
    1158 
    1159 
    1160 (defun loop-typed-init (data-type)
     970;;;; loop types
     971
     972(defun loop-typed-init (data-type &optional step-var-p)
    1161973  (when (and data-type (subtypep data-type 'number))
    1162     (if (or (subtypep data-type 'float) #-armedbear (subtypep data-type '(complex float)))
    1163   (coerce 0 data-type)
    1164   0)))
    1165 
     974    (if (or (subtypep data-type 'float)
     975      (subtypep data-type '(complex float)))
     976  (coerce (if step-var-p 1 0) data-type)
     977  (if step-var-p 1 0))))
    1166978
    1167979(defun loop-optional-type (&optional variable)
    1168   ;;No variable specified implies that no destructuring is permissible.
    1169   (and *loop-source-code*     ;Don't get confused by NILs...
     980  ;; No variable specified implies that no destructuring is permissible.
     981  (and *loop-source-code* ; Don't get confused by NILs..
    1170982       (let ((z (car *loop-source-code*)))
    1171983   (cond ((loop-tequal z 'of-type)
    1172     ;;This is the syntactically unambigous form in that the form of the
    1173     ;; type specifier does not matter.  Also, it is assumed that the
    1174     ;; type specifier is unambiguously, and without need of translation,
    1175     ;; a common lisp type specifier or pattern (matching the variable) thereof.
     984    ;; This is the syntactically unambigous form in that
     985    ;; the form of the type specifier does not matter.
     986    ;; Also, it is assumed that the type specifier is
     987    ;; unambiguously, and without need of translation, a
     988    ;; common lisp type specifier or pattern (matching the
     989    ;; variable) thereof.
    1176990    (loop-pop-source)
    1177991    (loop-pop-source))
    1178992
    1179993         ((symbolp z)
    1180     ;;This is the (sort of) "old" syntax, even though we didn't used to support all of
    1181     ;; these type symbols.
    1182     (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*))
    1183              (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*)))))
     994    ;; This is the (sort of) "old" syntax, even though we
     995    ;; didn't used to support all of these type symbols.
     996    (let ((type-spec (or (gethash z
     997                (loop-universe-type-symbols
     998                 *loop-universe*))
     999             (gethash (symbol-name z)
     1000                (loop-universe-type-keywords
     1001                 *loop-universe*)))))
    11841002      (when type-spec
    11851003        (loop-pop-source)
    11861004        type-spec)))
    11871005         (t
    1188     ;;This is our sort-of old syntax.  But this is only valid for when we are destructuring,
    1189     ;; so we will be compulsive (should we really be?) and require that we in fact be
    1190     ;; doing variable destructuring here.  We must translate the old keyword pattern typespec
    1191     ;; into a fully-specified pattern of real type specifiers here.
     1006    ;; This is our sort-of old syntax. But this is only
     1007    ;; valid for when we are destructuring, so we will be
     1008    ;; compulsive (should we really be?) and require that
     1009    ;; we in fact be doing variable destructuring here. We
     1010    ;; must translate the old keyword pattern typespec
     1011    ;; into a fully-specified pattern of real type
     1012    ;; specifiers here.
    11921013    (if (consp variable)
    11931014        (unless (consp z)
    11941015         (loop-error
    1195       "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected."
     1016      "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected"
    11961017      z))
    1197         (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z))
     1018        (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z))
    11981019    (loop-pop-source)
    11991020    (labels ((translate (k v)
     
    12011022         ((atom k)
    12021023          (replicate
    1203             (or (gethash k (loop-universe-type-symbols *loop-universe*))
    1204           (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*))
     1024            (or (gethash k
     1025             (loop-universe-type-symbols
     1026              *loop-universe*))
     1027          (gethash (symbol-name k)
     1028             (loop-universe-type-keywords
     1029              *loop-universe*))
    12051030          (loop-error
    1206             "Destructuring type pattern ~S contains unrecognized type keyword ~S."
     1031            "The destructuring type pattern ~S contains the unrecognized type keyword ~S."
    12071032            z k))
    12081033            v))
    12091034         ((atom v)
    12101035          (loop-error
    1211             "Destructuring type pattern ~S doesn't match variable pattern ~S."
     1036            "The destructuring type pattern ~S doesn't match the variable pattern ~S."
    12121037            z variable))
    1213          (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v))))))
     1038         (t (cons (translate (car k) (car v))
     1039            (translate (cdr k) (cdr v))))))
    12141040       (replicate (typ v)
    1215          (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v))))))
     1041         (if (atom v)
     1042             typ
     1043             (cons (replicate typ (car v))
     1044             (replicate typ (cdr v))))))
    12161045      (translate z variable)))))))
    12171046
    12181047
    1219 
    1220 
    1221 ;;;; Loop Variables
    1222 
     1048;;;; loop variables
    12231049
    12241050(defun loop-bind-block ()
    1225   (when (or *loop-variables* *loop-declarations* *loop-wrappers*)
    1226     (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*)
     1051  (when (or *loop-vars* *loop-declarations* *loop-wrappers*)
     1052    (push (list (nreverse *loop-vars*)
     1053    *loop-declarations*
     1054    *loop-desetq-crocks*
     1055    *loop-wrappers*)
    12271056    *loop-bind-stack*)
    1228     (setq *loop-variables* nil
     1057    (setq *loop-vars* nil
    12291058    *loop-declarations* nil
    12301059    *loop-desetq-crocks* nil
    12311060    *loop-wrappers* nil)))
    12321061
    1233 (defun loop-variable-p (name)
    1234   (do ((entry *loop-bind-stack* (cdr entry))) (nil)
    1235     (cond ((null entry)
    1236      (return nil))
    1237     ((assoc name (caar entry) :test #'eq)
    1238     (return t)))))
    1239 
    1240 (defun loop-make-variable (name initialization dtype &optional iteration-variable-p)
     1062(defun loop-var-p (name)
     1063  (do ((entry *loop-bind-stack* (cdr entry)))
     1064      (nil)
     1065    (cond
     1066      ((null entry) (return nil))
     1067      ((assoc name (caar entry) :test #'eq) (return t)))))
     1068
     1069(defun loop-make-var (name initialization dtype &optional iteration-var-p step-var-p)
    12411070  (cond ((null name)
    1242    (cond ((not (null initialization))
    1243     (push (list (setq name (loop-gentemp 'loop-ignore-))
    1244           initialization)
    1245           *loop-variables*)
    1246     (push `(ignore ,name) *loop-declarations*))))
     1071   (setq name (gensym "LOOP-IGNORE-"))
     1072   (push (list name initialization) *loop-vars*)
     1073   (if (null initialization)
     1074       (push `(ignore ,name) *loop-declarations*)
     1075       (loop-declare-var name dtype)))
    12471076  ((atom name)
    1248    (cond (iteration-variable-p
    1249     (if (member name *loop-iteration-variables*)
    1250         (loop-error "Duplicated LOOP iteration variable ~S." name)
    1251         (push name *loop-iteration-variables*)))
    1252          ((assoc name *loop-variables*)
    1253     (loop-error "Duplicated variable ~S in LOOP parallel binding." name)))
     1077   (cond (iteration-var-p
     1078    (if (member name *loop-iteration-vars*)
     1079        (loop-error "duplicated LOOP iteration variable ~S" name)
     1080        (push name *loop-iteration-vars*)))
     1081         ((assoc name *loop-vars*)
     1082    (loop-error "duplicated variable ~S in LOOP parallel binding"
     1083          name)))
    12541084   (unless (symbolp name)
    1255      (loop-error "Bad variable ~S somewhere in LOOP." name))
    1256    (loop-declare-variable name dtype)
     1085     (loop-error "bad variable ~S somewhere in LOOP" name))
     1086   (loop-declare-var name dtype step-var-p)
    12571087   ;; We use ASSOC on this list to check for duplications (above),
    12581088   ;; so don't optimize out this list:
    1259    (push (list name (or initialization (loop-typed-init dtype)))
    1260          *loop-variables*))
     1089   (push (list name (or initialization (loop-typed-init dtype step-var-p)))
     1090         *loop-vars*))
    12611091  (initialization
    1262    (cond (*loop-destructuring-hooks*
    1263     (loop-declare-variable name dtype)
    1264     (push (list name initialization) *loop-variables*))
    1265          (t (let ((newvar (loop-gentemp 'loop-destructure-)))
    1266         (loop-declare-variable name dtype)
    1267         (push (list newvar initialization) *loop-variables*)
    1268         ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
    1269         (setq *loop-desetq-crocks*
    1270           (list* name newvar *loop-desetq-crocks*))
    1271         #+ignore
    1272         (loop-make-variable name nil dtype iteration-variable-p)))))
     1092   (let ((newvar (gensym "LOOP-DESTRUCTURE-")))
     1093           (loop-declare-var name dtype)
     1094           (push (list newvar initialization) *loop-vars*)
     1095           ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
     1096           (setq *loop-desetq-crocks*
     1097                 (list* name newvar *loop-desetq-crocks*))))
    12731098  (t (let ((tcar nil) (tcdr nil))
    12741099       (if (atom dtype) (setq tcar (setq tcdr dtype))
    12751100     (setq tcar (car dtype) tcdr (cdr dtype)))
    1276        (loop-make-variable (car name) nil tcar iteration-variable-p)
    1277        (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
     1101       (loop-make-var (car name) nil tcar iteration-var-p)
     1102       (loop-make-var (cdr name) nil tcdr iteration-var-p))))
    12781103  name)
    12791104
    1280 
    1281 (defun loop-make-iteration-variable (name initialization dtype)
    1282   (loop-make-variable name initialization dtype t))
    1283 
    1284 
    1285 (defun loop-declare-variable (name dtype)
     1105(defun loop-make-iteration-var (name initialization dtype)
     1106  (loop-make-var name initialization dtype t))
     1107
     1108(defun loop-declare-var (name dtype &optional step-var-p)
    12861109  (cond ((or (null name) (null dtype) (eq dtype t)) nil)
    12871110  ((symbolp name)
    1288    (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
    1289      (let ((dtype #-cmu dtype
    1290       #+cmu
    1291       (let ((init (loop-typed-init dtype)))
     1111   (unless (subtypep t dtype)
     1112     (let ((dtype (let ((init (loop-typed-init dtype step-var-p)))
    12921113        (if (typep init dtype)
    12931114            dtype
     
    12961117  ((consp name)
    12971118   (cond ((consp dtype)
    1298     (loop-declare-variable (car name) (car dtype))
    1299     (loop-declare-variable (cdr name) (cdr dtype)))
    1300          (t (loop-declare-variable (car name) dtype)
    1301       (loop-declare-variable (cdr name) dtype))))
    1302   (t (error "Invalid LOOP variable passed in: ~S." name))))
    1303 
     1119    (loop-declare-var (car name) (car dtype))
     1120    (loop-declare-var (cdr name) (cdr dtype)))
     1121         (t (loop-declare-var (car name) dtype)
     1122      (loop-declare-var (cdr name) dtype))))
     1123  (t (error "invalid LOOP variable passed in: ~S" name))))
    13041124
    13051125(defun loop-maybe-bind-form (form data-type)
    13061126  (if (loop-constantp form)
    13071127      form
    1308       (loop-make-variable (loop-gentemp 'loop-bind-) form data-type)))
    1309 
    1310 
     1128      (loop-make-var (gensym "LOOP-BIND-") form data-type)))
    13111129
    13121130
     
    13211139     (cond ((not (symbolp key))
    13221140      (loop-error
    1323         "~S found where keyword expected getting LOOP clause after ~S."
     1141        "~S found where keyword expected getting LOOP clause after ~S"
    13241142        key for))
    13251143           (t (setq *loop-source-context* *loop-source-code*)
     
    13281146             first-clause-p)
    13291147          (setq *loop-source-code*
    1330           (cons (or it-p (setq it-p (loop-when-it-variable)))
     1148          (cons (or it-p
     1149              (setq it-p
     1150              (loop-when-it-var)))
    13311151          (cdr *loop-source-code*))))
    13321152        (cond ((or (not (setq data (loop-lookup-keyword
    13331153                   key (loop-universe-keywords *loop-universe*))))
    1334              (progn (apply (symbol-function (car data)) (cdr data))
     1154             (progn (apply (symbol-function (car data))
     1155               (cdr data))
    13351156              (null *loop-body*)))
    13361157         (loop-error
     
    13411162         (if (loop-tequal (car *loop-source-code*) :and)
    13421163       (loop-pop-source)
    1343        (return (if (cdr body) `(progn ,@(nreverse body)) (car body)))))))
     1164       (return (if (cdr body)
     1165             `(progn ,@(nreverse body))
     1166             (car body)))))))
    13441167      (let ((then (get-clause for))
    13451168      (else (when (loop-tequal (car *loop-source-code*) :else)
     
    13541177         ,@else))))))
    13551178
    1356 
    13571179(defun loop-do-initially ()
    13581180  (loop-disallow-conditional :initially)
     
    13691191  (let ((name (loop-pop-source)))
    13701192    (unless (symbolp name)
    1371       (loop-error "~S is an invalid name for your LOOP." name))
     1193      (loop-error "~S is an invalid name for your LOOP" name))
    13721194    (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*)
    13731195      (loop-error "The NAMED ~S clause occurs too late." name))
     
    13751197      (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
    13761198      (car *loop-names*) name))
    1377     (setq *loop-names* (list name nil))))
     1199    (setq *loop-names* (list name))))
    13781200
    13791201(defun loop-do-return ()
    1380   (loop-pseudo-body (loop-construct-return (loop-get-form))))
    1381 
    1382 
    1383 
    1384 ;;;; Value Accumulation: List
    1385 
     1202  (loop-emit-body (loop-construct-return (loop-get-form))))
     1203
     1204
     1205;;;; value accumulation: LIST
    13861206
    13871207(defstruct (loop-collector
    1388        (:copier nil)
    1389        (:predicate nil))
     1208      (:copier nil)
     1209      (:predicate nil))
    13901210  name
    13911211  class
     
    13931213  (tempvars nil)
    13941214  dtype
    1395   (data nil))           ;collector-specific data
    1396 
     1215  (data nil)) ;collector-specific data
    13971216
    13981217(defun loop-get-collection-info (collector class default-type)
     
    14031222    (loop-pop-source))))
    14041223    (when (not (symbolp name))
    1405       (loop-error "Value accumulation recipient name, ~S, is not a symbol." name))
     1224      (loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
    14061225    (unless name
    14071226      (loop-disallow-aggregate-booleans))
     
    14111230           :key #'loop-collector-name)))
    14121231      (cond ((not cruft)
    1413        (when (and name (loop-variable-p name))
    1414          (loop-error "Variable ~S cannot be used in INTO clause" name))
     1232       (when (and name (loop-var-p name))
     1233         (loop-error "Variable ~S in INTO clause is a duplicate" name))
    14151234       (push (setq cruft (make-loop-collector
    14161235         :name name :class class
     
    14191238      (t (unless (eq (loop-collector-class cruft) class)
    14201239     (loop-error
    1421        "Incompatible kinds of LOOP value accumulation specified for collecting~@
    1422         ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S."
     1240       "incompatible kinds of LOOP value accumulation specified for collecting~@
     1241        ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S"
    14231242       name (car (loop-collector-history cruft)) collector))
    14241243         (unless (equal dtype (loop-collector-dtype cruft))
    14251244     (loop-warn
    1426        "Unequal datatypes specified in different LOOP value accumulations~@
    1427        into ~S: ~S and ~S."
     1245       "unequal datatypes specified in different LOOP value accumulations~@
     1246       into ~S: ~S and ~S"
    14281247       name dtype (loop-collector-dtype cruft))
    14291248     (when (eq (loop-collector-dtype cruft) t)
     
    14321251      (values cruft form))))
    14331252
    1434 
    1435 (defun loop-list-collection (specifically)  ;NCONC, LIST, or APPEND
    1436   (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list)
     1253(defun loop-list-collection (specifically)  ; NCONC, LIST, or APPEND
     1254  (multiple-value-bind (lc form)
     1255      (loop-get-collection-info specifically 'list 'list)
    14371256    (let ((tempvars (loop-collector-tempvars lc)))
    14381257      (unless tempvars
    14391258  (setf (loop-collector-tempvars lc)
    1440         (setq tempvars (list* (loop-gentemp 'loop-list-head-)
    1441             (loop-gentemp 'loop-list-tail-)
     1259        (setq tempvars (list* (gensym "LOOP-LIST-HEAD-")
     1260            (gensym "LOOP-LIST-TAIL-")
    14421261            (and (loop-collector-name lc)
    14431262           (list (loop-collector-name lc))))))
    14441263  (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
    14451264  (unless (loop-collector-name lc)
    1446     (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars)))))
     1265    (loop-emit-final-value `(loop-collect-answer ,(car tempvars)
     1266                   ,@(cddr tempvars)))))
    14471267      (ecase specifically
    14481268  (list (setq form `(list ,form)))
    14491269  (nconc nil)
    14501270  (append (unless (and (consp form) (eq (car form) 'list))
    1451       (setq form `(loop-copylist* ,form)))))
     1271      (setq form `(copy-list ,form)))))
    14521272      (loop-emit-body `(loop-collect-rplacd ,tempvars ,form)))))
    14531273
    14541274
    1455 
    1456 ;;;; Value Accumulation: max, min, sum, count.
    1457 
    1458 
    1459 
    1460 (defun loop-sum-collection (specifically required-type default-type)  ;SUM, COUNT
     1275;;;; value accumulation: MAX, MIN, SUM, COUNT
     1276
     1277(defun loop-sum-collection (specifically required-type default-type);SUM, COUNT
    14611278  (multiple-value-bind (lc form)
    14621279      (loop-get-collection-info specifically 'sum default-type)
     
    14651282      (unless tempvars
    14661283  (setf (loop-collector-tempvars lc)
    1467         (setq tempvars (list (loop-make-variable
     1284        (setq tempvars (list (loop-make-var
    14681285             (or (loop-collector-name lc)
    1469            (loop-gentemp 'loop-sum-))
     1286           (gensym "LOOP-SUM-"))
    14701287             nil (loop-collector-dtype lc)))))
    14711288  (unless (loop-collector-name lc)
     
    14751292      `(when ,form
    14761293         (setq ,(car tempvars)
    1477          ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars)))))
     1294         (1+ ,(car tempvars))))
    14781295      `(setq ,(car tempvars)
    1479        (+ ,(hide-variable-reference t (car tempvars) (car tempvars))
     1296       (+ ,(car tempvars)
    14801297          ,form)))))))
    1481 
    1482 
    14831298
    14841299(defun loop-maxmin-collection (specifically)
    14851300  (multiple-value-bind (lc form)
    1486       (loop-get-collection-info specifically 'maxmin *loop-real-data-type*)
    1487     (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
     1301      (loop-get-collection-info specifically 'maxmin 'real)
     1302    (loop-check-data-type (loop-collector-dtype lc) 'real)
    14881303    (let ((data (loop-collector-data lc)))
    14891304      (unless data
    14901305  (setf (loop-collector-data lc)
    14911306        (setq data (make-loop-minimax
    1492          (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-))
     1307         (or (loop-collector-name lc)
     1308             (gensym "LOOP-MAXMIN-"))
    14931309         (loop-collector-dtype lc))))
    14941310  (unless (loop-collector-name lc)
     
    14961312      (loop-note-minimax-operation specifically data)
    14971313      (push `(with-minimax-value ,data) *loop-wrappers*)
    1498       (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form))
    1499       )))
    1500 
    1501 
    1502 
    1503 ;;;; Value Accumulation:  Aggregate Booleans
    1504 
    1505 ;;;ALWAYS and NEVER.
     1314      (loop-emit-body `(loop-accumulate-minimax-value ,data
     1315                  ,specifically
     1316                  ,form)))))
     1317
     1318
     1319;;;; value accumulation: aggregate booleans
     1320
     1321;;; handling the ALWAYS and NEVER loop keywords
     1322;;;
    15061323;;; Under ANSI these are not permitted to appear under conditionalization.
    15071324(defun loop-do-always (restrictive negate)
     
    15131330    (loop-emit-final-value t)))
    15141331
    1515 
    1516 
    1517 ;;;THERIS.
     1332;;; handling the THEREIS loop keyword
     1333;;;
    15181334;;; Under ANSI this is not permitted to appear under conditionalization.
    15191335(defun loop-do-thereis (restrictive)
     
    15211337  (loop-disallow-anonymous-collectors)
    15221338  (loop-emit-final-value)
    1523   (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
    1524          ,(loop-construct-return *loop-when-it-variable*))))
    1525 
     1339  (loop-emit-body `(when (setq ,(loop-when-it-var) ,(loop-get-form))
     1340        ,(loop-construct-return *loop-when-it-var*))))
    15261341
    15271342
     
    15301345  (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
    15311346
     1347(defun loop-do-repeat ()
     1348  (loop-disallow-conditional :repeat)
     1349  (let ((form (loop-get-form))
     1350  (type 'integer))
     1351    (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type)))
     1352      (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*)
     1353      (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*)
     1354      ;; FIXME: What should
     1355      ;;   (loop count t into a
     1356      ;;         repeat 3
     1357      ;;         count t into b
     1358      ;;         finally (return (list a b)))
     1359      ;; return: (3 3) or (4 3)? PUSHes above are for the former
     1360      ;; variant, L-P-B below for the latter.
     1361      #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop))))))
    15321362
    15331363(defun loop-do-with ()
     
    15401370         (loop-get-form))
    15411371        (t nil)))
    1542     (when (and var (loop-variable-p var))
     1372    (when (and var (loop-var-p var))
    15431373      (loop-error "Variable ~S has already been used" var))
    1544     (loop-make-variable var val dtype)
     1374    (loop-make-var var val dtype)
    15451375    (if (loop-tequal (car *loop-source-code*) :and)
    15461376  (loop-pop-source)
     
    15481378
    15491379
    1550 
    1551 ;;;; The iteration driver
     1380;;;; the iteration driver
    15521381
    15531382(defun loop-hack-iteration (entry)
     
    15551384     (cond ((null list-of-forms) nil)
    15561385     ((member t list-of-forms) '(go end-loop))
    1557      (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms))))
     1386     (t `(when ,(if (null (cdr (setq list-of-forms
     1387             (nreverse list-of-forms))))
    15581388        (car list-of-forms)
    15591389        (cons 'or list-of-forms))
     
    15691399   (tem) (data))
    15701400  (nil)
    1571       ;; Note we collect endtests in reverse order, but steps in correct
    1572       ;; order.  MAKE-ENDTEST does the nreverse for us.
    1573       (setq tem (setq data (apply (symbol-function (first entry)) (rest entry))))
     1401      ;; Note that we collect endtests in reverse order, but steps in correct
     1402      ;; order. MAKE-ENDTEST does the nreverse for us.
     1403      (setq tem (setq data
     1404          (apply (symbol-function (first entry)) (rest entry))))
    15741405      (and (car tem) (push (car tem) pre-step-tests))
    1575       (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem))))))
     1406      (setq steps (nconc steps (copy-list (car (setq tem (cdr tem))))))
    15761407      (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
    1577       (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem))))))
     1408      (setq pseudo-steps
     1409      (nconc pseudo-steps (copy-list (car (setq tem (cdr tem))))))
    15781410      (setq tem (cdr tem))
    15791411      (when *loop-emitted-body*
    1580   (loop-error "Iteration in LOOP follows body code."))
     1412  (loop-error "iteration in LOOP follows body code"))
    15811413      (unless tem (setq tem data))
    15821414      (when (car tem) (push (car tem) pre-loop-pre-step-tests))
    1583       (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem))))))
    1584       (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests))
    1585       (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem))))
     1415      ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough
     1416      ;; that it might be worth making it into an NCONCF macro.
     1417      (setq pre-loop-steps
     1418      (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem))))))
     1419      (when (car (setq tem (cdr tem)))
     1420  (push (car tem) pre-loop-post-step-tests))
     1421      (setq pre-loop-pseudo-steps
     1422      (nconc pre-loop-pseudo-steps (copy-list (cadr tem))))
    15861423      (unless (loop-tequal (car *loop-source-code*) :and)
    1587   (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps)
    1588           (make-endtest pre-loop-post-step-tests)
    1589           (loop-make-psetq pre-loop-steps)
    1590           (make-endtest pre-loop-pre-step-tests)
    1591           *loop-before-loop*)
    1592         *loop-after-body* (list* (loop-make-desetq pseudo-steps)
    1593                (make-endtest post-step-tests)
    1594                (loop-make-psetq steps)
    1595                (make-endtest pre-step-tests)
    1596                *loop-after-body*))
     1424  (setq *loop-before-loop*
     1425        (list* (loop-make-desetq pre-loop-pseudo-steps)
     1426         (make-endtest pre-loop-post-step-tests)
     1427         (loop-make-psetq pre-loop-steps)
     1428         (make-endtest pre-loop-pre-step-tests)
     1429         *loop-before-loop*))
     1430  (setq *loop-after-body*
     1431        (list* (loop-make-desetq pseudo-steps)
     1432         (make-endtest post-step-tests)
     1433         (loop-make-psetq steps)
     1434         (make-endtest pre-step-tests)
     1435         *loop-after-body*))
    15971436  (loop-bind-block)
    15981437  (return nil))
    1599       (loop-pop-source)       ; flush the "AND"
     1438      (loop-pop-source)       ; Flush the "AND".
    16001439      (when (and (not (loop-universe-implicit-for-required *loop-universe*))
    1601      (setq tem (loop-lookup-keyword
    1602            (car *loop-source-code*)
    1603            (loop-universe-iteration-keywords *loop-universe*))))
    1604   ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied.
     1440     (setq tem
     1441           (loop-lookup-keyword
     1442      (car *loop-source-code*)
     1443      (loop-universe-iteration-keywords *loop-universe*))))
     1444  ;; The latest ANSI clarification is that the FOR/AS after the AND must
     1445  ;; NOT be supplied.
    16051446  (loop-pop-source)
    16061447  (setq entry tem)))))
    16071448
    16081449
    1609 
    1610 ;;;; Main Iteration Drivers
    1611 
    1612 
    1613 ;FOR variable keyword ..args..
     1450;;;; main iteration drivers
     1451
     1452;;; FOR variable keyword ..args..
    16141453(defun loop-do-for ()
    16151454  (let* ((var (loop-pop-source))
     
    16231462           keyword
    16241463           (loop-universe-for-keywords *loop-universe*))))
    1625       (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword))
     1464      (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP."
     1465      keyword))
    16261466    (apply (car tem) var first-arg data-type (cdr tem))))
    16271467
    1628 (defun loop-do-repeat ()
    1629   (loop-disallow-conditional :repeat)
    1630   (let ((form (loop-get-form))
    1631   (type 'real))
    1632     (let ((var (loop-make-variable (loop-gentemp) form type)))
    1633       (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*)
    1634       (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*)
    1635       ;; FIXME: What should
    1636       ;;   (loop count t into a
    1637       ;;         repeat 3
    1638       ;;         count t into b
    1639       ;;         finally (return (list a b)))
    1640       ;; return: (3 3) or (4 3)? PUSHes above are for the former
    1641       ;; variant, L-P-B below for the latter.
    1642       #+nil (loop-pseudo-body `(when (minusp (decf ,var)) (go end-loop))))))
    1643 
    1644 (defun loop-when-it-variable ()
    1645   (or *loop-when-it-variable*
    1646       (setq *loop-when-it-variable*
    1647       (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
    1648 
    1649 
    1650 
    1651 ;;;; Various FOR/AS Subdispatches
    1652 
    1653 
    1654 ;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
    1655 ;;; is omitted (other than being more stringent in its placement), and like
    1656 ;;; the old "FOR x FIRST y THEN z" when the THEN is present.  I.e., the first
    1657 ;;; initialization occurs in the loop body (first-step), not in the variable binding
    1658 ;;; phase.
     1468(defun loop-when-it-var ()
     1469  (or *loop-when-it-var*
     1470      (setq *loop-when-it-var*
     1471      (loop-make-var (gensym "LOOP-IT-") nil nil))))
     1472
     1473
     1474;;;; various FOR/AS subdispatches
     1475
     1476;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when
     1477;;; the THEN is omitted (other than being more stringent in its
     1478;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN
     1479;;; is present. I.e., the first initialization occurs in the loop body
     1480;;; (first-step), not in the variable binding phase.
    16591481(defun loop-ansi-for-equals (var val data-type)
    1660   (loop-make-iteration-variable var nil data-type)
     1482  (loop-make-iteration-var var nil data-type)
    16611483  (cond ((loop-tequal (car *loop-source-code*) :then)
    1662    ;;Then we are the same as "FOR x FIRST y THEN z".
     1484   ;; Then we are the same as "FOR x FIRST y THEN z".
    16631485   (loop-pop-source)
    16641486   `(() (,var ,(loop-get-form)) () ()
    16651487     () (,var ,val) () ()))
    1666   (t ;;We are the same as "FOR x = y".
     1488  (t ;; We are the same as "FOR x = y".
    16671489   `(() (,var ,val) () ()))))
    16681490
    1669 
    16701491(defun loop-for-across (var val data-type)
    1671   (loop-make-iteration-variable var nil data-type)
    1672   (let ((vector-var (loop-gentemp 'loop-across-vector-))
    1673   (index-var (loop-gentemp 'loop-across-index-)))
     1492  (loop-make-iteration-var var nil data-type)
     1493  (let ((vector-var (gensym "LOOP-ACROSS-VECTOR-"))
     1494  (index-var (gensym "LOOP-ACROSS-INDEX-")))
    16741495    (multiple-value-bind (vector-form constantp vector-value)
    16751496  (loop-constant-fold-if-possible val 'vector)
    1676       (loop-make-variable
     1497      (loop-make-var
    16771498  vector-var vector-form
    16781499  (if (and (consp vector-form) (eq (car vector-form) 'the))
    16791500      (cadr vector-form)
    16801501      'vector))
    1681       #+Genera (push `(system:array-register ,vector-var) *loop-declarations*)
    1682       (loop-make-variable index-var 0 'fixnum)
     1502      (loop-make-var index-var 0 'fixnum)
    16831503      (let* ((length 0)
    16841504       (length-form (cond ((not constantp)
    1685          (let ((v (loop-gentemp 'loop-across-limit-)))
    1686            (push `(setq ,v (length ,vector-var)) *loop-prologue*)
    1687            (loop-make-variable v 0 'fixnum)))
     1505         (let ((v (gensym "LOOP-ACROSS-LIMIT-")))
     1506           (push `(setq ,v (length ,vector-var))
     1507           *loop-prologue*)
     1508           (loop-make-var v 0 'fixnum)))
    16881509        (t (setq length (length vector-value)))))
    16891510       (first-test `(>= ,index-var ,length-form))
     
    16971518      (setq other-test t)))
    16981519  `(,other-test ,step () ,pstep
    1699     ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep)))))))
    1700 
    1701 
    1702 
    1703 
    1704 ;;;; List Iteration
    1705 
     1520    ,@(and (not (eq first-test other-test))
     1521     `(,first-test ,step () ,pstep)))))))
     1522
     1523
     1524;;;; list iteration
    17061525
    17071526(defun loop-list-step (listvar)
    1708   ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any
    1709   ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used
    1710   ;; as the stepping function.
    1711   ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not
    1712   ;; recognizing FOO may defeat some LOOP optimizations.
     1527  ;; We are not equipped to analyze whether 'FOO is the same as #'FOO
     1528  ;; here in any sensible fashion, so let's give an obnoxious warning
     1529  ;; whenever 'FOO is used as the stepping function.
     1530  ;;
     1531  ;; While a Discerning Compiler may deal intelligently with
     1532  ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP
     1533  ;; optimizations.
    17131534  (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by)
    17141535      (loop-pop-source)
     
    17171538    (cond ((and (consp stepper) (eq (car stepper) 'quote))
    17181539     (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
    1719      (values `(funcall ,stepper ,listvar) nil))
     1540     `(funcall ,stepper ,listvar))
    17201541    ((and (consp stepper) (eq (car stepper) 'function))
    1721      (values (list (cadr stepper) listvar) (cadr stepper)))
    1722     (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function)
    1723              ,listvar)
    1724          nil)))))
    1725 
     1542     (list (cadr stepper) listvar))
     1543    (t
     1544     `(funcall ,(loop-make-var (gensym "LOOP-FN-") stepper 'function)
     1545         ,listvar)))))
    17261546
    17271547(defun loop-for-on (var val data-type)
    1728   (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
     1548  (multiple-value-bind (list constantp list-value)
     1549      (loop-constant-fold-if-possible val)
    17291550    (let ((listvar var))
    1730       (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type))
    1731       (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list)
    1732          (loop-make-iteration-variable var nil data-type)))
    1733       (multiple-value-bind (list-step step-function) (loop-list-step listvar)
    1734   (declare #+(and (not LOOP-Prefer-POP) (not CLOE)) (ignore step-function))
    1735   ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind.
     1551      (cond ((and var (symbolp var))
     1552       (loop-make-iteration-var var list data-type))
     1553      (t (loop-make-var (setq listvar (gensym)) list 'list)
     1554         (loop-make-iteration-var var nil data-type)))
     1555      (let ((list-step (loop-list-step listvar)))
    17361556  (let* ((first-endtest
    1737     (hide-variable-reference
    1738      (eq var listvar)
    1739      listvar
    1740      ;; the following should use `atom' instead of `endp', per
    1741      ;; [bug2428]
    1742      `(atom ,listvar)))
     1557    ;; mysterious comment from original CMU CL sources:
     1558    ;;   the following should use `atom' instead of `endp',
     1559    ;;   per [bug2428]
     1560    `(atom ,listvar))
    17431561         (other-endtest first-endtest))
    17441562    (when (and constantp (listp list-value))
    17451563      (setq first-endtest (null list-value)))
    17461564    (cond ((eq var listvar)
    1747      ;;Contour of the loop is different because we use the user's variable...
    1748      `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest
    1749        () () () ,first-endtest ()))
    1750     #+LOOP-Prefer-POP
    1751     ((and step-function
    1752           (let ((n (cdr (assoc step-function '((cdr . 1) (cddr . 2)
    1753                  (cdddr . 3) (cddddr . 4))))))
    1754       (and n (do ((l var (cdr l)) (i 0 (1+ i)))
    1755            ((atom l) (and (null l) (= i n)))
    1756          (declare (fixnum i))))))
    1757      (let ((step (mapcan #'(lambda (x) (list x `(pop ,listvar))) var)))
    1758        `(,other-endtest () () ,step ,first-endtest () () ,step)))
    1759     (t (let ((step `(,var ,listvar)) (pseudo `(,listvar ,list-step)))
     1565     ;; The contour of the loop is different because we
     1566     ;; use the user's variable...
     1567     `(() (,listvar ,list-step)
     1568       ,other-endtest () () () ,first-endtest ()))
     1569    (t (let ((step `(,var ,listvar))
     1570       (pseudo `(,listvar ,list-step)))
    17601571         `(,other-endtest ,step () ,pseudo
    17611572           ,@(and (not (eq first-endtest other-endtest))
    17621573            `(,first-endtest ,step () ,pseudo)))))))))))
    17631574
    1764 
    17651575(defun loop-for-in (var val data-type)
    1766   (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val)
    1767     (let ((listvar (loop-gentemp 'loop-list-)))
    1768       (loop-make-iteration-variable var nil data-type)
    1769       (loop-make-variable listvar list 'list)
    1770       (multiple-value-bind (list-step step-function) (loop-list-step listvar)
    1771   #-LOOP-Prefer-POP (declare (ignore step-function))
     1576  (multiple-value-bind (list constantp list-value)
     1577      (loop-constant-fold-if-possible val)
     1578    (let ((listvar (gensym "LOOP-LIST-")))
     1579      (loop-make-iteration-var var nil data-type)
     1580      (loop-make-var listvar list 'list)
     1581      (let ((list-step (loop-list-step listvar)))
    17721582  (let* ((first-endtest `(endp ,listvar))
    17731583         (other-endtest first-endtest)
     
    17761586    (when (and constantp (listp list-value))
    17771587      (setq first-endtest (null list-value)))
    1778     #+LOOP-Prefer-POP (when (eq step-function 'cdr)
    1779             (setq step `(,var (pop ,listvar)) pseudo-step nil))
    17801588    `(,other-endtest ,step () ,pseudo-step
    17811589      ,@(and (not (eq first-endtest other-endtest))
     
    17831591
    17841592
    1785 
    1786 ;;;; Iteration Paths
    1787 
     1593;;;; iteration paths
    17881594
    17891595(defstruct (loop-path
    1790        (:copier nil)
    1791        (:predicate nil))
     1596      (:copier nil)
     1597      (:predicate nil))
    17921598  names
    17931599  preposition-groups
     
    17961602  user-data)
    17971603
    1798 
    1799 (defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data)
    1800   (unless (listp names) (setq names (list names)))
    1801   ;; Can't do this due to CLOS bootstrapping problems.
    1802   #-(or Genera (and CLOE Source-Bootstrap)) (check-type universe loop-universe)
     1604(defun add-loop-path (names function universe
     1605          &key preposition-groups inclusive-permitted user-data)
     1606  (declare (type loop-universe universe))
     1607  (unless (listp names)
     1608    (setq names (list names)))
    18031609  (let ((ht (loop-universe-path-keywords universe))
    18041610  (lp (make-loop-path
     
    18061612        :function function
    18071613        :user-data user-data
    1808         :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups)
     1614        :preposition-groups (mapcar (lambda (x)
     1615              (if (listp x) x (list x)))
     1616            preposition-groups)
    18091617        :inclusive-permitted inclusive-permitted)))
    1810     (dolist (name names) (setf (gethash (symbol-name name) ht) lp))
     1618    (dolist (name names)
     1619      (setf (gethash (symbol-name name) ht) lp))
    18111620    lp))
    18121621
    18131622
    1814 
    1815 ;;; Note:  path functions are allowed to use loop-make-variable, hack
     1623;;; Note: Path functions are allowed to use LOOP-MAKE-VAR, hack
    18161624;;; the prologue, etc.
    18171625(defun loop-for-being (var val data-type)
    1818   ;; FOR var BEING each/the pathname prep-phrases using-stuff...
    1819   ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn.
     1626  ;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the =
     1627  ;; EACH or THE. Not clear if it is optional, so I guess we'll warn.
    18201628  (let ((path nil)
    18211629  (data nil)
     
    18271635     (loop-pop-source)
    18281636     (setq inclusive t)
    1829      (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her))
    1830        (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax."
     1637     (unless (loop-tmember (car *loop-source-code*)
     1638         '(:its :each :his :her))
     1639       (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax."
    18311640       (car *loop-source-code*)))
    18321641     (loop-pop-source)
    18331642     (setq path (loop-pop-source))
    18341643     (setq initial-prepositions `((:in ,val))))
    1835     (t (loop-error "Unrecognizable LOOP iteration path syntax.  Missing EACH or THE?")))
     1644    (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?")))
    18361645    (cond ((not (symbolp path))
    1837      (loop-error "~S found where a LOOP iteration path name was expected." path))
     1646     (loop-error
     1647      "~S was found where a LOOP iteration path name was expected."
     1648      path))
    18381649    ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
    18391650     (loop-error "~S is not the name of a LOOP iteration path." path))
     
    18421653    (let ((fun (loop-path-function data))
    18431654    (preps (nconc initial-prepositions
    1844       (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t)))
     1655      (loop-collect-prepositional-phrases
     1656       (loop-path-preposition-groups data)
     1657       t)))
    18451658    (user-data (loop-path-user-data data)))
    18461659      (when (symbolp fun) (setq fun (symbol-function fun)))
     
    18481661          (apply fun var data-type preps :inclusive t user-data)
    18491662          (apply fun var data-type preps user-data))))
    1850     (when *loop-named-variables*
    1851       (loop-error "Unused USING variables: ~S." *loop-named-variables*))
    1852     ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back).  Protect the system from the user
    1853     ;; and the user from himself.
     1663    (when *loop-named-vars*
     1664      (loop-error "Unused USING vars: ~S." *loop-named-vars*))
     1665    ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back).
     1666    ;; Protect the system from the user and the user from himself.
    18541667    (unless (member (length stuff) '(6 10))
    18551668      (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
     
    18571670    (do ((l (car stuff) (cdr l)) (x)) ((null l))
    18581671      (if (atom (setq x (car l)))
    1859     (loop-make-iteration-variable x nil nil)
    1860     (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
     1672    (loop-make-iteration-var x nil nil)
     1673    (loop-make-iteration-var (car x) (cadr x) (caddr x))))
    18611674    (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
    18621675    (cddr stuff)))
    18631676
    18641677
    1865 
    1866 
    1867 ;;;INTERFACE:  Lucid, exported.
    1868 ;;; i.e., this is part of our extended ansi-loop interface.
    1869 (defun named-variable (name)
    1870   (let ((tem (loop-tassoc name *loop-named-variables*)))
     1678(defun loop-named-var (name)
     1679  (let ((tem (loop-tassoc name *loop-named-vars*)))
    18711680    (declare (list tem))
    1872     (cond ((null tem) (values (loop-gentemp) nil))
    1873     (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
     1681    (cond ((null tem) (values (gensym) nil))
     1682    (t (setq *loop-named-vars* (delete tem *loop-named-vars*))
    18741683       (values (cdr tem) t)))))
    18751684
    1876 
    1877 (defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases)
     1685(defun loop-collect-prepositional-phrases (preposition-groups
     1686             &optional
     1687             using-allowed
     1688             initial-phrases)
    18781689  (flet ((in-group-p (x group) (car (loop-tmember x group))))
    18791690    (do ((token nil)
     
    18821693   (this-prep nil nil)
    18831694   (disallowed-prepositions
    1884      (mapcan #'(lambda (x)
    1885            (loop-copylist*
    1886       (find (car x) preposition-groups :test #'in-group-p)))
     1695     (mapcan (lambda (x)
     1696         (copy-list
     1697          (find (car x) preposition-groups :test #'in-group-p)))
    18871698       initial-phrases))
    18881699   (used-prepositions (mapcar #'car initial-phrases)))
     
    18981709     (if (member this-prep used-prepositions)
    18991710         "A ~S prepositional phrase occurs multiply for some LOOP clause."
    1900          "Preposition ~S used when some other preposition has subsumed it.")
     1711         "Preposition ~S was used when some other preposition has subsumed it.")
    19011712     token))
    19021713       (setq used-prepositions (if (listp this-group)
     
    19051716       (loop-pop-source)
    19061717       (push (list this-prep (loop-get-form)) prepositional-phrases))
    1907       ((and USING-allowed (loop-tequal token 'using))
     1718      ((and using-allowed (loop-tequal token 'using))
    19081719       (loop-pop-source)
    19091720       (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
    19101721         (when (cadr z)
    1911      (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
     1722     (if (setq tem (loop-tassoc (car z) *loop-named-vars*))
    19121723         (loop-error
    19131724           "The variable substitution for ~S occurs twice in a USING phrase,~@
    1914             with ~S and ~S."
     1725      with ~S and ~S."
    19151726           (car z) (cadr z) (cadr tem))
    1916          (push (cons (car z) (cadr z)) *loop-named-variables*)))
    1917          (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*)))
     1727         (push (cons (car z) (cadr z)) *loop-named-vars*)))
     1728         (when (or (null *loop-source-code*)
     1729       (symbolp (car *loop-source-code*)))
    19181730     (return nil))))
    19191731      (t (return (nreverse prepositional-phrases)))))))
    19201732
    19211733
    1922 
    1923 ;;;; Master Sequencer Function
    1924 
    1925 
    1926 (defun loop-sequencer (indexv indexv-type indexv-user-specified-p
    1927         variable variable-type
    1928         sequence-variable sequence-type
    1929         step-hack default-top
    1930         prep-phrases)
    1931    (let ((endform nil)        ;Form (constant or variable) with limit value.
    1932    (sequencep nil)      ;T if sequence arg has been provided.
    1933    (testfn nil)       ;endtest function
    1934    (test nil)       ;endtest form.
    1935    (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment.
     1734;;;; master sequencer function
     1735
     1736(defun loop-sequencer (indexv indexv-type
     1737           variable variable-type
     1738           sequence-variable sequence-type
     1739           step-hack default-top
     1740           prep-phrases)
     1741   (let ((endform nil) ; form (constant or variable) with limit value
     1742   (sequencep nil) ; T if sequence arg has been provided
     1743   (testfn nil) ; endtest function
     1744   (test nil) ; endtest form
     1745   (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment
    19361746   (stepby-constantp t)
    1937    (step nil)       ;step form.
    1938    (dir nil)        ;Direction of stepping: NIL, :UP, :DOWN.
    1939    (inclusive-iteration nil)    ;T if include last index.
    1940    (start-given nil)      ;T when prep phrase has specified start
     1747   (step nil) ; step form
     1748   (dir nil) ; direction of stepping: NIL, :UP, :DOWN
     1749   (inclusive-iteration nil) ; T if include last index
     1750   (start-given nil) ; T when prep phrase has specified start
    19411751   (start-value nil)
    19421752   (start-constantp nil)
    1943    (limit-given nil)      ;T when prep phrase has specified end
     1753   (limit-given nil) ; T when prep phrase has specified end
    19441754   (limit-constantp nil)
    19451755   (limit-value nil)
    19461756   )
    1947      (when variable (loop-make-iteration-variable variable nil variable-type))
    1948      (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
    1949        (setq prep (caar l) form (cadar l))
    1950        (case prep
    1951    ((:of :in)
    1952     (setq sequencep t)
    1953     (loop-make-variable sequence-variable form sequence-type))
    1954    ((:from :downfrom :upfrom)
    1955     (setq start-given t)
    1956     (cond ((eq prep :downfrom) (setq dir ':down))
    1957     ((eq prep :upfrom) (setq dir ':up)))
    1958     (multiple-value-setq (form start-constantp start-value)
    1959       (loop-constant-fold-if-possible form indexv-type))
    1960     (loop-make-iteration-variable indexv form indexv-type))
    1961    ((:upto :to :downto :above :below)
    1962     (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up)))
    1963     ((loop-tequal prep :to) (setq inclusive-iteration t))
    1964     ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down)))
    1965     ((loop-tequal prep :above) (setq dir ':down))
    1966     ((loop-tequal prep :below) (setq dir ':up)))
    1967     (setq limit-given t)
    1968     (multiple-value-setq (form limit-constantp limit-value)
    1969       (loop-constant-fold-if-possible form indexv-type))
    1970     (setq endform (if limit-constantp
    1971           `',limit-value
    1972           (loop-make-variable
    1973             (loop-gentemp 'loop-limit-) form indexv-type))))
    1974    (:by
    1975      (multiple-value-setq (form stepby-constantp stepby)
    1976        (loop-constant-fold-if-possible form indexv-type))
    1977      (unless stepby-constantp
    1978        (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type)))
    1979    (t (loop-error
    1980         "~S invalid preposition in sequencing or sequence path.~@
    1981          Invalid prepositions specified in iteration path descriptor or something?"
    1982         prep)))
    1983        (when (and odir dir (not (eq dir odir)))
    1984    (loop-error "Conflicting stepping directions in LOOP sequencing path"))
    1985        (setq odir dir))
    1986      (when (and sequence-variable (not sequencep))
    1987        (loop-error "Missing OF or IN phrase in sequence path"))
    1988      ;; Now fill in the defaults.
    1989      (unless start-given
    1990        (loop-make-iteration-variable
    1991    indexv
    1992    (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0))
    1993    indexv-type))
    1994      (cond ((member dir '(nil :up))
    1995       (when (or limit-given default-top)
    1996         (unless limit-given
    1997     (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-))
    1998             nil indexv-type)
    1999     (push `(setq ,endform ,default-top) *loop-prologue*))
    2000         (setq testfn (if inclusive-iteration '> '>=)))
    2001       (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
    2002      (t (unless start-given
    2003     (unless default-top
    2004       (loop-error "Don't know where to start stepping."))
    2005     (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
    2006         (when (and default-top (not endform))
    2007     (setq endform (loop-typed-init indexv-type) inclusive-iteration t))
    2008         (when endform (setq testfn (if inclusive-iteration  '< '<=)))
    2009         (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
    2010      (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
    2011      (when step-hack
    2012        (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack))))
    2013      (let ((first-test test) (remaining-tests test))
    2014        (when (and stepby-constantp start-constantp limit-constantp)
    2015    (when (setq first-test (funcall (symbol-function testfn) start-value limit-value))
    2016      (setq remaining-tests t)))
    2017        `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack
    2018    () () ,first-test ,step-hack))))
    2019 
    2020 
    2021 
    2022 ;;;; Interfaces to the Master Sequencer
    2023 
    2024 
     1757     (flet ((assert-index-for-arithmetic (index)
     1758        (unless (atom index)
     1759    (loop-error "Arithmetic index must be an atom."))))
     1760       (when variable (loop-make-iteration-var variable nil variable-type))
     1761       (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
     1762   (setq prep (caar l) form (cadar l))
     1763   (case prep
     1764     ((:of :in)
     1765      (setq sequencep t)
     1766      (loop-make-var sequence-variable form sequence-type))
     1767     ((:from :downfrom :upfrom)
     1768      (setq start-given t)
     1769      (cond ((eq prep :downfrom) (setq dir ':down))
     1770      ((eq prep :upfrom) (setq dir ':up)))
     1771      (multiple-value-setq (form start-constantp start-value)
     1772        (loop-constant-fold-if-possible form indexv-type))
     1773      (assert-index-for-arithmetic indexv)
     1774      ;; KLUDGE: loop-make-var generates a temporary symbol for
     1775      ;; indexv if it is NIL. We have to use it to have the index
     1776      ;; actually count
     1777      (setq indexv (loop-make-iteration-var indexv form indexv-type)))
     1778     ((:upto :to :downto :above :below)
     1779      (cond ((loop-tequal prep :upto) (setq inclusive-iteration
     1780              (setq dir ':up)))
     1781      ((loop-tequal prep :to) (setq inclusive-iteration t))
     1782      ((loop-tequal prep :downto) (setq inclusive-iteration
     1783                (setq dir ':down)))
     1784      ((loop-tequal prep :above) (setq dir ':down))
     1785      ((loop-tequal prep :below) (setq dir ':up)))
     1786      (setq limit-given t)
     1787      (multiple-value-setq (form limit-constantp limit-value)
     1788        (loop-constant-fold-if-possible form `(and ,indexv-type real)))
     1789      (setq endform (if limit-constantp
     1790            `',limit-value
     1791            (loop-make-var
     1792         (gensym "LOOP-LIMIT-") form
     1793         `(and ,indexv-type real)))))
     1794     (:by
     1795      (multiple-value-setq (form stepby-constantp stepby)
     1796        (loop-constant-fold-if-possible form `(and ,indexv-type (real (0)))))
     1797      (unless stepby-constantp
     1798        (loop-make-var (setq stepby (gensym "LOOP-STEP-BY-"))
     1799     form
     1800     `(and ,indexv-type (real (0)))
     1801     nil t)))
     1802     (t (loop-error
     1803     "~S invalid preposition in sequencing or sequence path;~@
     1804        maybe invalid prepositions were specified in iteration path descriptor?"
     1805     prep)))
     1806   (when (and odir dir (not (eq dir odir)))
     1807     (loop-error "conflicting stepping directions in LOOP sequencing path"))
     1808   (setq odir dir))
     1809       (when (and sequence-variable (not sequencep))
     1810   (loop-error "missing OF or IN phrase in sequence path"))
     1811       ;; Now fill in the defaults.
     1812       (if start-given
     1813     (when limit-given
     1814       ;; if both start and limit are given, they had better both
     1815       ;; be REAL.  We already enforce the REALness of LIMIT,
     1816       ;; above; here's the KLUDGE to enforce the type of START.
     1817       (flet ((type-declaration-of (x)
     1818          (and (eq (car x) 'type) (caddr x))))
     1819         (let ((decl (find indexv *loop-declarations*
     1820         :key #'type-declaration-of))
     1821         (%decl (find indexv *loop-declarations*
     1822          :key #'type-declaration-of
     1823          :from-end t)))
     1824     #+sbcl (aver (eq decl %decl))
     1825     (setf (cadr decl)
     1826           `(and real ,(cadr decl))))))
     1827     ;; default start
     1828     ;; DUPLICATE KLUDGE: loop-make-var generates a temporary
     1829     ;; symbol for indexv if it is NIL. See also the comment in
     1830     ;; the (:from :downfrom :upfrom) case
     1831     (progn
     1832       (assert-index-for-arithmetic indexv)
     1833       (setq indexv
     1834       (loop-make-iteration-var
     1835          indexv
     1836          (setq start-constantp t
     1837          start-value (or (loop-typed-init indexv-type) 0))
     1838          `(and ,indexv-type real)))))
     1839       (cond ((member dir '(nil :up))
     1840        (when (or limit-given default-top)
     1841    (unless limit-given
     1842      (loop-make-var (setq endform (gensym "LOOP-SEQ-LIMIT-"))
     1843         nil
     1844         indexv-type)
     1845      (push `(setq ,endform ,default-top) *loop-prologue*))
     1846    (setq testfn (if inclusive-iteration '> '>=)))
     1847        (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
     1848       (t (unless start-given
     1849      (unless default-top
     1850        (loop-error "don't know where to start stepping"))
     1851      (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
     1852    (when (and default-top (not endform))
     1853      (setq endform (loop-typed-init indexv-type)
     1854      inclusive-iteration t))
     1855    (when endform (setq testfn (if inclusive-iteration  '< '<=)))
     1856    (setq step
     1857          (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
     1858       (when testfn
     1859   (setq test
     1860         `(,testfn ,indexv ,endform)))
     1861       (when step-hack
     1862   (setq step-hack
     1863         `(,variable ,step-hack)))
     1864       (let ((first-test test) (remaining-tests test))
     1865   (when (and stepby-constantp start-constantp limit-constantp
     1866        (realp start-value) (realp limit-value))
     1867     (when (setq first-test
     1868           (funcall (symbol-function testfn)
     1869        start-value
     1870        limit-value))
     1871       (setq remaining-tests t)))
     1872   `(() (,indexv ,step)
     1873     ,remaining-tests ,step-hack () () ,first-test ,step-hack)))))
     1874
     1875
     1876;;;; interfaces to the master sequencer
    20251877
    20261878(defun loop-for-arithmetic (var val data-type kwd)
    20271879  (loop-sequencer
    2028     var (loop-check-data-type data-type 'number) t
    2029     nil nil nil nil nil nil
    2030     (loop-collect-prepositional-phrases
    2031       '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
    2032       nil (list (list kwd val)))))
    2033 
     1880   var (loop-check-data-type data-type 'number)
     1881   nil nil nil nil nil nil
     1882   (loop-collect-prepositional-phrases
     1883    '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
     1884    nil (list (list kwd val)))))
    20341885
    20351886(defun loop-sequence-elements-path (variable data-type prep-phrases
    2036             &key fetch-function size-function sequence-type element-type)
    2037   (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
    2038     (let ((sequencev (named-variable 'sequence)))
    2039       #+Genera (when (and sequencev
    2040         (symbolp sequencev)
    2041         sequence-type
    2042         (subtypep sequence-type 'vector)
    2043         (not (member (the symbol sequencev) *loop-nodeclare*)))
    2044      (push `(sys:array-register ,sequencev) *loop-declarations*))
     1887            &key
     1888            fetch-function
     1889            size-function
     1890            sequence-type
     1891            element-type)
     1892  (multiple-value-bind (indexv) (loop-named-var 'index)
     1893    (let ((sequencev (loop-named-var 'sequence)))
    20451894      (list* nil nil        ; dummy bindings and prologue
    20461895       (loop-sequencer
    2047          indexv 'fixnum indexv-user-specified-p
    2048          variable (or data-type element-type)
    2049          sequencev sequence-type
    2050          `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev)
    2051          prep-phrases)))))
    2052 
    2053 
    2054 
    2055 ;;;; Builtin LOOP Iteration Paths
    2056 
     1896        indexv 'fixnum
     1897        variable (or data-type element-type)
     1898        sequencev sequence-type
     1899        `(,fetch-function ,sequencev ,indexv)
     1900        `(,size-function ,sequencev)
     1901        prep-phrases)))))
     1902
     1903
     1904;;;; builtin LOOP iteration paths
    20571905
    20581906#||
     
    20631911||#
    20641912
    2065 (defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which)
    2066   (check-type which (member hash-key hash-value))
     1913(defun loop-hash-table-iteration-path (variable data-type prep-phrases
     1914               &key which)
     1915  (declare (type (member :hash-key :hash-value) which))
    20671916  (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
    2068    (loop-error "Too many prepositions!"))
    2069   ((null prep-phrases) (loop-error "Missing OF or IN in ~S iteration path.")))
    2070   (let ((ht-var (loop-gentemp 'loop-hashtab-))
    2071   (next-fn (loop-gentemp 'loop-hashtab-next-))
     1917   (loop-error "too many prepositions!"))
     1918  ((null prep-phrases)
     1919   (loop-error "missing OF or IN in ~S iteration path")))
     1920  (let ((ht-var (gensym "LOOP-HASHTAB-"))
     1921  (next-fn (gensym "LOOP-HASHTAB-NEXT-"))
    20721922  (dummy-predicate-var nil)
    20731923  (post-steps nil))
    20741924    (multiple-value-bind (other-var other-p)
    2075   (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
    2076       ;;@@@@ named-variable returns a second value of T if the name was actually
    2077       ;; specified, so clever code can throw away the gensym'ed up variable if
    2078       ;; it isn't really needed.
    2079       ;;The following is for those implementations in which we cannot put dummy NILs
    2080       ;; into multiple-value-setq variable lists.
    2081       #-Genera (setq other-p t
    2082          dummy-predicate-var (loop-when-it-variable))
     1925  (loop-named-var (ecase which
     1926        (:hash-key 'hash-value)
     1927        (:hash-value 'hash-key)))
     1928      ;; @@@@ LOOP-NAMED-VAR returns a second value of T if the name
     1929      ;; was actually specified, so clever code can throw away the
     1930      ;; GENSYM'ed-up variable if it isn't really needed. The
     1931      ;; following is for those implementations in which we cannot put
     1932      ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists.
     1933      (setq other-p t
     1934      dummy-predicate-var (loop-when-it-var))
    20831935      (let* ((key-var nil)
    20841936       (val-var nil)
    2085        (temp-val-var (loop-gentemp 'loop-hash-val-temp-))
    2086        (temp-key-var (loop-gentemp 'loop-hash-key-temp-))
    2087        (temp-predicate-var (loop-gentemp 'loop-hash-predicate-var-))
    2088        (variable (or variable (loop-gentemp)))
     1937       (variable (or variable (gensym "LOOP-HASH-VAR-TEMP-")))
    20891938       (bindings `((,variable nil ,data-type)
    20901939       (,ht-var ,(cadar prep-phrases))
    20911940       ,@(and other-p other-var `((,other-var nil))))))
    2092   (if (eq which 'hash-key)
    2093       (setq key-var variable val-var (and other-p other-var))
    2094       (setq key-var (and other-p other-var) val-var variable))
     1941  (ecase which
     1942    (:hash-key (setq key-var variable
     1943         val-var (and other-p other-var)))
     1944    (:hash-value (setq key-var (and other-p other-var)
     1945           val-var variable)))
    20951946  (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
    2096   (when (consp key-var)
    2097     (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
    2098            ,@post-steps))
    2099     (push `(,key-var nil) bindings))
    2100   (when (consp val-var)
    2101     (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
    2102            ,@post-steps))
    2103     (push `(,val-var nil) bindings))
    2104   `(,bindings       ;bindings
    2105     ()          ;prologue
    2106     ()          ;pre-test
    2107     ()          ;parallel steps
    2108     (not
    2109      (multiple-value-bind (,temp-predicate-var ,temp-key-var ,temp-val-var)
    2110          (,next-fn)
    2111        ;; We use M-V-BIND instead of M-V-SETQ because we only
    2112        ;; want to assign values to the key and val vars when we
    2113        ;; are in the hash table.  When we reach the end,
    2114        ;; TEMP-PREDICATE-VAR is NIL, and so are temp-key-var and
    2115        ;; temp-val-var.  This might break any type declarations
    2116        ;; on the key and val vars.
    2117        (when ,temp-predicate-var
    2118          (setq ,val-var ,temp-val-var)
    2119          (setq ,key-var ,temp-key-var))
    2120        (setq ,dummy-predicate-var ,temp-predicate-var)
    2121        )) ;post-test
     1947        (when (or (consp key-var) data-type)
     1948          (setq post-steps
     1949                `(,key-var ,(setq key-var (gensym "LOOP-HASH-KEY-TEMP-"))
     1950                           ,@post-steps))
     1951          (push `(,key-var nil) bindings))
     1952        (when (or (consp val-var) data-type)
     1953          (setq post-steps
     1954                `(,val-var ,(setq val-var (gensym "LOOP-HASH-VAL-TEMP-"))
     1955                           ,@post-steps))
     1956          (push `(,val-var nil) bindings))
     1957  `(,bindings                     ;bindings
     1958    ()                            ;prologue
     1959    ()                            ;pre-test
     1960    ()                            ;parallel steps
     1961    (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var)
     1962     (,next-fn)))           ;post-test
    21221963    ,post-steps)))))
    21231964
    2124 
    2125 (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types)
     1965(defun loop-package-symbols-iteration-path (variable data-type prep-phrases
     1966              &key symbol-types)
    21261967  (cond ((and prep-phrases (cdr prep-phrases))
    21271968   (loop-error "Too many prepositions!"))
    2128   ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
    2129    (loop-error "Unknow preposition ~S" (caar prep-phrases))))
     1969        ((and prep-phrases (not (member (caar prep-phrases) '(:in :of))))
     1970         (loop-error "Unknown preposition ~S." (caar prep-phrases))))
    21301971  (unless (symbolp variable)
    21311972    (loop-error "Destructuring is not valid for package symbol iteration."))
    2132   (let ((pkg-var (loop-gentemp 'loop-pkgsym-))
    2133   (next-fn (loop-gentemp 'loop-pkgsym-next-))
    2134   (variable (or variable (loop-gentemp)))
    2135   (pkg (or (cadar prep-phrases) '*package*)))
    2136     (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*)
    2137     `(((,variable nil ,data-type) (,pkg-var ,pkg))
     1973  (let ((pkg-var (gensym "LOOP-PKGSYM-"))
     1974  (next-fn (gensym "LOOP-PKGSYM-NEXT-"))
     1975  (variable (or variable (gensym "LOOP-PKGSYM-VAR-")))
     1976        (package (or (cadar prep-phrases) '*package*)))
     1977    (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types))
     1978    *loop-wrappers*)
     1979    `(((,variable nil ,data-type) (,pkg-var ,package))
    21381980      ()
    21391981      ()
    21401982      ()
    2141       (not (multiple-value-setq (,(progn
    2142             ;;@@@@ If an implementation can get away without actually
    2143             ;; using a variable here, so much the better.
    2144             #+Genera NIL
    2145             #-Genera (loop-when-it-variable))
     1983      (not (multiple-value-setq (,(loop-when-it-var)
    21461984         ,variable)
    21471985       (,next-fn)))
     
    21491987
    21501988
    2151 ;;;; ANSI Loop
     1989;;;; ANSI LOOP
    21521990
    21531991(defun make-ansi-loop-universe (extended-p)
    21541992  (let ((w (make-standard-loop-universe
    2155        :keywords `((named (loop-do-named))
     1993       :keywords '((named (loop-do-named))
    21561994       (initially (loop-do-initially))
    21571995       (finally (loop-do-finally))
     
    21652003       (nconc (loop-list-collection nconc))
    21662004       (nconcing (loop-list-collection nconc))
    2167        (count (loop-sum-collection count ,*loop-real-data-type* fixnum))
    2168        (counting (loop-sum-collection count ,*loop-real-data-type* fixnum))
     2005       (count (loop-sum-collection count
     2006                 real
     2007                 fixnum))
     2008       (counting (loop-sum-collection count
     2009              real
     2010              fixnum))
    21692011       (sum (loop-sum-collection sum number number))
    21702012       (summing (loop-sum-collection sum number number))
     
    21732015       (maximizing (loop-maxmin-collection max))
    21742016       (minimizing (loop-maxmin-collection min))
    2175        (always (loop-do-always t nil))  ; Normal, do always
    2176        (never (loop-do-always t t)) ; Negate the test on always.
     2017       (always (loop-do-always t nil)) ; Normal, do always
     2018       (never (loop-do-always t t)) ; Negate test on always.
    21772019       (thereis (loop-do-thereis t))
    2178        (while (loop-do-while nil :while)) ; Normal, do while
    2179        (until (loop-do-while t :until)) ; Negate the test on while
     2020       (while (loop-do-while nil :while)) ; Normal, do while
     2021       (until (loop-do-while t :until)) ;Negate test on while
    21802022       (when (loop-do-if when nil)) ; Normal, do when
    21812023       (if (loop-do-if if nil)) ; synonymous
    2182        (unless (loop-do-if unless t)) ; Negate the test on when
     2024       (unless (loop-do-if unless t)) ; Negate test on when
    21832025       (with (loop-do-with))
    2184       (repeat (loop-do-repeat)))
     2026                        (repeat (loop-do-repeat)))
    21852027       :for-keywords '((= (loop-ansi-for-equals))
    21862028           (across (loop-for-across))
     
    21912033           (upfrom (loop-for-arithmetic :upfrom))
    21922034           (below (loop-for-arithmetic :below))
    2193            (above (loop-for-arithmetic :above))
     2035                             (above (loop-for-arithmetic :above))
    21942036           (to (loop-for-arithmetic :to))
    21952037           (upto (loop-for-arithmetic :upto))
     
    21992041       :iteration-keywords '((for (loop-do-for))
    22002042           (as (loop-do-for)))
    2201        :type-symbols '(array atom bignum bit bit-vector character compiled-function
    2202            complex cons double-float fixnum float
    2203            function hash-table integer keyword list long-float
    2204            nil null number package pathname random-state
    2205            ratio rational readtable sequence short-float
    2206            simple-array simple-bit-vector simple-string
    2207            simple-vector single-float standard-char
    2208            stream string base-char
    2209           symbol t vector)
     2043       :type-symbols '(array atom bignum bit bit-vector character
     2044           compiled-function complex cons double-float
     2045           fixnum float function hash-table integer
     2046           keyword list long-float nil null number
     2047           package pathname random-state ratio rational
     2048           readtable sequence short-float simple-array
     2049           simple-bit-vector simple-string simple-vector
     2050           single-float standard-char stream string
     2051           base-char symbol t vector)
    22102052       :type-keywords nil
    22112053       :ansi (if extended-p :extended t))))
     
    22132055       :preposition-groups '((:of :in))
    22142056       :inclusive-permitted nil
    2215        :user-data '(:which hash-key))
     2057       :user-data '(:which :hash-key))
    22162058    (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
    22172059       :preposition-groups '((:of :in))
    22182060       :inclusive-permitted nil
    2219        :user-data '(:which hash-value))
     2061       :user-data '(:which :hash-value))
    22202062    (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
    22212063       :preposition-groups '((:of :in))
    22222064       :inclusive-permitted nil
    2223        :user-data '(:symbol-types (:internal :external :inherited)))
    2224     (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w
     2065       :user-data '(:symbol-types (:internal
     2066                 :external
     2067                 :inherited)))
     2068    (add-loop-path '(external-symbol external-symbols)
     2069       'loop-package-symbols-iteration-path w
    22252070       :preposition-groups '((:of :in))
    22262071       :inclusive-permitted nil
    22272072       :user-data '(:symbol-types (:external)))
    2228     (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w
     2073    (add-loop-path '(present-symbol present-symbols)
     2074       'loop-package-symbols-iteration-path w
    22292075       :preposition-groups '((:of :in))
    22302076       :inclusive-permitted nil
    2231        :user-data '(:symbol-types (:internal :external)))
     2077       :user-data '(:symbol-types (:internal
     2078                 :external)))
    22322079    w))
    22332080
    2234 
    22352081(defparameter *loop-ansi-universe*
    2236         (make-ansi-loop-universe nil))
    2237 
     2082  (make-ansi-loop-universe nil))
    22382083
    22392084(defun loop-standard-expansion (keywords-and-forms environment universe)
     
    22432088  `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
    22442089
    2245 
    2246 ;;;INTERFACE: ANSI
    22472090(defmacro loop (&environment env &rest keywords-and-forms)
    2248   #+Genera (declare (compiler:do-not-record-macroexpansions)
    2249         (zwei:indentation . zwei:indent-loop))
    22502091  (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*))
    22512092
    2252 #+allegro
    2253 (defun excl::complex-loop-expander (body env)
    2254   (loop-standard-expansion body env *loop-ansi-universe*))
    2255 
    2256 (provide :loop)
     2093(defmacro loop-finish ()
     2094  "Cause the iteration to terminate \"normally\", the same as implicit
     2095termination by an iteration driving clause, or by use of WHILE or
     2096UNTIL -- the epilogue code (if any) will be run, and any implicitly
     2097collected result will be returned as the value of the LOOP."
     2098  '(go end-loop))
     2099
     2100(provide "LOOP")
Note: See TracChangeset for help on using the changeset viewer.