Add Sacla to the repository.

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)))
+
+