;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/point.l,v 1.12 84/11/20 11:00:57 bill Exp $
(putprop 'point "$Revision: 1.12 $" 'rcs_revision)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                            point.l                               ;;;
;;;                                                                  ;;;
;;; William Brew                                     3-28-83	     ;;;
;;;                                                                  ;;;
;;; Utilities for "pointing" in debugger windows.		     ;;;
;;;                                                                  ;;;
;;; 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 'ctio))    ;Compatable io


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


#+franz
(eval-when (compile load eval) (ct_load 'screens)) ;Window flavors
#+lispm
(eval-when (compile load eval) (ct_load 'lmscreens));Window flavors


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

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

(eval-when (load eval) (ct_load 'dfind))           ;Diana finding


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

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

(declare (special *db%code_window* *db%diana* *db%source_files*
		  *inbuilt_diana_trees*))

(defvar *db%choosable_files* nil
    "A list of files which the user may choose to view. Consists of the
    files the user inputs and any files from the envirnment")

(defvar *db%source_roots* nil
    "A list of source roots.")

(defvar *db%inbuilt_source_roots* nil
    "An alist which associates a source path with an inbuilt diana subtree.")

(defvar *db%hidden_files* '("wazzoo" "library")
    "Files (or pseudo files) which we do not want the user to see.")


#+franz
(declare (localf db%start_trees db%init_trees db%process_comp_units
	     db%title_and_point db%path_to_sroot
; needs work	     db%add_generic_source db%root
	     db%get_definition_source_range db%init_window db%start_window
	     db%instantiation_depth db%same_nodetypep))

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

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

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

; 
; Initialize the debugger pointing module
; 

(defun db%init_point ()
    (db%init_trees)
    (db%init_window))

; 
; Startup the debugger pointing module.
; 

(defun db%start_point ()
    (db%start_trees)
    (db%start_window))

;			
; Give a menu from which the user can choose the file that he wants
; to see displayed.  The files available are those that were originally
; input when the session was begun and are found in *db%choosable_files*
;

(defun db%choose_file ()
  (let ((sroot (db%ask_literal "Select a file: " *db%choosable_files*)))
      (db%source_to_window *db%code_window* sroot)))

;Lets turn this off for now until we can work out some of the problems.
#|
; 
; Select a generic instance. Find out what the user is pointing at. If it is
; a generic instance looking thing, then find the corresponding source root
; and show the user the code. 
; 

; --NBMay want to tag the site of the instantiation so the user can find it easily.

(defun db%select_generic ()
  (let* ((node (db%get_best_node '(dn_proc_id dn_function_id dn_package_id)))
	 (body (and (diana_nodep node) (diana_get node 'sm_body))))
    (cond ((not (and (diana_nodep node)
		     (db%generic_rootp node)
		     (eq (db%classify_node node) 'generic_copy)
		     body))
	   (db%message
	     "What you are pointing at is not a generic instance."))
	  ((member (source_region%path (diana_get body 'lx_srcpos)) *db%hidden_files*)
	   (db%message
	     "The generic instance you are pointing at is in an unviewable file."))
	  (t (db%source_to_window *db%code_window* (db%node_to_record body))))))

|#

; 
; Show the source which corresponds to the source to tree root in sroot
; in the indicated window. First we check that everything looks good. Also
; we try to avoid the overhead of getting the file again if we already have
; it hooked up to the window. Also remember the current position in
; the file in case we decide to look at it again.
; 

(defun db%source_to_window (window sroot &optional
			    (ochar (diana_late_get sroot 'position))
			    (origin ':center))
  (let ((path (diana_late_get sroot 'path))
	(current_sroot (get-iv db%debug_window window 'name))
	(cursor (db%ask_cursor window))
	(xy))
    (cond ((member path *db%hidden_files*)
	   (db%message "The file ~a is unviewable." path))
	  ((not (db%probef path))
	   (db%message "The file ~a was not found." path))
	  ((and (eq sroot current_sroot)
		(ct_string_equal path (get-iv db%debug_window window 'filename)))
	   (ct_csend db%debug_window window ':center-around-char ochar origin)
	   (setq xy (ct_csend db%debug_window window ':translate-document-to-screen ochar))
	   (db%point_in_window window (first xy) (second xy)))
	  ((ct_string_equal path (get-iv db%debug_window window 'filename))
	   (and (diana_nodep current_sroot)
		(diana_late_put current_sroot
				(ct_csend db%debug_window window
					  ':translate-screen-to-document
					  (first cursor) (second cursor))
				'position))
	   (ct_csend db%debug_window window ':restrict-range
		     (diana_late_get sroot 'top)
		     (diana_late_get sroot 'bottom) nil)
	   (ct_csend db%debug_window window ':center-around-char ochar origin)
	   (setq xy (ct_csend db%debug_window window ':translate-document-to-screen ochar))
	   (db%title_and_point window sroot xy))
	  (t
	   (and (diana_nodep current_sroot)
		(diana_late_put current_sroot
				(ct_csend db%debug_window window
					  ':translate-screen-to-document
					  (first cursor) (second cursor))
				'position))
	   (ct_csend db%debug_window window ':display-file
		     path (diana_late_get sroot 'top)
		     (diana_late_get sroot 'bottom) ochar origin)
	   (setq xy (ct_csend db%debug_window window ':translate-document-to-screen ochar))
	   (db%title_and_point window sroot xy)))))
  
; 
; Find the source root which corresponds to a diana node. First we look for
; a "root" for the subtree containing the node. Then we look to see if we
; have a source root for this root. If we do then return it. If not, then
; we assume we have found a generic instance and so create a new source root
; for it.
; 
#|
(defun db%node_to_record (node)
    (loop with root = (db%root node)
	  with key = (ct_if (db%generic_rootp root)
			    (diana_get root 'sm_body)
			    root)
	  while root
	  for record in *db%source_roots*
	  for node_list = (diana_get (db%source_record%tree record) 'as_list)
	  if (memq key node_list)
	  collect record into possibles
	  finally (cond ((eq (length possibles) 1) (return (first possibles)))
		        ((and (null possibles)
			      (db%generic_rootp root))
			 (return (db%add_generic_source root)))
			(t (lose 'pnt_no_tree 'db%node_to_tree
			       '("I can't find a tree to match a node."))))))
|#

; Lets turn off the generic stuff for now. Also, this time lets use a different
; scheme to find the appropriate tree. We call tree-memberp. It can look up
; to see if a node is a member of a tree.

(defun db%node_to_sroot (node)
  (loop for candidate in (db%path_to_sroots (source_region%path (diana_get node 'lx_srcpos)))
	if (or (tree-memberp node candidate)
	       (and (memq (diana_nodetype_get node)
			  '(dn_ct_task_handler dn_ct_exception_handler))
		    (tree-memberp (first (diana_get node 'ct_threadp)) candidate)))
	collect candidate into possibles
	finally (cond ((eq (length possibles) 1) (return (first possibles)))
		      ((null possibles)
		       (lose 'pnt_no_tree 'db%node_to_sroot
			     '("I can't find a tree to match a node.")))
		      (t (lose 'pnt_many_tree 'db%node_to_sroot
			       '("I found several possible trees for a node."))))))

; 
; Get a list of nodes of a type in node_set which best correspond to the 
; current cursor position in the code window. Get the cursor position.
; Translate it. Look for a diana subtree which corresponds to the file
; and then call the diana look up routine.
; 

(defun db%get_best_nodes (node_set)
  (let ((cursor_pos (db%ask_cursor *db%code_window*))
	(tree (get-iv db%debug_window *db%code_window* 'name))
	nodes)
    (cond ((not (and (diana_nodep tree) (eq (diana_nodetype_get tree) 'dn_compilation)))
	   (lose 'pnt_no_tree 'db%get_best_node
		 '("I dont have a tree for that file.")))
	  (t
	   (setq nodes
		 (get-best-nodes tree (ct_csend db%debug_window *db%code_window*
						':translate-screen-to-document
						(first cursor_pos) (second cursor_pos))
				 node_set))
	   (or (apply #'db%same_nodetypep nodes)
	       (lose 'pnt_diff_nodes 'db%get_best_node
		     '("The nodes found were of different types.")))
	   nodes))))

;
; Classify a node into one of three classes; normal nodes, generic copy nodes or
; generic definition nodes. Generic copies belong to an instantiation of a generic
; unit. Generic definitions belong to the definition of a generic unit. Normals 
; are everything that is left over.
;
;;out for now until we work out some of the problems with generics.
#|
(defun db%classify_node (node)
  (let ((root_self (ct_if (db%generic_rootp node)
			  node
			  (db%root node))))
    (cond ((not (or (and (diana_node_accepts_attributep node 'ct_generic_membership)
			 (diana_get node 'ct_generic_membership))
		    (db%generic_rootp node)))
	   'normal)
	  ((not (db%generic_rootp root_self)) 'generic_definition)
	  ((memq (db%classify_node
		   (first (diana_get (first (diana_get root_self 'ct_threadp))
				     'ct_threadp)))
		 `(normal generic_copy))
;	  ((eq (db%instantiation_depth root)
;	       (length (diana_get (diana_get root 'sm_body) 'ct_generic_membership)))
	   'generic_copy)
	  (t 'generic_definition))))
|#

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

; Out for now until we work out some of the problems
#|
;
; Find the generic instantiation depth of a node. We loop looking for successive
; ancestral roots of the node until we find one that is not a generic root. This 
; should be the top of the tree. Depth counts the number of generic roots which 
; we found.
;

(defun db%instantiation_depth (node)
  (loop for root = (db%root node) then (db%root (first (diana_get root 'ct_threadp)))
	for depth from 0
	while (db%generic_rootp root)
	finally (return depth)))

|#

;
; A predicate to determine if a list of diana nodes are all of the same type.
;

(defun db%same_nodetypep (&rest nodes)
  (loop with firsttype = (and (diana_nodep (first nodes)) (diana_nodetype_get (first nodes)))
	for node in (cdr nodes)
	always (and (diana_nodep node) (eq firsttype (diana_nodetype_get node)))))
	
; 
; Initialize the inbuilt trees by flattening them for diana finding later on.
; Remember the inbuilt map.
; 

(defun db%init_trees ()
  (setq *db%source_roots* nil)
  (and (boundp '*inbuilt_diana_trees*)
      (db%process_comp_units *inbuilt_diana_trees*))
  (setq *db%inbuilt_source_roots* *db%source_roots*))

;
; Initialize the pointing window. For now we just clear it out.
;

(defun db%init_window ()
  (ct_csend db%debug_window *db%code_window* ':display-string ""))

; 
; Get all the diana trees set up. Initilize the map from the inbuilts.
; Flatten the users trees.
; Gather up the files names and set the source file list. Put up the initial 
; display in the code window.
; 

(defun db%start_trees ()
  (db%message "Preparing program for debugging ...")
  (setq *db%source_roots* *db%inbuilt_source_roots*)
  (db%process_comp_units (diana_get *db%diana* 'as_list))
  (setq *db%choosable_files*
	(loop for sroot in *db%source_roots*
	      if (eq (diana_late_get sroot 'type) 'source)
	      collect (list (diana_late_get sroot 'path_string) sroot) into sources
	      if (eq (diana_late_get sroot 'type) 'library)
	      collect (list (diana_late_get sroot 'path_string) sroot) into libraries
	      if (eq (diana_late_get sroot 'type) 'environment)
	      collect (list (diana_late_get sroot 'path_string) sroot) into environments
	      finally (return (nconc (nreverse sources) libraries environments)))))

;
; Start up the pointing window. Clear it out first so that it forgets the out file.
; Then show the user the first choosable file.
;

(defun db%start_window ()
  (ct_csend db%debug_window *db%code_window* ':display-string "")
  (set-iv db%debug_window *db%code_window* 'name "The window with no name")
  (db%source_to_window *db%code_window* (second (first *db%choosable_files*)) 0 ':top))

; 
; Put the title on the window and position the cursor appropriately.
; 

(defun db%title_and_point (window sroot xy)
  (db%point_in_window window (first xy) (second xy))
  (set-iv db%debug_window window 'name sroot)
  (db%change_file_name (diana_late_get sroot 'path_string)))


; 
; Find the sroots associated with a path.
; 

(defun db%path_to_sroots (path)
  (loop for sroot in *db%source_roots*
	if (ct_string_equal path (diana_late_get sroot 'path))
	collect sroot))

; 
; Find the "root" for the diana tree containing node. We define the root
; as the comp unit if this is a normal node or a generic definition. If
; it is a generic instance, then we look for the id node which corresponds
; to the copy. Note that if we seach from below and find a generic root we
; call it the copy. If we start with the generic root then we search upward.
; 
;Not needed while we have all the generic stuff commented out
#|

(defun db%root (node)
  (loop for the_node = node then (first (diana_get the_node 'ct_threadp))
	if (not (diana_nodep the_node))
	do (lose 'pnt_no_root 'db%root
		 '("Can't find the root for a node."))
	if (or (eq (diana_nodetype_get the_node) 'dn_comp_unit)
	       (and (neq the_node node) (db%generic_rootp the_node)))
	return the_node))
|#
;
; Add a generic instantiation to the list of source trees. First look to see
; if this tree is already in the list. If not then we add it by cons'ing up
; a new dn_compilation. We make this dn_compilation look acceptable. 
; We form a special source_record by looking around for the strings to use
; for its title line. Also we set its top and bottom so that only the
; body of the generic will be viewable. Finally, we flatten the tree so that
; we can search it later.
; 
;;out for now while we work on a better scheme for generics.
#|
(defun db%add_generic_source (root)
  (let* ((body (diana_get root 'sm_body))
	 (spec (diana_get root 'sm_spec))
	 (path (source_region%path (diana_get body 'lx_srcpos)))
	 (new_record (loop for record in *db%source_roots*
			   if (memq body (diana_get (db%source_record%tree record)
						    'as_list))
			   return record))
	 new_node new_srcpos)
    (cond (new_record)
	  ((member path *db%hidden_files*) nil)
	  (t
	   (setq new_node (diana_cons 'dn_compilation))
	   (diana_put new_node (list body spec) 'as_list)
	   (diana_put new_node (source_region (- *plus-infinity* -1)
					      (1- *plus-infinity*)
					      0 0 path 0 0)
		      'lx_srcpos)
	   (diana_put new_node nil 'ct_threadp)
	   (setq new_srcpos (db%get_definition_source_range root))
	   (setq new_record
		 (db%source_record 'generic path
				   (ct_format nil "<~a>~13tInstantiation of ~a ~a"
					      'generic
					      (ct_selectq (diana_nodetype_get root)
							  (dn_proc_id "procedure")
							  (dn_function_id "function")
							  (dn_package_id "package"))
					      (apply #'ct_string_append
						     (second (diana_get root 'lx_symrep))))
				   (source_region%startchar new_srcpos)
				   (source_region%endchar new_srcpos)
				   new_node (source_region%startchar new_srcpos)))
	   (setq *db%source_roots*
		 (cons new_record *db%source_roots*))
	   (get-best-nodes new_node path nil nil)))
    new_record))
|#

;
; Get the source position for the declaration of the body of a generic unit. 
; First walk up the tree and over to the instantiation to find out what we are
; instantiating. Then find its defining occurence. Look for the body and finally,
; go up one node to get the declaration. When looking for the body declaration, 
; we look for a subprogram_decl for generic subprograms. This is a ct departure
; from standard diana.
;
;out for now while we work on a better scheme for generics
#|
(defun db%get_definition_source_range (root)
  (let* ((decl (first (diana_get root 'ct_threadp)))
	 (instant (ct_selectq (diana_nodetype_get decl)
				   (dn_subprogram_decl (diana_get decl 'as_subprogram_def))
				   (dn_package_decl (diana_get decl 'as_package_def))
				   (otherwise (lose 'pnt_gen_def
						    'db%get_definition_source_range
						    '("Cannot find generic definition")))))
	 (body (diana_get (db%diana_defineself (diana_get instant 'as_name)) 'sm_body)))
    (loop for daddy in (diana_get body 'ct_threadp)
	  if (memq (diana_nodetype_get daddy) '(dn_subprogram_decl dn_package_body))
	  return (diana_get daddy 'lx_srcpos)
	  finally (lose 'pnt_gen_body 'db%get_definition_source_range
			'("Cannot find the body declaration of a generic unit")))))
|#

;
; Process diana compilation units for diana finding. Loop over the list of
; compilation units. If the comp unit is for a hidden file do nothing. If this is
; the first time for this file then build a fake dn_compilation and add to the
; source to tree map. If we have seen the file already, then just put another 
; comp unit in the fake dn_compilation. Finally call get best node to flatten
; things. Note, get best node will remember which subtrees it has flattened
; already and hence may be called multiple times with the same subtree. Note,
; that when this processing takes place, there is a one to one correspondance
; between paths and trees. Later, when we start discovering generic subtrees,
; this will no longer hold.
;

(defun db%process_comp_units (comps)
  (loop with (nodes type)
	for comp_unit in comps
	for path = (source_region%path (diana_get comp_unit 'lx_srcpos))
	for sroot = (first (db%path_to_sroots path))
	do (cond ((member path *db%hidden_files*) nil)
		 ((null sroot)
		  (setq sroot (diana_cons 'dn_compilation))
		  (diana_put sroot (list comp_unit) 'as_list)
		  (diana_put sroot (source_region nil nil 0 0 path 0 0) 'lx_srcpos)
		  (diana_put sroot nil 'ct_threadp)
		  (setq type (cond ((memq comp_unit *inbuilt_diana_trees*)
				    'environment)
				   ((member path *db%source_files*) 'source)
				   (t 'library)))
		  (diana_late_put sroot type 'type)
		  (diana_late_put sroot path 'path)
		  (diana_late_put sroot (ct_format nil "<~a>~13t~a" type path) 'path_string)
		  (diana_late_put sroot 0 'position)
		  (setq *db%source_roots* (cons sroot *db%source_roots*)))
		 ((and (setq nodes (diana_get sroot 'as_list))
		       (not (memq comp_unit nodes)))
		  (diana_put sroot (cons comp_unit nodes) 'as_list))
		 (t (lose 'pnt_bad_tree 'db%process_comp_units
			  '("An error has occurred trying to collect trees")))))
  (flatten-diana-trees *db%source_roots*))

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