⟦0c165a57a⟧

TextFile

;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Emacs-Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;
;; tags-ada.el --- Ada tags lookup, Release 1.05
;; Author          : Unknown, enhanced by Lynn Slater
;; Created On      : Fri May 27 14:48:53 1988
;; Last Modified By: Lynn Slater
;; Last Modified On: Tue Oct 18 06:49:30 1988
;; Update Count    : 27
;; Status          : Beta Released
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; 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.

;; Make this file tags-ada.el in ~/el
;; You should byte-compile it.

;; Functions for working with Verdix Ada tags files.

;; History 		
;; 5-Oct-1988		Lynn Slater	
;;    Moved get-tags-for-ada-buffer to dired-ada
;; 26-Sep-1988		Lynn Slater	
;;    Made the tags functions produce better messages

(provide 'tags-ada)
(defvar  last-ada-tag-string-searched ""
  "Last Ada tag string searched for.  Saved so you can search for it again.")

(defvar  ada-non-identifier-regexp "[^a-zA-Z0-9_]"
  "Regexp that matches a character that cannot appear in an
Ada identifier.")

(defvar  ada-identifier-regexp "[a-zA-Z0-9_]"
  "Regexp that matches a character that can appear in an Ada identifier.")

(defconst  ada-reserved-words-list
  '( "abort"     "declare"     "generic"     "of"         "select"
     "abs"       "delay"       "goto"        "or"         "separate"
     "accept"    "delta"                     "others"     "subtype"
     "access"    "digits"      "if"          "out"             
     "all"       "do"          "in"                       "task"
     "and"                     "is"          "package"    "terminate"
     "array"                                 "pragma"     "then"
     "at"        "else"                      "private"    "type"
                 "elsif"       "limited"     "procedure"       
                 "end"         "loop"                          
     "begin"     "entry"                     "raise"      "use"
     "body"      "exception"                 "range"           
                 "exit"        "mod"         "record"     "when"
                                             "rem"        "while"
                               "new"         "renames"    "with"
     "case"      "for"         "not"         "return"          
     "constant"  "function"    "null"        "reverse"    "xor"
 )
  "List of reserved words in Ada."
)

(defvar  ada-tag-alist  nil
  "Alist used for completions of Ada tags.  The alist consists of a list
of triples.  Each triple is a list of three elements:  the tag, the
name of the file containing the tag, and a regexp string used to search
for the tag.")
(defvar ada-tag-directory "" ;; lrs
  "The name of the directory in which the tag files are found")

(defun member (e l)
  "Returns non-nil if ELT is an element of LIST.  Comparison done with 
equal.  The value is actually the tail of LIST whose car is ELT.
Why isn't this a predefined function in Emacs-Lisp?  "
  (let ((templ l))
    (catch 'result
       (while templ
          (if (equal e (car templ))
              (throw 'result (cdr templ))
             (setq templ (cdr templ))))
       nil)))

(defun make-ada-tag (str)
  "Turns str (a form from a a.tags output file) into a form acceptable
   for tags lookup. This means
       1. All specifications begin with 's#' and the converted identifier
       2. Identifiers are converted by reversing the order of occurance
          of names and replacing periods with '-'s. For example, 
          a1.b2.c3 becomes c3-b2-a1. If this had occured in a spec, it
	  would have become s#c3-b2-a1. This fits best with the users
	  desire to lookup the function name, with emacs style of command
          completine up to the next hyphen, and with the desire to be able
	  to find either body of specs but not both at once."
  (let ((specp nil)
	(term-list nil)
	(split)
	(chars (concat str ".")))

    (while (setq split (string-match "\\." chars))
      ;;(message "split %s" split) (sit-for 1)
      (if (and (> split 2) (string-equal "s#" (substring chars 0 2)))
	  (progn;; strip off the s#, but remember it
	    (setq specp t)
	    (setq chars (substring chars 2))
	    (setq split (- split 2))))
      (setq term-list (cons (substring chars 0 split) term-list))
      (setq chars (substring chars (1+ split)))
      ;;(message "chars %s" chars) (sit-for 1)
      )

    ;;(message "term-list %s" term-list) (sit-for 1)
    ;; ok, the string is broken down. Now rebuild it in reverse order
    (setq chars (if specp "s#" ""))
    (setq chars (concat chars (car term-list)))
    (setq term-list (cdr term-list))
    (while term-list
      (setq chars (concat chars "-" (car term-list)))
      (setq term-list (cdr term-list)))
    chars))

;; (make-ada-tag "AI_LBasic.Apply_Language")
;; (make-ada-tag "AI_DB.s#Apply_Language")
;; (make-ada-tag "abc")
;; (make-ada-tag "a.bc.de")
;; (make-ada-tag "a.s#bc.de")

(defun  build-ada-tag-alist  nil
  "Given a buffer containing a Verdix tag table, this subroutine
builds the ada-tag-alist.  Should only be used after
condition-ada-tag-table  has been run over the tag table."
  (goto-char (point-min))
  (setq ada-tag-alist nil)
  (while (not (eobp))
    (let ((start-of-tag  (point)))
      (search-forward  "\t")
      (backward-char  1)
      (let ((tag (buffer-substring  start-of-tag  (point))))
	(forward-char  1)
	(let ((start-of-filename (point)))
	  (search-forward "\t")
	  (backward-char  1)
	  (let ((filename (buffer-substring  start-of-filename  (point))))
	    (forward-char 2)
	    (let ((start-of-search-string  (point)))
	      (end-of-line)
	      (backward-char  1)
	      (let ((search-string
		     (buffer-substring  start-of-search-string  (point))))
		(setq ada-tag-alist
		      (cons (list (make-ada-tag tag) filename search-string)
			    ada-tag-alist))
		(next-line  1)
		(beginning-of-line))))))))
  (goto-char (point-min)))

;;(defun print-ada-taglist ()
;;  (let ((l ada-tag-alist))
;;    (with-output-to-temp-buffer "*temp*"
;;      (while l
;;	(print (car l))
;;	(setq l (cdr l))
;;	))))

(require 'location) ;; lrs
(require 'compl-read) ;; bug fix
(defun  goto-ada-tag  (ada-tag)
  "Given a Verdix Ada tag, this function finds it from the tag table.
It finds the file (in another window) and searches for the tag within it.

A Verdix Ada tag looks like an Ada name, except for the following cases:
Specifications:  the Ada simple name is prefaced by s#
Stubs:           the Ada simple name is prefaced by stub#

Bodies, types, etc., use the unmodified Ada name.
Example:  procedure spec ABC in package P is tagged as P.s#ABC"

  (interactive
    (list;; lrs
      ;; I would like to just call completing read, but this will give me back
      ;; the wrong value if the user gives a fill string but in the wrong
      ;; case. The new form of compleating read must be used.
      (let ((completion-ignore-case t));; value will revert upon exit from let
	(if (not ada-tag-alist) (error "There are no Ada tags loaded!"))
	(completing-read  "Ada tag: "
			  ada-tag-alist
			  'ada-tag-match-criterion
			  t
			  (current-ada-identifier)))))
  (let* ((location-pair  (cdr (assoc ada-tag  ada-tag-alist)))
	 (filename       (expand-file-name (car  location-pair) ;; lrs
					   ada-tag-directory))
	 (search-string  (car (cdr location-pair))))
    (if location-pair
	(if (file-exists-p filename)
	    (progn
	      (record-user-location)
	      (find-file filename)
	      (goto-char (point-min))
	      (if (re-search-forward search-string nil t)
		    (setq last-ada-tag-string-searched  search-string)
		(error "The regular expression '%s' was not found."
		       search-string)))
	  (error "Cannot find file '%s'" filename))
      ;; if we were passed the tag name, it may not always match
      (error "There is no tag entry for '%s'" ada-tag))
    ))

(defun  ada-tag-match-criterion  (ada-tag)
  "For now, let all tags match."
  t)

(defun  current-ada-identifier  nil
  "Returns, as a string, the identifier surrounding or just after point.
The empty string is returned if the identifier is an Ada reserved word."
  (catch 'id-string
    (save-excursion
      (if (or (eobp) (looking-at ada-non-identifier-regexp))
	  (condition-case  foo
	      (progn
		(re-search-backward  ada-identifier-regexp)
		(forward-char  1))
	    (error (throw 'id-string "")))
	(condition-case foo
	    (progn
	      (re-search-forward  ada-non-identifier-regexp)
	      (backward-char 1))
	  (error (end-of-buffer))))
      (set-mark  (point))
      (backward-char 1)
      (condition-case  foo
	  (progn
	    (re-search-backward  ada-non-identifier-regexp)
	    (forward-char  1))
	(error (goto-char (point-min))))
      (let ((identifier (buffer-substring (point) (mark))))
	(if (member (downcase identifier) ada-reserved-words-list)
	    ""
	  identifier)))))

(defun  tags-ada-continue-search  nil
  "Continue searching current file for next occurrence of last
Ada tag found."
  (interactive)
  (if (not (re-search-forward  last-ada-tag-string-searched nil t))
      (error "Cannot find another occurance of the Ada tag in this file.")))

(defun  visit-tags-table-ada  (tagfn)
  "Reads a file made by a.tags and converts it into internal data structures.
   After this, the emacs ada tag commands will work."
  (interactive "fTag file name: ")
  (message "Loading tags file, please wait...")
  ;;(sit-for 0)
  (save-excursion
    (set-buffer (get-buffer-create "*tag-ada*"))
    (erase-buffer)
    (insert-file  tagfn) ;; erases the message
    (message "Conditioning tags file, please wait...")
    (condition-ada-tag-table) ;; kills message
    (goto-char (point-min)) ;; (beginning-of-buffer)
    (set-buffer-modified-p nil)
    (message "Am making internal data structures")
    (sit-for 0)
    (build-ada-tag-alist)
    (setq ada-tag-directory (or (file-name-directory tagfn)
				default-directory));; lrs
    (kill-buffer "*tag-ada*")
    ;;(sit-for 0)
    )
  ;; forget the normal tags
  (setq tags-file-name nil)
  (message "Done! Tags loaded & available for use!")
  )

(defun  condition-ada-tag-table  nil
  "Given a buffer containing a Verdix tag table, this subroutine
converts the regexp search strings generated by a.tags into a form
that is more compatible with what Emacs expects of regexps."
  (goto-char (point-min))
  ;; replace string sets the mark and kills all messages
  (replace-string "\\[" "[")		;  \[  ->  [
  (goto-char (point-min))
  (replace-string "\\*" "*")		;  \*  ->  *
  (goto-char (point-min))
  (replace-string """**" """\\**")	;  "**  ->  "\**
  (goto-char (point-min))
  (replace-string """*" """\\*")	;  "*  ->  "\*
  (goto-char (point-min))
  (replace-string """+" """\\+")	;  "+  ->  "\+
  (goto-char (point-min))
  (replace-string "*""\\+" "*\\+")	;  *"\+  ->  *\+
  (goto-char (point-min))
  (replace-string "*""-" "*\\-")	;  *"-  ->  *\-
  (goto-char (point-min))
  (replace-string "*""\\/" "*\\/")	;  *"\/  ->  *\/
  (goto-char (point-min))
  (replace-string "\\**" "\\*\\*")	; \**  ->  \*\*
  (goto-char (point-min))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Installation: The problem
;;
;; Normal tags and ada tags are incompatable in how they operate
;; internally, but they have almost the same user view.  It would be nice
;; to have single commands that knew which internals to use. Then which tag
;; function was bound to which key would not depend upon the mode. 
;;
;; The core approach:
;;    visit-tags-table will reset ada-tag-alist and
;;    visit-tags-table-ada will reset tags-file-name
;; Then single functions will see which is set and know which function to
;; call.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; load tags if not already loaded
(if (not (fboundp 'find-tag))
    (load-library "tags"))

(defun find-tag-universal ()
  "Calls either find-tag or goto-ada-tag depending upon the last tags table
   loaded." 
  (interactive)
  (call-interactively (if tags-file-name 'find-tag 'goto-ada-tag)))

(defun tags-loop-continue-universal ()
  "Calls either tags-loop-continue or tags-ada-continue-search depending
   upon the last tags table loaded."
  (interactive)
  (call-interactively (if tags-file-name
			  'tags-loop-continue
			'tags-ada-continue-search)))

;; now, I need visit-tags-table to reset my variables
(defun visit-tags-table (file)
  "Tell tags commands to use tag table file FILE.
FILE should be the name of a file created with the `etags' program.
A directory name is ok too; it means file TAGS in that directory."
  (interactive (list (read-file-name "Visit tags table: (default TAGS) "
				     default-directory
				     (concat default-directory "TAGS")
				     t)))
  (setq file (expand-file-name file))
  (if (file-directory-p file)
      (setq file (concat file "TAGS")))
  (setq tag-table-files nil
	tags-file-name file
	ada-tag-alist nil ;; forget ada tags
	))

;; now install the tags
(define-key esc-map "." 'find-tag-universal)
(define-key esc-map "," 'tags-loop-continue-universal)
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦0c165a57a⟧ TextFile

Derivation

TextFile
