;;; -*- Mode: LISP; Package: USER; Base: 10 -*-
;;; $Header: /ct/debug/envirwalk.l,v 1.21 85/06/27 10:22:07 bill Exp $
(putprop 'envirwalk "$Revision: 1.21 $" 'rcs_revision)
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                  ;;;
;;;                          envirwalk.l                             ;;;
;;;                                                                  ;;;
;;; William Brew                                          8-11-83    ;;;
;;;                                                                  ;;;
;;; Lisp code for walking the dynamic environment in the C*T 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 'dlist))   ; Double list package


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

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

(eval-when (compile load eval) (ct_load 'dianades)) ; Diana desciber

#+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 'ferec))   ; Interpretter records

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

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

(eval-when (compile load eval) (ct_load 'queue))   ; Task rec flavor

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

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

; Record for activations. Depth is the dynamic calling depth, act points
; to the flavor instance for this activation.

(def_record_type db%act *DBACT* (depth . act))

(defvar *db%current_dlact* nil
    "*db%current_dlact is a pointer into a dlist to the current activation record
    which we are interested in. This var
    should be setup (along with the rest of the stack) whenever the debugger
    is entered. Successor links point towards the top of the stack.
    Predecessor links point towards the bottom."
)

(defvar *db%top_dlact* nil
    "*db%top_dlact* is a pointer to the dlcell for the activation record at
    the top of the calling stack."
)

(defvar *db%bottom_dlact* nil
    "*db%bottom_dlact* is a pointer to the dlcell for the activation record at
    the bottom of the calling stack."
)

(defvar *db%envirnwalk_tags* nil
    "A list of tags for the environment walker"
)

(defvar *db%current_pc_tag* nil
    "The tag associated with the pc of the currently selected activation."
)

(defvar *db%true_pc_tag* nil
    "The tag associated with the true pc of the diana virtual machine."
)

(defvar *db%auto_reposition* #+franz 'entry #+lispm 'always
    "A flag which indicates whether to position the code window over the pc
    whenever we change activations. Always implies always reposition. Never
    implies never reposition. Entry implies reposition only on entry to the
    debugger."
)

(defvar *db%activation_verbosity* 'auto
    "A flag indicating how much is to be printed when an activation is shown.
    Verbose implies show all locals. Brief implies show only the description.
    Auto implies brief or verbose depending on how many activations are being
    shown."
)

(defvar *db%current_task* nil
    "Points to the task which the debugger is currently interested in."
)

; 
; Declare specials.
; 

(declare (special *db%user_window* *db%code_window* *current_task*))

#+franz
(declare (localf db%top_stack db%bottom_stack db%step_up_stack
	     db%step_down_stack db%show_some_stack db%pp_activation
	     db%start_stack_tags db%verbity db%show_some_tasks
	     db%pp_task_family db%select_a_task
	 )
)

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

; Get the interpretter activation associated with a dlact.

(defmacro db%get_activation (dlact)
    `(cond (,dlact (db%act%act (dlval ,dlact))))
)

; Get the block associated with a dl activation.

(defmacro db%get_block (dlact)
    `(cond (,dlact
	    (db%diana_defineself
		(diana_get
		    (db%diana_defineself
			(get-iv adabe_activation (db%get_activation ,dlact) 'node))
		    'sm_body
		)
	    )
	   )
     )
)

; Get the pc for a dlact. (Assumes the pc has been set in *activation*)

(defmacro db%get_pc (dlact)
    `(cond (,dlact (get-iv adabe_activation (db%get_activation ,dlact) 'pc)))
)

; 
; Check to see if we should reposition the code window after moving. We don't do
; anything if there is no tag or no stack.
; 

(defmacro db%maybe_position_window (tag when)
    `(and ,tag
	  *db%current_dlact*
	  (or (eq *db%auto_reposition* 'always)
	      (eq *db%auto_reposition* ,when)
	  )
	  (ct_csend db%vanilla_tag_flavor ,tag 'displayself *db%code_window*
	      *db%user_window*
	  )
     )
)

; 
; Try to display an activation. Check to see if there is one. If so then pp it.
; Otherwise let the user know there is no stack.
; 

(defmacro db%maybe_pp_activation (dlact stream count)
    `(ct_if ,dlact
	 (db%pp_activation ,dlact ,stream (db%verbity ,count))
	 (db%message "There is no activation stack.")
     )
)

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

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

; 
; Initialize the environment walker
; 

(defun db%init_envirwalk ()
    nil)

; 
; Startup the environment walker
; 

(defun db%start_envirwalk ()
    (db%start_stack_tags))

; 
; A function to return the list of envirnwalk tags. Check to make sure we really
; have some activations
; 

(defun db%envirnwalk_tags ()
  (and *db%current_dlact* *db%envirnwalk_tags*))

; 
; Get the stack history from the interpreter and massage it for our use.
; First gather up all the activation records into a dlist. Then run back
; the other direction and number them according to their depth. Finally,
; set up the current activation pointer. Note the stack may be null.
; If things look correct, then we set up the pc in then current activation and
; the activation in the current task.
;

(defun db%get_envirnment (intask &aux inact)
  (cond (intask
	 (setq *db%current_task* intask)
	 (setq inact (get-iv task_queue_entry intask 'value)))
	(t
	 (setq *db%current_task* nil)
	 (setq inact nil)))
  (setq *db%bottom_dlact* nil)
  (loop for iact = inact then (get-iv adabe_activation iact 'clink)
	while iact
	do (setq *db%bottom_dlact* (dlinfirst *db%bottom_dlact* (db%act 0 iact))))
  (setq *db%top_dlact* (loop for dlact = *db%bottom_dlact*
			     then (dlsucc dlact)
			     for i from 0
			     if dlact do (%= (db%act%depth (dlval dlact)) i)
			     unless (dlsucc dlact) return dlact))
  (setq *db%current_dlact* *db%top_dlact*)
  (db%maybe_position_window *db%current_pc_tag* 'entry))

; 
; Make the current activation the top of the stack. Show it to the user.
; 

(defun db%top_of_stack ()
  (ct_if *db%current_dlact*
	 (db%top_stack *db%user_window*)
	 (db%message "There is no activation stack.")))

; 
; Make the current activation the bottom of the stack. Show it to the user.
; 

(defun db%bottom_of_stack ()
  (ct_if *db%current_dlact*
	 (db%bottom_stack *db%user_window*)
	 (db%message "There is no activation stack.")))

; 
; Move up the activation stack. Ask the user how many steps.
; 

(defun db%up_stack ()
  (ct_if *db%current_dlact*
	 (db%step_up_stack (db%ask_integer "How many steps up?" 0 'positive 1)
			   *db%user_window*)
	 (db%message "There is no activation stack.")))

; 
; Move down the activation stack. Ask the user how many steps.
; 

(defun db%down_stack ()
  (ct_if *db%current_dlact*
	 (db%step_down_stack (db%ask_integer "How many steps down?" 0 'positive 1)
			     *db%user_window*)
	 (db%message "There is no activation stack.")))

; 
; Show the calling stack to the user. Ask them how much.
; 

(defun db%show_stack ()
  (ct_if *db%current_dlact*
	 (db%show_some_stack (db%ask_literal "How much of the stack?"
					     '(("Current activation" current)
					       ("Current activation to the top" up)
					       ("Current activation to the bottom" down)
					       ("All activations" all)))
	                     *db%user_window*)
	 (db%message "There is no activation stack.")))

; 
; Show the task hierarchy to user. 
; 

(defun db%show_tasks ()
  (cond ((and (boundp '*db%current_task*) *db%current_task*) (db%show_some_tasks))
	(t (db%message "There are no tasks."))))

; 
; Select a task for use by the debugger. This is used to get a stack for evaluation
; of variables and for the stack walking commands.
; 

(defun db%select_task ()
  (cond ((and (boundp '*db%current_task*) *db%current_task*) (db%select_a_task))
	(t (db%message "There are no tasks."))))


; 
; Get the diana node for the pc of the current activation.
; 

(defun db%current_pc ()
    (db%get_pc *db%current_dlact*))

; 
; Get the diana node for the pc of the top activation.
; 

(defun db%top_pc ()
    (db%get_pc *db%top_dlact*))

; 
; Return the diana node for the body of the current activation.
; 

(defun db%current_block ()
    (db%get_block *db%current_dlact*))

; 
; Return the diana node for the body of the top activation.
; 

(defun db%top_block ()
    (db%get_block *db%top_dlact*))

; 
; Return the current interpretter activation record.
; 

(defun db%current_activation ()
    (db%get_activation *db%current_dlact*))

; 
; Return the top interpretter activation record.
; 

(defun db%top_activation ()
    (db%get_activation *db%top_dlact*))

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

; 
; Make the current activation the top of the stack. Show it to the user.
; 

(defun db%top_stack (stream)
    (setq *db%current_dlact* *db%top_dlact*)
    (db%maybe_pp_activation *db%current_dlact* stream 1)
    (db%maybe_position_window *db%current_pc_tag* nil) 
    *db%current_dlact*
)

; 
; Make the current activation the bottom of the stack. Show it to the user.
; 

(defun db%bottom_stack (stream)
    (setq *db%current_dlact* *db%bottom_dlact*)
    (db%maybe_pp_activation *db%current_dlact* stream 1)
    (db%maybe_position_window *db%current_pc_tag* nil) 
    *db%current_dlact*
)

; 
; Move the current activation up the stack by <step> activations (or as far
; as we can go). Run up the successor links and then show the user where
; we are.
; 

(defun db%step_up_stack (steps stream)
    (setq *db%current_dlact* (loop for dlact = *db%current_dlact*
			           then (dlsucc dlact)
				   while dlact
				   repeat steps
				   while (dlsucc dlact)
				   finally (return dlact)
			     )
    )
    (db%maybe_pp_activation *db%current_dlact* stream 1)
    (db%maybe_position_window *db%current_pc_tag* nil) 
    *db%current_dlact*
)

; 
; Move the current activation down the stack by <step> activations (or as far
; as we can go). Run down the predecessor links and then show the user where
; we are.
; 

(defun db%step_down_stack (steps stream)
    (setq *db%current_dlact* (loop for dlact = *db%current_dlact*
			           then (dlpred dlact)
				   while dlact
				   repeat steps
				   while (dlpred dlact)
				   finally (return dlact)
			     )
    )
    (db%maybe_pp_activation *db%current_dlact* stream 1)
    (db%maybe_position_window *db%current_pc_tag* nil) 
    *db%current_dlact*
)

; 
; Show the dynamic calling history of the ADA program. The parameter
; tells how much to show, all of the stack, everything from the top to
; "here", everything from "here" to the bottom, or the current activation
; ("here"). The display is done by running over the activation stack and
; calling the print activation function.
; 

(defun db%show_some_stack (amount stream)
  (let (strings)
    (ct_if *db%current_dlact*
	   (setq strings
		 (ct_selectq amount
			     (all (loop for dlact = *db%bottom_dlact* then (dlsucc dlact)
					while dlact
					collect (db%pp_activation dlact stream
								  (db%verbity 2))))
			     (down (loop for dlact = *db%bottom_dlact*
					 then (dlsucc dlact)
					 while dlact
					 collect (db%pp_activation dlact stream
								   (db%verbity 2))
					 until (eq dlact *db%current_dlact*)))
			     (up (loop for dlact = *db%current_dlact* then (dlsucc dlact)
				       while dlact
				       collect (db%pp_activation dlact stream
								 (db%verbity 2))))
			     (current (db%pp_activation *db%current_dlact* stream
							(db%verbity 1)))))
	   (setq strings nil))
    (cond (stream nil)
	  ((null strings) "")
	  (t (apply 'string-append strings)))))

; 
; Print a message in the user interaction window describing the activation
; record. Mark the top, bottom and current activations. Print the calling
; depth and then tell the activation to pretty print itself. Dlact is a pointer
; to a dlcell containing a db%act record.
; 

(defun db%pp_activation (dlact stream verbity)
    (ct_if dlact
	(let* ((prinlength 8.)
	       (prinlevel 2.)
	       (act (db%get_activation dlact))
	       (locals (ct_if verbity (db%pp_locals act nil) ""))
	      )
	    (ct_format stream "~2a~3a ~3d  ~a~a~%~a"
		(cond ((eq dlact *db%top_dlact*) "T")
		      ((eq dlact *db%bottom_dlact*) "B")
		      (t " ")
		)
		(cond ((eq dlact *db%current_dlact*) "-->")
		      (t "   ")
		) 
		(db%act%depth (dlval dlact))
		(db%describe_node (get-iv adabe_activation act 'node) nil nil)
		(ct_if (equal locals "")
		    ""
		    " with local variables"
		)
		locals	
	    )
	)
	(lose 'db%env_bad_pp 'db%pp_activation '("tried to pp a non activation"))
    )
    dlact
)

; 
; Print the local variables of an activation. Locals are an alist of diana node and
; data type instance pairs. Check to make sure the instance knows how to print
; itself and that it isn't one of the "internal only" type.
;

(defun db%pp_locals (act stream)
  (let ((strings
	  (loop for (dnode . instance) in (ct_csend adabe_activation act 'locals)
		if (and (or (get-handler-for instance 'printself)
			    (get-handler-for instance ':printself))
			(not (memq (typep instance)
				   '(dt_entry_type dt_task_type dt_type_type))))
		collect (ct_format stream "~15@T~a = ~a~%"
				   (apply #'ct_string_append 
					  (second (diana_get dnode 'lx_symrep)))
				   (ct_send instance 'printself nil)))))
    (cond (stream nil)
	  ((null strings) "")
	  (t (apply #'ct_string_append strings)))))
		   
; 
; Select a task for the debugger to use.
; 

(defun db%select_a_task ()
    (let* ((root (loop for task = *db%current_task* then mommy
		       for mommy = (get-iv task_queue_element task
				           'superior_task)
		       unless mommy return task))
	   (tasks (db%itemize_task_family root))
	   (newtask (db%ask_literal "Which task? " tasks
			       (list (get-iv task_queue_entry *current_task* 'name)
				     *current_task*))))
	(db%get_envirnment newtask)
	(db%message "Task ~a has been selected." (get-iv task_queue_entry newtask 'name))))

; 
; Collect up all the inferiors of a task into a list appropriate for
; db%ask_literal. Collect things up in reverse order because the list of
; inferiors seems to be reversed already.
; 

(defun db%itemize_task_family (task)
    (cons (list (get-iv task_queue_entry task 'name) task)
	  (loop with result
		for child in (get-iv task_queue_entry task 'inferior_tasks)
		do (setq result (nconc (db%itemize_task_family child) result))
		finally (return result))))

; 
; Print the current tasking hierarchy for the user. First find the root task.
; Then call the pretty printer on it.
; 

(defun db%show_some_tasks ()
    (let ((root (loop for task = *db%current_task* then mommy
		      for mommy = (get-iv task_queue_element task
				          'superior_task)
		      unless mommy return task)))
	(with-output-buffered *db%user_window*
	    (db%pp_task_family root *db%user_window* 0))))

;
; Pretty print a description of a task family. Level is the nesting depth
; of the task. First format a line describing the task. Then recurse and 
; describe all the children.
; 

(defun db%pp_task_family (task stream level)
  (let (strings
	(string1
	  (ct_format stream "~a~a ~v@T~a, priority = ~d~a~a~%"
		     (ct_if (and *db%current_task*
				 (boundp '*current_task*)
				 (eq task *current_task*))
			    "* "
			    "  ")
		     (ct_if (eq task *db%current_task*) "-->" "   ")
		     (* level 2)
		     (get-iv task_queue_element task 'name)
		     (get-iv task_priority_queue
			     (get-iv task_queue_element task 'myqueue)
			     'priority)
		     (ct_if (get-iv task_queue_element task 'runnable_p)
			 ", runnable"
			 "")
		     (ct_if (get-iv task_queue_element task 'terminated)
			 ", terminated"
			 ""))))
    (setq strings
	  (loop for child in (reverse (get-iv task_queue_entry task 'inferior_tasks))
		unless stream collect (db%pp_task_family child stream (1+ level))
		else do (db%pp_task_family child stream (1+ level))))
    (cond (stream nil)
	  ((null strings) "")
	  (t (apply #'ct_string_append (cons string1 strings))))))
    

; 
; Initialize the tags associated with the activation stack. Make the tags and
; put them on the envirnwalk tags list.
; 

(defun db%start_stack_tags ()
  (setq *db%envirnwalk_tags*
	(list
	  (setq *db%true_pc_tag*
		(db%make_stack_tag "True pc"
				   "The pc of the top activation." '(db%top_pc) 'top))
	  (setq *db%current_pc_tag*
		(db%make_stack_tag "Current pc"
				   "The pc of the currently selected activation."
				   '(db%current_pc)
				   'top))
	  (db%make_stack_tag "Top of activation"
			     "The top of the currently selected activation."
			     '(db%current_block)
			     'top)
	  (db%make_stack_tag "Bottom of activation"
			     "The bottom of the currently selected activation."
			     '(db%current_block) 'bottom 'bottom))))

; 
; A utility function for making stack tags. A new tag is created.
; It is given the indicated pname, description and node
; function. If present, origin and over_origin are set.
; 

(defun db%make_stack_tag (pname description node_func
			       &optional (origin 'center) (over_origin 'top)
			 )
    (ct_make_instance 'db%vanilla_tag_flavor
	'pname pname
	'description description
	'node node_func
	'origin origin
	'over_origin over_origin
    )
)
			
; 
; A function to determine how much we should show when printing activations.
; 


(defun db%verbity (count)
    (cond ((and (eq *db%activation_verbosity* 'auto) (> count 1)) nil)
	  ((and (eq *db%activation_verbosity* 'auto) (<= count 1)) t)
    	  ((eq *db%activation_verbosity* 'verbose) t)
	  ((eq *db%activation_verbosity* 'brief) nil)
	  (t (lose 'db%env_verbity 'db%verbity '("No such verbosity")))
    )
)

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