;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/datamon.l,v 1.18 85/06/27 10:20:24 bill Exp $
(putprop 'datamon "$Revision: 1.18 $" 'rcs_revision)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                            datamon.l                             ;;;
;;;                                                                  ;;;
;;; William Brew                                        9-10-83	     ;;;
;;;                                                                  ;;;
;;; Code for monitoring variables in the Ada debugger.		     ;;;
;;;                                                                  ;;;
;;; 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 'ctflav))  ;Flavors
   

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

(eval-when (compile load eval) (ct_load 'dianatags));Diana node tags package,flav

(eval-when (load eval) (ct_load 'nodenum))         ;Node numbering
  
#+franz
(eval-when (load eval) (ct_load 'screens))         ;Ask's
#+lispm
(eval-when (load eval) (ct_load 'lmscreens))       ;Ask's


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

(eval-when (compile load eval) (ct_load 'ctadadt)) ;Ada data types


(eval-when (load eval) (ct_load 'dianades))        ;The diana describer

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

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

; Specials declared elsewhere

(declare (special *db%user_window* *db%diana* *activation*))

#+franz
(declare (localf db%set_a_data_monitor db%get_new_dm_name db%collect_instances
		 db%remove_old_dm_hook db%remove_pending_dm_hook))

(defconst *db%monitorable_variables*
    '(dn_var_id dn_out_id dn_iteration_id dn_in_id dn_in_out_id)
    "A list of diana variable or variable like node types which may be
    monitored."
)

(defconst *db%monitorable_search_variables*
    (append1 *db%monitorable_variables* 'dn_used_name_id)
    "A list of diana variable or variable like node types which we search
    for when trying to set data monitors."
)

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

; 
; Set and get the value of the data tags list. We put the tags as a property of the
; diana tree so that the node list will remain in correspondance with any
; nodes in the tree which may be tagged.
; 

(defmacro db%set_diana_data_tags (tags)
    `(progn
	 (diana_late_put *db%diana* ,tags 'db%data_tags)
	 (ct_if ,tags
	     (diana_late_put *db%diana* '(db%field_new_data_instance)
		 'ctadadt_inithook
	     )
	     (diana_late_put *db%diana* nil 'ctadadt_inithook)
	 )
     )
)

(defmacro db%get_diana_data_tags ()
    `(diana_late_get *db%diana* 'db%data_tags)
)

; 
; Macros to add and remove data tags from the list of data tags. The list is
; in the form of an alist of diana node list and the corresponing data tag.
; 

(defmacro db%add_data_tag (nodes tag)
  `(db%set_diana_data_tags (cons (cons ,nodes ,tag) (db%get_diana_data_tags))))

(defmacro db%remove_data_tag (tag)
  `(let ((the_tags (db%get_diana_data_tags)))
     (db%set_diana_data_tags (delq (rassq ,tag the_tags) the_tags))))

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

; 
; A new tag flavor for data monitors. Add instance variables for remembering
; whether this is a before, after or init monitor and whether this is a break or
; trace monitor. Also the list of nodes found.
; 

(ct_defflavor db%data_monitor
    ((when 'before)		       ; Indicates before, after or init execution
     (type 'trace)		       ; Indicates break or just trace
     (node_list nil)                   ; The nodes being monitored
    )
    ()
    (:included-flavors db%vanilla_tag_flavor)
    #+lispm :initable-instance-variables
)

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

; 
; Initialize the code monitor module.
; 

(defun db%init_datamon ()
    nil
)

; 
; Startup the code monitor module.
; 

(defun db%start_datamon ()
    nil
)

; 
; Return the list of monitors which are set.
; 

(defun db%data_tags ()
    (loop for (nodes . tag) in (db%get_diana_data_tags)
	  collect tag))

; 
; Set a data monitor. Find the node by mapping the cursor position to a list of nodes
; in the diana tree. Then ask the user all the particulars for this data monitor.
; Then loop through the responses and set the monitors.
; 

(defun db%set_data_monitor ()
  (let ((nodes (mapcar #'db%diana_defineself
		       (db%get_best_nodes *db%monitorable_search_variables*)))
	name timing)
    (cond ((or (null nodes)
	       (loop for node in nodes
		     thereis (not (and (diana_nodep node)
				       (memq (diana_nodetype_get node)
					     *db%monitorable_variables*)))))
	   (db%message "What you are pointing at is not value monitorable."))
; Out for now until we have a better scheme for generics.
;	  ((eq (db%classify_node node) 'generic_definition)
;	   (db%message
;	     "What you are pointing at is in a generic definition and is unreachable."))
	  (t
	   (and (> (length nodes) 1)
		(db%message
		  "There is a generic ambiguity with the program element you have selected.
All instantiations will be monitored."))
	   (setq name (db%diana_printself (first nodes) nil))
	   (ct_format *db%user_window*
		      "Setting a value monitor on ~a.~%" name)
	   (setq timing (db%ask_multiple_literal "Monitoring time(s)? "
						 '(("Creation" creation)
						   ("Before a write" before)
						   ("After a write" after))
						 `("After a write" after)))
	   (loop for time in timing
		 do (db%set_a_data_monitor nodes time *db%user_window*))))))

;
; Remove a data monitor from the Ada program. If we have some monitors ask the
; user which one. Then try removing it. 
;

(defun db%remove_data_monitor ()
    (let* ((data_tags (db%data_tags))
	   (choices (append1 (loop for tag in data_tags
				   collect `(,(ct_csend db%data_monitor tag
						  'printself nil)
					      ,tag))
			     'all))
	   response)
	(cond ((null data_tags)
	       (db%message "There are no value monitors to remove."))
	      ((eq 'all (setq response (db%ask_literal "Which monitor? " choices)))
	       (db%remove_all_data_monitors))
	      (t (ct_csend db%data_monitor response 'removeself *db%user_window*)))))

; 
; Remove all data monitors which are currently set. Do so by looping over the
; list of data monitors and telling each to remove itself.
; 

(defun db%remove_all_data_monitors ()
    (loop for monitor in (db%data_tags)
	  do (ct_csend db%data_monitor monitor 'removeself nil))
    (db%set_diana_data_tags nil)
    (db%message "All value monitors have been removed."))

; 
; This function is put on the variable instance hooks. It merely redirects
; the processing to the data monitor.
; 

(defun db%field_data_monitor (object path nuval timing data_monitor)
    (ct_csend  db%data_monitor data_monitor 'fieldself object `(,path ,nuval)
	timing *db%user_window*))

; 
; This function is called when ever a new monitorable value is created.
; Check to see if the new instance corresponds to any that we are currently
; monitoring. If so then call the resetself method.
; 

(defun db%field_new_data_instance (object params diana_node timing)
  (loop for (nodes . tag) in (db%get_diana_data_tags)
	if (memq diana_node nodes)
	do (ct_csend db%data_monitor tag 'resetself object params diana_node
		     timing *db%user_window*)))

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

; 
; A method to read the when instance variable.
; 

(ct_defmethod (db%data_monitor when) ()
    when
)

; 
; A method for a monitor to set itself. First check that everything looks ok.
; If so then find all current instances of the object. For each of these, 
; remove any existing hook and set a new one. Finally, set up the instance vars
; and let the user know what happened.
; 

(ct_defmethod (db%data_monitor setself) (dnodes name how timing stream)
  (cond ((and dnodes
	      (loop for dnode in dnodes always (diana_nodep dnode))
	      (stringp name)
	      (memq how '(break trace))
	      (memq timing '(creation before after)))
	 (loop for dnode in dnodes
	       for instances = (db%collect_instances dnode)
	       do (ct_selectq timing
			      (before
				(loop for instance in instances
				      do (db%remove_old_dm_hook instance 'ct_prehook stream)
				      do (ct_send instance 'set-ct_prehook
						  `(db%field_data_monitor ,self)))
				(setq origin 'center))
			      (after
				(loop for instance in instances
				      do (db%remove_old_dm_hook instance 'ct_posthook stream)
				      do (ct_send instance 'set-ct_posthook
						  `(db%field_data_monitor ,self)))
				(setq origin 'center)))
	       do (db%remove_pending_dm_hook dnode timing stream))
	 (setq node_list dnodes
	       node (first dnodes)
	       pname name
	       when timing
	       type how)
	 (db%add_data_tag dnodes self)
	 (ct_format stream
		    "Value monitor ~a of type ~a ~a has been set.~%" name how timing)
	 self)
	(t
	 (lose 'db%dm_cant_dm 'setself '("Can't set data monitor"))
	 nil)))


;
; Reset a data monitor. This gets called when a new instance of a data object
; gets created and we decide that there is a data monitor for the variable
; corresponding to the new object. If we are looking for creation time activation
; then this is it. Otherwise, we just set up the hooks on the new object and
; return.
;

(ct_defmethod (db%data_monitor resetself) (object params dnode timing stream)
    (ct_if (memq dnode node_list)
	(ct_selectq when
	    (creation
		(ct_csend db%data_monitor self 'fieldself object (ncons params)
		    timing stream))
	    (before
		(db%remove_old_dm_hook object 'ct_prehook stream)
		(ct_send object 'set-ct_prehook `(db%field_data_monitor ,self)))
	    (after
		(db%remove_old_dm_hook object 'ct_posthook stream)
		(ct_send object 'set-ct_posthook `(db%field_data_monitor ,self))))
	(lose 'db%dm_mismatch 'resetself '("Mismatch between node and dm"))))

; 
; A method to remove a data monitor. We check to make sure the hook looks like
; what we think it should. If so then remove the function from the hook etc.
; 

(ct_defmethod (db%data_monitor removeself) (stream)
  (cond ((loop for dnode in node_list always (diana_nodep dnode))
	 (loop for dnode in node_list
	       do (ct_selectq when
			      (before
				(loop for instance in (db%collect_instances dnode)
				      if (equal (ct_send instance 'ct_prehook)
						`(db%field_data_monitor ,self))
				      do (ct_send instance 'set-ct_prehook nil)))
			      (after
				(loop for instance in (db%collect_instances dnode)
				      if (equal (ct_send instance 'ct_posthook)
						`(db%field_data_monitor ,self))
				      do (ct_send instance 'set-ct_posthook nil)))))
	 (db%return_node_num node self)
	 (db%remove_data_tag self)
	 (ct_format stream "Value monitor ~a has been removed.~%"
		    (ct_csend db%data_monitor self 'printself nil))
	 self)
	(t
	 (lose 'db%dm_remove 'removeself '("Can't remove pm"))
	 nil)))

; 
; A method which allows a data monitor to field itself when it is activated when
; its instance is processed by the interpretter. First we check to make sure 
; everything looks good. If so then print the trace message. If this is a break
; monitor then we enter the debugger. Iparms is a list of all the parameters 
; that were passed by the intepretter to the relevant method of the data instance,
; i.e. (path nuval) for writes, (params) for initializes. If this is a before or
; after monitor then do an auto describe of the node.
; 

(ct_defmethod (db%data_monitor fieldself) (object iparms timing stream)
   iparms
   (ct_if (and (memq (ct_send object 'def_occurence) node_list)
	       (eq timing when)
	       (memq self (db%data_tags)))
	  (let ((name (db%diana_printself node nil)))
	    (ct_format stream "<value monitor ~a activated ~a ~a>~%" pname
		       (cond ((eq when 'creation) "creating") (t when)) name)
	    (ct_selectq timing
			(creation)
			((before after)
			 (db%describe_id_node node
					  (cond ((eq (length node_list) 1) *activation*)
						(t 'multiple_nodes))
					  stream nil)
			 (ct_terpri stream)))
	    (ct_if (eq type 'break)
		   (db%enter_debugger "a value monitor break")))
	  (progn
	    (ct_csend db%data_monitor self 'removeself stream)
	    (lose 'db%bad_dm 'fieldself '("Bad value monitor.")))))

; 
; Set a data monitor on the given node with the given timing. Use the stream
; for messages. First cons up a new tag. Get the type of action desired. Get
; a valid name. Finally set the monitor.
; 

(defun db%set_a_data_monitor (nodes time stream)
  stream
  (let* ((tag (ct_make_instance 'db%data_monitor))
	 (how (db%ask_literal (ct_format nil "Action for the ~a monitor"
					 time
					 )
			      '(("Trace" trace) ("Break" break))))
	 (name (loop with tag_names = (mapcar #'(lambda (tag)
						  (ct_send tag 'printself nil))
					      (db%all_tags))
		     for new_name = (db%get_new_dm_name (first nodes) tag how time)
		     if (member new_name tag_names)
		     do (db%message "The tag name, ~a, is already in use. Try again."
				    new_name)
		     else return new_name)))
    (ct_csend db%data_monitor tag 'setself nodes name how time *db%user_window*)))

; 
; Generate a new data monitor name if the user didn't supply one. Build a string
; from the id of the node and other useful info.
; 

(defun db%get_new_dm_name (node tag how timing)
  (let ((name (db%ask_string (ct_format nil "Name for the ~a ~a monitor? "
					how timing)
			     'positive "<generated name>")))
    (db%return_node_num node tag)
    (ct_if (equal name "<generated name>")
	   (format nil "vm_~a~a_~2,48d" (ct_string_downcase (ct_character how))
		   (ct_string_downcase (ct_character timing)) (db%get_node_num node tag))
	   name)))

; 
; Collect up all active instantiations of a variable like node. First get the
; defining occurence of the node. Then loop through all the activations. If
; we find the correct program nesting level and the node is represented in the
; locals then we collect its instantiation.
; 

(defun db%collect_instances (node)
    (setq node (db%diana_defineself node))
    (loop with instance = nil
          for act = (and (boundp '*activation*) *activation*)
	          then (get-iv adabe_activation act 'clink)
	  until (null act)
	  if (and (equal (get-iv adabe_activation act 'pnl)
		         (diana_get node 'ct_pnl)
		  )
		  (setq instance
		        (cdr (assq node (get-iv adabe_activation act 'locals)))
		  )
	     )
	  collect instance
    )
)

; 
; Remove an old hook from a variable instance prior to setting a new one.
; If there is a hook value and it looks like one of ours then try telling the
; tag to remove itself.
; 

(defun db%remove_old_dm_hook (instance hook_name stream)
  (let ((old_hook (ct_selectq hook_name
			      (ct_prehook (ct_send instance 'ct_prehook))
			      (ct_posthook (ct_send instance 'ct_posthook)))))
    (cond ((and old_hook
		(listp old_hook)
		(eq (first old_hook) 'db%field_data_monitor)
		(instancep (setq old_hook (car (last old_hook))))
		(or (get-handler-for old_hook 'removeself)
		    (get-handler-for old_hook ':removeself)))
	   (ct_format stream "<A value monitor already exists. It will be removed.>~%")
	   (ct_csend db%data_monitor old_hook 'removeself stream)))))

; 
; Remove an old hook from a variable instance prior to setting a new one.
; If there is a hook value and it looks like one of ours then try telling the
; tag to remove itself. Write the warning message here also because there may not have
; been any instances with the monitor on them already which we would have found
; with remove_old_dm_hook.
; 

(defun db%remove_pending_dm_hook (diana_node timing stream)
  (loop	for (nodes . tag) in (db%get_diana_data_tags)
	if (and (memq diana_node nodes)
		(eq (get-iv db%data_monitor tag 'when) timing))
	do (ct_format stream "<A value monitor already exists. It will be removed.>~%")
	and do (ct_csend db%data_monitor tag 'removeself stream)))

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