;;; -*- mode:lisp;package:user;base:10.;fonts:(cptfontb) -*- 
;;; $Header: /ct/interp/dsmacs.l,v 1.82 85/01/24 18:10:40 penny Exp $

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                             DS_MACS                              ;;;
;;; Mark L. Miller and Paul Robertson               February 8, 1983 ;;;
;;;                                                                  ;;;
;;; This file defines a set of macros for defining the dynamic       ;;;
;;; semantics functions for each type of Diana node -- these nodes   ;;;
;;; should always be defined using the macros provided below.        ;;;
;;;                                                                  ;;;
;;; 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 'aip))	  ;AIP macros pkg. 

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

(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 'ctadadt)) ;get datatype definitions.

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

(eval-when (compile load eval) (ct_load 'charmac))  ; get #$% and #$~.

(eval-when (compile load eval) (ct_load 'ferec))  ;  get nodestage code.

(eval-when (compile load eval) (ct_load 'sema))    ; get sc_diana macro  

(eval-when (compile load eval) (ct_load 'cache))   ; the ds caching system.

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

(declare (ct_includef 'intrpdcl))		   ;  declarations.


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

;Temp kludge till we supply ct_compatibility versions of implode,
;exploden, etc.
#+lispm (declare (setq obsolete-function-warning-switch nil))	  ;+++

#+franz (declare (macros t))
							;Ports/Streams:
(declare (special *listing*				;  Interpreter out
	          *errin*				;  Error query in
		  *errout*				;  Error msg out
		  *userin*				;  Ada Prog in
		  *userout*				;  Ada Prog out
		  pc
		  stage
		  replay
		  *continuation*			;See DRIVER
		  *activation*))			;See DRIVER
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Call-able Functions/Macros for Defining Diana Nodetypes

;(diana_get_cheaply 'foo 'fred)
(eval-when (compile load eval)
(defun diana_get_cheaply macro (l)  ;(node indicator)
       `(break diana_get_cheaply_will_make_you_lose_very_badly))
;  `(get (cdr ,(cadr l)) ,(caddr l) ))
)


       ;;;;;;;;;;;;;;
(defun def_diana_node macro (l)
       ;;;;;;;;;;;;;;

       (setq l (cdr l))
       `(def_diana ,(car l)
;		   ,(concat 'diana_node_ (car l))
		   ,(car l)
	  ,(cadr l)			  ; Locals list
	  ,(cddr l)			  ; Body
	  diana_node_def))

	       ;;;;;;;;;;;
#+franz (defun fdefinition (x) (getd x))	; kludge for now ++
	       ;;;;;;;;;;;

       ;;;;;;;;;
(defun def_diana macro (l)
       ;;;;;;;;;

       (setq l (cdr l))
       (let ((sym (first l))
	     (funnam (second l))
	     (locals (third l))
	     (body (fourth l))
	     (ind (fifth l)))
	 `(progn 'compile
		 (defun ,funnam (pc stage)
#+lispm		   (cond (*debugdriver*
			  (freshline *listing*)
			  (ct_princ '(Visiting ,sym) *listing*)
			  (ct_princ stage *listing*)
			  (freshline *listing*)))
		   (prog (replay)
;			 (setq replay nil)
		      rerun
			 (ct_selectq stage  ,@(build_sem_body locals body))
			 (cond (replay
				(setq replay nil)
				(setq stage (1+ stage))
				(setnodestage stage)
				(go rerun)))))
#|		 (putprop ',sym 
		          (fdefinition ',funnam)	  ;not in franz++
			  ',ind)
|#
		 )))

;;; Put the locals onto the locals alist associated with this node and
;;; activation record. Note that the alist maps local names onto
;;; a list whose car is the value. This is essential so that 
;;; nonlocal variables return nil to assoc and trigger a search of the
;;; ds environment.
       ;;;;;;;;;;;;;;
(defun with_ds_locals  (pc locals) 	; setup ds locals
       ;;;;;;;;;;;;;;

  (let ((ds_ns (assoc (diana_get pc 'ct_id) 
		      *nodestages*)))
    (cond 
      ((null ds_ns)			  ; no node stage created yet.
       (setq *nodestages*
	     (cons (nodestage pc 1. 
			      (mapcar 
				(function 
				  (lambda(ln)
				    (list ln nil)))
					  ;(recycle_cached_var ln pc)))
				locals))
		   *nodestages*))
       (set-iv adabe_activation *activation* 'nodestages *nodestages*))

      (t
       (%= (nodestagerec%alist ds_ns)	  ; initialize all ds_locals to nil
	   (append (mapcar
		     (function
		       (lambda(ln)
			 (list ln nil)))
			 ;(recycle_cached_var ln pc)))
		     locals)
		   *_*))))))
	
;;; Translates a dynamic semantic function into a selectq, breaking it
;;; up into stages as it proceeds. Supports certain primitive control cues
;;; presently ds_follow and ds_exit.
       ;;;;;;;;;;;;;;
(defun build_sem_body(locals steps)
       ;;;;;;;;;;;;;;

  (let ((dslabels nil))
    (cond 
      ((and (null steps)(null locals))(%= steps '((ds_exit))))	  ; void case
      (locals
       (ct_push `(with_ds_locals pc ',locals) steps)))
    (do ((stages nil)			  ; accumulate stages here.
	 (curstage 1)			  ; first stage is 1.
	 (thisstage nil)		  ; build a stage here.
	 (nextstep steps (cdr nextstep))  ; consider forms one at a time.
	 )
	((null nextstep)		  ; no more steps left in defn.
	 (cond
	   (thisstage			  ; dont lose any steps!
	    (ct_push `(,curstage . ,(reverse thisstage)) stages)
	    (%= curstage (1+ *_*))))
	 (reverse stages)		  ; the body of the selectq in nice order.
	 )
      (cond				  ; check for end of stage.
	((eq (caar nextstep) 'ds_follow)
	 (ct_push `(ds_follow ,(cadar nextstep)) thisstage)
	 (ct_push `(,curstage . ,(reverse thisstage)) stages)
	 (%= curstage (1+ *_*))
	 (%= thisstage nil))		  ; start a new stage.
	((eq (caar nextstep) 'ds_call_diana)
	 (ct_push `(ds_call_diana ,(cadar nextstep)) thisstage)
	 (ct_push `(,curstage . ,(reverse thisstage)) stages)
	 (%= curstage (1+ *_*))
	 (%= thisstage nil))		  ; start a new stage.
	((memq (caar nextstep) '(ds_exit ds_break))
	 (ct_push `(,curstage . ,(reverse thisstage)) stages)
	 (%= curstage (1+ *_*))
	 (%= thisstage nil))		  ; start a new stage.
	((memq (caar nextstep) '(ds_if ds_goto ds_label))
	 (ct_push (car nextstep) thisstage)
	 (ct_push `(,curstage . ,(reverse thisstage)) stages)
	 (%= curstage (1+ *_*))
	 (%= thisstage nil))
	(t  (ct_push (car nextstep) thisstage))))))
 
#|
       ;;;;;
(defun ds_if fexpr(l)
       ;;;;;

       (let ((condition (first l))
	     (iftrue    (second l))
	     (iffalse   (third l)))
	 (setq replay t)		  ; onto next stage if I dont override.
	 (cond ((eval condition) (eval iftrue))
	       (iffalse (eval iffalse)))))
|#

       ;;;;;
(defun ds_if macro(l)
       ;;;;;

       `(progn (setq replay t)		  ; onto next stage if I don't override.
	       (cond
		 (,(second l) ,(third l))
		 (t           ,(fourth l)))))

;;; eg. (ds_push 1 #$^fred)   vs (ct_push 1 #$^fred)
;;;     (ds_pop #$~fred)      vs (ct_pop #$~fred)

       ;;;;;;; 
(defun ds_push  macro(l)
       ;;;;;;;
       (selfinsertmacro l
       (let* ((val (second l))
	      (nam (third l))
	      (type (car nam)))
	 (ct_selectq type
		     (ds_get_var
		       `(let ((pair (ds_find_var ,(second nam)  ,(third nam))))
			  (rplaca (cdr pair) (cons ,val (cadr pair)))))
		     (ds_get_moms_var
		       `(let* ((*dynamic_locals_alist* nil)
			       (pair (ds_find_var ,(second nam)
						 (dynamic_mother ,(third nam)))))
			  (rplaca (cdr pair) (cons ,val (cadr pair)))))
		     (otherwise (lose 'ds_ima 'ds_push))))))

       ;;;;;;
(defun ds_pop macro (l)
       ;;;;;;
       (let* ((stack (second l))
	      (type (car stack)))
	 (ct_selectq type
		     (ds_get_var
		       `(let* ((pair (ds_find_var ,(second stack) ,(third stack)))
			       (res (cadr pair)))
			  (rplaca (cdr pair)  (cdadr pair))
			  (car res)))
		     (ds_get_moms_var
		       `(let* ((*dynamic_locals_alist* nil)
			       (pair (ds_find_var ,(second stack)
						  (dynamic_mother ,(third stack))))
			       (res (cadr pair)))
			  (rplaca (cdr pair)  (cdadr pair))
			  (car res)))
		     (otherwise (lose 'ds_ima 'ds_pop)))))
	       
#|

       ;;;;;;;
(defun ds_goto(labelst)
       ;;;;;;;

  (%= stage labelst)			  ; set the new stage.
  (setnodestage labelst)		  ; set stage in nodestage.
  (setq replay t))			  ; back to myself!!
|#

       ;;;;;;;
(defun ds_goto macro(l)
       ;;;;;;;

       (selfinsertmacro l
			(let ((labelst (second l)))
			  `(progn
			     (%= stage ,labelst)  ; set the new stage.
			     (setnodestage ,labelst)	  ; set stage in nodestage.
			     (setq replay t)))))

       ;;;;;;;;;;;;
(defun setnodestage(n)
       ;;;;;;;;;;;;

  (let ((ns *nodestages*))
    (let ((thisnode (assq (diana_get pc 'ct_id) ns)))
      (cond
	((null thisnode)
	 (lose 'be_cfnfp 'setnodestage
	       ()
	       '("couldn't find nodestages for pc")))
	(t (rplaca (cdr thisnode) n))))))

#|
       ;;;;;;;;
(defun ds_label fexpr(l)
       ;;;;;;;;

       (let ((var (first l)))
	 (setq replay t)		  ; onto next stage immediately.
	 (eval `(%= ,var stage))))	  ; record current stage.
|#

;;; raise the requested exception, we need to do something with the
;;; description dsc.
       ;;;;;;;;;
(defun ada_raise(exc dsc)
       ;;;;;;;;;

  (ct_push dsc *exception_reason*)
  (ct_push exc *exception_name*)
  (ds_raise_aux exc))

;when called directly
       ;;;;;;;;
(defun ds_raise (exc)
       ;;;;;;;;
    (ada_raise exc "implicit raise")
)
;;; cause an exception of type 'exc' to be raised.
       ;;;;;;;;
(defun ds_raise_aux(exc)
       ;;;;;;;;
 (cond ((not *infrontend*)
  ;;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 ((advice_fcns (get exc 'ada_advise)))
    (mapc
      #'(lambda(af)
	  (funcall af exc nil))		  ;call the advice function.
      advice_fcns))
  (let ((handler (find_exception_handler_for
		   exc
		   (cond
		       (*exchandler* 
			(dynamic_mother *exchandler*))
		       (t pc))
		   *activation*)))
    (let((handler_process (find_nodes_process_activation (first handler)))
	 (excnod (sc_diana dn_ct_exception_handler
			   as_stm_s (diana_get (second handler) 'as_stm_s)
			   ct_threadp (list pc)  ;preserve dynamic environment.
			   ct_raising exc ;name of the exception.
			   ct_id (gensym) ;so that nodestages work.
			   ct_resume (first handler))))
      (cond
	((eq *activation* handler_process)
	 (%= *nuactivation* nil)	  ;inhibit a process switch.
	 (%= *continuation* excnod))
	(t (set-iv adabe_activation handler_process 'pc excnod)	  ;goto handler node.
	   (%= *continuation* nil)	  ;inhibit a local branch.
	   (%= *nuactivation* handler_process)	  ;switch to appropriate process.
	   ))))
  (*throw 'implicit_exception 'implicit_exception))
       (t (semwarn ' will_raise_exception exc)
	  (throw '*diana_node_not_static_expression*
		 '*diana_node_not_static_expression*)
	  nil)))

       ;;;;;;;;
(defun ds_label macro(l)
       ;;;;;;;;

       `(progn (setq replay t)		  ; onto next stage if I don't override.
	       (%= ,(second l) stage)))


#|
       ;;;;;;;;;;
(defun ds_get_var(n pc)
       ;;;;;;;;;;

  (let ((dsv
	  (or
	    (assoc n *dynamic_locals_alist*)	  ;a local
;	    (assoc n *dynamic_mother_locals_alist*)	;a local of my mother.
	    )))
    (cond
      (dsv (cadr dsv))
      (t (ds_get_var_aux n pc)))
    ))

       ;;;;;;;;;;;;;;;
(defun ds_get_moms_var(n pc)
       ;;;;;;;;;;;;;;;

  (let ((mom
	  (or
	    (nodestagerec%caller (assoc (diana_get pc 'ct_id)
					*nodestages*))
	    (car #$%ct_threadp))))
    (ds_get_var_aux n mom)))

|#

       ;;;;;;;;;;;;;;
(defun ds_get_var_aux(n pc)		; The the value associated with the ds
       ;;;;;;;;;;;;;;

					  ; variable named n and node pc.
  (let* ((*activation* (find_nodes_process_activation pc))
	 (*nodestages* (get-iv adabe_activation *activation* 'nodestages))
	 (ns (assoc (diana_get pc 'ct_id) *nodestages*))
	 (value (assoc n (nodestagerec%alist ns))))
	;; value if any associated with n
	(cond
	  (value			  ; if it is bound in this environment..
	   (second value))		  ; return the value part of it.
	  (t 
	   (let ((mom
		   (or
		     (nodestagerec%caller ns)	  ; called tree?
		     (car (diana_get pc 'ct_threadp))))); get mother node.
	     (cond
	       ((null mom)
		(lose 'be_udsv 'ds_get_var_aux
		      ()
		      '("Unbound DS variable ~A" n)))
	       (t (ds_get_var_aux n mom)))))))) ; search env for n.


  
       ;;;;;;;;;;;;;;;;;;;
(defun ds_get_var_pair_aux (n pc)	; The the value associated with the ds
       ;;;;;;;;;;;;;;;;;;;

  					  ; variable named n and node pc.
  (let* ((*activation* (find_nodes_process_activation pc))
	(*nodestages* (get-iv adabe_activation *activation* 'nodestages))
	(ns (assoc (diana_get pc 'ct_id) *nodestages*))
	(value (assoc n (nodestagerec%alist ns))))
	;; value if any associated with n
	(cond
	  (value			  ; if it is bound in this environment..
	   value)
	  (t 
	   (let ((mom
		   (or
		     (nodestagerec%caller ns)	  ; called tree?
		     (car (diana_get pc 'ct_threadp))))); get mother node.
	     (cond
	       ((null mom)
		(lose 'be_udsv 'ds_get_var_aux
		      ()
		      '("Unbound DS variable ~A" n)))
	       (t
#|		(cond
		  ((eq (diana_nodetype_get mom) 'dn_labeled)
		   (setq pc mom)
		   (setq mom
			 (or
			   (nodestagerec%caller ns)	  ; called tree?
			   (car (diana_get pc 'ct_threadp))))))|#
		(ds_get_var_pair_aux n mom)))))))) ; search env for n.


#|
       ;;;;;;;;;;
(defun ds_set_var(n pc v)
       ;;;;;;;;;;

  (let ((dsv
	  (or
	    (assoc n *dynamic_locals_alist*)	  ;a local

	    ;;  (assoc n *dynamic_mother_locals_alist*)
	    )))				  ;a local of my mother.
    (cond
      (dsv (%= (cadr dsv) v))
      (t (ds_set_var_aux n pc v)))))

       ;;;;;;;;;;;;;;;
(defun ds_set_moms_var(n pc v)
       ;;;;;;;;;;;;;;;

  (let ((mom
	  (or
	    (nodestagerec%caller (assoc (diana_get pc 'ct_id)
					*nodestages*))
	    (car #$%ct_threadp))))
    (ds_set_var_aux n mom v)))


|#       ;;;;;;;;;;;;;;
(defun ds_set_var_aux(n pc v)	; set version of above.
       ;;;;;;;;;;;;;;

  (let* ((*activation* (find_nodes_process_activation pc))
	 (*nodestages* (get-iv adabe_activation *activation* 'nodestages))
	 (ns (assoc (diana_get pc 'ct_id) *nodestages*))
	 (value (assoc n (nodestagerec%alist ns))))
	;; value if any associated with n
	(cond
	  (value			  ; if it is bound in this environment..
	   (%= (cadr value) v))		  ; set the value part of it.
	  (t 
	   (let ((mom
		   (or
		     (nodestagerec%caller ns)	  ; called tree?
		     (car (diana_get pc 'ct_threadp))))); get mother node.
	     (cond
	       ((null mom)
		(lose 'be_udsv 'ds_set_var_aux
		      ()
		      '("Undeclared DS variable ~A" n)))
	       (t (ds_set_var_aux n mom v))))))))	  ; search env for n.

 (eval-when (compile load eval)    
  (defprop ds_get_var ds_set_var set_program)	  ; make it work for %=
  (defprop ds_get_moms_var ds_set_moms_var set_program))

;;;follow passes control onto the specified node. If the specified node
;;;turns out to be nil, stage is incremented and the process is repeated
;;;on the same node. This is helpful for embedding follows as well as
;;;reducing the number of dn_void nodes in the diana tree.
       ;;;;;;;;;
(defun ds_follow macro (l)
       ;;;;;;;;;

       (selfinsertmacro l
			(let ((x (second l)))
			  
			  `(cond ((null ,x)
				  (setq replay nil)
				  (setq *continuation* 'as_you_were))
				 (t (setq replay nil)(setq *continuation* ,x))))))

;;;Update the variable named name with the value value.++
;	(defun ds_update(name path value)
;	    (let ((varnam (diana_get name 'lx_symrep))
;		  (varpnl (diana_get name 'ct_pnl))
;		  (defpnl (diana_get (diana_get name 'sm_defn) 'ct_pnl)))
;		(let ((lvslot
;                  (assoc varnam
;			 (get-iv adabe_activation *activation* 'locals))))
;		    (and lvslot (ct_send (cdr lvslot) 'set_val path value)))))
	
;;; new winning version that uses jrm's activation record support.
       ;;;;;;;;;
(defun ds_update(name path value)
       ;;;;;;;;;

  (let ((lvslot (look_up_ident name)))
    (or (and lvslot (prog1 t (ct_send (cdr lvslot) 'set_val path value)))
	(lose 'be_ffv 'ds_update
	      ()
	      '("failed to find variable")))))

       ;;;;;;;
(defun ds_exit macro(l)
       ;;;;;;;

       (selfinsertmacro l `(setq replay nil)))

       ;;;;;;;;
(defun ds_break macro(l)
       ;;;;;;;;

       (selfinsertmacro l `(setq replay nil)))

       ;;;;;;;;
(defun ds_valof(name)
       ;;;;;;;;

  (let ((lvslot (look_up_ident name)))
    (cond 
      (lvslot  (ct_send (cdr lvslot) 'get_val nil))
      (t (lose 'ffv 'ds_valof
	       ()
	       '("failed to find variable"))))))

       ;;;;;;;
(defun ds_succ(name)
       ;;;;;;;

  (let ((lvslot (look_up_ident name)))
    (or (and lvslot
	     (let ((val (ct_send (cdr lvslot) 'attribute_handler '|succ| nil)))
	       (ct_send (cdr lvslot) 'set_val nil val)
	       val))
	(lose 'be_ffv 'ds_succ
	      ()
	      '("failed to find variable")))))

       ;;;;;;;
(defun ds_pred(name)
       ;;;;;;;

  (let ((lvslot (look_up_ident name)))
    (or (and lvslot
	     (let ((val (ct_send (cdr lvslot) 'attribute_handler '|pred| nil)))
	       (ct_send (cdr lvslot) 'set_val nil val)
	       val))
	(lose 'be_ffv 'ds_pred
	      ()
	      '("failed to find variable")))))


       ;;;;;;;;;;
(defun ds_undeclare(name)	; create a new object in local environment.
       ;;;;;;;;;;
 
    (set-iv adabe_activation  *activation* 'locals
	     (delq
	       (assq name (get-iv adabe_activation  *activation* 'locals))
	       (get-iv adabe_activation  *activation* 'locals))))

       ;;;;;;;;;;
(defun ds_declare(name flav &optional (initializep t))	; create a new object in local environment.
       ;;;;;;;;;;

  (car
    (set-iv adabe_activation  *activation* 'locals
	     (cons
	       (let ((nuobj
		       `(,(diana_get name 'sm_defn) .
			 ,(ct_make_instance flav))))
		 (ct_send (cdr nuobj)
			  'set-ada_name
			  (intern
			    (implode (cadr (diana_get name 'lx_symrep)))
			    'user))
		 (ct_send (cdr nuobj)
			  'set-ada_index
			  nil)
		 (cond (initializep
			(ct_send (cdr nuobj)
			  'initialize
			  (list
			    (extract_basetype (diana_get name 'sm_defn))
			    nil
			    nil
			    (diana_get name 'sm_defn)))
			(ct_send (cdr nuobj) 'set_val nil '*unassigned*)))
		 nuobj)
	       (get-iv adabe_activation  *activation* 'locals)))))

       ;;;;;;;;;;;;;;;;;;;
(defun ds_return_to_caller macro (l)	; switch contexts back to mommy.
       ;;;;;;;;;;;;;;;;;;;

       (selfinsertmacro
	 l
	 `(%= *nuactivation* (get-iv adabe_activation *activation* 'clink))))	  ; mommy's place.

       ;;;;;;;;;;;
(defun ds_resultis macro (l)
       ;;;;;;;;;;;

       (selfinsertmacro l `(ct_push ,(second l) #$^res)))
;    (let ((value (second l)))
;	`(let ((pc (car #$%ct_threadp))	; bind up mommy's environment.
;	       (val ,value))    	 ; value in my environment.
;	     (ct_push val #$~res)))))    ; set DS variable res in mothers env.
;    (ds_set_var 'res #$%threadp value))

       ;;;;;;;;;;;;
(defun ds_resultset macro (l)
       ;;;;;;;;;;;;

       (selfinsertmacro l `(%= #$^res ,(second l))))
;    (let ((value (second l)))
;	`(let ((pc (car #$%ct_threadp))	; bind up mommy's environment.
;	       (val ,value))	     ; value in my environment.
;	     (%= #$~res val)))))    ; set DS variable res in mothers env.

       ;;;;;;;;;;;;
(defun ds_returnres macro(l)
       ;;;;;;;;;;;;

       (selfinsertmacro
	 l
	 `(let* ((val ,(second l))
		 (*activation*
		   (get-iv adabe_activation *activation* 'clink))	  ; parent process.
		(*nodestages*
		  (get-iv adabe_activation *activation* 'nodestages))
		(pc (get-iv  adabe_activation *activation*  'pc))  ; parent node.
		)	  ; value to deliver.
	    (%= #$~funres val))))

;;; actuals is a list of evaluated actual (normalized) parameters.
;;; formals is a list of formal parameters (as_param_s).
;;; returns an alist of formal name and value. (cf ds_declare).
;;; parameter group refers to the fact that parameters are grouped
;;; by parameter type.

       ;;;;;;;;;;;;;;;;
(defun buildparamlocals (actuals formals)
       ;;;;;;;;;;;;;;;;

  (do ((pg formals (cdr pg))		  ; iterate on the parameter groups.
       (parnum 1)
       (locals nil))			  ; collect locals here.
      ((null pg) locals)
    (do ((ps (diana_get (car pg) 'as_id_s) (cdr ps))	  ; iterate on params.
	 (groupbasetype (basetype (diana_get (car pg) 'as_name)))
	 (grouptype (diana_get (car pg) 'as_name))
	 (ptype (diana_nodetype_get (car pg))))  ; one of dn_in, dn_out, dn_in_out.
	((null ps))			  ; no more parameters in this group.
      (cond
	((null actuals)
	 (lose 'be_iap 'buildparamlocals
	       ()
	       '("Insufficient actual parameters"))))
      (let ((nuobj (ct_make_instance	  ; create local variable.
		     (type_builder groupbasetype)
		     'ada_name nil
		     'ada_index nil)))
;	(break buildparamlocals)
	(ct_send nuobj 'initialize
		 (pinitfun groupbasetype grouptype (car ps)
			   (n_th (1- parnum) (reverse #$~pils))))
	(ct_send nuobj
		 'set-ada_name
		 (intern (implode (cadr
				    (diana_get (car ps) 'lx_symrep)))
			 'user))
	(cond ((or (neq ptype 'dn_out)
		   (eq groupbasetype 'array))
	       (ct_send nuobj 'set_val nil (ct_pop actuals)))
	      (t (ct_pop actuals)))	  ; initialize	
	(ct_push			  ; add variable/value pair to locals.
	  `(,(diana_get (car ps) 'sm_defn) . ,nuobj)
	  locals))
      (setq parnum (1+ parnum)))
      ))

(defun find_fixed_bits (suggestion)
  (cond
    (suggestion suggestion)
    (t (do ((parms #$~pils (cdr parms)))
	   ((or (car parms) (null parms))
	    (car parms))))))

       ;;;;;;;;
(defun pinitfun (gbt gt id con)
       ;;;;;;;;
;  (break pinitfun)		
  (ct_selectq gbt
	      (|record| (list gt con #'pinitrec id))
	      (record (list gt con #'pinitrec id))
	      (|array| (list gt nil nil id))
	      (array (list gt nil nil id))
	      (|fixed| (list gt (find_fixed_bits con) nil id))
	      (fixed (list gt (find_fixed_bits con) nil id))
	      (otherwise (list gt con nil id))))

       ;;;;;;;;
(defun pinitrec (i)
       ;;;;;;;;

  nil)
  
;;; function to selectively copy back out (and in out) parameters.
;;; Actuals, is a list of unevaluated actual parameters.
;;; Formals, is the list of formal parameters
;;; ar       is the activation record containing the variables.
       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun copy_back_out_parameters (actuals formals ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;

  (do ((pg formals (cdr pg))		  ; iterate on the parameter groups.
       (written nil))
      ((null pg) written)		  ;nothing to return.
    (do ((ps (diana_get (car pg) 'as_id_s) (cdr ps))	  ; iterate on params.
	 (groupbasetype (basetype (diana_get (car pg) 'as_name)))
	 (ptype (diana_nodetype_get (car pg))))  ; one of dn_in, dn_out, dn_in_out.
	((null ps))			  ; no more parameters in this group.
      (cond
	((null actuals)
	 (lose 'be_iap 'copy_back_out_parameters
	       ()
	       '("Insufficient actual parameters"))))
      (cond
	((eq ptype 'dn_in)
	 (ct_push nil written)
	 (ct_pop actuals))		  ;skip in parameters.
	(t (let ((actual  (ct_pop actuals)))	  ;get actual param.
	     (let (			  ;(obj (look_up_ident actual))
		   ;;find the object.
		   (updated_value 
		     (ct_send
		       (cdr (assq
			      (diana_get (car ps) 'sm_defn)
			      (ct_send ar 'locals)))
		       'get_val nil)))
	       (ct_push updated_value written)
	       (ct_send
		 actual			  ;(cdr obj)
		 'set_val nil updated_value))))))))
       ;;;;;;;;
(defun typemark(ts)
       ;;;;;;;;

  (ct_selectq (diana_nodetype_get ts)
    (dn_used_name_id	  ; if its a type mark.
     (typemark (diana_get ts 'sm_defn)))
    (dn_constrained	  ;if its constrained.
     (typemark (diana_get ts 'as_name)))
    (dn_type_id	ts)	  ;if its a type_id.
    (dn_derived ts)  	  ;if its a derived type
    (dn_subtype_id ts)	  ;if its a type_id.
    (dn_l_private_type_id ts)
    (dn_private_type_id ts)
    (dn_predefined_type nil)
    (t (lose 'be_cft 'typemark
	     ()
	     '("cant find typemark")))
    ))
       ;;;;;;;;;;
(defun find_range(dn)
       ;;;;;;;;;;

  (ct_selectq (diana_nodetype_get dn)
	      (dn_used_name_id (find_range (diana_get dn 'sm_defn)))
	      (dn_array
		(diana_get dn 'as_dscrt_range_s))
	      ((dn_range dn_attribute_call) dn)
	      (dn_integer (find_range (diana_get dn 'as_range)))
	      (dn_derived (find_range (diana_get dn 'as_constrained)))
	      (dn_constrained (find_range (diana_get dn 'as_constraint)))
	      (dn_subtype_id (find_range (diana_get dn 'sm_type_spec)))
	      (dn_type_id (find_range (diana_get dn 'sm_type_spec)))
	      (dn_record nil)
	      (otherwise (lose 'be_cfr 'find_range))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun extract_delta_from_fixed_pt_subtype (dn)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (ct_selectq (diana_nodetype_get dn)
	      (dn_constrained
		(extract_delta_from_fixed_pt_subtype
		  (diana_get dn 'as_name)))
	      (dn_type_id
		(extract_delta_from_fixed_pt_subtype
		  (diana_get dn 'sm_type_spec)))
	      (dn_subtype_id
		(extract_delta_from_fixed_pt_subtype
		  (diana_get dn 'sm_type_spec)))
	      (dn_fixed
		(be_static_eval (diana_get dn 'as_exp)))
	      (dn_used_name_id
		(extract_delta_from_fixed_pt_subtype
		  (diana_get dn 'sm_defn)))
	      (dn_var_id
		(extract_delta_from_fixed_pt_subtype
		  (diana_get dn 'sm_obj_type)))
	      (otherwise (lose 'be_bft 'extract_delta_from_fixed_pt_subtype ))))

;;; basetype should be called basekind. It returns the 'kind' of datatype
;;; ie: array record float fixed etc.
       ;;;;;;;;
(defun basetype(ts)
       ;;;;;;;;
  (cond
    ((eq ts *universal_fixed*)
     'fixed)
    (t
     (ct_selectq (diana_nodetype_get ts)
		 (dn_used_name_id	  ; if its a type mark.
		   (basetype (diana_get ts 'sm_defn)))
		 (dn_array		  ; if its an array type.
		   'array)
		 (dn_access		  ; if its an access type.
		   'access)
		 (dn_slice		  ; if its an array type.
		   'array)
		 (dn_record		  ; if its an record type.
		   'record)
		 (dn_integer
		   'integer)
		 (dn_float
		   'float)
		 (dn_fixed
		   'fixed)
		 (dn_task_spec
		   'task)
		 (dn_predefined_type	  ; if its a predefined type.
		   (intern (implode (cadr (diana_get ts 'lx_symrep)))
			   'user))
		 (dn_enum_literal_s
		   'enumeration)	  ; if its an enumeration type.
		 
		 (dn_constrained	  ;if its constrained.
		   (basetype (diana_get ts 'as_name)))
		 (dn_selected
		   (basetype (diana_get ts 'as_designator_char)))
		 (dn_type_id		  ;if its a type_id.
		   (basetype (diana_get ts 'sm_type_spec)))
		 (dn_derived		  ;if its a derived type
		   (basetype (diana_get ts 'as_constrained)))
		 (dn_subtype_id		  ;if its a type_id.
		   (basetype (diana_get ts 'sm_type_spec)))
		 (dn_l_private_type_id
		   (basetype (diana_get ts 'sm_type_spec)))
		 (dn_private_type_id
		   (basetype (diana_get ts 'sm_type_spec)))
		 (dn_var_id
		   (basetype (diana_get ts 'sm_obj_type)))
		 ((dn_formal_dscrt dn_formal_integer
				   dn_formal_float dn_formal_fixed)
		  nil)
		 (t (lose 'be_cft 'basetype
			  ()
			  '("cant find type")))
		 ))))

#|
  (cond
    ((eq (car ts) 'dn_used_name_id)	  ; if its a type mark.
     (basetype (diana_get ts 'sm_defn)))
    ((eq (car ts) 'dn_array)		  ; if its an array type.
     'array)
    ((eq (car ts) 'dn_slice)		  ; if its an array type.
     'array)
    ((eq (car ts) 'dn_record)		  ; if its an record type.
     'record)
    ((eq (car ts) 'dn_predefined_type)	  ; if its a predefined type.
     (intern (implode (cadr (diana_get ts 'lx_symrep)))
       'user))
    ((eq (car ts) 'dn_enum_literal_s)
     'enumeration)
    
    ((eq (car ts) 'dn_constrained)	  ;if its constrained.
     (basetype (diana_get ts 'as_name)))
    ((eq (car ts) 'dn_type_id)		  ;if its a type_id.
     (basetype (diana_get ts 'sm_type_spec)))
    ((eq (car ts) 'dn_subtype_id)	  ;if its a type_id.
     (basetype (diana_get ts 'sm_type_spec)))
    (t (lose 'be_cft 'basetype
	     ()
	     '("cant find type")))
    )
|#


;;; finds base type from a type spec.
       ;;;;;;;;;;;;
(defun ds_find_type(ts)
       ;;;;;;;;;;;;
  (%= #$~basetype (basetype ts)))
  


       ;;;;;;;;;;;;;;;;;;;;;;
(defun ds_find_base_type_spec(ts)
       ;;;;;;;;;;;;;;;;;;;;;;
  (cond ((null ts) nil)
	(t
	 (ct_selectq
	   (diana_nodetype_get ts)
	   (dn_used_name_id		  ; if its a type mark.
	     (ds_find_base_type_spec (diana_get ts 'sm_defn)))
	   (dn_array ts)		  ; if its an array type.
	   (dn_access ts)		  ; if its an access type.
	   (dn_record (dscrmt_record		  ;a discriminant record.
			nil
			ts
			(ds_find_dscrmt_vars ts)))
	   (dn_integer (ds_find_base_type_spec (diana_get ts 'as_range)))
	   (dn_float ts);(ds_find_base_type_spec (diana_get ts 'as_range_void)))
	   (dn_private nil)
	   (dn_fixed ts)
	   (dn_task_spec nil)
	   (dn_index nil)
	   (dn_range ts)
	   (dn_var_id (ds_find_base_type_spec (diana_get ts 'sm_obj_type)))
	   (dn_predefined_type nil)
	   (dn_enum_literal_s ts)	  ; if its an enumeration type.
	   (dn_constrained		  ;if its constrained.
	     (cond
	       ((or (null (diana_get ts 'as_constraint))
		    (eq (diana_nodetype_get (diana_get ts 'as_constraint))
			'dn_void))
		(ds_find_base_type_spec (diana_get ts 'as_name)))
	       ((eq (diana_nodetype_get (diana_get ts 'as_constraint))
		    'dn_dscrmt_aggregate)
		(dscrmt_record		  ;a discriminant record.
		  (diana_get ts 'as_constraint)
		  (let ((rts (ds_find_base_type_spec (diana_get ts 'as_name))))
		    (cond ((is_dscrmt_record rts)
			   (dscrmt_record%record rts))
			  (t rts)))
		  (ds_find_dscrmt_vars (diana_get ts 'as_name))))
	       (t (diana_get ts 'as_constraint))))
	   (dn_type_id			  ;if its a type_id.
	     (ds_find_base_type_spec (diana_get ts 'sm_type_spec)))
	   (dn_selected
	     (ds_find_base_type_spec (diana_get ts 'as_designator_char)))
	   (dn_slice (diana_get ts 'as_dscrt_range))	  ;if its a slice
	   (dn_derived			  ;if its a derived
	     (ds_find_base_type_spec (diana_get ts 'as_constrained)))
	   (dn_subtype_id		  ;if its a type_id.
	     (ds_find_base_type_spec (diana_get ts 'sm_type_spec)))
	   (dn_l_private_type_id	  ;if its a type_id.
	     (ds_find_base_type_spec (diana_get ts 'sm_type_spec)))
	   (dn_private_type_id		  ;if its a type_id.
	     (ds_find_base_type_spec (diana_get ts 'sm_type_spec)))
	   (t nil)
	   )))
  ) 
       ;;;;;;;;;;;;;;;;;;;
(defun ds_find_dscrmt_vars (ts)
       ;;;;;;;;;;;;;;;;;;;

  (ct_selectq (diana_nodetype_get ts)
	      (dn_used_name_id
		(ds_find_dscrmt_vars (diana_get ts 'sm_defn)))
	      (dn_dscrmt_var_s
		(diana_get ts 'as_list))
	      (dn_record
		(diana_get ts 'sm_discriminants))
	      (dn_private_type_id
		(ds_find_dscrmt_vars (diana_get ts 'sm_type_spec)))
	      (dn_l_private_type_id
		(ds_find_dscrmt_vars (diana_get ts 'sm_type_spec)))
	      (dn_type_id
		(diana_get (car (diana_get ts 'ct_threadp)) 'as_dscrmt_var_s))
	      (otherwise (lose 'be_cfdv 'ds_find_dscrmt_vars))))

;;;calls a diana subtree as a function. A call is essentially a two step
;;;operation. first of all save the return address, and then 'goto' the
;;;destination (diana subtree). The former is achieved by setting up
;;;a nodestage for the destination tree with the 'caller' slot filled in to
;;; the current node (pc). The latter is achieved simply by setting the 
;;; continuation.
       ;;;;;;;;;;;;;
(defun ds_call_diana (dt)
       ;;;;;;;;;;;;;

  (cond
    (dt
     (setq replay nil)
     (let ((nns (nodestagerec (diana_ct_id dt) 1 nil pc)));dest nodestage.
       (setq *nodestages* (cons nns *nodestages*))	  ;add new nodestage.
       (set-iv adabe_activation
	 *activation*
	 'nodestages *nodestages*)
       (setq *diana_subtree_call* (cons dt nns))
       ))))	  ;set continuation.

#+franz (eval-when (compile load eval) (ct_load 'loop))

;;;Activation record functions -- jrm, 2/23/83


       ;;;;;;;;;
(defun env_depth (id_node)
       ;;;;;;;;;
  (let ((defocc (diana_get id_node 'sm_defn)))
    (cond
      ((eq id_node defocc)
       (- (get-iv adabe_activation *activation* 'pnl)
	  (diana_get defocc 'ct_pnl)))
      (t
       (-				  ;(diana_get id_node 'ct_pnl)
	 (get-iv adabe_activation *activation* 'pnl)
	 ;(1+ (ct_send *activation* 'pnl))
	 (or	(diana_get defocc 'ct_pnl) 1))))))

;;;LOOK_UP_IDENT: ***********************************************************
;;;Given a Diana ID_NODE, locate the binding for that node.
;;;This depends upon the addition of Diana attribute CT_PNL, which describes
;;;the procedure nesting level of ID_NODE and of *ACTIVATION* (the currently
;;;executing process).

       ;;;;;;;;;;;;;
(defun look_up_ident (id_node &aux target_record)
       ;;;;;;;;;;;;;

  
  ;;Follow the ALINK from the current activation record; the number of links
  ;;to cross is the difference between the PNL of *ACTIVATION* and of 
  ;;ID_NODE.  ASSQ then finds the appropriate entry for the id_node in 
  ;;the locals of the corresponding activation record.  LOOK_UP_IDENT
  ;;returns the (id . binding) entry from those locals.
  
  (assq (or (diana_get (diana_get id_node 'sm_defn) 'sm_defn);strip one off++
	    (diana_get id_node 'sm_defn))
	 (ct_send (follow_alink_n_times *activation* (env_depth id_node))
		  'locals)))


;;;FOLLOW_ALINK_N_TIMES: ****************************************************
;;;Follow the ALINK path from the current activation record N times,
;;;returning the activation record found at that point.

       ;;;;;;;;;;;;;;;;;;;;
(defun follow_alink_n_times (act_rec n)
       ;;;;;;;;;;;;;;;;;;;;

  
  ;;If N=0, we've reached the desired activation record: return 
  
  (cond ((zerop n) act_rec)
	
	;;Otherwise, follow the activation record's ALINK up to the next 
	;;node and decrement n.
	
	(t (follow_alink_n_times
	     (get-iv adabe_activation act_rec 'alink) (sub1 n)))))
    
    
;;;MAKE_ACTIVATION_RECORD: ***************************************************
;;;Make and return an instance of ADABE_ACTIVATION at procedure nesting level
;;;NEW_RECORD_PNL, with ALINK and CLINK filled in corresponding to the
;;;current value of *ACTIVATION*.

       ;;;;;;;;;;;;;;;;;;;;;;
(defun make_activation_record (current_pnl new_record_pnl)
       ;;;;;;;;;;;;;;;;;;;;;;

  (ct_make_instance
    'adabe_activation
    
    ;;CT_PNL is given in the call.
    
    'pnl (1+ new_record_pnl)
    
    ;;CLINK: The record that is the dynamic superior of the new record is,
    ;;by definition, always *ACTIVATION*.
    
    'clink *activation*
    
    ;;ALINK: The textual superior record is the superior of *ACTIVATION*,
    ;;but we may have to search back a bit to find it.
    
    'alink (let ((current_pnl (get-iv adabe_activation *activation* 'pnl)))
	     
	     ;;CURRENT_PNL had better be greater than NEW_RECORD_PNL;
	     ;;flag an error if this is not true.
	     
	     (cond ((> (1- new_record_pnl) current_pnl)
		    (break current_pnl_less_than_new_record_pnl t))
		   
		   ;;OK: search up from *ACTIVATION* through 
		   ;;(- current_pnl (1- new_record_pnl)) records, and copy
		   ;;that record's ALINK.  Note that zero searches
		   ;;may be done, which is ok.
		   
		   (t (follow_alink_n_times
			*activation*
			(- current_pnl new_record_pnl))
		      )))
    'taskinstance *current_task*	  ;assume same task.
    'arid (gensym)			  ;unique AR identifier
    'enhook nil
    'exhook nil
    'nodestages nil))

 			  
;			  (t (get-iv adabe_activation
;                             (follow_alink_n_times
;				    *activation*
;				    (- current_pnl (1- new_record_pnl)))
;				 'alink))))))

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

;;; None.

       ;;;;;;;;;;
(defun coerce_int(av)
       ;;;;;;;;;;

  (cond
    ((numberp av) av)
    ((and (diana_nodep av)(memq (diana_nodetype_get av) '(dn_enum_id dn_def_char)))
     (diana_get av 'sm_pos))
    (t (lose 'be_coerce_int 'coerce_int
	     ()
	     '("Value not an integer or enumeration literal.")))))

       ;;;;;;;;
(defun ada_succ(v)		; finds the successor of v
       ;;;;;;;;
  (cond 
    ((numberp v)(1+ v))			  ; thats easy!.
    ((and (diana_nodep v)
	  (memq (diana_nodetype_get v) '(dn_def_char dn_enum_id)))
     (let* ((mom (diana_get v 'sm_obj_type))
	    (lit (diana_get mom 'as_list))
	    (rest (memq v lit))
	    (next (cadr rest)))
       (cond
	 ((null next)
	  (ada_raise '|constraint_error| "can't take the successor of the last"))
	 (t next))))
    (t (lose 'be_cfst 'ada_succ
	     ()
	     '("dont know how to find succ of that!!")))))

       ;;;;;;;;
(defun ada_pred(v)		; finds the predecessor of v
       ;;;;;;;;

  (cond 
    ((numberp v)(1- v))			  ; thats easy!.
    ((and (diana_nodep v)
	  (memq (diana_nodetype_get v) '(dn_def_char dn_enum_id)))
     (let ((lst (diana_get (diana_get v 'sm_obj_type) 'as_list)))
       (do ((enl lst (cdr enl)))
	   ((or (null enl)(eq (cadr enl) v))
	    (cond 
	      ((null enl)
	       (ada_raise '|constraint_error|
			  "can't take the predecessor of the first"))
	      (t (car enl)))))))
    (t (lose 'be_cfpt 'ada_pred
	     ()
	     '("dont know how to find pred of that!!")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Functions to support Exceptions - MLM,JM & PR. 5-5-83
    
       ;;;;;;;;;;
(defun next_level (this_node ar)
       ;;;;;;;;;;

  (let ((next_node (dynamic_mother this_node))
	(thistop (get-iv adabe_activation ar 'node)))	  ;top node of this activation record.
    (let ((alternatives
	    (and next_node
		 (eq (diana_nodetype_get next_node) 'dn_block)
		 (diana_get next_node 'as_alternative_s))))
      (cond
	((eq alternatives this_node)(next_level next_node  ar))
	((eq this_node thistop)		  ;have we reached the top of the tree?
	 (let ((parent_ar (get-iv adabe_activation ar 'clink)))	;dynamic following.
	   (cond
	     ((null parent_ar) nil)
	     (t
	      `(,(get-iv adabe_activation parent_ar 'pc) ,parent_ar)))))
	(t `(,next_node ,ar))))))

;;; find exception handler.
;;; Searches from 'pc'. for the dynamically closest diana node that contains  
;;; an exception handler that is either exactly 'raised' or OTHERS.
;;; The diana subtree for this exception handler is returned as a result.
;;; if no matching exception handler is found a runtime error is generated
;;; with 'raised' in the message.
;;; The result is a pair of diana tree's. (block handler)
;;; block is the diana node that has an as_alternatives slot with a matching
;;; handler. This is used to find the parent process.
;;; the handler, is the diana subtree for the handler that control will be
;;; passed to.

       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find_exception_handler_for(raised pc ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;

  (cond
    ((null pc)
;     (ferror "Runtime error: ~A" raised)
     (setq *exception* (exceptionrec  raised))	  ;error type
     ;(break foo)
     (*throw 'runtime_error 'runtime_error))
    (t
     (let ((handlers
	     (let ((exh (and (eq (diana_nodetype_get pc) 'dn_block)
			     (diana_get pc 'as_alternative_s))))
	       (and exh (diana_get exh 'as_list)))))
       (cond
	 ;; exception handlers found for this node, check to see if one
	 ;;of them matches 'raised'
	 (handlers
	  (search_for_matching_handler raised pc handlers ar))
	 ;; exception handler not found at this node.
	 (t (let ((nl (next_level pc ar)))
	      (find_exception_handler_for
		raised
		(first nl)
		(second nl)))))))))

;;; search_for_matching_handler
;;; searches through the handler list to find a handler that matches 'raised'.
;;; it it finds one, the (block handler) pair is returned, otherwise
;;; find_exception_for is recursively  invoked to search the dynamic
;;; environment.

       ;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun search_for_matching_handler(raised pc handlers ar)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (do ((ehs handlers (cdr ehs))
       (found nil))
      ((cond
	 ;; If the ehs have all been checked and none match, we must end the
	 ;; loop and try in the parent node. Note: find_exception_handler
	 ;; cannot return nil.
	 ((null ehs)
	  (setq found
		(let ((nl (next_level pc ar)))
		  (find_exception_handler_for raised (first nl) (second nl))))
	  )
	 ((let ((choices (diana_get (car ehs) 'as_choice_s)))
	    (do ((chs choices (cdr chs)))
		((cond
		   ((null chs))
		   ((or			  ;(break)
		      (eq (diana_nodetype_get (car chs)) 'dn_others)
		      (eq raised
			  (intern
			    (implode (cadr (diana_get
					     (find_selected (car chs))
					     'lx_symrep)))
			    'user)))
		    (setq found `(,pc ,(car ehs) ,ar)))
		   ;; catch for 'others' should go here++
		   )
		 found)))))
       found)))

;;; find_nodes_process
;;; searches the dynamic runtime clink chain and finds the process that owns
;;; the  node. Takes two arguments, an activation record and a node. Returns
;;; an activation record.
       ;;;;;;;;;;;;;;;;;;
(defun find_nodes_process_activation ( node)
       ;;;;;;;;;;;;;;;;;;

     (let ((ns (assoc (diana_get node 'ct_id) *nodestages*)))
       (cond
	 (ns *activation* )		  ;if we found it..return the process.
	 (t (find_nodes_process *activation* node)))))

       ;;;;;;;;;;;;;;;;;;
(defun find_nodes_process (ar node)
       ;;;;;;;;;;;;;;;;;;

  (cond
    ((null ar)(lose 'be_cfpt 'find_nodes_process
		    ()
		    '("cannot find process for this node")))
    (t
     (let ((ns (assoc (diana_get node 'ct_id)
		      (get-iv adabe_activation ar 'nodestages))))
       (cond
	 (ns ar)			  ;if we found it..return the process.
	 (t (find_nodes_process (get-iv adabe_activation ar 'clink) node)))))))

;;; This function takes an alist and rplaces the cars with their
;;; symreps -- This is used to make the alist in the AR readable
;;; by the inspector

       ;;;;;;;;;;;;
(defun inspectorate (alist)
       ;;;;;;;;;;;;

  (mapcar
    #'(lambda (x)
	`(,(concat '|<DN FOR :|
		   (implode (cadr (diana_get (car x) 'lx_symrep)))
		   '|>|)
	  .
	  ,(cdr x)))
    alist))

;;new way to find the main procedure, given a dn_compilation
       ;;;;;;;;;;;;;;;;;
(defun ds_find_main_prog(dn)
       ;;;;;;;;;;;;;;;;;
  (do ((cu (diana_get dn 'as_list) (cdr cu)))
      ((null cu) (ada_raise '|program_error| "main program missing"))
    (ct_selectq (diana_nodetype_get (car cu))
		(dn_comp_unit
		  (let* ((thing (diana_get (car cu) 'as_unit_body))
			 (kind (diana_nodetype_get thing)))
		    (ct_selectq kind
				(dn_subprogram_decl
				  (let ((sp (diana_get thing 'as_designator)))
				    (cond
				      ((and
					 (eq (diana_nodetype_get sp) 'dn_proc_id)
				         (null (diana_get sp 'sm_spec)))
				       (return (car cu)))))))))
		(otherwise (lose 'be_mfd 'ds_find_main_prog)))))

(declare (special *units*))
       ;;;;;;;;;;;;;;;;;;;;;;;;
(defun ds_find_list_of_contexts(cus mp)
       ;;;;;;;;;;;;;;;;;;;;;;;;
  (let* ((ccls
	   (mapcan
	       #'(lambda(cu)
		   (let ((cuc
		     (mapcan
		       #'(lambda(cc)
			   (cond ((eq (diana_nodetype_get cc) 'dn_with)
				  (list (diana_get cc 'as_list)))))
		       (let* ((ctx (diana_get cu 'as_context))
			      (ctxl (and ctx (diana_get ctx 'as_list))))
			 ctxl))))
		     (cond (cuc (list (cons (diana_get cu 'as_unit_body) cuc))))))
	       cus))
	 (root (cdr (assq (diana_get mp 'as_unit_body) ccls))))
    (do ((subtree root (cdr subtree))
	 (*units* nil))
	((null subtree) (nreverse *units*))
      (find_new_units_recursively subtree ccls))))

       ;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun find_new_units_recursively(dns cual)
       ;;;;;;;;;;;;;;;;;;;;;;;;;;

  (do ((group dns (cdr group)))
      ((null group))
    (do ((sg (car group) (cdr sg)))
	((null sg))
      (let ((defo (diana_get (car sg) 'sm_defn)))
	(cond
	  ((not (memq defo *units*))
	   ;(break here)
	   (find_new_units_recursively
	     (cdr (assq (car (diana_get  defo 'ct_threadp)) cual))
	     cual)
	   (ct_push defo *units*)))))))

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