;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/dianades.l,v 1.1 85/06/27 10:10:24 bill Exp $
(putprop 'dianades "$Revision: 1.1 $" 'rcs_revision)
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                          dianades.l                              ;;;
;;;                                                                  ;;;
;;; William Brew                                         8-22-83     ;;;
;;;                                                                  ;;;
;;; Code for the Ada dianades.                                       ;;;
;;;                                                                  ;;;
;;; 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.                                         ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Ensure presence of needed files. 

(comment Assumes ct_load and some suitable file_map 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 'ctstrl))  ;New strings

(eval-when (compile load eval) (ct_load 'dlist))   ;The double linked lists

(eval-when (compile load eval) (ct_load 'ctio))    ;Compatable io


(eval-when (compile load eval) (ct_load 'dbutils)) ; Debugger utilities

(eval-when (compile load eval) (ct_load 'dianatags)) ; Tag flavor

(eval-when (load eval) (ct_load 'point))           ; Diana pointing utils

(eval-when (load eval) (ct_load 'datades))         ; Data desciption
 
#+franz (eval-when (load eval) (ct_load 'screens)) ; Windows, asks
#+lispm (eval-when (load eval) (ct_load 'lmscreens)) ; Windows, asks


(eval-when (compile load eval) (ct_load 'adabe))   ; Activation rec flavor

(eval-when (compile load eval) (ct_load 'ferec))   ; Interpretter records

(eval-when (compile load eval) (ct_load 'dsmacs))  ; Dynamic semantics utilities

(eval-when (compile load eval) (ct_load 'diana))   ; Diana node utiliies

(eval-when (load eval) (ct_load 'dynsem))          ; Dynamic semantics (numval)


(eval-when (load eval) (ct_load 'envirwalk))       ; Environment walker (curr act)

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

#+franz (declare (macros t))
#+franz (setq *flavor-expand-macros* t)

(defvar *db%describable_ids* nil
  "A list of diana id like node types which are describable.")

(defvar *db%describable_statements* nil
  "A list of diana statement like node types which are describable.")

(defvar *db%latest_description* nil
  "A circular dlist of tags for nodes which the dianades has described. The
   list acts as a finite depth stack of the latest descriptions.")

(defconst *db%description_depth* 3
  "The number of descriptions which are remembered.")

(defconst *db%modify_ada_constants* t
  "A flag used to control whether we will allow Ada constants to be modified.")

; Specials used here and delared elsewhere.

(declare (special *db%user_window*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macro definitions --

; Macro to make a diana id node type able to print its lexical representation.

(defmacro db%make_diana_printable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'printself_program))
	   (t (remprop ,node_type 'printself_program))))

; Macro to make a diana id node type able to describe its static semantics.

(defmacro db%make_diana_describable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'describeself_program))
	   (t (remprop ,node_type 'describeself_program))))

; Macro to make a diana id node type able to determine its defining occurrence.

(defmacro db%make_diana_defineable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'defineself_program))
	   (t (remprop ,node_type 'defineself_program))))

; Format a string on the indicated stream. (ala format)

(defmacro db%formstring (stream string)
    `(let ((str ,string))
	 (ct_if ,stream
	     (ct_princ str ,stream)
	     str)))

; Get the node tag from an description stack cell.

(defmacro db%dl_node_tag (dl)
    `(first (dlval ,dl)))

; Get the definition tag from an description stack cell.

(defmacro db%dl_def_tag (dl)
    `(second (dlval ,dl)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Flavor definitions --

; 
; A new tag flavor for the diana describer. Add an instance variable to remember
; the list of nodes that we found.
; 

(ct_defflavor db%describer_tag
    ((node_list nil))                   ; The nodes found
    ()
    (:included-flavors db%vanilla_tag_flavor)
    :gettable-instance-variables
    :settable-instance-variables
    #+lispm :initable-instance-variables)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Externally Callable Functions/Methods -- 

; 
; Initialize the describer
; 

(defun db%init_dianades ()
    (db%init_id_describables)
    (db%init_statement_describables)
    (db%init_misc))

; 
; Startup the describer
; 

(defun db%start_dianades ()
    (db%start_describer_tags))

; 
; A function for describing diana nodes. Used to describe any kind of id
; node. First we find the node we are interested in by finding the node the
; user is pointing at. Then call the node describe function. Finally put the
; node in the described node stack. Features is a list of features to control
; how things are described. Current features are refine and modify. Refine implies
; that the user should be given a chance to refine composite objects. (e.g. arrays)
; Modify impies that the user should be given a chance to modify the value of an
; object.
; 

(defun db%describe_id (&optional (features '(refine modify)))
  (let* ((nodes (db%get_best_nodes *db%describable_ids*))
	 (node (first nodes))
	 (activation (cond ((null nodes) nil)
			   ((eq (length nodes) 1) (db%current_activation))
			   (t 'multiple_nodes))))
    (cond ((diana_nodep node)
	   (unwind-protect
	     (db%describe_id_node node activation *db%user_window* features)
	     (ct_terpri *db%user_window*))
	   (setq *db%latest_description* (dlsucc *db%latest_description*))
	   (set-iv db%describer_tag (db%dl_node_tag *db%latest_description*)
		   'node_list nodes)
	   (set-iv db%describer_tag (db%dl_node_tag *db%latest_description*) 'node node))
	  (t (db%message "What you are pointing at is not describable.")))))

; 
; Describe a diana id node. Just format up the strings generated by the
; various diana utilities. Note, the valueself part of the description must be
; called after the rest of the line has gone out because valueself can
; potenially ask the user some questions based on what has been shown so far.
; For this reason, stream should be an interactive stream if the valueself
; prog can ask questions. Activation is the activation record (runtime stack)
; which is used as the root for finding values.
; 

(defun db%describe_id_node (node activation stream &optional (features '(refine modify)))
  (let ((descrip (db%diana_describeself node nil features))
	(valueable (db%diana_valueselfp node activation))
	string1 string2 string3)
    (cond ((not (ct_string_equal descrip ""))
	   (setq string1 (ct_format stream "~a is ~a ~a"
				    (db%diana_printself node nil features)
				    (db%proper_article_for descrip)
				    descrip))
	   (cond ((eq valueable 'normal)
		  (setq string2 (ct_format stream " with value "))
		  (setq string3	(db%diana_valueself node activation stream features)))
		 ((eq valueable 'multiple_nodes)
		  (setq string2 (ct_format stream " with value "))
		  (setq string3 (ct_format stream "*GENERIC AMBIGUITY*")))
		 (t (setq string2 "" string3 ""))))
	  (t (setq string1 (ct_format stream "<This node type is not describable>"))
	     (setq string2 "" string3 "")))
    (ct_if (null stream)
	   (ct_string_append string1 string2 string3))))

; 
; Describe a diana node. Just format up the strings generated by the
; various diana utilities.
; 

(defun db%describe_node (node stream &optional features)
  (let ((descrip (db%diana_describeself node nil features))
	string1)
    (cond ((not (ct_string_equal descrip ""))
	   (setq string1 (ct_format stream "~a is ~a ~a"
				    (db%diana_printself node nil features)
				    (db%proper_article_for descrip)
				    descrip)))
	  (t (setq string1 (ct_format stream "<This node type is not describable>"))))
    (ct_if (null stream) string1)))


; 
; The following are a sequence of utilities for getting various properties 
; of diana nodes.
; 

; Print the lexical representation of a diana node. Check to see if the
; node type has a printself program. If not then try its defintion.  If still
; no luck then return the null string.
; 

(defun db%diana_printself (node stream &optional features)
    (let (dnode (program (and node
			      (get (diana_nodetype_get node) 'printself_program))))
	(cond (program (apply (car program)
			      (cons node (cons stream (cons features (cdr program))))))
	      ((neq node (setq dnode (db%diana_defineself node)))
	       (db%diana_printself dnode stream features))
	      (t ""))))

; 
; Print a description of the static semantics of a diana node. Check to see
; if the node type has a descibe program. If not then check for a defining
; occurrence. If not then return the null string.
; 

(defun db%diana_describeself (node stream &optional features)
  (let (dnode (program (get (diana_nodetype_get node) 'describeself_program)))
	(cond (program (apply (car program)
			      (cons node (cons stream (cons features (cdr program))))))
	      ((neq node (setq dnode (db%diana_defineself node)))
	       (db%diana_describeself dnode stream features))
	      (t ""))))

;
; A simple predicate to tell if we know how to describe a particular diana node type.
;

(defun db%diana_describable_p (node stream)
  (neq "" (db%diana_describeself node stream)))

; 
; Get the defining occurrence of a id like diana node. Check for a defining
; program. If there is one then call it. If not return the node itself. If we get a
; new node, then try getting the defining occurrence of it.
; 

(defun db%diana_defineself (node)
    (let* ((program (and node (get (diana_nodetype_get node) 'defineself_program)))
	   (dnode (ct_if program
		      (apply (car program) (cons node (cdr program)))
		      node)))
	(ct_if (neq node dnode)
	    (db%diana_defineself dnode)
	    dnode)))

; 
; A predicate to check whether the runtime "value" of a diana node exist.
; Look first to see if this is for a generic defintion. If so then no value.
; Look for a value self program.
; If none, then try for a defining occurrence. If none then return nil.
; 

(defun db%diana_valueselfp (node activation)
  (let (dnode)
;;hack for now until we have a better scheme for generics
    (cond ;((eq (db%classify_node node) 'generic_definition) nil)
	  ((and node (get (diana_nodetype_get node) 'valueself_program))
	   (ct_if (eq activation 'multiple_nodes) 'multiple_nodes 'normal))
	  ((neq node (setq dnode (db%diana_defineself node)))
	   (db%diana_valueselfp dnode activation))
	  (t nil))))

; 
; Print the runtime "value" of a diana node. Look for a value self program.
; If none, then try for a defining occurrence. If none then return the null
; string. Activation is the activation record which is used to derive a value
; for variables.
; 

(defun db%diana_valueself (node activation stream &optional (features nil))
  (let (dnode
	(program (and node (get (diana_nodetype_get node) 'valueself_program))))
    (cond (program (apply (car program)
			  (cons node
				(cons activation
				      (cons stream (cons features (cdr program)))))))
	  ((neq node (setq dnode (db%diana_defineself node)))
	   (db%diana_valueself dnode activation stream features))
	  (t ""))))


; 
; A function to return a list of describer tags. Run around the description stack
; and collect up all the tags.
; 

(defun db%describer_tags ()
    (loop for cell = *db%latest_description* then (dlpred cell)
	  if (get-iv *db%describer_tag (first (dlval cell)) 'node)
	  append (dlval cell)
	  until (eq (dlpred cell) *db%latest_description*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal Use Only Functions/Methods -- 

; 
; The following code is used for building the network of diana node
; type property list programs
; which are used by the describer to do its job.
;
; First we handle the id like nodes.
;

; 
; Make a diana id like node type describable. We put programs on the property
; list of the node type to print the nodes lexical representation, descibe the
; the node, to find the nodes defining occurrence and 
; to give the node a run time value.
; 

(defun db%make_id_describable (node_type  &optional pbody dbody vbody dfbody)
    (db%make_diana_printable node_type pbody)
    (db%make_diana_describable node_type dbody)
    (db%make_diana_valueable node_type vbody)
    (db%make_diana_defineable node_type dfbody)
    node_type)

; 
; A function to initialize all the describable node types. We do so by
; calling the appropriate functions to set up the programs on the property
; lists and to add the node types to the list of describable nodes.
; 

(defun db%init_id_describables ()
    (setq *db%describable_ids*
	(list
	    (db%make_id_describable 'dn_argument_id
		'(db%lx_symrep_prog)
		'(db%string_prog "argument to a pragma"))
	    (db%make_id_describable 'dn_attr_id
		'(db%lx_symrep_prog)
		'(db%string_prog "attribute"))
	    (db%make_id_describable 'dn_comp_id
		'(db%lx_symrep_prog)
		'(db%string_prog "component of a record"))    
	    (db%make_id_describable 'dn_const_id
		'(db%lx_symrep_prog)
		'(db%string_prog "constant")
		'(db%const_value_prog)
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_def_char
		'(db%lx_symrep_prog)
		'(db%string_prog "character literal"))    
	    (db%make_id_describable 'dn_def_op
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "operator")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_dscrmt_id
		'(db%lx_symrep_prog)
		'(db%string_prog "descriminant")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_entry_id
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "task entry"))    
	    (db%make_id_describable 'dn_enum_id
		'(db%lx_symrep_prog)
		'(db%string_prog "enumeration element"))    
	    (db%make_id_describable 'dn_exception_id
		'(db%lx_symrep_prog)
		'(db%string_prog "exception condition")
		'(db%exception_value_prog))    
	    (db%make_id_describable 'dn_function_id
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "function")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_generic_id
		'(db%lx_symrep_prog)
		'(db%string_prog "generic")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_in_id
		'(db%lx_symrep_prog)
		'(db%string_prog "input parameter")
		'(db%variable_value_prog)
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_in_out_id
		'(db%lx_symrep_prog)
		'(db%string_prog "input output parameter")
		'(db%variable_value_prog)
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_iteration_id
		'(db%lx_symrep_prog)
		'(db%string_prog "iteration variable")
		'(db%variable_value_prog))	    
	    (db%make_id_describable 'dn_l_private_type_id
		'(db%lx_symrep_prog)
		'(db%string_prog "limited privated type"))    
	    (db%make_id_describable 'dn_label_id
		'(db%lx_symrep_prog)
		'(db%string_prog "label"))    
	    (db%make_id_describable 'dn_null_access
		'(db%string_prog "null")
		'(db%string_prog "null access"))    
	    (db%make_id_describable 'dn_number_id
		'(db%lx_symrep_prog)
		'(db%string_prog "defined number")
		'(db%number_value_prog))    
	    (db%make_id_describable 'dn_numeric_literal
		'(db%lx_numrep_prog)
		'(db%string_prog "numeric literal"))    
	    (db%make_id_describable 'dn_out_id
		'(db%lx_symrep_prog)
		'(db%string_prog "output parameter")
		'(db%variable_value_prog)
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_package_id
		'(db%lx_symrep_prog)
		'(db%string_prog "package")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_pragma_id
		'(db%lx_symrep_prog)
		'(db%string_prog "pragma"))    
	    (db%make_id_describable 'dn_private_type_id
		'(db%lx_symrep_prog)
		'(db%string_prog "private type"))    
	    (db%make_id_describable 'dn_proc_id
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "procedure")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_string_literal
		'(db%lx_symrep_prog)
		'(db%string_prog "string literal"))    
	    (db%make_id_describable 'dn_subtype_id
		'(db%lx_symrep_prog)
		'(db%string_prog "subtype"))    
	    (db%make_id_describable 'dn_task_body_id
		'(db%lx_symrep_prog)
		'(db%string_prog "task body")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_type_id
		'(db%lx_symrep_prog)
		'(db%string_prog "type")
		nil
		'(db%definition_prog sm_first))    
	    (db%make_id_describable 'dn_var_id
		'(db%lx_symrep_prog)
		'(db%string_prog "variable")
		'(db%variable_value_prog))    
	    (db%make_id_describable 'dn_used_bltn_id
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_operator))    
	    (db%make_id_describable 'dn_used_bltn_op
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_operator))    
	    (db%make_id_describable 'dn_used_char
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn))    
	    (db%make_id_describable 'dn_used_name_id
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn))    
	    (db%make_id_describable 'dn_used_object_id
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn))    
	    (db%make_id_describable 'dn_used_op
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn))    

	    ; 
	    ; NON STANDARD DIANA NODE TYPES
	    ; 

	    ; like a dn_attr_id
	    (db%make_id_describable 'dn_predefined_attribute
		'(db%lx_symrep_prog)
		'(db%string_prog "attribute"))
	    ; like an dn_exception_id
	    (db%make_id_describable 'dn_predefined_exception
		'(db%lx_symrep_prog)
		'(db%string_prog "exception condition")
		'(db%exception_value_prog))    
	    ; like a dn_pragma_id
	    (db%make_id_describable 'dn_predefined_pragma
		'(db%lx_symrep_prog)
		'(db%string_prog "pragma"))    
	    ; like an dn_argument_id
	    (db%make_id_describable 'dn_predefined_pragma_parameter
		'(db%lx_symrep_prog)
		'(db%string_prog "argument to a pragma"))
	    ;like a dn_integer or dn_float of dn_fixed type
	    (db%make_id_describable 'dn_predefined_type
		'(db%lx_symrep_prog)
		'(db%string_prog "predefined type")))))  


; 
; The following are the programs which are put on the property list of the 
; various diana id node types. The functions all end in _prog. The first
; argument to each function should be the node to be examined. This argument
; is consed in to the value obtained from the property list by the accessor
; functions.
; 

; 
; Returns a string with the lexical representation of a symbol. (if any).
; 

(defun db%lx_symrep_prog (node stream features)
  features
  (db%formstring stream (apply #'ct_string_append (cadr (diana_get node 'lx_symrep)))))

; 
; Returns a string with the lexical representation of a number (if any).
; Used for numeric literals and named numbers.
; 

(defun db%lx_numrep_prog (node stream features)
  features
  (db%formstring stream (ct_format nil "~a" (numval (diana_get node 'lx_numrep)))))

; 
; A function which just evaluates to a string.
; 

(defun db%string_prog (node stream features string)
  node features
  (db%formstring stream string))

; 
; Describe "procedure like" diana nodes. This includes procedures, functions,
; entries, and operators. Look to see if they have a lisp function
; implementation. If so then desribe them as built in. If we cannot find a body
; then it must be an entry id.
; 

(defun db%proc_like_prog (node stream features string)
    features
    (let* ((def (db%diana_defineself node))
	   (body (db%diana_defineself (and (diana_node_accepts_attributep def 'sm_body)
					   (diana_get def 'sm_body)))))
	(ct_format stream "~a~a"
	    (ct_if (and body
			(diana_node_accepts_attributep body 'ct_lisp_func)
		        (diana_get body 'ct_lisp_func))
		"built in "
		"")
	    string)))

; 
; Get the value string of an Ada variable value object. (var_id,
; iteration_id, parameters etc.). First find the object then refine it if
; appropriate. If we cannot find an instance
; of the object then it is ambiguous defined because it is outside the scope of
; the current activation.
; 

(defun db%variable_value_prog (node activation stream features)
  (let ((instance (db%look_up_ident node activation))
	final_instance string)
    (cond (instance
	   (setq string
		 (ct_send (setq final_instance
				(ct_if (memq 'refine features)
				       (ct_send instance 'refine_value node features stream)
				       instance))
			  'describe_value features stream))
	   (cond ((memq 'modify features)
		  (ct_send final_instance 'modify_value node features stream))
		 (t string)))
	  (t (db%formstring stream "*OUT OF SCOPE*")))))

; 
; Get the value string of an exception condition.
; 
; --NB flesh this out:value = the handler which would catch this or maybe raised/not raised
(defun db%exception_value_prog (node activation stream features)
  node activation features
  (db%formstring stream "*NOT IMPLEMENTED YET*"))

; 
; Get the value string of a constant. For now, just treat them like variables.
; 

(defun db%const_value_prog (node activation stream features)
  (ct_if *db%modify_ada_constants*
	 (db%variable_value_prog node activation stream features)
	 (db%variable_value_prog node activation stream (remq 'modify features))))

; 
; Get the value string of a named number.
; 

(defun db%number_value_prog (node activation stream features)
  activation features
  (let ((value (diana_get node 'sm_value)))
    (db%formstring stream
		   (cond ((fixp value) (ct_format nil "~f" value))
			 ((floatp value) (ct_format nil "~d" value))
			 (t "bad named number")))))

;
; Get the definition of a node. Follow the indicated attribute
; and then ask the definition to define itself. Special case for sm_first 
; since our interpretter does not build a correct diana tree. Follow sm_firsts
; until it is nil, then you have the definition.
; 

(defun db%definition_prog (node attr)
    (let ((dnode (diana_get node attr)))
	(cond ((and (null dnode) (eq attr 'sm_first)) node)
	      (dnode (db%diana_defineself dnode))
	      (t (lose 'db%insp_no_def 'db%definition_prog
		     '("Can't get diana node definition"))))))


;
; Now set up the properties for describing statement like nodes.
; 
; Make a diana statement node type describable. We put programs on the property
; list of the node type to print the nodes lexical representation, descibe the
; the node. 
; 

(defun db%make_statement_describable (node_type  &optional dbody)
    (db%make_diana_printable node_type '(db%string_prog "***"))
    (db%make_diana_describable node_type dbody)
    node_type)

; 
; A function to initialize all the describable node types. We do so by
; calling the appropriate functions to set up the programs on the property
; lists and to add the node types to the list of describable nodes.
; 
; --NB these descriptions need to be elaborated at some point

(defun db%init_statement_describables ()
    (setq *db%describable_statements*
	(list
	    ;Statements
	    (db%make_statement_describable 'dn_abort
		'(db%string_prog "abort statement"))
	    (db%make_statement_describable 'dn_accept
		'(db%string_prog "accept statement"))
	    (db%make_statement_describable 'dn_assign
		'(db%string_prog "assignment statement"))
	    (db%make_statement_describable 'dn_block
		'(db%string_prog "block statement"))
	    (db%make_statement_describable 'dn_case
		'(db%string_prog "case statement"))
	    (db%make_statement_describable 'dn_code
		'(db%string_prog "code statement"))
	    (db%make_statement_describable 'dn_delay
		'(db%string_prog "delay statement"))
	    (db%make_statement_describable 'dn_entry_call
		'(db%string_prog "entry call statement"))
	    (db%make_statement_describable 'dn_exit
		'(db%string_prog "exit statement"))
	    (db%make_statement_describable 'dn_function_call
		'(db%string_prog "function call expression"))
	    (db%make_statement_describable 'dn_goto
		'(db%string_prog "goto statement"))
	    (db%make_statement_describable 'dn_if
		'(db%string_prog "if statement"))
	    (db%make_statement_describable 'dn_loop
		'(db%string_prog "loop statement"))
	    (db%make_statement_describable 'dn_null_stm
		'(db%string_prog "null statement"))
	    (db%make_statement_describable 'dn_procedure_call
		'(db%proc_like_call_prog))
	    (db%make_statement_describable 'dn_raise
		'(db%string_prog "raise statement"))
	    (db%make_statement_describable 'dn_return
		'(db%string_prog "return statement"))
	    (db%make_statement_describable 'dn_select
		'(db%string_prog "select statement"))
	    (db%make_statement_describable 'dn_terminate
		'(db%string_prog "terminate statement"))

	    ; Declarations
	    (db%make_statement_describable 'dn_comp_unit
		'(db%string_prog "Ada compilation unit"))
	    
	    ; 
	    ; Make dn_compilation describable for the benifit of the
	    ; environment walker. (used when showing the top of stack while
            ; we are still looking for the main program)
	    ; 
	    (db%make_statement_describable 'dn_compilation
		'(db%string_prog "Ada program"))
	    (db%make_statement_describable 'dn_constant
		'(db%string_prog "constant declaration"))
	    (db%make_statement_describable 'dn_exception
		'(db%string_prog "exception declaration"))
	    (db%make_statement_describable 'dn_number
		'(db%string_prog "number declaration"))
	    (db%make_statement_describable 'dn_package_decl
		'(db%string_prog "package declaration"))
	    (db%make_statement_describable 'dn_subprogram_decl
		'(db%proc_like_decl_prog))
	    (db%make_statement_describable 'dn_subtype
		'(db%string_prog "subtype declaration"))
	    (db%make_statement_describable 'dn_task_decl
		'(db%string_prog "task declaration"))
	    (db%make_statement_describable 'dn_type
		'(db%string_prog "type declaration"))
	    (db%make_statement_describable 'dn_var
		'(db%string_prog "variable declaration")))))

;
; Build up a string describing procedure call like things. For now this includes
; real procedure calls as well as entry calls because the interpreter cheats. Further,
; apparently, the describe_self doesn't work with entries because they put a
; dn_selected as the sm_defn of a dn_used_name_id. Urgh.
;

(defun db%proc_like_call_prog (node stream features)
  features
  (let ((def_name_type (diana_nodetype_get (db%diana_defineself (diana_get node 'as_name)))))
    (cond ((eq def_name_type 'dn_proc_id) (db%formstring stream "procedure call statement"))
	  ((eq def_name_type 'dn_entry_id) (db%formstring stream "entry call statement"))
	  ((eq def_name_type 'dn_selected) (db%formstring stream "entry call statement"))
	  (t (db%formstring stream "unknown call")))))

;
; Build a string describing a subprogram decl. Special case for entry decls.
;

(defun db%proc_like_decl_prog (node stream features)
  features
  (cond ((eq 'dn_entry_id (diana_nodetype_get (diana_get node 'as_designator)))
	 (db%formstring stream "entry declaration"))
	(t (db%formstring stream "subprogram declaration"))))
	 

; 
; Finally, set up a few miscellaneous nodes.
; 

(defun db%init_misc ()
    (db%make_diana_defineable 'dn_rename '(db%definition_prog as_name))
    (db%make_diana_printable 'dn_ct_task_handler '(db%string_prog "***"))
    (db%make_diana_describable 'dn_ct_task_handler '(db%string_prog "task handler")))


; 
; A function to get the instance (if any) which is associated with an
; identifier node. This is very similar to the look_up_ident function which the
; interpretter uses except it has been modified for the debuggers purposes.
; (mainly it can resolve a binding with respect to any activation and not
; just *activation*. Also we allow for the possiblity that we may try to
; follow the alinks beyond the bottom of the stack) The
; procedure is to find the activation record with the
; correct program nesting level by following the alinks from the current
; activation. Then we assq down the locals looking for the correct node.
; If we find something then return it. (a flavor instance for the
; identifier) If not then the identifier is either unelaborated as yet or is
; not visible from the current activation. Return nil in this case.
; 

(defun db%look_up_ident (id_node cur_act)
    (let ((dfn_node (db%diana_defineself id_node)) distance id_act)
	(and dfn_node
	     cur_act
	     (not (< (setq distance (- (get-iv adabe_activation cur_act 'pnl)
				       (diana_get dfn_node 'ct_pnl)))
		     0))
	     (setq id_act (db%follow_alink cur_act distance))
	     (car (errset (cdr (assq id_node (get-iv adabe_activation id_act 'locals)))
			  nil)))))

(defun db%follow_alink (act n)
    (ct_if (not (> n 0))
	act
	(let ((next_up (get-iv adabe_activation act 'alink)))
	    (ct_if next_up
		(db%follow_alink next_up (1- n))
		(lose 'db%insp_bad_alink 'db%follow_alink '("Bad alinks"))))))


; 
; The following code is used to build and manipulate the description stack.
; 

; 
; Build the stack of described nodes. The stack is implemented as a circular dlist.
; *db%latest_description* always points to the most recently described node. Each
; cell of the stack constains a list of two tags. The first is the node that was
; described. The second tag is the defining occurrence of the described node. We
; build the stack by adding successive elements to the end of a dlist and then
; joining the two ends.
; 

(defun db%start_describer_tags ()
  (setq *db%latest_description* (dlinfirst nil (db%make_fresh_description_tags)))
  (dlappend (loop for length from 1 to *db%description_depth*
		  for cell = *db%latest_description*
		  then (dlinlast cell (db%make_fresh_description_tags))
		  finally (return cell))
	    *db%latest_description*))

; 
; Make a pair of fresh description tags. Two tags are created and returned in a
; list. The first tag has a nil node association. The second tag has a node
; hook function which gets the defining occurrence of the node which will be
; associated with the first tag.
; 

(defun db%make_fresh_description_tags ()
  (let ((node_tag (ct_make_instance 'db%describer_tag 'node nil)))
    (list node_tag (ct_make_instance 'db%describer_tag
				     'node `(db%get_tag_def_node ,node_tag)
				     'pname `(db%get_tag_def_pname ,node_tag)
				     'description `(db%get_tag_def_description ,node_tag)))))

; 
; Get the defining occurrence of the node associated with a tag. This function
; is used by the describer tags to get the defining occurrence of an described 
; node.
; 

(defun db%get_tag_def_node (tag)
  (db%diana_defineself (ct_csend db%describer_tag tag 'node)))

; 
; Build a print representation for the tag which represents the defining occurrence
; of a node.
; 

(defun db%get_tag_def_pname (tag)
  (ct_string_append "Defining occurrence of "
		    (db%diana_printself (db%get_tag_def_node tag) nil)))

; 
; Build a print representation for the description of the tag which represents
; the defining occurrence of a node.
; 

(defun db%get_tag_def_description (tag)
    (ct_string_append "definition of "
	(db%diana_printself (db%get_tag_def_node tag) nil)))

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