;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/inspector.l,v 1.22 84/09/18 14:03:57 bill Exp $
(putprop 'inspector "$Revision: 1.22 $" 'rcs_revision)
;;;
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                          inspector.l                             ;;;
;;;                                                                  ;;;
;;; William Brew                                         8-22-83     ;;;
;;;                                                                  ;;;
;;; Code for the Ada inspector.                                      ;;;
;;;                                                                  ;;;
;;; 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. ;;;
;;;                                                                  ;;;
;;;   The following code assumes familiarity with these materials.   ;;;
;;;                                                                  ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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
 
#+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 (compile load eval) (ct_load 'ctadadt)) ; Ada data types (records),flavs


(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%inspectable_ids* nil
    "A list of diana id like node types which are inspectable."
)

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

(defvar *db%latest_inspection* nil
    "A circular dlist of tags for nodes which the inspector has inspected. The
    list acts as a finite depth stack of the latest inspections."
)

(defconst *db%inspection_depth* 3
    "The number of inspections which are remembered."
)

; Specials used here and delared elsewhere.

(declare (special *db%user_window*))

#+franz
(declare (localf db%init_misc db%init_id_inspectables db%look_up_ident
	     db%follow_alink db%diana_get_type_value db%diana_refine_type_object
	     db%diana_ask_type_value
	     db%init_types db%print_object
	     db%init_statement_inspectables db%start_inspector_tags
	     db%make_fresh_inspection_tags db%get_tag_def_node
	     db%get_tag_def_pname db%get_tag_def_description
	 )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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_describeable (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 dynamic value.

(defmacro db%make_diana_valueable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'valueself_program))
	   (t (remprop ,node_type 'valueself_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))
     )
)

; Macro to make a diana type node type able to get a value for the associated
; id node.

(defmacro db%make_diana_get_valueable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'get_value_program))
	   (t (remprop ,node_type 'get_value_program))
     )
)

; Macro to make a diana type node type able to refine its value. Used on
; array and record types to get part of the structure.

(defmacro db%make_diana_refine_objectable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'refine_object_program))
	   (t (remprop ,node_type 'refine_object_program))
     )
)

; Macro to make a diana type node type able to ask for a value of its type.

(defmacro db%make_diana_ask_valueable (node_type body)
    `(cond (,body (putprop ,node_type ,body 'ask_value_program))
	   (t (remprop ,node_type 'ask_value_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 inspection stack cell.

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

; Get the definition tag from an inspection stack cell.

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

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

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

(ct_defflavor db%inspector_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 inspector
; 

(defun db%init_inspector ()
    (db%init_id_inspectables)
    (db%init_statement_inspectables)
    (db%init_types)
    (db%init_misc)
)

; 
; Startup the inspector
; 

(defun db%start_inspector ()
    (db%start_inspector_tags)
)

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

(defun db%inspector_tags ()
    (loop for cell = *db%latest_inspection* then (dlpred cell)
	  if (get-iv *db%inspector_tag (first (dlval cell)) 'node)
	  append (dlval cell)
	  until (eq (dlpred cell) *db%latest_inspection*)))

; 
; A function for inspecting diana nodes. Used to inspect 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 inspect function. Finally put the
; node in the inspected node stack.
; 

(defun db%inspect ()
  (let* ((nodes (db%get_best_nodes *db%inspectable_ids*))
	 (node (first nodes))
	 (activation (cond ((null nodes) nil)
			   ((eq (length nodes) 1) (db%current_activation))
			   (t 'multiple_nodes))))
    (cond ((diana_nodep node)
	   (db%inspect_node node activation *db%user_window*)
	   (ct_terpri *db%user_window*)
	   (setq *db%latest_inspection* (dlsucc *db%latest_inspection*))
	   (set-iv db%inspector_tag (db%dl_node_tag *db%latest_inspection*)
		   'node_list nodes)
	   (set-iv db%inspector_tag (db%dl_node_tag *db%latest_inspection*) 'node node))
	  (t (db%message "What you are pointing at is not describable.")))))

; 
; Inspect a diana node. Just format up the strings generated by the
; various diana utilities. Note, the valueself part of the inspection 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%inspect_node (node activation stream &optional (verbosity nil))
  (let* ((descrip (db%diana_describeself node nil verbosity))
	 (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 verbosity)
				    (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 verbosity)))
		 ((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))))

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

; Print the lexical representation of a diana 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 (verbosity nil))
    (let (dnode (program (and node
			      (get (diana_nodetype_get node) 'printself_program))))
	(cond (program (apply (car program)
			      (cons node (cons stream (cons verbosity (cdr program))))
		       )
	      )
	      ((neq node (setq dnode (db%diana_defineself node)))
	       (db%diana_printself dnode stream verbosity)
	      )
	      (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 (verbosity nil))
    (let (dnode (program (get (diana_nodetype_get node) 'describeself_program)))
	(cond (program (apply (car program)
			      (cons node (cons stream (cons verbosity (cdr program))))
		       )
	      )
	      ((neq node (setq dnode (db%diana_defineself node)))
	       (db%diana_describeself dnode stream verbosity)
	      )
	      (t "")
	)
    )
)

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

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

; 
; 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 (verbosity 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 verbosity (cdr program)))))))
	  ((neq node (setq dnode (db%diana_defineself node)))
	   (db%diana_valueself dnode activation stream verbosity))
	  (t ""))))

; 
; 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)))

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

; 
; The following are used for building the network of diana node
; type property list programs
; which are used by the inspector to do its job.
;

; 
; 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_describeable 'dn_ct_task_handler '(db%string_prog "task handler"))
)

; 
; Make a diana id like node type inspectable. 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_inspectable (node_type  &optional pbody dbody vbody dfbody)
    (db%make_diana_printable node_type pbody)
    (db%make_diana_describeable 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 inspectable 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 inspectable nodes.
; 

(defun db%init_id_inspectables ()
    (setq *db%inspectable_ids*
	(list
	    (db%make_id_inspectable 'dn_argument_id
		'(db%lx_symrep_prog)
		'(db%string_prog "argument to a pragma")
	    )
	    (db%make_id_inspectable 'dn_attr_id
		'(db%lx_symrep_prog)
		'(db%string_prog "attribute")
	    )
	    (db%make_id_inspectable 'dn_comp_id
		'(db%lx_symrep_prog)
		'(db%string_prog "component of a record")
	    )    
	    (db%make_id_inspectable 'dn_const_id
		'(db%lx_symrep_prog)
		'(db%string_prog "constant")
		'(db%const_value_prog)
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_def_char
		'(db%lx_symrep_prog)
		'(db%string_prog "character literal")
	    )    
	    (db%make_id_inspectable 'dn_def_op
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "operator")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_dscrmt_id
		'(db%lx_symrep_prog)
		'(db%string_prog "descriminant")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_entry_id
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "task entry")
	    )    
	    (db%make_id_inspectable 'dn_enum_id
		'(db%lx_symrep_prog)
		'(db%string_prog "enumeration element")
	    )    
	    (db%make_id_inspectable 'dn_exception_id
		'(db%lx_symrep_prog)
		'(db%string_prog "exception condition")
		'(db%exception_value_prog)
	    )    
	    (db%make_id_inspectable 'dn_function_id
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "function")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_generic_id
		'(db%lx_symrep_prog)
		'(db%string_prog "generic")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_in_id
		'(db%lx_symrep_prog)
		'(db%string_prog "input parameter")
		'(db%variable_value_prog)
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable '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_inspectable 'dn_iteration_id
		'(db%lx_symrep_prog)
		'(db%string_prog "iteration variable")
		'(db%variable_value_prog)
	    )	    
	    (db%make_id_inspectable 'dn_l_private_type_id
		'(db%lx_symrep_prog)
		'(db%string_prog "limited privated type")
	    )    
	    (db%make_id_inspectable 'dn_label_id
		'(db%lx_symrep_prog)
		'(db%string_prog "label")
	    )    
	    (db%make_id_inspectable 'dn_null_access
		'(db%string_prog "null")
		'(db%string_prog "null access")
	    )    
	    (db%make_id_inspectable 'dn_number_id
		'(db%lx_symrep_prog)
		'(db%string_prog "defined number")
		'(db%number_value_prog)
	    )    
	    (db%make_id_inspectable 'dn_numeric_literal
		'(db%lx_numrep_prog)
		'(db%string_prog "numeric literal")
	    )    
	    (db%make_id_inspectable 'dn_out_id
		'(db%lx_symrep_prog)
		'(db%string_prog "output parameter")
		'(db%variable_value_prog)
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_package_id
		'(db%lx_symrep_prog)
		'(db%string_prog "package")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_pragma_id
		'(db%lx_symrep_prog)
		'(db%string_prog "pragma")
	    )    
	    (db%make_id_inspectable 'dn_private_type_id
		'(db%lx_symrep_prog)
		'(db%string_prog "private type")
	    )    
	    (db%make_id_inspectable 'dn_proc_id
		'(db%lx_symrep_prog)
		'(db%proc_like_prog "procedure")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_string_literal
		'(db%lx_symrep_prog)
		'(db%string_prog "string literal")
	    )    
	    (db%make_id_inspectable 'dn_subtype_id
		'(db%lx_symrep_prog)
		'(db%string_prog "subtype")
	    )    
	    (db%make_id_inspectable 'dn_task_body_id
		'(db%lx_symrep_prog)
		'(db%string_prog "task body")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_type_id
		'(db%lx_symrep_prog)
		'(db%string_prog "type")
		nil
		'(db%definition_prog sm_first)
	    )    
	    (db%make_id_inspectable 'dn_var_id
		'(db%lx_symrep_prog)
		'(db%string_prog "variable")
		'(db%variable_value_prog)
	    )    
	    (db%make_id_inspectable 'dn_used_bltn_id
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_operator)
	    )    
	    (db%make_id_inspectable 'dn_used_bltn_op
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_operator)
	    )    
	    (db%make_id_inspectable 'dn_used_char
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn)
	    )    
	    (db%make_id_inspectable 'dn_used_name_id
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn)
	    )    
	    (db%make_id_inspectable 'dn_used_object_id
		'(db%lx_symrep_prog)
		nil
		nil
		'(db%definition_prog sm_defn)
	    )    
	    (db%make_id_inspectable '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_inspectable 'dn_predefined_attribute
		'(db%lx_symrep_prog)
		'(db%string_prog "attribute")
	    )
; like an dn_exception_id
	    (db%make_id_inspectable 'dn_predefined_exception
		'(db%lx_symrep_prog)
		'(db%string_prog "exception condition")
		'(db%exception_value_prog)
	    )    
; like a dn_pragma_id
	    (db%make_id_inspectable 'dn_predefined_pragma
		'(db%lx_symrep_prog)
		'(db%string_prog "pragma")
	    )    
; like an dn_argument_id
	    (db%make_id_inspectable '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_inspectable 'dn_predefined_type
		'(db%lx_symrep_prog)
		'(db%string_prog "predefined type")
	    )    

	)
    )
; Call get-best-node here to get things initialized for searching later.
; --NB uncomment the following after we are finished debugging
; --NB not quite right anymore
; get best node has changed, source files not bound, should be called by
; the modules that actually build the node type search lists.

;    (ct_if (and (boundp '*db%diana*) (diana_nodep *db%diana*))
;	(loop for file in *db%source_files*
;	      do (get-best-node *db%diana* file 0 *db%inspectable_ids*)
;	)
;    )
)
    

; 
; 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 &optional (verbosity nil))
  verbosity
  (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 &optional (verbosity nil))
  verbosity
  (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 verbosity string)
  node verbosity
  (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 verbosity string)
    verbosity
    (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 call the
; appropriate printer for the type of the object. 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 &optional (verbosity nil))
  (let ((instance (db%look_up_ident node activation)))
    (ct_if instance
	   (db%diana_get_type_value (diana_get node 'sm_obj_type)
				    node instance verbosity stream)
	   (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
(defun db%exception_value_prog (node activation stream &optional (verbosity nil))
  node activation verbosity
  (db%formstring stream "*NOT IMPLEMENTED YET*"))

; 
; Get the value string of a constant. For now, just treat them like variables. When
; we can modify values, then we will have to be more careful.
; 

(defun db%const_value_prog (node activation stream &optional (verbosity nil))
  (db%variable_value_prog node activation stream verbosity))

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

(defun db%number_value_prog (node activation stream &optional (verbosity nil))
  activation verbosity
  (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")
		 )
	      )
	)
    )
)


; 
; 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"))))))


; 
; Get the value string of the given Ada object with type as given by the
; type spec node. Output on the given stream. If we can't find a program
; then try extracting the base type and looking on it. If still no luck then
; return the null string. Verbose is a flag which says whether we want
; composite types to print their value or just "...". Node is the original
; node which we are inspecting.
; 

(defun db%diana_get_type_value (tnode node object verbose stream)
    (let (bnode (program (get (diana_nodetype_get tnode) 'get_value_program)))
	(cond (program (apply (car program)
			      (nconc `(,tnode ,node ,object ,verbose ,stream)
				     (cdr program))))
	      ((neq tnode (setq bnode (extract_basetype tnode t)))
	       (db%diana_get_type_value bnode node object verbose stream))
	      (t ""))))

; 
; Refine the value of an object of type tnode. Used on array and record
; types. Look for a refine program. If non then try extracting the base
; type. If still no luck then the object refines to itself.
; 

(defun db%diana_refine_type_object (tnode node object verbose stream)
    (let (bnode (program (get (diana_nodetype_get tnode) 'refine_object_program)))
	(cond (program (apply (car program)
			      (nconc `(,tnode ,node ,object ,verbose ,stream)
				     (cdr program)
			      )
		       )
	      )
	      ((neq tnode (setq bnode (extract_basetype tnode t)))
	       (db%diana_refine_type_object bnode node object verbose stream)
	      )
	      (t object)
	)
    )
)


; 
; Ask the user for a value of type tnode. Look for a ask value program. If
; non then look again on the base type. If still no luck then return nil.
; 

(defun db%diana_ask_type_value (tnode first last)
    (let (bnode (program (get (diana_nodetype_get tnode) 'ask_value_program)))
	(cond (program (apply (car program)
			      (cons tnode (cons first (cons last (cdr program))))
		       )
	      )
	      ((neq tnode (setq bnode (extract_basetype tnode t)))
	       (db%diana_ask_type_value bnode first last)
	      )
	      (t nil)
	)
    )
)

; 
; Make a type spec node type able to print the value of an object.
; Put a get value property on the node type. Also a refine object and a ask
; value property.
; 

(defun db%make_type_printable (node_type &optional vbody rbody abody)
    (db%make_diana_get_valueable node_type vbody)
    (db%make_diana_refine_objectable node_type rbody)
    (db%make_diana_ask_valueable node_type abody)
    node_type
)

; As of now (9-1-83) there are no progs for the constrained and derived
; types. We get info for these only via the extract_basetype in
; db%diana_get_type_value.

; 
; This function initilizes the type spec node types by putting various
; programs on their property lists.
; 

(defun db%init_types ()
    (db%make_type_printable 'dn_access
	'(db%get_access_value_prog)
	'(db%refine_access_object_prog)
    )
    (db%make_type_printable 'dn_array
	'(db%get_array_value_prog)
	'(db%refine_array_object_prog)
    )
    (db%make_type_printable 'dn_enum_literal_s
	'(db%get_enumeration_value_prog)
	nil
	'(db%ask_enumeration_value_prog)
    )
    (db%make_type_printable 'dn_fixed
	'(db%get_fixed_value_prog)
	nil
	'(db%ask_fixed_value_prog)
    )
    (db%make_type_printable 'dn_float
	'(db%get_float_value_prog)
	nil
	'(db%ask_float_value_prog)
    )
    (db%make_type_printable 'dn_integer
	'(db%get_integer_value_prog)
	nil
	'(db%ask_integer_value_prog)
    )
    (db%make_type_printable 'dn_record
	'(db%get_record_value_prog)
	'(db%refine_record_object_prog)
    )
    (db%make_type_printable 'dn_task_spec
	'(db%get_task_spec_value_prog)
    )
    (db%make_type_printable 'dn_ufixed
	'(db%get_ufixed_value_prog)
	nil
	'(db%ask_ufixed_value_prog)
    )
    (db%make_type_printable 'dn_ufloat
	'(db%get_ufloat_value_prog)
	nil
	'(db%ask_ufloat_value_prog)
    )
    (db%make_type_printable 'dn_uinteger
	'(db%get_uinteger_value_prog)
	nil
	'(db%ask_uinteger_value_prog)
    )

; 
; NON STANDARD DIANA NODE TYPES
; 

; like a dn_integer or dn_float or dn_fixed
    (db%make_type_printable 'dn_predefined_type
	'(db%get_predefined_value_prog)
	nil
	'(db%ask_predefined_value_prog)
    )
)


; 
; The following are a series of functions that are put on the property lists
; of the diana type spec node types (dn_record, dn_array etc.). The names of the
; functions all end in _prog. Each is passed the type node, the original node,
; the object they
; are to get the value of, and the stream which they are to use for their
; output. (ala format)
; 

; 
; Get the value for any of the ct predefined types. This should susume the
; integer, fixed and float types. 
; 

(defun db%get_predefined_value_prog (tnode node object verbose stream)
  tnode node verbose
  (db%print_object object stream)
)

; 
; Get the value of an integer type. This is in just in case the predefined
; node does not cover everything.
; 

(defun db%get_integer_value_prog (tnode node object verbose stream)
  tnode node verbose
  (db%print_object object stream)
)

; 
; Get the value of an fixed point type. This is in just in case the predefined
; node does not cover everything.
; 

(defun db%get_fixed_value_prog (tnode node object verbose stream)
  tnode node verbose
  (db%print_object object stream)
)

; 
; Get the value of an floating point type. This is in just in case the predefined
; node does not cover everything.
; 

(defun db%get_float_value_prog (tnode node object verbose stream)
  tnode node verbose
  (db%print_object object stream)
)

; 
; Get the value string for a enumeration type.
; (Note, unlike the integer, fixed and float nodes, the
; enumeration type node is not susumed by the predefined type node.)
; 

(defun db%get_enumeration_value_prog (tnode node object verbose stream)
  tnode node verbose
  (db%print_object object stream)
)

; 
; Get the value for a array type. If we are told to verbose output then
; do so. If not then print "...", and then try to refine the value some more.
; 

(defun db%get_array_value_prog (tnode node object verbose stream)
    (ct_if verbose
	(db%print_object object stream)
	(let (robject)
	    (cond (stream
		      (ct_format stream "...~%")
		      (db%diana_printself node stream)
		  )
	    )
	    (setq robject (db%diana_refine_type_object tnode node object
			      verbose stream
			  )
	    )
	    (ct_if stream (ct_princ " = " stream))
	    (db%print_object robject stream)
	)
    )
)
						       
; 
; Get the value for a record type. If we are told to verbose output then
; do so. If not then print "...", and then try to refine the value some more.
; 

(defun db%get_record_value_prog (tnode node object verbose stream)
    (ct_if verbose
	(db%print_object object stream)
	(let (robject)
	    (cond (stream
		      (ct_format stream "...~%")
		      (db%diana_printself node stream)
		  )
	    )
	    (setq robject (db%diana_refine_type_object tnode node object
			      verbose stream
			  )
	    )
	    (ct_if stream (ct_princ " = " stream))
	    (db%print_object robject stream)
	)
    )
)

; 
; Get the value for an access type. If we are allowed verbose output then
; just show the object itself. Otherwise try to refine the users intention.
; 

(defun db%get_access_value_prog (tnode node object verbose stream)
    (ct_if verbose
	(db%print_object object stream)
	(let (robject)
	    (cond (stream
		      (ct_format stream "...~%")
		      (db%diana_printself node stream)
		  )
	    )
	    (setq robject (db%diana_refine_type_object tnode node object
			      verbose stream
			  )
	    )
	    (ct_if stream (ct_princ " = " stream))
	    (db%print_object robject stream)
	)
    )
)
; 
; Get the value for a task type.
; 

(defun db%get_task_spec_value_prog (tnode node object verbose stream)
  tnode node verbose
  (db%print_object object stream))

; 
; Get the value for a universal integer.
; 

(defun db%get_uinteger_value_prog (tnode node object verbose stream)
  tnode node object verbose
  (db%formstring stream "*NOT IMPLEMENTED YET*")
)
; 
; Get the value for a universal fixed.
; 

(defun db%get_ufixed_value_prog (tnode node object verbose stream)
  tnode node object verbose
  (db%formstring stream "*NOT IMPLEMENTED YET*")
)

; 
; Get the value for a universal float
; 

(defun db%get_ufloat_value_prog (tnode node object verbose stream)
  tnode node object verbose
  (db%formstring stream "*NOT IMPLEMENTED YET*")
)


; 
; The following functions are for refining the value of non simple types.
; 

; 
; Refine the value of an array type object. First check to see if we should
; just print the value of the entire array with out any further refinement.
; If we do need to refine, then call then loop though the indices for the
; array and ask the user for a value to use. If we are really writing to a
; stream and not just a string, then echo back the refinement in Ada syntax
; as we go. When we have all the indices, then get the value of that element
; and call the refine on it using the type spec for the array object.
; 

(defun db%refine_array_object_prog (tnode node obj verbose stream)
    (ct_if (eq 'all (db%ask_literal "Refine the array's value or print all of it?"
			'(refine all)
		    )
	   )
	obj
	(db%diana_refine_type_object (diana_get tnode 'as_constrained) node
	    (ct_csend dt_array_type obj 'get_val
		(loop for inode in (diana_get (diana_get tnode 'as_dscrt_range_s)
				       'as_list
				   )
		      for separator = "(" then ","
		      for cnt from 1
		      for indx = (db%diana_ask_type_value inode 
				     (ct_csend dt_array_type obj
					 'attribute_handler '|first| cnt
				     )
				     (ct_csend dt_array_type obj
					 'attribute_handler '|last| cnt
				     )
				 )
		      for printindx = (cond ((numberp indx) indx)
					    ((diana_nodep indx)
			                     (db%diana_printself indx nil)
					    )
					    (t (lose 'db%insp_bad_index
						   'db%refine_array_object
						   '("Unknown index type")
					       )
					    )
				      )
		      if stream do (ct_princ separator stream) and
		                do (ct_format stream "~d" printindx)
		      collect indx
		      finally (ct_if stream (ct_princ ")" stream))
		)
	    )
	    verbose stream
	)
    )
)
							       
; 
; Refine the value of a record type. Ask the user whether the want the whole thing
; or just part. If they want part then get the alist of available fields from the
; record and ask the user which one. Then print the name and try to refine further.
; 

(defun db%refine_record_object_prog (tnode node obj verbose stream)
    tnode
    (ct_if (eq 'all (db%ask_literal "Refine the record's value or print all of it?"
			'(refine all)
		    )
	   )
	obj
	(let* ((rec_alist
		   (ada_record_value%record
		       (ct_csend dt_record_type obj 'get_val nil)
		   )
	       )
	       (pair (db%ask_literal "Record field: "
			 (loop for (comp_id . thing) in rec_alist
			       collect `(,(db%diana_printself comp_id nil)
					  (,comp_id . ,thing)
					)
			 )
		     )
	       )
	       (c_id (car pair))
	       (field_obj (cdr pair))
	      )
	    (and stream (ct_format stream ".~a" (db%diana_printself c_id nil)))
; --NB
; This won't work until our diana tree has all the attributes
;	    (db%diana_refine_type_object (diana_get c_id 'sm_obj_type) node
	    (db%diana_refine_type_object (extract_basetype c_id t) node
		field_obj verbose stream
	    )
	)
    )
)		    

; 
; Refine an access type object. Two possibilities exist. Either we want the value
; of the pointer itself or we want the object that it is pointing to.
; 

(defun db%refine_access_object_prog (tnode node obj verbose stream)
    (ct_if (eq 'accessor (db%ask_literal "Accessed object or the accessor?"
			     '(accessed accessor)
			 )
	   )
	obj
	(cond ((neq (get-iv dt_access_type obj 'current_value) '*unassigned*)
	       (ct_if stream (ct_princ ".all" stream))
	       (db%diana_refine_type_object (diana_get tnode 'as_constrained) node
		   (ct_csend dt_access_type obj 'get_val nil) verbose stream
	       )
	      )
	      (t 'bad_access_object)
	)
    )
)


; 
; Ask the user for a value of type dn_predefined in the range first to last.
; Tnode is the type node. Should really be checking for legitimate range. 
; 
; --NB this only works for integers right now. Eventually this should disappear

(defun db%ask_predefined_value_prog (tnode first last)
    tnode
    (db%ask_integer "Index value: " first last)
)

; 
; Ask the user for a value of an enumeration type. First is the
; first value allowed (a dn_enum_id or def_char). Last is the last value
; allowed. Tnode is dn_enum_literal_s. First we gather up a list of pairs of print
; representations and enum_id (or def_char). If it looks like we have a
; legitimate list then ask the user for a value.
; 

(defun db%ask_enumeration_value_prog (tnode first last)
    (let* ((first_up (memq first (diana_get tnode 'as_list)))
	   (last_up (memq last first_up))
	   (enum_list (loop for enum_id in (ldiff first_up (cdr last_up))
			    collect (list (db%diana_printself enum_id nil) enum_id)
		      )
	   )
	  )
	(ct_if (and first_up last_up enum_list)
	    (db%ask_literal "Index value: " enum_list)
	    (lose 'db%insp_enum 'db%ask_enumeration_value_prog
		'("Can't get enumeration range")
	    )
	)
    )
)

; 
; Print the object. We check to see if the object knows how to
; print itself. If so then do it. Else it is an error.
; 

(defun db%print_object (object stream)
  (let ((prinlength 10.)
	(prinlevel 2.))
    (cond ((or (get-handler-for object 'printself) (get-handler-for object ':printself))
	   (ct_send object 'printself stream))
	  ((eq object 'bad_access_object)
	   (db%formstring stream "<unassigned access>"))
	  (t (db%formstring stream "<cannot print self>"))))); --NB should be a
                                                             ; db%lose eventually
  

; 
; Make a diana statement node type inspectable. 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_inspectable (node_type  &optional dbody)
    (db%make_diana_printable node_type '(db%string_prog "***"))
    (db%make_diana_describeable node_type dbody)
    node_type
)

; 
; A function to initialize all the inspectable 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 inspectable nodes.
; 
; --NB these descriptions need to be elaborated at some point

(defun db%init_statement_inspectables ()
    (setq *db%inspectable_statements*
	(list
	    (db%make_statement_inspectable 'dn_abort
		'(db%string_prog "abort statement")
	    )
	    (db%make_statement_inspectable 'dn_accept
		'(db%string_prog "accept statement")
	    )
	    (db%make_statement_inspectable 'dn_assign
		'(db%string_prog "assignment statement")
	    )
	    (db%make_statement_inspectable 'dn_block
		'(db%string_prog "block statement")
	    )
	    (db%make_statement_inspectable 'dn_case
		'(db%string_prog "case statement")
	    )
	    (db%make_statement_inspectable 'dn_code
		'(db%string_prog "code statement")
	    )
	    (db%make_statement_inspectable 'dn_delay
		'(db%string_prog "delay statement")
	    )
	    (db%make_statement_inspectable 'dn_entry_call
		'(db%string_prog "entry call statement")
	    )
	    (db%make_statement_inspectable 'dn_exit
		'(db%string_prog "exit statement")
	    )
	    (db%make_statement_inspectable 'dn_function_call
		'(db%string_prog "function call expression")
	    )
	    (db%make_statement_inspectable 'dn_goto
		'(db%string_prog "goto statement")
	    )
	    (db%make_statement_inspectable 'dn_if
		'(db%string_prog "if statement")
	    )
	    (db%make_statement_inspectable 'dn_loop
		'(db%string_prog "loop statement")
	    )
	    (db%make_statement_inspectable 'dn_null_stm
		'(db%string_prog "null statement")
	    )
	    (db%make_statement_inspectable 'dn_procedure_call
		'(db%proc_like_call_prog)
	    )
	    (db%make_statement_inspectable 'dn_raise
		'(db%string_prog "raise statement")
	    )
	    (db%make_statement_inspectable 'dn_return
		'(db%string_prog "return statement")
	    )
	    (db%make_statement_inspectable 'dn_select
		'(db%string_prog "select statement")
	    )
	    (db%make_statement_inspectable 'dn_terminate
		'(db%string_prog "terminate statement")
	    )
	    
	    
	    ; Declarations
	    
	    (db%make_statement_inspectable 'dn_comp_unit
		'(db%string_prog "Ada compilation unit")
	    )
	    
	    ; 
	    ; Make dn_compilation inspectable 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_inspectable 'dn_compilation
		'(db%string_prog "Ada program")
	    )
	    (db%make_statement_inspectable 'dn_constant
		'(db%string_prog "constant declaration")
	    )
	    (db%make_statement_inspectable 'dn_exception
		'(db%string_prog "exception declaration")
	    )
	    (db%make_statement_inspectable 'dn_number
		'(db%string_prog "number declaration")
	    )
	    (db%make_statement_inspectable 'dn_package_decl
		'(db%string_prog "package declaration")
	    )
	    (db%make_statement_inspectable 'dn_subprogram_decl
		'(db%proc_like_decl_prog)
	    )
	    (db%make_statement_inspectable 'dn_subtype
		'(db%string_prog "subtype declaration")
	    )
	    (db%make_statement_inspectable 'dn_task_decl
		'(db%string_prog "task declaration")
	    )
	    (db%make_statement_inspectable 'dn_type
		'(db%string_prog "type declaration")
	    )
	    (db%make_statement_inspectable '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 verbosity)
  verbosity
  (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 verbosity)
  verbosity
  (cond ((eq 'dn_entry_id (diana_nodetype_get (diana_get node 'as_designator)))
	 (db%formstring stream "entry declaration"))
	(t (db%formstring stream "subprogram declaration"))))
	 

; 
; The following code is used to build and manipulate the inspection stack.
; 

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

(defun db%start_inspector_tags ()
  (setq *db%latest_inspection* (dlinfirst nil (db%make_fresh_inspection_tags)))
  (dlappend (loop for length from 1 to *db%inspection_depth*
		  for cell = *db%latest_inspection*
		  then (dlinlast cell (db%make_fresh_inspection_tags))
		  finally (return cell))
	    *db%latest_inspection*))

; 
; Make a pair of fresh inspection 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_inspection_tags ()
  (let ((node_tag (ct_make_instance 'db%inspector_tag 'node nil)))
    (list node_tag (ct_make_instance 'db%inspector_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 inspector tags to get the defining occurrence of an inspected 
; node.
; 

(defun db%get_tag_def_node (tag)
  (db%diana_defineself (ct_csend db%inspector_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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;