;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/dynsem.l,v 1.177 84/10/30 19:13:50 penny Exp $
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                              DYNSEM                              ;;;
;;; Mark L. Miller and Paul Robertson               February 8, 1983 ;;;
;;;                                                                  ;;;
;;; This file defines the Dynamic Semantics for Ada, in terms of a   ;;;
;;; function associated with each type of Diana node.  These should  ;;;
;;; always be defined using the definition macros in ds_macs.        ;;;
;;;                                                                  ;;;
;;; NB:  Currently, only a fraction of the 167. node types have been ;;;
;;; implemented.  ++                                                 ;;;
;;;                                                                  ;;;
;;; 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.                ;;;
;;;      ==> Should merge on-line Diana manual with this file! ++    ;;;
;;; The following code assumes familiarity with these materials.     ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


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

(comment Assumes ct_load and some suitable ct_daba are present)

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

(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 'charmac)) ;get #$% and #$~

(eval-when (compile load eval) (ct_load 'time))	  ;Timing functions. 

(eval-when (compile load eval) (ct_load 'diana))  ;LISP rep of datatype.

(eval-when (compile load eval) (ct_load 'ctflav));Flavor compatability.

(eval-when (compile load eval) (ct_load 'dsmacs));Macros.

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

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

(eval-when (compile load eval) (ct_load 'attribute))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler Declarations and Global Variables -- 

#+franz (declare (macros t))
(declare (ct_includef 'intrpdcl))
							;Ports/Streams:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Definitions of Diana Nodetypes --


		;;;;;;;;;;;;;;
(def_diana_node dn_compilation(starting referencep types record nuar 
                               mp dead_p cxs cxl)
		;;;;;;;;;;;;;;
;;;types is used to collect the subtype cxonstraints for types
;;;and the formals for parameters respectively. Each is an A-List indexed
;;;by the defining (dn...id ...) node.
;;;starting is t as long as the program is searching for the main procedure.

      (ds_if #$~dead_p
	     (ds_exit))
      (%= #$~starting t)		; we are looking for the main procedure.
      (%= *exchandler* nil)
      (ds_if *package_standard*
	     (ct_send *activation* 'set-locals *package_standard*)
	     (ds_call_diana (ada_declared (ada_ident standard) nil 'package)));with standard;
      (%= *package_standard* (ct_send *activation* 'locals))
      (%= #$~mp (ds_find_main_prog pc))
      (%= #$~cxs (ds_find_list_of_contexts #$%as_list #$~mp))
      (ds_label #$~cxl)
      (ds_if (and #$~cxs
		  (diana_nodep (car #$~cxs))
		  (eq (diana_nodetype_get (car #$~cxs))
		      'dn_package_id))
	     (ds_call_diana (ds_pop #$~cxs))
	     (ds_pop #$~cxs))
      (ds_if #$~cxs (ds_goto #$~cxl))
      ;(break look-at-cntxt)
  ;;; execute the main program.
  (let ((ar (make_activation_record 1 0))
	(asbdydes (diana_get
		    (diana_get #$~mp 'as_unit_body)
		    'as_designator)))
    (set-iv adabe_activation ar 'locals nil)
    (set-iv adabe_activation ar 'pc asbdydes)
					  ; start procedure at the start.
    (set-iv adabe_activation ar 'node asbdydes)
    (%= #$~nuar ar)			  ; make an empty AR.
    (%= *nuactivation* ar))		  ; driver will switch in nuactivation 
					  ; record on the next cycle of
					  ; the virtual machine.
  (ds_break)				  ; stage

  (ct_send *current_task* 'make_wait_for_inferiors
	   (ct_send *current_task* 'inferior_tasks))
  (%= #$~dead_p t)			  ;time to go die.
  (ds_follow pc)			  ;by the time I get there I'll be dead.
)


		;;;;;;;;;;;;
(def_diana_node dn_comp_unit()
                ;;;;;;;;;;;;
   (cond (#$%as_context (ds_call_diana #$%as_context))))

#|;  (break look-at-as-unit-body)
  ;;; elaborate the context
  (ds_if #$~dead_p
	 (progn
	   (ct_send *current_task* 'kill_yourself_and_inferiors)
	   (ds_exit))
	 (cond (#$%as_context (ds_call_diana #$%as_context))));stage

  ;;; execute the body
  (let ((ar (make_activation_record 1 0))
	(asbdydes (diana_get #$%as_unit_body 'as_designator)))
    (set-iv adabe_activation ar 'locals nil)
    (set-iv adabe_activation ar 'pc asbdydes)
					  ; start procedure at the start.
    (set-iv adabe_activation ar 'node asbdydes)
    (%= #$~nuar ar)			  ; make an empty AR.
    (%= *nuactivation* ar))		  ; driver will switch in nuactivation 
					  ; record on the next cycle of
					  ; the virtual machine.
  (ds_break)				  ; stage

  (ct_send *current_task* 'make_wait_for_inferiors
	   (ct_send *current_task* 'inferior_tasks))
  (%= #$~dead_p t)			  ;time to go die.
  (ds_follow pc)			  ;by the time I get there I'll be dead.
)|#

		;;;;;;;;;;
(def_diana_node dn_context (cxl cxs)
		;;;;;;;;;;

  (%= #$~cxs #$%as_list)
  (ds_label #$~cxl)
  (ds_if #$~cxs 
         (ds_call_diana (ds_pop #$~cxs)))
  (ds_if #$~cxs (ds_goto #$~cxl)))

		;;;;;;;
(def_diana_node dn_with (lus lul)
                ;;;;;;;
  (%= #$~lus #$%as_list)
  (ds_label #$~lul)			  ;stage
  
  (let ((flus (first #$~lus)))
    (ds_if (eq (diana_nodetype_get (diana_get flus 'sm_defn))
	       'dn_package_id)
	   (ds_call_diana (diana_get flus 'sm_defn))))
  (ds_break)				  ;stage
  
  (ds_pop  #$~lus )
  (ds_if #$~lus (ds_goto #$~lul))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Packages


		;;;;;;;;;;;;;
(def_diana_node dn_package_id (genpars genparl)
		;;;;;;;;;;;;;
;   (break in-package-id)
  ; check to see if this is an instantiation and if it is get its
  ; generic parameters and elaborate them
  (%= #$~genpars
      (let* ((ctth (diana_get pc 'ct_threadp))
	     (pkgdecl (car (mapcan #'(lambda(ct)
				       (cond ((and (diana_nodep ct)
						   (eq (diana_nodetype_get ct)
						  'dn_package_decl))
					      (list ct))))
				   ctth)))
	     (pkgdef (and pkgdecl 
		      (diana_get pkgdecl 'as_package_def))))
	(and pkgdef (eq (diana_nodetype_get pkgdef) 'dn_instantiation)
	     (diana_get pkgdef 'sm_decl_s))))
  (ds_label #$~genparl)
  (ds_if #$~genpars
	 (ds_call_diana (ds_pop #$~genpars)))	  ;elaborate the genpars
  (ds_if #$~genpars
	 (ds_goto #$~genparl))

;  (ds_call_diana #$%sm_spec)
  (ds_if (or (and #$%sm_spec 
		  (eq (diana_nodetype_get #$%sm_spec) 'dn_instantiation))
	     #|(and #$%sm_body
		  (memq (diana_nodetype_get #$%sm_body) '(dn_void dn_stub nil)))|#
	     )
	 (ds_exit)
	 (ds_call_diana #$%sm_spec))
  (ds_if (or (and #$%sm_spec 
		  (eq (diana_nodetype_get #$%sm_spec) 'dn_instantiation))
	     (and #$%sm_body
		  (memq (diana_nodetype_get #$%sm_body) '(dn_void dn_stub nil))))
	 (ds_exit)
	 #|(cond
	   ((eq (diana_nodetype_get #$%sm_spec) 'dn_instantiation)
	    (ds_call_diana #$%sm_spec)))|#
	 (ds_call_diana #$%sm_body)))


		;;;;;;;;;;;;;;;
(def_diana_node dn_package_decl()
		;;;;;;;;;;;;;;;
  (ds_if (eq (diana_nodetype_get #$%as_package_def) 'dn_instantiation)
#|	 (ds_call_diana (diana_get
			  (diana_get #$%as_package_def 'as_name)
			  'sm_body))|#
	 (ds_call_diana #$%as_id)
	 (ds_call_diana #$%as_package_def)))

		;;;;;;;;;;;;;;;
(def_diana_node dn_package_body(starting) ;make sure that this isnt selected
		;;;;;;;;;;;;;;;
;  (break frobe)
  (ds_if (not
	   (eq (let*
		 ((smspec (diana_get #$%as_id 'sm_spec))
		  (res (and smspec
			    (diana_nodetype_get
			      (car (diana_get smspec 'ct_threadp))))))
		 res)
	       'dn_generic_id))
	 (let ((abs #$%as_block_stub));(break look-at-me)
	   (ds_if abs
		  (ds_call_diana abs))))) ;elaborate declarations and
    (ds_break)
;  (break in-package-body)		;as ther main program.
;  
					  ;do initialization.
		;;;;;;;;;;;;;;;
(def_diana_node dn_package_spec(types)
		;;;;;;;;;;;;;;;
  (ds_call_diana #$%as_decl_s1)
  (ds_call_diana #$%as_decl_s2))

		;;;;;;;;;
(def_diana_node dn_decl_s(dcls dl record );;possibly others missing?+++
		;;;;;;;;;
  (%= #$~dcls  #$%as_list)
  (ds_label #$~dl)			  ;stage

  (ds_if #$~dcls (ds_call_diana (ds_pop #$~dcls)));stage
  (ds_if #$~dcls (ds_goto #$~dl)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; types and subtypes

       ;;;;;;;;;
(defun type_depth (defocc)
       ;;;;;;;;;
  (- (get-iv adabe_activation *activation* 'pnl)
     (diana_get defocc 'ct_pnl)))
      


		;;;;;;;
(def_diana_node dn_type (res evaluatep invar dscrmt_vars dscrmt_constraints )
		;;;;;;;
 (let ((ats (ds_find_base_type_spec #$%as_type_spec)))
  (%= #$~evaluatep t)
  (cond ((is_dscrmt_record ats)
		    (%= #$~dscrmt_constraints (dscrmt_record%dscrmt ats))
		    (%= #$~dscrmt_vars (dscrmt_record%vars ats))
		    (%= ats (dscrmt_record%record *_*))))
   (ds_if (and ats
	      (not (memq (diana_nodetype_get ats) '(dn_record dn_array))))
	 (ds_call_diana ats)))
 (ds_break)
    (let ((nutype (ct_make_instance 'dt_type_type)))
    ;(break look-for-digits)
    (ct_send nutype 'initialize `(, #$%as_id
				  ,#$~res
				  nil
				  , #$%as_id))
    (let ((*activation*
	    (follow_alink_n_times
	      *activation*
	      (type_depth #$%as_id))))
      (set-iv adabe_activation *activation* 'locals
	      (cons
		(cons  #$%as_id nutype) 
		(get-iv adabe_activation *activation* 'locals) ;the locals slot.
		))))
  (ds_push (cons #$%as_id (first #$~res)) #$^types))


		;;;;;;;;;;
(def_diana_node dn_subtype (res evaluatep invar dscrmt_vars dscrmt_constraints )
		;;;;;;;;;;
  (%= #$~evaluatep t)
  (let ((ds (ds_find_base_type_spec #$%as_constrained)))
    (cond ((is_dscrmt_record ds)
		    (%= #$~dscrmt_constraints (dscrmt_record%dscrmt ds))
		    (%= #$~dscrmt_vars (dscrmt_record%vars ds))
		    (%= ds (dscrmt_record%record *_*))))
    (ds_if (not (is_dscrmt_record ds))
	   (ds_call_diana ds)))
  (ds_break)
    (let* ((nutype (ct_make_instance 'dt_type_type))
	   (parent (cdr (look_up_ident
		     (diana_get #$%as_constrained 'as_name))))
	   (momsrng (and parent (ct_send parent 'range))))
    (ct_send nutype 'initialize `(, #$%as_id
				  ,#$~res
				  ,momsrng
				  , #$%as_id))
    (let ((*activation*
	    (follow_alink_n_times
	      *activation*
	      (type_depth #$%as_id))))
      (set-iv adabe_activation *activation* 'locals
	      (cons
		(cons  #$%as_id nutype) 
		(get-iv adabe_activation *activation* 'locals) ;the locals slot.
		))))
  (ds_push (cons #$%as_id (first #$~res)) #$^types))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Exceptions 


		;;;;;;;;;;;;
(def_diana_node dn_exception())		;do nothing at run time.
		;;;;;;;;;;;;



		;;;;;;;;
(def_diana_node dn_raise(exception_name handler handler_process propergatingp)
		;;;;;;;;

  (do ((i 0 (1+ i)))
      ((= i (second (arraydims *ds_cache*))))
    (let ((cache_entry (aref *ds_cache* i)))
      (%= (cache%activation cache_entry) nil)
      (%= (cache%node cache_entry) nil)
      (%= (cache%entry cache_entry) nil)))

  (%= #$~exception_name			  ;name of exception being raised.
      (cond
	((eq (diana_nodetype_get #$%as_name_void) 'dn_used_name_id)
	 (implode (cadr (diana_get #$%as_name_void 'lx_symrep))))
	(t
	 (find_propergated_exception_name pc))))
  (ct_push "raised by a raise statement" *exception_reason*)
  (ct_push #$~exception_name *exception_name*)
  ;;Before we raise the exception, check to see if there is advise for this
  ;;exception. If there is, call each advise function and THEN, raise the
  ;;exception.
  (let* ((excname #$~exception_name)
	 (advice_fcns (get excname 'ada_advise)))
    (mapc
      #'(lambda(af)
	  (funcall af excname nil))	  ;call the advice function.
      advice_fcns)
    ;(break look-at-exc)
    (%= #$~handler (find_exception_handler_for
		     (intern excname 'user)
		     (cond
		       (*exchandler* 
			(dynamic_mother *exchandler*))
		       (t pc))
		     *activation*)))
  ;(break foo)
  ;; before raising the exception, clear the cache.
  (do ((i 0 (1+ i)))
      ((= i (second (arraydims *ds_cache*))))
    (let ((cache_entry (aref *ds_cache* i)))
      (%= (cache%activation cache_entry) nil)
      (%= (cache%node cache_entry) nil)
      (%= (cache%entry cache_entry) nil)))

  (%= #$~handler_process
      (cond #|((eq *exchandler* (first #$~handler))
	     
	     (find_nodes_process (ct_send *activation* 'clink)
				 (first #$~handler)))|#
	    (t
	     (find_nodes_process *activation*  (first #$~handler)))))
  ;; to call an exception handler, create a handler node and pass control
  ;; to it in the right process.
  (let* ((hndler #$~handler)
	 (hndproc #$~handler_process)
	 (hannod (sc_diana dn_ct_exception_handler
			   as_stm_s (diana_get (second hndler) 'as_stm_s)
;			  ct_threadp (list pc);preserve the dynamic environment.
			   ct_threadp (list (first hndler))
			   ct_raising #$~exception_name	  ;name of the exception.
			   ct_id (gensym)
			   ct_resume    (first hndler))))
    (cond
      ((eq *activation* hndproc)	  ;if the process is the same.
       (%= *continuation* hannod))
      (t  (set-iv adabe_activation hndproc 'pc hannod)	  ;goto the handler node.
	  (%= *nuactivation* hndproc)	  ;switch to appropriate process.
	  )))
  )

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find_propergated_exception_name(pc)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond
    ((eq (diana_nodetype_get pc) 'dn_ct_exception_handler) #$%ct_raising)
    (t (find_propergated_exception_name (dynamic_mother pc)))))


		;;;;;;;;;;;;;;;;;;;;;;;
(def_diana_node dn_ct_exception_handler()
		;;;;;;;;;;;;;;;;;;;;;;;
  (%= *exchandler* #$%ct_resume)
  (handle_exception_advise pc)
  (ds_call_diana #$%as_stm_s)
  (handle_exception_after_advise pc)
;  (break in-exception-handler)
  (%= *resume* #$%ct_resume)
  (ct_pop *exception_reason* )
  (ct_pop *exception_name* )
  (%= *exchandler* nil))

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun handle_exception_advise (hanpc)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (let* ((procname (intern
		     (implode
		       (cadr
			 (diana_get
			   (get-iv adabe_activation *activation* 'node)
			   'lx_symrep)))
		     'user))
	 (exceptname (diana_get hanpc 'ct_raising))
	 (aea (get procname 'ada_exception_advise)))
    (cond
      (aea				  ;if we have an advise function.
       (mapc
	 #'(lambda(aa)
	     (funcall aa procname exceptname))
	 aea)))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun handle_exception_after_advise (hanpc)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let* ((procname (intern
		     (implode
		       (cadr
			 (diana_get
			   (get-iv adabe_activation *activation* 'node)
			   'lx_symrep)))
		     'user))
	 (exceptname (diana_get hanpc 'ct_raising))
	 (aea (get procname 'ada_exception_after_advise)))
    (cond
      (aea				  ;if we have an advise function.
       (mapc
	 #'(lambda(aa)
	     (funcall aa procname exceptname))
	 aea)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic specific diana nodes



		;;;;;;;;;;
(def_diana_node dn_generic ())
		;;;;;;;;;;

		;;;;;;;;;;;;;
(def_diana_node dn_generic_id ()
		;;;;;;;;;;;;;

      (ds_call_diana #$%sm_body)
      (ds_return_to_caller))


		;;;;;;;;;;;;;;;;
(def_diana_node dn_instantiation ()
		;;;;;;;;;;;;;;;;
  (ds_follow (first #$%sm_decl_s))	  ;elaborate the generic parameter dcls
  (ds_follow #$%as_name))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Task specific diana nodes.


		;;;;;;;;;;;;
(def_diana_node dn_task_decl(thistask)
		;;;;;;;;;;;;
  (let* ((asdes #$%as_id)
	 (taskq (ct_make_instance 'dt_task_type))
	 (pair (cons asdes taskq)))
    (ct_send taskq 'initialize nil)
    (ct_send taskq 'set-def_occurence asdes)
    (ct_send taskq 'set-sm_defn (extract_basetype asdes))
    (set-iv adabe_activation *activation*
	    'locals
	    (cons
	      pair
	      (get-iv adabe_activation *activation* 'locals)))
    (ct_send taskq 'set_val nil nil)
    (%= #$~thistask taskq))
  (ds_call_diana #$%as_task_def))

		;;;;;;;;;;;;
(def_diana_node dn_task_spec(dls dll nuar pqe hannod)
		;;;;;;;;;;;;
  (%= #$~dls #$%as_decl_s)
  (ds_label #$~dll)
  (ds_if #$~dls (ds_call_diana (ds_pop #$~dls)))
  (ds_if #$~dls (ds_goto #$~dll))
  
  ;;First of all, create a task handler node that will serve to extinguish
  ;;the task when it is completed.
  (let ((hannod (sc_diana dn_ct_task_handler
			  as_stm_s #$%sm_body
			  #|(let ((bdy (diana_get #$%as_id 'sm_body)))
			    (cond
			      ((eq (diana_nodetype_get bdy) 'dn_stub)
			       (diana_get
				 (diana_get #$%as_id 'sm_type_spec)
				 'sm_body))
			      (t bdy)))|#
			  ct_threadp (list pc)	  ;preserve the dynamic environment.
			  ct_cont nil
			  ct_id (gensym))))
    ;;create an activation for the task. Its C and A links are necessarily
    ;;the current process because of the way tasks are activated.
    (let* ((tpnl #$%ct_pnl)
	   (ar (make_activation_record tpnl tpnl)))
      (%= #$~nuar ar)			  ; make an empty AR.
      (set-iv adabe_activation ar 'pc hannod)
      (set-iv adabe_activation ar 'node hannod)
      (set-iv adabe_activation ar 'locals nil))	  ;there are no locals.yet.
    ;;now add the activation record to the task queue. pqe is assessed by
    ;;the handler node when it wants to destroy itself.
    ;(break what-is-thetask-name)
    (let ((tpqe (second
		  (ct_send *root_task_queue*
			   'add_task_to_priority_queue
			   *default_task_priority*;later use pragma's priority.
			   #$~nuar	  ;initialize the task to this process.
			   *current_task*
			    (implode
			      (cadr (diana_get
				      (ct_send #$^thistask 'def_occurence)
				      'lx_symrep)))))))
      (%= #$~pqe tpqe)			  ;this is the superior task.
      (ct_send tpqe 'make_runnable)	  ;make this task active.
      (ct_send tpqe 'set-terminated nil)  ;and bring him to life.
      (ct_send tpqe 'set-task_object #$^thistask)
      (ct_send #$^thistask 'set-tqe tpqe)
      (ds_push tpqe #$^mytasks)		  ;add this to the list of tasks in this
					  ;block.
      (ct_send #$~nuar 'set-taskinstance tpqe)
      (diana_put hannod tpqe 'ct_task_entry))
    )
)
  
		;;;;;;;;;;;;
(def_diana_node dn_task_body()
		;;;;;;;;;;;;

#|  
  (ct_format *userout* "In task body of ~A ~%"
	  (implode (cadr (diana_get #$%as_id 'lx_symrep))))
|#
;	(break in-dn-task-body)	
)
  
 

		;;;;;;;;;;;;;;;;;;
(def_diana_node dn_ct_task_handler(dead_p)
		;;;;;;;;;;;;;;;;;;

  (ds_if #$~dead_p 
         (progn
           (ct_send #$%ct_task_entry 'kill_yourself_and_inferiors)
           (ds_follow pc)))		  ;stage

;  (break in-task-handler-starting)
  (ds_call_diana #$%as_stm_s)		  ;pass control to the task body.stage

  (ct_send #$%ct_task_entry 'make_unrunnable)
  (ct_send #$%ct_task_entry 'delete_yourself_from_queue)
;  (break in-task-handler-finishing)
  (let ((taskent #$%ct_task_entry ))
    (ct_send taskent 'make_wait_for_inferiors
                            (ct_send taskent  'inferior_tasks)))
  (%= #$~dead_p t)			  ;I really am dead!
  (ds_follow pc)			  ;kill time while dying.
)

;;; The DELAY statement.
;;; Until we implement fixed point types, we will treat delay times
;;; specified as (integer) milliseconds.                                 ++


		;;;;;;;;
(def_diana_node dn_delay(res evaluatep)
		;;;;;;;;

  ;;first of all evaluate the delay.
  (%= #$~evaluatep t)
  (ds_follow #$%as_exp)
  ;;now wait for the specified time.
  (ct_send *current_task* 'wait_for_duration (car #$~res))
)

                ;;;;;;;;;;;;;
(def_diana_node dn_cond_entry(task ready_to_go_p)
                ;;;;;;;;;;;;;
  (%= #$~task (cdr (look_up_ident
		     (diana_get
		       (diana_get
			 (diana_get
			   (car (diana_get
				  #$%as_stm_s1
				  'as_list))
			   'as_name)
			 'sm_defn)
		       'as_name))))
  (let* ((eid (find_selected
	       (diana_get
		 (diana_get
		   (car (diana_get
			  #$%as_stm_s1
			  'as_list))
		   'as_name)
		 'sm_defn)))
	 (entobj (cdr (assq eid (ct_send #$~task 'current_value)))))
    (cond ((and entobj
		(ct_send entobj 'accesses_waiting))
	   (%= #$~ready_to_go_p t))))
  (ds_if #$~ready_to_go_p
	 (ds_call_diana #$%as_stm_s1)
	 (ds_call_diana #$%as_stm_s2)))

;;; The ACCEPT statement.


		;;;;;;;;;
(def_diana_node dn_accept(entry rendez accepting)
		;;;;;;;;;
  (let ((ent (cdr (assq (diana_get #$%as_name 'sm_defn)
			(ct_send
			  (ct_send *current_task* 'task_object)
			  'current_value)))))
    (%= #$~entry ent)
    (ds_if (not (or (ct_send  ent  'accesses_waiting)  #$~accepting))
	   (progn
	     #|	   (ct_format *userout* "waiting on accept ~A ~A~%"
		      (implode (cadr (diana_get #$%as_name 'lx_symrep)))
		      #$%ct_id)|#
	     (ct_send *current_task* 'make_unrunnable)	  ;temporary permanant wait.
	     (ct_send ent 'set-entry_waiting *current_task*)
	     (%= #$~accepting t)
;	   (break sleep-while-waiting-for-entry)
	     (ds_follow pc))))
  (ds_break);stage

#|	 (break entry-read-to-go)|#
  (let ((ent #$~entry))
    (%= #$~rendez (first (ct_send ent 'accesses_waiting)))
    (ct_send ent
	     'set-accesses_waiting (cdr (ct_send ent 'accesses_waiting))))
  (set-iv adabe_activation *activation* 'locals
	   (append (get-iv adabe_activation (second #$~rendez) 'locals)
		   (get-iv adabe_activation *activation* 'locals)))
;  (break about-to-make-rendezvous)
  (ds_follow #$%as_stm_s)  ;;pass control to rendezvous. stage

  (ct_send (first #$~rendez) 'make_runnable)
;  (break end-of-rendezvous)
)

                ;;;;;;;;;;;
(def_diana_node dn_entry_id(entry returned)
                ;;;;;;;;;;;
  (ds_if #$~returned
	 (progn
;	   (break back-from-entry)
	   (ds_return_to_caller)))	  ;stage

  (let ((ent (cdr (assq
		    (diana_get
		      (diana_get
			(diana_get
			  (get-iv adabe_activation
				  (get-iv adabe_activation *activation* 'clink)
				  'pc)
			  'as_name)
			'sm_defn)
		      'as_designator_char)
		    (let* ((*activation* (ct_send *activation* 'clink))
			   (pc (ct_send *activation* 'pc)))
		      (ct_send #$~task 'current_value))))))
    (%= #$~entry ent)
;  (break about-to-initiate-entry)
;  (ct_format *userout* "entering ~A~%" #$%ct_id)
    (%= #$~returned t)
    (ct_send ent
	     'add_me_to_the_access_waiting_queue *current_task* *activation*))
  (ds_return_to_caller))

       ;;;;;;;;;;;;;;;;;;;;;;;
(defun dead_or_dying_offspring (offspring me)
       ;;;;;;;;;;;;;;;;;;;;;;;
  (do ((brother offspring (cdr brother)))
      ((null brother) t)
    (cond ((and (neq me (car brother))
		(null (ct_send (car brother) 'terminated)))
	   ;++needs more to detect dying offspring
	   (return nil)))))

       ;;;;;;;;;;;;;
(defun ready_to_go_p (stms)
       ;;;;;;;;;;;;;
  (let* ((selecttype (first (diana_get stms 'as_list))))
    (ct_selectq (diana_nodetype_get selecttype)
		(dn_delay
		  (lose
		    'be_dsis
		    'ready_to_go_p
		    '("delay statements in selects not supported at present")))
		(dn_entry (lose 'be_esis 'ready_to_go_p))
		(dn_accept
		  (let* ((eid (diana_get
				(diana_get selecttype 'as_name) 'sm_defn))
			 (task (ct_send
				 (ct_send *activation* 'taskinstance)
				 'task_object))
			 (entry (cdr (assq eid
					   (ct_send task 'current_value))))
			 (queue (ct_send entry 'accesses_waiting)))
		    (cond (queue stms))))		    
		(dn_terminate ;(break in-ready_to_go-terminate)
		  ;(break in-terminate)
		  ;(ct_send *current_task* 'kill_yourself_and_inferiors)
		  (let* ((mom (ct_send *current_task* 'superior_task))
			 (menopausalp
			   (ct_send mom 'waiting_for_inferiors_to_finish))
			 (offspring (ct_send mom 'inferior_tasks)))
		    (cond
		      ((and menopausalp
			    (dead_or_dying_offspring offspring *current_task*))
		       (ct_send *current_task* 'kill_yourself_and_inferiors))))
		      
		  nil))))
	 

                ;;;;;;;;;
(def_diana_node dn_select(chosen csc csl picked)
                ;;;;;;;;;
  ;;get the candidate set =>chosen
  (ds_follow (first #$%as_select_clause_s))	  ;stage

  (%= #$~chosen (nreverse *_*))
  (%= #$~csc #$~chosen)
  (ds_label #$~csl)			  ;stage

  (ds_if #$~csc
	 (%= #$~picked (ready_to_go_p (first #$~csc))))	  ;stage

  (ds_pop #$~csc)
  (ds_if (and #$~csc (not #$~picked))
	 (ds_goto #$~csl))		  ;stage

  
  (ds_if #$~picked
	 (ds_call_diana #$~picked)
	 (ds_if #$%as_stm_s
		(ds_call_diana #$%as_stm_s))));(break go-do-the-else-part)))

                ;;;;;;;;;;;;;;;;
(def_diana_node dn_select_clause(res evaluatep referencep)
                ;;;;;;;;;;;;;;;;
  (%= #$~evaluatep t)
  (%= #$~res `(,*ct_ada_true*))			  ;assume t for void case
  ;;evaluate the when part 
  (ds_follow #$%as_exp_void)
  ;;if the when part yeided true add to the candidate set
  (cond ((eq *ct_ada_true* (first #$~res))
	 (ds_push #$%as_stm_s #$^chosen))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Subprogram declaration /calls


       ;;;;;;;;;;;;;
(defun strip_renames(id)
       ;;;;;;;;;;;;;
  (cond
    ((and (not
	    (eq
	      (diana_nodetype_get id)
	      'dn_entry_id))
	  (eq (diana_nodetype_get
		(diana_get id 'sm_body))
	      'dn_rename))
     (strip_renames
       (diana_get
	 (diana_get id 'sm_body)
	 'as_name))
     )
    (t id)))

		;;;;;;;;;;;;;;;;
(def_diana_node dn_function_call(funres name body evaluatep res referencep apl epl
		;;;;;;;;;;;;;;;;

					bltinp func  nuar invar seres
					procname aa rtnval constraint
					basetypespec dscrmt_constraints
					dscrmt_vars indexlist dscrmts
					fpl ueparams eparams pils compobj proto)
    (%= #$~seres #$%sm_value)
    (ds_if #$~seres
	   (progn			  ;return the result.
	     (cond (#$^evaluatep (ds_push #$~seres #$^res))	
		   (t            (ds_push #$~seres #$^name)))
	     (ds_exit)))
    (%= #$~invar t)  
    (%= #$~apl
	(diana_get #$%sm_normalized_param_s 'as_list)) ;get the parameters.
    #|(%= #$~fpl (mapcar
		 #'extract_basetype
		 (diana_get (diana_get pc 'sm_normalized_param_s) 'as_list)))|#
    (let* ((smdef (diana_get #$%as_name 'sm_defn))
	   (rmsel (cond ((eq (diana_nodetype_get smdef) 'dn_selected)
			 (diana_get (find_selected smdef) 'sm_defn))
			(t smdef)))
	   (spec (diana_get rmsel 'sm_spec))
	   (aspar (and spec (diana_get
			      spec
			      'as_param_s))))
      (%= #$~fpl (mapcar
		   #'(lambda(dn)
		       (diana_get
			 (car (diana_get dn 'as_id_s))
			 'sm_obj_type))
		   aspar)))
    (ds_label #$~epl)			  ;evaluate parameters loop.stage

    (%= #$~referencep t)
    (%= #$~evaluatep nil)
    (ds_if #$~apl			  ;if there are parameters to evaluate.
	   (let ((next_parameter (ds_pop #$~apl)))	     
	     (ds_call_diana next_parameter))) ;stage

    ;; find the parameter constraints indices and prototypes if any.
    (let ((tfpl #$~fpl))
      (ds_if tfpl
	   (let ((bts
		   (cond ((car tfpl)(ds_find_base_type_spec (car tfpl))))))
	     (cond ((is_dscrmt_record bts)
		    (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
		    (%= #$~dscrmt_vars (dscrmt_record%vars bts))
		    (%= bts (dscrmt_record%record *_*))))
	     (%= #$~basetypespec bts))))	  ;stage
;    (ds_break)
  (let ((dc #$~dscrmt_constraints))
    (%= #$~evaluatep t)  
    (%= #$~res nil)			  ;index ranges will be
					  ; collected in res.
    (ds_if dc				  ;collect dscrmts if any.
	   (ds_call_diana dc)))
    (ds_break)			  ;stage

;  (break dn_var)
  (%= #$~constraint nil)
  (let ((bts #$~basetypespec))
    (ds_if (and #$~fpl (diana_nodep bts)  )
	   (ds_call_diana bts)))	  ;list=>diana.
  (ds_break)			  ;stage
  
  
  (let ((il (or (nreverse #$~res) #$~constraint)))
    (ds_push il #$~pils)		  ;add index to ordered list of parameters.
    (%= #$~indexlist il))
  (ds_pop #$~fpl)
    ;; continue to iterate over the actuals.
    (ds_if #$~apl (ds_goto #$~epl));stage


    (%= #$~ueparams #$~name)		  ;the unevaluated parameters.
    (%= #$~evaluatep t)
    (%= #$~procname
	(intern (implode (cadr (diana_get #$%as_name 'lx_symrep)))
		'user))
    (%= #$~aa (get #$~procname 'ada_advise)) ;Ada advice functions.
    (ds_if
      (or
	(eq
	  (diana_nodetype_get
	    (diana_get (diana_get #$%as_name 'sm_defn) 'sm_body))
	  'dn_predefined_simple_function)
	(and (eq
	       (diana_nodetype_get
		 (diana_get (diana_get #$%as_name 'sm_defn) 'sm_body))
	       'dn_rename)
	     (eq
	       (diana_nodetype_get
		 (diana_get
		     (diana_get
		       (diana_get (diana_get #$%as_name 'sm_defn) 'sm_body)
		       'as_name)
		   'sm_body))
	       'dn_predefined_simple_function)))
      (let ((res (funcall (cond ((eq
				   (diana_nodetype_get
				     (diana_get
				       (diana_get #$%as_name 'sm_defn)
				       'sm_body))
				   'dn_rename)
				 (diana_get
				   (diana_get
				       (diana_get
					 (diana_get
					   (diana_get #$%as_name 'sm_defn)
					   'sm_body)
					 'as_name)
				     'sm_body)
				   'ct_lisp_func))
				(t (diana_get
				     (diana_get
				       (diana_get #$%as_name 'sm_defn)
				       'sm_body)
				     'ct_lisp_func)))
			  (nreverse
			    (mapcar
			      #'(lambda(pn)
				  (cond
				    ((instancep pn) (ct_send pn 'get_val nil))
				    (t pn)))
			      #$~name)))))
;	(ct_send #$~rtnval 'set_val res)
	;; return the function result.
	(cond (#$^evaluatep (ds_push res #$^res))	
	      (t            (ds_push res #$^name)))
	(ds_exit)))
    ;; To call a user defined function --
    ;; 1. Evaluate the normalized parameters. (returns alist of parameters)
    ;; 2. Create New activation record for this function.
    ;; 3. Put parameters on to the locals slot for the new AR.
    ;; 4. Put the #$~body onto the pc and code slots.
    ;; 5. activation record %= new activation record.
    ;; 6. follow the body.
    ;; 7. Pop the AR (follow click).
    (let ((bdy (diana_get #$%as_name 'sm_defn)))
      (%= #$~body bdy)			  ; body is a dn_function_id.
      (let ((ar 
	      (make_activation_record
		#$%ct_pnl
		(diana_get (strip_renames
			     (subprog_bit bdy))
			     'ct_pnl)))); make an empty AR.
	(%= #$~nuar ar)
      (set-iv adabe_activation ar 'pc bdy)	  ; start function at the start.
      (set-iv adabe_activation ar 'node  bdy)
	(let ((nam #$~name)
	      (pc bdy)
	      (*activation* ar))
	  (set-iv adabe_activation ar 'locals 
		 (buildparamlocals 
		   (nreverse (mapcar
			       #'(lambda(pn)
				   (cond
				     ((instancep pn) (ct_send pn 'get_val nil))
				     (t pn)))
			       nam))  ; evaluated actuals.
		   (diana_get
		     (let ((id (strip_renames (subprog_bit bdy))))
		       (or (diana_get id 'ct_spec)
			   (diana_get id 'sm_spec)))
		     'as_param_s); formals.
		   )))))			  ; setup the initial locals.
    (let ((bts (ds_find_base_type_spec #$%sm_exp_type) ))
      (cond ((is_dscrmt_record bts)
	     (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
	     (%= #$~dscrmt_vars (dscrmt_record%vars bts))
	     (%= bts (dscrmt_record%record *_*))))
      (%= #$~basetypespec bts))
    (%= #$~res nil)			  ;index ranges will be
           				  ; collected in res.
    (ds_if #$~dscrmt_constraints		  ;collect dscrmts if any.
	   (ds_call_diana #$~dscrmt_constraints));stage

    (let ((bts #$~basetypespec))
      (ds_if (diana_nodep bts)
	   (ds_call_diana bts)))    ;list=>diana.
    (ds_break) ;stage

    (%= #$~indexlist (reverse #$~res))	  ; find indexlist.(if any)
    (let* ((returntype #$%sm_exp_type)
	   (groupbasetype (basetype returntype))
	   (grouptype returntype)
	   (nuobj (ct_make_instance	  ; create return variable.
		     (type_builder groupbasetype)
		     'ada_name nil
		     'ada_index nil)))
	(ct_send nuobj 'initialize
		 (pinitfun groupbasetype grouptype nil #$~indexlist))
	(%= #$~rtnval nuobj))
    (let ((ar #$~nuar)
	  (bdy #$~body)) 
      (cond
	(#$~aa				  ;if there is Ada Advise
	 (let ((*activation* ar))
	   (mapc
	     #'(lambda(af)
		 (funcall af #$~procname
			  (reverse #$~ueparams))) ;#$~res
	     #$~aa))))			  ;apply it to the evaluated arguments.
      (%= *nuactivation* ar))		  ; driver will switch in nu activation record
				; on the next cycle of the virtual machine.
    (ds_break)				  ;stage

    (%= #$~aa (get #$~procname 'ada_after_advise)) ;Ada advice functions.
    (cond ((and (not (eq (diana_nodetype_get
			   (diana_get #$~body 'sm_body))
			 'dn_predefined_function))
		(not #$~funres))
	   (ada_raise '|program_error| "return statement not executed")))
    (cond
      (#$~aa			;if there is Ada Advise
       (let ((*activation* #$~nuar))
	 (mapc
	   #'(lambda(af)(funcall af #$~procname (list #$~funres)))
	   #$~aa))))			  ;apply it to the evaluated arguments.
    ;; return the function result.
    (cond (#$^evaluatep (ds_push #$~funres #$^res))	
          (t            (ds_push #$~funres #$^name)))
)


		;;;;;;;;;;;;;;;;;
(def_diana_node dn_procedure_call(body evaluatep referencep procname aa apl epl
		;;;;;;;;;;;;;;;;;
				       basetypespec dscrmt_constraints invar
				       dscrmt_vars indexlist constraint task
				       fpl res nuar tpnl dpnl name dscrmts
				       ueparams eparams pils compobj proto)
    ;; To call a procedure --
    ;; 1. Evaluate the normalized parameters. (returns alist of parameters)
    ;; 2. Create New activation record for this procedure.
    ;; 3. Put parameters on to the locals slot for the new AR.
    ;; 4. Put the #$~body onto the pc and code slots.
    ;; 5. activation record %= new activation record.
    ;; 6. follow the body.
    ;; 7. Pop the AR (follow clink).
    (%= #$~invar t)
    (%= #$~apl
	(diana_get #$%sm_normalized_param_s 'as_list)) ;get the parameters.
    #|(%= #$~fpl (mapcar
		 #'extract_basetype
		 (diana_get (diana_get pc 'sm_normalized_param_s) 'as_list)))|#
    (let* ((smdef (diana_get #$%as_name 'sm_defn))
	   (rmsel (cond ((eq (diana_nodetype_get smdef) 'dn_selected)
			 (diana_get (find_selected smdef) 'sm_defn))
			(t smdef)))
	   (spec (diana_get rmsel 'sm_spec))
	   (aspar (and spec (diana_get
			      spec
			      'as_param_s))))
      (%= #$~fpl (mapcar
		   #'(lambda(dn)
		       (diana_get
			 (car (diana_get dn 'as_id_s))
			 'sm_obj_type))
		   aspar)))
    (ds_label #$~epl)			  ;evaluate parameters loop.stage

    (%= #$~referencep t)
    (%= #$~evaluatep nil)
    (ds_if #$~apl			  ;if there are parameters to evaluate.
	   (let ((next_parameter (ds_pop #$~apl)))
	     (ds_call_diana next_parameter)))	  ;stage

    ;; find the parameter constraints indices and prototypes if any.
    (let ((tfpl #$~fpl))
      (ds_if tfpl
	     (let ((bts 
		     (cond ((car tfpl)(ds_find_base_type_spec (car tfpl))))))
	       (cond ((is_dscrmt_record bts)
		      (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
		      (%= #$~dscrmt_vars (dscrmt_record%vars bts))
		      (%= bts (dscrmt_record%record *_*))))
	       (%= #$~basetypespec bts))))

  (cond ((eq (diana_nodetype_get  (diana_get #$%as_name 'sm_defn)) 'dn_selected)
	 (%= #$~task (cdr (look_up_ident
		       (diana_get (diana_get #$%as_name 'sm_defn) 'as_name)
			    
		       )))))


#| this might be the best way oneday.
  (%= #$~evaluatep t)
  (ds_if (eq (diana_nodetype_get (diana_get #$%as_name 'sm_defn)) 'dn_selected)
	 (ds_call_diana (diana_get #$%as_name 'sm_defn)))
  (%= #$~task (ds_pop #$~res))
  (break look-at-task)
|#

  (%= #$~evaluatep t)
  (%= #$~res nil)			  ;index ranges will be
           				  ; collected in res.
  (let ((dc #$~dscrmt_constraints))
    (ds_if dc				  ;collect dscrmts if any.
	   (ds_call_diana dc)))
    (ds_break);stage


  (%= #$~constraint nil)
  (let ((bts #$~basetypespec))
    (ds_if (and #$~fpl (diana_nodep bts)  )
	   (ds_call_diana bts)))	  ;list=>diana.
  (ds_break)				  ;stage

  (let ((il (or (reverse #$~res) #$~constraint)))	  ; find indexlist.(if any)
    (ds_push il #$~pils)		  ;add index to ordered list of parameters.
    (%= #$~indexlist il))
  (ds_pop #$~fpl)
    ;; continue to iterate over the actuals.
    (ds_if #$~apl (ds_goto #$~epl))	  ;stage

;  (break wot-we-got)
    (%= #$~eparams
	(let ((formals
		(extract_formal_id_s
		  (let ((spec
			  (cond
			    ((and
			       (not
				 (eq
				   (diana_nodetype_get
				     (subprog_bit
				       (diana_get #$%as_name 'sm_defn)))
				   'dn_entry_id))
			       (diana_get
				     (subprog_bit
				       (diana_get #$%as_name 'sm_defn))
				     'sm_body)
			       (eq (diana_nodetype_get
				   (diana_get
				     (subprog_bit
				       (diana_get #$%as_name 'sm_defn))
				     'sm_body))
				   'dn_rename))
			     ;(break in-dn-proc)
			     (diana_get
				 (diana_get
				   (diana_get
				     (subprog_bit
				       (diana_get #$%as_name 'sm_defn))
				     'sm_body)
				   'as_name)
			       'sm_spec))
			    (t (diana_get
				 (subprog_bit
				   (diana_get #$%as_name 'sm_defn))
				 'sm_spec)))))
		    (and spec (diana_get spec 'as_param_s))))))
	  (mapcar
	    #'(lambda(pn fp)		  ;car fp is a dn_in/out/in_out_id node
		(cond
		  ((and (instancep pn)
			(not (eq (diana_nodetype_get (car fp)) 'dn_out_id)))
		   (ct_send pn 'get_val nil))
		  (t pn)))
	    #$~name (reverse formals))))	  ;dereference the parameters.
    (%= #$~ueparams #$~name)		  ;save the unevaluated ones for OUT
    (%= #$~procname (intern
		      (implode (cadr
				 (diana_get #$%as_name 'lx_symrep)))
		      'user))
    (%= #$~aa (get #$~procname 'ada_advise)) ;Ada advice functions.
    (let* ((bdy
	    (subprog_bit
	      (diana_get #$%as_name 'sm_defn))) ; body is a dn_proc_id node.
	  ;;now, if this is a dn_subprogram_decl, we really want its as_designator.
	  (ar
	    (make_activation_record
	      #$%ct_pnl
	      (diana_get (strip_renames
			   (subprog_bit bdy))
			 'ct_pnl))))	  ; make an empty AR.
      (%= #$~nuar ar)
      (%= #$~body bdy)
      (set-iv adabe_activation ar 'pc bdy)	  ; start procedure at the start.
      (set-iv adabe_activation ar 'node  bdy)

      (let ((epars #$~eparams)
	    (asnam #$%as_name)
	    (pc bdy)
	    (*activation* ar))
	(set-iv adabe_activation ar 'locals 
	       (buildparamlocals 
		 (reverse epars)	  ; evaluated actuals.
		 (let ((spec
		     (let ((id (strip_renames (subprog_bit
					  (diana_get asnam 'sm_defn)))))
		       (or (diana_get id 'ct_spec)
			   (diana_get id 'sm_spec)))))
		   (and spec (diana_get spec 'as_param_s)))  ; formals.
		 )))			  ; setup the initial locals.
      (cond
	(#$~aa				  ;if there is Ada Advise
	 (let ((*activation* ar)) 
	   (mapc
	     #'(lambda(af)
		 (funcall af #$~procname (reverse #$~ueparams)))
	     #$~aa))))			  ;apply it to the evaluated arguments.
	     (%= *nuactivation* ar))	 ;driver will switch in nuactivation record
				; on the next cycle of the virtual machine.
;    (break "about to invoke a new process")
    (ds_break)				  ;stage


;    (break "returned from process")
;;;now that we have returned from the procedure, lets copy back any out 
;;;parameters.
    (%= #$~evaluatep nil)
    (%= #$~referencep t)	;find the origins of the variables.
    (%= #$~name nil)
;;    (ds_follow (first #$%as_param_assoc_s)) ;put result onto #$~name.stage

    (%= #$~aa (get #$~procname 'ada_after_advise)) ;Ada advice functions.
    (%= #$~name
	(copy_back_out_parameters
;      #$%as_param_assoc_s       ;the actual (reference) parameters.
	  (reverse #$~ueparams)		  ;the actual parameter references.
	  (let ((spec
		  (let ((id (strip_renames (subprog_bit
					  (diana_get #$%as_name 'sm_defn)))))
		       (or (diana_get id 'ct_spec)
			   (diana_get id 'sm_spec)))))
	    (and spec (diana_get spec 'as_param_s)))	  ; formal parameters
	  #$~nuar			  ;the activation record.
	  ))
    (cond
      (#$~aa			;if there is Ada Advise
       (let ((*activation* #$~nuar))
	 (mapc
	   #'(lambda(af)(funcall af #$~procname (reverse #$~ueparams)))
	   #$~aa))))			  ;apply it to the evaluated arguments.
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Conditional Statements


		;;;;;;;
(def_diana_node dn_case(expval res evaluatep flag)
		;;;;;;;

    (%= #$~evaluatep t)
    (ds_follow #$%as_exp)			; pushed result to #$~res
    (%= #$~expval (ds_pop #$~res))
    (ds_follow  #$%as_alternative_s))		; search for appropriate
						; 'when'


		;;;;;;;;;;;;;;;;
(def_diana_node dn_alternative_s()
		;;;;;;;;;;;;;;;;

    (ds_follow (first #$%as_list)))


		;;;;;;;;;;;;;;
(def_diana_node dn_alternative(res)
		;;;;;;;;;;;;;;

    (ds_if #$^flag (ds_exit))			; exit if found already.
    (ds_follow #$%as_choice_s)			; look for maching choice.stage

    (let ((exval  #$^expval))
      (mapc
	#'(lambda(ch)
	    (ds_if (consp ch)
		   (cond ((and (greaterp (1+ (coerce_int exval))
					 (coerce_int (first ch)))
			       (lessp    (1- (coerce_int exval))
					 (coerce_int (second ch))))
			  (%= #$^flag t)))
		   (cond ((or (eq ch t)(equal exval ch))
			  (%= #$^flag t)))))
	#$~res))
;    (break in-alternative)
    (ds_if #$^flag (ds_follow #$%as_stm_s) (ds_exit))
)


		;;;;;;;;;
(def_diana_node dn_others()
		;;;;;;;;;

    (ds_push t #$^res))			; this one always wins!


		;;;;;;;;;;;
(def_diana_node dn_choice_s()
		;;;;;;;;;;;

    (ds_follow (first #$%as_list)))


		;;;;;
(def_diana_node dn_if(res)
		;;;;;

    (%= #$~res nil)				; set to t upon completion.
    (ds_follow (first #$%as_list)))		; sucessful cond will return.


		;;;;;;;;;;;;;;
(def_diana_node dn_cond_clause(evaluatep)
		;;;;;;;;;;;;;;

    (ds_if (eq *ct_ada_true* (first #$~res)) (ds_exit))
    (%= #$~evaluatep t)
    (ds_push  *ct_ada_true* #$~res)		; assume t for void case.
    (ds_follow #$%as_exp_void)			; evaluate the expression.
    (ds_if (eq *ct_ada_true* (first #$~res)) (ds_follow #$%as_stm_s)(ds_exit))
    						; if true evaluate stm's
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Control/Iteration Statements


		;;;;;;;
(def_diana_node dn_exit (res evaluatep)
		;;;;;;;

  (%= #$~evaluatep t)				;evaluate the condition.
  (%= #$~res `(,*ct_ada_true*))			;assume that we should leave.
  (ds_follow #$%as_exp_void)
  (ds_if (eq *ct_ada_true* (first #$~res))	; t if we should exit loop.
	 (let ((enclp (cond ((eq (diana_nodetype_get #$%as_name_void)
				 'dn_used_name_id)
			     (diana_get
			       (diana_get #$%as_name_void 'sm_defn)
					'sm_stm))
			    (t (find_closest 'dn_loop pc)))));find loop.
;	   (break in-exit)
	   ;reset the cache
	   (do ((i 0 (1+ i)))
	       ((= i (second (arraydims *ds_cache*))))
	     (let ((cache_entry (aref *ds_cache* i)))
	       (%= (cache%activation cache_entry) nil)
	       (%= (cache%node cache_entry) nil)
	       (%= (cache%entry cache_entry) nil)))
	   (%= *resume* (exit_route enclp)))));exit from it.

;;; Find the closest superior 'node' of 'at'

       ;;;;;;;;;;;;
(defun find_closest(node at)
       ;;;;;;;;;;;;

  (let ((mom (dynamic_mother at)))
    (cond
      ((null mom)(lose 'be_enil 'find_closest
		       `("Error - exit statement not inside a loop")
		       `("Error - exit statement not inside a loop")))
      ((eq (diana_nodetype_get mom) 'dn_ct_exception_handler)
       (find_closest node (diana_get mom 'ct_resume)))
      ((eq (diana_nodetype_get mom) node) mom)
      (t (find_closest node mom)))))

;;; Find the correct exit path from a diana node.

       ;;;;;;;;;;
(defun exit_route(pc)
       ;;;;;;;;;;

  (let ((called_by (nodestagerec%caller
		     (adabe_nodestage_get *activation* pc))))
    (cond
      (called_by called_by)			;we were invoked as a diana proc
      (t #$%ct_cont))))


		;;;;;;;
(def_diana_node dn_loop	(loopvar eolp loopphase res lp)
		;;;;;;;

    ; eolp=t means loop, eolp=nil means not.
    (%= #$~eolp t)				       ; initially loop.
    (%= #$~loopphase 'initialize)		       ; start of loop.
    (ds_follow #$%as_iteration)			       ; preloop test/init.
    (%= #$~loopphase 'iterate)			       ; enter iteration
						       ; cycle.
    (ds_label #$~lp)
;    (ds_follow #$%as_stm_s)
    (ds_if (null #$~eolp)
	(progn
	  (ds_undeclare (car #$~loopvar))
	  (ds_exit))					; end of loop.
	(ds_follow #$%as_stm_s))
    (ds_follow #$%as_iteration)				; loop test
    (ds_goto #$~lp)
)



		;;;;;;
(def_diana_node dn_for(evaluatep basetype constraint)
		;;;;;;

  (%= #$~evaluatep t)
  (ds_if (eq #$~loopphase 'initialize)
	 (ds_call_diana (cond ((eq (diana_nodetype_get #$%as_dscrt_range)
				   'dn_used_name_id)
			       (diana_get  #$%as_dscrt_range 'sm_defn))
			      ((eq (diana_nodetype_get #$%as_dscrt_range)
				   'dn_constrained)
			       (diana_get  #$%as_dscrt_range 'as_constraint))
			      (t  #$%as_dscrt_range))))	  ; find range.stage

  (ds_follow #$%as_id)			  ; find loop id.stage

  (ds_if (eq #$~loopphase 'initialize)
	 (ds_declare (car #$~loopvar)
		     (let ((flv (first (first #$~res))))
			   (cond
			     ((numberp flv) (type_builder '|integer|))
			     ((and (diana_nodep flv)
				   (memq (diana_nodetype_get flv)
						  '(dn_enum_id dn_def_char)))
			      (type_builder '|enumeration|))
			     ((null #$~res)
			      (%=  #$~res #$~constraint)
			      (type_builder
				(basetype (extract_basetype (first #$^loopvar)))))
			     (t (lose 'be_ubif 'diana_node_dn_for
				      ()  ;let the lusers work it out for themselves
				      `("unknown basetype in for")))))
		     nil))
					  ; variable.stage

  (let ((carlpvar (car #$~loopvar))
	(result  #$~res))
    (cond
      ((eq #$~loopphase 'initialize)	  ;check that we really want to iterate.
       (%= #$^eolp (le (coerce_int (first (first result)))
		       (coerce_int (second (first result))))))
      (t
       (ds_if (ge (coerce_int (ds_valof carlpvar))
		  (coerce_int (second (first result))))	  ; end of iteration?
	      (%= #$^eolp nil)		  ; yes.
	      (%= #$^eolp t))))		  ; no..continue.
    (ds_if (eq #$~loopphase 'initialize)
	   (progn
	     (ct_send (cdr (look_up_ident carlpvar))
			   'initialize
			   (list
			     (extract_basetype
			       (diana_get (car #$~loopvar) 'sm_defn))
			     nil
			     nil
			     (diana_get (car #$~loopvar) 'sm_defn)))
	     (ds_update carlpvar nil
			(first (first result))))	  ; initialize loopvar.
	   (cond (#$~eolp (ds_succ carlpvar)))))
  (ds_exit)
  )

                ;;;;;;;;;
(def_diana_node dn_rename ()
                ;;;;;;;;;
  
    (ds_if
      (let ((smdef (diana_get #$%as_name 'sm_defn)))
	(cond ((and smdef
		    (eq
		      (diana_nodetype_get
			smdef)
		      'dn_package_id)) nil)
	      (t t)))
      (ds_call_diana (diana_get #$%as_name 'sm_body))))

		;;;;;;;;;;
(def_diana_node dn_reverse(evaluatep basetype constraint)
		;;;;;;;;;;

  (%= #$~evaluatep t)
  (ds_if (eq #$~loopphase 'initialize)
	 (ds_call_diana (cond ((eq (diana_nodetype_get #$%as_dscrt_range)
				   'dn_used_name_id)
			       (diana_get  #$%as_dscrt_range 'sm_defn))
			      ((eq (diana_nodetype_get #$%as_dscrt_range)
				   'dn_constrained)
			       (diana_get  #$%as_dscrt_range 'as_constraint))
			      (t  #$%as_dscrt_range))))	  ; find range.stage

  (ds_follow #$%as_id)			  ; find loop id.stage

  (ds_if (eq #$~loopphase 'initialize)
	 (ds_declare (car #$~loopvar)
		     (let ((flv (second (first #$~res))))
			   (cond
			     ((numberp flv) (type_builder '|integer|))
			     ((and (diana_nodep flv)
				   (memq (diana_nodetype_get flv)
						  '(dn_enum_id dn_def_char)))
			      (type_builder '|enumeration|))
			     (t (lose 'be_ubif 'diana_node_dn_reverse
				      ()  ;let the lusers work it out for themselves
				      `("unknown basetype in reverse")))))
		     nil))
					  ; variable.stage

  (let ((carlpvar (car #$~loopvar))
	(result #$~res))
    (cond
    ((eq #$~loopphase 'initialize)	  ;check that we really want to itterate.
     (%= #$^eolp (le (coerce_int (first (first result)))
		     (coerce_int (second (first result))))))
    (t
     (ds_if (le (coerce_int (ds_valof carlpvar))
		(coerce_int (first (first result))))	  ; end of iteration?
	    (%= #$^eolp nil)		  ; yes.
	    (%= #$^eolp t))))		  ; no..continue.
  (ds_if (eq #$~loopphase 'initialize)
	 (progn
	   (ct_send (cdr (look_up_ident carlpvar))
			   'initialize
			   (list
			     (extract_basetype
			       (diana_get (car #$~loopvar) 'sm_defn))
			     nil
			     nil
			     (diana_get (car #$~loopvar) 'sm_defn)))  
	 (ds_update carlpvar nil (second (first result))))  ; initialize loopvar.
	 (cond (#$~eolp (ds_pred carlpvar)))))
  (ds_exit)
  )


		;;;;;;;;
(def_diana_node dn_while(res evaluatep)	  ;
		;;;;;;;;

    (%= #$~evaluatep t)
    (ds_follow #$%as_exp)				; eval condition.
    (%= #$^eolp (eq *ct_ada_true* (first #$~res)))	; return value.
)



		;;;;;;;;;;;;;;;
(def_diana_node dn_used_bltn_op()
		;;;;;;;;;;;;;;;

    (%= #$~bltinp t)				; report build in op.
    (%= #$~func (mapop #$%sm_operator))		; return lisp function.
)

                ;;;;;;;;;
(def_diana_node dn_binary (evaluatep res)
                ;;;;;;;;;
  (%= #$~evaluatep t)
  (ds_follow #$%as_exp1)		  ;evaluate the first part stage

  (ds_if (and
	   (eq *ct_ada_true* (first #$~res))
	   (eq (diana_nodetype_get #$%as_binary_op) 'dn_or_else))
	 ;;return the true result to caller
	 (progn (cond (#$^evaluatep (ds_push *ct_ada_true* #$^res))
		      (t (ds_push *ct_ada_true* #$^name)))
		(ds_exit))
	 ;;otherwise try the other leg.
	 (ds_if (not
		  (and
		    (eq *ct_ada_false* (first #$~res))
		    (eq (diana_nodetype_get #$%as_binary_op) 'dn_and_then)))
		(ds_follow #$%as_exp2)))  ;stage

; (break mumf)
  (cond (#$^evaluatep (ds_push (first #$~res)  #$^res))
		      (t (ds_push  (first #$~res) #$^name))))

		;;;;;;;;;;;;;;;;
(def_diana_node dn_parenthesized()
		;;;;;;;;;;;;;;;;

    (ds_follow #$%as_exp))			; evaluate embedded exp.



		;;;;;;;;
(def_diana_node dn_range(res evaluatep)
		;;;;;;;;

  (%= #$~evaluatep t)			  ; evaluate bounds.
  (ds_call_diana #$%as_exp2)		  ; compute last.
  (ds_call_diana #$%as_exp1)		  ; compute first.
  (ds_push  (list (ds_pop #$~res)(ds_pop #$~res)) #$^res)
  )


		;;;;;;;;;;;;;;;
(def_diana_node dn_iteration_id()
		;;;;;;;;;;;;;;;

    (ds_push pc #$~loopvar) 		; return loop id.
)


		;;;;;;;;;;;;;;;;;;
(def_diana_node dn_subprogram_decl()
		;;;;;;;;;;;;;;;;;;
  (ds_if (eq (diana_nodetype_get #$%as_designator) 'dn_entry_id)
	 (progn				  ;elaborate the entry.
	   (let* ((asdes #$%as_designator)
		  (entryq (ct_make_instance 'dt_entry_type
					 'def_occurence asdes))
		  (pair (cons asdes entryq)))
	     (ct_send entryq 'initialize nil)
	     (ct_send #$^thistask 'set_val nil
		      (cons
			pair
			(ct_send #$^thistask 'get_val nil)))))))

#|
		;;;;;;;;;;;;;;;;;;
(def_diana_node dn_subprogram_decl(dead_p)
		;;;;;;;;;;;;;;;;;;
    ;(break in-subprogram-decl)
    (ds_if #$~dead_p 
           (progn
             (ct_send *current_task* 'kill_yourself_and_inferiors)
             (ds_exit)))
    (ds_if #$~starting
	(progn 'compile
               (%= #$~starting nil)	; we found the main procedure!
	       (ds_follow #$%as_designator)))
;	(progn ;(ds_exit)
;	  (ct_send *current_task* 'make_wait_for_inferiors
;		   (ct_send *current_task* 'inferior_tasks))
;	  (break am-I-dead-yet?)
;	  (%= #$~dead_p t)                  ;time to go die.
;	  (ds_follow pc)                  ;by the time I get there I'll be dead.
)
;      (ds_follow #$%as_subprogram_def)
;      (ds_follow #$%as_designator))
|#

		;;;;;;;;;;
(def_diana_node dn_proc_id()
		;;;;;;;;;;

      (ds_call_diana #$%sm_body)
      (ds_return_to_caller))


		;;;;;;;;;;;;;;
(def_diana_node dn_function_id(basetype constraint)
		;;;;;;;;;;;;;;

    (ds_call_diana #$%sm_body)
    (ds_return_to_caller))


		;;;;;;;;;
(def_diana_node dn_return(res evaluatep)
		;;;;;;;;;

    (%= #$~evaluatep t)			; we want to evaluate the result.
    (ds_follow #$%as_exp_void)		; (car #$~res) is the result.stage

    (cond
      (#$~res
       (let* ((result (car #$~res))
	   (rtnobj
	    (let* ((*activation*
		     (get-iv adabe_activation *activation* 'clink))
		   (pc (get-iv adabe_activation *activation* 'pc)))
	      #$~rtnval)))
      (ct_send rtnobj 'set_val nil result))))	  ;perform constraint check.
    (ds_if (not (eq (diana_nodetype_get #$%as_exp_void) 'dn_void))
	   (ds_returnres (car #$~res)))		; return result to caller.stage

    (ds_return_to_caller))


		;;;;;;;;;;;;;;;;;;;;;;;
(def_diana_node dn_predefined_procedure()
		;;;;;;;;;;;;;;;;;;;;;;;

    (funcall #$%ct_lisp_func *activation*))	; call lisp function.


		;;;;;;;;;;;;;;;;;;;;;;
(def_diana_node dn_predefined_function()
		;;;;;;;;;;;;;;;;;;;;;;

    (ds_returnres
      (funcall #$%ct_lisp_func *activation*)))	; call lisp function.


		;;;;;;;;;;;;;;
(def_diana_node dn_constrained(res evaluatep)
		;;;;;;;;;;;;;;

      (%= #$~basetype 
	  (ds_find_type #$%as_name))
      (%= #$~evaluatep t)
      (ds_if #$^constraint
	  (ds_exit)
	  (ds_follow #$%as_constraint)); go find constraints if any
      (ds_if #$^constraint
	  (ds_exit)
	  (progn ;(break in-dn_constrained)
		 (%= #$^constraint #$~res))))


		;;;;;;;;
(def_diana_node dn_stm_s()
		;;;;;;;;


      (ds_follow (first #$%as_list)))


		;;;;;;;;;;;
(def_diana_node dn_null_stm())
		;;;;;;;;;;;

;     (freshline *listing*)
;     (ct_princ "Executing the NULL statement." *listing*)
;     (freshline *listing*))

                ;;;;;;;;;;;;
(def_diana_node dn_named_stm()
                ;;;;;;;;;;;;
    ;;; need to do its as_stm 

   (ds_follow #$%as_id))

		;;;;;;;;;;;;;;;
(def_diana_node dn_named_stm_id()
		;;;;;;;;;;;;;;;

  (ds_call_diana #$%sm_stm))

                ;;;;;;;;;;
(def_diana_node dn_labeled()
                ;;;;;;;;;;
    ;;; need to do its as_stm 
   (ds_follow #$%as_id))

                ;;;;;;;;;;
(def_diana_node dn_label_id()
                ;;;;;;;;;;
    ;;; need to do its as_stm 
   (ds_follow #$%as_stm))

                ;;;;;;;
(def_diana_node dn_goto(labeled process)
                ;;;;;;;
  ;; find the labeled statement.
  (%= #$~labeled (diana_get (diana_get #$%sm_name 'sm_defn) 'ct_labeled))
  ;; ct_change used to be as_name
  (ds_if (null #$~labeled)(lose 'missing-label 'dn_goto))

  ;; find the process for the labeled statement.

    (%= *nuactivation*
	(follow_alink_n_times *activation*
			      (env_depth (diana_get #$~labeled 'as_id))))
  (cond
    ((eq *activation* *nuactivation*)
     (%= *continuation* #$~labeled)
     (%= *nuactivation* nil))
    (t 
     (set-iv adabe_activation *nuactivation* 'pc #$~labeled)))

;  (ct_princ "YOU DESERVE TO LOSE")(ct_terpri)
  
)

		;;;;;;;;
(def_diana_node dn_block (starting mytasks record types formals dscrmts inexc
			  compobj dscrmt_vars del dcls constraint proto)
     		;;;;;;;;
;;;types is used to collect the subtype cxonstraints for types
;;;and the formals for parameters respectively. Each is an A-List indexed
;;;by the defining (dn...id ...) node.
  (%= #$~inexc *exchandler*)
  (%= *exchandler* nil)
  (%= #$~dcls #$%as_item_s)
  (ds_label #$~del)
  (ds_if #$~dcls (ds_call_diana (first #$~dcls)))  ; elaborate the declarations.
  (%= #$~dcls (cdr *_*))
  (ds_if #$~dcls (ds_goto #$~del))
  (ds_call_diana #$%as_stm_s)		  ; execute the statements.
  (%= *exchandler* #$~inexc))

		;;;;;;;
(def_diana_node dn_stub ()
		;;;;;;;
  (ada_raise '|program_error| "missing body"))

		;;;;;;;;;;;;;;;;;
(def_diana_node dn_enum_literal_s()	  ; nothing at runtime.
	        ;;;;;;;;;;;;;;;;;
  (ds_resultis (|attribute_range| pc nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Access types

		;;;;;;;;
(def_diana_node dn_access(basetype)
		;;;;;;;;

)

                ;;;;;;;;;;;;        
(def_diana_node dn_allocator(res evaluatep nuobj basetype compobj 
                ;;;;;;;;;;;;
			     basetypespec constraint indexlist nuvars
			     dscrmt_vars dscrmt_constraints dscrmts
			     invar)
  (%= #$~evaluatep t)		;we will evaluate the initializing expression.
  (ds_find_type  (extract_basetype #$%sm_exp_type));find basetype.
 ; (break trace-me)
  (let ((allbt (diana_nodetype_get  #$%as_exp_constrained)))
    (cond ((not (eq allbt 'dn_qualified))
	   (%= #$~basetypespec
	       (ds_find_base_type_spec #$%as_exp_constrained))
	   (%= #$~res nil))
	  (t
	   (%= #$~basetypespec (ds_find_base_type_spec #$%sm_exp_type)))))
;  (break in-disc-alligators1)
  (ds_if (diana_nodep #$~basetypespec)
	 (ds_call_diana #$~basetypespec))	  ;stage
    
    (let ((bts  #$~basetypespec))
      (cond ((is_dscrmt_record bts)	  ;(break frob)
	     (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
	     (%= #$~dscrmt_vars (dscrmt_record%vars bts))
	     (%= bts (dscrmt_record%record *_*))))
      (%= #$~basetypespec bts))
;  (break in-disc-alligators2)
    (%= #$~res nil)			  ;index ranges will be
					  ; collected in res.
    (let ((dc #$~dscrmt_constraints))
      (ds_if dc				  ;collect dscrmts if any.
	     (ds_call_diana dc)))
    (ds_break)				  ;stage
    
    (let ((bts #$~basetypespec))
      (ds_if (diana_nodep bts)
	     (ds_call_diana bts)))
    (ds_break)				  ;stage
    (ds_if (eq  (diana_nodetype_get #$%as_exp_constrained) 'dn_qualified)
	   (ds_call_diana  #$%as_exp_constrained))
;    (break foolowed-constrained)
    (%= #$~indexlist (reverse #$~res))
;  (break in-dn_allocator)
    (ds_find_type #$%sm_exp_type)
    (%= #$~nuobj (ct_make_instance (type_builder #$~basetype)
				'ada_name nil
				'ada_index nil))
    (ct_send #$~nuobj 'initialize
	     `(,#$%sm_exp_type nil ,(setr_builder #$~basetype) ,pc))
;  (ds_call_diana (diana_get #$%as_exp_constrained 'as_constraint))
    (ct_send #$~nuobj 'set_val nil (first #$~res))
;    (break look-at-nuobj)
    (ds_push #$~nuobj #$^res)
;  (break  in-dn_allocator)
    )

                ;;;;;;
(def_diana_node dn_all (res evaluatep name referencep)
		;;;;;;
  (%= #$~referencep t)
  (%= #$~evaluatep nil)
  (ds_follow #$%as_name)		  ;get the access type object.
  (cond ((eq (ct_send  (first #$~name) 'get_val nil)
	     '*null*)
	 (ada_raise '|constraint_error| ".all operation on access null)")))
  (ds_if #$^evaluatep
	 (ds_push (ct_send
		    (ct_send (first #$~name) 'get_val nil)
		    'get_val nil) #$^res)
	 (ds_push (ct_send
		    (first #$~name)
		    'get_val nil) #$^name))	     
)

		;;;;;;;;;;;;;;
(def_diana_node dn_null_access ()
		;;;;;;;;;;;;;;
  (cond (#$~evaluatep
		(ds_push '*null* #$^res))
	 (t (ds_push '*null* #$^name))))

		;;;;;;;;
(def_diana_node dn_array (basetype res basetypespec dscrmt_constraints
				   dscrmt_vars initval indexlist)
		;;;;;;;;
                         

  (ds_call_diana #$%as_dscrt_range_s)	  ;find the index ranges.
  (%= #$^res #$~res)
  (%= #$~res nil)
  (ds_find_type #$%as_constrained)
  (let ((bts (ds_find_base_type_spec #$%as_constrained)))
    (%= #$~initval #$~res)    
    (cond ((is_dscrmt_record bts)
	   (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
	   (%= #$~dscrmt_vars (dscrmt_record%vars bts))
	   (%= bts (dscrmt_record%record *_*))))
    (%= #$~basetypespec bts))
  (%= #$~res nil)			  ;index ranges will be
           				  ; collected in res.
  (let ((dc #$~dscrmt_constraints))
    (ds_if dc				  ;collect dscrmts if any.
	   (ds_call_diana dc)))
  (ds_break);stage

  (%= #$~constraint nil)
  (let ((bts #$~basetypespec))
    (ds_if (diana_nodep bts)  
	   (ds_call_diana bts)))	  ;list=>diana.
  (ds_break);stage
  (%= #$~indexlist #$~res)
  (%= #$^proto (cdr (object_builder nil))))

		;;;;;;;;;;;;;;;;
(def_diana_node dn_dscrt_range_s(res evaluatep constraint rngl rngs rng bts)
		;;;;;;;;;;;;;;;;

  (%= #$~evaluatep t)
  ;;This is a crocko grosso.
  ;;   used to generate a proto for a constrained array. if not invar,
  ;;   we are in a type declaration!
  (ds_if (and #$^invar
	      (eq (diana_nodetype_get (car #$%ct_threadp)) 'dn_constrained))
	 (ds_call_diana (extract_basetype (car #$%ct_threadp))))
  (%= #$~rngs #$%as_list)
  (ds_label #$~rngl)
  (%= #$~rng (ds_pop #$~rngs))
  (%= #$~bts (ds_find_base_type_spec #$~rng))
  (cond ((eq (diana_nodetype_get #$~rng) 'dn_used_name_id)
	 (%= #$~rng (diana_get #$~rng 'sm_defn))))
  (ds_if #$~rng
	 (ds_call_diana (or #$~bts #$~rng)))
  (ds_if #$~rngs (ds_goto #$~rngl))
  (ds_if #$~constraint
	 (%= #$^res #$~constraint)
	 (%= #$^res  #$~res)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Records

		;;;;;;;;;
(def_diana_node dn_record(record basetype name res evaluatep
				 referencep rcs rcl)
		;;;;;;;;;
  ;; First of all make a record object.
  (%= #$~record (ct_make_instance 'dt_record_type
			       'ada_name nil 'ada_index nil
			       'sm_defn nil
			       'current_value (ada_record_value nil)))
  ;; First elaborate the discriminants .. if there are any.
  (let ((dv #$~dscrmt_vars ))
    (ds_if dv (ds_call_diana  dv)))
  (ds_break);stage

  ;; Now enter any specified discriminant constraints.
  (do ((disc
	 (ada_record_value%record (ct_send #$~record 'current_value))(cdr disc))
       (const
	 #$~dscrmts (cdr const)))
      ((or (null const) (null disc)))
    (ct_send (cdar disc) 'set_val nil (car const)))
  ;; Now elaborate the components.
  (%= #$~rcs #$%as_list)
  (ds_label #$~rcl)
  (ds_if #$~rcs   (ds_call_diana (ds_pop #$~rcs )))	  ;stage
  (ds_if #$~rcs (ds_goto #$~rcl))

  ;; Now return the record object as a complex object.
  (%= #$^compobj #$~record))

		;;;;;;;;;;;;;;;
(def_diana_node dn_inner_record(basetype name res evaluatep referencep)
		;;;;;;;;;;;;;;;
  (ds_follow (first #$%as_list))
)

		;;;;;;;;;;;;;;;
(def_diana_node dn_variant_part(dscrmt)
		;;;;;;;;;;;;;;;
  (%= #$~dscrmt
      (ct_send
	(cdr
	  (assq #$%as_name
		(ada_record_value%record
		  (ct_send #$^record 'current_value))))
	'get_val nil))
  (ds_follow #$%as_variant_s))

		;;;;;;;;;;;;
(def_diana_node dn_null_comp ()
		;;;;;;;;;;;;

  )

		;;;;;;;;;;;;
(def_diana_node dn_variant_s(vars varl found)
		;;;;;;;;;;;;
  (%= #$~vars #$%as_list)		  ;list of variants
  (ds_label #$~varl)
  (ds_if (and #$~vars (not #$~found))
	 (ds_call_diana (ds_pop #$~vars)));search for selected variant.
  (ds_if (and #$~vars (not #$~found))
	 (ds_goto #$~varl)))

		;;;;;;;;;;
(def_diana_node dn_variant(chss chsl evaluatep res)
		;;;;;;;;;;
  (%= #$~evaluatep t)			  ;evaluate the choices
  (%= #$~chss #$%as_choice_s)		  ;choices for this variant.
  (ds_label #$~chsl)
  (ds_if #$~chss
	 (ds_call_diana (ds_pop #$~chss)));evaluate this choice.
  (%= #$~found (equal (ds_pop #$~res) #$^dscrmt))
  (ds_if (and #$~chss (not #$~found))
	 (ds_goto #$~chsl))
  (ds_if #$~found
	 ;;if we get here, this variant is the selected one.
	 (ds_follow #$%as_record)))



		;;;;;;;;;;;;;;;;;
(def_diana_node dn_attribute_call(argument res evaluatep name attribute)
                ;;;;;;;;;;;;;;;;;
  
  (%= #$~evaluatep t)
  (ds_if #$%as_exp
	 (ds_call_diana #$%as_exp)); evaluate the argument if present.stage
	 

  (%= #$~argument (ds_pop #$~res));the argument.
  (ds_call_diana #$%as_name);get the object and the attribute name.stage

  (let* ((handler (concat '|attribute_| #$~attribute))
	 (result  (funcall handler (first #$~name) #$~argument)))
    (cond				  ;return result to caller.
      (#$^evaluatep (ds_push result #$^res))
      (t (ds_push result #$^name)))))

		;;;;;;;;;;;;
(def_diana_node dn_attribute(evaluatep referencep)
                ;;;;;;;;;;;;
  
  (%= #$^attribute
      (intern (implode (cadr (diana_get #$%as_id 'lx_symrep)))
	      'user))  ;attribute name.
  (%= #$~referencep t)
  (ds_if #$%as_name (ds_call_diana #$%as_name)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Aggregates.

       ;;;;;;;;;;;;;;;;;;
(defun string_aggregate_p (ag)
       ;;;;;;;;;;;;;;;;;;

  (and (consp ag)(or (eq (car ag) 'lex_string)(eq (car ag) 'lex_char))))


		;;;;;;;;;;;;
(def_diana_node dn_aggregate(res evaluatep shrinking_aggie alp dyna_aggie range)
		;;;;;;;;;;;;

  (%= #$~evaluatep t)			  ;set RHS mode for aggregate eval.
  (cond
    (#$%sm_normalized_comp_s
     (%= #$~shrinking_aggie
	 (cond ((diana_nodep #$%sm_normalized_comp_s)
		(diana_get #$%sm_normalized_comp_s 'as_list))
	       (t (%= #$~dyna_aggie t)
		  #$%sm_normalized_comp_s))))
    (t (%= #$~shrinking_aggie #$%as_list)));++
  (ds_if #$~dyna_aggie
	 (ds_call_diana
	   (let ((range (dynamic_range_rec%range #$~shrinking_aggie)))
	     (cond ((memq (diana_nodetype_get range) '(dn_used_name_id))
		    (diana_get range 'sm_defn))
		   (t range)))))
  (cond ((and #$~dyna_aggie (consp (car #$~res)))
	 (do ((i (coerce_int (caar #$~res)) (1+ i))
	      (val nil (cons (dynamic_range_rec%val #$~shrinking_aggie) val)))
	     ((> i (coerce_int (cadar #$~res)))
	      (%= #$~shrinking_aggie val))))
	(#$~dyna_aggie
	 (%= #$~shrinking_aggie
	     (cons (dynamic_range_rec%val #$~shrinking_aggie) nil))))
  (%= #$~res nil)

  (ds_label #$~alp)			  ;stage

  (ds_if #$~shrinking_aggie
	 (let ((nxt_agponent (ds_pop  #$~shrinking_aggie)))
	   (ds_call_diana nxt_agponent))) ;stage

  (ds_if  #$~shrinking_aggie (ds_goto #$~alp))	  ;stage

;;  (ds_call_diana (first #$%as_list))	  ;evaluate the aggregates exp's,
  (ds_if #$^evaluatep
	 (ds_resultis (nreverse #$~res))
	 (ds_push (nreverse #$~res) #$^name)))	  ;return in the correct order.


		;;;;;;;;
(def_diana_node dn_named()
		;;;;;;;;

  (lose 'be_nanyi 'diana_node_dn_aggregate
	'("Named aggregates are not yet implemented - sorry"))
  )
		;;;;;;;;;;;;;;;;;;;
(def_diana_node dn_dscrmt_aggregate(res evaluatep ds dl)
		;;;;;;;;;;;;;;;;;;;

  (%= #$~evaluatep t)
  (%= #$~ds #$%as_list)
  (ds_label #$~dl)
  (ds_if #$~ds
	 (ds_call_diana (ds_pop #$~ds)))	  ;should be sm_normalized_comp_s
  (ds_if #$~ds (ds_goto #$~dl))
  (%= #$^dscrmts (reverse #$~res))
)
		;;;;;;;;
(def_diana_node dn_fixed(res evaluatep)
		;;;;;;;;

  (%= #$~evaluatep t)
  (ds_follow #$%as_range_void)		  ;get the range.
  (ds_follow #$%as_exp)			  ;get the delta
  (%= #$^res #$~res)			  ;return (delta (L R)) to be used in
					  ;initialize.
)

;; return the range (array declaration)

		;;;;;;;;;;
(def_diana_node dn_integer(res)
		;;;;;;;;;;
  (ds_follow #$%as_range)
  ;(break look-at-range)
  (ds_resultis (car #$~res)))

		;;;;;;;;
(def_diana_node dn_float(res evaluatep)
		;;;;;;;;
  (%= #$~evaluatep t)
  (ds_follow #$%as_range_void)
  (ds_follow #$%as_exp)
  ;(break look-at-range)
  (%= #$^res #$~res);return ( digit (l r))
  )

		 ;;;;;;;;;;
(def_diana_node  dn_type_id()
		 ;;;;;;;;;;
  (ds_resultis (|attribute_range| pc nil )))
  
		 ;;;;;;;;;;;;;
(def_diana_node  dn_subtype_id()
		 ;;;;;;;;;;;;;
  (ds_resultis (|attribute_range| pc nil )))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Object Declarations.


		;;;;;;;;;
(def_diana_node dn_number()
		;;;;;;;;;
)


(def_diana_node dn_dscrmt_var_s()
;  (break ds_var_s-entry)
  (ds_follow (first #$%as_list))
;  (break ds_var_s-exit)
)

		;;;;;;;;;;;
(def_diana_node dn_constant(indexlist basetype nuvars evaluatep res invar
			    ival thistask compobj initval basetypespec
			    constraint elp ids renamep dscrmts
			    dscrmt_constraints dscrmt_vars referencep proto)
		;;;;;;;;;;;
                       
		       
  (%= #$~invar t)
   (%= #$~ids #$%as_id_s)
   (ds_label #$~elp)			  ;stage

   (ds_if #$~ids (ds_call_diana (car #$~ids))) ;stage
   (%= #$~evaluatep t)
   (let ((aod #$%as_object_def))
    (ds_if
      (and aod (eq (diana_nodetype_get aod) 'dn_rename))
      (%= #$~renamep (diana_get aod 'as_name))
      (ds_call_diana aod)))
  (ds_break)
  (let* ((id (car #$~ids))
	 (ts (extract_basetype id)))
    (ds_if (eq (diana_nodetype_get ts) 'dn_task_spec)
	   (progn
	     (%= #$~thistask (ct_make_instance 'dt_task_type
					  'current_value nil
					  'sm_defn ts
					  'def_occurence id))
	     (set-iv adabe_activation *activation* 'locals
		     (cons
		       (cons id #$~thistask )
		       (get-iv adabe_activation *activation* 'locals)	  ; the locals slot.
		       ))
	     (ds_call_diana ts)))
    )
  (ds_break) ;(break look_at-tasks)
   (ds_push #$~res  #$~ival)
   (%= #$~evaluatep nil)
   (ds_pop #$~ids)
   (ds_if #$~ids (ds_goto #$~elp))	  ;stage
   (ds_if (eq (diana_nodetype_get (extract_basetype (car #$%as_id_s)))
	      'dn_task_spec)
	  (ds_exit))

;  (ds_follow (first #$%as_id_s))	  ; build list of identifiers.
;  (ds_follow #$%as_type_spec)	          ; find base type and constraint
  (ds_find_type #$%as_type_spec)
  (%= #$~evaluatep t)			  ; set evaluate mode.
  ; evaluate expression.(init).stage


  (let ((bts (ds_find_base_type_spec #$%as_type_spec)))
        
    (cond ((is_dscrmt_record bts)
	   (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
	   (%= #$~dscrmt_vars (dscrmt_record%vars bts))
	   (%= bts (dscrmt_record%record *_*))))
    ;(break look-at-dscrmt)
    (%= #$~basetypespec bts))
  (%= #$~res nil)			  ;index ranges will be
           				  ; collected in res.
  (let ((dc #$~dscrmt_constraints))
    (ds_if dc				  ;collect dscrmts if any.
	   (ds_call_diana dc)))
  (ds_break);stage

;  (break dn_var)
  (%= #$~constraint nil)
  (let ((bts #$~basetypespec))
    (ds_if (diana_nodep bts)  
	   (ds_call_diana bts)))	  ;list=>diana.
  (ds_break);stage 

  (%= #$~indexlist (or (reverse #$~res) #$~constraint))	  ; find indexlist.(if any)
;      (break in-var)
  ;; Now we have a list of identifiers in nuvar and the basetype in
  ;; basetype. The initialization is in 'res' if it exists.
  ;; All we have to do is create an object of type 'type' for each
  ;; 'nuvar' and put them on the current activation record *activation*
  ;; locals slot. Then if there was an initialization expression, we
  ;; initialize the new object to that value.
  ;; Whats more, if the object is a complex one (currently a record),
  ;; the prototypical object is in compobj.
  ;; Note: In the absence of an initialization *unassigned* will be used
  ;;       to initialize the new object.

;; if we are in the context of a record, we need to insert the record
;; components. Otherwise we need to add these declarations to the
;; current activation record.
  (let ((rec #$^record)
	(newvar #$~nuvars))
    (ds_if rec
	   (%= (ada_record_value%record (ct_send rec 'current_value))
	       (append
		 *_*
		 (mapcar #'(lambda (var)
				      (%= #$~initval (ds_pop #$~ival))
				      (object_builder var))
				  newvar)
		 ;(mapcar #'object_builder newvar);++pmj changed to be the same
		 ;as the non record case 84-3-18
		 ))
	   (let ((*activation*
		   (follow_alink_n_times
		     *activation*
		     (env_depth (car #$%as_id_s)))))
	     (set-iv adabe_activation *activation* 'locals
		     (append
		       (cond
			 (#$~renamep
			  (let ((renamed_var (look_up_ident #$~renamep)))
			    `((,(first #$~nuvars) . ,(cdr renamed_var)))))
			 (t 
			  (mapcar #'(lambda (var)
				      (%= #$~initval (ds_pop #$~ival))
				      (object_builder var))
				  newvar)))
		       (get-iv adabe_activation *activation* 'locals)	  ; the locals slot.
		       )))))
;  (break in-var)
)			  ; returns an A-list of ids and objects.

                ;;;;;;
(def_diana_node dn_var(indexlist basetype nuvars evaluatep res invar ival
		       thistask compobj initval basetypespec constraint elp
		       ids renamep dscrmts dscrmt_constraints dscrmt_vars
		       referencep proto)
		;;;;;;
                       
		       
  (%= #$~invar t)
   (%= #$~ids #$%as_id_s)
   (ds_label #$~elp)			  ;stage

   (ds_if #$~ids (ds_call_diana (car #$~ids))) ;stage
   (%= #$~evaluatep t)
   (let ((aod #$%as_object_def))
    (ds_if
      (and aod (eq (diana_nodetype_get aod) 'dn_rename))
      (%= #$~renamep (diana_get aod 'as_name))
      (ds_call_diana aod)))
  (ds_break)
  (let* ((id (car #$~ids))
	 (ts (extract_basetype id)))
    (ds_if (eq (diana_nodetype_get ts) 'dn_task_spec)
	   (progn
	     (%= #$~thistask (ct_make_instance 'dt_task_type
					  'current_value nil
					  'sm_defn ts
					  'def_occurence id))
	     (set-iv adabe_activation *activation* 'locals
		     (cons
		       (cons id #$~thistask )
		       (get-iv adabe_activation *activation* 'locals)	  ; the locals slot.
		       ))
	     (ds_call_diana ts)))
    )
  (ds_break) ;(break look_at-tasks)
   (ds_push #$~res  #$~ival)
   (%= #$~evaluatep nil)
   (ds_pop #$~ids)
   (ds_if #$~ids (ds_goto #$~elp))	  ;stage
   (ds_if (eq (diana_nodetype_get (extract_basetype (car #$%as_id_s)))
	      'dn_task_spec)
	  (ds_exit))

;  (ds_follow (first #$%as_id_s))	  ; build list of identifiers.
;  (ds_follow #$%as_type_spec)	          ; find base type and constraint
  (ds_find_type #$%as_type_spec)
  (%= #$~evaluatep t)			  ; set evaluate mode.
  ; evaluate expression.(init).stage


  (let ((bts (ds_find_base_type_spec #$%as_type_spec)))
        
    (cond ((is_dscrmt_record bts)
	   (%= #$~dscrmt_constraints (dscrmt_record%dscrmt bts))
	   (%= #$~dscrmt_vars (dscrmt_record%vars bts))
	   (%= bts (dscrmt_record%record *_*))))
    ;(break look-at-dscrmt)
    (%= #$~basetypespec bts))
  (%= #$~res nil)			  ;index ranges will be
           				  ; collected in res.
  (let ((dc #$~dscrmt_constraints))
    (ds_if dc				  ;collect dscrmts if any.
	   (ds_call_diana dc)))
  (ds_break);stage

;  (break dn_var)
  (%= #$~constraint nil)
  (let ((bts #$~basetypespec))
    (ds_if (diana_nodep bts)  
	   (ds_call_diana bts)))	  ;list=>diana.
  (ds_break);stage 

  (%= #$~indexlist (or (reverse #$~res) #$~constraint))	  ; find indexlist.(if any)
;      (break in-var)
  ;; Now we have a list of identifiers in nuvar and the basetype in
  ;; basetype. The initialization is in 'res' if it exists.
  ;; All we have to do is create an object of type 'type' for each
  ;; 'nuvar' and put them on the current activation record *activation*
  ;; locals slot. Then if there was an initialization expression, we
  ;; initialize the new object to that value.
  ;; Whats more, if the object is a complex one (currently a record),
  ;; the prototypical object is in compobj.
  ;; Note: In the absence of an initialization *unassigned* will be used
  ;;       to initialize the new object.

;; if we are in the context of a record, we need to insert the record
;; components. Otherwise we need to add these declarations to the
;; current activation record.
  (let ((rec #$^record)
	(newvar #$~nuvars))
    (ds_if rec
	   (%= (ada_record_value%record (ct_send rec 'current_value))
	       (append
		 *_*
		 (mapcar #'(lambda (var)
				      (%= #$~initval (ds_pop #$~ival))
				      (object_builder var))
				  newvar)
		 ;(mapcar #'object_builder newvar);++pmj changed to be the same
		 ;as the non record case 84-3-18
		 ))
	   (let ((*activation*
		   (follow_alink_n_times
		     *activation*
		     (env_depth (car #$%as_id_s)))))
	     (set-iv adabe_activation *activation* 'locals
		     (append
		       (cond
			 (#$~renamep
			  (let ((renamed_var (look_up_ident #$~renamep)))
			    `((,(first #$~nuvars) . ,(cdr renamed_var)))))
			 (t 
			  (mapcar #'(lambda (var)
				      (%= #$~initval (ds_pop #$~ival))
				      (object_builder var))
				  newvar)))
		       (get-iv adabe_activation *activation* 'locals)	  ; the locals slot.
		       )))))
;  (break in-var)
)

		;;;;;;;;
(def_diana_node dn_slice(res evaluatep referencep name nuarray)
		;;;;;;;;

  (%= #$~referencep t)
  (ds_follow #$%as_name)	;get the array object. => name stage

  (%= #$~evaluatep t)
  (ds_follow #$%as_dscrt_range)	;get the range.        => res stage

  ;;check the bounds of the range.
  (let ((result #$~res)
	(nme #$~name))
    (cond
      ((eq (and (consp (first nme))(first (first nme))) 'lex_string));temp crock+++
      ((> (first (first result))(second (first result)))) ;null slice. -- OK
      ((> (second (first result))
	  (second (first (ct_send (first nme) 'index_list))))
       (ada_raise '|constraint_error| "slice out of bounds"))
      ((< (first (first result))
	  (first (first (ct_send (first nme) 'index_list))))
       (ada_raise '|constraint_error| "slice out of bounds")))
    (%= #$~nuarray			  ;make an array object.
	(let ((arobj (first nme)))
	  (cond ((instancep arobj)
		 (ct_make_instance 'dt_array_type
			 'sm_defn nil	  ;(ct_send arobj 'sm_defn)
			 'index_list result	  ;the new range.
			 'multipliers (ct_send arobj 'multipliers)
			 'starters (ct_send  arobj 'starters)
			 'ada_name (ct_send  arobj 'ada_name)
			 'ada_index nil
			 'array_storage
			 (ct_send arobj 'array_storage)
			 ))
		((and (consp arobj);;total crock, do right later.+++
		      (eq (car arobj) 'lex_string))
		 (do ((oldstr (nthcdr (1- (caar result)) (cadr arobj))
			      (cdr oldstr) )
		      (newstr nil)
		      (i (caar result) (1+ i)))
		     ((> i (cadar result)) 
		      (list 'lex_string (nreverse newstr)))
		   (ct_push (car oldstr) newstr)))
		      )))
    (cond				  ;Make new slice available for use.
      (#$^evaluatep (ds_push #$~nuarray #$^res))
      (t            (ds_push #$~nuarray #$^name))))
;  (break in-slice)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Expressions / object access.


		;;;;;;;;;
(def_diana_node dn_var_id()
		;;;;;;;;;

;    (ds_push #$%lx_symrep #$^nuvars)	;sideffect dn_var's list.
    (ds_push #$%sm_defn #$^nuvars))	;sideffect dn_var's list.


		;;;;;;;;;;
(def_diana_node dn_comp_id()
		;;;;;;;;;;

;    (ds_push #$%lx_symrep #$^nuvars)	;sideffect dn_var's list.
    (ds_push #$%sm_defn #$^nuvars))	;sideffect dn_var's list.

		;;;;;;;;;;
(def_diana_node dn_dscrmt_id()
		;;;;;;;;;;

;    (ds_push #$%lx_symrep #$^nuvars)	;sideffect dn_var's list.
    (ds_push #$%sm_defn #$^nuvars))	;sideffect dn_var's list.


		;;;;;;;;;;
(def_diana_node dn_enum_id()
		;;;;;;;;;;

;    (ds_push #$%lx_symrep #$^nuvars)	;sideffect dn_var's list.
    (ds_push #$%sm_defn #$^nuvars))	;sideffect dn_var's list.


		;;;;;;;;;;;;
(def_diana_node dn_number_id()
		;;;;;;;;;;;;

;    (ds_push #$%lx_symrep #$^nuvars)	;sideffect dn_var's list.
    (ds_push #$%sm_defn #$^nuvars))	;sideffect dn_var's list.


		;;;;;;;;;;;
#|(def_diana_node dn_const_id()
		;;;;;;;;;;;
  (ds_if #$%sm_obj_def
	 (ds_call_diana #$%sm_obj_def)
	 (ds_call_diana #$%sm_init_exp)))|#

		;;;;;;;;;
(def_diana_node dn_const_id()
		;;;;;;;;;

;    (ds_push #$%lx_symrep #$^nuvars)	;sideffect dn_var's list.
    (ds_push #$%sm_defn #$^nuvars))	;sideffect dn_var's list.



		;;;;;;;;;;;;;;;;;;
(def_diana_node dn_character_literal()  	; side effect callers #$~res
		;;;;;;;;;;;;;;;;;;

  (cond
    (#$~evaluatep
     (ds_push (convert_integer_to_char (caadr #$%lx_symrep)) #$~res))
    (#$~referencep
     (ds_push (convert_integer_to_char (caadr #$%lx_symrep)) #$~name))
    (t (lose 'be_wmawi 'diana_node_dn_character_literal
	     ()
	     '("what mode are we in ? dn_character_literal")))))

		;;;;;;;;;;;;;;;;;;
(def_diana_node dn_numeric_literal()  	; side effect callers #$~res
		;;;;;;;;;;;;;;;;;;

  (cond
    (#$~evaluatep (ds_push (numval #$%lx_numrep) #$~res) )
    (#$~referencep (ds_push (numval #$%lx_numrep) #$~name))
    (t (lose 'be_wmawi 'diana_node_dn_numeric_literal
	     ()
	     '("what mode are we in ? dn_numeric_literal")))))
;    (ds_push (numval #$%lx_numrep) #$~res)) 


		;;;;;;;;;;;;;;;;;
(def_diana_node dn_string_literal()   	; put string onto callers #$~res
		;;;;;;;;;;;;;;;;;

  (cond
    (#$~evaluatep (ds_push #$%lx_symrep #$~res))
    (#$~referencep (ds_push #$%lx_symrep #$~name))
    (t (lose 'be_wmami 'diana_node_dn_string_literal
	     ()
	     '("what mode are we in ? dn_string_literal")))))

;;; There are three modes in which used_name_id's can be used.
;;; (1) RHS mode, evaluatep = t
;;;     returns the value of the id.
;;; (2) LHS mode, referencep = t
;;;     returns the object that id is bound to (used primarily in assignment).
;;; (3) NAME mode,
;;;     returns the id itself, used primarily in declarations.

		;;;;;;;;;;;;;;;
(def_diana_node dn_used_name_id()
		;;;;;;;;;;;;;;;
 (let* ((smdef (diana_get pc 'sm_defn))
	(ntype (diana_nodetype_get smdef)))
   (cond
     (#$~evaluatep			  ; are we evaluating names? RHS mode?
      (cond
	((memq ntype
	       '(dn_enum_id dn_type_id dn_subtype_id dn_def_char))
	 (ds_push smdef #$~res)) 
	((eq ntype 'dn_number_id)
	 (ds_push (be_static_eval pc) #$~res))
	((eq ntype 'dn_dscrmt_id)
	 (ds_push (ct_send
		    (ct_send #$~record 'get_val #$%sm_defn)
		    'get_val
		    nil)
		  #$~res))
	#|((eq ntype 'dn_const_id)
	 (ds_call_diana #$%sm_defn))|#  
	(t (ds_push (ds_valof pc) #$~res))))	  ; record of pc.
     (#$~referencep			  ; is this LHS mode?
      (cond
	((memq ntype
	       '(dn_enum_id dn_type_id dn_subtype_id dn_predefined_type dn_def_char))
	 (ds_push smdef #$~name))
	((eq ntype 'dn_number_id)
	 (ds_push (be_static_eval pc) #$~name))
	#|((eq ntype 'dn_const_id)
	 (ds_call_diana #$%sm_defn))|#  
	(t 
	 (ds_push
	   (cdr (look_up_ident pc))	  ;object to which pc is bound.
	   #$~name))))
     (t  (ds_push pc #$~name)))))	  ; otherwise return the name.

       ;;;;;;;;;;;;;;;;;;;;;
(defun conversion_compatible (val type)
       ;;;;;;;;;;;;;;;;;;;;;
  ;;this is not finished it needs to ensure that
  ;;this value is compatible with the type.
  ;; For the moment just return t
  (let* ((typid (or (and (eq (diana_nodetype_get type) 'dn_selected)
			 (diana_get
			   (diana_get type 'as_designator_char)
			   'sm_defn))
		    (diana_get type 'sm_defn)))
	 (typspec (and typid (diana_get typid 'sm_type_spec)))
	 (range (and typspec
		     (ct_selectq
		       (diana_nodetype_get typspec)
		       ((dn_float dn_fixed)
			(let*
			  ((r (diana_get typspec 'as_range_void))
			   (lb
			     (cond ((eq (diana_nodetype_get r)
					'dn_void)
				    *float_first*)
				   (t
				    (static_eval (diana_get r 'as_exp1)))))
			   (ub
			     (cond ((eq (diana_nodetype_get r)
					'dn_void)
				    *float_last*)
				   (t (static_eval (diana_get r 'as_exp2))))))
			  (list lb ub)))
		       (dn_derived
			 nil)
		       (otherwise
			 (let ((rang (|attribute_range| typid nil)))
			   (cond ((consp (first rang))
				  `(,(fpv_to_real_conversion (car rang))
				    ,(fpv_to_real_conversion (cadr rang))))
				 (t rang))))))))
    (cond ((numberp val)
	   (cond ((and range
		       (equal (car range) nil))
		  t)
		 ((and range
		       (or (= val (first range))
			   (> val (first range)))
		       (or (= val (second range))
			   (< val (second range))))
		  t)
		 
		 ((and range
		       (or (< val (first range))
			   (> val (second range))))			 
		  (ada_raise '|constraint_error|
			     "number out of range in conversion"))
		 (t t)))
	  (t   t))))
  
                ;;;;;;;;;;;;;
(def_diana_node dn_conversion()
                ;;;;;;;;;;;;;
  ;;; There needs to be a check that the return value of the conversion 
  ;;; is assignment compatible with the conversion type.
  (ds_call_diana #$%as_exp)
  (cond (#$^evaluatep (conversion_compatible (car #$^res) #$%as_name))
	((instancep (car #$^name))
	 (conversion_compatible (ct_send (car #$^name) 'get_val nil) #$%as_name))
	(t (conversion_compatible (car #$^name) #$%as_name))))

                ;;;;;;;;;;;;
(def_diana_node dn_qualified()
                ;;;;;;;;;;;;

  (ds_call_diana #$%as_exp))

		;;;;;;;;
(def_diana_node dn_index ()
		;;;;;;;;
  )

		;;;;;;;;;;
(def_diana_node dn_indexed(res name referencep evaluatep arrobj indexed)
		;;;;;;;;;;

  (%= #$~referencep t)
  (ds_follow #$%as_name)		  ; get the array object.stage
  (%= #$~arrobj (first #$~name))	  ; => arrobj
  (%= #$~evaluatep t)
  (%= #$~res nil)
  (ds_follow #$%as_exp_s)	  ; evaluate the indices.stage

  (%= #$~indexed (ct_send #$~arrobj 'get_val (reverse #$~res)))	  ; get object.
  (cond
    (#$^evaluatep			  ; mom in RHS mode?
     (ds_resultis (ct_send #$~indexed 'get_val nil)))
    (#$^referencep
     (ds_push #$~indexed #$^name))
    (t (lose 'be_wmawi 'diana_node_dn_indexed
	     ()
	     '("in dn_indexed ... not in LHS or RHS mode!!")) ))
  )
    
;;; selected needs to be hacked to work for  packages, tasks, 
;;; functions and procedures too.

		;;;;;;;;;;;
(def_diana_node dn_selected  (name res referencep evaluatep recobj selected)
		;;;;;;;;;;;

  (%= #$~referencep t)
  (ds_if (or
	   (memq (diana_nodetype_get #$%as_name) '(dn_selected dn_indexed dn_all))
	   (and (eq (diana_nodetype_get #$%as_name) 'dn_used_name_id)
		(memq (diana_nodetype_get
			(diana_get #$%as_name 'sm_defn))
		      '(dn_in_id dn_out_id dn_in_out_id dn_var_id))))
	 (ds_follow #$%as_name))		  ; get the record object.stage

  (cond ((not #$^evaluatep) (%= #$~referencep #$^referencep)))
  (%= #$~evaluatep #$^evaluatep)
  (%= #$~recobj (first #$~name))	  ; => recobj
;  (break in-dn_selected)
  (ds_if (or (null #$~recobj)
	     (and
	       (eq (diana_nodetype_get #$%as_name) 'dn_used_name_id)
	       (memq (diana_nodetype_get (diana_get #$%as_name 'sm_defn))
		     '(dn_package_id dn_proc_id dn_function_id dn_task_body_id))))
	 (progn
	   (ds_follow #$%as_designator_char )
	   )
	 (%= #$~selected
	     (ct_send #$~recobj 'get_val
		      (diana_get #$%as_designator_char 'sm_defn))))	  ;stage

;  (break look-at-selected)
  (ds_if (or (null #$~recobj)
	     (and
	       (eq (diana_nodetype_get #$%as_name) 'dn_used_name_id)
	       (memq (diana_nodetype_get (diana_get #$%as_name 'sm_defn))
		     '(dn_package_id dn_proc_id dn_function_id dn_task_body_id))))
	 (cond
	   (#$^evaluatep	    
	    (ds_resultis (first #$~res)))
	   (#$^referencep	    
	    (ds_push (first #$~name) #$^name)))
	 (cond
	   (#$^evaluatep		  ; mom in RHS mode?
	    (ds_resultis (ct_send #$~selected 'get_val nil)))
	   (#$^referencep
	    (ds_push #$~selected #$^name))
	   (t (lose 'be_wmawi 'diana_node_dn_selected
		    ()
		    '("in dn_selected ... not in LHS or RHS mode!!")) )))
;  (break in-dn_selected)
  )
      
    
;;; used in array indices. simply evaluate the list of expressions.
;;; note, the resulting list of values will be in the reverse order
;;; upon completion. (in callers #$~res) and must be reversed before
;;; used. Also used in normalized parameters.. same applies.

		;;;;;;;;
(def_diana_node dn_exp_s()
		;;;;;;;;

    (ds_follow (first #$%as_list)))


		;;;;;;;;;;;;;;;;;;
(def_diana_node dn_predefined_type())
		;;;;;;;;;;;;;;;;;;


		;;;;;;;;;;;;;;;;
(def_diana_node dn_param_assoc_s()
		;;;;;;;;;;;;;;;;

  (ds_follow (first #$%as_list)))


		;;;;;;;;;;;;;
(def_diana_node dn_membership(res evaluatep referencep not_in_p resp)
		;;;;;;;;;;;;;

  (%= #$~evaluatep t)
  (ds_call_diana (find_range #$%as_type_range))	  ;find the range => res stage

  (ds_follow #$%as_exp)			  ;find the expression. stage

  (%= #$~not_in_p (eq (diana_nodetype_get #$%as_membership_op) 'dn_not_in))
  (let ((result #$~res))
    (%= #$~resp (and (ge (coerce_int (first result))
			 (coerce_int (first (second result))))
		     (le (coerce_int (first result))
			 (coerce_int (second (second result)))))))
  (cond (#$~not_in_p (%= #$~resp (not #$~resp))))
  (cond
    (#$^evaluatep
     (ds_push (cond (#$~resp *ct_ada_true*)(t *ct_ada_false*)) #$^res))
    (t
     (ds_push (cond (#$~resp *ct_ada_true*)(t *ct_ada_false*)) #$^name))))
    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous statements.


		;;;;;;;;;
(def_diana_node dn_assign(name res evaluatep referencep)
		;;;;;;;;;

  (%= #$~evaluatep t)			  ; we will evaluate names in the RHS
  (ds_call_diana #$%as_exp)			  ; evaluate the R.H.S.
  (%= #$~evaluatep nil)			  ; don't evaluate LHS.
  (%= #$~referencep t)			  ; but return a reference.
  (ds_call_diana #$%as_name)		  ; evaluate    L.H.S.
;  (break frob)
  (ct_send (first #$~name) 'set_val nil (first #$~res))
					  ; update the value associated with #$~name
  )

		;;;;;;;;;
(def_diana_node dn_pragma(params name evaluatep referencep ppl
		;;;;;;;;;

				 evp pragmads res pragmaname)
					  ; runtime semantics for a pragma (if any).
  (%= #$~pragmaname (intern (implode (cadr #$%as_id))
			    'user))
  (cond
    ((get #$~pragmaname 'lhs_params)
     (%= #$~referencep t))		  ;find the addresses of the parameters.
    (t
     (%= #$~evaluatep t)))		  ; lets evaluate the parameters.
  (%= #$~name nil)
  (%= #$~res nil)
  (%= #$~params nil)
#|
  (ds_if (second (diana_get #$%as_param_assoc_s 'as_list))
	 (ds_call_diana (second (diana_get #$%as_param_assoc_s 'as_list))); onto params
	 )
|#
  (%= #$~ppl (cdr (diana_get #$%as_param_assoc_s 'as_list)))
  (ds_label #$~evp)			  ;loop on eval parameters. stage

  (ds_if #$~ppl				  ;if there are parameters.
	 (ds_call_diana (first #$~ppl)))  ;evaluate the first. stage

  (ds_if #$~ppl (%= #$~ppl (cdr #$~ppl))) ;cdr down the parameter liust stage

  (ds_if #$~ppl (ds_goto #$~evp))	  ;stage

  (%= #$~params
      (cons
	(first (diana_get #$%as_param_assoc_s 'as_list))
	(reverse (cond (#$~referencep #$~name)(t #$~res)))))
					  ; get parameters into the right order.
  (%= #$~pragmads (get #$~pragmaname 'pragma_runtime_semantics))
;  (break in-dn_pragma)
  (cond 
    ((null #$~pragmads)
     (lose 'be_mrsp 'diana_node_dn_pragma
	   ()
	   '("Missing runtime semantics for PRAGMA")))
    (t (funcall #$~pragmads #$~params )))); run the ds over the parameters.


;;; This diana node is created to implement the pragma interface(lisp ..).



		;;;;;;;;;;;;;;
(def_diana_node dn_ct_lispcall() ; pass control to lisp function.
		;;;;;;;;;;;;;;

    (funcall #$%ct_function *activation*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These nodes do nothing at all at runtime.


		;;;;;;;
(def_diana_node dn_void ()
		;;;;;;;

)


		;;;;;;
(def_diana_node dn_use ()
		;;;;;;

)

		;;;;;;;;;;;;;
(def_diana_node dn_simple_rep ())
		;;;;;;;;;;;;;

		;;;;;;;;;;;;;
(def_diana_node dn_record_rep ())
		;;;;;;;;;;;;;


		 ;;;;;;;
;(def_diana_node dn_void ())
		 ;;;;;;;

;;; Define the runtime semantics of a lisp_call pragma.
(defprop |lisp_call|
    (lambda(params)
	(funcall 
	    (intern (implode (cadr (diana_get (first params) 'lx_symrep)))
		    'user)
	    (cdr params)))
    pragma_runtime_semantics)

;;; Define the runtime semantics of a list pragma.
(defprop |list|
    (lambda(params) nil)
    pragma_runtime_semantics)

(defprop |page|
    (lambda(params) nil)
    pragma_runtime_semantics)

(defprop |pack|
    (lambda(params) nil)
    pragma_runtime_semantics)

;;; Define the runtime semantics of a annotate pragma.
(defprop |annotate|
    (lambda(params)
	(apply 
	    (intern (implode (cadr (diana_get (first params) 'lx_symrep)))
		    'user)
	    (massage_annotation_parameters (cdr params))))
    pragma_runtime_semantics)

(defprop |annotate| t lhs_params) ;takes reference parameters!

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


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Macros -- 
       ;;;;;
(defun mapop(opname)
       ;;;;;

  (ct_selectq opname
	      (unary_not 'ct_ada_not)	  ; not operator.
	      (unary_minus 'minus)	  ; negation.
	      (unary_plus 'plus)	  ; unary addition
	      (ampersand #'ct_ada_string_concat)
	      (star 'times)		  ; multiply operator.
	      (plus 'plus)		  ; addition operator.
	      (minus 'difference)
	      (slash 'quotient)		  ; division.
	      (and   'ct_ada_and)	  ;logical AND.
	      (or    'ct_ada_or)	  ;logical OR.
	      (equals 'ct_ada_equal)
	      (lt 'ct_ada_lessp)
	      (gt 'ct_ada_greaterp)
	      (ge 'ct_ada_ge)
	      (le 'ct_ada_le)
	      (notequals #'(lambda(n m)(ct_ada_not (ct_ada_equal n m))))
	      (mod #'(lambda(n m)
		       (let ((rem (remainder n m)))
			 (cond
			   ((or (and (minusp n)(not (minusp m)))
				(and (minusp m)(not (minusp n))))
			    (difference m rem))
			   (t rem)))))
	      (abs 'abs)
	      (starstar #'(lambda(m n)
			    (do ((ct n (1- ct))
				 (pr 1 (* pr m)))
				((zerop ct) pr))))
	      (rem 'remainder)
	      (t (lose 'be_bionyi 'mapop
		       `("Built in function ~A not yet implemented" opname)
		       ()))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions on Ada string objects.
       ;;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_equal(str1 str2)
       ;;;;;;;;;;;;;;;;;;;

  (cond ((equal str1 str2) *ct_ada_true*)))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_notequal(str1 str2)
       ;;;;;;;;;;;;;;;;;;;;;;

  (cond ((equal str1 str2) *ct_ada_false*)))

       ;;;;;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_greaterp(str1 str2)
       ;;;;;;;;;;;;;;;;;;;;;;

  (cond
    ((> (first str1)(first str2)) *ct_ada_true*)
    ((< (first str1)(first str2)) *ct_ada_false*)
    ((and (cdr str1)(cdr str2)) (ct_ada_string_greaterp (cdr str1)(cdr str2)))
    ((cdr str1) *ct_ada_true*)
    ((cdr str2) *ct_ada_false*)
    (t (lose 'bif_strgr 'ct_ada_string_greaterp () "holly shit"))))

       ;;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_lessp(str1 str2)
       ;;;;;;;;;;;;;;;;;;;

  (cond
    ((< (first str1)(first str2)) *ct_ada_true*)
    ((> (first str1)(first str2)) *ct_ada_false*)
    ((and (cdr str1)(cdr str2)) (ct_ada_string_lessp (cdr str1)(cdr str2)))
    ((cdr str1) *ct_ada_false*)
    ((cdr str2) *ct_ada_true*)
    (t (lose 'bif_strls 'ct_ada_string_lessp () "holly shit"))))

       ;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_ge_p(str1 str2)
       ;;;;;;;;;;;;;;;;;;

  (cond

    ((equal str1 str2) *ct_ada_true*)
    ((> (first str1)(first str2)) *ct_ada_true*)
    ((< (first str1)(first str2)) *ct_ada_false*)
    ((and (cdr str1)(cdr str2)) (ct_ada_string_greaterp (cdr str1)(cdr str2)))
    ((cdr str1) *ct_ada_true*)
    ((cdr str2) *ct_ada_false*)
    (t (lose 'bif_strgr 'ct_ada_string_greaterp () "holly shit"))))

       ;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_le_p(str1 str2)
       ;;;;;;;;;;;;;;;;;;

  (cond
    ((equal str1 str2) *ct_ada_true*)
    ((< (first str1)(first str2)) *ct_ada_true*)
    ((> (first str1)(first str2)) *ct_ada_false*)
    ((and (cdr str1)(cdr str2)) (ct_ada_string_lessp (cdr str1)(cdr str2)))
    ((cdr str1) *ct_ada_false*)
    ((cdr str2) *ct_ada_true*)
    (t (lose 'bif_strls 'ct_ada_string_lessp () "holly shit"))))

       ;;;;;;;;;;;;;;;;;;;;
(defun ct_ada_string_concat(str1 str2)
       ;;;;;;;;;;;;;;;;;;;;

  (cond
    ((and (ada_string_or_char str1) (ada_string_or_char str2))
     `(lex_string ,(append (second str1)(second str2))))
    (t (lose 'be_naas 'ct_ada_string_concat
	     ()
	     '("Not an Ada string")))))

       ;;;;;;;;;;;;;;;;;;
(defun ada_string_or_char(s)
       ;;;;;;;;;;;;;;;;;;

  (memq (car s) '(lex_string lex_char)))

       ;;;;;;;;;;
(defun ct_ada_and(tv1 tv2)
       ;;;;;;;;;;

  (cond
    ((and (eq tv1 *ct_ada_true*)(eq tv2 *ct_ada_true*)) *ct_ada_true*)
    (t *ct_ada_false*)))

       ;;;;;;;;;
(defun ct_ada_or(tv1 tv2)
       ;;;;;;;;;

  (cond
    ((or  (eq tv1 *ct_ada_true*)(eq tv2 *ct_ada_true*)) *ct_ada_true*)
    (t *ct_ada_false*)))

       ;;;;;;;;;;
(defun ct_ada_not(atv)
       ;;;;;;;;;;

  (cond
    ((eq atv *ct_ada_true*) *ct_ada_false*)
    ((eq atv *ct_ada_false*) *ct_ada_true*)
    (t (lose 'be_naatv 'ct_ada_not
	     ()
	     '("Not an Ada truth value")))))

#|
       ;;;;;;;;;;;;
(defun ct_ada_equal(avn avm)
       ;;;;;;;;;;;;

  (cond
    ((ada_string_or_char avn)
     (ct_ada_string_equal avn avm))
    (t
     (cond
       ((equal avn avm) *ct_ada_true*)
       (t              *ct_ada_false*)))))
|#

       ;;;;;;;;;;;;
(defun ct_ada_equal(avn avm)
       ;;;;;;;;;;;;

  (cond
    ((equal avn avm) *ct_ada_true*)
    (t              *ct_ada_false*)))

       ;;;;;;;;;;;;
(defun ct_ada_lessp(avn avm)
       ;;;;;;;;;;;;

  (cond
    ((lessp avn avm) *ct_ada_true*)
    (t              *ct_ada_false*)))

       ;;;;;;;;;;;;;;;
(defun ct_ada_greaterp(avn avm)
       ;;;;;;;;;;;;;;;

  (cond
    ((greaterp avn avm) *ct_ada_true*)
    (t              *ct_ada_false*)))

       ;;;;;;;;;
(defun ct_ada_le(avn avm)
       ;;;;;;;;;

  (cond
    ((greaterp avn avm) *ct_ada_false*)
    (t                   *ct_ada_true*)))

       ;;;;;;;;;
(defun ct_ada_ge(avn avm)
       ;;;;;;;;;

  (cond
    ((lessp avn avm) *ct_ada_false*)
    (t                *ct_ada_true*)))


       ;;;;;;;;;;;;;;
(defun object_builder(id)
       ;;;;;;;;;;;;;;

  (let ((nuobj `(,id . ,(ct_make_instance (type_builder #$~basetype)
				       'ada_name nil
				       'ada_index nil)))
	(setter    (setr_builder #$~basetype)))
    (cond ((eq (type_builder #$~basetype) 'dt_fixed_point_type)
	   (cond ((null (second #$~indexlist)); delta not specified for subtype
		  (%= #$~indexlist
		      (list (first *_*)
			    (extract_delta_from_fixed_pt_subtype id))))))
	  ((eq (type_builder #$~basetype) 'dt_floating_type)
	   ;(break look-at-indexlist)
	   (cond ((null (second #$~indexlist));range or digits not specified
		  (cond ((null (consp (first #$~indexlist)));range not there
			 ;(break look-at-indexlist)
			 (%= #$~indexlist
			     (list (list *float_first* *float_last*)
				   (first *_*)))))))))
	  
    (ct_send
      (cdr nuobj)
      'initialize 
      `(,(cond
	   ((not (diana_node_accepts_attributep pc 'as_type_spec))
	    (diana_get pc 'as_constrained))
	   ((eq (diana_nodetype_get (extract_basetype #$%as_type_spec)) 'dn_array)
	    #$%as_type_spec)
	   (t
	    (let ((asnam
		(diana_get #$%as_type_spec 'as_name)))
	      (cond ((diana_node_accepts_attributep asnam 'sm_defn)
		     (diana_get asnam 'sm_defn))
		    ((diana_node_accepts_attributep asnam 'as_designator_char)
		     (diana_get asnam 'as_designator_char))))))
	,#$~indexlist			          ;the path
	,setter				  	;the initialization fn.
	,id))				  ;the id itself.
    (ct_send (cdr nuobj)
		 'set-ada_name
		 (and id (intern (implode (cadr (diana_get id 'lx_symrep)))
				 'user)))
    (cond
      (#$~initval				  ; was there an init?
       (ct_send
	 (cdr nuobj)
	 'set_val nil (car #$~initval))))	  ;generalize++
    nuobj)
  )

	;;;;;;;;;;;;
;(defun path_builder(ts)		; return an index list.
	;;;;;;;;;;;;

;  '((1 10)));++

       ;;;;;;;;;;;;
(defun setr_builder(ts)		; return an initializing function.
       ;;;;;;;;;;;;

  (ct_selectq ts
	      (|integer| #'unassignedf)
	      (|access| #'unassignedf)
	      (|task| #'unassignedf)
	      (|float| #'unassignedf)
	      (|fixed| #'unassignedf)
	      (|**any_type**| #'unassignedf)
	      (|**any_fixed**| #'unassignedf)
	      (|**any_integer**| #'unassignedf)
	      (|**any_float**| #'unassignedf)
	      (|**any_real**| #'unassignedf)
	      (|enumeration| #'unassignedf)
	      (|array| #'intobjmake)	
	      (|record| #'recobjmake)
	      (fixed  #'unassignedf)
	      (record   #'recobjmake) 
	      (array   #'intobjmake)
	      (integer #'unassignedf)
	      (access #'unassignedf)
	      (task #'unassignedf)
	      (float #'unassignedf)
	      (enumeration #'unassignedf)
	      (otherwise (lose 'be_ttnyi 'setr_builder
			       ()
			       '("this type not yet implemented ~A" ts)))))

       ;;;;;;;;;;
(defun recobjmake(i)
       ;;;;;;;;;;

;    (break in-recobjmake)
    (ct_send (ct_send #$~compobj 'copyself) 'current_value))
       ;;;;;;;;;;
(defun intobjmake(i)
       ;;;;;;;;;;

;    (break in-intobjmake)
    (ct_send #$~proto 'copyself))

       ;;;;;;;;;;;
(defun unassignedf(i)
       ;;;;;;;;;;;

  '*unassigned*)

       ;;;;;;;;;;;;
(defun intbuildtemp(i)
       ;;;;;;;;;;;;

  (let ((intobj (ct_make_instance 'dt_integer_type
			       'ada_name nil
			       'ada_index nil)))
    (ct_send intobj 'initialize '(nil nil #'unassignedf nil))
    intobj))

       ;;;;;;;;;;;;
(defun type_builder(ts)		; return a builder for the typespec.
       ;;;;;;;;;;;;

  (ct_selectq ts
	      (integer 'dt_integer_type)
	      (|integer| 'dt_integer_type);simple hack to overcome case problems on
	      (enumeration 'dt_enumeration_type)  ;the LM, preobably can delete all non
	      (|enumeration| 'dt_enumeration_type);quoted lines (to be done)++
	      (string 'dt_string_type)
	      (|string| 'dt_string_type)
	      (float 'dt_floating_type)
	      (|float| 'dt_floating_type)
	      (fixed 'dt_fixed_point_type)
	      (|fixed| 'dt_fixed_point_type)
	      (|**any_real**| 'dt_floating_type)
	      (|**any_fixed**| 'dt_fixed_point_type)
	      (|**any_type**| 'dt_integer_type) ;;this is going to cause problems
	      (|**any_integer**| 'dt_integer_type)
	      (|**any_float**| 'dt_floating_type)
	      (access 'dt_access_type)
	      (|access| 'dt_access_type)
	      (task 'dt_task_type)
	      (|task| 'dt_task_type)
	      (array 'dt_array_type)
	      (|array| 'dt_array_type)
	      (record 'dt_record_type)
	      (|record| 'dt_record_type)
	      (otherwise (lose 'be_ttnyi 'type_builder
			       ()
			       '("this type not yet implemented")))))

       ;;;;;;
(defun numval(adanumconst)	; xlate lexical number into a lisp number.
       ;;;;;;
  
  (cond
    ((is_la_num adanumconst)
     (let ((res
	     (errset
	       (let ((wholepart (la_num%wholepart adanumconst))
		     (fractpart (la_num%fractpart adanumconst))
		     (base (la_num%base adanumconst))
		     (floatp (la_num%floatp adanumconst))
		     (exponent  (la_num%exp       adanumconst))
		     (fdigs (la_num%fdigs adanumconst)))
		 (cond (floatp
			(times (plus wholepart
				     (convert_fract base fractpart fdigs))
			       (expt (float base) exponent)))
		       (t (times wholepart (expt base exponent)))))
	       nil)))
       (cond (res (car res))
	     (t
	      (cond
		(*infrontend*
		 (la_gripe '("This numeric literal cannot be interpreted.")
		     '((lrmref "LRM" (lrmsec 2 4 nil) (lrmpar 2 nil))))
		 (cond ((la_num%floatp adanumconst) 1.0)
		      (t 1)))
		(t
		 (ct_format *userout*
			    "Lexical error:~%~
			     This numeric literal cannot be interpreted.~%~
			     Reference: LRM Section 2.4, Paragraph 2")
		 (*throw 'cant_continue 'cant_continue)))))))
    (t (lose 'be_nan 'numval
	     ()
	     '("~A is not a number" adanumconst)))))

       ;;;;;;;;;;;;;
(defun convert_fract (base fract fdigs)
       ;;;;;;;;;;;;;
  (let* ((*nopoint t))
    (quotient (float fract) (expt base fdigs))))

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; temporary IO. to be commented out to serve as an example.
;;;
;;;	;;;;;;;;
;;;(defun |lnewline|(ar)
;;;	;;;;;;;;
;;;
;;;  (do ((i 1 (1+ i)))
;;;      ((greaterp i (ct_send
;;;		     (cdr
;;;		       (assoc
;;;			 `(lex_ident ,(uplowlist (exploden 'spacing)))
;;;			 (ct_send ar 'locals)))
;;;		     'get_val nil)))
;;;    (ct_terpri *userout*)))
;;;
;;;	;;;;;;;
;;;(defun |lgetint|(ar)
;;;	;;;;;;;
;;;
;;;    (let ((intadr (cdr
;;;		      (assoc
;;;			  `(lex_ident ,(uplowlist (exploden 'item)))
;;;			  (ct_send ar 'locals)))))
;;;	(ct_send intadr 'set_val nil (read_integer *userin*))))
;;;
;;;#|
;;;       ;;;;;;;;;;;
;;;(defun read_robust(strm)
;;;       ;;;;;;;;;;;
;;;
;;;  (let ((val (errset (ct_read strm) nil)))
;;;    (or val (read_robust strm))))
;;;
;;;       ;;;;;;;;;;;;
;;;(defun read_integer(st)
;;;       ;;;;;;;;;;;;
;;;
;;;    (let ((inp (do ((num 0)
;;;		    (dig (- (ct_tyi st) #/0)(- (ct_tyi st) #/0)))
;;;		   ((or (> dig 9)(< dig 0))
;;;		    (cond
;;;		      ((eq dig (- #\rubout #/0))
;;;		       (ct_format *userout* "~%Please reenter your number: ")
;;;		       (read_integer st))
;;;		      (t num)))
;;;		 (setq num (+ (* num 10.) dig)))))
;;;	(cond 
;;;	    ((numberp inp) inp)
;;;	    (t (ct_format *errout* "Not a number ~A. Try Again:" inp)
;;;		(read_integer st)))))
;;;|#
;;;
;;;#+lispm
;;;       ;;;;;;;;;;;;
;;;(defun read_integer(st)
;;;       ;;;;;;;;;;;;
;;;
;;;  (let ((irt readtable))
;;;    (unwind-protect
;;;      (progn
;;;	(setq readtable (copy-readtable))
;;;	(set-syntax-from-description #/, 'si:whitespace)
;;;	(set-syntax-from-description #/) 'si:whitespace)
;;;	(set-syntax-from-description #/( 'si:whitespace)
;;;	(set-syntax-from-description #/` 'si:whitespace)
;;;	(set-syntax-from-description #/# 'si:whitespace)
;;;; 	(set-syntax-from-description #/_ 'si:slash)
;;;	(let ((inp (ct_read st)))
;;;	  (cond 
;;;	    ((numberp inp) inp)
;;;	    (t (ct_format *errout* "Not a number ~A. Try Again:" inp)
;;;	       (read_integer st)))))
;;;      (setq readtable irt))))
;;;#+franz
;;;       ;;;;;;;;;;;;
;;;(defun read_integer(st)
;;;       ;;;;;;;;;;;;
;;;
;;;  (ct_read st))
;;;
;;;
;;;	;;;;;;;
;;;(defun |lputint|(ar)
;;;	;;;;;;;
;;;
;;;  (let* ((printval (ct_send
;;;		    (cdr
;;;		      (assoc
;;;			`(lex_ident ,(uplowlist (exploden 'item)))
;;;			(ct_send ar 'locals)))
;;;		    'get_val nil))
;;;	 (*nopoint t)
;;;	 (base 10.))
;;;    (cond 
;;;	((and (consp printval) (memq (diana_nodetype_get printval) '(dn_enum_id dn_def_char)))
;;;	    (setq printval (implode (cadr (diana_get printval 'lx_symrep)))))
;;;	((and (consp printval) (eq (car printval) 'lex_string))
;;;	   (setq printval (implode (cadr printval)))))
;;;    (ct_princ printval *userout*)
;;;    (ct_princ " " *userout*)))
;;;
;;;	;;;;;;;;;;;;
;;;(defun |lput_linestr|(ar)
;;;	;;;;;;;;;;;;
;;;
;;;  (let ((printval (ct_send
;;;			  (cdr
;;;			    (assoc
;;;			      `(lex_ident ,(uplowlist (exploden 'item)))
;;;			      (ct_send ar 'locals)))
;;;			  'get_val nil)))
;;;
;;;    (do ((i 1 (1+ i)))
;;;	((> i (second (car (ct_send printval 'index_list)))))
;;;	(ct_tyo  (convert_char_to_integer
;;;		  (ct_send
;;;		      (ct_send printval 'get_val `(,i))
;;;		      'get_val nil)) *userout*))
;;;    (ct_terpri *userout*)))
;;;
;;;	;;;;;;;;;;;;
;;;(defun |lputstr|(ar)
;;;	;;;;;;;;;;;;
;;;
;;;  (let ((printval (ct_send
;;;			  (cdr
;;;			    (assoc
;;;			      `(lex_ident ,(uplowlist (exploden 'item)))
;;;			      (ct_send ar 'locals)))
;;;			  'get_val nil)))
;;;
;;;    (do ((i 1 (1+ i)))
;;;	((> i (second (car (ct_send printval 'index_list)))))
;;;	(ct_tyo  (convert_char_to_integer
;;;		  (ct_send
;;;		      (ct_send printval 'get_val `(,i))
;;;		      'get_val nil)) *userout*))
;;;    ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; code to test the various advising facilities. plus debugging pragmas.

	;;;;;;;;;
(defun |ada_break|(args)
	;;;;;;;;;

  (cond ((eq  (caar args) 'lex_string)(eval `(break ,(implode (cadar args)))))))

	;;;;;;;;;
(defun |ada_error|(args)
	;;;;;;;;;

  (cond ((eq  (caar args) 'lex_string)(eval `(ferror ,(implode (cadar args)))))))

	;;;;;;;
(defun |newline|(args)
	;;;;;;;

  (ct_terpri *userout*))

	;;;;;
(defun |write|(args)
	;;;;;

    (do ((items args (cdr items)))
	((null items))
	(cond
	    ((numberp (car items)) (ct_princ (car items) *userout*))
	    ((eq (caar items) 'lex_string)
	     (ct_princ (implode (cadr (car items))) *userout*))
	    ((eq (caar items) 'dn_used_name_id)
		(cond
		    ((eq (diana_nodetype_get (diana_get (car items) 'sm_defn)) 'dn_enum_id)
			(ct_princ
			  (implode (cadr (diana_get (car items) 'lx_symrep)))
			  *userout*))
		    (t (ct_princ
			   (ct_send 
			       (cdr (assoc 
					(diana_get (car items) 'lx_symrep)
					(ct_send *activation* 'locals)))
			       'current_value) *userout*))))
	    (t (lose 'be_batw 'write
		     ()
		     '("bad arg to write ~A" (car items)))))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun massage_annotation_parameters(args)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    (do ((items args (cdr items))
	 (annotation_parameters nil))
	((null items) (reverse annotation_parameters)) 
	(cond
	    ((numberp (car items)) (ct_push (car items) annotation_parameters))
	    ((and (consp (car items))(eq (caar items) 'lex_string))
	     (ct_push (implode (cadr (car items)))annotation_parameters))
	    ((and (diana_nodep (car items))
		  (eq (diana_nodetype_get (car items)) 'dn_used_name_id))
		(cond
		    ((eq
		       (diana_nodetype_get (diana_get (car items) 'sm_defn))
		       'dn_enum_id)
			(ct_push
			  (implode (cadr (diana_get (car items) 'lx_symrep)))
			  annotation_parameters))
		    (t (ct_push
			 (cdr (assoc 
				(diana_get (car items) 'lx_symrep)
				(ct_send *activation* 'locals)))
			 *userout*))))
	    (t (ct_push (car items) annotation_parameters)))))

       ;;;;;;;;;;;;;;;;;;;;
(defun massage_trace_params(args)
       ;;;;;;;;;;;;;;;;;;;;

    (do ((items args (cdr items))
	 (trace_parameters nil))
	((null items) (reverse trace_parameters)) 
	(cond
	    ((numberp (car items)) (ct_push (car items) trace_parameters))
	    ((and (consp  (car items))(eq (caar items) 'lex_string))
	     (ct_push (implode (cadr (car items))) trace_parameters))
	    (t (ct_push '*** trace_parameters)))))

(declare (special *tracedepth* *tracedfunctions* ))

       ;;;;;;;;;;;;;
(defun ada_monitorfn( name oldval newval index)
       ;;;;;;;;;;;;;

  (freshline *userout*)
  
  (let ((*nopoint t))
  (ct_format *userout* "*** Changing the value of ~A~A from ~A to ~A" name
          (cond ((null index) "")(t  index))
          (cond ((listp oldval)
		 (implode (cadr (diana_get oldval 'lx_symrep))))
		(t oldval))
	  (cond ((listp newval)
		 (implode (cadr (diana_get newval 'lx_symrep))))
		(t newval))))
  (freshline *userout*)
)

       ;;;;;;;;;;;
(defun ada_tracefn(name params)
       ;;;;;;;;;;;

  (freshline *userout*)
  (do ((i 0 (1+ i)))((= i *tracedepth*))(ct_princ "|.."))
  (%= *tracedepth* (1+ *tracedepth*))
  (ct_format *userout* "*** Entered ~A ~A" name (massage_trace_params params))
  (freshline *userout*)
)

       ;;;;;;;;;;;;;;;
(defun ada_traceexitfn(name params)
       ;;;;;;;;;;;;;;;

  (freshline *userout*)
  (%= *tracedepth* (1- *tracedepth*))
  (do ((i 0 (1+ i)))((= i *tracedepth*))(ct_princ "|.."))
  (ct_format *userout* "*** Exited  ~A ~A" name (massage_trace_params params))
  (freshline *userout*)
)

       ;;;;;;;;;;;
(defun ada_monitor fexpr (name)
       ;;;;;;;;;;;

       (let* ((nm (car name))
	      (nme (intern (implode (uplowlist (exploden nm)))
			   'user))
	      (frob (variable_advise_rec 'ada_monitorfn (cadr name) 'set)))
	 (putprop
	   nme
	   (cons frob
		 (delete frob (get nm 'ada_variable_advise)))
	   'ada_variable_advise)
	 
	 (ct_push nme *tracedfunctions*)
	     name))

       ;;;;;;;;;
(defun ada_trace fexpr (name)
       ;;;;;;;;;

       (mapc
	 #'(lambda(nm)
	     (let ((nme (intern (implode (uplowlist (exploden nm)))
				'user)))
 	       (putprop
		 nme
		 (cons 'ada_tracefn (delq 'ada_tracefn (get nm 'ada_advise)))
		 'ada_advise)
	       (putprop
		 nme
		 (cons 'ada_traceexitfn
		       (delq 'ada_traceexitfn (get nm 'ada_after_advise)))
		 'ada_after_advise)
	       (ct_push nme *tracedfunctions*)))
	     name))

       ;;;;;;;;;;;
(defun ada_unmonitor fexpr (name)
       ;;;;;;;;;;;

       (mapc
	 #'(lambda(nm)
	     (let ((nme (intern (implode (uplowlist (exploden nm)))
				'user))
		   (frob (variable_advise_rec 'ada_monitorfn nil 'set))) 
	       (setq *tracedfunctions* (delq nme *tracedfunctions*))
	       (putprop
		 nme
		 (delete frob (get nm 'ada_variable_advise))
		 'ada_variable_advise)
	       
	       ))
	 (or name *tracedfunctions*)))


       ;;;;;;;;;;;
(defun ada_untrace fexpr (name)
       ;;;;;;;;;;;

       (mapc
	 #'(lambda(nm)
	     (let ((nme (intern (implode (uplowlist (exploden nm)))
				'user))) 
	       (setq *tracedfunctions* (delq nme *tracedfunctions*))
	       (putprop
		 nme
		 (delq 'ada_tracefn (get nm 'ada_advise))
		 'ada_advise)
	       (putprop
		 nme
		 (delq 'ada_traceexitfn (get nm 'ada_after_advise))
		 'ada_after_advise)
	       ))
	 (or name *tracedfunctions*)))

       ;;;;;;;;;;;;;;;;;;;
(defun ada_exception_trace fexpr (name)
       ;;;;;;;;;;;;;;;;;;;

       (mapc
	 #'(lambda(nm)
	     (let ((nme (intern (implode (uplowlist (exploden nm)))
				'user)))
 	       (putprop
		 nme
		 (cons 'ada_excfn (delq 'ada_excfn (get nm 'ada_exception_advise)))
		 'ada_exception_advise)
	       (putprop
		 nme
		 (cons 'ada_excexitfn
		       (delq 'ada_excexitfn (get nm 'ada_exception_after_advise)))
		 'ada_exception_after_advise)
	       (ct_push nme *tracedfunctions*)))
	     name))

       ;;;;;;;;;;;;;;;;;;;;;
(defun ada_exception_untrace fexpr (name)
       ;;;;;;;;;;;;;;;;;;;;;

       (mapc
	 #'(lambda(nm)
	     (let ((nme (intern (implode (uplowlist (exploden nm)))
				'user))) 
	       (setq *tracedfunctions* (delq nme *tracedfunctions*))
	       (putprop
		 nme
		 (delq 'ada_excfn (get nm 'ada_exception_advise))
		 'ada_exception_advise)
	       (putprop
		 nme
		 (delq 'ada_excexitfn (get nm 'ada_exception_after_advise))
		 'ada_exception_after_advise)
	       ))
	 (or name *tracedfunctions*)))

       ;;;;;;;;;
(defun ada_excfn(name exc)
       ;;;;;;;;;

  (freshline *userout*)
  (ct_format *userout* "*** Subprogram ~A handling exception ~A"
	     name exc)
  (freshline *userout*)
)

       ;;;;;;;;;;;;;
(defun ada_excexitfn(name exc)
       ;;;;;;;;;;;;;

  (freshline *userout*)
  (ct_format *userout* "*** Subprogram ~A exited handler for exception ~A"
	     name exc)
  (freshline *userout*)
)

;;; eof
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;