;;; -*- mode:lisp;package:user;base:10.;fonts: cptfont -*- 
;;; $Header: /ct/interp/driver.l,v 1.37 84/08/16 16:07:10 penny Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              DRIVER                              ;;;
;;; Mark Miller and Paul Robertson                          6-Feb-83 ;;;
;;; See last page for edit history.                                  ;;;
;;;								     ;;;
;;;          The Backend Driver of the C*T Ada Interpreter           ;;;
;;;                                                                  ;;;
;;;   Initializes an activation record, tree walks the Diana S-expr, ;;;
;;; and so on, supporting the Dynamic Semantic Functions.  Similar   ;;;
;;; in flavor to a micro-code engine, with specials serving a role   ;;;
;;; analogous to the hardware machine registers.                     ;;;
;;;                                                                  ;;;
;;; This file is part of a proprietary software project.  Source     ;;;
;;; code and documentation describing implementation details are     ;;;
;;; available on a confidential, non-disclosure basis only.  These   ;;;
;;; materials, including this file in particular, are trade secrets  ;;;
;;; of Computer * Thought Corporation.                               ;;;
;;;                                                                  ;;;
;;; (c) Copyright 1982 and 1983,  Computer * Thought Corporation.    ;;;
;;;     All Rights Reserved.                                         ;;;
;;;                                                                  ;;;
;;; Reference materials:                                             ;;;
;;;   Foderaro and Sklower, The FRANZ LISP Manual, September 1981.   ;;;
;;;   Weinreb and Moon, LISP MACHINE MANUAL, Symbolics, July 1981.   ;;;
;;;   Charniak et al., 1980.  Artificial Intelligence Programming.   ;;;
;;;   Miller, 1982.  The C*T Ada Tutor: Guide to the Implementation. ;;;
;;;   Tartan Labs, 1982.  The Diana Reference Manual.                ;;;
;;;   Robertson & Miller, 1982.  The C*T Diana Virtual Machine.      ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment Assumes presence of ct_load and a suitable database)

(eval-when (compile load eval) (ct_load 'aip))	   ;;AIP macros pkg. 

(eval-when (compile load eval) (ct_load 'compat))  ;;Franz/LM compat pkg. 

(eval-when (compile load eval) (ct_load 'diana))   ;;Diana internal rep.

#+franz
(eval-when (compile load eval) (ct_load 'format))  ;;Compatible formatted IO.

(eval-when (compile load eval) (ct_load 'ctflav)) ;;LM-compat flavors

(eval-when (compile load eval) (ct_load 'ferec))  ;;Nodestagerec,Exceptionrec

(eval-when (compile load eval) (ct_load 'dsmacs)) ;;For dynamic_mother macro.

(eval-when (compile load eval) (ct_load 'queue))   ;;Task queues

(eval-when (compile load eval) (ct_load 'adabe))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

(declare (ct_includef 'intrpdcl)) ; Declarations for entire interpreter
;;; NB: Many declarations moved to intrpdcl --mlm

;;; Setq to t to cause a break on each cycle of the diana machine.
(cond ((not (boundp '*debug_dvm*)) (setq *debug_dvm* nil))) ;;++tst

(cond ((not (boundp '*dvm_cycle_counter*)) (setq *dvm_cycle_counter* 0)))

;;; Setq to t to track process switching in the virtual machine.
(cond ((not (boundp '*debugscheduler*)) (setq *debugscheduler* nil))) ;;++tst

(defconst *default_task_priority* 10.
  "The default priority for all tasks.  Since all tasks have the same
   priority (for now), this number could be anything.")

(defvar *scheduler_algorithm* 'round_robin
  "The method used to retrieve the next task to execute.  This must be the
   name of a method for QUEUE_OF_PRIORITY_QUEUES; right now, the only
   one is ROUND_ROBIN.  See QUEUE.L.")

(defvar *task_cyclecounter* 0.
  "Keep track of the number of cycles that have run since the last task
   switch.  At the top of the interpreter loop, this is incremented and
   mod-ed with *TASK_CYCLEFREQUENCY*.")

(defvar *task_cyclefrequency* 5.
  "The number of interpreter cycles that take place between task switches.
   See *TASK_CYCLECOUNTER*")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 

(defun nodestage (node stage alist)
 ;;; A nodestage is an element in an alist in which the node id is the key.
 ;;; The most common field needed is the stage so that is in the cadr.
 ;;; The cddr is an alist of bindings owned by the dynamic semantic routines
 ;;; for processing this particular node of this particular activation record.
 ;;; (What goes there is up to the dynamic semantic functions.)
 ;;; The stage is a counter used by the driver and passed to the dynsem funs,
 ;;; for how often the node has been visited, ie., what stage of processing
 ;;; it is at.
  (nodestagerec (diana_get node 'ct_id) stage alist nil))

(defun adabe_nodestage_get (ar node)
  " Gets the nodestage object associated with node for this activation. 
    The nodestages field is an a-list with node as the key. "
  (let ((id (diana_get node 'ct_id)))
    (do ((stagelist (get-iv adabe_activation ar nodestages)
		    (cdr stagelist))) ;;jrm change
	((null stagelist) nil)
      (cond ((eq (nodestagerec%id (first stagelist)) id)
	     (return (first stagelist)))))))

;;; continued
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros, continued --

(defun adabe_nodestage_cnt (node)
  (let ((ndstage (adabe_nodestage_get *activation*  node)))
    (cond
      (ndstage (let ((stage (1+ (nodestagerec%stage ndstage))))
		   (%= (nodestagerec%stage ndstage) stage)
		   stage))
      (t (setq *nodestages*
	       (set-iv adabe_activation *activation*
		       nodestages (cons (nodestage node 1. nil)
					   (get-iv adabe_activation
						   *activation*  nodestages))))
	 1.))))


(defun adabe_nodestage_reset (node);(ar node)
    (setq *nodestages*
	  (set-iv adabe_activation  *activation*  nodestages
	     (cons (nodestage node 1. nil)(get-iv adabe_activation
						  *activation* nodestages))))
    1)
	       

;;;BUMP_CYCLECOUNTER: Increment and remainder *TASK_CYCLECOUNTER*; this
;;;ultimately determines whether it's time to switch task processes.

(defun bump_cyclecounter nil
  (setq *task_cyclecounter*
	(remainder (setq *task_cyclecounter* (+ *task_cyclecounter* 1))
		   *task_cyclefrequency*)))

; Simple check that a thing looks like a hooked function. WAB

(defun funcp (thing)
    (and (symbolp thing) (#+franz getd #+lispm fboundp thing)))

;
; Optionally run a hooked function. Try a few simple cases to see what type of hook
; we have.
;

(eval-when (compile load eval)
(defun maybe_run_hook macro (l);(hook &optional arg_list)
       (let ((hook (second l))(arg_list (third l)))
	 `(cond ((null ,hook))
		((funcp ,hook) (apply ,hook ,arg_list))
		((and (listp ,hook) (funcp (car ,hook)))
		 (apply (car ,hook) (append ,arg_list (cdr ,hook)))))))

; 
; Hook functions modified 9-12-83 to accomidate other forms besides funcall. WAB
; (maybe_run_prehook 'foo)

(defun maybe_run_prehook macro (pc)
       `(maybe_run_hook (diana_get ,(cadr pc) 'ct_prehook)
			(list ,(cadr pc) 'before)))

(defun maybe_run_posthook macro (pc)
       `(maybe_run_hook (diana_get ,(cadr pc) 'ct_posthook)
			(list ,(cadr pc) 'after)))

; 
; Called once each time around the back end before a node is begun. WAB
; 

(defun maybe_run_prefetchhook macro (pc)
       `(maybe_run_hook (diana_late_get *diana* 'ct_prefetchhook)
			(list ,(cadr pc) 'prefetch)))

; 
; Called once each time around the back end after a node is finished. WAB
; 

(defun maybe_run_postfetchhook macro (pc)
       `(maybe_run_hook (diana_late_get *diana* 'ct_postfetchhook)
			(list ,(cadr pc) 'postfetch)))

; 
; Called once each time around the back end when a node is resumed. WAB
; 

(defun maybe_run_resumefetchhook macro (pc);takes second arg of resume pc
       `(maybe_run_hook (diana_late_get *diana* 'ct_resumefetchhook)
			(list ,(cadr pc) ,(caddr pc) 'resumefetch)))


(defun dynsemfun macro (pc)
;  `(diana_def_get (diana_nodetype_get ,(cadr pc))))
  `(fdefinition (diana_nodetype_get ,(cadr pc))))
)
(defun visiting (pc stage)
   " For debugging, eg, when visit a node that is not yet implemented. "
   (freshline *listing*)
   (ct_princ "Visiting Diana Node: " *listing*)
   (ct_princ (diana_get pc 'ct_id) *listing*)
   (ct_princ ", stage " *listing*)
   (ct_princ stage *listing*)
   (cond ((null (dynsemfun pc)) (ct_princ "  [NYI]." *listing*)))
   (ct_terpri *listing*)
   nil)

;;;(rundynsem 'pc 'stage)
#|
(eval-when (compile load eval)
(defun rundynsem macro (l);(pc stage)
  " Run the dynamic semantics fun for node PC at processing stage STAGE. "
  (let ((pc (second l))(stage (third l)))
  `(let ((fun (dynsemfun ,pc)))
    (cond
     (fun (funcall fun ,pc ,stage))   
     (t (cond ((status feature debugging) (visiting ,pc ,stage)))
        (lose 'nyi 'rundynsem
         '("Your program uses Ada constructs which are not yet fully implemented.")
	 `("Node = ~A,~%Type = ~A,~%Stage = ~D."
	    ,(diana_get pc 'ct_id)
	    ,(diana_nodetype_get pc)
	    ,stage)
	  nil nil))))))
)
|#

(eval-when (compile load eval)
(defun rundynsem macro (l);(pc stage)
  " Run the dynamic semantics fun for node PC at processing stage STAGE. "
  (let ((pc (second l))(stage (third l)))
    `(funcall (diana_nodetype_get ,pc) ,pc ,stage)))
)

(defun splice_out_car_eq (key l)
  ;;; Destructively splices out items in l whose cars are eq to key.
  ;;; Returns MODIFIED l, does not cons.
  (cond
    ((eq key (caar l))
     (do ((dsl (nodestagerec%alist (car l)) (cdr dsl)))
	 ((null dsl))
       (rplaca (car dsl) nil))		  ;stomp on it!!
     (cdr l))				  ; if the first node is it, return the cdr
    (t (splice_out_car_eq_aux key l)
       l))
  )

(defun splice_out_car_eq_aux (key l)
  (do ((rst l (cdr rst)))
      ((or (null rst)
	   (cond
	     ((eq (caadr rst) key)
	      ;; now then, the dying nodestage is the cadr.
	      ;; the ds alist is in (nodestagerec%alist (cadr rst)) clobber them.
	      (do ((dsl (nodestagerec%alist (cadr rst)) (cdr dsl)))
		  ((null dsl))
		(rplaca (car dsl) nil))	  ;stomp on it!!
	      ;; and now zap its last remains from the nodestage list.
	      (rplacd rst (cddr rst)) t ))))))

(defun splice_out_obsolete_nodestages (nod)
  ;;; Why had someone commented out the body of this?  -- mlm ++
  ;;; beats me -PR-
  (setq *nodestages*
	(set-iv adabe_activation   *activation* nodestages
	   (splice_out_car_eq (diana_get nod 'ct_id)
			      (get-iv adabe_activation
				      *activation*  nodestages)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros -- 

;;; (declare (special *total_number_of_runnable_tasks*))
(defun adabe (*diana* *listing* *errin* *errout* *userin* *userout*)
  " The Top Level Back End Driver of the C*T Ada Interpreter. "
  ;;; Expects a Diana S-expression as input, plus 5 streams/ports.
  ;;; Vars in *stars* are specials -- see notes above.
  ;;; Normal return is t, but nil if unhandled exception occurs.
  (let*					  ;This catches unhandled exceptions.
    ((*exception* nil)			  ;Ie., Ada runtime errors.
     (*root_task_queue* (ct_make_instance 'queue_of_priority_queues))
     (*infrontend* nil)
     ;;+++++
     (catchval
       (*catch 'runtime_error
	 (prog (*activation* *nuactivation* *continuation* *resume*
		*dynamic_locals_alist* *nodestages* *dynamic_mother_locals_alist*
;		*total_number_of_runnable_tasks*
		threadp pc stage newpc vector tutorp)
	       (declare (fixnum stage))
	       (setq *dvm_cycle_counter* 0)

	       ;; Check to see if running inside tutor.
	       (ct_if (status_feature 'tutor)
		      (setq tutorp t)
		      (setq tutorp nil))
	       
	       ;; If the Tutor says we were wrenched, and there is a saved-state,
	       ;; we restore our state from that, calling it vector.  (Not using
	       ;; records because I am under the impression that there is a
	       ;; (smaller) limit to items in records.)
	       
	       ;; John -- NB!! -- You have to add some new fields to
	       ;; your state vectors, as of May 14, 1983!!!  ++mlm
	       (cond ((and tutorp
			   (ada_wrenched_p_fcn)
			   ;;;;;;Old way commented out 14 May -- genec:
			   ;;;;;;(ct_send *userin* ':wrenched_p)
			   (setq vector
				 (ada_saved_state_fcn)
				 ;;;;;(ct_send *userin* ':saved_state)
				 ))
		      (setq *diana* (nth 0 vector)
			    *listing* (nth 1 vector)
			    *errin* (nth 2 vector)
			    *errout* (nth 3 vector)
			    *userin* (nth 4 vector)
 			    *userout* (nth 5 vector)
			    *activation* (nth 6 vector)
			    *nuactivation* (nth 7 vector)
			    *continuation* (nth 8 vector)
			    threadp (nth 9 vector)
			    pc (nth 10. vector)
			    stage (nth 11. vector)
			    newpc (nth 12. vector)
			    *resume* (nth 13. vector)
			    *root_task_queue* (nth 14. vector)
			    *current_task* (nth 15. vector))
		      (go continue-point)))
	       
	       ;;Make sure the Diana tree is well-formed -- its car is a legal
	       ;;Diana node, and its cdr is nil (with the balance being a
	       ;;disembodied property list).
	       
	       (cond ((not (diana_nodep *diana*))  ;Weaken this test? ++mlm
		      (lose 'diana_not_well_formed 'adabe
			    ()	; demo version of info
			    `("There is a problem with the diana: ~A."
			      ,(cond ((consp *diana*)
				      (diana_get *diana* 'ct_id))
				     (t *diana*)))
		            nil nil)))
	       
	       ;;Create the threaded version of the diana node
	       ;; diana wil be threaded before this point
	       ;(setq *diana* (diana_threadify *diana*))
	       
	       ;;Set the trace indentation to 0
	       (setq *tracedepth* 0)
	       
	       ;;Save *DIANA* for debugging purposes
	       (setq *last_diana* *diana*)
	       
	       ;;Initialize PC to toplevel Diana node,  STAGE to 1 (=> 1-indexing),
	       ;;and *CONTINUATION* to nil.
	       
	       (setq pc *diana*
		     stage 1.
		     *continuation* nil
		     *resume* nil)
	       
	       ;;Create the toplevel activation record from *diana*.
	       
	       (setq *activation*
		     (ct_make_instance 'adabe_activation 
				    'pnl 0;was 1
				    'pc pc
				    'node *diana*
				    'alink nil
				    'clink nil
				    ;;NODESTAGES is essentially a
				    ;;stack of associations between
				    ;;the current node (via its ct_id),
				    ;;its stage, and its alist of local
				    ;;variables (none of which exist
				    ;;here).
				    'nodestages
				    (list (nodestage *diana* stage nil))
				    'arid (gensym)
				    'enhook nil
				    'exhook nil
				    'locals nil))
	       (setq *nodestages* (get-iv adabe_activation
					  *activation* nodestages))
	       ;;Store this activation record in a task queue with priority =
	       ;;*DEFAULT_TASK_PRIORITY* and with no superior task (i.e.,
	       ;;the final parameter in the message is NIL.  This task becomes
	       ;;the *CURRENT_TASK*; make it runnable.  (That is, 
	       ;;ADD_TASK_TO_PRIORITY_QUEUE does not automatically make
	       ;;added tasks runnable; nor does DELETE_YOURSELF_FROM_QUEUE
	       ;;automatically undo the runnable state of the task.  This 
	       ;;shoule maybe be changed, but it should work for now as long
	       ;;as we're careful.)
	       (setq *total_number_of_runnable_tasks* 0)
	       (setq *current_task*
		     (second
		       (ct_send *root_task_queue* 'add_task_to_priority_queue
				*default_task_priority*
				*activation*
				nil
				'*Main*Program*)))
	       (ct_send *current_task* 'make_runnable)
	       (ct_send *current_task* 'set-terminated nil)
	   
	       ;;initiate the *ada_default_input* and *ada_default_output*
	       ;; if *userin* or *userout* was bound then change the standard
	       ;; input or output to it respectively.
	      
	       (cond ((boundp '*userout*) 
		      (setq *ada_default_output*
		       (ct_make_instance 'ada_output_stream
				      'name "standard output"
				      'real_stream *userout*
				      'max_column 80
				      'status 'open))
		      (setq **text_file_list** (replace_nth **standard_output**
							    *ada_default_output*
							    **text_file_list**))))

	       (cond ((boundp '*userin*) 
		      (setq *ada_default_input*
		       (ct_make_instance 'ada_input_stream
				      'name "standard input"
				      'real_stream *userin*
				      'terminal_style_io t
				      'status 'open))
		      (setq **text_file_list** (replace_nth **standard_input**
							    *ada_default_input*
							    **text_file_list**))))
	       
    
	       ;;Store a backpointer to this task instance in the activation
	       ;;record.
	       
	       (ct_send  *activation*
		       'set-taskinstance *current_task*)
	       
	       ;;Set the "most recently executed" pointers to point to
	       ;;*CURRENT_TASK*.  This need be done only once -- they will
	       ;;be updated by ROUND_ROBIN when that message is used.
	       
	       (ct_send *root_task_queue* 'set_most_recently_executed_task
			*current_task*)
	       (ct_send (ct_send *current_task* 'myqueue)
			'set_most_recently_executed_task *current_task*)
	       
	       ;;The main backend loop: this is also the continuation point
	       ;;for re-entry.
	       
	    continue-point		  ;hook for re-entry.

#| lets whip this bit out until the tutor is ressurecticated.	       
	       ;; Once around the loop, check to see if we should interrupt
	       ;; by calling central-dispatch-little-peek.  If it returns
	       ;; t, save state in the user-in window, and call central-
	       ;; dispatch-peek, which unwinds the stack and does other
	       ;; nasty things.  We make the assumption that we will be
	       ;; resumed later, so we set wrenched_p t.
	       ;;; John -- NB -- this may need more state now ++mlm
	       
	       (cond ((and tutorp (central-dispatch-tyi-little-peek))
		      (ada_set_saved_state_fcn
			;;;;;;(ct_send *userin* ':set-saved_state
			(list *diana* *listing* *errin* *errout*
			      *userin* *userout* *activation*
			      *nuactivation* *continuation* threadp
			      pc stage newpc *resume* *root_task_queue*
			      *current_task*))
		      (ada_set_wrenched_p_fcn  t)
		      ;;;;;Old way commented out 14-May -- genec:
		      ;;;;;(ct_send *userin* ':set-wrenched_p t)
		      (central-dispatch-peek-fcn)))
|#
		 ;;Switch to a new task IF (a) there is more than one
		 ;;runnable task on *ROOT_TASK_QUEUE* and the cyclecounter
		 ;;has wrapped around to zero OR (b) if *CURRENT_TASK* has 
		 ;;become unrunnable.
		 
                 (cond
		 ((or (and (greaterp *total_number_of_runnable_tasks* 
				     1)
			   (zerop (bump_cyclecounter)))
		      (null (ct_send *current_task* 'runnable_p)))
		  
		  ;;Get the activation record of the new task (presuming one
		  ;;exists), save the PC of the old task, and switch to the
		  ;;new task's activation record.
		  (cond (*debugscheduler*
			 (ct_format t "~%Get a new task.")))
		  
                  ;;Try to get the next task from the scheduler algorithm.

		  (setq *current_task*
			(cond (

                               ;;If the scheduler returns a task, take it.
			       ;;The PROGN is to make sure that KEYWORDIFY
			       ;;doesn't keywordify *scheduler_algorithm* -- Soley

                               (ct_send *root_task_queue*
                                        (progn *scheduler_algorithm*)))

                              ;;If the scheduler couldn't find a task, check
                              ;;to see if there are any tasks awaiting the
                              ;;end of a delay.

			      (t (cond
                                   ((zerop (ct_send *root_task_queue*
                                                    'number_of_delayed_tasks))

                                    ;;There are no tasks waiting for a delay:
                                    ;;Exit via END_OF_DVM_LOOP.

                                    (go end_of_dvm_loop))

                                   ;;There is at least one task waiting for a
                                   ;;delay to finish.  Loop around until the
                                   ;;delay ends, making sure that we let the
                                   ;;student interrupt via
                                   ;;CENTRAL_DISPATCH_PEEK_FCN. 

		    (t (go continue-point))))))

		  ;;Save the old activation record's pc...
		  
		  (set-iv adabe_activation  *activation* pc pc)

		  ;;Tell the task that this is the current activation for this task

		  (ct_send
			  (ct_send *activation* 'taskinstance)
			  'set-value *activation*)
		  
		  ;;...Insert the new task as the new value of
		  ;;;*ACTIVATION*...
		  
		  (%= *activation* (ct_send *current_task* 'value))
		  (setq *nodestages*
			(get-iv adabe_activation  *activation* nodestages))
		  
		  ;;...and update the values of PC and STAGE to reflect
		  ;;the new activation record.
		  
		  (%= pc (get-iv adabe_activation  *activation* pc))
		  (%= stage
		      (or (nodestagerec%stage
			    (adabe_nodestage_get *activation* pc))
			  (adabe_nodestage_reset pc)))))
	       
	       ;;If *debug_dvm* is on, break. This global special is OK.
	       
;;;	       (and *debug_dvm* (break dvm_loop t))
	       
	       ;;  Add here the hook for exit and re-entry.  Exit involves
	       ;; returning a vector of locally-bound things.  Re-entry
	       ;; involves restoring the locally-bound things from a supplied
	       ;; vector.  The list returned is all the locally bound things
	       ;; in the order specified in the arg-list to adabe, and in
	       ;; the prog variables list.
	       
	       ;;Look up the local vars alist for the dynamic semantic functions
	       ;;for this node and its parent once and for all (per cycle), since
	       ;;the dynsemfuns need to access this frequently.  --mlm
	       (setq *dynamic_locals_alist*
		     (nodestagerec%alist (adabe_nodestage_get *activation* pc))
		     
;;; This doesn't work across process boundaries.. needs to find the appropriate
;;; activation if there is a process boundary. PR +++
;;;		     *dynamic_mother_locals_alist*
;;;		     (nodestagerec%alist (adabe_nodestage_get *activation*
;;;							      (dynamic_mother pc)))
		     )
;;; *** end of does not work ***

;;Try calling the prefetch hook function. This was added for the debugger
;;so that the
;;interpretter could be "interrupted" and control passed to the debugger. WAB

  

;;If a stage 1 execution, this node is being executed from the
;;beginning: run the prehook (if defined)
;;Check the special follow flag so that we don't call the pre hooks when we are
;;just following to ourself. --wab 3-14-84

  (cond ((and (= stage 1.) (not (get-iv task_queue_entry *current_task* 'following_self)))
	 (maybe_run_prefetchhook pc)
	 (maybe_run_prehook pc)))
  (set-iv task_queue_entry *current_task* 'following_self nil)

;;Execute the node via the dynamic semantics functions.  If there
;;is a continuation below this node (as opposed to threads back up
;;to higher nodes), that continuation will be placed on
;;*CONTINUATION* by the dynamic semantics.

  (*catch 'implicit_exception (rundynsem pc stage) )

;;Determine what to do after the execution of this node:

  (cond
  ;; There is a resumption point. a previously started node has
  ;; been resumed in an abnormal sequence, such asd from a
  ;; non normal exit from a loop, or from an exception handler.
  (*resume*				  ;(break in-resume)
;   (format t "~%Resuming ~a from ~a" pc *resume*)
   (maybe_run_resumefetchhook pc *resume*); Let others know that we skipped exiting some nodes
   (setq pc *resume*)
   (setq *resume* nil)
   (setq stage (adabe_nodestage_cnt pc)))
  
  
  ;;(a): There is a continuation -- *ACTIVATION* has spawned a "lower"
  ;;node.  Move that node to PC, clear *CONTINUATION*, and (re)set
  ;;its stage to 1, as it's being entered from the beginning.
  
  (*continuation*
;;;Detect the special case that we are following to ourself --wab 3-14-84
   (cond ((eq pc *continuation*) (set-iv task_queue_entry *current_task* 'following_self t)))
;   (format t "~%Continue from ~a to ~a" pc *continuation*)
   (cond
     ;; This hack is so that ds_follow'ing a nil attribute gets 
     ;; you back to the same node at the next stage.
     ((symbolp *continuation*)
      (setq *continuation* nil)
      (setq stage (adabe_nodestage_cnt pc)))
     (t (setq pc *continuation*)
	(setq *continuation* nil)
	(setq stage 
	      (adabe_nodestage_reset pc)))))
  (*diana_subtree_call*
;   (format t "~%subtree ~a from ~a" pc (car *diana_subtree_call*))
   (setq pc (car *diana_subtree_call*)
	 stage (nodestagerec%stage (cdr *diana_subtree_call*))
	 *diana_subtree_call* nil))
  ;;Hacked by Paul to provide a better model of process switching
  ;;that will facilitate the implementation of tasking. 4-6-83
  ;;Scheduler goes here!  *debugscheduler*, a global, is OK here
  ;; for re-entrant code.
  (*nuactivation*			  ; was an explicit process switch issued?
;   (format t "~%nuactivation ~a from ~a" pc *nuactivation*)
   (let ((oldpc pc))
     (cond 
       (*debugscheduler*			; take this out when working. ++tst
	(ct_princ "process switching")
	(ct_terpri)))
     (set-iv adabe_activation  *activation* pc pc)	; save state of this
						; process.
     
     (%= *activation* *nuactivation*)		; switch to new
     (setq *nodestages* (get-iv adabe_activation  *activation* nodestages))
						; process.
     (%= pc (get-iv adabe_activation  *activation* pc))	; get that guys pc
     (%= stage
	 (adabe_nodestage_cnt pc))
     (%= *nuactivation* nil)			; process switched.
     (cond ((neq stage 1)			; returning from call?
	    (maybe_run_resumefetchhook oldpc pc)))))
  
  ;;(c) there is no lower node, but we may continue horizontally
  ;;to another brother node, or follow a thread back up to a
  ;;parent node.  The PROG2, ugly though it is, will get the next
  ;;node to be executed (be it brother or parent) into NEWPC, and
  ;;will set THREADP to T or NIL depending on whether this
  ;;continuation is a thread up to the parent.  The RHS of this
  ;;clause of the COND will then fire, depending on the value of
  ;;THREADP.
  ;; Modified by Paul 2-25-83.
  ;; meaning of ct_threadp has been changed. It is always a pointer
  ;; back to the parent node. Therefore, if it is eq with ct_cont,
  ;; we are going back to the parent and therefore it is a THREAD.
  ;; This change was incorporated to give dynamic semantic functions
  ;; an environment.
  
  ((prog2 nil
	  (setq threadp (eq (car (diana_get pc 'ct_threadp))
			    (diana_get pc 'ct_cont)))
	  (setq newpc (diana_get pc 'ct_cont)))
   
   ;;Here, THREADP is T: we're leaving this node to return to the
   ;;parent.  Run the posthook (if it's defined).
   
   (maybe_run_posthook pc)
   (maybe_run_postfetchhook pc)

   ;;Pc Must Be the next node to be executed.  If there's
   ;;something in NEWPC (i.e., if there is a brother or parent
   ;;of PC that should be executed), use that.  Otherwise, follow
   ;;*ACTIVATION*'s CLINK back up to the parent and make that
   ;;node *ACTIVATION* -- presuming it exists.  If it does exist, 
   ;;PC becomes this activation record's PC; if it doesn't, we're 
   ;;at the end of the top node, and can quit.  Make sure
   ;;wrenched-p is nil before leaving.
   
   (let ((oldpc pc))
     
     (cond
       ((setq pc
	      (nodestagerec%caller
		(adabe_nodestage_get *activation* pc))))
       ((null (setq pc newpc))
	(setq *activation* (get-iv adabe_activation  *activation* clink))
	(cond
	  (*activation* (setq pc
			      (get-iv adabe_activation *activation* pc)))
	  (t (ct_if tutorp
		    (ada_set_wrenched_p_fcn  nil)
		    ;;;;;(ct_send *userin* ':set-wrenched_p nil)
		    )
	     (return t)))))
     
     
     ;;; This next flushes entries in the nodestages field
     ;;; of the ar for this pc, since we are leaving it and
     ;;; therefore won't need them again.
     (splice_out_obsolete_nodestages oldpc)
     )
   
   ;;Regardless of what has become PC, set (probably increment) 
   ;;PC's STAGE.
   
   (setq stage (adabe_nodestage_cnt pc)))
  
  ;;(d) The next node to be executed is neither an offspring nor
  ;;on a thread of *ACTIVATION*: we must be moving sideways to a
  ;;new node.  Move that node to PC (breaking if no such node
  ;;exists) and initialize its STAGE value to 1.
  
  (t
   (let ((oldpc pc))
     
     (or (setq pc newpc)
	 (lose 'bad_diana 'adabe ()
     `("Problem with diana tree -- NIL cont but not thread: ~A, type: ~A."
	       ,(diana_get oldpc 'ct_id)
	       ,(diana_nodetype_get oldpc)) () ()))
	       
     
     (maybe_run_posthook oldpc)
     (maybe_run_postfetchhook oldpc)

;;; before leaving this node, check to see if we are at a 'diana call point'
;;; if we are, we should return to the caller rather than proceeding on our
;;; way.
     
     
     (cond
       ((setq newpc (nodestagerec%caller  ;back to caller
		      (adabe_nodestage_get *activation* oldpc)))
	(setq pc newpc)
	(setq stage (adabe_nodestage_cnt pc)))
       (t (setq stage
		(adabe_nodestage_reset pc))))
     ;;; This next flushes entries in the nodestages field
     ;;; of the ar for this pc, since we are leaving it and
     ;;; therefore won't need them again.
     (splice_out_obsolete_nodestages oldpc)
     
     )))
;;Continue the loop with the newly set *ACTIVATION* and PC.
 (setq *dvm_cycle_counter* (1+ *dvm_cycle_counter*))
 (go continue-point)
 end_of_dvm_loop)))
    (result
      (prog2 nil
	     (cond (*exception*		  ;An unhandled runtime exception
		    (ct_format *errout* "~&There was no exception handler for ~A.~%Program execution has ended."
			    (exceptionrec%type *exception*))
		    *exception*)
		   ((eq catchval 'runtime_error)  ;Extra caution.
		    (ct_format *errout*	  ;No *Exception* record info.
			    "~&Your program encountered a runtime error.~%")
		    (ct_format *errout*
			    "There was no exception handler for RUNTIME_ERROR.~%Program execution has ended.~%")
		    (exceptionrec 'runtime_error))
		   (t nil))

	     ;;Delete the current task from *ROOT_TASK_QUEUE*.  This should
	     ;;be the only remaining task active on the task queue; it falls
	     ;;to the dynamic semantics to clean up other terminating tasks.

	     (ct_send *current_task* 'make_unrunnable)
	     (ct_send *current_task* 'delete_yourself_from_queue)   )))
		;;; deleted virtual machine cyles printout from here --mlm
   result))

;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Edit History:
;;;
;;; JRM:   Convert activations from records to flavors:       Feb-83
;;; JS:    Support wrench/resume for tutor:                   Apr-83
;;; MLM:   Support "calling a subtree".                    27-Apr-83
;;; PR,MM: Support exceptions.                              6-May-83
;;; MLM:   Support cycle counter.                           6-May-83
;;; MLM:   Lookup dynsem locals alist once per loop.       14-May-83
;;; GeneC: Change wrench/resume to use functions:  	   14-May-83
;;; JRM:   Queues added for tasking:    		   17-May-83
;;; MLM:   Use LOSE instead of FERROR, BREAK.  Move the    26-May-83
;;;        diana cycle counter over to interp.l.  Move the
;;;        declarations, specials, defvars, etc. to intrpdcl.
;;;
;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;