;;; -*- mode:lisp;package:user;base:10.;fonts: cptfont -*- ;;; $Header: /ct/debug/lmscreens.l,v 1.55 85/06/27 10:22:59 bill Exp $ ;;; ;;; Hacked 16 August 1985 Richard Mark Soley for Lambda port (putprop 'lmscreens "$Revision: 1.55 $" 'rcs_revision) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; LMSCREENS ;;; ;;; ;;; ;;; ;;; ;;; 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. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 'dbutils)) ;debugger utilities (eval-when (compile load eval) (ct_load 'scroll)) ;scroll windows (eval-when (compile load eval) (ct_load 'menufix)) ;get rectangles right ;around menu items (eval-when (compile load eval) (ct_load 'diana)) ;diana node stuff (eval-when (compile load eval) (ct_load 'protect)) ;proctection stuff (eval-when (load eval) (ct_load 'cthl12)) ;ct font. (better kern table) (eval-when (load eval) (ct_load 'cthl12b)) ;ct font. (better kern table) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compiler Declarations and Global Variables -- #+franz (declare (macros t)) ;;;Kludge for now. This should try to figure out the system version by poking around ;;;in the lisp system. #+Symbolics (eval-when (compile load eval) #+cadr (sstatus nofeature rel5.2) #+3600. (sstatus feature rel5.2)) ;;; ;;;Some variables ;;; ;;;Specials which we import. (declare (special *lossage* *temp_directory* *integer_first* *integer_last* tv:who-line-documentation-window *float_first* *float_last*)) ;;;The system key which will invode the interpreter/debugger. (defvar *db%system_key* #/A) ;;;the frame containing all of the panes (defvar *db%debug_frame* nil) ;;;the window to display interpreter I/O (defvar *db%output_window* nil) ;;;the window to display user source code (defvar *db%code_window* nil) ;;;the window to display output from the debugger (defvar *db%user_window* nil) ;;;the window used to set up the interpreter front end (defvar *db%interp_window* nil) ;;;the window used to display the listing from the front end (defvar *db%listing_window* nil) ;;;a window to use for user input to the debugger (defvar *db%input_window* nil) ;;;a window used when login is needed from the user to login. (defvar *db%login_window* nil) ;;;A standalone editor window for editing file path names. (defvar *db%path_editor_window* nil) ;;;the menu to pop up for multiple-entry queries. (defvar *db%multiple_menu* nil) ;;;the menu to pop up for multiple-entry queries without a do-it opton (defvar *db%initial_choice_menu* nil) ;;;The envirnment for running the front end. (defvar *db%envirnment* nil) ;;;A flag for remembering what mode we are running in. (defvar *db%front_end_mode* nil) ;;;The tree which results from running the front end of the interpreter. (defvar *db%front_end_tree* nil) ;;;The source files (defvar *db%source_files* nil) (putprop '*db%source_files* "Source files" 'db%title) (putprop '*db%source_files* t 'db%count) (putprop '*db%source_files* 'read 'db%direction) (putprop '*db%source_files* (list () (tv:scroll-parse-item '(:mouse (:mouse_item :value Edit-Source :documentation "Edit the source file names") :string "Source files:")) (tv:scroll-maintain-list #'(lambda () *db%source_files*) 'db%one_per_line) (tv:scroll-parse-item '(:string " ")) (tv:scroll-parse-item '(:string " "))) 'db%display_list) ;;;The library (what a joke) file. Merge one of these with the diana tree. (defvar *db%object_input_file* nil) (putprop '*db%object_input_file* "Library file" 'db%title) (putprop '*db%object_input_file* 'read 'db%direction) (putprop '*db%object_input_file* (list () (tv:scroll-parse-item '(:mouse (:mouse_item :value Edit-Library :documentation "Edit the library file name") :string "Library file:")) (tv:scroll-maintain-list #'(lambda () (and *db%object_input_file* (list *db%object_input_file*))) 'db%one_per_line) (tv:scroll-parse-item '(:string " ")) (tv:scroll-parse-item '(:string " "))) 'db%display_list) ;;;The internal file (used to save the results of a translation) (defvar *db%object_output_file* nil) (putprop '*db%object_output_file* "Internal file" 'db%title) (putprop '*db%object_output_file* 'write 'db%direction) (putprop '*db%object_output_file* (list () (tv:scroll-parse-item '(:mouse (:mouse_item :value Edit-Internal :documentation "Edit the internal file name") :string "Internal file:")) (tv:scroll-maintain-list #'(lambda () (and *db%object_output_file* (list *db%object_output_file*))) 'db%one_per_line) (tv:scroll-parse-item '(:string " ")) (tv:scroll-parse-item '(:string " "))) 'db%display_list) ;;;The listing file (defvar *db%listing_file* nil) (putprop '*db%listing_file* "Listing file" 'db%title) (putprop '*db%listing_file* 'write 'db%direction) (putprop '*db%listing_file* (list () (tv:scroll-parse-item '(:mouse (:mouse_item :value Edit-Listing :documentation "Edit the listing file name") :string "Listing file:")) (tv:scroll-maintain-list #'(lambda () (and *db%listing_file* (list *db%listing_file*))) 'db%one_per_line) (tv:scroll-parse-item '(:string " ")) (tv:scroll-parse-item '(:string " "))) 'db%display_list) ;;;The pathname (string) which we will merge in for the user. (defvar *db%default_pathname* nil) ;;;The temp file we use for the listing. (defvar *db%temp_output_file* "uninitialized") ;;; ;;;And now a bunch of menu item lists ;;; ;;;A null item list. (defvar *db%null_menu_items* '(("" :no-select t))) (defvar *db%last_menu_items* '(("Quit Session" :value Quit-Session :documentation "Quit this session" :font fonts:cthl12))) ;;; These characters are mouse characters that look nice for ;;; top-of-file, previous-page, next-page, bottom-of-file (defvar *db%better_command_menu_pane_item_list* '(("" :no-select t) ("l" :value top-of-file :font fonts:mouse :documentation "Go to the top of this window") ("m" :value previous-page :font fonts:mouse :documentation "L:Scroll back 1 page, M:Scroll back 1//2 page, R:Scroll back 1 line") ("" :no-select t) ("Find" :value find-string :font fonts:hl10b :documentation "Find a string in this window") ("Save" :value save-contents :font fonts:hl10b :documentation "Save the contents of this window in a file") ("" :no-select t) ("k" :value next-page :font fonts:mouse :documentation "L:Scroll forward 1 page, M:Scroll forward 1//2 page, R:Scroll forward 1 line") ("j" :value bottom-of-file :font fonts:mouse :documentation "Go to the bottom of this window"))) ;;;These are for the command menu for asking the user how to run the interp/debugger #+cadr (defvar *db%basic_front_end_menu_items* '(("Clear" :value clear :documentation "Clear the current translator setup") ("" :no-select t) ("Quit Session" :value Quit-Session :font fonts:cthl12 :documentation "Quit this session") ("Check" :value check :documentation "Translate and enter the error checker") ("Execute" :value execute :documentation "Translate and enter the executor") ("Debug" :value debug :documentation "Translate and enter the debugger"))) #+(or 3600. lambda) (defvar *db%basic_front_end_menu_items* '(("" :no-select t) ("Check" :value check :documentation "Translate and enter the error checker") ("" :no-select t) ("Execute" :value execute :documentation "Translate and enter the executor") ("" :no-select t) ("Debug" :value debug :documentation "Translate and enter the debugger") ("" :no-select t) ("" :no-select t) ("Clear" :value clear :documentation "Clear the current translator setup"))) (defvar *db%front_end_menu_items* *db%basic_front_end_menu_items*) ;;;These are the items available when we are in the check translation erros configuration #+cadr (defvar *db%basic_check_menu_items* '(("Execute" :value Execute :documentation "Enter the executor") ("Quit Session" :value Quit-Session :documentation "Quit this session" :font fonts:cthl12) ("Debug" :value Debug :documentation "Enter the debugger") ("Translate" :value Translate :documentation "Return to the interpreter translator"))) #+(or 3600. lambda) (defvar *db%basic_check_menu_items* '(("" :no-select t) ("Execute" :value Execute :documentation "Enter the executor") ("" :no-select t) ("Debug" :value Debug :documentation "Enter the debugger") ("" :no-select t) ("Translate" :value Translate :documentation "Return to the interpreter translator"))) (defvar *db%check_menu_items* *db%basic_check_menu_items*) ;;;These are the items for when we are in the execute configuration #+cadr (defvar *db%basic_execute_menu_items* '(("Begin Program" :value Begin-Program :documentation "Begin execution of the Ada program") ("Translate" :value Translate :documentation "Return to the interpreter translator") ("Quit Session" :value Quit-Session :documentation "Quit this session" :font fonts:cthl12) ("Continue Program" :value Continue-Program :documentation "Resume from the current breakpoint") ("Debug" :value Debug :documentation "Enter the debugger"))) #+(or 3600. lambda) (defvar *db%basic_execute_menu_items* '(("" :no-select t) ("Begin Program" :value Begin-Program :documentation "Begin execution of the Ada program") ("" :no-select t) ("Continue Program" :value Continue-Program :documentation "Resume from the current breakpoint") ("" :no-select t) ("" :no-select t) ("Debug" :value Debug :documentation "Enter the debugger") ("" :no-select t) ("Translate" :value Translate :documentation "Return to the interpreter translator"))) (defvar *db%execute_menu_items* *db%basic_execute_menu_items*) ;;;These are the items for when we are in the debugger. lm2 version -- 4 columns #+cadr (defvar *db%basic_debug_menu_items* '(("Debugger State" :value Debugger-State :documentation "Display the state of the debugger") ("Show Tasks" :value Describe-Tasks :documentation "Show the current set of tasks.") ("Top of Act Records" :value Top-of-Act-Records :documentation "Display the top activation record") ("Quit Session" :value Quit-Session :documentation "Quit this session" :font fonts:cthl12) ("Remove Monitor" :value Remove-Monitor :documentation "Clear a trace//break on an Ada variable//statement.") ("Choose Task" :value Select-Task :documentation "Choose a task for examination.") ("Up Activation Record" :value Up-Activation-Record :documentation "Move the subprogram activation pointer to the caller of the current subprogram") ("Execute" :value Execute :documentation "Enter the executor") ("Monitor Program" :value Monitor-Program :documentation "Set a break or trace on an Ada statement") ("Continue Program" :value Continue-Program :documentation "Resume from the current breakpoint") ("Down Activation Record" :value Down-Activation-Record :documentation "Move the subprogram activation pointer to the callee of the current subprogram") ("Translate" :value Translate :documentation "Return to the interpreter translator") ("Monitor Value" :value Monitor-Value :documentation "Set a break or trace on an Ada variable") ("Single Step" :value Single-Step :documentation "Single step through the program") ("Bottom of Act Records" :value Bottom-of-Act-Records :documentation "Display the bottom activation record") ("Display Tag" :value Display-Tag :documentation "Select a tagged source text point and position the code window there.") #| ;; Out for now until we have a better scheme ("Select Generic" :value Select-Generic :documentation "Select a gerneric context.") |# ("Describe Object" :value Describe-Object :documentation "L:Display the value of the identifier under the cursor M,R:Display and maybe modify the value") ("Begin Program" :value Begin-Program :documentation "Begin execution of the Ada program") ("Show Activation Record" :value Show-Activation-Record :documentation "Display the entire calling history") ("Choose File" :value Choose-File :documentation "Choose a new source file to be displayed.") )) #+(or 3600 lambda) (defvar *db%basic_debug_menu_items* '(("" :no-select t) ("Describe Object" :value Describe-Object :documentation "L:Display the value of the identifier under the cursor M,R:Display and maybe modify the value") ("" :no-select t) ("Monitor Program" :value Monitor-Program :documentation "Set a break or trace on an Ada statement") ("" :no-select t) ("Monitor Value" :value Monitor-Value :documentation "Set a break or trace on an Ada variable") ("" :no-select t) ("Remove Monitor" :value Remove-Monitor :documentation "Clear a trace//break on an Ada variable//statement.") ("" :no-select t) ("" :no-select t) ("Begin Program" :value Begin-Program :documentation "Begin execution of the Ada program") ("" :no-select t) ("Single Step" :value Single-Step :documentation "Single step through the program") ("" :no-select t) ("Continue Program" :value Continue-Program :documentation "Resume from the current breakpoint") ("" :no-select t) ("" :no-select t) ("Show Activation Records" :value Show-Activation-Record :documentation "Display the program calling history") ("" :no-select t) ("Top of Act Records" :value Top-of-Act-Records :documentation "Display the top activation record") ("" :no-select t) ("Up Activation Record" :value Up-Activation-Record :documentation "Move the subprogram activation pointer to the caller of the current subprogram" ) ("" :no-select t) ("Down Activation Record" :value Down-Activation-Record :documentation "Move the subprogram activation pointer to the callee of the current subprogram") ("" :no-select t) ("Bottom of Act Records" :value Bottom-of-Act-Records :documentation "Display the bottom activation record") ("" :no-select t) ("" :no-select t) ("Show Tasks" :value Describe-Tasks :documentation "Show the current set of tasks.") ("" :no-select t) ("Choose Task" :value Select-Task :documentation "Choose a task for examination.") ("" :no-select t) ("" :no-select t) ("Choose File" :value Choose-File :documentation "Choose a new source file to be displayed.") ("" :no-select t) ("Display Tag" :value Display-Tag :documentation "Select a tagged source text point and position the code window there.") ("" :no-select t) ("" :no-select t) ("Debugger State" :value Debugger-State :documentation "Display the state of the debugger") ("" :no-select t) ("Execute" :value Execute :documentation "Enter the executor") ("" :no-select t) ("Translate" :value Translate :documentation "Return to the interpreter translator") ;;Out for now until we have a better scheme #| ("Select Generic" :value Select-Generic :documentation "Select a gerneric context.") |# )) (defvar *db%debug_menu_items* *db%basic_debug_menu_items*) ;;; ;;;Some window flavors and methods which we will need. ;;; ;;;A frame that will also take the stream messages. (ct_defflavor bordered_stream_frame () (tv:bordered-constraint-frame-with-shared-io-buffer tv:process-mixin tv:stream-mixin #+LMI tv:select-mixin)) ;;;These two methods will change the font in the mouse documentation line when ;;;the ctada frame is in use. A bit of a kludge but its cute. Its not clear ;;;that expose is the right method to use but is good enough for now. Note ;;;also, that there is nothing here to unwind the new font if something ;;;goes wrong. (ct_defmethod (bordered_stream_frame :after :expose) (&rest ignore) (send tv:who-line-documentation-window ':set-font-map '(fonts:cptfontb))) (ct_defmethod (bordered_stream_frame :after :deexpose) (&rest ignore) (send tv:who-line-documentation-window ':set-font-map '(fonts:cptfont))) ;;;A scroll window with mouse items (ct_defflavor mouseable_scroll_window () (tv:scroll-window) (:included-flavors tv:scroll-mouse-mixin)) ;;;a window that won't cause the windows beneath it to disappear (ct_defflavor temporary_window () (tv:temporary-window-mixin tv:window)) (ct_defmethod (temporary_window :after :expose) (&rest ignore) #-LMI (ct_send self ':select)) ;;;a temporary window which allows mouse clicks (ct_defflavor mousey_temporary_window () (temporary_window)) ;;;So we get the clicks (defmethod (mousey_temporary_window :tyi) (&optional eof-action) (send self (if (send self ':operation-handled-p ':any-tyi) ':any-tyi ':tyi) eof-action)) ;;;So we get the clicks as integers (defmethod (mousey_temporary_window :mouse-click) (buttons x y) x y (cond ((send self ':operation-handled-p ':force-kbd-input) (send self ':force-kbd-input buttons)) (t (beep))) t) ;;;a command menu that know who it's associated pane is--used to know ;;;which window's right hand menu was clicked on (ct_defflavor better-command-menu-pane (associated-pane) (tv:command-menu-pane) #+LMI (:default-init-plist :borders '(0 1 0 0)) :settable-instance-variables :initable-instance-variables :gettable-instance-variables) (ct_defmethod (better-command-menu-pane :after :refresh) (&rest ignore) (send self :set-item-list *db%better_command_menu_pane_item_list*)) ;;; A new flavor to make the multiple menu NOT clobber other ;;; menus on the screen. This should work because the temporary ;;; mixin causes the window to save the bits of underlying windows ;;; when it is popped up. (ct_defflavor temporary-multiple-menu () (tv:temporary-window-mixin tv:multiple-menu)) ;;;make the window panes understand mouse blips and have the ability to ;;;have properties (ct_defflavor nice_window () (tv:list-mouse-buttons-mixin tv:line-truncating-mixin si:property-list-mixin tv:window-pane)) ;;;Set up the nice_windows. Since they are the only ones which will be selected, ;;;we let them handle the asynchonous characters. (ct_defmethod (nice_window :after :init) (ignore) (setf (tv:sheet-truncate-line-out-flag self) 1) (ct_send self ':remove-asynchronous-character #\ctrl-abort) (ct_send self ':add-asynchronous-character #\ctrl-abort #'db%kbd-asynchronous-intercept-character) (ct_send self ':remove-asynchronous-character #\ctrl-break) (ct_send self ':add-asynchronous-character #\ctrl-break #'db%kbd-asynchronous-intercept-character) (ct_send self ':add-asynchronous-character #\ctrl-s #'db%kbd-asynchronous-intercept-character) (ct_send self ':add-asynchronous-character #\ctrl-q #'db%kbd-asynchronous-intercept-character)) (ct_defmethod (nice_window :after :refresh) (&rest ignore) (let ((debug_window (send self ':get ':debug_window))) (when debug_window (send debug_window ':refresh) (send debug_window ':reposition_cursor)))) ;;; A mixin to provide a box around the character under the mouse. About ;;; the only method for this flavor is mouse-moves. (ct_defflavor box-character-mixin ((mouse-blinker nil)) () (:required-flavors tv:window) :gettable-instance-variables :settable-instance-variables :initable-instance-variables ) (ct_defmethod (box-character-mixin :after :init) (&rest ignore) (setq mouse-blinker (tv:make-blinker self 'tv:hollow-rectangular-blinker ':x-pos 0 ':y-pos 0 ':visibility t))) (ct_defmethod (box-character-mixin :after :mouse-moves) (x y) (let ((font (ct_send self ':current-font))) (multiple-value (x y) (db%character_size self x y font)) (setq x (* x (tv:font-char-width font)) y (* y tv:line-height)) (ct_send mouse-blinker ':set-cursorpos x y))) ;;; Cause the box blinker to be turned off when mouse isn't inside ;;; the window. ;;; Stolen from the hysteretic window mixin. (ct_defmethod (box-character-mixin :handle-mouse) () (let (left-lim top-lim right-lim bottom-lim (hysteresis 0.)) (multiple-value (left-lim top-lim) (tv:sheet-calculate-offsets self tv:mouse-sheet)) (setq right-lim (+ left-lim tv:width hysteresis) bottom-lim (+ top-lim tv:height hysteresis) left-lim (- left-lim hysteresis) top-lim (- top-lim hysteresis)) (ct_send mouse-blinker ':set-visibility t) (do (w) (()) ;; let the mouse out of the window only if it moves more than away (and (or tv:mouse-reconsider ;; also leave if mouse fell into inferior (and (neq self (setq w (tv:lowest-sheet-under-point tv:mouse-sheet tv:mouse-x tv:mouse-y nil ':exposed))) (tv:sheet-me-or-my-kid-p w self)) (< tv:mouse-x left-lim) (> tv:mouse-x right-lim) (< tv:mouse-y top-lim) (> tv:mouse-y bottom-lim)) (return t)) (tv:mouse-standard-blinker self) (tv:mouse-default-handler self nil)) (ct_send mouse-blinker ':set-visibility nil))) (ct_defflavor really_nice_window () (box-character-mixin nice_window)) ;;;squirrely re-draw for the command menu #-LMI (ct_defmethod (tv:command-menu-pane :redraw) () nil) ;;;make a window that scrolls rather than wraps around (ct_defflavor scolling-window () (tv:line-truncating-mixin tv:window)) (ct_defmethod (scolling-window :after :init) (ignore) (setf (tv:sheet-truncate-line-out-flag self) 1)) (ct_defmethod (scolling-window :end-of-page-exception) () (cond ((not (zerop (tv:sheet-end-page-flag))) ;home smashes this, since it moves the cursor (let ((m-vp tv:more-vpos)) ;;when at the end of the page, move to home to delete ;;a line and then write again at the end of the screen (funcall-self ':home-cursor) (funcall-self ':delete-line) (funcall-self ':home-down) ;; arrange for more processing next time around (cond ((null m-vp)) ;no more processing at all (( m-vp 100000) ;more processing delayed? (setq tv:more-vpos (- m-vp 100000))) (t (setq tv:more-vpos (tv:sheet-deduce-more-vpos self)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Externally Call-able Functions/Macros -- ;;;Initialize this module (defun db%init_screens () (db%initial_make_windows) (tv:add-system-key (ct_char_upcase (ct_character *db%system_key*)) *db%debug_frame* "C * T Ada Interpreter//Debugger" nil) (tv:add-to-system-menu-programs-column "CTAda" '(ctada_int) "C * T Ada Interpreter//Debugger")) ;;;This is the function that starts it all off. Call this to start the interpreter ;;;debugger. (or just hit the appropriate system key) (defun ctada () (send *db%debug_frame* :activate) (send *db%debug_frame* :expose) (send *db%debug_frame* ':select) (format t "~%The CTAda process has been started~%")) ;;;This is an internal version of the above function. (defun ctada_int () (send *db%debug_frame* :activate) (send *db%debug_frame* :expose) (send *db%debug_frame* ':select)) ;;;This is the top level function for ctada. It gets called whenever we start or ;;;reset the ctada process. (defun ctada_top_level (frame) frame (let ((terminal-io (send *db%user_window* :window))) (unwind-protect (cond ((or (status feature debugging) (status feature debug_debug)) (db%advise_login) (db%do_ctada)) (t (db%advise_login) (multiple-value-bind (nil error?) (errset (db%do_ctada)) (if error? (db%ctada_error "A system error has occurred. Please Contact Computer*Thought"))))) (db%unadvise_login)))) ;;;Rebind terminal io etc around our login kludge. This is so that the user may load ;;;an init file and not get a sheet lock. (defun db%advise_login () (advise fs:force-user-to-login :around ctada_login_advice nil (if (and (or (null fs:user-id) (ct_string_equal fs:user-id "")) (eq current-process (ct_send *db%debug_frame* ':process)) (boundp '*db%login_window*) (instancep *db%login_window*)) (let ((terminal-io *db%login_window*) (query-io *db%login_window*) (error-output *db%login_window*) its_value) (ct_send *db%login_window* ':expose) (ct_send *db%login_window* ':select) (setq its_value (multiple-value-list :do-it)) (ct_send *db%login_window* ':deexpose) (values-list its_value)) (values-list (multiple-value-list :do-it)))) #+Symbolics (advise fs:prompt-for-user-and-password :around ctada_login_advice nil (if (and (or (fifth arglist) (and (not (nth 7 arglist)) (sixth arglist))) (eq current-process (ct_send *db%debug_frame* ':process)) (boundp '*db%login_window*) (instancep *db%login_window*)) (let ((terminal-io *db%login_window*) (query-io *db%login_window*) (error-output *db%login_window*) its_value) (ct_send *db%login_window* ':expose) (ct_send *db%login_window* ':select) (setq its_value (multiple-value-list :do-it)) (ct_send *db%login_window* ':deexpose) (values-list its_value)) (values-list (multiple-value-list :do-it))))) ;;;Remove our advice to login (defun db%unadvise_login () (unadvise fs:force-user-to-login :around ctada_login_advice) #+Symbolics (unadvise fs:prompt-for-user-and-password :around ctada_login_advice)) ;;;This is the function which is the top level for the interp/debugger. It sets ;;;things up and then loops running the front end and then the backend. (defun db%do_ctada () (setq-globally base 10. ibase 10.) ; (ct_send terminal-io ':set-deexposed-typeout-action ':permit) (fs:force-user-to-login) (setq *db%default_pathname* (fs:user-homedir)) (db%init_scroll_window *db%user_window*) (setq *db%front_end_mode* nil) (setq *db%source_files* nil) (setq *db%object_output_file* nil) (setq *db%object_input_file* nil) (setq *db%listing_file* nil) (db%size_command_menus) (db%initial_interp_screen) (db%message "Welcome to the C*T Ada Developement System on ~a." (protect 'debugger)) (setq *lossage* t) (multiple-value-bind (nil thrownp) (*catch 'lossage (*catch 'db%quit_system (loop do (*catch 'db%catch_reprocess (unwind-protect (let ((tv:kbd-tyi-hook #'db%kbd-intercept-character)) (db%init_scroll_window *db%code_window*) (db%init_scroll_window *db%output_window*) (setq *db%temp_output_file* (format nil "~actadatmp~a.tmp" *temp_directory* (gensym))) (db%front_end_execution) (db%back_end_execution)) (when (db%probef *db%temp_output_file*) (deletef *db%temp_output_file*) (fs:expunge-directory *temp_directory*))))))) (when thrownp (db%ctada_error "A CTADA error has occurred. Please contact Computer*Thought")))) ;;;Process the blips from the interp set up window and starts things off. (defun db%front_end_execution () (db%initial_interp_screen) (db%message "Welcome to the C*T Ada Translator on ~a." (protect 'debugger)) (db%message "") (setq *db%front_end_mode* nil) (loop with finished = nil for frog = (db%select_for_commands) for keystroke = (ct_send *db%debug_frame* ':any-tyi) for (cmd button window) = (db%extract_click keystroke) do (*catch 'db%catch_command (cond (cmd (ct_selectq cmd (top-of-file (db%top_of_file window)) (bottom-of-file (db%bottom_of_file window)) (previous-page (db%previous_page window button)) (next-page (db%next_page window button)) (Quit-Session (db%quit_system)) (Find-String (db%find_string (ct_send (ct_send window ':associated-pane) ':get ':debug_window))) (Save-Contents (db%save_contents (ct_send (ct_send window ':associated-pane) ':get ':debug_window))) ((Check Execute Debug) (cond ((db%front_end_files_ok) (setq *db%front_end_mode* cmd) (setq finished t)))) (Clear (db%init_front_end_setup)) (Edit-Source (db%edit_file_spec '*db%source_files*)) (Edit-Library (db%edit_file_spec '*db%object_input_file*)) (Edit-Internal (db%edit_file_spec '*db%object_output_file*)) (Edit-Listing (db%edit_file_spec '*db%listing_file*)) (otherwise (beep)))) (t (beep)))) until finished) (db%translate)) ;;;Clear out the current setup. (defun db%init_front_end_setup () (setq *db%front_end_mode* nil) (setq *db%source_files* nil) (setq *db%object_output_file* nil) (setq *db%object_input_file* nil) (setq *db%listing_file* nil) (ct_send *db%interp_window* ':redisplay)) ;;;This function is called after a mouse click on one of the file specs. It ;;;allows the user to edit the file spec. (defun db%edit_file_spec (spec_name) (let* ((value (symeval spec_name)) (title (get spec_name 'db%title)) (count (get spec_name 'db%count)) (default_path (cond ((null value) *db%default_pathname*) ((consp value) (first value)) ((stringp value) value) (t *db%default_pathname*))) (prompt (ct_format nil "~a. Default path is ~a. Finish with ." title default_path))) (setq value (db%ask_paths prompt value default_path)) (cond (count (ct_selectq (get spec_name 'db%direction) (read (loop for file in value if (db%check_file_spec file 'read) collect file into new_value finally (set spec_name new_value))) (write (loop for file in value if (db%check_file_spec file 'write) collect file into new_value finally (set spec_name new_value))))) (t (and (> (length value) 1.) (db%message "You have specified too many files. Only the first one will be used")) (ct_selectq (get spec_name 'db%direction) (read (and (db%check_file_spec (first value) 'read_nil) (set spec_name (first value)))) (write (and (db%check_file_spec (first value) 'write_nil) (set spec_name (first value))))))) (ct_send *db%interp_window* ':redisplay))) ;;;try a few checks to make sure everything looks ok. (defun db%front_end_files_ok (&aux (result t)) (unless (or *db%source_files* *db%object_input_file*) (db%message "You did not specify any source or library files.") (setq result nil)) (loop for file in *db%source_files* unless (db%check_file_spec file 'read) do (setq result nil)) (unless (db%check_file_spec *db%object_input_file* 'read_nil) (setq result nil)) (unless (db%check_file_spec *db%object_output_file* 'write_nil) (setq result nil)) (unless (db%check_file_spec *db%listing_file* 'write_nil) (setq result nil)) (and (not result) (db%message "There are problems with your file specifications. Try again.")) result) ;;;A function to run the interpreter front end. (defun db%translate () (let (front_end_result) (db%initial_listing_screen) (with-output-buffered *db%user_window* (progn (db%message "Translation has begun ...") (db%message "~5tMode: ~a" *db%front_end_mode*) (db%message "~5tSource files: ~a" (or *db%source_files* "")) (db%message "~5tLibrary file: ~a" (or *db%object_input_file* "")) (db%message "~5tInternal file: ~a" (or *db%object_output_file* "")) (db%message "~5tListing file: ~a" (or *db%listing_file* "")))) ;;run the front end with 'adai, saving the value returned from ;;the function in front_end_result. If running in (cond (*db%listing_file* (with-open-file (output_file *db%listing_file* '(:out)) (setq front_end_result (adai *db%object_input_file* *db%envirnment* *db%source_files* output_file *db%listing_window* *db%listing_window* *db%listing_window* *db%listing_window*)))) (t ;;run the interpreter without scroll windows for better performance (when (db%probef *db%temp_output_file*) (deletef *db%temp_output_file*) (fs:expunge-directory *temp_directory*)) (ct_if (not (db%probedir *db%temp_output_file*)) (lose 'bad_temp_file 'db%translate '("Problems writing the temp file"))) (with-open-file (temp_output *db%temp_output_file* '(:out)) (setq front_end_result (adai *db%object_input_file* *db%envirnment* *db%source_files* (make-broadcast-stream temp_output *db%listing_window*) *db%listing_window* *db%listing_window* *db%listing_window* *db%listing_window*))))) (setq *db%front_end_tree* (first front_end_result)) ;;see if the user wanted to save the diana output (ct_if (and *db%object_output_file* *db%front_end_tree*) (save_tree *db%object_output_file*)) (db%message "Translation is complete."))) ;;; A function to check a file spec to make sure it will work in the prescibed mode. (defun db%check_file_spec (file_spec mode) (ct_selectq mode (read (cond ((and file_spec (db%probef file_spec)) t) (t (db%message "The file ~a, cannot be read." file_spec) nil))) (write (cond ((and file_spec (db%probedir file_spec)) t) (t (db%message "The file ~a, cannot be written." file_spec) nil))) (read_nil (cond ((or (null file_spec) (db%probef file_spec)) t) (t (db%message "The file ~a, cannot be read." file_spec) nil))) (write_nil (cond ((or (null file_spec) (db%probedir file_spec)) t) (t (db%message "The file ~a, cannot be written." file_spec) nil))))) ;;;Now try to set up things for the backend. (defun db%back_end_execution () (let ((back_end_args (list *db%front_end_tree* *db%output_window* *db%output_window* *db%output_window* *db%output_window* *db%output_window*))) ;;and get the debugger started in the proper mode. (cond ((or (eq *db%front_end_mode* 'check) (not (diana_nodep *db%front_end_tree*))) (setq back_end_args (cons 'check_mode back_end_args)) (apply 'db%debugger back_end_args) (db%quit_system)) ((eq *db%front_end_mode* 'debug) (setq back_end_args (cons 'debug_mode back_end_args)) (apply 'db%debugger back_end_args) (db%quit_system)) ((eq *db%front_end_mode* 'execute) (setq back_end_args (cons 'execute_mode back_end_args)) (apply 'db%debugger back_end_args) (db%quit_system)) (t (lose 'huh 'huh '("what mode are we in anyway")))))) ;;; Modified versions of the standard key board intercepters. Instead of signaling abort ;;; when the abort key is hit, we call db%abort_ada. Instead of calling break ;;; when a break key is hit, we call db%suspend_ada. ;;; This function knows what to do in response to each of the standard intercepted ;;; characters. (defun db%kbd-intercept-character (char &optional ignore) (setq inhibit-scheduling-flag nil) ; it was t in the io-buffer-output-function (selectq char (#\abort (db%abort_ada) t) ; Abort the ada program (#\break (db%suspend_ada) t))) ; Suspend the ada program ;;; This function is called, possibly in the keyboard process, when one of the ;;; standard asynchronous intercepted characters, of the sort that mungs over the ;;; process, is typed. Scheduling is inhibited. ;;; This does the actual munging of the process in a separate process, in case ;;; it has to wait for the process' stack-group to get out of some weird state. (defun db%kbd-asynchronous-intercept-character (char &optional window &aux p) (tv:kbd-esc-clear nil) ;forget chars typed before "ctrl-abort", even those inside window's (and (setq p tv:selected-window) ;find process to be hacked (setq p (funcall p ':process)) (selectq char ((#\c-abort #\c-break) (process-run-function '(:name "abort" :priority 50.) p ':interrupt #'db%kbd-intercept-character (dpb 0 %%kbd-control char))) ;;DON'T try running these in the original process as above! It breaks ;;for some unknown reason and you have to warm boot. You have been warned. ;;This whole sheet lock business is a real kludge and should be done some ;;other way. (#\c-s (tv:sheet-get-lock window)) (#\c-q (tv:sheet-release-lock window))))) ;;;This is the main command loop for the backend. (defun db%debug_command () (loop for frog = (db%select_for_commands) for keystroke = (ct_send *db%debug_frame* ':any-tyi) for (cmd button window) = (db%extract_click keystroke) do (*catch 'db%catch_command (cond (cmd (selectq cmd (top-of-file (db%top_of_file window)) (bottom-of-file (db%bottom_of_file window)) (previous-page (db%previous_page window button)) (next-page (db%next_page window button)) (Find-String (db%find_string (ct_send (ct_send window ':associated-pane) ':get ':debug_window))) (Save-Contents (db%save_contents (ct_send (ct_send window ':associated-pane) ':get ':debug_window))) (Single-Step (db%step)) (Quit-Session (db%quit_system)) (Translate (db%reprocess)) (Choose-File (db%choose_file)) (Monitor-Program (db%set_code_monitor)) (Monitor-Value (db%set_data_monitor)) (Remove-Monitor (db%remove_monitor)) (Describe-Object (db%describe_object button)) (Begin-Program (db%start)) (Continue-Program (db%resume)) (Debug (db%switch_to_debug_mode)) (Execute (db%switch_to_execute_mode)) (Debugger-State (db%debugger_state)) (Top-of-Act-Records (db%top_of_stack)) (Bottom-of-Act-Records (db%bottom_of_stack)) (Up-Activation-Record (db%up_stack)) (Down-Activation-Record (db%down_stack)) (Show-Activation-Record (db%show_stack)) (Display-Tag (db%display_tag)) (Describe-Tasks (db%show_tasks)) ;;Out for now until we have a better scheme ; (Select-Generic (db%select_generic)) (Select-Task (db%select_task)))) ((consp keystroke) (db%handle_mouse_click keystroke)) ((and (eq keystroke #\resume) (or (eq *db%front_end_mode* 'debug) (eq *db%front_end_mode* 'execute))) (db%resume)) (t (beep)))))) ;;;this will get the menu choice from a menu click (defun db%extract_menu_choice (click) (cond ((atom click) click) ((not (consp (cdr click))) (cdr click)) ((null (cddr click)) (cadr click)) (t (third click)))) ;;;Extracts the action button and window from a click and returns them as a list. (defun db%extract_click (click) (cond ((and (consp click) (eq (first click) ':menu)) (list (db%extract_menu_choice (second click)) (ldb %%kbd-mouse-button (third click)) (fourth click))) ((and (consp click) (eq (first click) ':mouse_item)) (list (db%extract_menu_choice (second click)) (ldb %%kbd-mouse-button (fourth click)) (third click))))) ;;;Moves the cursor in the code window via the mouse. (defun db%handle_mouse_click (keystroke) #+cadr (if (status feature jokes) (sys:%slide 1000 1 90 500000)) (let* ((window (third keystroke)) (xpos (fourth keystroke)) (ypos (fifth keystroke)) (codepane (ct_send *db%code_window* ':window)) (font (ct_send codepane ':current-font ))) (multiple-value (xpos ypos) (db%character_size codepane xpos ypos font)) (cond ((neq window codepane) (beep)) (t (ct_send codepane ':set-cursorpos xpos ypos ':character) (ct_send *db%code_window* ':set-current_xpos xpos) (ct_send *db%code_window* ':set-current_ypos ypos))))) ;;;Call this when the user interface has detected an error. (defun db%user_interface_error (error_string) (db%message error_string) (*throw 'db%catch_command t)) ;;; ;;;And now some functions for dealing with the various window configurations we use. ;;; ;;;This is the function which makes all the windows we will need. It is called ;;;at init time before we dump a band. (defun db%initial_make_windows () ;;make all of the windows and set up the various frame information (setq base 10. ibase 10.) ;just in case. (setq *db%debug_frame* (tv:make-window 'bordered_stream_frame ':process '(ctada_top_level :regular-pdl-size 4000. :special-pdl-size 4000.) ':panes `((menu-pane tv:command-menu-pane :font-map (fonts:cthl12b fonts:cthl12) :item-list ,*db%debug_menu_items*) (front-end-pane mouseable_scroll_window :label (:string "Translator Setup" :font fonts:cptfontb) :more-p nil :font-map (fonts:cptfontb) :deexposed-typeout-action :permit :display-item ,(tv:scroll-maintain-list #'(lambda () '(*db%source_files* *db%object_input_file* *db%object_output_file* *db%listing_file*)) #'(lambda (item) (get item 'db%display_list)))) (listing-pane scolling-window :more-p nil :save-bits t :font-map (fonts:cptfontb) :deexposed-typeout-action :permit :label (:string "Translation Listing//Errors" :font fonts:cptfontb)) (user-pane nice_window :save-bits t :deexposed-typeout-action :permit :font-map (fonts:cptfontb) :label (:string "Debugger Messages" :font fonts:cptfontb) :more-p nil) (code-pane really_nice_window :more-p nil :font-map (fonts:cptfontb) :save-bits t :deexposed-typeout-action :permit :label (:string "Source Code" :font fonts:cptfontb)) (output-pane nice_window :more-p nil :font-map (fonts:cptfontb) :deexposed-typeout-action :permit :save-bits t :label (:string "Ada Input//Output" :font fonts:cptfontb)) (user-menu-pane better-command-menu-pane :font-map (fonts:hl10b fonts:mouse) :save-bits t :item-list ,*db%better_command_menu_pane_item_list*) (code-menu-pane better-command-menu-pane :font-map (fonts:hl10b fonts:mouse) :save-bits t :item-list ,*db%better_command_menu_pane_item_list*) (output-menu-pane better-command-menu-pane :font-map (fonts:hl10b fonts:mouse) :save-bits t :item-list ,*db%better_command_menu_pane_item_list*)) ':constraints #+cadr '((main . ((menu-pane code-dmy user-dmy output-dmy) ((menu-pane . (5 :lines))) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((output-dmy :horizontal (12. :lines output-pane) (output-menu-pane output-pane) ((output-menu-pane . (:ask :pane-size))) ((output-pane :even)))) ((code-dmy :horizontal (:even) (code-menu-pane code-pane) ((code-menu-pane . (:ask :pane-size))) ((code-pane :even)))))) (front-end . ((menu-pane user-dmy front-end-pane) ((menu-pane . (2 :lines))) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((front-end-pane . (:even))))) (listing . ((menu-pane user-dmy listing-pane) ((menu-pane . (2 :lines))) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((listing-pane . (:even))))) (check-only . ((menu-pane user-dmy output-dmy) ((menu-pane . (2 :lines))) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((output-dmy :horizontal (:even) (output-menu-pane output-pane) ((output-menu-pane . (:ask :pane-size))) ((output-pane :even)))))) (execute-only . ((menu-pane user-dmy output-dmy) ((menu-pane . (2 :lines))) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((output-dmy :horizontal (:even) (output-menu-pane output-pane) ((output-menu-pane . (:ask :pane-size))) ((output-pane :even))))))) #+(or 3600. Lambda) '((main . ((dmy) ((dmy :horizontal (:even) (menu-pane real-dmy) ((menu-pane . (30 :characters))) ((real-dmy :vertical (:even) (code-dmy user-dmy output-dmy) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((output-dmy :horizontal (12 :lines output-pane) (output-menu-pane output-pane) ((output-menu-pane . (:ask :pane-size))) ((output-pane :even)))) ((code-dmy :horizontal (:even) (code-menu-pane code-pane) ((code-menu-pane . (:ask :pane-size))) ((code-pane :even)))))))))) (front-end . ((dmy) ((dmy :horizontal (:even) (menu-pane real-dmy) ((menu-pane . (30 :characters))) ((real-dmy :vertical (:even) (user-dmy front-end-pane) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((front-end-pane . (:even))))))))) (listing . ((dmy) ((dmy :horizontal (:even) (menu-pane real-dmy) ((menu-pane . (30 :characters))) ((real-dmy :vertical (:even) (user-dmy listing-pane) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((listing-pane . (:even))))))))) (check-only . ((dmy) ((dmy :horizontal (:even) (menu-pane real-dmy) ((menu-pane . (30 :characters))) ((real-dmy :vertical (:even) (user-dmy output-dmy) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((output-dmy :horizontal (:even) (output-menu-pane output-pane) ((output-menu-pane . (:ask :pane-size))) ((output-pane :even)))))))))) (execute-only . ((dmy) ((dmy :horizontal (:even) (menu-pane real-dmy) ((menu-pane . (30 :characters))) ((real-dmy :vertical (:even) (user-dmy output-dmy) ((user-dmy :horizontal (12. :lines user-pane) (user-menu-pane user-pane) ((user-menu-pane . (:ask :pane-size))) ((user-pane :even)))) ((output-dmy :horizontal (:even) (output-menu-pane output-pane) ((output-menu-pane . (:ask :pane-size))) ((output-pane :even))))))))))))) (ct_send (ct_send *db%debug_frame* ':get-pane 'user-menu-pane) ':set-associated-pane (ct_send *db%debug_frame* ':get-pane 'user-pane)) (ct_send (ct_send *db%debug_frame* ':get-pane 'code-menu-pane) ':set-associated-pane (ct_send *db%debug_frame* ':get-pane 'code-pane)) (ct_send (ct_send *db%debug_frame* ':get-pane 'output-menu-pane) ':set-associated-pane (ct_send *db%debug_frame* ':get-pane 'output-pane)) (setq *db%listing_window* (ct_send *db%debug_frame* ':get-pane 'listing-pane)) (setq *db%interp_window* (ct_send *db%debug_frame* ':get-pane 'front-end-pane)) ;;each db%debug_window know has a pane as its window (setq *db%user_window* (ct_make_instance 'db%debug_window ':window (ct_send *db%debug_frame* ':get-pane 'user-pane) ':lines-displayed (db%get_number_of_lines 'user-pane) ':max_ypos (db%get_number_of_lines 'user-pane) ':max_xpos (db%get_number_of_columns 'user-pane) ':write_only t)) (setq *db%output_window* (ct_make_instance 'db%debug_window ':window (ct_send *db%debug_frame* ':get-pane 'output-pane) ':lines-displayed (db%get_number_of_lines 'output-pane) ':max_ypos (db%get_number_of_lines 'output-pane) ':max_xpos (db%get_number_of_columns 'output-pane))) (setq *db%code_window* (ct_make_instance 'db%debug_window ':window (ct_send *db%debug_frame* :'get-pane 'code-pane) ':lines-displayed (db%get_number_of_lines 'code-pane) ':max_ypos (db%get_number_of_lines 'code-pane) ':max_xpos (db%get_number_of_columns 'code-pane) ':write_only t)) ;;tell each pane which debug window it is associated with (ct_send (ct_send *db%debug_frame* ':get-pane 'user-pane) ':putprop *db%user_window* ':debug_window) (ct_send (ct_send *db%debug_frame* ':get-pane 'output-pane) ':putprop *db%output_window* ':debug_window) (ct_send (ct_send *db%debug_frame* ':get-pane 'code-pane) ':putprop *db%code_window* ':debug_window) ;;make a few other assorted windows. (setq *db%input_window* (tv:make-window 'mousey_temporary_window ':character-height 1. ':width 700. ':deexposed-typeout-action ':permit ':save-bits t ':font-map '(fonts:cptfontb) ':label '(:top :string "Input Window" :font fonts:cptfontb))) (setq *db%login_window* (tv:make-window 'temporary_window ':character-height 10. ':width 700. ':font-map '(fonts:cptfontb) ':save-bits nil ':label '(:top :string "Login Window" :font fonts:cptfontb))) ;; the menu to pop up for multiple-entry queries. The "ABORT" option ;; causes the window to bury itself and then does a throw back ;; up to 'db%catch_command in the db%debug_command function (setq *db%multiple_menu* (tv:make-window 'temporary-multiple-menu ':special-choices '(("Do It" :eval (ct_send *db%multiple_menu* ':highlighted-values)) ("Abort" :eval (progn (ct_send *db%multiple_menu* ':bury) (*throw 'db%catch_command t)))) ':font-map '(fonts:hl12i fonts:hl12b))) (setq *db%path_editor_window* (tv:make-window 'temporary_window ':font-map '(fonts:cptfontb) ':label '(:top :string "Path Window" :font fonts:cptfontb) ':save-bits nil ':width 700. ':character-height 10.))) ;;;Let the user know we are running ada (defun db%select_for_ada () (let ((output_pane (ct_send *db%debug_frame* ':get-pane 'output-pane)) (code_pane (ct_send *db%debug_frame* ':get-pane 'code-pane)) (exposed_panes (ct_send *db%debug_frame* ':exposed-panes))) (ct_if (memq output_pane exposed_panes) (ct_send output_pane ':select)) (ct_if (memq code_pane exposed_panes) (ct_send (tv:sheet-following-blinker code_pane) ':set-visibility ':on)))) ;;;Let the user know we are accepting commands (defun db%select_for_commands () (let ((user_pane (ct_send *db%debug_frame* ':get-pane 'user-pane)) (code_pane (ct_send *db%debug_frame* ':get-pane 'code-pane)) (exposed_panes (ct_send *db%debug_frame* ':exposed-panes))) (ct_if (memq user_pane exposed_panes) (ct_send user_pane ':select)) (ct_if (memq code_pane exposed_panes) (ct_send (tv:sheet-following-blinker code_pane) ':set-visibility ':blink)))) ;;;Put a scroll window item on one line. (defun db%one_per_line (item) (tv:scroll-parse-item `(:string ,(format nil " ~a" item)))) ;;;Make the initial interpreter window. (defun db%initial_interp_screen () (let ((menu_pane (ct_send *db%debug_frame* ':get-pane 'menu-pane)) (user_pane (ct_send *db%debug_frame* ':get-pane 'user-pane))) (ct_send menu_pane ':set-item-list *db%null_menu_items*) ;;the initial configuration will be 'front-end (ct_send *db%debug_frame* 'set-configuration 'front-end) (ct_send menu_pane ':set-item-list *db%front_end_menu_items*) (ct_send user_pane ':set-label `(:string "Translator Setup Messages" :font fonts:cptfontb)) ;;start off with the user window selected ;;(ct_send (send *db%user_window* ':window) ':select) ;;get all of the exposed panes and for the ones that are instances ;;of "nice windows", let the window know who its pane is (loop for window_pane_name in (db%get_exposed_pane_names) for window = (ct_send *db%debug_frame* ':get-pane window_pane_name) if (typep window 'nice_window) do (db%update_window_info (ct_send window ':get ':debug_window) window_pane_name)) ;;Set up the initial window contents if we haven't done so already (when (ct_csend db%debug_window *db%user_window* 'init-flag) (ct_csend db%debug_window *db%user_window* ':display-string "") (ct_csend db%debug_window *db%user_window* 'set-init-flag nil)) (db%bottom_of_window *db%user_window*) ; (ct_send *db%interp_window* #-rel5.2 ':clear-screen #+rel5.2 ':clear-window);;These appear to happen for free ; (ct_send *db%interp_window* ':redisplay) (ct_send *db%debug_frame* ':clear-input))) ;;;Make the windows into the listing configuration (defun db%initial_listing_screen () (let ((menu_pane (ct_send *db%debug_frame* ':get-pane 'menu-pane)) (user_pane (ct_send *db%debug_frame* ':get-pane 'user-pane))) (ct_send menu_pane ':set-item-list *db%null_menu_items*) ;;the initial configuration will be 'front-end (ct_send *db%debug_frame* 'set-configuration 'listing) (ct_send menu_pane ':set-item-list *db%front_end_menu_items*) (ct_send user_pane ':set-label `(:string "Translation Messages" :font fonts:cptfontb)) ;;start off with the user window selected ;;(ct_send (ct_send *db%user_window* ':window) ':select) ;;get all of the exposed panes AND for the ones that are instances ;;of "nice windows", let the window know who its pane is (loop for window_pane_name in (db%get_exposed_pane_names) for window = (ct_send *db%debug_frame* ':get-pane window_pane_name) if (typep window 'nice_window) do (db%update_window_info (ct_send window ':get ':debug_window) window_pane_name)) ;;Set up the initial window contents if we haven't done so already (when (ct_csend db%debug_window *db%user_window* 'init-flag) (ct_csend db%debug_window *db%user_window* ':display-string "") (ct_csend db%debug_window *db%user_window* 'set-init-flag nil)) (db%bottom_of_window *db%user_window*) (ct_send *db%listing_window* #-rel5.2 ':clear-screen #+rel5.2 ':clear-window) (ct_send *db%debug_frame* ':clear-input))) ;; Make the debugger screen with three windows ;; Each of the windows will be an instance of db%debug_window. (defun db%initial_debugger_screen () (let ((menu_pane (ct_send *db%debug_frame* ':get-pane 'menu-pane)) (code_pane (ct_send *db%debug_frame* ':get-pane 'code-pane)) (user_pane (ct_send *db%debug_frame* ':get-pane 'user-pane)) (output_pane (ct_send *db%debug_frame* ':get-pane 'output-pane))) (ct_send menu_pane ':set-item-list *db%null_menu_items*) ;;the initial configuration will be 'main (ct_send *db%debug_frame* 'set-configuration 'main) (ct_send menu_pane ':set-item-list *db%debug_menu_items*) (ct_send code_pane ':set-label `(:string "Source Code" :font fonts:cptfontb)) (ct_send user_pane ':set-label `(:string "Debugger Messages" :font fonts:cptfontb)) (ct_send output_pane ':set-label `(:string "Ada Input//Output" :font fonts:cptfontb)) ;;start off with the user window selected ;;(ct_send (ct_send *db%user_window* ':window) ':select) ;;get all of the exposed panes and for the ones that are instances ;;of "nice windows", let the window know who its pane is (loop for window_pane_name in (db%get_exposed_pane_names) for window = (ct_send *db%debug_frame* ':get-pane window_pane_name) if (typep window 'nice_window) do (db%update_window_info (ct_send window ':get ':debug_window) window_pane_name)) ;;Set up the initial window contents if we haven't done so already (when (ct_csend db%debug_window *db%code_window* 'init-flag) (ct_csend db%debug_window *db%code_window* ':display-string "") (ct_csend db%debug_window *db%code_window* 'set-init-flag nil)) (ct_csend db%debug_window *db%code_window* ':reposition_cursor) (when (ct_csend db%debug_window *db%user_window* 'init-flag) (ct_csend db%debug_window *db%user_window* ':display-string "") (ct_csend db%debug_window *db%user_window* 'set-init-flag nil)) (db%bottom_of_window *db%user_window*) ;;if there's a temporary output file, display it, otherwise ;;the user must have listed output to a file, so just ;;display the null string (when (ct_csend db%debug_window *db%output_window* 'init-flag) (ct_if (db%probef *db%temp_output_file*) (ct_csend db%debug_window *db%output_window* ':display-file *db%temp_output_file* nil nil nil nil nil) (ct_csend db%debug_window *db%output_window* ':display-string "" nil)) (ct_csend db%debug_window *db%output_window* 'set-init-flag nil)) (db%bottom_of_window *db%output_window*) (ct_send *db%debug_frame* ':clear-input))) ; Make the execute screen with two windows. Each of the windows will be an instance ; of db%debug_window. (defun db%initial_executor_screen () (let ((menu_pane (ct_send *db%debug_frame* ':get-pane 'menu-pane)) (user_pane (ct_send *db%debug_frame* ':get-pane 'user-pane)) (output_pane (ct_send *db%debug_frame* ':get-pane 'output-pane))) (ct_send menu_pane ':set-item-list *db%null_menu_items*) ;;the initial configuaration will be execute only (ct_send *db%debug_frame* ':set-configuration 'execute-only) (ct_send menu_pane ':set-item-list *db%execute_menu_items*) (ct_send user_pane ':set-label `(:string "Executor Messages" :font fonts:cptfontb)) (ct_send output_pane ':set-label `(:string "Ada Input//Output" :font fonts:cptfontb)) ;;start off with the user window selected ;;(ct_send (ct_send *db%user_window* ':window) ':select) ;;get all of the exposed panes and for the ones that are instances ;;of "nice windows", let the window know who its pane is (loop for window_pane_name in (db%get_exposed_pane_names) for window = (ct_send *db%debug_frame* ':get-pane window_pane_name) if (typep window 'nice_window) do (db%update_window_info (ct_send window ':get ':debug_window) window_pane_name)) ;;Set up the initial window contents if we haven't done so already (when (ct_csend db%debug_window *db%user_window* 'init-flag) (ct_csend db%debug_window *db%user_window* ':display-string "") (ct_csend db%debug_window *db%user_window* 'set-init-flag nil)) (db%bottom_of_window *db%user_window*) ;;if there's a temporary output file, display it, otherwise ;;the user must have listed output to a file, so just ;;display the null string (when (ct_csend db%debug_window *db%output_window* 'init-flag) (ct_if (db%probef *db%temp_output_file*) (ct_csend db%debug_window *db%output_window* ':display-file *db%temp_output_file* nil nil nil nil nil) (ct_csend db%debug_window *db%output_window* ':display-string "" nil)) (ct_csend db%debug_window *db%output_window* 'set-init-flag nil)) (db%bottom_of_window *db%output_window*) (ct_send *db%debug_frame* ':clear-input))) ;;;Make the checker screen with two windows. (defun db%initial_checker_screen () (let ((menu_pane (ct_send *db%debug_frame* 'get-pane 'menu-pane)) (user_pane (ct_send *db%debug_frame* ':get-pane 'user-pane)) (output_pane (ct_send *db%debug_frame* ':get-pane 'output-pane))) (ct_send menu_pane ':set-item-list *db%null_menu_items*) ;;the initial configuaration will be check only (ct_send *db%debug_frame* ':set-configuration 'check-only) (ct_send menu_pane ':set-item-list *db%check_menu_items*) (ct_send user_pane ':set-label `(:string "Checker Messages" :font fonts:cptfontb)) (ct_send output_pane ':set-label `(:string "Translator Listing//Errors" :font fonts:cptfontb)) ;;start off with the user window selected ;;(ct_send (ct_send *db%user_window* ':window) ':select) ;;get all of the exposed panes and for the ones that are instances ;;of "nice windows", let the window know who its pane is (loop for window_pane_name in (db%get_exposed_pane_names) for window = (ct_send *db%debug_frame* ':get-pane window_pane_name) if (typep window 'nice_window) do (db%update_window_info (ct_send window ':get ':debug_window) window_pane_name)) ;;Set up the initial window contents if we haven't done so already (when (ct_csend db%debug_window *db%user_window* 'init-flag) (ct_csend db%debug_window *db%user_window* ':display-string "") (ct_csend db%debug_window *db%user_window* 'set-init-flag nil)) (db%bottom_of_window *db%user_window*) ;;if there's a temporary output file, display it, otherwise ;;the user must have listed output to a file, so just ;;display the null string (when (ct_csend db%debug_window *db%output_window* 'init-flag) (ct_if (db%probef *db%temp_output_file*) (ct_csend db%debug_window *db%output_window* ':display-file *db%temp_output_file* nil nil nil nil nil) (ct_csend db%debug_window *db%output_window* ':display-string "" nil)) (ct_csend db%debug_window *db%output_window* 'set-init-flag nil)) (db%bottom_of_window *db%output_window*) (ct_send *db%debug_frame* ':clear-input))) ;;;Get a list of all the panes which are currently exposed in the debug_frame. (defun db%get_exposed_pane_names () ;;get all of the exposed panes for the *db%debug_frame* (loop for pane in (ct_send *db%debug_frame* ':exposed-panes) collect (ct_send *db%debug_frame* ':pane-name pane))) ;;;figure out the number of lines that this pane has (defun db%get_number_of_lines (pane) (multiple-value-bind (nil height) (ct_send (ct_send *db%debug_frame* ':get-pane pane) ':size-in-characters) height)) ;;;figure out the number of columns for a pane (defun db%get_number_of_columns (pane) (- (ct_send (ct_send *db%debug_frame* ':get-pane pane) ':size-in-characters) 2)) ;;update the number of lines and columns for a window, using the ;;window and its pane for information (defun db%update_window_info (window pane) (ct_send window ':set-lines-displayed (db%get_number_of_lines pane)) (ct_send window ':set-max_ypos (db%get_number_of_lines pane)) (ct_send window ':set-max_xpos (db%get_number_of_columns pane))) ;;;Initialize a window. Clear it out and clear the init flag. (defun db%init_scroll_window (window) (ct_send (ct_send window ':window) #-rel5.2 ':clear-screen #+rel5.2 ':clear-window) (ct_send window ':display-string "") (ct_send window 'set-init-flag t)) ;;;Position the window and cursor at the bottom. (defun db%bottom_of_window (debug_window) (ct_csend db%debug_window debug_window ':end) (ct_csend db%debug_window debug_window ':adjust_position) (ct_csend db%debug_window debug_window ':reposition_cursor)) ;;; Translate from x,y pixel positions into x,y character positions. (defun db%character_size (real-window x y font) (let ((debug-window (ct_send real-window ':get ':debug_window))) (values (max (ct_send debug-window ':min_xpos) (min (// (- x 6.) (tv:font-char-width font)) (ct_send debug-window ':max_xpos))) (max (ct_send debug-window ':min_ypos) (min (// (- y 14) (ct_send real-window ':line-height)) (ct_send debug-window ':max_ypos)))))) ;;; ;;;A few little window ditties which are useful to other parts of the system. ;;; ;;;A function to position the cursor and make it blink in the indicated scroll window. #+lispm (defun db%point_in_window (window x y) ;;;update its ;;;current x and y positions to 'x and 'y (ct_send window 'set-current_xpos x) (ct_send window 'set-current_ypos y) (ct_send (ct_send window ':window) ':set-cursorpos x y ':character)) ;;;Retitle the code window (defun db%change_file_name (file_name) (ct_send (ct_send *db%code_window* ':window) ':set-label `(:string , (format nil "Ada Program: ~A" file_name) :font fonts:cptfontb))) #+3600. (defun db%size_command_menus () (setq *db%front_end_menu_items* (bottom_justify_menu *db%basic_front_end_menu_items* *db%last_menu_items*)) (setq *db%check_menu_items* (bottom_justify_menu *db%basic_check_menu_items* *db%last_menu_items*)) (setq *db%execute_menu_items* (bottom_justify_menu *db%basic_execute_menu_items* *db%last_menu_items*)) (setq *db%debug_menu_items* (bottom_justify_menu *db%basic_debug_menu_items* *db%last_menu_items*))) #+(or cadr Lambda) (defun db%size_command_menus () nil) ;;;Justify the items in a menu to fill the entire height (defun bottom_justify_menu (top_items bottom_items) (nconc (copylist top_items) (loop with lines = (db%get_number_of_lines 'menu-pane) repeat (- lines (length top_items) (length bottom_items)) collect '("" :no-select t)) (copylist bottom_items))) ;;; ;;;VARIOUS DEBUGGER REQUESTED INPUT FUNCTIONS ;;; ;;;;;;;;;;;;; (defun db%ask_string (prompt max_length &optional default_value) ;;;;;;;;;;;;; ;;Prompt the user to input a string of at most 'max_length ;;with prompt 'prompt and the default answer of 'default_value (let ((temp_string nil) (long_string (ct_if (eq max_length 'positive) *integer_last* max_length))) (ct_if default_value (setq temp_string (ct_format nil "~A [~A]:~3X" prompt default_value)) (setq temp_string (ct_format nil "~A [null string]:~3X" prompt ))) (loop while t with input_string = nil do (setq input_string (db%get_string_input prompt)) do (ct_if (or (equal input_string "") (not input_string)) (ct_if default_value (return default_value) (return nil))) when (< (string-length input_string) long_string) return input_string else do (db%user_interface_error "String too long")))) ;;;Ask the user for some path names. Seeds will be used for the initial value ;;;of the path names. Merge with def_path. (defun db%ask_paths (&optional prompt seeds (def_path *db%default_pathname*)) (or (consp seeds) (null seeds) (setq seeds (list seeds))) (let ((default_path (condition-case () (fs:default-pathname def_path) (error "no default"))) (strings "")) (loop for file in seeds do (setq strings (ct_string_append strings file #\return))) (ct_if (not (ct_stringp prompt)) (setq prompt (format nil "Default is ~a. Finish with ." default_path))) (setq strings (ct_string_append (db%edit_paths strings prompt) #\return)) (loop for head = 0 then (1+ tail) for tail = (ct_string_search_set '(#\return #/,) strings head) while tail for path_string = (ct_string_trim '(#\sp #\tab #\return) (ct_substring strings head tail)) if (not (ct_string_equal path_string "")) collect (condition-case () (ct_if (not (ct_string_equal default_path "no default")) (ct_send (fs:merge-pathnames path_string default_path) ':string-for-printing) path_string) (error path_string))))) ;;; A funtion to let the user edit some pathnames. Seed_string will be the ;;; initial paths. Pop up an editor to do the work. #|(defun db%edit_paths (&optional (seed_string "") (prompt "")) (ct_send *db%path_editor_window* ':set-interval-string seed_string) (ct_send *db%path_editor_window* ':set-label `(:top :string ,prompt :font fonts:hl12i)) (ct_send *db%path_editor_window* ':expose-near '(:mouse)) (ct_send *db%path_editor_window* ':select) (ct_send *db%path_editor_window* ':edit) (prog1 (ct_send *db%path_editor_window* ':interval-string) (ct_send (ct_send *db%path_editor_window* ':mode-line-window) ':done-with-mode-line-window) (ct_send *db%path_editor_window* ':bury)))|# (defun db%edit_paths (&optional (seed_string "") (prompt "")) (ct_send *db%path_editor_window* ':set-label `(:top :string ,prompt :font fonts:hl12i)) (ct_send *db%path_editor_window* ':expose-near '(:mouse)) (ct_send *db%path_editor_window* ':select) (unwind-protect (read-delimited-string #\end *db%path_editor_window* nil `((:initial-input ,seed_string))) (ct_send *db%path_editor_window* ':bury))) ;;;;;;;;;;;;;; (defun db%ask_integer (prompt low high &optional default_value) ;;;;;;;;;;;;;; ;;Prompt the user to input an integer with prompt 'prompt, ;;lowest allowed value 'low, highest allowed value 'high, ;; and optional default value 'default_value (let ((temp_string nil) (low_num (ct_if (eq low 'negative) *integer_first* low)) (high_num (ct_if (eq high 'positive) *integer_last* high))) (ct_if default_value (setq temp_string (ct_format nil "~A (~D to ~D) [~D]:~3X" prompt low high default_value)) (setq temp_string (ct_format nil "~A (~D to ~D) [~D]:~3X" prompt low high low))) (loop with input_num = nil do (setq input_num (db%get_input ':number-or-nil temp_string)) do (ct_if (or (eq input_num #\return) (eq input_num #\linefeed) (equal input_num "") (not input_num)) (ct_if default_value (return default_value) (return low))) when (and (fixp input_num) (>= input_num low_num) (<= input_num high_num)) return input_num else do (db%user_interface_error "Invalid number")))) ;;;;;;;;;;;;;; (defun db%ask_float (prompt low high &optional default_value) ;;;;;;;;;;;;;; ;;Prompt the user to input a float with prompt 'prompt, ;;lowest allowed value 'low, highest allowed value 'high, ;; and optional default value 'default_value (let ((temp_string nil) (low_num (ct_if (eq low 'negative) *float_first* low)) (high_num (ct_if (eq high 'positive) *float_last* high))) (ct_if default_value (setq temp_string (ct_format nil "~A (~D to ~D) [~D]:~3X" prompt low high default_value)) (setq temp_string (ct_format nil "~A (~D to ~D) [~D]:~3X" prompt low high low))) (loop with input_num = nil do (setq input_num (db%get_input ':number-or-nil temp_string)) do (ct_if (or (eq input_num #\return) (eq input_num #\linefeed) (equal input_num "") (not input_num)) (ct_if default_value (return default_value) (return low))) when (and (floatp input_num) (>= input_num low_num) (<= input_num high_num)) return input_num else do (db%user_interface_error "Invalid number")))) ;;;;;;;;;;;;;; (defun db%ask_literal (prompt item_list &optional default_value) ;;;;;;;;;;;;;; ;;ask the user to choose from a menu with 'prompt being ;;the prompt displayed and item_list consisting of either ;;an atom which will return itself as a value or ;;(item value) where item is displayed and value is returned ;;if that item is chosen. The optional default choice is ;;found in 'default_value, which again will be either an item ;;or an item,value pair. (let* ((default_print (ct_if (not default_value) (ct_if (atom (first item_list)) (first item_list) (first (first item_list))) (ct_if (atom default_value) default_value (first default_value)))) (menu_item_list (db%boldify_menu_items item_list)) (return_item nil)) (setq prompt (list ':top ':string prompt ':font fonts:hl12i)) (setq return_item (tv:menu-choose menu_item_list prompt '(:mouse) (loop for item in menu_item_list if (member default_print item) return item))) ;;****might not want a nil to signal the default choice (cond ((not return_item) (*throw 'db%catch_command t)) (t return_item)))) (defun db%boldify_menu_items (item_list) (loop for item in item_list collect (cond ((atom item) (list item ':value item ':font 'fonts:hl12b)) ((not (consp (cdr item))) (list (car item) ':value (cdr item) ':font 'fonts:hl12b)) ((null (cddr item)) (list (car item) ':value (cadr item) ':font 'fonts:hl12b)) (t (append item (list ':font 'fonts:hl12b)))))) ;;;;;;;;;;;;;;;;;;;;;;; (defun db%ask_multiple_literal (prompt item_list &optional default_value) ;;;;;;;;;;;;;;;;;;;;;;; ;;ask the user to choose from a menu with 'prompt being ;;the prompt displayed and item_list consisting of either ;;an atom which will return itself as a value or ;;(item value) where item is displayed and value is returned ;;if that item is chosen. The optional default choice is ;;found in 'default_value, which again will be either an item ;;or an item,value pair. ;;Multiple items are allowed to be chosen. (let* ((default_print (ct_if (not default_value) (ct_if (atom (first item_list)) (first item_list) (first (first item_list))) (ct_if (atom default_value) default_value (first default_value)))) (menu_item_list (db%boldify_menu_items item_list)) (highlighted_item (loop for item in menu_item_list if (member default_print item) return item)) (return_item nil)) (ct_send *db%multiple_menu* ':set-label `(:top :string ,prompt :font fonts:hl12i)) (ct_send *db%multiple_menu* ':set-item-list menu_item_list) (ct_if highlighted_item (ct_send *db%multiple_menu* ':set-highlighted-items (list highlighted_item))) (ct_send *db%multiple_menu* ':expose-near '(:mouse)) (unwind-protect (setq return_item (ct_send *db%multiple_menu* ':choose)) (ct_send *db%multiple_menu* ':bury)) (cond ((not return_item) (*throw 'db%catch_command t)) (t (reverse return_item))))) ;;;;;;;;;;;;; (defun db%ask_cursor (&optional (window *db%code_window*)) ;;;;;;;;;;;;; ;;return the (x,y) cursor position from the given window, (list (get-iv db%debug_window window current_xpos) (get-iv db%debug_window window current_ypos))) (defun db%get_string_input (prompt) (let ((query-io *db%input_window*) (error-output *db%input_window*) (input_string nil) (tv:kbd-tyi-hook nil)) (ct_send *db%input_window* #-rel5.2 ':clear-screen #+rel5.2 ':clear-window) (ct_send *db%input_window* ':set-label `(:top :string ,prompt :font fonts:hl12i)) (ct_send *db%input_window* ':expose-near '(:mouse)) (ct_send *db%input_window* ':select) (condition-case () (unwind-protect (setq input_string (prompt-and-read '(:delimited-string :delimiter (#\end #\return #\line #\mouse-l-1 #\mouse-m-1 #\mouse-r-1 #\mouse-l-2 #\mouse-m-2 #\mouse-r-2)) "")) (ct_send *db%input_window* ':bury)) (sys:abort));We catch it if the user types abort. Suspend can still squeak through. input_string)) (defun db%get_input (type prompt) (let ((query-io *db%input_window*) (error-output *db%input_window*) (input_string nil) (tv:kbd-tyi-hook nil)) (ct_send *db%input_window* #-rel5.2 ':clear-screen #+rel5.2 ':clear-window) (ct_send *db%input_window* ':set-label `(:top :string ,prompt :font fonts:hl12i)) (ct_send *db%input_window* ':expose-near '(:mouse)) (ct_send *db%input_window* ':select) (condition-case () (unwind-protect (setq input_string (prompt-and-read type "")) (ct_send *db%input_window* ':bury)) (sys:abort));We catch it if the user types abort. Suspend can still squeak through. input_string)) ;;; Not used any more #| ;;; **************************************************************** ;;; Gray Border code ;;; **************************************************************** ;;; Following is code to generate gray borders. ;;; This is a 2 by 32 bit array with alternating 1's and 0's. It is ;;; used to fill the borders. (defvar *gray-pattern* (fillarray (make-array '(32. 2) ':type 'art-1b) '(1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1 1 0 0 1))) (defun draw-gray-border (window alu left top right bottom) (bitblt alu (- right left) (- bottom top) *gray-pattern* 0 0 (ct_send window ':screen-array) left top)) (putprop 'draw-gray-border 4. 'tv:default-border-size) |# ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;