(* This is the aardvark compiled code processor. *)

(globalvars global-env global-env-hash-array)

(globalvars *return-opcode*  *const-opcode* *var-opcode* 
      *pcheck-opcode* *call-opcode* *tail-call-opcode* 
      *call-objectified-opcode* *tail-call-objectified-opcode*
      *lambda-opcode* *if-opcode* *primitive-opcode* 
      *gset-opcode* *rcons-opcode* *halt-opcode*)

(datatype continuation (pc env data cont))

(defun 1.9-lisp (stream) 
   (do (ersetq (1.9-lisp-kernel stream))))

(defun 1.9-lisp-kernel (stream)
  (prog (exp env pc data cont inst opcode instargs result
         must-save nargs backwards-arg-list temp proc
         culprit message pattern-info nexpected only-arg
         pattern body primitive-name var contour var-list 
         env-temp val-list val n nexecuted nconses nmsec
         start-time freq-table time-table first-opcode last-opcode
         this-tick last-tick opname-alist)
     (setq first-opcode *return-opcode*)
     (setq last-opcode *halt-opcode*)
     (setq freq-table 
       (array (add1 (idifference last-opcode first-opcode)) 
              NIL 0 first-opcode))
     (setq time-table  
       (array (add1 (idifference last-opcode first-opcode)) 
              NIL 0 first-opcode))
     (setq opname-alist 
        (list (list *return-opcode* 'ret)
              (list *const-opcode* 'const)
              (list *var-opcode* 'var)
              (list *pcheck-opcode* 'pcheck)
              (list *call-opcode* 'call)
              (list *tail-call-opcode* 'tcall)
              (list *call-objectified-opcode* 'callo)
              (list *tail-call-objectified-opcode* 'tcallo)
              (list *lambda-opcode* 'lambda)
              (list *if-opcode* 'if)
              (list *primitive-opcode* 'primitive)
              (list *gset-opcode* 'gset)
              (list *rcons-opcode* 'rcons)
              (list *halt-opcode* 'halt)))

   read-normalise-print
     (setq exp (prompt&read stream))
     (setq env global-env)
     (setq pc (aardvark exp global-env))
     (setq data ())
     (setq cont 
        (create continuation 
           pc _ (list (list *halt-opcode*)) 
           env _ env 
           data _ data
           cont _ nil))
     (setq nexecuted 0)
     (for i from first-opcode to last-opcode do
        (seta freq-table i 0)
        (seta time-table i 0))
     (setq start-time (clock))
     (conscount 0)
     (setq last-tick (clock))
     (setq opcode *halt-opcode*)
     
   decode
     (setq this-tick (clock))
     (seta time-table opcode
        (iplus (elt time-table opcode)
               (idifference this-tick last-tick)))
     (setq last-tick this-tick)
     (setq nexecuted (add1 nexecuted))
     (setq inst (car pc))
     (setq pc (cdr pc))
     (setq opcode (car inst))
     (seta freq-table opcode (add1 (elt freq-table opcode)))
     (setq instargs (cdr inst))
     (if (eq opcode *return-opcode*) then
         (go return))
     (if (eq opcode *const-opcode*) then
         (go const))
     (if (eq opcode *var-opcode*) then
         (go var))
     (if (eq opcode *pcheck-opcode*) then
         (go pcheck))
     (if (eq opcode *call-opcode*) then
         (go call))
     (if (eq opcode *tail-call-opcode*) then
         (go tail-call))
     (if (eq opcode *call-objectified-opcode*) then
         (go call-objectified))
     (if (eq opcode *tail-call-objectified-opcode*) then
         (go tail-call-objectified))
     (if (eq opcode *lambda-opcode*) then
         (go lambda))
     (if (eq opcode *if-opcode*) then
         (go if))
     (if (eq opcode *primitive-opcode*) then
         (go primitive))
     (if (eq opcode *gset-opcode*) then
         (go gset))
     (if (eq opcode *rcons-opcode*) then
         (go rcons))
     (if (eq opcode *halt-opcode*) then
         (go halt))
    (shouldnt 'Bad-3-lisp-opcode)
     
   const
     (setq data (cons (car instargs) data))
     (go decode)

   var
     (setq var (car instargs))
     (setq env-temp env)      
   next-contour
     (if (null env-temp) then
         (go global-binding))
     (setq contour (car env-temp))
     (setq env-temp (cdr env-temp))
     (setq var-list (car contour))
     (setq val-list (cadr contour))
   next-binding-this-contour
     (if (null var-list) then
         (go next-contour))
     (if (eq (car var-list) var) then
         (setq result (car val-list))
         (go success))
     (setq var-list (cdr var-list))
     (setq val-list (cdr val-list))
     (go next-binding-this-contour)
   global-binding
     (setq val (gethash var global-env-hash-array))
     (if (null val) then
         (go failure))
     (if (eq val 'nil.surrogate) then 
         (setq result nil)
     else 
         (setq result val))
     (go success)
   success
     (setq data (cons result data))
     (go decode)
   failure
     (setq culprit var)
     (setq message "unbound variable")
     (go diagnose-error)


   pcheck
     (setq proc (car data))
     (if (neq (car proc) *closure*) then
         (setq culprit proc)
         (setq message "not reducible")
         (go diagnose-error))
     (if (atom (caddr proc)) then
         (shouldnt "Surprised by a special closure."))
     (go decode)

   call
     (setq must-save t)
     (go non-objectified-arguments)

   tail-call
     (setq must-save nil)
   non-objectified-arguments
     (setq nargs (car instargs))
     (setq temp data)
     (for i from 1 to nargs do
        (setq temp (cdr temp)))
     (go general-call)
     
   call-objectified
     (setq must-save t)	
     (setq nargs -1)
     (setq temp (cdr data))
     (go general-call)

   tail-call-objectified
     (setq must-save nil)
     (setq nargs -1)
     (setq temp (cdr data))
     (go general-call)
     
   general-call
     (setq backwards-arg-list data)
     (setq proc (car temp))

     (if must-save then
         (setq cont
            (create continuation 
                pc _ pc 
                env _ env
                data _ (cdr temp) 
                cont _ cont)))

     (setq pc (cadddr proc))
     (setq data ())

     (setq pattern-info (caddr proc))
     (setq nexpected (car pattern-info))

     (if (ieqp nexpected nargs) then
         (* Handle both easy cases: n to n, 
            and objectified to nospread. *)
         (go done-call)) 

     (if (ieqp nexpected -1) then
         (* Collect all arguments into a rail. *)
         (setq temp backwards-arg-list)
         (setq result (rcons0))
         (for i from 1 to nargs do
            (setq result (prep (car temp) result))
            (setq temp (cdr temp)))
         (setq backwards-arg-list (list result))
         (go done-call))

     (if (ieqp nargs -1) then
         (* Spread the objectified argument rail. *)
         (setq only-arg (car backwards-arg-list))
         (if (not (rail? only-arg)) then
             (go mismatch))
         (setq nargs (rlength only-arg))
         (if (not (ieqp nexpected nargs)) then
             (go mismatch))
             
         (setq temp only-arg)
         (setq backwards-arg-list nil)
         (for i from 1 to nargs do
             (setq backwards-arg-list 
                 (cons (first temp) backwards-arg-list))
             (setq temp (rest temp)))
         (go done-call))

   done-call
     (setq env (cons (list (cdr pattern-info)
                           backwards-arg-list)
                     (cadr proc)))
     (go decode)


     (* Otherwise there is an argument/pattern mismatch. *)

   mismatch
     (setq culprit proc)
     (setq message "wrong number of arguments")
     (go diagnose-error)


   return
     (setq pc   (ffetch pc of cont))
     (setq env  (ffetch env of cont))
     (setq data (cons (car data) (ffetch data of cont)))
     (setq cont (ffetch cont of cont))
     (go decode)

   lambda
     (setq pattern (car instargs))
     (setq body (cadr instargs))
     (setq result (ccons env pattern body))
     (setq data (cons result data))
     (go decode)

   if
     (setq temp (car data))
     (setq data (cdr data))
     (if (null temp) then
         (setq pc (cadr instargs))
         (go decode))
     (if temp then
         (setq pc (car instargs))
         (go decode))

     (setq culprit temp)
     (setq message "IF expects a boolean")
     (go diagnose-error)

   primitive
     (* Note that this instruction must be the entire
        body of some closure. *)
     (setq primitive-name (car instargs))
     (if (nlsetq
           (setq result (apply primitive-name (cadar env))) 
           t) then
         (setq data (list result))
         (go return))

     (setq culprit primitive-name)
     (setq message "error in a primitive")
     (go diagnose-error)
 
   gset
     (setq var (car instargs))
     (puthash var 
        (if (null (car data)) then 'nil.surrogate else (car data))
        global-env-hash-array)
     (go decode)

   rcons
     (setq nargs (car instargs))
     (setq temp (rcons0))
     (for i from 1 to nargs do
         (setq temp (prep (car data) temp))
         (setq data (cdr data)))
     (setq data (cons temp data))
     (go decode)

   halt
     (setq result (car data))
     (setq nconses (conscount))
     (setq nmsec (difference (clock) start-time))
     (prompt&print result stream)
     (printout promptwindow
        nmsec " msec.; "
        nexecuted " inst.; " 
        nconses " conses" t)
     (for i from first-opcode to last-opcode do
         (printout promptwindow 
            (assoc i opname-alist) ": n=" 
            (elt freq-table i) ", T=" 
            (elt time-table i) ";  "))
     (printout promptwindow t) 
     (go read-normalise-print)

   diagnose-error
     (printout stream "*** " message "." t)
     (printout stream "Hint: " .ppv (export culprit) t)
     (printout stream t "Reset." t)
     (setq message nil)
     (setq culprit nil)
     (go read-normalise-print)
))


STOP