;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/codemon.l,v 1.14 84/11/06 10:59:04 bill Exp $
(putprop 'codemon "$Revision: 1.14 $" 'rcs_revision)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                            codemon.l                             ;;;
;;;                                                                  ;;;
;;; William Brew                                        9-10-83	     ;;;
;;;                                                                  ;;;
;;; Code for monitoring statements 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 utils

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

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

#+franz
(declare (localf db%set_a_code_monitor db%get_new_cm_name db%remove_old_cm_hook))

(defconst *db%monitorable_statements*
    '(dn_abort dn_accept dn_assign dn_block dn_case dn_code dn_delay
	 dn_entry_call dn_exit dn_function_call dn_goto dn_if dn_loop
	 dn_null_stm dn_procedure_call dn_raise dn_return dn_select
	 dn_terminate dn_comp_unit dn_constant dn_exception
	 dn_number dn_package_decl dn_subprogram_decl dn_subtype
	 dn_task_decl dn_type dn_var
     )
    "A list of diana statement or statement like node types which may be
    monitored."
)

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

; 
; Set and get the value of the code 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_code_tags (tags)
    `(diana_late_put *db%diana* ,tags 'db%code_tags)
)

(defmacro db%get_diana_code_tags ()
    `(diana_late_get *db%diana* 'db%code_tags)
)

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

(defmacro db%add_code_tag (tag)
    `(db%set_diana_code_tags (cons ,tag (db%get_diana_code_tags)))
)

(defmacro db%remove_code_tag (tag)
    `(db%set_diana_code_tags (delq ,tag (db%get_diana_code_tags)))
)

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

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

(ct_defflavor db%code_monitor
    ((when 'before)		       ; Indicates before or after node 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_codemon ()
    nil)

; 
; Startup the code monitor module.
; 

(defun db%start_codemon ()
    nil)

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

(defun db%code_tags ()
    (db%get_diana_code_tags))

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

(defun db%set_code_monitor ()
  (let ((nodes (db%get_best_nodes *db%monitorable_statements*))
	descrip timing)
    (cond ((or (null nodes)
	       (loop for node in nodes thereis (not (diana_nodep node))))
	   (db%message "What you are pointing at is not program monitorable."))
; out for now until we have a better scheme
;	  ((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 descrip (db%diana_describeself (first nodes) nil))
	   (ct_format *db%user_window*
		      "Setting a program monitor on ~a ~a.~%"
		      (db%proper_article_for descrip) descrip)
	   (setq timing
		 (db%ask_multiple_literal "Monitoring time(s)? "
					  '(("Before execution or elaboration" before)
					    ("After execution or elaboration" after))))
	   (loop for time in timing
		 do (db%set_a_code_monitor nodes time *db%user_window*))))))

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

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

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

(defun db%remove_all_code_monitors ()
  (loop for monitor in (db%code_tags)
	do (ct_csend db%code_monitor monitor 'removeself nil))
  (db%set_diana_code_tags nil)
  (db%message "All program monitors have been removed."))

; 
; This function is put on the diana node hooks. It merely redirects the processing
; to the code monitor.
; 

(defun db%field_code_monitor (node timing code_monitor)
  (ct_csend db%code_monitor code_monitor 'fieldself node timing *db%user_window*))

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

; 
; A method for a monitor to set itself. First check that everything looks ok.
; If so then set the appropriate instance variables. Finally, put the hook 
; on the diana node.
; 

(ct_defmethod (db%code_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 '(before after)))
	 (ct_selectq timing
		     (before
		       (loop for dnode in dnodes
			     do (db%remove_old_cm_hook dnode 'ct_prehook stream)
			     do (diana_put dnode `(db%field_code_monitor ,self) 'ct_prehook))
		       (setq origin 'top))
		     (after
		       (loop for dnode in dnodes
			     do (db%remove_old_cm_hook dnode 'ct_posthook stream)
			     do (diana_put dnode `(db%field_code_monitor ,self) 'ct_posthook))
		       (setq origin 'bottom)))
	 (setq node_list dnodes
	       node (first dnodes)
	       pname name
	       when timing
	       type how)
	 (db%add_code_tag self)
	 (ct_format stream
		    "Program monitor ~a of type ~a ~a has been set.~%" name how timing)
	 self)
	(t
	 (lose 'db%cm_cant_cm 'setself '("Can't set code monitor"))
	 nil)))

; 
; A method to remove a code 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%code_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
				(ct_if (equal (diana_get dnode 'ct_prehook)
					      `(db%field_code_monitor ,self))
				       (diana_put dnode nil 'ct_prehook)))
			      (after
				(ct_if (equal (diana_get dnode 'ct_posthook)
					      `(db%field_code_monitor ,self))
				       (diana_put dnode nil 'ct_posthook)))))
	 (db%return_node_num node self)
	 (db%remove_code_tag self)
	 (ct_format stream "Program monitor ~a has been removed.~%"
		    (ct_csend db%code_monitor self 'printself nil))
	 self)
	(t 
	 (lose 'db%cm_remove 'removeself '("Can't remove pm"))
	 nil)))

; 
; A method which allows a code monitor to field itself when it is activated when
; its node 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.
; 

(ct_defmethod (db%code_monitor fieldself) (diana_node timing stream)
    (ct_if (and (memq diana_node node_list) (eq timing when) (memq self (db%code_tags)))
	(let ((descrip (db%diana_describeself node nil)))
	    (ct_format stream "<program monitor ~a activated ~a ~a ~a>~%"
		pname when (db%proper_article_for descrip) descrip)
	    (ct_if (eq type 'break)
		(db%enter_debugger "a program break")))
	(progn
	    (ct_csend db%code_monitor self 'removeself stream)
	    (lose 'db%cm_bad_cm 'fieldself '("Bad program monitor.")))))

; 
; Set a code 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_code_monitor (nodes time stream)
  stream
  (let* ((tag (ct_make_instance 'db%code_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_cm_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%code_monitor tag 'setself nodes name how time *db%user_window*)))

; 
; Generate a new code 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_cm_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 "pm_~a~a_~2,48d" (ct_string_downcase (ct_character how))
		   (ct_string_downcase (ct_character timing)) (db%get_node_num node tag))
	   name)))

; 
; Remove the old hook from a diana node 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_cm_hook (node hook_name stream)
  (let ((old_hook (diana_get node hook_name)))
    (cond ((and old_hook
		(listp old_hook)
		(eq (first old_hook) 'db%field_code_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 program monitor already exists. It will be removed.>~%")
	   (ct_csend db%code_monitor old_hook 'removeself stream)))))

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