(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LOOP" (USE "LISP" "XCL")) READTABLE "XCL" BASE 10)


(il:filecreated " 3-Dec-2025 12:36:20" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;3|
 62357  

      :edit-by "mth"

      :changes-to (il:functions cl::symbol-macrolet)

      :previous-date " 3-Dec-2025 11:51:58" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;2|
)


(il:prettycomprint il:xcl-loopcoms)

(il:rpaqq il:xcl-loopcoms

          ((file-environments il:loop)
           (il:structures simple-program-error)
           (il:variables *accumulators* *anonymous-accumulator* *boolean-terminator* *current-clause*
                  *current-keyword* *environment* *for-as-components* *for-as-subclauses* 
                  *hash-group* *for-as-prepositions* *ignorable* *it-symbol* *it-visible-p* 
                  *list-end-test* *loop-clauses* *loop-components* *loop-name* *loop-tokens* 
                  *message-prefix* *symbol-group* *temporaries*)
           (il:functions %keyword %list accumulate-in-list accumulation-clause accumulator-kind 
                  accumulator-spec along-with always-never-thereis-clause ambiguous-loop-result-error
                  append-context appendf bindings bound-variables by-step-fun car-type cdr-type 
                  check-multiple-bindings cl-external-p clause* clause1 compound-forms* 
                  compound-forms+ conditional-clause constant-bindings constant-function-p 
                  constant-vector constant-vector-p d-var-spec-p d-var-spec1 d-var-type-spec 
                  declarations default-binding default-bindings default-type default-value 
                  destructuring-multiple-value-bind destructuring-multiple-value-setq 
                  dispatch-for-as-subclause do-clause empty-p enumerate extended-loop fill-in 
                  finally-clause for for-as-across-subclause for-as-arithmetic-possible-prepositions
                  for-as-arithmetic-step-and-test-functions for-as-arithmetic-subclause 
                  for-as-being-subclause for-as-clause for-as-equals-then-subclause for-as-fill-in 
                  for-as-hash-subclause for-as-in-list-subclause for-as-on-list-subclause 
                  for-as-package-subclause for-as-parallel-p form-or-it form1 gensym-ignorable 
                  globally-special-p hash-d-var-spec initially-clause 
                  invalid-accumulator-combination-error keyword1 keyword? let-form loop-error 
                  loop-finish-test-forms loop-warn lp main-clause* mapappend 
                  multiple-value-list-argument-form multiple-value-list-form-p name-clause? one 
                  ordinary-bindings preposition1 preposition? psetq-forms quoted-form-p quoted-object
                  reduce-redundant-code repeat-clause return-clause selectable-clause simple-loop 
                  simple-var-p simple-var1 stray-of-type-error cl::symbol-macrolet type-spec? 
                  until-clause using-other-var variable-clause* while-clause with with-accumulators 
                  with-binding-forms with-clause with-iterator-forms with-list-accumulator 
                  with-loop-context with-numeric-accumulator with-temporaries zero)
           (il:functions loop)
           (il:prop (il:filetype il:makefile-environment il:copyright il:license)
                  il:xcl-loop)))

(define-file-environment il:loop
 :package (defpackage "LOOP" (:use "LISP" "XCL"))
   :readtable "XCL")

(define-condition simple-program-error
 (simple-condition program-error)
   nil)

(defvar *accumulators*
 nil)

(defvar *anonymous-accumulator*
 nil)

(defvar *boolean-terminator*
 nil)

(defvar *current-clause*
 nil)

(defvar *current-keyword*
 nil)

(defvar *environment*
)

(defvar *for-as-components*
)

(defvar *for-as-subclauses*

   (let ((table (make-hash-table)))
        (mapc #'(lambda (spec)
                       (destructuring-bind (subclause-name . keywords)
                              spec
                              (dolist (key keywords)
                                  (setf (gethash key table)
                                        subclause-name))))
              '((for-as-arithmetic-subclause
 :from :downfrom :upfrom :to :downto :upto :below :above
                       :by)
                (for-as-in-list-subclause
 :in)
                (for-as-on-list-subclause
 :on)
                (for-as-equals-then-subclause
 :=)
                (for-as-across-subclause
 :across)
                (for-as-being-subclause
 :being)))
        table)
   "A table mapping for-as prepositions to their processor function-designator.")

(defvar *hash-group*
 '(:hash-key :hash-keys :hash-value :hash-values))

(defvar *for-as-prepositions*

   (let ((prepositions nil))
        (maphash #'(lambda (key value)
                          (declare
 (ignore value))
                          (push key prepositions))
               *for-as-subclauses*)
        prepositions))

(defvar *ignorable*
 nil
   "Ignorable temporary variables in *temporaries*.")

(defvar *it-symbol*
 nil)

(defvar *it-visible-p*
 nil)

(defvar *list-end-test*
 'atom)

(defvar *loop-clauses*

   (let ((table (make-hash-table)))
        (mapc #'(lambda (spec)
                       (destructuring-bind (clause-name . keywords)
                              spec
                              (dolist (key keywords)
                                  (setf (gethash key table)
                                        clause-name))))
              '((for-as-clause
 :for :as)
                (with-clause
 :with)
                (do-clause
 :do :doing)
                (return-clause
 :return)
                (initially-clause
 :initially)
                (finally-clause
 :finally)
                (accumulation-clause
 :collect :collecting :append :appending :nconc :nconcing :count
                       :counting :sum :summing :maximize :maximizing :minimize :minimizing)
                (conditional-clause
 :if :when :unless)
                (repeat-clause
 :repeat)
                (always-never-thereis-clause
 :always :never :thereis)
                (while-clause
 :while)
                (until-clause
 :until)))
        table)
   "A table mapping loop keywords to their processor function-designator.")

(defvar *loop-components*
 nil)

(defvar *loop-name*
 nil)

(defvar *loop-tokens*
)

(defvar *message-prefix*
 "")

(defvar *symbol-group*
 '(:symbol :symbols :present-symbol :present-symbols :external-symbol 
                               :external-symbols))

(defvar *temporaries*
 nil
   "Temporary variables used in with-clauses and for-as-clauses.")

(defun %keyword
 (designator)
   (intern (string designator)
          "KEYWORD"))

(defun %list
 (designator)
                             (il:* il:\; "Edited 14-Mar-2024 11:46 by lmm")

   (if (listp designator)
       designator
       (list designator)))

(defun accumulate-in-list
 (form accumulator-spec)
   (destructuring-bind (name &key var splice &allow-other-keys)
          accumulator-spec
          (declare
 (ignore name))
          (let* ((copy-f (ecase *current-keyword*
                             ((:collect :collecting) 'list)
                             ((:append :appending) 'copy-list)
                             ((:nconc :nconcing) 'identity)))
                 (collecting-p (member *current-keyword* '(:collect :collecting)))
                 (last-f (if collecting-p
                             'cdr
                             'last))
                 (splicing-form (if collecting-p
                                    `(rplacd ,splice (setq ,splice (list ,form)))
                                    `(setf (cdr ,splice)
                                           (,copy-f ,form)
                                           ,splice
                                           (,last-f ,splice)))))
                (if (globally-special-p
 var)
                    (lp
 :do `(if ,splice
                                 ,splicing-form
                                 (setq ,splice (,last-f (setq ,var (,copy-f ,form))))))
                    (lp
 :do splicing-form)))))

(defun accumulation-clause
 ()
   (let* ((form (form-or-it
))
          (name (if (preposition?
 :into)
                    (simple-var1
)
                    (progn (setq *anonymous-accumulator* *current-keyword*)
                           (when *boolean-terminator* (ambiguous-loop-result-error
))
                           nil)))
          (accumulator-spec
 (accumulator-spec
 name)))
         (destructuring-bind (name &rest plist &key var &allow-other-keys)
                accumulator-spec
                (declare
 (ignore name))
                (ecase *current-keyword*
                    ((:collect :collecting :append :appending :nconc :nconcing) (accumulate-in-list

                                                                                 form 
                                                                                 accumulator-spec))
                    ((:count :counting) (lp
 :if form :do `(incf ,var)))
                    ((:sum :summing) (lp
 :do `(incf ,var ,form)))
                    ((:maximize :maximizing :minimize :minimizing) 
                       (let ((first-p (getf plist :first-p))
                             (fun (if (member *current-keyword* '(:maximize :maximizing))
                                      '<
                                      '>)))
                            (lp
 :do `(let ((value ,form))
                                          (cond
                                             (,first-p (setq ,first-p nil ,var value))
                                             ((,fun ,var value)
                                              (setq ,var value)))))))))))

(defun accumulator-kind
 (key)
   (ecase key
       ((:collect :collecting :append :appending :nconc :nconcing) :list)
       ((:sum :summing :count :counting) :total)
       ((:maximize :maximizing :minimize :minimizing) :limit)))

(defun accumulator-spec
 (name)
   (let* ((kind (accumulator-kind
 *current-keyword*))
          (spec (assoc name *accumulators*))
          (plist (cdr spec)))
         (if spec
             (if (not (eq kind (getf plist :kind)))
                 (invalid-accumulator-combination-error
 (reverse (getf plist :keys)))
                 (progn (pushnew *current-keyword* (getf plist :keys))
                        (when (member kind '(:total :limit))
                            (multiple-value-bind (type supplied-p)
                                   (type-spec?
)
                                   (when supplied-p
                                       (push type (getf plist :types)))))))
             (let ((var (or name (gensym "ACCUMULATOR-"))))
                  (setq plist `(:var ,var :kind ,kind :keys (,*current-keyword*)))
                  (ecase kind
                      (:list 
                         (setf (getf plist :splice)
                               (gensym "SPLICE-"))
                         (unless name
                             (fill-in
 :results `((cdr ,var)))))
                      ((:total :limit) 
                         (multiple-value-bind (type supplied-p)
                                (type-spec?
)
                                (when supplied-p
                                    (push type (getf plist :types))))
                         (when (eq kind :limit)
                             (let ((first-p (gensym "FIRST-P-")))
                                  (setf (getf plist :first-p)
                                        first-p)
                                  (with
 first-p t := t)))
                         (unless name
                             (fill-in
 :results `(,var)))))
                  (push (setq spec `(,name ,@plist))
                        *accumulators*)))
         spec))

(defun along-with
 (var type &key equals (then equals))
   (for-as-fill-in
 :bindings (apply #'bindings type var (when (quoted-form-p
 equals)
                                                            `(,equals))))
   (unless (quoted-form-p
 equals)
       (for-as-fill-in
 :after-head `((setq ,@(mapappend
 #'cdr (bindings
 type var equals))))))
   (for-as-fill-in
 :after-tail `((setq ,@(mapappend
 #'cdr (bindings
 type var then))))))

(defun always-never-thereis-clause
 ()
   (setq *boolean-terminator* *current-keyword*)
   (when *anonymous-accumulator* (ambiguous-loop-result-error
))
   (ecase *current-keyword*
       (:always 
          (lp
 :unless (form1
)
              :return nil :end)
          (fill-in
 :results '(t)))
       (:never (lp
 :always `(not ,(form1
))))
       (:thereis 
          (lp
 :if (form1
)
              :return :it :end)
          (fill-in
 :results '(nil)))))

(defun ambiguous-loop-result-error
 ()
   (error 'simple-program-error :format-control (append-context
 
                                               "~S cannot be used without `into' preposition with ~S"
                                                       )
          :format-arguments
          `(,*anonymous-accumulator* ,*boolean-terminator*)))

(defun append-context
 (message)
   (concatenate 'string message (let ((clause (ldiff *current-clause* *loop-tokens*)))
                                     (format nil "~%Current LOOP context:~{ ~S~}" clause))))

(define-modify-macro appendf
 (&rest args) append
   "Append onto list")

(defun bindings
 (d-type-spec d-var-spec &optional (value-form "NEVER USED" value-form-p))
   (cond
      ((null value-form-p)
       (default-bindings
 d-type-spec d-var-spec))
      ((quoted-form-p
 value-form)
       (constant-bindings
 d-type-spec d-var-spec (quoted-object
 value-form)))
      (t (ordinary-bindings
 d-type-spec d-var-spec value-form))))

(defun bound-variables
 (binding-form)
   (let ((operator (first binding-form))
         (second (second binding-form)))
        (ecase operator
            ((let let* symbol-macrolet) (mapcar #'first second))
            ((multiple-value-bind) second)
            ((with-package-iterator with-hash-table-iterator) `(,(first second))))))

(defun by-step-fun
 ()
   (if (preposition?
 :by)
       (form1
)
       '#'cdr))

(defun car-type
 (d-type-spec)
   (if (consp d-type-spec)
       (car d-type-spec)
       d-type-spec))

(defun cdr-type
 (d-type-spec)
   (if (consp d-type-spec)
       (cdr d-type-spec)
       d-type-spec))

(defun check-multiple-bindings
 (variables)
   (mapl #'(lambda (vars)
                  (when (member (first vars)
                               (rest vars))
                      (loop-error
 'simple-program-error :format-control 
                             "Variable ~S is bound more than once." :format-arguments
                             (list (first vars)))))
         variables))

(defun cl-external-p
 (symbol)
   (multiple-value-bind (cl-symbol status)
          (find-symbol (symbol-name symbol)
                 "CL")
          (and (eq symbol cl-symbol)
               (eq status :external))))

(defun clause*
 ()
   (loop
 (let ((key (keyword?
)))
              (unless key (return))
              (clause1
))))

(defun clause1
 ()
   (multiple-value-bind (clause-function-designator present-p)
          (gethash *current-keyword* *loop-clauses*)
          (unless present-p
              (loop-error
 "Unknown loop keyword ~S encountered." (car *current-clause*)))
          (let ((*message-prefix* (format nil "LOOP ~A clause: " *current-keyword*)))
               (funcall clause-function-designator))))

(defun compound-forms*
 ()
   (when (and *loop-tokens* (consp (car *loop-tokens*)))
       (cons (pop *loop-tokens*)
             (compound-forms*
))))

(defun compound-forms+
 ()
   (or (compound-forms*
)
       (loop-error
 "At least one compound form is needed.")))

(defun conditional-clause
 ()
   (let* ((*it-symbol* nil)
          (middle (gensym "MIDDLE-"))
          (bottom (gensym "BOTTOM-"))
          (test-form (if (eq *current-keyword* :unless)
                         `(not ,(form1
))
                         (form1
)))
          (condition-form `(unless ,test-form
                               (go ,middle))))
         (lp
 :do condition-form)
         (let ((*it-visible-p* t))
              (selectable-clause
))
         (loop
 (unless (preposition?
 :and)
                      (return))
               (selectable-clause
))
         (cond
            ((preposition?
 :else)
             (lp
 :do `(go ,bottom))
             (fill-in
 :body `(,middle))
             (let ((*it-visible-p* t))
                  (selectable-clause
))
             (loop
 (unless (preposition?
 :and)
                          (return))
                   (selectable-clause
))
             (fill-in
 :body `(,bottom)))
            (t (fill-in
 :body `(,middle))))
         (preposition?
 :end)
         (when *it-symbol*
             (with
 *it-symbol*)
             (setf (second condition-form)
                   `(setq ,*it-symbol* ,(second condition-form))))))

(defun constant-bindings
 (d-type-spec d-var-spec value)
   (let ((bindings
 nil))
        (labels ((dig (type var value)
                      (cond
                         ((null var)
                          nil)
                         ((simple-var-p
 var)
                          (appendf
 bindings `((,type ,var ',value))))
                         (t (dig (car-type
 type)
                                 (car var)
                                 (car value))
                            (dig (cdr-type
 type)
                                 (cdr var)
                                 (cdr value))))))
               (dig d-type-spec d-var-spec value)
               bindings)))

(defun constant-function-p
 (form)
   (let ((expansion (macroexpand form *environment*)))
        (and (consp expansion)
             (eq (first expansion)
                 'function)
             (symbolp (second expansion))
             (let ((symbol (second expansion)))
                  (and (cl-external-p
 symbol)
                       (fboundp symbol))))))

(defun constant-vector
 (form)
   (cond
      ((quoted-form-p
 form)
       (quoted-object
 form))
      ((vectorp form)
       form)
      (t (error "~S is not a vector form." form))))

(defun constant-vector-p
 (form)
   (or (quoted-form-p
 form)
       (vectorp form)))

(defun d-var-spec-p
 (spec)
   (or (simple-var-p
 spec)
       (null spec)
       (and (consp spec)
            (d-var-spec-p
 (car spec))
            (d-var-spec-p
 (cdr spec)))))

(defun d-var-spec1
 ()
   (unless (and *loop-tokens* (d-var-spec-p
 (car *loop-tokens*)))
          (loop-error
 "A destructured-variable-spec is missing."))
   (let ((d-var-spec (pop *loop-tokens*)))
        d-var-spec))

(defun d-var-type-spec
 ()
   (let ((var (d-var-spec1
))
         (type (type-spec?
)))
        (when (empty-p
 var)
            (unless (member type '(nil t))
                   (loop-warn
 "Type spec ~S is ignored." type))
            (setq var (gensym)
                  type t))
        (values var type)))

(defun declarations
 (bindings
)
   (let ((declarations
 (mapcan #'(lambda (binding)
                                        (destructuring-bind (type var . rest)
                                               binding
                                               (declare
 (ignore rest))
                                               (unless (eq type 't)
                                                   `((type ,type ,var)))))
                              bindings)))
        (when declarations
            `((declare
 ,@declarations)))))

(defun default-binding
 (type var)
   `(,(default-type
 type)
     ,var
     ,(default-value
 type)))

(defun default-bindings
 (d-type-spec d-var-spec)
   (let ((bindings
 nil))
        (labels ((dig (type var)
                      (cond
                         ((null var)
                          nil)
                         ((simple-var-p
 var)
                          (appendf
 bindings `(,(default-binding
 type var))))
                         (t (dig (car-type
 type)
                                 (car var))
                            (dig (cdr-type
 type)
                                 (cdr var))))))
               (dig d-type-spec d-var-spec)
               bindings)))

(defun default-type
 (type)
                            (il:* il:\; "Edited 13-Jun-2024 20:05 by mth")


   (il:* il:|;;| "Probably shouldn't ever happen, but if TYPE is NIL")


   (if (or (null type)
           (eq type t))
       t
       (let ((value (default-value
 type)))
            (if (typep value type)
                type
                (let ((default-type
 (type-of value)))
                     (if (subtypep type default-type)
                         default-type
                         (if (null value)
                             `(or null ,type)
                             `(or ,default-type ,type))))))))

(defun default-value
 (type)
                           (il:* il:\; "Edited 13-Jun-2024 20:31 by mth")

   (cond
      ((null type)

       (il:* il:|;;| "giving NIL specifically as the VAR type probably shouldn't happen, but seems to be \"legal\", so handle it")


       nil)
      ((subtypep type 'bignum)
       (1+ most-positive-fixnum))
      ((subtypep type 'integer)
       0)
      ((subtypep type 'ratio)
       1/10)
      ((subtypep type 'float)
       0.0)
      ((subtypep type 'number)
       0)
      ((subtypep type 'character)
       #\Space)
      ((subtypep type 'string)
       "")
      ((subtypep type 'bit-vector)
       #*0)
      ((subtypep type 'vector)
       #())
      ((subtypep type 'package)
       *package*)
      (t nil)))

(defun destructuring-multiple-value-bind
 (d-type-spec d-var-spec value-form)
   (let ((mv-bindings nil)
         (d-bindings nil)
         (padding-temps nil)
         temp)
        (do ((vars d-var-spec (cdr vars))
             (types d-type-spec (cdr-type
 types)))
            ((endp vars))
          (if (listp (car vars))
              (progn (setq temp (gensym))
                     (appendf
 mv-bindings `((t ,temp)))
                     (appendf
 d-bindings `((,(car-type
 types)
                                            ,(car vars)
                                            ,temp)))
                     (when (empty-p
 (car vars))
                           (push temp padding-temps)))
              (appendf
 mv-bindings `((,(car-type
 types)
                                      ,(car vars))))))
        (fill-in
 :binding-forms
               `((multiple-value-bind ,(mapcar #'second mv-bindings)
                        ,(multiple-value-list-argument-form
 value-form)
                        ,@(declarations
 mv-bindings)
                        ,@(when padding-temps
                              `((declare
 (ignore ,@padding-temps)))))))
        (let ((bindings
 (mapappend
 #'(lambda (d-binding)
                                            (apply #'bindings d-binding))
                               d-bindings)))
             (when bindings
                 (fill-in
 :binding-forms `(,(let-form
 bindings)))))))

(defun destructuring-multiple-value-setq
 (d-var-spec value-form &key iterator-p)
   (let (d-bindings mv-vars temp)
        (do ((vars d-var-spec (cdr vars)))
            ((endp vars))
          (if (listp (car vars))
              (progn (setq temp (or (pop *temporaries*)
                                    (gensym-ignorable
)))
                     (appendf
 mv-vars `(,temp))
                     (appendf
 d-bindings `((t ,(car vars)
                                              ,temp))))
              (appendf
 mv-vars `(,(car vars)))))
        (let ((mv-setq-form `(multiple-value-setq ,mv-vars ,value-form))
              (bindings
 nil))
             (do ((d-bindings d-bindings (cdr d-bindings)))
                 ((endp d-bindings))
               (destructuring-bind (type var temp)
                      (car d-bindings)
                      (declare
 (ignore type var))
                      (push temp *temporaries*)
                      (appendf
 bindings (apply #'bindings (car d-bindings)))))
             (when iterator-p
                 (setq mv-setq-form `(unless ,mv-setq-form (loop-finish))))
             (if bindings
                 `(progn ,mv-setq-form (setq ,@(mapappend
 #'cdr bindings)))
                 mv-setq-form))))

(defun dispatch-for-as-subclause
 (var type)
   (unless *loop-tokens* (loop-error
 "A preposition is missing."))
   (let ((preposition (preposition1
 *for-as-prepositions*)))
        (multiple-value-bind (subclause-function-designator present-p)
               (gethash preposition *for-as-subclauses*)
               (unless present-p (loop-error
 "Unknown preposition ~S is supplied." preposition))
               (push preposition *loop-tokens*)
               (funcall subclause-function-designator var type))))

(defun do-clause
 ()
   (fill-in
 :body (compound-forms+
)))

(defun empty-p
 (d-var-spec)
   (or (null d-var-spec)
       (and (consp d-var-spec)
            (empty-p
 (car d-var-spec))
            (empty-p
 (cdr d-var-spec)))))

(defun enumerate
 (items)
   (case (length items)
       (1 (format nil "~S" (first items)))
       (2 (format nil "~S and ~S" (first items)
                 (second items)))
       (t (format nil "~{~S, ~}and ~S" (butlast items)
                 (first (last items))))))

(defmacro extended-loop
 (&rest tokens &environment environment)
   (let
    ((*environment* environment))
    (with-loop-context

     tokens
     (let
      ((body-tag (gensym "LOOP-BODY-"))
       (epilogue-tag (gensym "LOOP-EPILOGUE-")))
      (name-clause?
)
      (variable-clause*
)
      (main-clause*
)
      (when *loop-tokens* (error "Loop form tail ~S remained unprocessed." *loop-tokens*))
      (reduce-redundant-code
)
      (destructuring-bind
       (&key binding-forms iterator-forms initially head neck body tail finally results)
       *loop-components*
       (check-multiple-bindings
 (append *temporaries* (mapappend
 #'bound-variables binding-forms)
                                       (mapcar #'(lambda (spec)
                                                        (getf (cdr spec)
                                                              :var))
                                              *accumulators*)))
       `(block ,*loop-name*
            ,(with-temporaries

              `(,*temporaries* :ignorable ,*ignorable*)
              (with-accumulators

               *accumulators*
               (with-binding-forms

                binding-forms
                (with-iterator-forms

                 iterator-forms
                 `(macrolet ((loop-finish nil '(go ,epilogue-tag)))
                         (tagbody ,@head ,@initially ,body-tag ,@neck ,@body ,@tail
                                (go ,body-tag)
                                ,epilogue-tag
                                ,@finally
                                ,@(when results
                                      `((return-from ,*loop-name* ,(car results))))))))))))))))

(defun fill-in
 (&rest args)
   (when args
       (appendf
 (getf *loop-components* (first args))
              (second args))
       (apply #'fill-in (cddr args))))

(defun finally-clause
 ()
   (fill-in
 :finally (compound-forms+
)))

(defun for
 (var type &rest rest)
   (let ((*loop-tokens* rest))
        (dispatch-for-as-subclause
 var type)))

(defun for-as-across-subclause
 (var type)
   (preposition1
 :across)
   (let* ((form (form1
))
          (vector (if (constant-vector-p
 form)
                      form
                      (gensym "VECTOR-")))
          (length (if (constant-vector-p
 form)
                      (length (constant-vector
 form))
                      (gensym "LENGTH-")))
          (i (gensym "INDEX-"))
          (at-least-one-iteration-p (and (constant-vector-p
 form)
                                         (plusp length))))
         (unless (constant-vector-p
 form)
             (for-as-fill-in
 :bindings `((t ,vector ,form))
                    :bindings2
                    `((fixnum ,length (length ,vector)))))
         (for-as-fill-in
 :bindings `((fixnum ,i 0))
                :head-tests
                (unless at-least-one-iteration-p
                    `((= ,i ,length)))
                :tail-psetq
                `(,i (1+ ,i))
                :tail-tests
                `((= ,i ,length)))
         (along-with
 var type :equals (if at-least-one-iteration-p
                                          `',(aref (constant-vector
 form)
                                                   0)
                                          `(aref ,vector ,i))
                :then
                `(aref ,vector ,i))))

(defun for-as-arithmetic-possible-prepositions
 (used-prepositions)
   (append (cond
              ((intersection '(:from :downfrom :upfrom)
                      used-prepositions)
               nil)
              ((intersection '(:downto :above)
                      used-prepositions)
               '(:from :downfrom))
              ((intersection '(:upto :below)
                      used-prepositions)
               '(:from :upfrom))
              (t '(:from :downfrom :upfrom)))
          (cond
             ((intersection '(:to :downto :upto :below :above)
                     used-prepositions)
              nil)
             ((find :upfrom used-prepositions)
              '(:to :upto :below))
             ((find :downfrom used-prepositions)
              '(:to :downto :above))
             (t '(:to :downto :upto :below :above)))
          (unless (find :by used-prepositions)
              '(:by))))

(defun for-as-arithmetic-step-and-test-functions
 (used-prepositions)
   (let ((up-p (subsetp used-prepositions '(:below :upto :upfrom :from :to :by))))
        (values (if up-p
                    '+
                    '-)
               (cond
                  ((member :to used-prepositions)
                   (if up-p
                       '>
                       '<))
                  ((member :upto used-prepositions)
                   '>)
                  ((member :below used-prepositions)
                   '>=)
                  ((member :downto used-prepositions)
                   '<)
                  ((member :above used-prepositions)
                   '<=)
                  (t nil)))))

(defun for-as-arithmetic-subclause
 (var type)
   (unless (simple-var-p
 var)
          (loop-error
 "Destructuring on a number is invalid."))
   (multiple-value-bind (subtype-p valid-p)
          (subtypep type 'real)
          (when (and (not subtype-p)
                     valid-p)
              (setq type 'real)))
   (let (from to by preposition used candidates bindings)
        (loop
 (setq candidates (or (for-as-arithmetic-possible-prepositions
 used)
                                   (return)))
              (push (or (setq preposition (preposition?
 candidates))
                        (return))
                    used)
              (let ((value-form (form1
)))
                   (if (member preposition '(:from :downfrom :upfrom))
                       (progn (setq from value-form)
                              (appendf
 bindings `((,type ,var ,from))))
                       (progn (when (not (constantp value-form *environment*))
                                  (let ((temp (gensym)))
                                       (appendf
 bindings `((number ,temp ,value-form)))
                                       (setq value-form temp)))
                              (ecase preposition
                                  ((:to :downto :upto :below :above) (setq to value-form))
                                  (:by (setq by value-form)))))))
        (unless (intersection used '(:from :downfrom :upfrom))
            (appendf
 bindings `((,type ,var ,(zero
 type)))))
        (multiple-value-bind (step test)
               (for-as-arithmetic-step-and-test-functions
 used)
               (let ((tests (when test
                                `((,test ,var ,to)))))
                    (for-as-fill-in
 :bindings bindings :head-tests tests :tail-psetq
                           `(,var (,step ,var ,(or by (one
 type))))
                           :tail-tests tests)))))

(defun for-as-being-subclause
 (var type)
   (preposition1
 :being)
   (preposition1
 '(:each :the))
   (let* ((kind (preposition1
 (append *hash-group* *symbol-group*))))
         (cond
            ((find kind *hash-group*)
             (for-as-hash-subclause
 var type kind))
            ((find kind *symbol-group*)
             (for-as-package-subclause
 var type kind))
            (t (loop-error
 "Internal logic error")))))

(defun for-as-clause
 ()
   (let ((*for-as-components* nil))
        (loop
 (multiple-value-bind (var type)
                     (d-var-type-spec
)
                     (dispatch-for-as-subclause
 var type))
              (unless (preposition?
 :and)
                     (return)))
        (destructuring-bind (&key bindings bindings2 before-head head-psetq head-tests after-head 
                                  before-tail tail-psetq tail-tests after-tail)
               *for-as-components*
               (fill-in
 :binding-forms `(,@(when bindings
                                               `(,(let-form
 bindings)))
                                         ,@(when bindings2
                                               `(,(let-form
 bindings2))))
                      :head
                      `(,@before-head ,@(psetq-forms
 head-psetq)
                              ,@(loop-finish-test-forms
 head-tests)
                              ,@after-head)
                      :tail
                      `(,@before-tail ,@(psetq-forms
 tail-psetq)
                              ,@(loop-finish-test-forms
 tail-tests)
                              ,@after-tail)))))

(defun for-as-equals-then-subclause
 (var type)
   (preposition1
 :=)
   (let* ((first (form1
))
          (then (if (preposition?
 :then)
                    (form1
)
                    first))
          (parallel-p (for-as-parallel-p
)))
         (for-as-fill-in
 :bindings (apply #'bindings type var (when (quoted-form-p
 first)
                                                                  `(,first))))
         (if (and (not parallel-p)
                  (consp var)
                  (multiple-value-list-form-p
 first))
             (for-as-fill-in
 :before-head `(,(destructuring-multiple-value-setq
 var (

                                                                    multiple-value-list-argument-form

                                                                                     first))))
             (unless (quoted-form-p
 first)
                 (for-as-fill-in
 :head-psetq (mapappend
 #'cdr (bindings
 type var first)))))
         (if (and (not parallel-p)
                  (consp var)
                  (multiple-value-list-form-p
 then))
             (for-as-fill-in
 :before-tail `(,(destructuring-multiple-value-setq
 var (

                                                                    multiple-value-list-argument-form

                                                                                     then))))
             (for-as-fill-in
 :tail-psetq (mapappend
 #'cdr (bindings
 type var then))))))

(defun for-as-fill-in
 (&rest key-list-pairs)
   (when key-list-pairs
       (destructuring-bind (key list . rest)
              key-list-pairs
              (appendf
 (getf *for-as-components* key)
                     list)
              (apply #'for-as-fill-in rest))))

(defun for-as-hash-subclause
 (var type kind)
   (let* ((hash-table (progn (preposition1
 '(:in :of))
                             (form1
)))
          (other-var (using-other-var
 kind))
          (for-as-parallel-p
 (for-as-parallel-p
))
          (returned-p (or (pop *temporaries*)
                          (gensym-ignorable
)))
          (iterator (gensym))
          narrow-typed-var narrow-type)
         (when (and (simple-var-p
 var)
                    (not (typep 'nil type)))
             (setq narrow-typed-var var narrow-type type)
             (setq var (gensym)
                   type
                   `(or null ,type))
             (for-as-fill-in
 :bindings `(,(default-binding
 narrow-type narrow-typed-var))))
         (flet ((iterator-form nil `(with-hash-table-iterator (,iterator ,hash-table))))
               (if for-as-parallel-p
                   (progn (unless (constantp hash-table *environment*)
                              (let ((temp (gensym "HASH-TABLE-")))
                                   (for-as-fill-in
 :bindings `((t ,temp ,hash-table)))
                                   (setq hash-table temp)))
                          (fill-in
 :iterator-forms `(,(iterator-form))))
                   (fill-in
 :binding-forms `(,(iterator-form)))))
         (let* ((d-var-spec (hash-d-var-spec
 returned-p var other-var kind))
                (d-mv-setq (destructuring-multiple-value-setq
 d-var-spec `(,iterator)
                                  :iterator-p t))
                (setters `(,d-mv-setq ,@(when narrow-typed-var
                                            `((setq ,narrow-typed-var ,var))))))
               (push returned-p *temporaries*)
               (for-as-fill-in
 :bindings `(,@(bindings
 type var)
                                           ,@(when other-var (bindings
 t other-var)))
                      :after-head setters :after-tail setters))))

(defun for-as-in-list-subclause
 (var type)
   (preposition1
 :in)
   (let ((*list-end-test* 'endp))
        (for
 `(,var)
             `(,type)
             :on
             (form1
)
             :by
             (by-step-fun
))))

(defun for-as-on-list-subclause
 (var type)
   (preposition1
 :on)
   (let* ((form (form1
))
          (by-step-fun
 (by-step-fun
))
          (test *list-end-test*)
          (list-var (if (simple-var-p
 var)
                        var
                        (gensym "LIST-")))
          (list-type (if (simple-var-p
 var)
                         type
                         t))
          (at-least-one-iteration-p (and (quoted-form-p
 form)
                                         (not (funcall test (quoted-object
 form))))))
         (for-as-fill-in
 :bindings `((,list-type ,list-var ,form)
                                     ,@(unless (constant-function-p
 by-step-fun)
                                           (let ((temp (gensym "STEPPER-")))
                                                (prog1 `((t ,temp ,by-step-fun))
                                                       (setq by-step-fun temp)))))
                :head-tests
                (unless at-least-one-iteration-p
                    `((,test ,list-var)))
                :tail-psetq
                `(,list-var (funcall ,by-step-fun ,list-var))
                :tail-tests
                `((,test ,list-var)))
         (unless (simple-var-p
 var)
             (along-with
 var type :equals (if at-least-one-iteration-p
                                              form
                                              list-var)
                    :then list-var))))

(defun for-as-package-subclause
 (var type kind)
   (let* ((package (if (preposition?
 '(:in :of))
                       (form1
)
                       '*package*))
          (for-as-parallel-p
 (for-as-parallel-p
))
          (returned-p (or (pop *temporaries*)
                          (gensym-ignorable
)))
          (iterator (gensym))
          (kinds (ecase kind
                     ((:symbol :symbols) '(:internal :external :inherited))
                     ((:present-symbol :present-symbols) '(:internal :external))
                     ((:external-symbol :external-symbols) '(:external)))))
         (unless (typep 'nil type)
             (setq type `(or null ,type)))
         (flet ((iterator-form nil `(with-package-iterator (,iterator ,package ,@kinds))))
               (if for-as-parallel-p
                   (progn (unless (constantp package *environment*)
                              (let ((temp (gensym "PACKAGE-")))
                                   (for-as-fill-in
 :bindings `((t ,temp ,package)))
                                   (setq package temp)))
                          (fill-in
 :iterator-forms `(,(iterator-form))))
                   (fill-in
 :binding-forms `(,(iterator-form)))))
         (let* ((d-var-spec `(,returned-p ,var))
                (d-mv-setq (destructuring-multiple-value-setq
 d-var-spec `(,iterator)
                                  :iterator-p t)))
               (push returned-p *temporaries*)
               (for-as-fill-in
 :bindings (bindings
 type var)
                      :after-head
                      `(,d-mv-setq)
                      :after-tail
                      `(,d-mv-setq)))))

(defun for-as-parallel-p
 ()
   (or *for-as-components* (and *loop-tokens* (symbolp (car *loop-tokens*))
                                (string= (symbol-name (car *loop-tokens*))
                                       "AND"))))

(defun form-or-it
 ()
   (if (and *it-visible-p* (preposition?
 :it))
       (or *it-symbol* (setq *it-symbol* (gensym)))
       (form1
)))

(defun form1
 ()
   (unless *loop-tokens* (loop-error
 "A normal lisp form is missing."))
   (pop *loop-tokens*))

(defun gensym-ignorable
 ()
   (let ((var (gensym)))
        (push var *ignorable*)
        var))

(defun globally-special-p
 (symbol)
   (assert (symbolp symbol))
   (il:variable-globally-special-p symbol))

(defun hash-d-var-spec
 (returned-p var other-var kind)
   (if (find kind '(:hash-key :hash-keys))
       `(,returned-p ,var ,other-var)
       `(,returned-p ,other-var ,var)))

(defun initially-clause
 ()
   (fill-in
 :initially (compound-forms+
)))

(defun invalid-accumulator-combination-error
 (keys)
   (loop-error
 "Accumulator ~S cannot be mixed with ~S." *current-keyword* (enumerate
 keys)))

(defun keyword1
 (keyword-list-designator &key prepositionp)
   (let ((keywords (%list
 keyword-list-designator)))
        (or (keyword?
 keywords)
            (let ((length (length keywords))
                  (kind (if prepositionp
                            "preposition"
                            "keyword")))
                 (case length
                     (0 (loop-error
 "A loop ~A is missing." kind))
                     (1 (loop-error
 "Loop ~A ~S is missing." kind (car keywords)))
                     (t (loop-error
 "One of the loop ~As ~S must be supplied." kind keywords)))))))

(defun keyword?
 (&optional keyword-list-designator)
   (and *loop-tokens* (symbolp (car *loop-tokens*))
        (let ((keyword-list (%list
 keyword-list-designator))
              (keyword (%keyword
 (car *loop-tokens*))))
             (and (or (null keyword-list)
                      (find keyword keyword-list))
                  (setq *current-clause* *loop-tokens* *loop-tokens* (rest *loop-tokens*)
                        *current-keyword* keyword)))))

(defun let-form
 (bindings
)
   `(let ,(mapcar #'cdr bindings)
         ,@(declarations
 bindings)))

(defun loop-error
 (datum &rest arguments)
   (when (stringp datum)
       (setq datum (append-context
 datum)))
   (apply #'error datum arguments))

(defun loop-finish-test-forms
 (tests)
   (case (length tests)
       (0 nil)
       (1 `((when ,@tests (loop-finish))))
       (t `((when (or ,@tests)
                  (loop-finish))))))

(defun loop-warn
 (datum &rest arguments)
   (when (stringp datum)
       (setq datum (append-context
 datum)))
   (apply #'warn datum arguments))

(defun lp
 (&rest tokens)
   (let ((*loop-tokens* tokens)
         *current-keyword* *current-clause*)
        (clause*
)
        (when *loop-tokens* (error "~S remained after lp." *loop-tokens*))))

(defun main-clause*
 ()
   (loop
 (if (keyword?
 '(:do :doing :return :if :when :unless :initially :finally :while :until 
                             :repeat :always :never :thereis :collect :collecting :append :appending
                             :nconc :nconcing :count :counting :sum :summing :maximize :maximizing 
                             :minimize :minimizing))
             (clause1
)
             (return))))

(defun mapappend
 (function &rest lists)
   (apply #'append (apply #'mapcar function lists)))

(defun multiple-value-list-argument-form
 (form)
   (let ((expansion form)
         (expanded-p nil))
        (loop
 (when (and (consp expansion)
                         (eq (first expansion)
                             'multiple-value-list))
                  (return (second expansion)))
              (multiple-value-setq (expansion expanded-p)
                     (macroexpand-1 expansion *environment*))
              (unless expanded-p (error "~S is not expanded into a multiple-value-list form." form)))
        ))

(defun multiple-value-list-form-p
 (form)
   (let (expanded-p)
        (loop
 (when (and (consp form)
                         (eq (first form)
                             'multiple-value-list))
                    (return t))
              (multiple-value-setq (form expanded-p)
                     (macroexpand-1 form *environment*))
              (unless expanded-p (return nil)))))

(defun name-clause?
 ()
   (when (keyword?
 :named)
       (unless *loop-tokens* (loop-error
 "A loop name is missing."))
       (let ((name (pop *loop-tokens*)))
            (unless (symbolp name)
                   (loop-error
 "~S cannot be a loop name which must be a symbol." name))
            (setq *loop-name* name))))

(defun one
 (type)
   (cond
      ((subtypep type 'short-float)
       1.0)
      ((subtypep type 'single-float)
       1.0)
      ((subtypep type 'double-float)
       1.0)
      ((subtypep type 'long-float)
       1.0)
      ((subtypep type 'float)
       1.0)
      (t 1)))

(defun ordinary-bindings
 (d-type-spec d-var-spec value-form)
   (let ((temporaries *temporaries*)
         (bindings
 nil))
        (labels ((dig (type var form temp)
                      (cond
                         ((empty-p
 var)
                          nil)
                         ((simple-var-p
 var)
                          (when temp (push temp temporaries))
                          (appendf
 bindings `((,type ,var ,form))))
                         ((empty-p
 (car var))
                          (dig (cdr-type
 type)
                               (cdr var)
                               `(cdr ,form)
                               temp))
                         ((empty-p
 (cdr var))
                          (when temp (push temp temporaries))
                          (dig (car-type
 type)
                               (car var)
                               `(car ,form)
                               nil))
                         (t (unless temp
                                (setq temp (or (pop temporaries)
                                               (gensym))))
                            (dig (car-type
 type)
                                 (car var)
                                 `(car (setq ,temp ,form))
                                 nil)
                            (dig (cdr-type
 type)
                                 (cdr var)
                                 `(cdr ,temp)
                                 temp)))))
               (dig d-type-spec d-var-spec value-form nil)
               (setq *temporaries* temporaries)
               bindings)))

(defun preposition1
 (&optional keyword-list-designator)
   (let ((*current-keyword* *current-keyword*)
         (*current-clause* *current-clause*))
        (keyword1
 keyword-list-designator :prepositionp t)))

(defun preposition?
 (&optional keyword-list-designator)
   (let ((*current-keyword* *current-keyword*)
         (*current-clause* *current-clause*))
        (keyword?
 keyword-list-designator)))

(defun psetq-forms
 (args)
   (assert (evenp (length args)))
   (case (length args)
       (0 nil)
       (2 `((setq ,@args)))
       (t `((psetq ,@args)))))

(defun quoted-form-p
 (form)
   (let ((expansion (macroexpand form *environment*)))
        (and (consp expansion)
             (eq (first expansion)
                 'quote))))

(defun quoted-object
 (form)
   (let ((expansion (macroexpand form *environment*)))
        (destructuring-bind (quote-special-operator object)
               expansion
               (assert (eq quote-special-operator 'quote))
               object)))

(defun reduce-redundant-code
 ()
   (when (null (getf *loop-components* :initially))
       (let ((rhead (reverse (getf *loop-components* :head)))
             (rtail (reverse (getf *loop-components* :tail)))
             (neck nil))
            (loop
 (when (or (null rhead)
                            (null rtail)
                            (not (equal (car rhead)
                                        (car rtail))))
                        (return))
                  (push (pop rhead)
                        neck)
                  (pop rtail))
            (setf (getf *loop-components* :head)
                  (nreverse rhead)
                  (getf *loop-components* :neck)
                  neck
                  (getf *loop-components* :tail)
                  (nreverse rtail)))))

(defun repeat-clause
 ()
                               (il:* il:\; "Edited  2-Apr-2024 12:55 by lmm")

   (let ((form (form1
)))
        (lp
 :for (gensym)
            :downfrom form :to 1)
        (clause*
)))

(defun return-clause
 ()
   (lp
 :do `(return-from ,*loop-name* ,(form-or-it
))))

(defun selectable-clause
 ()
   (let ((*current-keyword* *current-keyword*)
         (*current-clause* *current-clause*))
        (unless (keyword?
 '(:if :when :unless :do :doing :return :collect :collecting :append 
                                :appending :nconc :nconcing :count :counting :sum :summing :maximize
                                :maximizing :minimize :minimizing))
               (loop-error
 "A selectable-clause is missing."))
        (ecase *current-keyword*
            ((:if :when :unless) (conditional-clause
))
            ((:do :doing) (do-clause
))
            ((:return) (return-clause
))
            ((:collect :collecting :append :appending :nconc :nconcing :count :counting :sum :summing
                    :maximize :maximizing :minimize :minimizing) (accumulation-clause
)))))

(defmacro simple-loop
 (&rest compound-forms)
   (let ((top (gensym)))
        `(block nil
             (tagbody ,top ,@compound-forms (go ,top)))))

(defun simple-var-p
 (var)
   (and (not (null var))
        (symbolp var)))

(defun simple-var1
 ()
   (unless (and *loop-tokens* (simple-var-p
 (car *loop-tokens*)))
          (loop-error
 "A simple variable name is missing."))
   (pop *loop-tokens*))

(defun stray-of-type-error
 ()
   (loop-error
 "OF-TYPE keyword should be followed by a type spec."))

(defmacro cl::symbol-macrolet
 (vardefs &body body)
    (il:* il:\; "Edited  3-Dec-2025 12:34 by mth")


                                                      (il:* il:\; "Edited 24-Mar-2024 21:46 by lmm")


   (il:* il:|;;| "")


   `(progn ,@(il:subpair (cons 'setq (mapcar #'car vardefs))
                    (cons 'setf (mapcar #'cadr vardefs))
                    body)))

(defun type-spec?
 ()
   (let ((type t)
         (supplied-p nil))
        (when (or (and (preposition?
 :of-type)
                       (or *loop-tokens* (stray-of-type-error
)))
                  (and *loop-tokens* (member (car *loop-tokens*)
                                            '(fixnum float t nil))))
            (setq type (pop *loop-tokens*)
                  supplied-p t))
        (values type supplied-p)))

(defun until-clause
 ()
   (lp
 :while `(not ,(form1
))))

(defun using-other-var
 (kind)
   (let ((using-phrase (when (preposition?
 :using)
                             (pop *loop-tokens*)))
         (other-key-name (if (find kind '(:hash-key :hash-keys))
                             "HASH-VALUE"
                             "HASH-KEY")))
        (when using-phrase
            (destructuring-bind (other-key other-var)
                   using-phrase
                   (unless (string= other-key other-key-name)
                          (loop-error
 "Keyword ~A is missing." other-key-name))
                   other-var))))

(defun variable-clause*
 ()
   (loop
 (let ((key (keyword?
 '(:with :initially :finally :for :as))))
              (if key
                  (clause1
)
                  (return)))))

(defun while-clause
 ()
   (lp
 :unless (form1
)
       :do
       '(loop-finish)
       :end))

(defun with
 (var &optional (type t)
                 &key
                 (= (default-value
 type)))
   (fill-in
 :binding-forms `(,(let-form
 `((,type ,var ,=))))))

(defun with-accumulators
 (accumulator-specs form)
   (if (null accumulator-specs)
       form
       (destructuring-bind (spec . rest)
              accumulator-specs
              (ecase (getf (cdr spec)
                           :kind)
                  (:list (with-list-accumulator
 spec (with-accumulators
 rest form)))
                  ((:total :limit) (with-numeric-accumulator
 spec (with-accumulators
 rest form)))))))

(defun with-binding-forms
 (binding-forms form)
   (if (null binding-forms)
       form
       (destructuring-bind (binding-form0 . rest)
              binding-forms
              (append binding-form0 (list (with-binding-forms
 rest form))))))

(defun with-clause
 ()
   (let ((d-bindings nil))
        (loop
 (multiple-value-bind (var type)
                     (d-var-type-spec
)
                     (let ((rest (when (preposition?
 :=)
                                     `(,(form1
)))))
                          (appendf
 d-bindings `((,type ,var ,@rest)))))
              (unless (preposition?
 :and)
                     (return)))
        (destructuring-bind (d-binding0 . rest)
               d-bindings
               (if (and (null rest)
                        (cddr d-binding0)
                        (destructuring-bind (type var form)
                               d-binding0
                               (declare
 (ignore type))
                               (and (consp var)
                                    (multiple-value-list-form-p
 form))))
                   (apply #'destructuring-multiple-value-bind d-binding0)
                   (let ((bindings
 (mapappend
 #'(lambda (d-binding)
                                                       (apply #'bindings d-binding))
                                          d-bindings)))
                        (fill-in
 :binding-forms `(,(let-form
 bindings))))))))

(defun with-iterator-forms
 (iterator-forms form)
   (if (null iterator-forms)
       form
       (destructuring-bind ((iterator-macro spec) . rest)
              iterator-forms
              `(,iterator-macro ,spec ,(with-iterator-forms
 rest form)))))

(defun with-list-accumulator
 (accumulator-spec
 form)
  (il:* il:\; "Edited  8-Apr-2024 19:28 by lmm")

   (destructuring-bind (name &key var splice &allow-other-keys)
          accumulator-spec
          (let* ((anonymous-p (null name))
                 (list-var (if (or anonymous-p (globally-special-p
 var))
                               var
                               (gensym "LIST-")))
                 (value-form (if (and (not anonymous-p)
                                      (globally-special-p
 var))
                                 nil
                                 '(list nil)))
                 (form (if (and (not anonymous-p)
                                (not (globally-special-p
 var)))
                           `(cl::symbol-macrolet
 ((,var (cdr ,list-var)))
                                   ,form)
                           form)))
                `(let ((,list-var ,value-form))
                      (declare
 (type list ,list-var))
                      (let ((,splice ,list-var))
                           (declare
 (type list ,splice))
                           ,form)))))

(defmacro with-loop-context
 (tokens &body body)
   `(let ((*loop-tokens* ,tokens)
          (*loop-name* nil)
          (*current-keyword* nil)
          (*current-clause* nil)
          (*loop-components* nil)
          (*temporaries* nil)
          (*ignorable* nil)
          (*accumulators* nil)
          (*anonymous-accumulator* nil)
          (*boolean-terminator* nil)
          (*message-prefix* "LOOP: "))
         ,@body))

(defun with-numeric-accumulator
 (accumulator-spec
 form)
   (destructuring-bind (name &key var types &allow-other-keys)
          accumulator-spec
          (labels ((type-eq (a b)
                          (and (subtypep a b)
                               (subtypep b a))))
                 (when (null types)
                     (setq types '(number)))
                 (destructuring-bind (type0 . rest)
                        types
                        (when (and rest (notevery #'(lambda (type)
                                                           (type-eq type0 type))
                                               types))
                            (warn "Different types ~A are declared for ~A accumulator." (enumerate

                                                                                         types)
                                  (or name "the anonymous")))
                        (let ((type (if rest
                                        `(or ,type0 ,@rest)
                                        type0)))
                             `(let ((,var ,(zero
 type)))
                                   (declare
 (type ,type ,var))
                                   ,form))))))

(defun with-temporaries
 (temporary-specs form)
        (il:* il:\; "Edited 21-Mar-2024 11:50 by lmm")


                                                      (il:* il:\; "Edited 16-Mar-2024 14:22 by lmm")

   (destructuring-bind (temporaries &key ((:ignorable ignorable)))
          temporary-specs
          (if temporaries
              `(let ,temporaries ,@(when ignorable
                                       `((declare
 (ignorable ,@ignorable))))
                    ,form)
              form)))

(defun zero
 (type)
   (cond
      ((subtypep type 'short-float)
       0.0)
      ((subtypep type 'single-float)
       0.0)
      ((subtypep type 'double-float)
       0.0)
      ((subtypep type 'long-float)
       0.0)
      ((subtypep type 'float)
       0.0)
      (t 0)))

(defmacro loop
 (&rest forms)
   (if (every #'consp forms)
       `(simple-loop
 ,@forms)
       `(extended-loop
 ,@forms)))

(il:putprops il:xcl-loop
 il:filetype
 :compile-file)

(il:putprops il:xcl-loop
 il:makefile-environment
 (:readtable "XCL" :package (defpackage "LOOP"
                                                                                   (:use "LISP" "XCL"
                                                                                         ))))

(il:putprops il:xcl-loop
 il:copyright
 (("Interlisp.org" 2004)
                                       ("Yuji Minejima <ggb01164@nifty.ne.jp>")
                                       2002 2004 2024))

(il:putprops il:xcl-loop
 il:license
 "See COPYRIGHT and LICENSE in the repository
;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;;  * Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;;  * Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in
;;    the documentation and/or other materials provided with the
;;    distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; 'AS IS' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.")
(il:declare\: il:dontcopy
  (il:filemap (nil (6770 6855 (%keyword 6770 . 6855)) (6857 7040 (%list 6857 . 7040)) (7042 8299 (
accumulate-in-list 7042 . 8299)) (8301 9981 (accumulation-clause 8301 . 9981)) (9983 10217 (
accumulator-kind 9983 . 10217)) (10219 12108 (accumulator-spec 10219 . 12108)) (12110 12579 (
along-with 12110 . 12579)) (12581 13073 (always-never-thereis-clause 12581 . 13073)) (13075 13434 (
ambiguous-loop-result-error 13075 . 13434)) (13436 13651 (append-context 13436 . 13651)) (13730 14107 
(bindings 13730 . 14107)) (14109 14449 (bound-variables 14109 . 14449)) (14451 14541 (by-step-fun 
14451 . 14541)) (14543 14649 (car-type 14543 . 14649)) (14651 14757 (cdr-type 14651 . 14757)) (14759 
15156 (check-multiple-bindings 14759 . 15156)) (15158 15378 (cl-external-p 15158 . 15378)) (15380 
15509 (clause* 15380 . 15509)) (15511 15911 (clause1 15511 . 15911)) (15913 16070 (compound-forms* 
15913 . 16070)) (16072 16196 (compound-forms+ 16072 . 16196)) (16198 17456 (conditional-clause 16198
 . 17456)) (17458 18169 (constant-bindings 17458 . 18169)) (18171 18542 (constant-function-p 18171 . 
18542)) (18544 18738 (constant-vector 18544 . 18738)) (18740 18831 (constant-vector-p 18740 . 18831)) 
(18833 19025 (d-var-spec-p 18833 . 19025)) (19027 19257 (d-var-spec1 19027 . 19257)) (19259 19584 (
d-var-type-spec 19259 . 19584)) (19586 20146 (declarations 19586 . 20146)) (20148 20258 (
default-binding 20148 . 20258)) (20260 20873 (default-bindings 20260 . 20873)) (20875 21523 (
default-type 20875 . 21523)) (21525 22295 (default-value 21525 . 22295)) (22297 23787 (
destructuring-multiple-value-bind 22297 . 23787)) (23789 25074 (destructuring-multiple-value-setq 
23789 . 25074)) (25076 25603 (dispatch-for-as-subclause 25076 . 25603)) (25605 25674 (do-clause 25605
 . 25674)) (25676 25852 (empty-p 25676 . 25852)) (25854 26128 (enumerate 25854 . 26128)) (26130 27856 
(extended-loop 26130 . 27856)) (27858 28029 (fill-in 27858 . 28029)) (28031 28108 (finally-clause 
28031 . 28108)) (28110 28228 (for 28110 . 28228)) (28230 29586 (for-as-across-subclause 28230 . 29586)
) (29588 30510 (for-as-arithmetic-possible-prepositions 29588 . 30510)) (30512 31228 (
for-as-arithmetic-step-and-test-functions 30512 . 31228)) (31230 33175 (for-as-arithmetic-subclause 
31230 . 33175)) (33177 33627 (for-as-being-subclause 33177 . 33627)) (33629 34845 (for-as-clause 33629
 . 34845)) (34847 36375 (for-as-equals-then-subclause 34847 . 36375)) (36377 36655 (for-as-fill-in 
36377 . 36655)) (36657 38623 (for-as-hash-subclause 36657 . 38623)) (38625 38871 (
for-as-in-list-subclause 38625 . 38871)) (38873 40366 (for-as-on-list-subclause 38873 . 40366)) (40368
 42070 (for-as-package-subclause 40368 . 42070)) (42072 42303 (for-as-parallel-p 42072 . 42303)) (
42305 42453 (form-or-it 42305 . 42453)) (42455 42574 (form1 42455 . 42574)) (42576 42676 (
gensym-ignorable 42576 . 42676)) (42678 42789 (globally-special-p 42678 . 42789)) (42791 42970 (
hash-d-var-spec 42791 . 42970)) (42972 43053 (initially-clause 42972 . 43053)) (43055 43212 (
invalid-accumulator-combination-error 43055 . 43212)) (43214 43831 (keyword1 43214 . 43831)) (43833 
44303 (keyword? 43833 . 44303)) (44305 44414 (let-form 44305 . 44414)) (44416 44570 (loop-error 44416
 . 44570)) (44572 44763 (loop-finish-test-forms 44572 . 44763)) (44765 44917 (loop-warn 44765 . 44917)
) (44919 45123 (lp 44919 . 45123)) (45125 45562 (main-clause* 45125 . 45562)) (45564 45660 (mapappend 
45564 . 45660)) (45662 46192 (multiple-value-list-argument-form 45662 . 46192)) (46194 46587 (
multiple-value-list-form-p 46194 . 46587)) (46589 46927 (name-clause? 46589 . 46927)) (46929 47208 (
one 46929 . 47208)) (47210 48855 (ordinary-bindings 47210 . 48855)) (48857 49074 (preposition1 48857
 . 49074)) (49076 49277 (preposition? 49076 . 49277)) (49279 49439 (psetq-forms 49279 . 49439)) (49441
 49621 (quoted-form-p 49441 . 49621)) (49623 49878 (quoted-object 49623 . 49878)) (49880 50684 (
reduce-redundant-code 49880 . 50684)) (50686 50915 (repeat-clause 50686 . 50915)) (50917 51007 (
return-clause 50917 . 51007)) (51009 51844 (selectable-clause 51009 . 51844)) (51846 51997 (
simple-loop 51846 . 51997)) (51999 52077 (simple-var-p 51999 . 52077)) (52079 52263 (simple-var1 52079
 . 52263)) (52265 52372 (stray-of-type-error 52265 . 52372)) (52374 52768 (cl::symbol-macrolet 52374
 . 52768)) (52770 53204 (type-spec? 52770 . 53204)) (53206 53272 (until-clause 53206 . 53272)) (53274 
53855 (using-other-var 53274 . 53855)) (53857 54051 (variable-clause* 53857 . 54051)) (54053 54157 (
while-clause 54053 . 54157)) (54159 54338 (with 54159 . 54338)) (54340 54785 (with-accumulators 54340
 . 54785)) (54787 55037 (with-binding-forms 54787 . 55037)) (55039 56270 (with-clause 55039 . 56270)) 
(56272 56531 (with-iterator-forms 56272 . 56531)) (56533 57680 (with-list-accumulator 56533 . 57680)) 
(57682 58119 (with-loop-context 57682 . 58119)) (58121 59359 (with-numeric-accumulator 58121 . 59359))
 (59361 59882 (with-temporaries 59361 . 59882)) (59884 60164 (zero 59884 . 60164)) (60166 60299 (loop 
60166 . 60299)))))
il:stop