;;; -*- mode:lisp;package:user;base:10.;fonts: cptfont -*- ;;; $Header: /ct/debug/lmdbcmds.l,v 1.17 85/06/27 15:15:15 bill Exp $ (putprop 'lmdbcmds "$Revision: 1.17 $" 'rcs_revision) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; LMDBCMDS ;;; ;;; Susan Rosenbaum January,84 ;;; ;;; ;;; ;;; ;;; ;;; 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. ;;; ;;; AJPO, Feb 1983. ANSI/MIL-STD-1815A Ada Reference Manual. ;;; ;;; The following code assumes familiarity with these materials. ;;; ;;; ;;; ;;; ASSUMES CT_LOAD AND SUITABLE FILEMAP ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Ensure presence of needed files. (eval-when (compile load eval) (ct_load 'charmac)) ;CT char set extensions. (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 'ctflav)) (eval-when (compile load eval) (ct_load 'dbutils)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- (declare (special *integer_first* *integer_last* *db%source_files* *db%code_window* *db%debug_frame* *db%multiple_menu* *db%input_window*)) (defvar *db%search_string* "" "The default string to use with find_string") #+franz (declare (macros t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;; None presently. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Internal Use Only Functions/Macros -- ;;;Initialize this module (defun db%init_dbcmds () nil) ;;;;;;;;;;;;;; (defun db%quit_system () (send *db%debug_frame* ':bury) (tv:await-window-exposure)) ;;;;;;;;;;;;;; #|(if (tv:menu-choose '(("Confirm system exit" :value t :font fonts:medfnb))) (*throw 'db%quit_system nil)))|# (defun db%reprocess () (*throw 'db%catch_reprocess 'try_again)) ;;;The following functions handle the commands found in the side menu for the debug ;;;windows. ;;;;;;;;;;;;;; (defun db%find_string (window) ;;;;;;;;;;;;;; ;;Ask the user for the desired string and ct_send the current ;;window a ':search message. If found, reposition the ;;window on the requested string; otherwise, give an ;;error that the string wasn't found (let ((input_string nil) (return_pos nil) (prompt_string (format nil "Search String (default is ~a):" *db%search_string*))) (setq input_string (db%get_string_input prompt_string)) (ct_if (ct_string_equal input_string "") (setq input_string *db%search_string*) (setq *db%search_string* input_string)) (ct_if (not (equal window *db%user_window*)) (ct_format *db%user_window* "Searching ...")) (setq return_pos (if input_string (ct_send window ':search input_string (ct_send window 'current_xpos) (ct_send window 'current_ypos)) nil)) (cond (return_pos (ct_if (not (equal window *db%user_window*)) (ct_format *db%user_window* " Found it.~%")) (ct_send window ':set-current_xpos (first return_pos)) (ct_send window ':set-current_ypos (second return_pos)) (ct_send (ct_send window ':window) ':set-cursorpos (first return_pos) (second return_pos) ':character)) (input_string ;;make sure the user didn't just hit (ct_if (not (equal window *db%user_window*)) (ct_format *db%user_window* "~%")) (db%user_interface_error (format nil "String not found: ~A" input_string))) (t (ct_if (not (equal window *db%user_window*)) (ct_format *db%user_window* "~%")))))) ;;;Ask the user for the file in which to save the ;;;contents of the window, then save it. (defun db%save_contents (window) (let* ((prompt (format nil "Save in file (default is ~a):" (fs:default-pathname))) (file_name (db%get_input ':string-or-nil prompt))) ;;if a file_name isn't given, don't try to save anything. ;;The user hit a rather than any input. ;;Otherwise, make sure that we have a valid pathname for the file (when file_name (cond ((db%probedir file_name) (db%message "Saving ~a in file ~a." (sixth (ct_send (ct_send window 'window) ':label)) file_name) (ct_send window ':print-to-file file_name) (fs:set-default-pathname file_name)) (t (db%user_interface_error (format nil "Cannot save window to file ~A" file_name))))))) ;;;Display the top of the buffer for this window. (defun db%top_of_file (window) (let ((debug_window (ct_send (ct_send window ':associated-pane) ':get ':debug_window))) (ct_send debug_window ':beginning) (ct_send debug_window ':set-current_xpos 0) (ct_send debug_window ':set-current_ypos 0) (ct_send debug_window ':reposition_cursor))) ;;;Display the previous page of the "buffer" for this window. Look at the mouse ;;;button to determine how far to go. (defun db%previous_page (window &optional button) (let* ((debug_window (ct_send (ct_send window ':associated-pane) ':get ':debug_window)) (page (ct_send debug_window ':lines-displayed)) (step (ct_selectq button (4 2) ;right (2 (// page 2.)) ;middle (otherwise page)))) (ct_send debug_window ':backward-screen step) (ct_send debug_window ':set-current_xpos 0) (ct_send debug_window ':set-current_ypos 0) (ct_send debug_window ':reposition_cursor))) ;;;Display the next page of the "buffer" for the window. Look at the mouse button to ;;;determine how far to move. (defun db%next_page (window &optional button) (let* ((debug_window (ct_send (ct_send window ':associated-pane) ':get ':debug_window)) (page (ct_send debug_window ':lines-displayed)) (step (ct_selectq button (4 2) ;right (2 (// page 2.)) ;middle (otherwise page)))) (ct_send debug_window ':forward-screen step) (ct_send debug_window ':set-current_xpos 0) (ct_send debug_window ':set-current_ypos (1- (ct_send debug_window ':lines-displayed))) (ct_send debug_window ':reposition_cursor))) ;;;Display the end of the "buffer" for this window (defun db%bottom_of_file (window) (let ((debug_window (ct_send (ct_send window ':associated-pane) ':get ':debug_window))) (ct_send debug_window ':end) (ct_csend db%debug_window debug_window ':adjust_position) (ct_send debug_window ':reposition_cursor))) (defun db%describe_object (button) (ct_selectq button (4 (db%describe_id '(refine modify))) ;right (2 (db%describe_id '(refine modify))) ;middle (otherwise (db%describe_id '(refine))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;