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


(il:filecreated "14-Jun-2024 23:09:54" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;4|
 62255  

      :edit-by "mth"

      :changes-to (il:functions default-type default-value)

      :previous-date " 8-Apr-2024 19:38:27" 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 24-Mar-2024 21:46 by lmm")


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


   `(progn ,@(il:subpair (cons 'setq (mapcar vardefs #'car))
                    (cons 'setf (mapcar vardefs #'cadr))
                    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 (6777 6862 (%keyword 6777 . 6862)) (6864 7047 (%list 6864 . 7047)) (7049 8306 (
accumulate-in-list 7049 . 8306)) (8308 9988 (accumulation-clause 8308 . 9988)) (9990 10224 (
accumulator-kind 9990 . 10224)) (10226 12115 (accumulator-spec 10226 . 12115)) (12117 12586 (
along-with 12117 . 12586)) (12588 13080 (always-never-thereis-clause 12588 . 13080)) (13082 13441 (
ambiguous-loop-result-error 13082 . 13441)) (13443 13658 (append-context 13443 . 13658)) (13737 14114 
(bindings 13737 . 14114)) (14116 14456 (bound-variables 14116 . 14456)) (14458 14548 (by-step-fun 
14458 . 14548)) (14550 14656 (car-type 14550 . 14656)) (14658 14764 (cdr-type 14658 . 14764)) (14766 
15163 (check-multiple-bindings 14766 . 15163)) (15165 15385 (cl-external-p 15165 . 15385)) (15387 
15516 (clause* 15387 . 15516)) (15518 15918 (clause1 15518 . 15918)) (15920 16077 (compound-forms* 
15920 . 16077)) (16079 16203 (compound-forms+ 16079 . 16203)) (16205 17463 (conditional-clause 16205
 . 17463)) (17465 18176 (constant-bindings 17465 . 18176)) (18178 18549 (constant-function-p 18178 . 
18549)) (18551 18745 (constant-vector 18551 . 18745)) (18747 18838 (constant-vector-p 18747 . 18838)) 
(18840 19032 (d-var-spec-p 18840 . 19032)) (19034 19264 (d-var-spec1 19034 . 19264)) (19266 19591 (
d-var-type-spec 19266 . 19591)) (19593 20153 (declarations 19593 . 20153)) (20155 20265 (
default-binding 20155 . 20265)) (20267 20880 (default-bindings 20267 . 20880)) (20882 21530 (
default-type 20882 . 21530)) (21532 22302 (default-value 21532 . 22302)) (22304 23794 (
destructuring-multiple-value-bind 22304 . 23794)) (23796 25081 (destructuring-multiple-value-setq 
23796 . 25081)) (25083 25610 (dispatch-for-as-subclause 25083 . 25610)) (25612 25681 (do-clause 25612
 . 25681)) (25683 25859 (empty-p 25683 . 25859)) (25861 26135 (enumerate 25861 . 26135)) (26137 27863 
(extended-loop 26137 . 27863)) (27865 28036 (fill-in 27865 . 28036)) (28038 28115 (finally-clause 
28038 . 28115)) (28117 28235 (for 28117 . 28235)) (28237 29593 (for-as-across-subclause 28237 . 29593)
) (29595 30517 (for-as-arithmetic-possible-prepositions 29595 . 30517)) (30519 31235 (
for-as-arithmetic-step-and-test-functions 30519 . 31235)) (31237 33182 (for-as-arithmetic-subclause 
31237 . 33182)) (33184 33634 (for-as-being-subclause 33184 . 33634)) (33636 34852 (for-as-clause 33636
 . 34852)) (34854 36382 (for-as-equals-then-subclause 34854 . 36382)) (36384 36662 (for-as-fill-in 
36384 . 36662)) (36664 38630 (for-as-hash-subclause 36664 . 38630)) (38632 38878 (
for-as-in-list-subclause 38632 . 38878)) (38880 40373 (for-as-on-list-subclause 38880 . 40373)) (40375
 42077 (for-as-package-subclause 40375 . 42077)) (42079 42310 (for-as-parallel-p 42079 . 42310)) (
42312 42460 (form-or-it 42312 . 42460)) (42462 42581 (form1 42462 . 42581)) (42583 42683 (
gensym-ignorable 42583 . 42683)) (42685 42796 (globally-special-p 42685 . 42796)) (42798 42977 (
hash-d-var-spec 42798 . 42977)) (42979 43060 (initially-clause 42979 . 43060)) (43062 43219 (
invalid-accumulator-combination-error 43062 . 43219)) (43221 43838 (keyword1 43221 . 43838)) (43840 
44310 (keyword? 43840 . 44310)) (44312 44421 (let-form 44312 . 44421)) (44423 44577 (loop-error 44423
 . 44577)) (44579 44770 (loop-finish-test-forms 44579 . 44770)) (44772 44924 (loop-warn 44772 . 44924)
) (44926 45130 (lp 44926 . 45130)) (45132 45569 (main-clause* 45132 . 45569)) (45571 45667 (mapappend 
45571 . 45667)) (45669 46199 (multiple-value-list-argument-form 45669 . 46199)) (46201 46594 (
multiple-value-list-form-p 46201 . 46594)) (46596 46934 (name-clause? 46596 . 46934)) (46936 47215 (
one 46936 . 47215)) (47217 48862 (ordinary-bindings 47217 . 48862)) (48864 49081 (preposition1 48864
 . 49081)) (49083 49284 (preposition? 49083 . 49284)) (49286 49446 (psetq-forms 49286 . 49446)) (49448
 49628 (quoted-form-p 49448 . 49628)) (49630 49885 (quoted-object 49630 . 49885)) (49887 50691 (
reduce-redundant-code 49887 . 50691)) (50693 50922 (repeat-clause 50693 . 50922)) (50924 51014 (
return-clause 50924 . 51014)) (51016 51851 (selectable-clause 51016 . 51851)) (51853 52004 (
simple-loop 51853 . 52004)) (52006 52084 (simple-var-p 52006 . 52084)) (52086 52270 (simple-var1 52086
 . 52270)) (52272 52379 (stray-of-type-error 52272 . 52379)) (52381 52666 (cl::symbol-macrolet 52381
 . 52666)) (52668 53102 (type-spec? 52668 . 53102)) (53104 53170 (until-clause 53104 . 53170)) (53172 
53753 (using-other-var 53172 . 53753)) (53755 53949 (variable-clause* 53755 . 53949)) (53951 54055 (
while-clause 53951 . 54055)) (54057 54236 (with 54057 . 54236)) (54238 54683 (with-accumulators 54238
 . 54683)) (54685 54935 (with-binding-forms 54685 . 54935)) (54937 56168 (with-clause 54937 . 56168)) 
(56170 56429 (with-iterator-forms 56170 . 56429)) (56431 57578 (with-list-accumulator 56431 . 57578)) 
(57580 58017 (with-loop-context 57580 . 58017)) (58019 59257 (with-numeric-accumulator 58019 . 59257))
 (59259 59780 (with-temporaries 59259 . 59780)) (59782 60062 (zero 59782 . 60062)) (60064 60197 (loop 
60064 . 60197)))))
il:stop