;;; **********************************************************************
;;; 
;;; Copyright (C) 2002 Heinrich Taube (taube@uiuc.edu) 
;;; 
;;; This program is free software; you can redistribute it and/or
;;; 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.
;;; 
;;; **********************************************************************


(module loop-support (scheme-loop loop-rename loop-compare)
  (import scheme (chicken base) (chicken port) (chicken syntax))

  (import srfi-1)

(define loop-rename (make-parameter #f))
(define loop-compare (make-parameter #f))

(define-syntax push
  (syntax-rules ()
    ((_ val sym)
     (begin
       (set! sym (cons val sym))
       sym))))

(define-syntax pop 
  (syntax-rules ()
    ((_ sym)
     (let ((v (car sym)))
       (set! sym (cdr sym))
       v))))

;;; this next one is a no-op in guile but i need it for the 
;;; automatic cltl2 translation.

(define-syntax function
  (syntax-rules ()
    ((_ sym) sym)))

(define (loop-operator c)          (vector-ref  c 0))
(define (loop-operator-set! c x)   (vector-set! c 0 x))
(define (loop-bindings c)          (vector-ref  c 1))
(define (loop-bindings-set! c x)   (vector-set! c 1 x))
(define (loop-collectors c)        (vector-ref  c 2))
(define (loop-collectors-set! c x) (vector-set! c 2 x))
(define (loop-initially c)         (vector-ref  c 3))
(define (loop-initially-set! c x)  (vector-set! c 3 x))
(define (loop-end-tests c)         (vector-ref  c 4))
(define (loop-end-tests-set! c x)  (vector-set! c 4 x))
(define (loop-looping c)           (vector-ref  c 5))
(define (loop-looping-set! c x)    (vector-set! c 5 x))
(define (loop-stepping c)          (vector-ref  c 6))
(define (loop-stepping-set! c x)   (vector-set! c 6 x))
(define (loop-finally c)           (vector-ref  c 7))
(define (loop-finally-set! c x)    (vector-set! c 7 x))
(define (loop-returning c)         (vector-ref  c 8))
(define (loop-returning-set! c x)  (vector-set! c 8 x))

(define (strip x) (strip-syntax x))

(define (c* x y) ((loop-compare) x y))
(define (r* x) ((loop-rename) x))

(define (make-loop-clause . args)
  (let ((v (vector #f '() '() '() '() '() '() '() '())))
    (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))))))))

(define (gather-clauses caller clauses)
  ;; nconc all clausal expressions into one structure
  (let ((gather-clause 
	 (lambda (clauses accessor)
	   ;; append data from clauses
	   (do ((l '()))
	       ((null? clauses) l)
	     (set! l (append l (accessor (car clauses))))
	     (set! clauses (cdr clauses))))))
    (make-loop-clause 'operator caller
		      'bindings
                      (gather-clause clauses 
                                     (function loop-bindings))
		      'collectors
                      (gather-clause clauses 
                                     (function loop-collectors))
		      'initially 
                      (gather-clause clauses 
                                     (function loop-initially))
		      'end-tests 
                      (gather-clause clauses 
                                     (function loop-end-tests))
		      'looping 
                      (gather-clause clauses 
                                     (function loop-looping))
		      'stepping 
                      (gather-clause clauses 
                                     (function loop-stepping))
		      'finally 
                      (gather-clause clauses
                                     (function loop-finally))
		      'returning 
                      (gather-clause clauses
                                     (function loop-returning)))))

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

(define (loop-variable? x)
  (symbol? x))

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

(define (loop-error ops forms . args)
  ;; all error messages include error context.
  (let ((loop-context
	 (lambda (lst ops)
	   ;; return tail of expr up to next op in cdr of tail
	   (do ((h lst)
		(l '()))
	       ((or (null? lst)
		    ;; ignore op if in front.
		    (and (not (eq? h lst))
			 (loop-op? (car lst) ops)))
		(reverse l))
	     (set! l (cons (car lst) l))
	     (set! lst (cdr lst))))))
    (let* ((forms (loop-context forms ops))
	   (msg (with-output-to-string
		  (lambda ()
		    (display "LOOP ERROR: ")
		    (do ((tail args (cdr tail)))
			((null? tail) #f)
		      (display (car tail)))
		    (newline)
		    (display "Iteration context: ")
		    (if (null? forms) 
			(display "()")
			(do ((tail forms (cdr tail)))
			    ((null? tail) #f)
			  (if (eq? tail forms) (display "'"))
			  (display (car tail))
			  (display (if (null? (cdr tail)) "'" " ")))) ) ) ) )
      (error msg) ) ) )

(define (parse-for forms clauses ops)
  ;; forms is (FOR ...)
  (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.")
            ;; find the iteration path in the op
            (let ((path (assoc (caddr forms) (cdddr op))))
              ;; path is (<pathop> <parser>)
              (if (not path)
                (loop-error ops forms "'" (caddr forms) "'"
			    " is not valid with 'for'.")
                ( (cadr path) forms clauses ops))))
          (loop-error ops forms "Found '" (cadr forms)
		      "' where a variable expected."))))))

(define (parse-numerical-for forms clauses ops)
  ;; forms is (FOR <var> <OP> ...)
  ;; where <OP> is guaranteed to be one of: FROM TO BELOW ABOVE DOWNTO
  clauses
  (let ((var (cadr forms))
        (tail (cddr forms))
        (bind '())
        (from #f)
        (head #f)
        (last #f)
        (stop #f)
        (step #f)
        (test #f)
        (incr #f))
    
    (do ((next #f))
        ((or (null? tail) (loop-op? (car tail) ops)))
      (set! next (pop tail))
      (when (null? tail)
        (loop-error ops forms
		    "Expected expression but source code ran out."))
      (case (strip next)
        ((from downfrom)
         (if head (loop-error ops forms "Found '" next "' when '"
			      head "' in effect."))
         (set! head next)
         (set! from (pop tail)))
        ((below)
         (if last (loop-error ops forms "Found '" next "' when '"
			      last "' in effect."))
         (set! stop (pop tail))
         (set! last next))
        ((to)
         (if last (loop-error ops forms "Found '" next "' when '"
			      last "' in effect."))
         (set! stop (pop tail) )
         (set! last next))
        ((above )
         (if last (loop-error ops forms "Found '" next "' when '"
			      last "' in effect."))
         (set! stop (pop tail))
         (set! last next))
        ((downto )
         (if last (loop-error ops forms "Found '" next "' when '"
			      last "' in effect."))
         (set! stop (pop tail))
         (set! last next))
        ((by)
         (if step (loop-error ops forms "Found duplicate 'by'."))
         (set! step (pop tail)))
        (else
         (loop-error ops forms 
		     "'" next "' is not valid with 'for'."))))
    (unless head
      (set! head 'from))
    (if (or (c* head 'downfrom)
            (c* last 'downto)
            (c* last 'above))
      (begin
       (set! incr '-)
       (if (c* last 'above)
         (set! test '<=)
         (set! test '<)))   ; allow to for downto
      (begin
       (set! incr '+)
       (if (c* last 'below)
         (set! test '>=)
         (set! test '>))))
    
    ;; add binding for initial value
    (push (make-binding var (or from 0)) bind)
    ;; add binding for non-constant stepping values.
    (if (not step)
      (set! step 1)
      (if (not (number? step))
        (let ((var (gensym "v")))
          (push (make-binding var step) bind)
          (set! step var))))
    (set! step `(,(r* 'set!) ,var (,(r* incr) ,var ,step)))
    (if stop
      (let ((end (gensym "v")))
        (push (make-binding end stop) bind)
        (set! 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)))

(define (parse-repeat forms clauses ops)
  ;; forms is (REPEAT <FORM> ...)
  (if (null? (cdr forms))
    (loop-error ops forms 
		"'repeat' clause expected but source code ran out." )
    (call-with-values (lambda ()
			(parse-numerical-for 
			 (list 'for (gensym "v") 'below (cadr forms))
			 clauses ops))
		      (lambda (clause ignore)
                        ignore
			(values clause (cddr forms))))))

(define (parse-sequence-iteration forms clauses ops)
  ;; tail is (FOR <var> <OP> ...)
  ;; <OP> is guaranteed to be one of: IN ON ACROSS
  clauses
  (let ((head forms)
        (var (cadr forms))
        (seq (gensym "v"))
        (tail (cddr forms))
        (bind '())
        (data #f) 
        (init '()) 
        (loop '()) 
        (incr #f)
        (stop '()) 
        (step '()) 
        (type #f))
    
    (do ((next #f))
        ((or (null? tail) (loop-op? (car tail) ops)))
      (set! next (pop tail))
      (unless tail
        (loop-error ops head
		    "Expression expected but source code ran out." ))
      (case (strip next)
        ((in on across)
         (if type (loop-error ops head 
			      "Extraneous '" next "' when '"
			      type "' in effect."))
         (set! type next)
         (set! data (pop tail)))
        ((by )
         (if incr 
           (loop-error ops head "Duplicate 'by'." )
           (if (c* type 'across)
             (loop-error ops head "'by' is invalid with 'across'." )
             (set! incr (pop tail)))))
        (else
         (loop-error ops head "'" next "' is not valid with 'for'."))))
    ; add bindings for stepping var and source
    (push (make-binding var #f) bind)
    (push (make-binding seq data) bind)
    (if (c* type 'across)
      (let ((pos (gensym "v"))
            (max (gensym "v")))
        (push (make-binding pos 0) bind)
        (push (make-binding max #f) bind)
        (push `(,(r* 'set!) ,max (,(r* 'vector-length) ,seq)) init)
        (push `(,(r* 'set!) ,pos (,(r* '+) 1 ,pos)) step)
        (push `(,(r* 'set!) ,var (,(r* 'vector-ref) ,seq ,pos)) loop)
        (push `(,(r* '>=) ,pos ,max) stop))
      (begin
       (if incr
         (if (and (list? incr) (eq? (car incr) 'quote))
           (push `(,(r* 'set!) ,seq (,(cadr incr) ,seq)) step)
           (push `(,(r* 'set!) ,seq (,incr ,seq)) step))
         (push `(,(r* 'set!) ,seq (,(r* 'cdr) ,seq)) step))
       (push (if (c* type 'in)
                `(,(r* 'set!) ,var (,(r* 'car) ,seq))
                `(,(r* 'set!) ,var ,seq))
              loop)
       (push `(,(r* 'null?) ,seq) stop)))
    
    (values (make-loop-clause 'operator 'for
			      'bindings (reverse bind)
			      'end-tests stop
			      'initially init
			      'looping loop
			      'stepping step)
            tail)))

(define (parse-general-iteration forms clauses ops)
  ;; forms is (FOR <var> = ...)
  clauses
  (let ((head forms)
        (var (cadr forms))
        (tail (cddr forms))
        (init #f)
        (type #f)
        (loop #f)
        (step #f))
    (do ((next #f))
        ((or (null? tail) (loop-op? (car tail) ops)))
      (set! next (pop tail))
      (unless tail
        (loop-error ops head 
		    "Expression expected but source code ran out."))
      (case (strip next)
        ((= )
         (when type (loop-error ops head "Duplicate '='."))
         (set! loop `(,(r* 'set!) ,var ,(pop tail)))
         (set! type next))
        ((then )
         (when init (loop-error ops head "Duplicate 'then'."))
         (set! init loop)
         (set! loop #f)
         (set! step `(,(r* 'set!) ,var ,(pop tail)))
         (set! type next))
        (else
         (loop-error ops head "'" next "' is not valid with 'for'."))))
    
    (values (make-loop-clause 'operator 'for
			      'bindings (list (make-binding var #f))
			      'initially (if init (list init) '())
			      'looping (if loop (list loop) '())
			      'stepping (if step (list step) '()))
            tail)))

(define (parse-with forms clauses ops)
  ;; forms is (WITH <var> = ...)
  clauses
  (let ((head forms)
        (tail (cdr forms))
        (var #f)
        (expr #f)
        (and? #f)
        (bind '())
        (init '()))
    (do ((need #t) 
         (next #f))
        ((or (null? tail) (loop-op? (car tail) ops)))
      (set! 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."))
             (set! var next)
             (set! expr #f)
             (set! and? #f)
             (set! need #f))
            ((c* next 'and)
             (if and?
               (loop-error ops head "Duplicate 'and'.")
               (if var 
                 (if expr
                   (begin
                    (push (make-binding var #f) bind)
                    (push `(,(r* 'set!) ,var ,expr) init))
                   (push (make-binding var #f) bind))
                 (loop-error ops head "Extraneous 'and'.")))
             (set! var #f)
             (set! expr #f)
             (set! and? #t)
             (set! need #t))
            ((c* next '=)
             (if expr
               (loop-error ops head 
			   "Found '=' where 'and' expected.")
               (set! expr (pop tail))))
            (else
             (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
          (begin (push (make-binding var #f) bind)
                 (push `(,(r* 'set!) ,var ,expr) init))
          (push (make-binding var #f) bind))))
    
    (values (make-loop-clause 'operator 'with
			      'bindings (reverse bind)
			      'initially (reverse init))
            tail)))

(define (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.")
           (set! body (reverse body))))
      (push (car forms) body)
      (set! forms (cdr forms)))
    (values
     (make-loop-clause 'operator oper 'looping body)
     forms)))

(define (parse-finally forms clauses ops)
  clauses
  (let ((oper (pop forms))
        (expr #f))
    (when (null? forms)
      (loop-error ops forms "Missing '" oper "' expression."))
    (set! expr (pop forms))
    (values (make-loop-clause 'operator oper 'finally (list expr))
            forms)))

(define (parse-initially forms clauses ops)
  clauses
  (let ((oper (pop forms))
        (expr #f))
    (when (null? forms)
      (loop-error ops forms "Missing '" oper "' expression."))
    (set! expr (pop forms))
    (values (make-loop-clause 'operator oper 'initially (list expr))
            forms)))

(define (lookup-collector var clauses)
  ;; collector is list: (<var> <type> <acc> <head>)
  ;; returns the clause where the collect variable VAR is
  ;; actually bound or nil if var hasn't already been bound
  ;; if var is nil only the single system allocated collecter
  ;; is possibly returned.
  (let ((checkthem (lambda (var lis)
                     (do ((a #f)) 
                         ((or (null? lis) a) a)
                       (if (c* var (car (car lis))) ;collector-var
                         (set! a (car lis)))
                       (set! lis (cdr lis))))))
    (do ((c #f))
        ((or (null? clauses) c) c)
      (set! c (checkthem var (loop-collectors (car clauses))))
      (set! clauses (cdr clauses)))))

(define (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)))))

(define (parse-accumulation forms clauses ops)
  ;; forms is (<op> form ...)
  ;; where <op> is collect append nconc
  (let ((save forms)
        (oper (pop forms))
	(make-collector (lambda (var type acc head)
			  (list var type acc head)))
	(collector-var (lambda (col) (car col)))
	(collector-type (lambda (col) (cadr col)))
	(collector-acc (lambda (col) (caddr col)))
	(collector-head (lambda (col) (cadddr col)))
        (expr #f)
        (coll #f)
        (new? #f)
        (into #f)
        (loop '())
        (bind '())
        (init '())
        (tests '())
        (return '()))
    
    (when (null? forms)
      (loop-error ops forms "Missing '" oper "' expression."))
    (set! expr (pop forms))
    (unless (null? forms)
      (when (c* (car forms) 'into)
        (when (null? (cdr forms))
          (loop-error ops save "Missing 'into' variable."))
        (if (loop-variable? (cadr forms))
          (begin (set! into (cadr forms))
                 (set! forms (cddr forms)))
          (loop-error ops save "Found '" (car forms)
		      "' where 'into' variable expected."))))
    
    ;; search for a clause that already binds either the user specified
    ;; accumulator (into) or a system allocated one if no into.
    ;; system collectors
    ;;   o only one  allowed, all accumuations must be compatible
    ;;   o returns value
    ;;   value collector: (nil <op> <#:acc>)
    ;;   list collector:  (nil <op> <#:tail> <#:head>)
    ;; into collectors
    ;;   o any number allowed
    ;;   o returns nothing.
    ;;   value collector: (<into> <op> <into> )
    ;;   list collector:  (<into> <op> <#:tail> <#:head>)
    (set! coll (lookup-collector into clauses))
    (if (not coll)
      (set! new? #t)
      ;; accumulator already established by earlier clause
      ;; check to make sure clauses are compatible.
      (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 #f))
         (if new?
           (begin 
            (set! acc (or into (gensym "v")))
            (push (make-binding acc 0) bind)
            ;; coll= (nil <op> <#:acc>) or (<into> <op> <into>)
            (set! coll (make-collector into oper acc #f))
            ;; only add a return value if new collector isnt into
            (if (not into) (push acc return)))
           (set! acc (collector-acc coll)))
         (if (eq? oper 'sum)
           (push `(,(r* 'set!) ,acc (,(r* '+) ,acc ,expr)) loop)
           (push `(,(r* 'if) ,expr (,(r* 'set!) ,acc (,(r* '+) ,acc 1))) loop))))
      ((minimize maximize)
       (let ((var (gensym "v"))
             (opr (r* (if (eq? oper 'minimize) '< '>)))
             (acc #f))
         (if new?
           (begin
            (set! acc (or into (gensym "v")))
            (push (make-binding acc #f) bind)
            ;; coll= (nil <op> <#:acc>) or (<into> <op> <into>)
            (set! coll (make-collector into oper acc #f))
            ;; only add a return value if new collector isnt into
            (if (not into) (push `(,(r* 'or) ,acc 0) return)))
           (set! acc (collector-acc coll)))
         (push (make-binding var #f) bind)
         (push `(,(r* 'begin) (,(r* 'set!) ,var ,expr)
		 (,(r* 'if) (,(r* 'or) (,(r* 'not) ,acc) 
			     (,opr ,var ,acc))
		  (,(r* 'set!) ,acc ,var)))
	       loop)))
      ((append collect nconc)
       ;; for list accumulation a pointer to the tail of the list
       ;; is updated and the head of the list is returned. any
       ;; into variable is set to the head inside the loop.
       (let ((head #f)
             (tail #f))
         (if (not new?)
           (begin (set! tail (collector-acc coll))
                  (set! head (collector-head coll)))
           (begin
            (if into (push (make-binding into #f) bind))
            (set! tail (gensym "v"))
            ;; allocate a pointer to the head of list
            (set! head (gensym "v"))
            (push (make-binding head `(,(r* 'list) #f)) bind)
            (push (make-binding tail #f) bind)
            ;; initialize tail to head
            (push `(,(r* 'set!) ,tail ,head) init)
            (set! coll (make-collector into oper tail head))
            ;; only add a return value if new collector isnt into
            (if (not into)
              (push `(,(r* 'cdr) ,head) return))))
         ;; add loop accumulation forms
         (if (c* oper 'append)
           (begin
            (push `(,(r* 'set-cdr!) ,tail (,(r* 'list-copy) ,expr)) loop)
            (push `(,(r* 'set!) ,tail (,(r* 'last-pair) ,tail)) loop))
           (if (c* oper 'collect)
             (begin
              (push `(,(r* 'set-cdr!) ,tail (,(r* 'list) ,expr)) loop)
              (push `(,(r* 'set!) ,tail (,(r* 'cdr) ,tail)) loop))
             (begin 
              (push `(,(r* 'set-cdr!) ,tail ,expr) loop)
              (push `(,(r* 'set!) ,tail (,(r* 'last-pair) ,tail)) loop))))
         ;; update user into variable inside the main loop
         ;; regardless of whether its a new collector or not
         (if into
           (push `(,(r* 'set!) ,into (,(r* '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)))

;(define (loop-stop expr)
;  `(%done% ,expr))

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

(define (parse-while-until forms clauses ops)
  clauses
  (let ((head forms)
        (oper (pop forms))
        (test #f)
        (stop `(,(r* 'go) #:done)))
    (when (null? forms)
      (loop-error ops head "Missing '" oper "' expression."))
    
    (case oper
      ((until ) (set! test (pop forms)))
      ((while ) (set! test `(,(r* 'not) ,(pop forms)))))
    ;; calls the DONE continuation.
    (values (make-loop-clause 'operator oper
			      'looping (list `(,(r* 'if) ,test ,stop)))
            forms)))

(define (parse-thereis forms clauses ops)
  clauses
  (let ((oper (car forms))
        (expr #f)
        (bool #f)
        (func #f))
    (when (null? (cdr forms))
      (loop-error ops forms "Missing '" (car forms) "' expression." ))
    (set! expr (cadr forms))
    ;; fourth element of operator definition must be
    ;; a function that returns the stop expression.
    (set! func (cadddr (loop-op? oper ops) ))
    
    (case (strip oper)
      ((thereis ) 
       ;; return true as soon as expr is true or false at end
       (set! bool #f))
      ((always )
       ;; return false as soon as expr is false, or true at end
       (set! expr `(,(r* 'not) ,expr))
       (set! bool #t))
      ((never )
       ;; return false as soon as expr is true, or true at end
       (set! bool #t)))
    (set! forms (cddr forms))
    ;; this calls the RETURN continuation
    (values (make-loop-clause 'operator 'thereis
			      'looping 
                              (list `(,(r* 'if) ,expr ,(func (not bool))))
			      'returning 
                              (list bool))
            forms)))

(define (parse-return forms clauses ops)
  clauses
  (let ((oper (car forms))
        (expr #f)
        (func #f))
    (when (null? (cdr forms))
      (loop-error ops forms "Missing '" (car forms) "' expression."))
    (set! expr (cadr forms))
    (set! forms (cddr forms))
    ;; fourth element of operator definition must be
    ;; a function that returns the stop expression.
    (set! func (cadddr (loop-op? oper ops) ))
    ;; this calls the RETURN continuation
    (values (make-loop-clause 'operator 'return
			      'looping `(,(func expr)))
            forms)))

(define (legal-in-conditional? x ops)
  ;; FIXED (member (loop-operator...))
  (let ((op (loop-op? x ops)))
    (if (and op 
	     (not (null? (cddr op)))
	     (eq? (caddr op) 'task)
             (not (any (lambda (x) (c* x (car op))) '(thereis never always))))
      op #f)))

(define (parse-then-else-dependents forms clauses ops)
  (let ((previous forms)
        (stop? #f)
        (parsed '()))
    
    (do ((op #f)
         (clause #f)
         (remains #f))
        ((or (null? forms) stop?))
      (set! op (legal-in-conditional? (car forms) ops))
      (unless op
        (loop-error ops previous "'" (car forms)
		    "' is not conditional operator."))
      ;(multiple-value-setq 
      ; (clause remains)
      ; ( (cadr op) forms (append clauses parsed) ops))
      (call-with-values
       (lambda () ( (cadr op) forms (append clauses parsed) ops))
       (lambda (a b) (set! clause a) (set! remains b)))

  ;(format #t "~%after call clause=~s forms=~S" clause forms)      

      (set! parsed (append parsed (list clause)))
      (set! previous forms)
      (set! forms remains)

      (unless (null? forms)
        (if (c* (car forms) 'and)
          (begin
           (set! forms (cdr forms))
           (if (null? forms)
             (loop-error ops previous "Missing 'and' clause.")))
          (if (c* (car forms) 'else)
            (set! stop? #t)
            (if (loop-op? (car forms) ops)
              (set! stop? #t))))))
    (values parsed forms)))

(define (parse-conditional forms clauses ops)
  (let ((ops (cons (list (r* 'else)) ops))
	(save forms)
        (oper (car forms))
        (loop (list))  ; avoid '() because of acl bug
        (expr (list))
        (then (list))
        (else (list)))
    (when (null? (cdr forms))
      (loop-error ops save "Missing '" oper "' expression."))
    (set! forms (cdr forms))
    (set! expr (pop forms))
    (when (null? forms)
      (loop-error ops forms "Missing conditional clause."))
    (when (c* oper 'unless)
      (set! expr (list (r* 'not) expr)))
    (call-with-values
     (lambda () (parse-then-else-dependents forms clauses ops))
     (lambda (a b)
       (set! then a)
       (set! forms b)))

    ;; combine dependant clauses if more than one
    (if (not (null? (cdr then)))
      (set! then (gather-clauses (list) then))
      (set! then (car then)))
    (loop-operator-set! then (r* 'if))

    ;; this if expression is hacked so that it is a newly
    ;; allocated list. otherwise acl and clisp have a
    ;; nasty structure sharing problem.
    (set! loop (list (r* 'if) expr 
                     (list-copy `(,(r* 'begin) ,@(loop-looping then)))
                     #f))
    (when (and (not (null? forms))
               (c* (car forms) 'else))
      (set! forms (cdr forms))
      (when (null? forms)
        (loop-error ops save "Missing 'else' clause."))
      (call-with-values 
       (lambda ()
	 (parse-then-else-dependents 
          forms (append clauses (list then))
          ops))
       (lambda (a b) (set! else a) (set! forms b)))
      (if (not (null? (cdr else)))
        (set! else (gather-clauses '() else))
        (set! else (car else)))
      (set-car! (cdddr loop) `(,(r* 'begin) ,@(loop-looping else)))
      ;; flush loop forms so we dont gather actions.
      (loop-looping-set! then '())
      (loop-looping-set! else '())
      (set! then (gather-clauses 'if (list then else))))
    (loop-looping-set! then (list loop))
    (values then forms)))

(define (parse-clauses forms cond? ops)
  (if (or (null? forms)
	  (not (symbol? (car forms))))
    (list (make-loop-clause 'operator 'do 'looping forms))
    (let ((op-type? (lambda (op type)
                      (and (not (null? (cddr op)))
                           (c* (caddr op) type)))))
      (let ((previous forms)
            (clauses '()))
        (do ((op #f)
             (clause #f)
             (remains '())
             (body '()) )
            ((null? forms))
          (if (and cond? (c* (car forms) 'and))
            (pop forms))
          (set! op (loop-op? (car forms) ops))
          (when (not op)
            (loop-error ops previous "Found '" (car forms)
			"' where operator expected."))
          ;(multiple-value-setq (clause remains)
          ;                     ((cadr op) forms clauses ops))
	  (call-with-values
	   (lambda () ( (cadr op) forms clauses ops))
	   (lambda (a b)
	     (set! clause a)
	     (set! remains b)))
          (if (op-type? op 'task)
            (set! body op)
            (if (op-type? op 'iter)
              (unless (null? body)
                (loop-error ops previous "'" (car op)
			    "' clause cannot follow '"
			    (car body) "'."))))
          (set! previous forms)
          (set! forms remains)
          (set! clauses (append clauses (list clause))))
        clauses))))

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

;;;
;;; loop implementation
;;;

(define *loop-operators*
  ;; each clause is (<op> <parser> <tag> . <whatever>)
  (list (list 'with (function parse-with) #f)
        (list 'initially (function parse-initially) #f)
        (list 'repeat (function parse-repeat) 'iter)
        (list 'for (function parse-for) 'iter
              (list 'from (function parse-numerical-for))
              (list 'downfrom (function parse-numerical-for))
              (list 'below (function parse-numerical-for))
              (list 'to (function parse-numerical-for))
              (list 'above (function parse-numerical-for))
              (list 'downto (function parse-numerical-for))
              (list 'in (function parse-sequence-iteration))
              (list 'on (function parse-sequence-iteration))
              (list 'across (function parse-sequence-iteration))
              (list '= (function parse-general-iteration)))
        (list 'as (function parse-for) 'iter)
        (list 'do (function parse-do) 'task)
        (list 'collect (function parse-accumulation) 'task)
        (list 'append (function parse-accumulation) 'task)
        (list 'nconc (function parse-accumulation) 'task)
        (list 'sum (function parse-accumulation) 'task)
        (list 'count (function parse-accumulation) 'task)
        (list 'minimize (function parse-accumulation) 'task)
        (list 'maximize (function parse-accumulation) 'task)
        (list 'thereis (function parse-thereis) 'task
              (function loop-return))
        (list 'always (function parse-thereis) 'task
              (function loop-return))
        (list 'never (function parse-thereis) 'task 
              (function loop-return))
        (list 'return (function parse-return) 'task 
              (function loop-return))
        (list 'while (function parse-while-until) #f )
        (list 'until (function parse-while-until) #f )
        (list 'when (function parse-conditional) 'task)
        (list 'unless (function parse-conditional) 'task)
        (list 'if (function parse-conditional) 'task)
        (list 'finally (function parse-finally) #f)))

;;;
;;; loop expansions for scheme and cltl2
;;;

(define (scheme-loop forms)
  (let ((name (gensym "v"))
        (parsed (parse-iteration 'loop forms *loop-operators*))
        (end-test '())
        (done `(,(r* 'go) #:done))
        (return #f))
    ;(write (list :parsed-> parsed))
    ;; cltl2's loop needs a way to stop iteration from with the run
    ;; block (the done form) and/or immediately return a value
    ;; (the return form).  scheme doesnt have a block return or a
    ;; go/tagbody mechanism these conditions are implemented using
    ;; continuations.  The forms that done and return expand to are
    ;; not hardwired into the code because this utility is also used
    ;; by CM's 'process' macro. Instead, the done and return forms
    ;; are returned by functions assocated with the relevant operator
    ;; data. For example, the function that returns the return form
    ;; is stored as the fourth element in the return operator data.
    ;; and the done function is stored in the while and until op data.
    
    ;; the cadddr of the RETURN operator is a function that
    ;; provides the form for immediately returning a value
    ;; from the iteration.

    (let ((returnfn (cadddr (assoc 'return *loop-operators*))))
      (set! return (returnfn
                    (if (null? (loop-returning parsed))
                      #f
                      (car (loop-returning parsed))))))
            
    ;; combine any end-tests into a single IF expression
    ;; that calls the (done) continuation if true. multiple
    ;; tests are OR'ed togther

    (set! end-test
          (let ((ends (loop-end-tests parsed)))
            (if (null? ends)
              '()
              (list
               `(,(r* 'if) ,(if (null? (cdr ends))
				(car ends)
				(cons 'or ends))
                  ;;  calls the done continuation
                  ,done 
                  #f)))))
    `(,(r* 'let) (,@ (loop-bindings parsed))
       ,@(loop-initially parsed)
       (,(r* 'call-with-current-continuation )
        (,(r* 'lambda) (return)     ; <- (return) returns from this lambda
          (,(r* 'call-with-current-continuation)
           (,(r* 'lambda) (,(r* 'go))  ; <- (go :done) returns from this lambda
             ;; a named let provides the actual looping mechanism.
             ;; the various tests and actions may exit via the
             ;; (done) or (return) continuations.
             (,(r* 'let) ,name () 
                  ,@end-test
                  ,@(loop-looping parsed)
                  ,@(loop-stepping parsed)
                  (,name))))
          ;; this is the lexical point for (go :done) continuation.
          ,@(loop-finally parsed)
          ;; invoke the RETURN continuation with loop value or #f
          ,return)))))

)