;;; **********************************************************************
;;; Copyright (C) 2003 Heinrich Taube (taube@uiuc.edu) 
;;; This program is free software; you can redistribute it and
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;; **********************************************************************

;;; generated by scheme->cltl from loop.scm on 23-Mar-2005 12:21:14

(in-package :cm)

(defun loop-operator (c) (elt c 0))

(defun loop-operator-set! (c x) (setf (elt c 0) x))

(defun loop-bindings (c) (elt c 1))

(defun loop-bindings-set! (c x) (setf (elt c 1) x))

(defun loop-collectors (c) (elt c 2))

(defun loop-collectors-set! (c x) (setf (elt c 2) x))

(defun loop-initially (c) (elt c 3))

(defun loop-initially-set! (c x) (setf (elt c 3) x))

(defun loop-end-tests (c) (elt c 4))

(defun loop-end-tests-set! (c x) (setf (elt c 4) x))

(defun loop-looping (c) (elt c 5))

(defun loop-looping-set! (c x) (setf (elt c 5) x))

(defun loop-stepping (c) (elt c 6))

(defun loop-stepping-set! (c x) (setf (elt c 6) x))

(defun loop-finally (c) (elt c 7))

(defun loop-finally-set! (c x) (setf (elt c 7) x))

(defun loop-returning (c) (elt c 8))

(defun loop-returning-set! (c x) (setf (elt c 8) x))

(defun make-loop-clause (&rest args)
  (let ((v (vector nil '() '() '() '() '() '() '() '())))
    (if (null args)
        v
        (do ((a args (cddr a)))
            ((null a) v)
          (case (car a)
            ((operator) (loop-operator-set! v (cadr a)))
            ((bindings) (loop-bindings-set! v (cadr a)))
            ((collectors) (loop-collectors-set! v (cadr a)))
            ((initially) (loop-initially-set! v (cadr a)))
            ((end-tests) (loop-end-tests-set! v (cadr a)))
            ((looping) (loop-looping-set! v (cadr a)))
            ((stepping) (loop-stepping-set! v (cadr a)))
            ((finally) (loop-finally-set! v (cadr a)))
            ((returning) (loop-returning-set! v (cadr a))))))))

(defun gather-clauses (caller clauses)
  (flet ((gather-clause (clauses accessor)
           (do ((l '()))
               ((null clauses) l)
             (setf l (append l (funcall accessor (car clauses))))
             (setf clauses (cdr clauses)))))
    (make-loop-clause 'operator caller 'bindings
     (gather-clause clauses #'loop-bindings) 'collectors
     (gather-clause clauses #'loop-collectors) 'initially
     (gather-clause clauses #'loop-initially) 'end-tests
     (gather-clause clauses #'loop-end-tests) 'looping
     (gather-clause clauses #'loop-looping) 'stepping
     (gather-clause clauses #'loop-stepping) 'finally
     (gather-clause clauses #'loop-finally) 'returning
     (gather-clause clauses #'loop-returning))))

(defun loop-op? (x ops) (assoc x ops))

(defun loop-variable? (x) (and x (symbolp x)))

(defun make-binding (var val) (list var val))

(defun loop-error (ops forms &rest args)
  (flet ((loop-context (lst ops)
           (do ((h lst) (l '()))
               ((or (null lst)
                    (and (not (eq h lst)) (loop-op? (car lst) ops)))
                (reverse l))
             (setf l (cons (car lst) l))
             (setf lst (cdr lst)))))
    (let ((forms (loop-context forms ops)))
      (terpri)
      (princ "LOOP ERROR: ")
      (do ((tail args (cdr tail)))
          ((null tail) nil)
        (princ (car tail)))
      (terpri)
      (princ "Iteration context: ")
      (if (null forms)
          (princ "()")
          (do ((tail forms (cdr tail)))
              ((null tail) nil)
            (if (eq tail forms) (princ "'"))
            (princ (car tail))
            (princ (if (null (cdr tail)) "'" " "))))
      (terpri)
      (error ""))))

(defun parse-for (forms clauses ops)
  (let ((op (loop-op? (car forms) ops)))
    (if (null (cdr forms))
        (loop-error ops forms
         "Variable expected but source code ran out.")
        (let ((var (cadr forms)))
          (if (loop-variable? var)
              (if (null (cddr forms))
                  (loop-error ops forms
                   "'for' clause expected but source code ran out.")
                  (let ((path (assoc (caddr forms) (cdddr op))))
                    (if (not path)
                        (loop-error ops forms "'" (caddr forms) "'"
                         " is not valid with 'for'.")
                        (funcall (cadr path) forms clauses ops))))
              (loop-error ops forms "Found '" (cadr forms)
               "' where a variable expected."))))))

(defun parse-numerical-for (forms clauses ops)
  clauses
  (let ((var (cadr forms))
        (tail (cddr forms))
        (bind '())
        (from nil)
        (head nil)
        (last nil)
        (stop nil)
        (step nil)
        (test nil)
        (incr nil))
    (do ((next nil))
        ((or (null tail) (loop-op? (car tail) ops)))
      (setf next (pop tail))
      (when (null tail)
        (loop-error ops forms
         "Expected expression but source code ran out."))
      (case next
        ((from downfrom)
         (if head
             (loop-error ops forms "Found '" next "' when '" head
              "' in effect."))
         (setf head next) (setf from (pop tail)))
        ((below)
         (if last
             (loop-error ops forms "Found '" next "' when '" last
              "' in effect."))
         (setf stop (pop tail)) (setf last next))
        ((to)
         (if last
             (loop-error ops forms "Found '" next "' when '" last
              "' in effect."))
         (setf stop (pop tail)) (setf last next))
        ((above)
         (if last
             (loop-error ops forms "Found '" next "' when '" last
              "' in effect."))
         (setf stop (pop tail)) (setf last next))
        ((downto)
         (if last
             (loop-error ops forms "Found '" next "' when '" last
              "' in effect."))
         (setf stop (pop tail)) (setf last next))
        ((by)
         (if step (loop-error ops forms "Found duplicate 'by'."))
         (setf step (pop tail)))
        (t
         (loop-error ops forms "'" next
          "' is not valid with 'for'."))))
    (unless head (setf head 'from))
    (if (or (eq head 'downfrom) (eq last 'downto) (eq last 'above))
        (progn (setf incr '-)
               (if (eq last 'above) (setf test '<=) (setf test '<)))
        (progn (setf incr '+)
               (if (eq last 'below) (setf test '>=) (setf test '>))))
    (push (make-binding var (or from 0)) bind)
    (if (not step)
        (setf step 1)
        (if (not (numberp step))
            (let ((var (gensym "v")))
              (push (make-binding var step) bind)
              (setf step var))))
    (setf step `(setf ,var (,incr ,var ,step)))
    (if stop
        (let ((end (gensym "v")))
          (push (make-binding end stop) bind)
          (setf stop (list test var end))))
    (values (make-loop-clause 'operator 'for 'bindings (reverse bind)
             'stepping (list step) 'end-tests
             (if (not stop) '() (list stop)))
            tail)))

(defun parse-repeat (forms clauses ops)
  (if (null (cdr forms))
      (loop-error ops forms
       "'repeat' clause expected but source code ran out.")
      (multiple-value-bind (clause ignore)
          (parse-numerical-for
           (list 'for (gensym "v") 'below (cadr forms)) clauses ops)
        ignore
        (values clause (cddr forms)))))

(defun parse-sequence-iteration (forms clauses ops)
  clauses
  (let ((head forms)
        (var (cadr forms))
        (seq (gensym "v"))
        (tail (cddr forms))
        (bind '())
        (data nil)
        (init '())
        (loop '())
        (incr nil)
        (stop '())
        (step '())
        (type nil))
    (do ((next nil))
        ((or (null tail) (loop-op? (car tail) ops)))
      (setf next (pop tail))
      (unless tail
        (loop-error ops head
         "Expression expected but source code ran out."))
      (case next
        ((in on across)
         (if type
             (loop-error ops head "Extraneous '" next "' when '" type
              "' in effect."))
         (setf type next) (setf data (pop tail)))
        ((by)
         (if incr
             (loop-error ops head "Duplicate 'by'.")
             (if (eq type 'across)
                 (loop-error ops head
                  "'by' is invalid with 'across'.")
                 (setf incr (pop tail)))))
        (t
         (loop-error ops head "'" next
          "' is not valid with 'for'."))))
    (push (make-binding var nil) bind)
    (push (make-binding seq data) bind)
    (if (eq type 'across)
        (let ((pos (gensym "v")) (max (gensym "v")))
          (push (make-binding pos 0) bind)
          (push (make-binding max nil) bind)
          (push `(setf ,max (length ,seq)) init)
          (push `(setf ,pos (+ 1 ,pos)) step)
          (push `(setf ,var (elt ,seq ,pos)) loop)
          (push `(>= ,pos ,max) stop))
        (progn (if incr
                   (if (and (listp incr) (eq (car incr) 'quote))
                       (push `(setf ,seq (,(cadr incr) ,seq)) step)
                       (push `(setf ,seq (,incr ,seq)) step))
                   (push `(setf ,seq (cdr ,seq)) step))
               (push (if (eq type 'in)
                         `(setf ,var (car ,seq))
                         `(setf ,var ,seq))
                     loop)
               (push `(null ,seq) stop)))
    (values (make-loop-clause 'operator 'for 'bindings (reverse bind)
             'end-tests stop 'initially init 'looping loop 'stepping
             step)
            tail)))

(defun parse-general-iteration (forms clauses ops)
  clauses
  (let ((head forms)
        (var (cadr forms))
        (tail (cddr forms))
        (init nil)
        (type nil)
        (loop nil)
        (step nil))
    (do ((next nil))
        ((or (null tail) (loop-op? (car tail) ops)))
      (setf next (pop tail))
      (unless tail
        (loop-error ops head
         "Expression expected but source code ran out."))
      (case next
        ((=) (when type (loop-error ops head "Duplicate '='."))
         (setf loop `(setf ,var ,(pop tail))) (setf type next))
        ((then) (when init (loop-error ops head "Duplicate 'then'."))
         (setf init loop) (setf loop nil)
         (setf step `(setf ,var ,(pop tail))) (setf type next))
        (t
         (loop-error ops head "'" next
          "' is not valid with 'for'."))))
    (values (make-loop-clause 'operator 'for 'bindings
             (list (make-binding var nil)) 'initially
             (if init (list init) '()) 'looping
             (if loop (list loop) '()) 'stepping
             (if step (list step) '()))
            tail)))

(defun parse-with (forms clauses ops)
  clauses
  (let ((head forms)
        (tail (cdr forms))
        (var nil)
        (expr nil)
        (and? nil)
        (bind '())
        (init '()))
    (do ((need t) (next nil))
        ((or (null tail) (loop-op? (car tail) ops)))
      (setf next (pop tail))
      (cond ((and (loop-variable? next) need)
             (when var
               (loop-error ops head "Found '" next
                "' where 'and' expected."))
             (when expr
               (loop-error ops head "Found '" next
                "' where 'and' expected."))
             (setf var next)
             (setf expr nil)
             (setf and? nil)
             (setf need nil))
            ((eq next 'and)
             (if and?
                 (loop-error ops head "Duplicate 'and'.")
                 (if var
                     (if expr
                         (progn (push (make-binding var nil) bind)
                                (push `(setf ,var ,expr) init))
                         (push (make-binding var nil) bind))
                     (loop-error ops head "Extraneous 'and'.")))
             (setf var nil)
             (setf expr nil)
             (setf and? t)
             (setf need t))
            ((eq next '=)
             (if expr
                 (loop-error ops head
                  "Found '=' where 'and' expected.")
                 (setf expr (pop tail))))
            (t
             (if need
                 (loop-error ops head "Found '" next
                  "' where variable expected.")
                 (loop-error ops head "Found '" next
                  "' where '=' or 'and' expected.")))))
    (if and?
        (loop-error ops head "Extraneous 'and'.")
        (if var
            (if expr
                (progn (push (make-binding var nil) bind)
                       (push `(setf ,var ,expr) init))
                (push (make-binding var nil) bind))))
    (values (make-loop-clause 'operator 'with 'bindings
             (reverse bind) 'initially (reverse init))
            tail)))

(defun parse-do (forms clauses ops)
  clauses
  (let ((head forms) (oper (pop forms)) (body '()))
    (do ()
        ((or (null forms) (loop-op? (car forms) ops))
         (if (null body)
             (loop-error ops head "Missing '" oper "' expression.")
             (setf body (reverse body))))
      (push (car forms) body)
      (setf forms (cdr forms)))
    (values (make-loop-clause 'operator oper 'looping body) forms)))

(defun parse-finally (forms clauses ops)
  clauses
  (let ((oper (pop forms)) (expr nil))
    (when (null forms)
      (loop-error ops forms "Missing '" oper "' expression."))
    (setf expr (pop forms))
    (values (make-loop-clause 'operator oper 'finally (list expr))
            forms)))

(defun parse-initially (forms clauses ops)
  clauses
  (let ((oper (pop forms)) (expr nil))
    (when (null forms)
      (loop-error ops forms "Missing '" oper "' expression."))
    (setf expr (pop forms))
    (values (make-loop-clause 'operator oper 'initially (list expr))
            forms)))

(defun lookup-collector (var clauses)
  (flet ((checkthem (var lis)
           (do ((a nil))
               ((or (null lis) a) a)
             (if (eq var (car (car lis))) (setf a (car lis)))
             (setf lis (cdr lis)))))
    (do ((c nil))
        ((or (null clauses) c) c)
      (setf c (checkthem var (loop-collectors (car clauses))))
      (setf clauses (cdr clauses)))))

(defun compatible-accumulation? (typ1 typ2)
  (let ((l1 '(collect append nconc))
        (l2 '(never always))
        (l3 '(minimize maximize)))
    (or (eq typ1 typ2)
        (and (member typ1 l1) (member typ2 l1))
        (and (member typ1 l2) (member typ2 l2))
        (and (member typ1 l3) (member typ2 l3)))))

(defun parse-accumulation (forms clauses ops)
  (flet ((make-collector (var type acc head)
           (list var type acc head))
         (collector-var (col) (car col))
         (collector-type (col) (cadr col))
         (collector-acc (col) (caddr col))
         (collector-head (col) (cadddr col)))
    (let ((save forms)
          (oper (pop forms))
          (expr nil)
          (coll nil)
          (new? nil)
          (into nil)
          (loop '())
          (bind '())
          (init '())
          (tests '())
          (return '()))
      (when (null forms)
        (loop-error ops forms "Missing '" oper "' expression."))
      (setf expr (pop forms))
      (unless (null forms)
        (when (eq (car forms) 'into)
          (when (null (cdr forms))
            (loop-error ops save "Missing 'into' variable."))
          (if (loop-variable? (cadr forms))
              (progn (setf into (cadr forms))
                     (setf forms (cddr forms)))
              (loop-error ops save "Found '" (car forms)
               "' where 'into' variable expected."))))
      (setf coll (lookup-collector into clauses))
      (if (not coll)
          (setf new? t)
          (unless (compatible-accumulation? oper
                   (collector-type coll))
            (loop-error ops save "'" (collector-type coll) "' and '"
             oper "' are incompatible accumulators.")))
      (case oper
        ((sum count)
         (let ((acc nil))
           (if new?
               (progn (setf acc (or into (gensym "v")))
                      (push (make-binding acc 0) bind)
                      (setf coll (make-collector into oper acc nil))
                      (if (not into) (push acc return)))
               (setf acc (collector-acc coll)))
           (if (eq oper 'sum)
               (push `(setf ,acc (+ ,acc ,expr)) loop)
               (push `(if ,expr (setf ,acc (+ ,acc 1))) loop))))
        ((minimize maximize)
         (let ((var (gensym "v"))
               (opr (if (eq oper 'minimize) '< '>))
               (acc nil))
           (if new?
               (progn (setf acc (or into (gensym "v")))
                      (push (make-binding acc nil) bind)
                      (setf coll (make-collector into oper acc nil))
                      (if (not into) (push `(or ,acc 0) return)))
               (setf acc (collector-acc coll)))
           (push (make-binding var nil) bind)
           (push `(progn (setf ,var ,expr)
                         (if (or (not ,acc) (,opr ,var ,acc))
                             (setf ,acc ,var)))
                 loop)))
        ((append collect nconc)
         (let ((head nil) (tail nil))
           (if (not new?)
               (progn (setf tail (collector-acc coll))
                      (setf head (collector-head coll)))
               (progn (if into (push (make-binding into nil) bind))
                      (setf tail (gensym "v"))
                      (setf head (gensym "v"))
                      (push (make-binding head '(list nil)) bind)
                      (push (make-binding tail nil) bind)
                      (push `(setf ,tail ,head) init)
                      (setf coll
                            (make-collector into oper tail head))
                      (if (not into) (push `(cdr ,head) return))))
           (if (eq oper 'append)
               (progn (push `(rplacd ,tail (copy-list ,expr)) loop)
                      (push `(setf ,tail (last ,tail)) loop))
               (if (eq oper 'collect)
                   (progn (push `(rplacd ,tail (list ,expr)) loop)
                          (push `(setf ,tail (cdr ,tail)) loop))
                   (progn (push `(rplacd ,tail ,expr) loop)
                          (push `(setf ,tail (last ,tail)) loop))))
           (if into (push `(setf ,into (cdr ,head)) loop)))))
      (values (make-loop-clause 'operator oper 'bindings
               (reverse bind) 'initially (reverse init) 'looping
               (reverse loop) 'returning (reverse return) 'collectors
               (if new? (list coll) '()) 'end-tests (reverse tests))
              forms))))

(defun loop-return (expr) `(return ,expr))

(defun parse-while-until (forms clauses ops)
  clauses
  (let ((head forms)
        (oper (pop forms))
        (test nil)
        (stop '(go :done)))
    (when (null forms)
      (loop-error ops head "Missing '" oper "' expression."))
    (case oper
      ((until) (setf test (pop forms)))
      ((while) (setf test `(not ,(pop forms)))))
    (values (make-loop-clause 'operator oper 'looping
             (list `(if ,test ,stop)))
            forms)))

(defun parse-thereis (forms clauses ops)
  clauses
  (let ((oper (car forms)) (expr nil) (bool nil) (func nil))
    (when (null (cdr forms))
      (loop-error ops forms "Missing '" (car forms) "' expression."))
    (setf expr (cadr forms))
    (setf func (cadddr (loop-op? oper ops)))
    (case oper
      ((thereis) (setf bool nil))
      ((always) (setf expr `(not ,expr)) (setf bool t))
      ((never) (setf bool t)))
    (setf forms (cddr forms))
    (values (make-loop-clause 'operator 'thereis 'looping
             (list `(if ,expr ,(funcall func (not bool)))) 'returning
             (list bool))
            forms)))

(defun parse-return (forms clauses ops)
  clauses
  (let ((oper (car forms)) (expr nil) (func nil))
    (when (null (cdr forms))
      (loop-error ops forms "Missing '" (car forms) "' expression."))
    (setf expr (cadr forms))
    (setf forms (cddr forms))
    (setf func (cadddr (loop-op? oper ops)))
    (values (make-loop-clause 'operator 'return 'looping
             `(,(funcall func expr)))
            forms)))

(defun legal-in-conditional? (x ops)
  (let ((op (loop-op? x ops)))
    (if (and op
             (not (null (cddr op)))
             (eq (caddr op) 'task)
             (not (member (car op) '(thereis never always))))
        op
        nil)))

(defun parse-then-else-dependents (forms clauses ops)
  (let ((previous forms) (stop? nil) (parsed '()))
    (do ((op nil) (clause nil) (remains nil))
        ((or (null forms) stop?))
      (setf op (legal-in-conditional? (car forms) ops))
      (unless op
        (loop-error ops previous "'" (car forms)
         "' is not conditional operator."))
      (multiple-value-bind (a b)
          (funcall (cadr op) forms (append clauses parsed) ops)
        (setf clause a)
        (setf remains b))
      (setf parsed (append parsed (list clause)))
      (setf previous forms)
      (setf forms remains)
      (unless (null forms)
        (if (eq (car forms) 'and)
            (progn (setf forms (cdr forms))
                   (if (null forms)
                       (loop-error ops previous
                        "Missing 'and' clause.")))
            (if (eq (car forms) 'else)
                (setf stop? t)
                (if (loop-op? (car forms) ops) (setf stop? t))))))
    (values parsed forms)))

(defun parse-conditional (forms clauses ops)
  (let ((ops (cons '(else) ops))
        (save forms)
        (oper (car forms))
        (loop (list))
        (expr (list))
        (then (list))
        (else (list)))
    (when (null (cdr forms))
      (loop-error ops save "Missing '" oper "' expression."))
    (setf forms (cdr forms))
    (setf expr (pop forms))
    (when (null forms)
      (loop-error ops forms "Missing conditional clause."))
    (when (eq oper 'unless) (setf expr (list 'not expr)))
    (multiple-value-bind (a b)
        (parse-then-else-dependents forms clauses ops)
      (setf then a)
      (setf forms b))
    (if (not (null (cdr then)))
        (setf then (gather-clauses (list) then))
        (setf then (car then)))
    (loop-operator-set! then 'if)
    (setf loop
          (list 'if
                expr
                (copy-list `(progn ,@(loop-looping then)))
                nil))
    (when (and (not (null forms)) (eq (car forms) 'else))
      (setf forms (cdr forms))
      (when (null forms)
        (loop-error ops save "Missing 'else' clause."))
      (multiple-value-bind (a b)
          (parse-then-else-dependents forms
           (append clauses (list then)) ops)
        (setf else a)
        (setf forms b))
      (if (not (null (cdr else)))
          (setf else (gather-clauses '() else))
          (setf else (car else)))
      (rplaca (cdddr loop) `(progn ,@(loop-looping else)))
      (loop-looping-set! then '())
      (loop-looping-set! else '())
      (setf then (gather-clauses 'if (list then else))))
    (loop-looping-set! then (list loop))
    (values then forms)))

(defun parse-clauses (forms cond? ops)
  (if (or (null forms)
          (not (let ((t0 (car forms))) (and t0 (symbolp t0)))))
      (list (make-loop-clause 'operator 'do 'looping forms))
      (flet ((op-type? (op type)
               (and (not (null (cddr op))) (eq (caddr op) type))))
        (let ((previous forms) (clauses '()))
          (do ((op nil) (clause nil) (remains '()) (body '()))
              ((null forms))
            (if (and cond? (eq (car forms) 'and)) (pop forms))
            (setf op (loop-op? (car forms) ops))
            (when (not op)
              (loop-error ops previous "Found '" (car forms)
               "' where operator expected."))
            (multiple-value-bind (a b)
                (funcall (cadr op) forms clauses ops)
              (setf clause a)
              (setf remains b))
            (if (op-type? op 'task)
                (setf body op)
                (if (op-type? op 'iter)
                    (unless (null body)
                      (loop-error ops previous "'" (car op)
                       "' clause cannot follow '" (car body) "'."))))
            (setf previous forms)
            (setf forms remains)
            (setf clauses (append clauses (list clause))))
          clauses))))

(defun parse-iteration (caller forms ops)
  (gather-clauses caller (parse-clauses forms '() ops)))

(defparameter *loop-operators* (list
                                (list 'with #'parse-with nil)
                                (list
                                 'initially
                                 #'parse-initially
                                 nil)
                                (list 'repeat #'parse-repeat 'iter)
                                (list
                                 'for
                                 #'parse-for
                                 'iter
                                 (list 'from #'parse-numerical-for)
                                 (list
                                  'downfrom
                                  #'parse-numerical-for)
                                 (list 'below #'parse-numerical-for)
                                 (list 'to #'parse-numerical-for)
                                 (list 'above #'parse-numerical-for)
                                 (list 'downto #'parse-numerical-for)
                                 (list
                                  'in
                                  #'parse-sequence-iteration)
                                 (list
                                  'on
                                  #'parse-sequence-iteration)
                                 (list
                                  'across
                                  #'parse-sequence-iteration)
                                 (list '= #'parse-general-iteration))
                                (list 'as #'parse-for 'iter)
                                (list 'do #'parse-do 'task)
                                (list
                                 'collect
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'append
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'nconc
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'sum
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'count
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'minimize
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'maximize
                                 #'parse-accumulation
                                 'task)
                                (list
                                 'thereis
                                 #'parse-thereis
                                 'task
                                 #'loop-return)
                                (list
                                 'always
                                 #'parse-thereis
                                 'task
                                 #'loop-return)
                                (list
                                 'never
                                 #'parse-thereis
                                 'task
                                 #'loop-return)
                                (list
                                 'return
                                 #'parse-return
                                 'task
                                 #'loop-return)
                                (list 'while #'parse-while-until nil)
                                (list 'until #'parse-while-until nil)
                                (list
                                 'when
                                 #'parse-conditional
                                 'task)
                                (list
                                 'unless
                                 #'parse-conditional
                                 'task)
                                (list 'if #'parse-conditional 'task)
                                (list 'finally #'parse-finally nil)))

(defmacro iter (&body args) (cltl2-loop args))

(defun cltl2-loop (forms)
  (let ((iter nil) (return nil))
    (setf iter (parse-iteration 'iter forms *loop-operators*))
    (setf return
          (funcall (cadddr (assoc 'return *loop-operators*))
                   (car (loop-returning iter))))
    `(,'let ,(loop-bindings iter) ,@(loop-initially iter)
      (block nil
        (tagbody
         :loop   ,@(let ((tests (loop-end-tests iter)))
                     (if tests
                         (list `(if
                                 ,(if
                                   (cdr tests)
                                   (cons 'or tests)
                                   (car tests))
                                 (go :done)))
                         (list)))
                 ,@(loop-looping iter)
                 ,@(loop-stepping iter)
                 (go :loop)
         :done   ,@(loop-finally iter)
                 ,return)))))
