;;; -*- Mode: LISP; Package: USER; Base: 10 -*- ;;; $Header: /ct/debug/adabugger.l,v 1.28 85/06/27 10:19:18 bill Exp $ (putprop 'adabugger "$Revision: 1.28 $" 'rcs_revision) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; adabugger.l ;;; ;;; ;;; ;;; William Brew 9-6-83 ;;; ;;; ;;; ;;; The main module of the debugger proper of 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 'protect)) ;Software protection ; Pull in the various parts of the debugger proper (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 'envirwalk)) ; The stack walker (eval-when (load eval) (ct_load 'dianades)) ; The diana describer (eval-when (load eval) (ct_load 'codemon)) ; The code monitors (eval-when (load eval) (ct_load 'datamon)) ; The data monitors #+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 'driver)) ; The back end driver (hooks) (eval-when (compile load eval) (ct_load 'adabe)) ; Activation rec flavor (eval-when (compile load eval) (ct_load 'queue)) ; Queue flavors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) #+franz (setq *flavor-expand-macros* t) (defvar *db%tag_funs* `(db%envirnwalk_tags db%describer_tags db%code_tags db%data_tags ) "A list of tag list functions. Each returns a list of tags for some module in the debugger." ) (defvar *db%debug_diana* nil "Gets bound to the current diana tree when the debugger is started. Useful for debugging the debugger." ) (defconst *db%verbose_tags* nil "A switch which indicates whether to give full or brief descriptions of tags when we are asked to display them." ) (defconst *db%steppable_nodes* '(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_constant dn_exception dn_number dn_package_decl dn_subprogram_decl dn_subtype dn_package_id ;so package elaboration acts right dn_task_decl dn_type dn_var ) "A list of diana statement or statement like node types which may be single stepped.") (defconst *db%compound_nodes* '(dn_block dn_case dn_entry_call dn_function_call dn_if dn_loop dn_procedure_call dn_select dn_package_decl dn_subprogram_decl dn_task_decl dn_package_id) ;so package elaboration acts right "A list of diana statement or statement like node types which may contain other statement or statement like nodes.") ;;; These are obsolete now. (defvar *db%suspend* nil "Flag used to indicate that we wish to suspend the interpreter.") (defvar *db%abort* nil "Flag used to indicate that we wish to abort the interpreter.") ; Specials declared elsewhere (declare (special *db%user_window* *db%code_window* *activation* pc *current_task* *db%true_pc_tag* *db%release* *exception_name* *exception_reason*)) ; The parameters to the top function (db%debugger) are also special. (declare (special *db%how_started* *db%diana* *db%listing* *db%errorin* *db%errorout* *db%userin* *db%userout*)) ; And some more specials bound in db%debugger (declare (special *db%start_up_debugger* *db%inside_ada* *db%why_entered* *db%step_mode* *db%step_break* *db%accepting_commands* *db%start_up_executor* *db%start_up_checker* *db%debugger_mode* *db%ada_has_been_run* *db%ada_resumable*)) #+franz (declare (localf db%push_diana_stack db%pop_diana_stack db%compound_stepp)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Macro definitions -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Flavor definitions -- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Callable Functions/Methods -- ; ; Initialize the adabugger module. Set up pointers to get the various tags in ; the system. ; (defun db%init_adabugger () (setq *db%tag_funs* `(db%envirnwalk_tags db%describer_tags db%code_tags db%data_tags))) ; ; Startup the adabugger module. ; (defun db%start_adabugger () nil) ; ; ; Startup the debugger proper. ; (defun db%start_debugger () (db%initial_debugger_screen) (db%message "Welcome to the C*T Ada debugger on ~a." (protect 'debugger)) (db%message "Preparing program for execution ...") (diana_threadify *db%diana*) (db%init_debugger) ; Just in case (db%start_adabugger) ; Startup the main module (db%start_nodenum) ; Startup the node to number map module (db%start_dianatags) ; Startup the tags (db%start_datades) ; Startup the data describer (db%start_dianades) ; Startup the describer (db%start_envirwalk) ; Startup the environment walker (db%start_codemon) ; Startup the code monitors (db%start_datamon) ; Startup the data monitors (db%start_dbutils) ; Startup the utilities (db%start_point) ; Startup the pointing utilities (setq *db%start_up_debugger* nil)) ; ; Start up the executor proper. ; (defun db%start_executor () (db%initial_executor_screen) (db%message "Welcome to the C*T Ada executor on ~a." (protect 'debugger)) (db%message "Preparing program for execution ...") (diana_threadify *db%diana*) (db%init_debugger) ; Just in case (db%start_adabugger) ; Startup the main module (db%start_dbutils) ; Startup the utilities (setq *db%start_up_executor* nil)) ; ; Start up the checker proper. ; (defun db%start_checker () (db%initial_checker_screen) (db%message "Welcome to the C*T Ada checker on ~a." (protect 'debugger)) (db%init_debugger) ; Just in case (db%start_adabugger) ; Startup the main module (db%start_dbutils) ; Startup the utilities (setq *db%start_up_checker* nil)) ; Start the debugger and set the quit and start catch points etc. ; Call protect to make sure we are a legal copy for this site etc. ; If how started is t, then we want to start debugging right away. Otherwise, wait ; until we are entered via an interrupt or an error. ; If this is the first time to start then make the windows and enter the debugger. ; Then call the interpretter back end to do its thing. ; Not the we prevent resumption unless there is actually a backend running. ; Depending on how we were started, we either enter the debugger when finished or ; quit. ; (defun db%debugger (*db%how_started* *db%diana* *db%listing* *db%errorin* *db%errorout* *db%userin* *db%userout*) (let ((*db%start_up_debugger* t) (*db%start_up_executor* t) (*db%start_up_checker* t) (*db%ada_has_been_run* nil) (*db%inside_ada* nil) (*db%ada_resumable* nil) (*db%debugger_mode* (ct_if (diana_nodep *db%diana*) *db%how_started* 'check_mode)) (*db%accepting_commands* nil) (*db%why_entered* "debugger start up") (*db%step_mode* '(proceed nil)) (*db%step_break* nil)) (setq *db%debug_diana* *db%diana*) (*catch 'db%quit_point (loop do (*catch 'db%init_point (progn (ct_if (not (soft-protect 'debugger)) (*throw 'db%quit_point 'protect)) (ct_selectq *db%debugger_mode* (debug_mode (*catch 'db%start_point (db%enter_debugger "initial start up"))) (execute_mode (*catch 'db%start_point (db%enter_executor "initial start up"))) (check_mode (*catch 'db%start_point (db%enter_checker "initial start up"))) (otherwise (lose 'bad_mode 'db%debugger))) (db%debugger_backend))))))) ; ; This is the function that actually runs all the debugger back end stuff. ; Basicly, we set up some catch points and loop running the interpreter and ; looking for commands. ; (defun db%debugger_backend () (loop with result do (*catch 'db%start_point (progn (setq *db%suspend* nil) (setq *db%abort* nil) (setq *db%step_break* nil) (setq *db%ada_has_been_run* t) (setq result (ct_selectq *db%debugger_mode* (debug_mode (db%run_diana_int *db%diana* *db%listing* *db%errorin* *db%errorout* *db%userin* *db%userout* 'db%field_prefetch 'db%field_postfetch 'db%field_resumefetch 'db%field_exception)) (execute_mode (db%run_diana_int *db%diana* *db%listing* *db%errorin* *db%errorout* *db%userin* *db%userout* 'db%simple_field_prefetch)) (otherwise (lose 'bad_mode 'db%debugger)))) (ct_if (and result (neq result 'aborted)) (setq *db%debugger_mode* 'debug_mode)) (ct_selectq *db%debugger_mode* (debug_mode (db%enter_debugger "program completion")) (execute_mode (db%enter_executor "program completion")) (otherwise (lose 'bad_mode 'db%debugger))))))) ; ; A function to cause the back end to switch to debugger mode. ; (defun db%switch_to_debug_mode () (cond ((diana_nodep *db%diana*) (setq *db%debugger_mode* 'debug_mode) (setq *db%start_up_debugger* t) (*throw 'db%init_point 'switch_to_debug)) (t (db%message "Your program contains translation errors and cannot be debugged.")))) ; ; A function to cause the back end to switch to execute mode. ; (defun db%switch_to_execute_mode () (cond ((diana_nodep *db%diana*) (cond ((eq *db%debugger_mode* 'debug_mode) (db%remove_all_code_monitors) (db%remove_all_data_monitors))) (setq *db%start_up_executor* t) (setq *db%debugger_mode* 'execute_mode) (*throw 'db%init_point 'switch_to_execute)) (t (db%message "Your program contains translation errors and cannot be executed.")))) ; ; A function to setup and run the interpeter backend. We set up the backend hooks ; and have at it. Return nil if things went ok, the reason they didn't go ok otherwise. ; (defun db%run_diana_int (tree listing errorin errorout userin userout &optional prehook posthook resumehook exceptionhook) (unwind-protect (progn (diana_late_put tree prehook 'ct_prefetchhook) (diana_late_put tree posthook 'ct_postfetchhook) (diana_late_put tree resumehook 'ct_resumefetchhook) (diana_late_put tree exceptionhook 'ct_exceptionhook) (setq *db%inside_ada* t) (db%select_for_ada) (*catch 'db%abort_point (run_diana_int tree listing errorin errorout userin userout))) (progn (diana_late_rem tree 'ct_prefetchhook) (diana_late_rem tree 'ct_postfetchhook) (diana_late_rem tree 'ct_resumefetchhook) (diana_late_rem tree 'ct_exceptionhook) (db%select_for_commands) (setq *db%inside_ada* nil)))) ; ; A simple pre fetch hook function. We use this when we start the debugger in ; execute mode and hence want less overhead. Just look for any special flags and do the ; the right thing. ; Note, the flags for suspending and aborting are no longer used. This is all handled ; by interrupting the process now. We leave this code here just in case we ever need ; it again. ; (defun db%simple_field_prefetch (pc type) pc type) ;Not used anymore ; (cond ((neq type 'prefetch) ; (lose 'db%adb_fetch 'db%simple_field_prefetch '("Bad prefetch hook"))) ; (*db%suspend* ; (setq *db%suspend* nil) ; (db%suspend_ada)) ; (*db%abort* ; (setq *db%abort* nil) ; (db%abort_ada)))) ; ; This function is called via the fetch hook in the back end of the ; interpretter. We push the diana pc on a stack to help us to step over ; compound statements and to catch diana nodes that do not exit in the ; normal fashion (and hence call their post hooks) ; It checks to see if the user has tried to interrupt ; or if we have finished a single step operation. If ; so then we enter the debugger. Three modes of stepping are possible. If ; *db%step_mode* is 'proceed then we have single stepping turned off. If ; 'one_step, then we should stop at the next "statement". If *db%step_mode* ; is a diana node then we wait for the post fetch hook to set *db%step_break* ; meaning we have finished executing the specified node. ; Note, the flags for suspending and aborting are no longer used. This is all handled ; by interrupting the process now. We leave this code here just in case we ever need ; it again. ; (defun db%field_prefetch (pc type) (db%push_diana_stack *current_task* pc) (cond ((neq type 'prefetch) (lose 'db%adb_fetch 'db%field_prefetch '("Bad prefetch hook"))) ;Not used anymore ; (*db%suspend* ; (setq *db%suspend* nil) ; (db%suspend_ada)) ; (*db%abort* ; (setq *db%abort* nil) ; (db%abort_ada)) ((not (consp *db%step_mode*)) (lose 'db%adb_mode 'db%field_prefetch '("Bad step mode"))) ((eq (first *db%step_mode*) 'proceed)) ((and (eq (first *db%step_mode*) 'one_step) (or (eq (second *db%step_mode*) *current_task*) (eq (second *db%step_mode*) 'any_task)) (memq (diana_nodetype_get pc) *db%steppable_nodes*)) (db%ada_to_debugger "step completion")) ((and (diana_nodep (first *db%step_mode*)) (or (eq (second *db%step_mode*) *current_task*) (eq (second *db%step_mode*) 'any_task)) (memq (diana_nodetype_get pc) *db%steppable_nodes*) *db%step_break*) (setq *db%step_break* nil) (db%ada_to_debugger "step completion")))) ; ; Field the post fetch hook. Called by the interpretter (or field_resumefetch) ; after a node has completed execution. First pop the node off the stack of ; nodes being executed. Check that things look correct. Three modes of stepping ; are possible. If step_mode is 'proceed then we don't want to do anything special. ; If step mode is 'one_step then we are trying to step one "statement" at a ; time. This will be handled in the prefetch hook. If *db%step_mode* is a ; diana node then we are waiting to finish executing that node. When we do, we ; set the *db%step_break* flag to let the rest of the world know. ; (defun db%field_postfetch (pc type) (db%pop_diana_stack *current_task* pc) (cond ((neq type 'postfetch) (lose 'db%adb_fetch 'db%field_postfetch '("Bad postfetch hook"))) ((not (consp *db%step_mode*)) (lose 'db%adb_mode 'db%field_postfetch '("Bad step mode"))) ((eq (first *db%step_mode*) 'proceed)) ((eq (first *db%step_mode*) 'one_step)) ((and (diana_nodep (first *db%step_mode*)) (eq pc (first *db%step_mode*)) (or (eq (second *db%step_mode*) *current_task*) (eq (second *db%step_mode*) 'any_task))) (setq *db%step_break* t)))) ; ; This function is called when ever the interpetter resumes a node in an ; abnormal fashion. This occurs because of exception handlers, return statements, ; exitloops etc. Unfortunately, this can leave the post hooks on any nodes ; which are skipped over uncalled. What we do here is to look back over the ; list of diana nodes in progress and call the post hooks for any that were ; skipped. (defun db%field_resumefetch (pc newpc type) (let* ((the_stack (get-iv task_queue_element *current_task* diana_used_stack)) (new_top (db%find_new_top newpc the_stack))) (cond ((and (eq type 'resumefetch) (eq pc (first the_stack)) new_top) (loop for missed_pc in the_stack until (eq missed_pc new_top) do (db%maybe_run_hook (diana_get missed_pc 'ct_posthook) missed_pc 'after) do (db%maybe_run_hook (diana_late_get *db%diana* 'ct_postfetchhook) missed_pc 'postfetch))) (t (lose 'db%adb_rfetch 'db%field_resumefetch '("Bad resume fetch hook")))))) ; ; This function gets called (via the exception hook) when the interpreter ; backend encounters an unhandled excepiton. Check to see if things look good and ; then enter the debugger. Note the second parameter to ada_to_debugger to ; indicate that the program is not resumable. ; (defun db%field_exception (pc type) (cond ((neq type 'unhandled_exception) (lose 'db%adb_exception 'db%field_exception '("Bad exception hook"))) (t (db%ada_to_debugger "an unhandled exception" nil)))) ; Find the point for popping the dianastack. The simple case is if the node is in the ; stack. If not then we start looking for ancestors of the node. This corresponds to ; the case when the interpetter does a resume to a node which it hasn't visited yet. ; (defun db%find_new_top (node stack) (loop for candidate = node then (first (diana_get candidate 'ct_threadp)) while (diana_nodep candidate) if (memq candidate stack) return candidate)) ; ; Restart the interpretter after entering the debugger. We do so by throwing ; to the start point which was set up when we entered. ; (defun db%start () (db%message "Program execution has begun.") (setq *db%step_mode* '(proceed nil)) (*throw 'db%start_point nil)) ; ; Single step the diana virtual machine. If the program is resumable, then ; we look at the next "instruction" to see if it is a compound statement. ; If it is, then we give the user the option of stepping it as a unit or ; stepping each of the individual parts. If the program is not resumable, ; then we set up for one step mode while we let the interpretter go through ; all it start up bullshit. ; (defun db%step (&aux descrip article) (cond ((and *db%inside_ada* *db%ada_resumable*) (ct_csend db%vanilla_tag_flavor *db%true_pc_tag* 'displayself *db%code_window* *db%user_window*) (setq descrip (ct_if (memq (diana_nodetype_get pc) '(dn_entry_call dn_function_call dn_procedure_call)) (ct_format nil "~a to ~a" (db%diana_describeself pc nil) (db%diana_printself (diana_get pc 'as_name) nil)) (db%diana_describeself pc nil))) (setq article (db%proper_article_for descrip)) (ct_if (not (ct_string_equal descrip "")) (db%message "Stepping ~a ~a ..." article descrip) (db%message "Stepping ...")) (ct_if (and (db%compound_stepp pc) (eq 'unit (db%ask_literal (ct_format nil "~a: Step as a whole or parts? " descrip) '(("Whole" unit) ("Parts" parts))))) (setq *db%step_mode* (list pc *current_task*)) (setq *db%step_mode* `(one_step ,*current_task*))) (*throw 'db%resume_point 'resume_execution)) ((not *db%inside_ada*) (db%message "Stepping program set up ...") (setq *db%step_mode* '(one_step any_task)) (*throw 'db%start_point nil)) (t (db%message "Your Ada program is not continuable.")))) ; ; Quit the interpretter after entering the debugger. We do so by throwing ; to the quit point which was set up when we entered. ; (defun db%quit_debugger () (db%message "Goodbye.") (*throw 'db%quit_point 'quitting)) ; ; A function to suspend the ada program. Three cases are possible. First off, ; the ada program may not even be running. Second, we may have started in execute ; mode and have not fully entered the debugger yet in which case, we throw out ; to the abort point. Finally, if we are fully in the debugger we enter the ; command loop from here (and hence preserve the interpreter state). ; (defun db%suspend_ada () (cond ((not (and (boundp '*db%how_started*) *db%how_started*))) ((not *db%inside_ada*) (db%message "Your Ada program is not active.")) (*db%accepting_commands* (db%message "You Ada program is already suspended.")) ((eq *db%debugger_mode* 'execute_mode) (db%ada_to_executor "a program interruption")) ((eq *db%debugger_mode* 'debug_mode) (db%ada_to_debugger "a program interruption")) (t (lose 'adb_bad_suspend 'db%suspend_ada '("Bad suspend state"))))) ; ; Resume the interpretter after entering the debugger. We do so by throwing ; to the resume point which was set up when we entered. ; (defun db%resume () (cond ((not (and (boundp '*db%how_started*) *db%how_started*))) ((not *db%inside_ada*) (db%message "Your Ada program is not active.")) ((not *db%accepting_commands*) (db%message "Your Ada program is already running")) ((not *db%ada_resumable*) (db%message "Your Ada program is not continuable.")) (t (db%message "Program execution has continued.") (setq *db%step_mode* '(proceed nil)) (*throw 'db%resume_point 'resume_execution)))) ; ; A function to abort the ada program. Check first to make sure there is one to abort. ; (defun db%abort_ada () (cond ((not (and (boundp '*db%how_started*) *db%how_started*)) (db%reprocess)) ((not *db%inside_ada*) (db%message "Your Ada program is not active.")) (T (*throw 'db%abort_point 'aborted)))) ; ; Print out the current debugger state. ; (defun db%debugger_state () (and (boundp '*db%release*) *db%release* (ct_format *db%user_window* "C*T Ada Debugger release ~a.~%" *db%release*)) (ct_format *db%user_window* "The debugger was entered due to ~a.~a~%" *db%why_entered* (cond ((not *db%inside_ada*) "") (*db%ada_resumable* " Your Ada program is continuable.") (t " Your Ada program is not continuable."))) (and (boundp '*exception_name*) *exception_name* (listp *exception_name*) (ct_format *db%user_window* "The ~a exception is raised because of ~a.~%" (first *exception_name*) (first *exception_reason*))) (with-output-buffered *db%user_window* (loop with tags = (db%code_tags) initially (and tags (db%message "Program monitors.")) for tag in tags do (ct_format *db%user_window* "~10@T~a~%" (ct_csend db%code_monitor tag 'printself nil)))) (with-output-buffered *db%user_window* (loop with tags = (db%data_tags) initially (and tags (db%message "Value monitors.")) for tag in tags do (ct_format *db%user_window* "~10@T~a~%" (ct_csend db%data_monitor tag 'printself nil))))) ; ; Collect up a list of all the tags defined currently. ; (defun db%all_tags () (loop for tag_fun in *db%tag_funs* append (funcall tag_fun))) ; ; Let the user tell us a tag that they wish displayed. We run over all the ; tag lists and collect up the tags which are defined as pairs of print name ; and tag. Then call the user interface to ask which one. Then display it. ; (defun db%display_tag () (let ((tags (loop for tag in (db%all_tags) collect (ct_if *db%verbose_tags* `(,(ct_string_append (ct_send tag 'printself nil) " : " (ct_send tag 'describeself nil)) ,tag) `(,(ct_send tag 'printself nil) ,tag))))) (ct_if tags (ct_send (db%ask_literal "Which tag?" tags) 'displayself *db%code_window* *db%user_window*) (db%message "There are no tags to display.")))) ; ; Remove a monitor from the Ada program. If we have some monitors ask the ; user which one. Then try removing it. ; (defun db%remove_monitor () (let* ((tags (append (db%code_tags) (db%data_tags))) (choices (append1 (loop for tag in tags collect `(,(ct_send tag 'printself nil) ,tag)) 'all)) response) (cond ((null tags) (db%message "There are no monitors to remove.")) ((memq 'all (setq response (db%ask_multiple_literal "Which monitor(s)? " choices))) (db%remove_all_code_monitors) (db%remove_all_data_monitors)) (t (loop for tag in response do (ct_send tag 'removeself *db%user_window*)))))) ; ; Enter the debugger. Check to see if we still need to start things up. ; Call protect to make sure we are a legal copy for this site etc. ; Print a message telling why we entered. ; Grab the stack for the environment walker. Set up the resume catch ; point and call the command loop. ; (defun db%enter_debugger (&optional (why "unknown reason") (resumablep t) &aux result) (unwind-protect (progn (setq *db%accepting_commands* t *db%ada_resumable* resumablep) (protect 'debugger) (ct_if *db%start_up_debugger* (db%start_debugger)) (db%message "" why) (setq *db%why_entered* why) (cond ((and *db%inside_ada* (boundp '*activation*) *activation* (boundp '*current_task*) *current_task*) (set-iv adabe_activation *activation* 'pc pc) (set-iv task_queue_entry *current_task* 'value *activation*))) (db%get_envirnment (and *db%inside_ada* (boundp '*current_task*) *current_task*)) (setq result (*catch 'db%resume_point (db%debug_command))) (setq *db%suspend* nil *db%abort* nil *db%step_break* nil)) (setq *db%accepting_commands* nil *db%ada_resumable* nil))) ; ; Enter the executor. This is the entry point for command processing when we ; are in execute mode. ; (defun db%enter_executor (&optional (why "unknown reason") (resumablep t) &aux result) (unwind-protect (progn (setq *db%accepting_commands* t *db%ada_resumable* resumablep) (ct_if *db%start_up_executor* (db%start_executor)) (db%message "" why) (setq *db%why_entered* why) (ct_if (ct_string_equal why "initial start up") (db%start) (setq result (*catch 'db%resume_point (db%debug_command))))) (setq *db%accepting_commands* nil *db%ada_resumable* nil))) ; ; Enter the checker. This is the entry point for command processing when we ; are in execute mode. ; (defun db%enter_checker (&optional (why "unknown reason") &aux result) (unwind-protect (progn (setq *db%accepting_commands* t) (ct_if *db%start_up_checker* (db%start_checker)) (db%message "" why) (setq *db%why_entered* why) (setq result (*catch 'db%resume_point (db%debug_command)))) (setq *db%accepting_commands* nil))) ;;;This function should be called when you are running inside the interpreter and ;;;want to go into the debugger for awhile. (defun db%ada_to_debugger (&rest args) (unwind-protect (progn (db%select_for_commands) (apply #'db%enter_debugger args)) (db%select_for_ada))) ;;;This function should be called when you are running inside the interpreter and ;;;want to go into the executor for awhile. (defun db%ada_to_executor (&rest args) (unwind-protect (progn (db%select_for_commands) (apply #'db%enter_executor args)) (db%select_for_ada))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Methods -- ; ; A predicate to determine if a node can be stepped as individual pieces or must ; be done as a whole. We first look in a list of candidate node types. Then do ; some special casing for built in functions and procedures. ; (defun db%compound_stepp (node) (let (type def body) (and (memq (setq type (diana_nodetype_get node)) *db%compound_nodes*) (not (and (memq type '(dn_entry_call dn_function_call dn_procedure_call)) (setq def (db%diana_defineself (diana_get node 'as_name))) (diana_node_accepts_attributep def 'sm_body) (setq body (diana_get def 'sm_body)) (diana_node_accepts_attributep body 'ct_lisp_func) (diana_get body 'ct_lisp_func)))))) ; ; A function to push a node on the diana stack for a task. The diana stack ; for a task keeps track of the nodes that are currently being worked on by ; the diana virtual machine for the particular task. We use the diana stack ; to gaurantee that we can always get the post hooks for nodes called even ; if the node exits in an abnormal way. To avoid unnecesary cons'ing, we ; keep a list of free cons cells. IF there is no free cons cell then make ; one. ; (defun db%push_diana_stack (task node &aux the_cell) ; (and (or (memq node node_list) ; (eq node_list 'all)) ; (or (eq task target) ; (eq target 'all)) ; (format t "~%Pushing ~a on to ~a" node task)) (cond ((consp (setq the_cell (get-iv task_queue_element task diana_free_stack))) (set-iv task_queue_element task diana_free_stack (cdr the_cell)) (rplaca the_cell node) (rplacd the_cell (get-iv task_queue_element task diana_used_stack)) (set-iv task_queue_element task diana_used_stack the_cell)) (t (set-iv task_queue_element task diana_used_stack (cons node (get-iv task_queue_element task diana_used_stack)))))) ; ; Pop an element of the diana stack for a task. Make sure the thing we are ; popping off is the node we expect. We keep track of the cons cells which ; are freed up so that we may reuse them. ; (defun db%pop_diana_stack (task node &aux the_cell) ; (and (or (memq node node_list) ; (eq node_list 'all)) ; (or (eq task target) ; (eq target 'all)) ; (format t "~%Popping ~a on to ~a" node task)) (cond ((and (consp (setq the_cell (get-iv task_queue_element task diana_used_stack))) (eq node (first the_cell))) (set-iv task_queue_element task diana_used_stack (cdr the_cell)) (rplacd the_cell (get-iv task_queue_element task diana_free_stack)) (set-iv task_queue_element task diana_free_stack the_cell)) (t (break dianastack) (lose 'db%adb_dstack 'db%pop_diana_stack '("Diana stack out of sync"))))) ;;; eof ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;