⟦f8e475243⟧

TextFile

;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Emacs-Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a-db.el ---  Run a.db under Emacs
;; Author          : Lynn Slater, W. Schelter, Richard M. Stallman
;; Created On      : Fri Jul 15 09:14:44 1988
;; Last Modified By: Lynn Slater
;; Last Modified On: Tue Oct 18 07:31:31 1988
;; Update Count    : 45
;; Status          : General Public Release 1.05
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This file is part of GNU Emacs.
;; Copyright (C) 1988 Lynn Randolph Slater, Jr.
;; Copyright (C) 1988 Free Software Foundation, Inc.
;;
;; This file is distributed in the hope that it will be useful,
;; but without any warranty.  No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing.
;;
;; Everyone is granted permission to copy, modify and redistribute
;; this file, but only under the conditions described in the
;; document "GNU Emacs copying permission notice".   An exact copy
;; of the document is supposed to have been given to you along with
;; this file so that you can know how you may redistribute it all.
;; It should be in a file named COPYING.  Among other things, the
;; copyright notice and this notice must be preserved on all copies.

;; Author: Lynn R. Slater, ESL
;;    lrs@esl.com
;;
;; Based upon the gdb to emacs interface written by
;; Author: W. Schelter, University of Texas
;;     wfs@rascal.ics.utexas.edu
;; and Rewritten by rms.
;;
;; Store as a-db.el and byte compile in your path
;; Read the mode help for details of how the interface works.

;; History 		
;; 12-Oct-1988		Lynn Slater	
;;    Made the ada-db-print-value and set break commands cause the
;;    debugger buffer to appear and to scroll.
;; 11-Oct-1988		Lynn Slater	
;;    Added the ada-db-print-value command. Is really handy!
;; 6-Oct-1988		Lynn Slater	
;;    Made a-db startup handle a change in directories better
;; 5-Oct-1988		Lynn Slater	
;;    Changed ada-db-mode to a-db-mode.
;;    Made a-db-mode be invokable from any existing shell so that
;;      this interface can be used even if the a-db command fails.
;; 5-Oct-1988		Lynn Slater	
;;    Made the shell be insensitive to cd's, pushes, and pops.
;; 28-Sep-1988		Lynn Slater	
;;    Made a-db kill the old debugging session
;;    Made the ada-db-prompt-pattern be better. You can now reuse lines.

(provide 'a-db)
(require 'shell)
(require 'elec-ada)

(defvar ada-db-prompt-pattern " *▶08◀> *"
  "A regexp to recognize the prompt from a.db.") 

(defvar ada-db-position-pattern
  "^\\(.* stopped .* \\)*\"\\(/.*\\)\".*:\\([0-9]+\\)"
  "A regexp to recognize file and line numbers in a.db output.
   The file name must correspond to (match-beginning 1) (match-end 1) and
   The line number must correspond to (match-beginning 2) (match-end 2).")
;;(makunbound 'ada-db-position-pattern)

(defvar ada-db-mode-map nil
  "Keymap for ada-db-mode.")

(if ada-db-mode-map
   nil
  (setq ada-db-mode-map (copy-keymap shell-mode-map))
  (define-key ada-db-mode-map "\C-l" 'ada-db-refresh))

(define-key ada-mode-map "\C-cb" 'ada-db-break)
(define-key ada-mode-map "\C-cp" 'ada-db-print-value)
;;->(define-key ctl-x-map "&" 'send-ada-db-command)


(defmacro def-ada-db (name key &optional doc)
  "Send STRING to a.db whenever KEYSEQUENCE is used in a debugger window.
   Option third arguement DOC."
  (let* ((fun (intern (format "a.db:%s" name)))
	 (cstr (list 'if '(not (= 1 arg))
		     (list 'format "%s %s" name 'arg)
		     name)))
    (list 'progn
 	  (list 'defun fun '(arg)
		(or doc "")
		'(interactive "p")
		(list 'ada-db-call cstr))
	  (list 'define-key 'ada-db-mode-map key  (list 'quote fun)))))

(progn
  ;; define standard set of a.db commands
  (def-ada-db "a"   "\C-ca" "Step one source line over calls")
  (def-ada-db "ai"  "\C-cA" "Step one instruction over calls")
  (def-ada-db "s"   "\C-cs" "Step one source line into subprograms")
  (def-ada-db "si"  "\C-cS" "Step one instruction into subprograms")
  (def-ada-db "g"   "\C-cg" "Continue executing the program")

  (def-ada-db "quit"   "\C-cq" "Terminate the debugger, keep the buffer")

  ;; current position changing fcns must let me know what the position is
  (def-ada-db "cs; e" "\C-c?" "Display the call stack")
  (def-ada-db "ct; e" "\C-ct" "Move to the top frame of the call stack")
  (def-ada-db "cb; e" "\C-cb" "Move to the Bottom frame of the call stack")
  (def-ada-db "cu; e" "\C-cu" "Move up on the call stack")
  (def-ada-db "cd; e" "\C-cd" "Move down on the call stack")
  (def-ada-db "e"    "\C-c." "Show current position");; ???
  (def-ada-db "bd; g" "\C-cf" "Finish executing current function and then stop")
  ;; home??
  )

;; \f


(defvar a-db-mode-hook nil "Function to call when a-db starts")

(defun a-db-mode ()
  "Major mode for interacting with an inferior Ada-Db process.
Read on for details.

This mode may either be invoked by either the a-db command or by typing
\\<shell-mode-map>\\[a-db-mode] from an existing shell which happens to be running 
the debugger.\\<ada-db-mode-map>

Operation:  a-db mode is a variant of shell mode where senitals are
  scanning all shell output for file and line information.  Whenever these
  are found, the file and line are displayed in the other window.

  Also, certain easy to use input macros are defined.

  More details follow after the commands are explained.

Commands:
  All commands from shell mode are available
  Additionally we have special bindings of VADS strings to emacs key sequences.

The following commands are available: \\{ada-db-mode-map}

If you are in an Ada source file:
  You may select a point to break at by placing the point on the desired
    line and typing \\<ada-mode-map>'\\[ada-db-break]'\\<ada-db-mode-map>.
    However, because of the way VADS does things, this resets the current
    position to home.
  You may print a value by positioning the cursor on the value and typing
    '\\<ada-mode-map>\\[ada-db-print-value]\\<ada-db-mode-map>'.

				  -- * --
Description of ADA-DB interface for the Verdex (VADS) debugger:

A facility is provided for the simultaneous display of the source code
in one window, while using a.db to step through a function in the
other.  A small arrow \"=>\" in the source window, indicates the current
line. This arrow is not really part of the buffer and cannot be edited.

Starting up:

In order to use this facility, invoke the command \"M-x a-db\" to obtain a
shell window with the appropriate command bindings.  You will be asked
for the name of a file to run.  a.db will be invoked on this file, in a
window named *a.db-foo* if the file is foo.

Only one debugger can be running at a time or emacs may get confussed
about which debugger it should send breakpoints and other stuff to.

You may control the debugger by typing at the end of the debugger shell buffer
or you may bind debugger commands to emacs key sequences using the macro
def-ada-db.  For example to put the ada-db command \"ai;e\" on C-ca
(def-ada-db \"ai;e\" \"\C-ca\"). These sequences will work only in the
debugging buffer.

ada-db-display-frame is the basic display function.  It tries to display
in the other window, the file and line corresponding to the current
position as known to the debugger.  For example after an a.db step, it
would display the line corresponding to the position for the last step.

The problem is knowing where the debugger thinks the current position
is.  To do this, \"process senitals\" are made that scan the output from
a.db and look for indications of the current position. This works fine
for the \"stopped at\" messages but fails at times because the verdex
debugger often changes the current position without showing the file
and line to which the new current position corresponds. The \"e\" verdex
command prints the current position and can be used in these cases. For
example, the emacs binding for \"up stack\" sends \"cu;e\" instead of just \"cu\" 
because otherwise emacs would not know the current position.
"
  (interactive)
  (kill-all-local-variables)
  (setq major-mode 'a-db-mode)
  (setq mode-name "Inferior Ada-Db")
  (setq mode-line-process '(": %s"))
  (use-local-map ada-db-mode-map)
  (make-local-variable 'last-input-start)
  (setq last-input-start (make-marker))
  (make-local-variable 'last-input-end)
  (setq last-input-end (make-marker))
  (make-local-variable 'ada-db-last-frame)
  (setq ada-db-last-frame nil)
  (make-local-variable 'ada-db-last-frame-displayed-p)
  (setq ada-db-last-frame-displayed-p t)
  ;;(make-local-variable 'ada-db-delete-prompt-marker)
  ;;(setq ada-db-delete-prompt-marker nil)
  (make-local-variable 'ada-db-filter-accumulator)
  (setq ada-db-filter-accumulator nil)
  (make-local-variable 'shell-prompt-pattern)
  (setq shell-prompt-pattern ada-db-prompt-pattern)
  ;; Make this shell insensitive to cd, popd, and pushd
  (make-local-variable 'shell-popd-regexp)
  (make-local-variable 'shell-pushd-regexp)
  (make-local-variable 'shell-cd-regexp)
  (setq shell-popd-regexp "$^";; an impossible regular expression
        shell-pushd-regexp "$^"
        shell-cd-regexp "$^")

  ;; if we already have a process running, start the senitals!
  (if (get-buffer-process (current-buffer))
    (progn
       (set-process-filter (get-buffer-process (current-buffer))
		    'ada-db-filter)
       (set-process-sentinel (get-buffer-process (current-buffer))
		      'ada-db-sentinel)
       (goto-char (point-max))
       (ada-db-set-buffer)))
  (run-hooks 'shell-mode-hook 'a-db-mode-hook))

(defvar current-ada-db-buffer nil)

(defvar ada-db-command-name "a.db";; VADS
  "Pathname for executing ada-db.")
;;(setq ada-db-command-name "sh")
;;(setq ada-db-command-name "a.db")

(defvar ada-db-last-file-name nil)

(defun a-db (path)
  "Run a.db on program FILE in buffer *ada-db-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for a.db.

This automatic startup may not work on all systems.  If this fails, you may
run a.db from within a shell window and type \\<shell-mode-map>\\[a-db-mode].

You may get a message such as 'Do not understand 'cm' % sequence.'
This is VADS complaining that the termcap entry does not let VADS move the
cursor of the terminal. (Under emacs, you do not want VADS to move your
cursor.) Ignore this message."
  (interactive
   (list (setq ada-db-last-file-name
	       (expand-file-name
		(read-file-name "Run a.db on binary file: "
				nil
				(and ada-db-last-file-name (file-name-nondirectory ada-db-last-file-name))
				t)
		(and ada-db-last-file-name (file-name-directory ada-db-last-file-name))))))
  (setq path (expand-file-name path))
  (let ((file (file-name-nondirectory path)))
    (switch-to-buffer (concat "*a.db-" file "*"))
    (setq default-directory (file-name-directory path))
    (goto-char (point-max))
    (or (bolp) (newline))
    (insert "Current directory is " default-directory "\n")

    (while (get-buffer-process (current-buffer))
      (kill-process (get-buffer-process (current-buffer)))
      )
    ;; For some reason, the line below does not work on primes or
    ;; on vms machines.  If this is the case, start a shell, run the
    ;; debugger, and type M-x a-db-mode.
    ;;
    ;; This logic mimics the make-shell function
    (switch-to-buffer (get-buffer-create (concat "*a.db-" file "*")))
    (start-process (concat "a.db-" file) (current-buffer)
		   (concat exec-directory "env")
		   (format "TERMCAP=emacs:co#%d:tc=unknown:"
			   (screen-width))
		   "TERM=emacs"
		   "EMACS=t"
		   "-" ada-db-command-name file)
    (goto-char (point-max))
    (set-marker (process-mark (get-buffer-process (current-buffer)))
		(point))

    ;; start the Process senitals
    (a-db-mode)
    ))

(defun ada-db-set-buffer ()
  (cond ((eq major-mode 'a-db-mode)
	(setq current-ada-db-buffer (current-buffer)))))
\f


(defun ada-db-filter (proc string)
  ;; This function is responsible for inserting output from ADA-DB
  ;; into the buffer.
  ;; Aside from inserting the text, it notices changes in the current position
  ;; as printed by a.db
  ;; It records the filename and line number, and maybe displays that file.
  (let ((inhibit-quit t))
    (if ada-db-filter-accumulator
	(ada-db-filter-scan-input proc
				  (concat ada-db-filter-accumulator string))
      (ada-db-filter-scan-input proc string))))

(defun ada-db-filter-accumulate-marker (proc string)
  ;; this is called only when string has a current position indication

  ;;(setq fam (cons string fam))
  (if (> (length string) 1)
	  (let ((end (string-match "\n" string))) ;; end of this line
	    (if end ;; if we did not find end of line, let it accuulate more
		(progn
		  ;; look for stopped at "/..../":nn
		  (if (string-match ada-db-position-pattern string)
		      (let ((fb (match-beginning 2))
			    (fe (match-end 2))
			    (lb (match-beginning 3))
			    (le (match-end 3)))
			(setq ada-db-last-frame
			      (cons (substring string fb fe)
				    (string-to-int
				     (substring string lb
						le))))
			(ada-db-filter-insert proc (substring string 0 (1+ end))))
		    (error "ada-db-filter-accumulate-marker called with no currnet position indication"))
		  (setq ada-db-last-frame-displayed-p nil)
		  ;; now, scan the unprocessed input
		  (ada-db-filter-scan-input proc
					    (substring string (1+ end)))
		  ) 
	      (setq ada-db-filter-accumulator string)))
    (setq ada-db-filter-accumulator string)))

;;(setq fci nil)
;;(setq string (car fam))
;;(setq string (nth 1 fci))
;;(setq fam nil)

(defun ada-db-filter-scan-input (proc string)
  ;;(setq fci (cons string fci))
  (if (equal string "")
      (setq ada-db-filter-accumulator nil) ;; ???
      (let ((start (string-match ada-db-position-pattern string)))
	(if start
	    (progn (ada-db-filter-insert proc (substring string 0 start))
		   (ada-db-filter-accumulate-marker proc
						 (substring string start)))
	    (ada-db-filter-insert proc string)))))

(defun ada-db-filter-insert (proc string);; untested
  (let ((moving)
	(output-after-point (< (point) (process-mark proc)))
	(old-buffer (current-buffer))
	(old-window (selected-window))
	(alive-window (get-buffer-window (process-buffer proc)))
	start)
    (if alive-window
	(select-window alive-window)
      (set-buffer (process-buffer proc)))
    (setq moving  (= (point) (marker-position (process-mark proc))))
    (unwind-protect
	(save-excursion
	  ;; Insert the text, moving the process-marker.
	  (goto-char (process-mark proc))
	  (setq start (point))
	  (insert string)
	  (set-marker (process-mark proc) (point))
	  ;;(ada-db-maybe-delete-prompt)
	  ;; Check for a filename-and-line number.
	  (ada-db-display-frame
	   ;; Don't display the specified file
	   ;; unless (1) point is at or after the position where output appears
	   ;; and (2) this buffer is on the screen.
	   (or output-after-point
	       (not (get-buffer-window (current-buffer))))
	   ;; Display a file only when a new filename-and-line-number appears.
	   t))
      (progn
	(if moving (goto-char (process-mark proc)))
	(if alive-window
	    (select-window old-window)
	  (set-buffer old-buffer))))
    ))

(defun ada-db-sentinel (proc msg)
  (cond ((null (buffer-name (process-buffer proc)))
	 ;; buffer killed
	 ;; Stop displaying an arrow in a source file.
	 (setq overlay-arrow-position nil)
	 (set-process-buffer proc nil))
	((memq (process-status proc) '(signal exit))
	 ;; Stop displaying an arrow in a source file.
	 (setq overlay-arrow-position nil)
	 ;; Fix the mode line.
	 (setq mode-line-process
	       (concat ": "
		       (symbol-name (process-status proc))))
	 (let* ((obuf (current-buffer)))
	   ;; save-excursion isn't the right thing if
	   ;;  process-buffer is current-buffer
	   (unwind-protect
	       (progn
		 ;; Write something in *compilation* and hack its mode line,
		 (set-buffer (process-buffer proc))
		 ;; Force mode line redisplay soon
		 (set-buffer-modified-p (buffer-modified-p))
		 (if (eobp)
		     (insert ?\n mode-name " " msg)
		   (save-excursion
		     (goto-char (point-max))
		     (insert ?\n mode-name " " msg)))
		 ;; If buffer and mode line will show that the process
		 ;; is dead, we can delete it now.  Otherwise it
		 ;; will stay around until M-x list-processes.
		 (delete-process proc))
	     ;; Restore old buffer, but don't restore old point
	     ;; if obuf is the ada-db buffer.
	     (set-buffer obuf))))))


(defun ada-db-refresh ()
  "Fix up a possibly garbled display, and redraw the arrow."
  (interactive)
  (redraw-display)
  (ada-db-display-frame))

(defun ada-db-display-frame (&optional nodisplay noauto)
  "Find and display in a window the last filename-and-line marker recieved
from  a.db.
  The marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n."
  (interactive)
  (ada-db-set-buffer)
  (and ada-db-last-frame (not nodisplay)
       (or (not ada-db-last-frame-displayed-p) (not noauto))
       (progn (ada-db-display-line (car ada-db-last-frame) (cdr ada-db-last-frame))
	      (setq ada-db-last-frame-displayed-p t))))

;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its line LINE is visible.
;; Put the overlay-arrow on the line LINE in that buffer.

(defun ada-db-display-line (true-file line)
  (let* ((buffer (find-file-noselect true-file))
	 (window (display-buffer buffer t))
	 (pos))
    (save-excursion
      (set-buffer buffer)
      (save-restriction
	(widen)
	(goto-line line)
	(setq pos (point))
	(setq overlay-arrow-string "=>")
	(or overlay-arrow-position
	    (setq overlay-arrow-position (make-marker)))
	(set-marker overlay-arrow-position (point) (current-buffer)))
      (cond ((or (< pos (point-min)) (> pos (point-max)))
	     (widen)
	     (goto-char pos))))
    (set-window-point window overlay-arrow-position)))
\f


(defun ada-db-call (command) ;; ???
  "Invoke ada-db COMMAND displaying source in other window."
  (interactive)
  (goto-char (point-max))
  ;;(setq ada-db-delete-prompt-marker (point-marker))
  (ada-db-set-buffer)
  (send-string (get-buffer-process current-ada-db-buffer)
	       (concat command "\n")))

;;->(defun ada-db-maybe-delete-prompt ()
;;->  (if (and ada-db-delete-prompt-marker
;;->	   (> (point-max) (marker-position ada-db-delete-prompt-marker)))
;;->      (let (start)
;;->	(goto-char ada-db-delete-prompt-marker)
;;->	(setq start (point))
;;->	(beginning-of-line)
;;->	;;(delete-region (point) start)
;;->	(setq ada-db-delete-prompt-marker nil))))

(defun what-ada-package ()
  "Returns the name of the package holding the current line"
  ;;(interactive)
  (save-excursion
    (if (re-search-backward "^[ \t]*package[ \t]+\\(body[ \t]+\\)*\\(.+\\)[ \t]+is" nil t)
	(let ((pb (match-beginning 2))
	      (pe (match-end 2))
	      (bb (match-beginning 1))
	      (be (match-end 1)))
	  (concat (buffer-substring pb pe) "'" (if bb "1" "2"))
	  )
      (error "Cound not figure out what package this was in"))))

(defun vads-file-name ()
  "Returns a string that lets VADS know the name of the current file"
  (if (string-match "-" (buffer-file-name))
      (what-ada-package)
    (buffer-file-name)))

(defun ada-db-break ()
  "Set ADA-DB breakpoint at this source line. Move current position to home"
  ;; Vads does not make this easy! We must send "e file-name;b line;*"
  ;; note: vads does not allow hyphens in file names in the e command
  (interactive)
  (let (--(file-name (file-name-nondirectory buffer-file-name))
	(line (save-restriction
		(widen)
		(1+ (count-lines 1 (point))))))
    (send-string (get-buffer-process current-ada-db-buffer)
		 (concat "e \"" (buffer-file-name) "\";b " line ";*;e\n"))
    (move-to-end-of-process current-ada-db-buffer)
    ))

(defun ada-db-print-value ()
  "Print the value under the cursor."
  (interactive)
  (move-to-end-of-process current-ada-db-buffer)
  (send-string (get-buffer-process current-ada-db-buffer)
	       (concat "p "(ada-current-expression) "\n"))
  )

(defun move-to-end-of-process (buffer)
  "Make sure that buffer is visible and that we are at its end"
  (let ((old-w (selected-window)))
    (select-window (display-buffer buffer))
    (goto-char (marker-position (process-mark (get-buffer-process buffer))))
    (select-window old-w)))
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦f8e475243⟧ TextFile

Derivation

TextFile
