summaryrefslogtreecommitdiff
path: root/Sacla/loop.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Sacla/loop.lisp')
-rw-r--r--Sacla/loop.lisp1142
1 files changed, 1142 insertions, 0 deletions
diff --git a/Sacla/loop.lisp b/Sacla/loop.lisp
new file mode 100644
index 0000000..f1ab322
--- /dev/null
+++ b/Sacla/loop.lisp
@@ -0,0 +1,1142 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $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.
+
+#-sacla
+(progn
+ (defpackage "SACLA-LOOP"
+ (:documentation "An ANSI Common Lisp Loop facility.")
+ (:use "COMMON-LISP")
+ (:shadow "ERROR" "WARN" "LOOP" "LOOP-FINISH")
+ (:export "LOOP" "LOOP-FINISH"))
+ (in-package "SACLA-LOOP"))
+
+#-sacla
+(progn
+ (defvar *message-prefix* "")
+ (defun error (datum &rest arguments)
+ (when (stringp datum)
+ (setq datum (concatenate 'string *message-prefix* datum)))
+ (apply #'cl:error datum arguments))
+ (defun warn (datum &rest arguments)
+ (when (stringp datum)
+ (setq datum (concatenate 'string *message-prefix* datum)))
+ (apply #'cl:warn datum arguments))
+
+
+ (defun %list (designator)
+ (if (listp designator) designator (list designator)))
+ (defun %keyword (designator)
+ (intern (string designator) "KEYWORD"))
+ (define-modify-macro appendf (&rest args) append "Append onto list")
+ (defun mapappend (function &rest lists)
+ (apply #'append (apply #'mapcar function lists)))
+ (define-condition simple-program-error (simple-condition program-error) ())
+)
+
+(defun globally-special-p (symbol)
+ (assert (symbolp symbol))
+ (if (constantp symbol)
+ (values nil t)
+ #+abcl (values (EXT:SPECIAL-VARIABLE-P symbol t))
+ #+allegro (values (excl::variable-special-p symbol nil) t)
+ #+clisp (values (ext:special-variable-p symbol nil) t)
+ #+cmu (values (walker:variable-globally-special-p symbol) t)
+ #+ecl (values (si:specialp symbol) t)
+ #+gcl (values (si:specialp symbol) t)
+ #+lispworks (values (eq :special (hcl:variable-information symbol)) t)
+ #+sbcl (values (sb-walker:var-globally-special-p symbol) t)
+ #-(or abcl allegro clisp cmu ecl gcl lispworks sbcl)
+ (progn
+ (warn "Implementation-specific globally-special-p should be defined.")
+ (values nil nil))))
+
+(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 *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 *for-as-prepositions*
+ (let ((prepositions nil))
+ (maphash #'(lambda (key value) (declare (ignore value)) (push key prepositions))
+ *for-as-subclauses*)
+ prepositions))
+
+(defvar *environment*)
+(defvar *loop-tokens*)
+(defvar *current-keyword* nil)
+(defvar *current-clause* nil)
+
+(defun append-context (message)
+ (concatenate 'string message
+ (let ((clause (ldiff *current-clause* *loop-tokens*)))
+ (format nil "~%Current LOOP context:~{ ~S~}" clause))))
+
+
+(defun loop-error (datum &rest arguments)
+ (when (stringp datum) (setq datum (append-context datum)))
+ (apply #'error datum arguments))
+
+(defun loop-warn (datum &rest arguments)
+ (when (stringp datum) (setq datum (append-context datum)))
+ (apply #'warn datum arguments))
+
+
+(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 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 preposition? (&optional keyword-list-designator)
+ (let ((*current-keyword* *current-keyword*)
+ (*current-clause* *current-clause*))
+ (keyword? keyword-list-designator)))
+
+(defun preposition1 (&optional keyword-list-designator)
+ (let ((*current-keyword* *current-keyword*)
+ (*current-clause* *current-clause*))
+ (keyword1 keyword-list-designator :prepositionp t)))
+
+
+
+(defvar *loop-name* nil)
+(defvar *it-symbol* nil)
+(defvar *it-visible-p* nil)
+(defvar *anonymous-accumulator* nil)
+(defvar *boolean-terminator* nil)
+(defvar *accumulators* nil)
+(defvar *loop-components* nil)
+
+
+
+(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 clause* ()
+ (loop
+ (let ((key (keyword?)))
+ (unless key (return))
+ (clause1))))
+
+(defun lp (&rest tokens)
+ (let ((*loop-tokens* tokens)
+ *current-keyword*
+ *current-clause*)
+ (clause*)
+ (when *loop-tokens* (error "~S remained after lp." *loop-tokens*))))
+
+(defun form1 ()
+ (unless *loop-tokens* (loop-error "A normal lisp form is missing."))
+ (pop *loop-tokens*))
+
+(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 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 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 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 stray-of-type-error ()
+ (loop-error "OF-TYPE keyword should be followed by a type spec."))
+
+(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 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 default-value (type)
+ (cond
+ ((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 default-type (type)
+ (if (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-binding (type var)
+ `(,(default-type type) ,var ,(default-value type)))
+
+(defvar *temporaries* nil
+ "Temporary variables used in with-clauses and for-as-clauses.")
+
+(defvar *ignorable* nil
+ "Ignorable temporary variables in *temporaries*.")
+
+(defun constant-bindings (d-type-spec d-var-spec value)
+ (let ((bindings nil))
+ (labels ((dig (type var value)
+ (cond
+ ((null var) nil) ;; do nothing
+ ((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 default-bindings (d-type-spec d-var-spec)
+ (let ((bindings nil))
+ (labels ((dig (type var)
+ (cond
+ ((null var) nil) ;; do nothing
+ ((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 ordinary-bindings (d-type-spec d-var-spec value-form)
+ (let ((temporaries *temporaries*)
+ (bindings nil))
+ (labels
+ ((dig (type var form temp)
+ ;; a TEMP moves horizontally, or cdr-wise, on an FORM.
+ ;; a TEMP can be reused by pushing it back onto TEMPORARIES.
+ (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 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 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 fill-in (&rest args)
+ (when args
+ (appendf (getf *loop-components* (first args)) (second args))
+ (apply #'fill-in (cddr args))))
+
+(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 let-form (bindings) `(let ,(mapcar #'cdr bindings) ,@(declarations bindings)))
+
+(defun with (var &optional (type t) &key (= (default-value type)))
+ (fill-in :binding-forms `(,(let-form `((,type ,var ,=))))))
+
+(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 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 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 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 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 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 for (var type &rest rest)
+ (let ((*loop-tokens* rest))
+ (dispatch-for-as-subclause var type)))
+
+(defvar *for-as-components*)
+(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))))
+
+(defvar *hash-group* '(:hash-key :hash-keys :hash-value :hash-values))
+(defvar *symbol-group* '(:symbol :symbols :present-symbol :present-symbols
+ :external-symbol :external-symbols))
+
+(defun loop-finish-test-forms (tests)
+ (case (length tests)
+ (0 nil)
+ (1 `((when ,@tests (loop-finish))))
+ (t `((when (or ,@tests) (loop-finish))))))
+
+(defun psetq-forms (args)
+ (assert (evenp (length args)))
+ (case (length args)
+ (0 nil)
+ (2 `((setq ,@args)))
+ (t `((psetq ,@args)))))
+
+(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-parallel-p ()
+ (or *for-as-components*
+ (and *loop-tokens*
+ (symbolp (car *loop-tokens*))
+ (string= (symbol-name (car *loop-tokens*)) "AND"))))
+
+(defun gensym-ignorable ()
+ (let ((var (gensym)))
+ (push var *ignorable*)
+ var))
+
+(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 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 for-as-equals-then-subclause (var type)
+ ;; 6.1.1.4 Expanding Loop Forms
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/06_aad.htm
+ ;; the form1 and form2 in a for-as-equals-then form includes the lexical
+ ;; environment of all the loop variables.
+ (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-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 zero (type)
+ (cond
+ ((subtypep type 'short-float) 0.0s0)
+ ((subtypep type 'single-float) 0.0f0)
+ ((subtypep type 'double-float) 0.0d0)
+ ((subtypep type 'long-float) 0.0l0)
+ ((subtypep type 'float) 0.0)
+ (t 0)))
+
+(defun one (type)
+ (cond
+ ((subtypep type 'short-float) 1.0s0)
+ ((subtypep type 'single-float) 1.0f0)
+ ((subtypep type 'double-float) 1.0d0)
+ ((subtypep type 'long-float) 1.0l0)
+ ((subtypep type 'float) 1.0)
+ (t 1)))
+
+(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-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 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 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))))))
+
+(defvar *list-end-test* 'atom)
+(defun by-step-fun () (if (preposition? :by) (form1) '#'cdr))
+
+(defun for-as-on-list-subclause (var type)
+ (preposition1 :on)
+ ;; Check with atom. See 6.1.2.1.3 The for-as-on-list subclause.
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abac.htm
+ (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-in-list-subclause (var type)
+ (preposition1 :in)
+ ;; Check with endp. See 6.1.2.1.2 The for-as-in-list subclause.
+ ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abab.htm
+ (let ((*list-end-test* 'endp))
+ (for `(,var) `(,type) :on (form1) :by (by-step-fun))))
+
+(defun constant-vector-p (form) (or (quoted-form-p form) (vectorp form)))
+(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 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 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 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 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 () `(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-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 () `(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-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 form-or-it ()
+ (if (and *it-visible-p* (preposition? :it))
+ (or *it-symbol* (setq *it-symbol* (gensym)))
+ (form1)))
+
+(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))))))
+
+(defun invalid-accumulator-combination-error (keys)
+ (loop-error "Accumulator ~S cannot be mixed with ~S."
+ *current-keyword* (enumerate keys)))
+
+(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 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 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 return-clause () (lp :do `(return-from ,*loop-name* ,(form-or-it))))
+
+
+(defun do-clause () (fill-in :body (compound-forms+)))
+
+(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)))))
+
+(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))))
+ ;; condition-form is destructively modified in the following code for IT.
+ (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 initially-clause () (fill-in :initially (compound-forms+)))
+(defun finally-clause () (fill-in :finally (compound-forms+)))
+(defun while-clause () (lp :unless (form1) :do '(loop-finish) :end))
+(defun until-clause () (lp :while `(not ,(form1))))
+(defun repeat-clause ()
+ (let* ((form (form1))
+ (type (typecase (if (quoted-form-p form) (quoted-object form) form)
+ (fixnum 'fixnum)
+ (t 'real))))
+ (lp :for (gensym) :of-type type :downfrom form :to 1)))
+(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 variable-clause* ()
+ (loop (let ((key (keyword? '(:with :initially :finally :for :as))))
+ (if key (clause1) (return)))))
+
+(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 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 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 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))
+
+
+(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-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-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-temporaries (temporary-specs form)
+ (destructuring-bind (temporaries &key ignorable) temporary-specs
+ (if temporaries
+ `(let ,temporaries
+ ,@(when ignorable `((declare (ignorable ,@ignorable))))
+ ,form)
+ form)))
+
+(defun with-list-accumulator (accumulator-spec form)
+ (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)))
+ `(symbol-macrolet ((,var (cdr ,list-var)))
+ ,form)
+ form)))
+ `(let ((,list-var ,value-form))
+ ;;(declare (dynamic-extent ,list-var))
+ (declare (type list ,list-var))
+ (let ((,splice ,list-var))
+ (declare (type list ,splice))
+ ,form)))))
+
+(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-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 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)))))
+
+(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 () '(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))))))))))))))))
+
+(defmacro simple-loop (&rest compound-forms)
+ (let ((top (gensym)))
+ `(block nil
+ (tagbody
+ ,top
+ ,@compound-forms
+ (go ,top)))))
+
+(defmacro loop (&rest forms)
+ (if (every #'consp forms)
+ `(simple-loop ,@forms)
+ `(extended-loop ,@forms)))
+
+