;;; -*- Mode: lisp; Package: clisp; Base: 10.; Syntax: Common-lisp -*-
;;;
;;;                 RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;; Technical Data and Computer Software Clause at 52.227-7013 of the DOD
;;; FAR Supplement
;;;
;;;		  BOLT BERANEK AND NEWMAN INC.
;;;		        10 Moulton Street
;;;		       Cambridge, MA 02238
;;;		          617-491-1850			
;;;


;;; A macro package that implements the INTERLISP iterative operator clisp package in
;;; Common Lisp.

(in-package "CLISP")
;#+ :3600
;(in-package 'clisp ':use 'CL)
;#+ :ti
;(in-package 'clisp ':use 'lisp)

(export '(CLISPARRAY for while until bind clisp-translate
		     repeatwhile repeatuntil collect join sum
                     always never thereis in on inside from
                     to eachtime
                     $$val $$out $$lp $$iterate _
                     tconc  ;it is usefull so let everyone use it.
                     ) 'clisp)
;can not export  the following because they conflict with commonlisp fns.
;   do, first, declare, count, when, unless

;Not implemented:
;  old, smallest, largest

;;; John: STIRLING: May97. Seems to foul up if cur-op does not 
;;; have some value at least during compilation under Allegro
;;; acl 3.0.2. So, it can't hurt I presume to...

(defvar cur-op nil)

;;; it is also used special below without a declaration, that is
;;; also fixed...

;(shadow '(count when unless))

(proclaim '(special last-iv cl-var-table $$lstcount **iterative-body**
		    clisp-iv-lst let-lst prog-lst test-lst-numeric update-lst
		    test-lst-list test-lst-avoid $$TEMcount eachtime-lst
		    initialize-lst finalize-lst cur-op bodyform t1 t2
		    h1 h2 v1 $outport$ after-tests spec-var-lst fixnum-var-lst
		    list-var-lst Iterative-action-dispatch-table CLISPARRAY
                    other-declarations-lst))


(defmacro tconc (np nx)
  (let ((p (gensym))(x (gensym)))
    `(let ((,p ,np)(,x ,nx))
       (cond ((consp (cdr ,p))
              (rplacd ,p (cdr (rplacd (cdr ,p)(cons ,x nil)))))
	     (t (rplaca ,p (cdr (rplacd ,p (cons ,x nil)))))))))

  ; This file contains the translation package that converts the Interlisp
  ; clisp iterative statement form into common lisp.  The various iterative
  ; statement operators are defined as macros that call the function
  ; clisp-translate.  Clisp-translate will take a clisp I.S. form and return
  ; a lisp form that looks like:
  ;
  ; (let (<initialized-locals>)    ; local variables initialized at entry.
  ;     <declarations>          ; special declarations for let variables.
  ;	(prog (<other-locals)	; Rest of local and temporary variables
  ;      <declarations>         ; rest of the decls. (including prog specials)
  ; 	<initialize>		; Anything else needed to be done just at
  ; 				; entry
  ;   $$LP <eachtime>		; Top of loop, do stuff that must happen on
  ; 				; each iteration.
  ; 	<test>			; Evaluation of guards and termination.
  ;	<body>			; The body of the iteration
  ;   $ITERATE <aftertest>	; additional termination checks.
  ; 	<update>		; "incrementing" iterative variables, i.v.'s
  ; 	(go $$LP)		; iterate
  ;  $$OUT <finalize>		; exit clause, doing necessary mopup
  ; 	(return $$VAL)))	; yeild a value, $$VAL usuall set by <body>.
  ;
  ;
  ; The instantiation of each <FORM> is determined as clisp-translate does its
  ; work.  <initialized-locals> is found on let-lst, <other-locals> is
  ; prog-lst, <declarations> currently can only be special or fixnum 
  ; declarations. Vars on spec-var-lst are declared special where they
  ; are bound. Vars on fixnum-var-lst are declared fixnum where they
  ; are bound.  Vars on list-var-lst are declared lists when they are bound.
  ; The fns from-action and to-action add vars to fixnum-var-lst.
  ; The fns in-action and on-action add vars to list-var-lst.
  ; <initialize> is initialize-lst, <eachtime> is eachtime-lst,
  ; <test> is built from test-lst-list, test-lst-numberic, and test-lst-avoid.
  ; <body> comes from **iterative-body**.  <update> comes form update-lst. and
  ; <finalize>comes from finalize-lst.  They are all built incrementally as
  ; clisp-translate examins each s-expression in the iterative statement.
  ;
  ; An important data structure that is used it the cl-var-table, which is a
  ; 12 "column table" of all of the variables used by the iterative statement.
  ; An important sub-table of the cl-var-table is the clisp-iv-lst which is
  ; just those entries in the var table that are iterative tables.
  ; The columns in the var table are:
  ;
  ; var-name			; the name of the variable
  ; numeric/list		; type of operation done on the variable
  ; lab-binding			; how variable is initialized on entry
  ; num-boundry			; upper bound for variable that are numeric
  ; num-increment		; form telling how to increment numeric vars
  ; update-form			; how to increment list type vars
  ; test-form			; termination criteria for list type vars
  ; to-type			; filled by to operator, effects num-boundry
  ; from-type			; ""   "" from operator, effects lam-binding
  ; by-type			; ""   "" by op. effects num-boundry or
  ;  				; the update-form,depending on numeric/list
  ;
  ; The order in which these fields are filled in depends upon the order in
  ; which the iterative statement was written.
  ;
  ; The cl-var-table is implemented where each "row" is a list.  The first
  ; element of a "row" is the var-name, thus the cl-var-table is an
  ; association list.  Likewise for the clisp-iv-lst.  New entries are made to
  ; cl-var-table by the function cl-var-entry-build which returns a virgin
  ; row.  The clisp-iv-lst is updated by new-or-old iv which will cause
  ; cl-var-entry-build to be called if necessary.
  ; The variable  last-iv  holds the entry in clisp-iv-lst that represents our
  ; current notion of what is the "current iv".
  ;
  ; The followin is a macro that expands to a from that updates an field in a
  ; row of the cl-var-table. The calling form is:
  ; (cl-var-reset field entry value)
  ; it essentiall does (REPLACE field OF entry WITH value).


(defstruct (Clisp-Iterative-Form-Variable-Table-Entry (:conc-name nil))
  var-name
  numeric/list
  tail-name
  lam-binding
  num-boundry
  num-increment
  update-form
  test-form
  list-disipline
  to-type
  from-type
  by-setp  ;t iff the var is to be updated by a user given "by" form
     ; If the user accidentally gives 2 by forms, the first would be
     ;ignored by the parser so this flag makes it easy to check that
     ;the by statment has a valid syntax (ie only 1 by form)
  by-type)

(defmacro cl-var-reset (field-loc table-entry newvalue)
  `(setf (,field-loc ,table-entry) ,newvalue))

;;; (cl-var-look-up field entry) retreives a field from a table entry.     
;;; It does (FETCH field OF entry)     

(defmacro cl-var-look-up (field entry)
  `(,field ,entry))


;;; (cl-var-entry-fetch var) returns the cl-var-table entry for variable var,
;;; if it exists.  Just expands into a call on assq.  Change this macro if the
;;; implementation of the table is altered.

(defmacro cl-var-entry-fetch (var)
  `(find ,var cl-var-table :test #'eq :key #'(lambda (x) (var-name x))))

;;; cl-var-entry-build is the function that adds new rows to the cl-var-entry
;;; table and then returns the virgin row.  The variable table is maintained
;;; as an association list, keyed bye the variable names, often we know that
;;; it is necessary to build a new entry before we know the name of the var.

(defun cl-var-entry-build ()
  (car (push (make-Clisp-Iterative-Form-Variable-Table-Entry) cl-var-table)))


;;; new-or-old-iv is a macro that expands into a form that determins weither
;;; or not what is considered to be the current i.v. is to undergo additional
;;; development.  The calling form is
;;;    (new-or-old-iv numeric-or-list table-entry-field [traversal-type])
;;; The first arg tells if the iv is a numberic or list variable, if that can
;;; be determined. The second arg tells which field in the table entry to
;;; update. and the optional third field is present when this is a list type
;;; variable, it tells if we are using the in, on, or inside operator to
;;; define the iv on each iteration.
;;; The macro expands into a call on a function that decides weither to
;;; continue to updat the current i.v. or to start decribing a new one. The
;;; what ever field updates that can be made, i.e. to-type or list-disipline,
;;; are made.  The resulting form will return what happens to represent the
;;; current i.v.      



(defmacro new-or-old-iv
	  (numeric-or-list table-entry-field &optional (traversal-type t))
  `(prog1
    (new-iv-check (clisp-when last-iv (cl-var-look-up numeric/list last-iv))
		  ,numeric-or-list
		  (clisp-when last-iv
		    (cl-var-look-up ,table-entry-field last-iv)))
    (cl-var-reset ,table-entry-field last-iv ,traversal-type)))


;;; cl-make-symbol will generate unique symbole, depending on arg, that is
;;; used as a temporary variable.  E.G., $$TEM1.

(defun cl-make-symbol (symbol-base)
  (let* ((counter (intern (format nil "~ACOUNT" (symbol-name symbol-base))
			  (find-package 'clisp)))
	 (sym (intern (format nil "~a~a" (symbol-name symbol-base)
			      (symbol-value counter)))))
    (incf (symbol-value counter))
    sym))
    

(defun cl-body-extract (form)
  (if (cdr (second form))
      `(progn ,.(second form))
      (first (second form))))

;;; oldtype is the disipline of what we have sofar considered to be the
;;; current iv.  newtype is the disipline of what we think the new current
;;; iv should be.  oldflag tells us if we have already describe the current
;;; iv that is we can't have more that one 'in' operator associated with a
;;; particular i.v.

(defun new-iv-check (oldtype newtype oldflag)
    (if (and last-iv
             (null oldflag)
             (or (null oldtype)
                 (and oldtype (null newtype))
                 (eq oldtype newtype)))

	; then continue working on same iv, only go through effort of updating
	; entry if there is info to put in.

	(and newtype
	     (null oldtype)
	     (cl-var-reset numeric/list last-iv newtype))

	;else
	(progn (setq last-iv (cl-var-entry-build))

	       ; Start on new iv

	       (and newtype (cl-var-reset numeric/list last-iv newtype))

	       ; fill in type if we can      
	       ; add it to iv  lst which will  be used later.

	       (setq clisp-iv-lst (cons last-iv clisp-iv-lst))))

  ; for Those who might be expecting it, return the current iv.

  last-iv)

;;; The following are the initialization routines that are called when a new
;;; clisp operator is discovered by clisp scan.  They simply make sure that
;;; the action routine that will be called right after them have the right iv
;;; structure to work with or just do simple error checking.


(defun finally-init nil
  (if finalize-lst
      (error "CLISP: Multiple finally operators in iterative statement")
      (setq finalize-lst (cons nil nil))))


(defun to-init nil
    (new-or-old-iv 'numeric to-type))


(defun from-init nil
    (new-or-old-iv 'numeric from-type))


(defun in-init nil
    (new-or-old-iv 'list list-disipline 'in))


(defun on-init nil
    (new-or-old-iv 'list list-disipline 'on))


(defun inside-init nil
    (new-or-old-iv 'list list-disipline 'inside))


(defun by-init nil
    (new-or-old-iv nil by-type))


(defun for/as-init nil
    (new-or-old-iv nil var-name nil))


(defun eachtime-init nil
    (if eachtime-lst
	(error "CLISP: Multiple EACHTIME operators in iterative statement")
	(setq eachtime-lst (cons nil nil))))


(defun first-init nil
    (if initialize-lst
	(error "CLISP: Multiple FIRST operators in iterative statement")
	(setq initialize-lst (cons nil nil))))



(defun clisp-no-op (&rest x)
  (declare (ignore x))
    nil)


(defun when-action (operand)
  (setq test-lst-avoid (cons (list 'not operand) test-lst-avoid)))


(defun unless-action (operand)
  (setq test-lst-avoid (cons operand test-lst-avoid)))


(defun until-action (operand)
  (setq test-lst-numeric (cons operand test-lst-numeric)))


(defun while-action (operand)
  (setq test-lst-numeric (cons (list 'not operand) test-lst-numeric)))


(defun finally-finish nil
  (setq finalize-lst (car finalize-lst)))


(defun first-finish nil
  (setq initialize-lst (car initialize-lst)))


(defun eachtime-finish nil
  (setq eachtime-lst (car eachtime-lst)))


(defun finally-action (operand)
  (setq finalize-lst (tconc finalize-lst operand)))


(defun from-action (operand)
  (and (cl-var-look-up var-name last-iv)
       (pushnew (cl-var-look-up var-name last-iv)
          fixnum-var-lst))  ;also done in to-action and by-action if they can.
  (if (cl-var-look-up lam-binding last-iv)

      ;then A mal-formed expression, e.g. ... from V1 V2 to ...     

      (progn(princ "CLISP: Don't know what to do with from operand ")
	    (print operand)
	    (terpri)
	    (princ "ignoring it")
	    (terpri))

      ; else evrything is golden

      (cl-var-reset lam-binding last-iv operand)))


(defun to-action (operand)
  (and (cl-var-look-up var-name last-iv)
       (pushnew (cl-var-look-up var-name last-iv)
          fixnum-var-lst)) ;also done in from-action and by-action if they can.
  (if (cl-var-look-up num-boundry last-iv)
      ; then  an error
      (progn (princ "CLISP: Don't know what to do with ")
	     (print operand)
	     (terpri)
	     (princ "Ignorring it")
	     (terpri))
      ; else everything ok
      (if (and (atom operand) (numberp operand))
	  ; then A constant, use it for comparison

	  (cl-var-reset num-boundry last-iv operand)

       ; else given ...to V.. and V is not a number then we want to
       ; evaluate V only once and keep its value in a temporary for comparison

	  (let ((helper (cl-var-entry-build))
                (tmp.var  (cl-make-symbol '$$TEM)))
	    (cl-var-reset var-name
			  helper
			  tmp.var)
            (push tmp.var fixnum-var-lst)  ;declare the temp var a fixnum.
	    (cl-var-reset lam-binding helper operand)
	    (cl-var-reset num-boundry
			  last-iv
			  (cl-var-look-up var-name helper))))))

;;; This is the action routine for the by operand.  It is, by necessity,
;;; weaker than we might like.  We can only commit ourselves to defining the
;;; disipline of the last-iv iff the operand is a number, if the operand is a
;;; non-numberic s-expression then all we can do is is fill in the updat-form
;;; field of the last-iv and let other routines take care of the rest. If we
;;; are lucky and have a numeric operand, then we can do some error checking,
;;; make a commitment about the i.v. disipline, and fill in the numeric
;;; increment field.  In real practice we are generally lucky.

(defun by-action (operand)
  (when operand
     (when (cl-var-look-up by-setp last-iv)
       (warn
         "More than one BY clause specified for iterative variable ~A.
 All but the last will be ignored!  (did you forget to include a DO?)"
         (cl-var-look-up var-name last-iv)))
    (cl-var-reset by-setp last-iv t))
  
  (if (numberp operand)
      
      ;then the lucky case
      
      (let ((tp (cl-var-look-up numeric/list last-iv)))
	(if (eq tp 'list)
	    ;then a fowl up
	    
	    (error "CLISP ERROR numeric BY operand on LIST iteration : ~S "
		   operand)
	    
	    ;else take care of buisness
	    
	    (progn(or tp (cl-var-reset numeric/list last-iv 'numeric))
		  (cl-var-reset num-increment last-iv operand)
		  (cl-var-reset update-form last-iv operand))))
      
      ;else the unlucky case, do what you can do.
      ; The last argument to cl-var-reset below was simply operand.
      ;That was wrong! The cond is much closer to what interlisp does.
      ;The first cond pair is technically not part of the interlisp
      ;definition of by but that is how it works. (I guess dwim 
      ;could cause that)  The second cond pair is exactly what
      ;the interlisp documentation sais will happen.
      ;The last cond pair is just in case the others dont execute.
      ;it can not be worse than a nil. My guess is that that case usually
      ;will cause an error when the translation is evaluated.  Putting
      ;operand there instead of nil will give a more meaningfull 
      ;error message.
      (cl-var-reset update-form last-iv
               (cond((symbolp operand)
                     (list operand (cl-var-look-up tail-name last-iv)))
                    ((consp operand)
                     (cl-subst
                       (cl-var-look-up tail-name last-iv)
                       (cl-var-look-up var-name last-iv)
                       operand))
                    (t operand)))))


(defun for/as-action (operand)
  (if (cl-var-entry-fetch operand)
      (format t "~&~a Is already a bound Clisp Variable, Ignoring It."
	      operand)
      (let ((cvar (cl-var-look-up var-name last-iv)))
	(if cvar

	    ; then for and as can have multiple operands.  The first one
	    ; is considered to be the new current i.v.

	    (cl-var-reset var-name (cl-var-entry-build) operand)

	    ; else 1st operand.  Assumed that new-or-old-iv has recently
	    ; it is to late for something like..to 5 from 1 for i...

	    (cl-var-reset var-name last-iv operand)))))


(defun eachtime-action (operand)
    (setq eachtime-lst (tconc eachtime-lst operand)))


(defun first-action (operand)
    (setq initialize-lst (tconc initialize-lst operand)))


(defun repeatuntil-action (operand)
    (setq after-tests (tconc after-tests operand)))


(defun repeatwhile-action (operand)
    (setq after-tests (tconc after-tests `(not ,operand))))


(defmacro binderror (it)
  `(error "CLISP: Illegal operand to bind  : ~S " ,it))

(defun bind-action (operand)
  (cond ((null operand)
	 (binderror operand))
	((symbolp operand)
	 (bind-variable operand nil))
	((and (listp operand) (atom (car operand)) (null (cdddr operand))
              (atom (cadr operand))
              (string= "_" (symbol-name(cadr operand))))
	 (let ((brk (clisp-assign operand)))
	   (bind-variable (car brk) (cdr brk))))
        ((listp operand)(mapc #'bind-action operand))
	(t (binderror operand))))


(defun bind-variable (var binding)
    (let ((entry (cl-var-entry-build)))
      (cl-var-reset var-name entry var)
      (and binding (cl-var-reset lam-binding entry binding))))

(defun need-decl (varlst neededlst lst.name)
  ;;If the variable specified by an entry in varlst is in neededlst, add the
  ;;varname to the result.
  (declare (list varlst neededlst)
			(symbol lst.name))
  (mapcan
    #'(lambda (var) (declare (special var))
        (and(consp var)(setq var(car var)));varlist can have
        (when (member-if                  ;initialization forms.
                #'(lambda(atm)
                    (and (symbolp atm)
                         (symbolp var)
                         (string= (symbol-name var)
                           (symbol-name atm))))
                neededlst)
            (setf (symbol-value lst.name)  ;need to know which decls are for 
                  (delete var neededlst))  ;vars that are not bound.
            (list var)))
    varlst))

(defun first-atom (elt)
  (cond ((not (listp elt))elt)
        (t (car elt))))

(defun i.s.declarations (varlst locflg)
; This fn returns a list of declarations to be inserted in the 
;translation at position locflg (either "let" or "prog")
  (let ((specvars (need-decl varlst spec-var-lst 'spec-var-lst))
        (fixnums (need-decl varlst fixnum-var-lst 'fixnum-var-lst))
        (listvars (need-decl varlst list-var-lst 'list-var-lst))
        res)
    (setq res
      `(,@(and specvars
              (list (cons 'special specvars)))
       ,@(and fixnums
              (list (cons 'fixnum fixnums)))
       ,@(and listvars
              (list (cons 'list listvars)))
       ,@(and (eq locflg 'prog);user decs go after the prog(for no good reason)
              other-declarations-lst)
       ,@(and (eq locflg 'prog) ;put out all the decls for unbound atoms.
              spec-var-lst
              (list (cons 'special (mapcar #'first-atom spec-var-lst))))
       ,@(and (eq locflg 'prog)
              fixnum-var-lst
              (list (cons 'fixnum (mapcar #'first-atom fixnum-var-lst))))
       ,@(and (eq locflg 'prog)
              list-var-lst
              (list (cons 'list (mapcar #'first-atom list-var-lst))))))
    (and res (list (cons 'declare res)))))


(defun clisp-make-form ()
  `(let ,let-lst ,@(i.s.declarations let-lst 'let) 
     (prog ,prog-lst ,@(i.s.declarations prog-lst 'prog)
       ,@initialize-lst
       $$lp ,@test-lst-list
       ,@eachtime-lst
       ,@(cl-make-tests test-lst-numeric test-lst-avoid)
       ,@**iterative-body**
       ,@(cond
               ((cl-searchwithin ;;see if the $$iterate label is actually used!
                  '$$iterate    
                  (list initialize-lst test-lst-list
                    eachtime-lst
                    (cl-make-tests test-lst-numeric test-lst-avoid)
                    **iterative-body** after-tests update-lst
                    finalize-lst))
                (list '$$iterate));;label $$iterate is used
               (t nil))    ;;no use of label $$iterate
       
       ,@(clisp-when after-tests
           `((clisp-when
               ,(if (cdr after-tests)
                  `(or ,.after-tests)
                  (car after-tests))
               (go $$out)))
           )
       ,@update-lst
       (go $$lp)
       $$out ,@finalize-lst
       (return $$val))))

(defun cl-searchwithin (item list)
  "searches within 'list' to find if 'item' appears at some level"
  (do ((tp list (cdr tp)) (ans))
      ((if (consp tp)
	   (setq ans (or (eq item (car tp))
			 (clisp-when (consp (car tp))
			   (cl-searchwithin item (car tp)))))
	   (progn (setq ans (eq item tp)) t))
       ans)))

(defun cl-make-tests (numtests when/unless)
  (clisp-when (or numtests when/unless)
    (let ((cnd nil))           ; cnd will become a list of cond clauses
      
      (clisp-when when/unless        ; build forms for when & unless ops.
	(setq cnd
	      (list
	       (cons (if (cdr when/unless)

			 ; then multiple conditions
			 (cons 'or when/unless)

			 ; else single condition

			 (car when/unless))

		     (copy-tree '((go $$ITERATE)))))))
      
      (clisp-when numtests             ; termination forms for a counting loop
	                         ; this will be tested first.
	   (setq cnd
		 (cons (cons (if (cdr numtests)
				 ; then multiple counters
				 (cons 'or numtests)
				 ; else usual case, single counter
				 (car numtests))
			     (copy-tree '((go $$OUT))))
		       cnd)))
      
      ; all done, build the cond.
      
      (list (cons 'cond cnd)))))

;;; The following are the action functions for the on, in, and inside clisp
;;; operators.  Provided no error is found a termporary $$lst# is generated
;;; that will hold the list structure that is to be tranversed, this is bound
;;; to tail.  otherentry will point to the var table entry that represents
;;; tail.  The otherentry feild of the last-iv is filled with tail to indicate
;;; their connection.  The lam-binding field of otherentry is set to the
;;; operand indicating what $$lst# should be bound to upon entry.  The
;;; update-form field of other entry is set to `(cdr tail) thus indicating the
;;; default traversal method, i.e. cdr'ing down a list.  This will be used if
;;; the update-form field of last-iv is nil [it will be non-nil if a by
;;; operator is associated with the current i.v.].  Finally the test form for
;;; the current i.v. (i.e. the test-form field of last-iv) is set to indicate
;;; how the i.v. is to be bound on each iteration and a termination check.  At
;;; this point the last-iv may not have had its var-name filled in, i.e. we see
;;; (in xxx by (cadr xxx) for x do ...),
;;; so we use a generic i.v. name that will be replaced in a latter pass
;;; through the clisp-iv-lst.

(defun on-action (operand)
  ;since the last cdr of the operand can be non-nil, it can not automatically
  ;declare the iv. and the tail to be lists.
    (if (cl-var-look-up tail-name last-iv)
	(format t "~&CLISP: multiple ON operands - ~a" operand)
      ; else
	(let ((otherentry (cl-var-entry-build))
	      (tail (cl-make-symbol '$$lst)))
	  (cl-var-reset var-name otherentry tail)
	  (cl-var-reset lam-binding otherentry operand)
	  (cl-var-reset update-form otherentry (list 'cdr tail))
	  (cl-var-reset tail-name last-iv tail)
	  (let ((tst `(or (consp (setq ,(cl-put last-iv (gensym))
				      ;we use the vartable as a marker
				      ;for where the var-name will go
				      ;during post-list-process
                                      ,tail))
                          (go $$out))))
	    (cl-var-reset test-form last-iv (copy-tree tst))))))


(defun in-action (operand)
    (if (cl-var-look-up tail-name last-iv)
	(format t "~&CLISP: multiple IN operand - ~a" operand)
      ;else
	(let ((otherentry (cl-var-entry-build))
	      (tail (cl-make-symbol '$$lst)))
;last cdr can be non-nil(push tail list-var-lst);declare the temp to be a list.
	  (cl-var-reset var-name otherentry tail)
	  (cl-var-reset lam-binding otherentry operand)
	  (cl-var-reset update-form otherentry (list 'cdr tail))
	  (cl-var-reset tail-name last-iv tail)
	  (let ((tst `(if (consp ,tail)
                        (setq ,(cl-put last-iv (gensym))
				       ;we use the vartable as a marker
				       ;for where the var-name will go
				       ;during post-list-process
                                      (car ,tail))
                        (go $$out))))

	    (cl-var-reset test-form last-iv (copy-tree tst))))))


(defun inside-action (operand)
  (if (cl-var-look-up tail-name last-iv)
      (format t "~&CLISP: multiple INSIDE operand - ~a" operand)
     ;else
      (let ((otherentry (cl-var-entry-build))
	    (tail (cl-make-symbol '$$lst)))
          ;tail is not guarenteed to be a list, so dont declare it.
	(cl-var-reset var-name otherentry tail)
	(cl-var-reset lam-binding otherentry operand)
	(cl-var-reset update-form
		      otherentry `(clisp-when (consp ,tail)(cdr ,tail)))
	(cl-var-reset tail-name last-iv tail)
	(let ((tst `(setq , (cl-put last-iv (gensym))
                          (cond ((null ,tail)(go $$out))
                                ((consp ,tail)(car ,tail))
			        (t ,tail)))))
	  (cl-var-reset test-form last-iv (copy-tree tst))))))

;;; The following few functions hadle what is called the body of the clisp
;;; iterative form.  The important data structure is bound to
;;; **iterative-body**, which evolves into what will appear in the expanded
;;; form.  It starts off as a list, the car telling what the operator was,
;;; (i.e. do, join, count) which will latter be used by cl-get-body.  the cdr
;;; it the list of operands which is in tconc format until body-finish is
;;; called to clean up and put the body in its final form.

(defun body-init nil
  (declare (special cur-op))
  (if (car **iterative-body**)
      (error
       "more than one iterative operator in CLISP iterative statement  : ~S ")
      (setq **iterative-body** (list (intern (symbol-name cur-op)
					     (find-package "CLISP"))
				     **iterative-body**))))

(defun body-action (operand)
  (setf (second **iterative-body**) 
        (tconc (second **iterative-body**) operand)))

(defun body-finish nil
  (let ((bd (cadr **iterative-body**)))
    (if bd
	; then
	(progn(rplaca (cdr **iterative-body**) (car bd))
	      (setq **iterative-body** (cl-get-body **iterative-body**)))

	; else it is not an error for the body to be empty
	; we print an informative message anyway.

	(format t "Empty Iterative body is CLISP form"))))

(defun cl-get-body (bodyform)
  (copy-tree (case (car bodyform)
    (DO (cadr bodyform))
    (COLLECT
     (let ((t1 (cl-make-symbol '$$TEM))
	   (t2 (cl-make-symbol '$$TEM))
	   (h1 (cl-var-entry-build))
	   (h2 (cl-var-entry-build)))
       (cl-var-reset var-name h1 t1)
       (cl-var-reset var-name h2 t2)
       `((setq ,t1 ,(cl-body-extract bodyform))
	 (cond (,t2 (rplacd ,t2 (setq ,t2 (list ,t1))))
	       (t (setq $$val (setq ,t2 (list ,t1))))))
       ))
    (JOIN
     `((setq $$val (nconc $$val ,(cl-body-extract bodyform)))))
    (clisp::COUNT
     (let ((vl (cl-var-entry-fetch '$$VAL)))
       (cl-var-reset lam-binding vl 0)
       `((clisp-when ,(cl-body-extract bodyform) (setq $$val (1+ $$val))))))
    (SUM
     (let ((vl (cl-var-entry-fetch '$$VAL)))
       (cl-var-reset lam-binding vl 0)
       `((setq $$val (+ $$val ,(cl-body-extract bodyform))))))
    (ALWAYS
     (let ((vl (cl-var-entry-fetch '$$VAL)))
       (cl-var-reset lam-binding vl t)
       `((or ,(cl-body-extract bodyform)
	     (setq $$val nil)
	     (go $$out)))))
    (NEVER
     (let ((vl (cl-var-entry-fetch '$$VAL)))
       (cl-var-reset lam-binding vl t)
       `((clisp-when ,(cl-body-extract bodyform)
		    (setq $$val nil)
		    (go $$out)))))
    (THEREIS
     `((clisp-when ,(cl-body-extract bodyform)
		  (setq $$val
			,(and (and last-iv
				   (cl-var-look-up var-name last-iv))
			      `(or ,(cl-var-look-up var-name last-iv)
                                   t)))
		  (go $$out))))
    (t nil))))


(defun clisp-translate-1 (clipper)

  ;; first initialize data structures
  (clisp-initialize)

  ;; Always have a local called $$VAL, create it.
  (let ((val (cl-var-entry-build)))
    (cl-var-reset var-name val '$$VAL))
  
  ;; "parse" the clisp expression
  (clisp-scan clipper)

  ;; do a "semantic analysis"
  (setq after-tests (car after-tests)) ;easy to do here.
  (do ((ivs clisp-iv-lst (cdr ivs)))
      ((null ivs))
    (cl-post-process1 (car ivs)))
  (do ((vars cl-var-table (cdr vars)))
      ((null vars))
    (cl-post-process2 (car vars)))

  ;; everything is ready, build the form.
  (clisp-make-form))

;;; ======================================================================
;;;    S T A R T   O F  P A R S I N G  R O U T I N E S


;;; This is the "parser" for a clisp form  which is bound to clispexpression.
;;; The basic stratagy is to examin each toplevel s-expression in the list,
;;; if one is a clisp operator then clean up any loose ends from the last
;;; operator, do whatever necessary initialization for the new operator, and
;;; then treat all following s-expers up to the next operator as the operands.

(defun clisp-scan (clispexpression)
  (do ((rst clispexpression (cdr rst))
       (clexp)          ; Clexp - current expression being examined.
       (cur-action)
       (next-action)
       (cur-op))
      ((null rst) (cl-finup cur-action))
    
    (setq clexp (car rst))
    (if (and (atom clexp) (not (numberp clexp)))

	; then clexp is potentially an operator.      

	(if (setq next-action (get-clisp-it-action clexp))

	    ; then it is, clean up loose ends and initialize.       

	    (progn (cl-finup cur-action)
		   (setq cur-action next-action)
		   (setq cur-op clexp)
		   (cl-init cur-action))

	    ; else False alarm, process operand      

	    (cl-action cur-action clexp))

	; else Process operand      

	(cl-action cur-action clexp))))



(defun get-clisp-it-action (indicator)
  (gethash (typecase indicator
	     (symbol (symbol-name indicator))
	     (string indicator)
	     (t (error "Panic: get-clisp-it-action given garbage")))
	   Iterative-action-dispatch-table))

;;; cl-finup is called when a new clisp operator is discovered, its job is to
;;; see that what ever post processing that needs to be done is done.
;;; cl-finup rarely has any real work to do.  then cl-init is called, its job
;;; is to make sure that all necessary initialization is done for the
;;; processing of the newly discovered operator.
;;; Both of these function are called with an atomic argument, act, which is
;;; the name of one of the action functions, e.g. by-action.  It is the old
;;; and new action for cl-finup and cl-init respectivly.  These atoms should
;;; name on their property lists the proper cleanup and initialization
;;; functions, which should be functions of no arguments.

(defun cl-finup (act)
  ;(format t "~&Finish up ~s" act)
  (let ((fn (get act 'clisp-it-finish)))
    (if fn
	; then
	(if (null (fboundp fn))
	    ;then
	    ()
	    ; else
	    (funcall fn))
	; else
	t)))


(defun cl-init (act)
  ;(format t "~&Initializeing for operand ~s" act)
  (let ((fn (get act 'clisp-it-init)))
    (if fn
	; then
	(if (null (fboundp fn))
	    ;then  the following print is for implementors info,
	    ;      users should not see it.
	    (format t "~&Clisp: an undefined clisp-init function missing")
	    
	    ;else
	    (funcall fn))
	; else
	(format t "~& Missing INIT fucntion for ~s" act)
	)))

;;; cl-action calles the right function, e.g. fn, which should be something
;;; like for/as-action on an operand of the most recently encountered operator.

(defun cl-action (fn arg)
  ;(format t "~&~%Running function ~s on argument ~%~s" fn arg)
  (if (null (fboundp fn))
      ;then  Debugging info.
      (format t "~& function ~s Doesn't Exist Yet" fn)
      ;else
      (funcall fn arg)))

;;; END OF PARSEIGN ROUTINES
;;; ======================================================================
;;;
;;; ======================================================================
;;;      S T A R T  O F  S E C O N D  P A S S  R O U T I N E S
;;; cl-post-process1 and the several routines that follow it work on members
;;; of the clisp-iv-lst.  That is any entry in the cl-var-table that
;;; represents an iterative variable.  These routines make what ever
;;; adjustments are needed in the update and testing forms that have been
;;; instantiated so far for the i.v. entries.

(defun cl-post-process1 (iventry)
    (let ((tl (cl-var-look-up tail-name iventry))
          (tst (cl-var-look-up test-form iventry))
          (nm (cl-var-look-up var-name iventry))
          (update (cl-var-look-up update-form iventry)))

        ; an IV can be nameless, i.e. (to x do something)  

      (if (null nm)
        ;then
	  (progn (setq nm (cl-make-symbol '$$TEM))
		 (cl-var-reset var-name iventry nm)
                 (and (eq 'numeric (cl-var-look-up numeric/list iventry))
                         ;declare temps created for '(to n do ...)
                      (push nm fixnum-var-lst))))
      
      (if (eq 'numeric (cl-var-look-up numeric/list iventry))
        ;then
	  (cl-post-numeric-process iventry nm
				   (cl-var-look-up num-increment iventry)
				    update
				   (cl-var-look-up num-boundry iventry))
        ;else
	  (cl-post-list-process iventry nm update tst tl
				(cl-var-entry-fetch tl)))))


(defun cl-post-list-process (iventry ivname ivupdate ivtest tailvar tailentry)
    (or (atom ivtest)
	(clisp-when ivtest
					;previously (rplaca (cdr ivtest) ivname))
	  (cl-nsubst ivname iventry ivtest)))
    (if ivupdate
						;then
	(if tailvar
						; then
	    (let ((tlm (cl-var-look-up lam-binding tailentry))
		  (alst (list (cons ivname tailvar))))
	      (and tlm (setq alst (cons (cons tlm tailvar) alst)))
	      (cl-var-reset update-form
			    tailentry
			    `(setq ,tailvar ,(sublis alst ivupdate)))
	      (cl-var-reset update-form iventry nil))
             ;else
	    (cl-var-reset update-form iventry
			  `(setq ,ivname ,ivupdate)))
      ;else
	(clisp-when tailvar
	  (let ((tlup (cl-var-look-up update-form tailentry)))
	    (cl-var-reset update-form tailentry
			  `(setq ,tailvar ,tlup))))))


(defun cl-post-numeric-process (iventry ivname ivincrement ivupdate ivboundry)
    (numeric-increment-post-process iventry ivname ivincrement ivupdate)
    (numeric-test-post-process iventry ivname ivboundry))


(defun numeric-test-post-process (iventry ivname ivboundry)
  (clisp-when ivboundry
    (let ((inc (cl-var-look-up num-increment iventry)))
      (if (numberp inc)
	  ;then
	  (let ((tst
		 (if (minusp inc) '< '>)))
	    (cl-var-reset test-form iventry (copy-tree `(,tst ,ivname ,ivboundry))))

	  ;else
	  (cl-var-reset test-form iventry
			(copy-tree `(clisp-when ,inc
			   (cond ((minusp ,inc)(< ,inc ,ivboundry))
				 (t (> ,inc ,ivboundry))))))
	  ))))

(defun numeric-increment-post-process (iventry ivname ivincrement ivupdate)
    (cond ((null ivupdate)
	   (setq ivincrement (setq ivupdate 1))
	   (cl-var-reset num-increment iventry 1)
	   (cl-var-reset update-form iventry 1)))
    (if (eq ivincrement ivupdate)
      ; then
	(cl-var-reset update-form iventry
		      `(setq ,ivname (+ ,ivname ,ivincrement)))
      ;else
	(let ((stupid (cl-make-symbol '$$TEM))
	      (tement (cl-var-entry-build)))
	  (cl-var-reset var-name tement stupid)
	  (cl-var-reset update-form iventry
			`(setq ,ivname (setq ,stupid (+ ,ivname ,ivupdate))))
	  (cl-var-reset num-increment iventry stupid)))

      ;If by now an initial value hasn't been found, use 1.  

    (or (cl-var-look-up lam-binding iventry)
        (cl-var-reset lam-binding iventry 1)))

;;; cl-post-process1 and the several routines that follow it work on members
;;; of the clisp-iv-lst.  That is any entry in the cl-var-table that
;;; represents an iterative variable.  These routines make what ever
;;; adjustments are needed in the update and testing forms that have been
;;; instantiated so far for the i.v. entries.

(defun cl-post-process2 (entry)
    (let ((datum (cl-var-look-up lam-binding entry)))
      (if datum
        ;then
	  (setq let-lst
		(cons (list (cl-var-look-up var-name entry) datum) let-lst))
        ;else
	  (setq prog-lst (cons (cl-var-look-up var-name entry) prog-lst))))
    (let ((tst (cl-var-look-up test-form entry)))
      (clisp-when tst
	(if (eq (cl-var-look-up numeric/list entry) 'numeric)

	    ;then

	    (setq test-lst-numeric (cons tst test-lst-numeric))

	    ;else

	    (setq test-lst-list (cons tst test-lst-list)))))

    (let ((updt (cl-var-look-up update-form entry)))
      (clisp-when updt (setq update-lst (cons updt update-lst)))))


(defun clisp-initialize nil
    (setq last-iv                nil
          cl-var-table           nil
          $$lstcount             0
          **iterative-body**     (cons nil nil)
          clisp-iv-lst           nil
          let-lst                nil
          prog-lst               nil
          test-lst-numeric       nil
          update-lst             nil
          test-lst-list          nil
          test-lst-avoid         nil
          $$TEMcount             0
          eachtime-lst           nil
          initialize-lst         nil
          finalize-lst           nil
          after-tests            (cons nil nil)
          spec-var-lst           nil
          fixnum-var-lst         nil
          list-var-lst           nil
          other-declarations-lst nil))

;;; The following is a function for decodeing clisp expressions of the form  
;;; atom_s-exp  which is the Clisp form of assignment statement used in the  
;;; bind iterative operator as well as in the record package forms.  operand  
;;; is a list of 1 to 3 elements i.e. (atom _ s-exp), (atom_ s-exp) ,or   
;;; (atom _s-exp).  The value returned is (atom . s-exp).  

(defun clisp-assign (operand)
  (cond  ((cddr operand)
	  (or (and (symbolp (cadr operand))
		   (string-equal (symbol-name (cadr operand)) "_")
		   (symbolp (car operand))
		   (cons (car operand) (caddr operand)))
	      (error "Illegal Clisp Assignment : ~S " operand)))
	 ((cdr operand)
	  (let ((back nil)
		(frnt (split-charcodes (symbol-name (car operand)) 95)))
	    (cond ((cadr frnt)
		   (cons (intern (car frnt)) (cadr operand)))
		  ((cadr
		    (setq back
			  (split-charcodes (symbol-name (cadr operand)) 95)))
		   (cons (car operand) (intern (car back))))
		  (t (cons (car operand) (cadr operand))))))
	 (t (let ((split (split-charcodes (symbol-name (car operand)) 95)))
	      (if (cadr split)
		  (cons (intern (car split)) (intern (caddr split)))
		  (cons (car operand) nil))))))

(setf Iterative-action-dispatch-table (make-hash-table :test #'equal :size 51))

(defun set-clisp-it-action (string atom)
  (if (symbolp string)(setq string (symbol-name string)))
  (setf (gethash string Iterative-action-dispatch-table) atom))


(set-clisp-it-action 'bind 'bind-action )


(setf (get 'bind-action 'clisp-it-init) 'clisp-no-op)


(setf (get 'finally-action 'clisp-it-finish) 'finally-finish)


(setf (get 'finally-action 'clisp-it-init) 'finally-init)


(set-clisp-it-action 'finally 'finally-action )


(set-clisp-it-action 'first 'first-action )


(setf (get 'first-action 'clisp-it-init) 'first-init)


(setf (get 'first-action 'clisp-it-finish) 'first-finish)


(set-clisp-it-action 'eachtime 'eachtime-action )


(setf (get 'eachtime-action 'clisp-it-init) 'eachtime-init)


(setf (get 'eachtime-action 'clisp-it-finish) 'eachtime-finish)


(setf (get 'until-action 'clisp-it-init) 'clisp-no-op)


(set-clisp-it-action 'until 'until-action )


(setf (get 'while-action 'clisp-it-init) 'clisp-no-op)


(set-clisp-it-action 'while 'while-action )


(setf (get 'unless-action 'clisp-it-init) 'clisp-no-op)


(set-clisp-it-action 'clisp::unless 'unless-action )


(setf (get 'when-action 'clisp-it-init) 'clisp-no-op)


(set-clisp-it-action 'clisp::when 'when-action )


(set-clisp-it-action 'for 'for/as-action )


(set-clisp-it-action 'as 'for/as-action )


(setf (get 'for/as-action 'clisp-it-init) 'for/as-init)


(set-clisp-it-action 'to 'to-action )


(setf (get 'to-action 'clisp-it-init) 'to-init)


(set-clisp-it-action 'from 'from-action )


(setf (get 'from-action 'clisp-it-init) 'from-init)


(set-clisp-it-action 'in 'in-action )


(setf (get 'in-action 'clisp-it-init) 'in-init)


(setf (get 'on-action 'clisp-it-init) 'on-init)


(set-clisp-it-action 'on 'on-action )


(set-clisp-it-action 'inside 'inside-action )


(setf (get 'inside-action 'clisp-it-init) 'inside-init)


(set-clisp-it-action 'by 'by-action )


(setf (get 'by-action 'clisp-it-init) 'by-init)


(setf (get 'body-action 'clisp-it-init) 'body-init)


(set-clisp-it-action 'do 'body-action )


(set-clisp-it-action 'thereis 'body-action )


(set-clisp-it-action 'always 'body-action )


(set-clisp-it-action 'clisp::count 'body-action )


(set-clisp-it-action 'sum 'body-action )


(set-clisp-it-action 'join 'body-action )


(set-clisp-it-action 'collect 'body-action )


(set-clisp-it-action 'never 'body-action )


(setf (get 'body-action 'clisp-it-finish) 'body-finish)


(set-clisp-it-action 'repeatuntil 'repeatuntil-action )


(setf (get 'repeatuntil-action 'clisp-it-init) 'clisp-no-op)


(set-clisp-it-action 'repeatwhile 'repeatwhile-action )


(setf (get 'repeatwhile-action 'clisp-it-init) 'clisp-no-op)




(defmacro movdqq (from too)
  (declare (ignore from))
  `(progn 'compile
	  (defmacro ,too (&rest form)
	    (clisp:clisp-translate (cons ',too form)))
	  ))


(defun clisp-translate (x)
  (let ((last-iv                 nil)
	(cl-var-table           nil)
	($$lstcount             0)
	(**iterative-body**     nil)
	(clisp-iv-lst           nil)
	(let-lst                nil)
	(prog-lst               nil)
	(test-lst-numeric       nil)
	(update-lst             nil)
	(test-lst-list          nil)
	(test-lst-avoid         nil)
	($$TEMcount             0)
	(eachtime-lst           nil)
	(initialize-lst         nil)
	(finalize-lst           nil)
	(after-tests            nil)
	(spec-var-lst           nil)
	(fixnum-var-lst         nil)
	(list-var-lst           nil)
	(other-declarations-lst nil))
    
    (let ((tran (clisp::clisp-translate-1 x)))
      (if tran tran				;(clisp:CLISPTRAN x tran)
	  (error "|Bad Clisp Translation| : ~S" x)))))


(eval-when (load eval)
  (movdqq bind bind)
  ;(movdqq bind clisp::count)
  (movdqq bind never)
  (movdqq bind as)
  (movdqq bind by)
  (movdqq bind in)
  (movdqq bind on)
  (movdqq bind to)
  (movdqq bind always)
  (movdqq bind while)
  (movdqq bind until)
  (movdqq bind from)
  (movdqq bind join)
  (movdqq bind inside)
  ;(movdqq bind when)
  (movdqq bind thereis)
  (movdqq bind for)
  (movdqq bind sum)
  (movdqq bind finally)
  (movdqq bind collect)
  ;(movdqq bind unless)
  (movdqq bind eachtime)
  ;(movdqq bind first)
  (movdqq bind repeatuntil)
  (movdqq bind repeatwhile))


(defun clisp-declare-action (x)
  (cond
    ((not(consp x))nil)
    ((consp(car x))(clisp-declare-action(car x))
     (clisp-declare-action(cdr x)))
    ((and (symbolp (car x))(string= (symbol-name (car x)) "FIXNUM"))
     (setf fixnum-var-lst(append (cdr x) fixnum-var-lst)))
    ((and(symbolp (car x))(string= (symbol-name (car x)) "SPECIAL"))
     (setf spec-var-lst(append (cdr x) spec-var-lst)))
    ((and(symbolp (car x))(string= (symbol-name (car x)) "LIST"))
     (setf list-var-lst (append (cdr x) list-var-lst)))
    (t (push x other-declarations-lst))))



(set-clisp-it-action 'declare 'clisp-declare-action)

(setf (get 'clisp-declare-action 'clisp-it-init) 'clisp-no-op);no init fn.


; some utilities used in the above.


(defun split-charcodes (string char)
  (declare (string string)(character char))
  (let ((len (1- (length string)))
	(pos (position char string)))
    (if (null pos) (error "bad string to split-charcodes : ~S " string))
    (list (clisp-unless (zerop pos)(subseq string 0 pos))
	  char
	  (clisp-unless (eq len pos) (subseq string (1+ pos ))))))
  

; %%un-dwim-translate used by anything that would change an list that would
; be evaluated to remove any translations that might be tucked away in the
; CLISPARRAY.  At present only planned to by used by the converted clisp
; forms.  CQ 2/15/82.


(defun %%un-dwim-translate (somelist)
    (and (consp somelist)(boundp 'CLISPARRAY)(Un-Dwimify somelist CLISPARRAY)))

(defun Un-Dwimify (somelist array)
      (remhash somelist array)
      (do ((l somelist (cdr l)))
	  ((not (consp l)))
	  (and (consp (car l))(Un-Dwimify (car l) array))))


(defun CLISPTRAN (a b)
	    (and (boundp 'clisp:CLISPARRAY) clisp:CLISPARRAY
		 (setf (gethash a clisp:CLISPARRAY) b))
	    b)

(defvar cl-subst-harray (make-hash-table :size 10 ))

(defun cl-get (old) (or (gethash old cl-subst-harray) old))

(defun cl-put (old val) (setf (gethash old cl-subst-harray) val) val)

(defun cl-subst (new old tree) (subst new (cl-get old) tree))

(defun cl-nsubst (new old tree) (nsubst new (cl-get old) tree))
