Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-eif-ft.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 4103f0995bd7
children 4be1180a9e89
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
4 ;; SUMMARY: Eiffel OO-Browser class and feature functions. 4 ;; SUMMARY: Eiffel OO-Browser class and feature functions.
5 ;; USAGE: GNU Emacs Lisp Library 5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: oop, tools 6 ;; KEYWORDS: oop, tools
7 ;; 7 ;;
8 ;; AUTHOR: Bob Weiner 8 ;; AUTHOR: Bob Weiner
9 ;; ORG: InfoDock Associates 9 ;; ORG: Motorola Inc.
10 ;; 10 ;;
11 ;; ORIG-DATE: 03-Oct-90 11 ;; ORIG-DATE: 03-Oct-90
12 ;; LAST-MOD: 31-Oct-96 at 17:05:31 by Bob Weiner 12 ;; LAST-MOD: 11-May-95 at 11:24:33 by Bob Weiner
13 ;; 13 ;;
14 ;; Copyright (C) 1990-1996 Free Software Foundation, Inc. 14 ;; Copyright (C) 1990-1995 Free Software Foundation, Inc.
15 ;; See the file BR-COPY for license information. 15 ;; See the file BR-COPY for license information.
16 ;; 16 ;;
17 ;; This file is part of the OO-Browser. 17 ;; This file is part of the OO-Browser.
18 ;; 18 ;;
19 ;; DESCRIPTION: 19 ;; DESCRIPTION:
20 ;; DESCRIP-END. 20 ;; DESCRIP-END.
21 21
22 ;;; ************************************************************************ 22 ;; ************************************************************************
23 ;;; Other required Elisp libraries 23 ;; Other required Elisp libraries
24 ;;; ************************************************************************ 24 ;; ************************************************************************
25 25
26 (require 'eif-calls) 26 (require 'eif-calls)
27 27
28 ;;; ************************************************************************ 28 ;; ************************************************************************
29 ;;; Public variables 29 ;; Public variables
30 ;;; ************************************************************************ 30 ;; ************************************************************************
31 31
32 (defconst eif-type-tag-separator "," 32 (defconst eif-type-tag-separator ","
33 "String that separates a tags type from its normalized definition form.") 33 "String that separates a tags type from its normalized definition form.")
34 34
35 ;;; ************************************************************************ 35 ;; ************************************************************************
36 ;;; Public functions 36 ;; Public functions
37 ;;; ************************************************************************ 37 ;; ************************************************************************
38 38
39 (defun eif-feature-implementors (ftr-name) 39 (defun eif-feature-implementors (ftr-name)
40 "Return unsorted list of Eiffel feature tags which implement FTR-NAME." 40 "Return unsorted list of Eiffel feature tags which implement FTR-NAME."
41 (eif-feature-matches (concat "^" (regexp-quote ftr-name) "$"))) 41 (eif-feature-matches (concat "^" (regexp-quote ftr-name) "$")))
42
43 (defun eif-feature-map-class-tags (function class)
44 "Apply FUNCTION to all feature tags from CLASS and return a list of the results.
45 Feature tags come from the file named by br-feature-tags-file."
46 (let ((obuf (current-buffer))
47 (class-tag (concat "\n" class eif-type-tag-separator))
48 (results)
49 start end)
50 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
51 (goto-char 1)
52 (if (not (search-forward class-tag nil t))
53 nil
54 (setq start (match-beginning 0)
55 end (if (search-forward "\^L\n" nil t)
56 (match-beginning 0)
57 (point-max)))
58 (goto-char start)
59 ;; Feature defs can occur only within a single file.
60 (while (search-forward class-tag end t)
61 (setq results (cons (funcall function) results))
62 ;; Might have deleted current tag and would miss next tag unless point
63 ;; is moved backwards.
64 (backward-char)))
65 (set-buffer obuf)
66 results))
67 42
68 (defun eif-feature-name-to-regexp (name) 43 (defun eif-feature-name-to-regexp (name)
69 "Converts feature NAME into a regular expression matching the feature's name tag." 44 "Converts feature NAME into a regular expression matching the feature's name tag."
70 (if (string-match (concat "^" br-feature-type-regexp " ") name) 45 (if (string-match (concat "^" br-feature-type-regexp " ") name)
71 (setq name (substring name (match-end 0)))) 46 (setq name (substring name (match-end 0))))
75 50
76 (fset 'eif-feature-signature-to-name 'eif-feature-partial-name) 51 (fset 'eif-feature-signature-to-name 'eif-feature-partial-name)
77 52
78 (defun eif-feature-signature-to-regexp (signature) 53 (defun eif-feature-signature-to-regexp (signature)
79 "Given an Eiffel class or feature SIGNATURE, return regexp to match its definition." 54 "Given an Eiffel class or feature SIGNATURE, return regexp to match its definition."
80 (let ((regexp) name type) 55 (let ((regexp) class name type)
81 (setq regexp 56 (setq regexp
82 (cond ((string-match (concat eif-type-tag-separator 57 (cond ((string-match (concat eif-type-tag-separator
83 "\\(" br-feature-type-regexp "\\) ") 58 "\\(" br-feature-type-regexp "\\) ")
84 signature) 59 signature)
85 (setq name (substring signature (match-end 0)) 60 (setq name (substring signature (match-end 0))
98 eif-class-name-after)))) 73 eif-class-name-after))))
99 (or regexp 74 (or regexp
100 (error "(eif-feature-signature-to-regexp): Invalid format, '%s'" 75 (error "(eif-feature-signature-to-regexp): Invalid format, '%s'"
101 signature)))) 76 signature))))
102 77
103 (defun eif-feature-tag-regexp (class feature-name)
104 "Return a regexp that matches to the feature tag entry for CLASS' FEATURE-NAME."
105 (concat "^" (regexp-quote class) eif-type-tag-separator
106 br-feature-type-regexp " "
107 (regexp-quote feature-name) "[ \n]"))
108
109 (defun eif-feature-tree-command-p (class-or-signature) 78 (defun eif-feature-tree-command-p (class-or-signature)
110 "Display definition of CLASS-OR-SIGNATURE if a signature and return t, else return nil." 79 "Display definition of CLASS-OR-SIGNATURE if a signature and return t, else return nil."
111 (if (br-in-browser) (br-to-view-window)) 80 (if (br-in-browser) (br-to-view-window))
112 (br-feature-found-p (br-feature-file class-or-signature) 81 (br-feature-found-p (br-feature-file class-or-signature)
113 class-or-signature)) 82 class-or-signature))
114 83
84 (defun eif-list-features (class &optional indent)
85 "Return sorted list of Eiffel feature names lexically defined in CLASS."
86 (let ((class-tag (concat "\n" class eif-type-tag-separator))
87 (features) start end)
88 (save-excursion
89 (set-buffer
90 (funcall br-find-file-noselect-function br-feature-tags-file))
91 (goto-char 1)
92 (if (not (search-forward class-tag nil t))
93 nil
94 (setq start (match-beginning 0)
95 end (if (search-forward "\^L\n" nil t)
96 (match-beginning 0)
97 (point-max)))
98 (goto-char start)
99 ;; Feature defs can occur only within a single file.
100 (while (search-forward class-tag end t)
101 (setq features (cons (br-feature-current) features)))
102 (eif-sort-features features)))))
115 103
116 (defun eif-get-feature-tags (feature-file feature-list) 104 (defun eif-get-feature-tags (feature-file feature-list)
117 "Save Eiffel feature tags defined in FEATURE-FILE to 'br-feature-tags-file'. 105 "Save Eiffel feature tags defined in FEATURE-FILE to 'br-feature-tags-file'.
118 Assume FEATURE-FILE has already been read into a buffer and that 106 Assume FEATURE-FILE has already been read into a buffer and that
119 'br-feature-tags-init' has been called. FEATURE-LIST is the list 107 'br-feature-tags-init' has been called. FEATURE-LIST is the list
134 (progn (insert "\^L\n" feature-file "\n") 122 (progn (insert "\^L\n" feature-file "\n")
135 (mapcar (function (lambda (tag) (insert tag "\n"))) 123 (mapcar (function (lambda (tag) (insert tag "\n")))
136 feature-list))) 124 feature-list)))
137 (set-buffer obuf))) 125 (set-buffer obuf)))
138 126
139 (defun eif-list-features (class &optional indent)
140 "Return sorted list of Eiffel feature names lexically defined in CLASS.
141 Optional INDENT is unused but is required for multi-language OO-Browser conformance."
142 ;; Use nreverse here so that stable sort ends up leaving same named
143 ;; features in the order they were defined in the source file.
144 (eif-sort-features
145 (eif-feature-map-class-tags 'br-feature-current class)))
146
147 (defun eif-scan-features-in-class (class start end) 127 (defun eif-scan-features-in-class (class start end)
148 "Return unordered list of Eiffel feature definitions in CLASS. 128 "Return unordered list of Eiffel feature definitions in CLASS.
149 START and END give buffer region to search." 129 START and END give buffer region to search."
150 (save-excursion 130 (save-excursion
151 (save-restriction 131 (save-restriction
179 (message 159 (message
180 "(OO-Browser): Select an Eiffel identifier to move to its definition.") 160 "(OO-Browser): Select an Eiffel identifier to move to its definition.")
181 nil)) 161 nil))
182 ))) 162 )))
183 163
184 ;;; ************************************************************************ 164 ;; ************************************************************************
185 ;;; Private functions 165 ;; Private functions
186 ;;; ************************************************************************ 166 ;; ************************************************************************
187 167
188 (defun eif-export-feature-p () 168 (defun eif-export-feature-p ()
189 "Return nil unless point is within a class export clause." 169 "Return nil unless point is within a class export clause."
190 (save-excursion 170 (save-excursion
191 (let ((end (point))) 171 (let ((end (point)))
243 (goto-char opoint) 223 (goto-char opoint)
244 t) 224 t)
245 (goto-char opoint) 225 (goto-char opoint)
246 nil))) 226 nil)))
247 227
228 (defun eif-feature-matches (regexp)
229 "Return an unsorted list of feature tags whose names match in part or whole to REGEXP."
230 ;; Ensure match to feature names only; also handle "^" and "$" meta-chars
231 (setq regexp
232 (concat "^\\(" eif-identifier "\\)"
233 eif-type-tag-separator
234 br-feature-type-regexp " "
235 (if (equal (substring regexp 0 1) "^")
236 (progn (setq regexp (substring regexp 1)) nil)
237 (concat "[" eif-identifier-chars "]*"))
238 (if (equal (substring regexp -1) "$")
239 (substring regexp 0 -1)
240 (concat regexp "[" eif-identifier-chars "]*"))
241 "[ \t\n\r]"))
242 (save-excursion
243 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
244 (goto-char 1)
245 (let ((features) start end)
246 (if (not (re-search-forward regexp nil t))
247 nil
248 (setq start (match-beginning 0)
249 end (if (search-forward "\^L\n" nil t)
250 (match-beginning 0)
251 (point-max)))
252 (goto-char start)
253 ;; Feature defs can occur only within a single file.
254 (while (re-search-forward regexp end t)
255 (backward-char) ;; Might have moved past newline.
256 (setq features (cons (br-feature-current) features))))
257 features)))
258
248 (defun eif-feature-lessp (feature1 feature2) 259 (defun eif-feature-lessp (feature1 feature2)
249 (string-lessp (eif-feature-partial-name feature1) 260 (string-lessp (eif-feature-partial-name feature1)
250 (eif-feature-partial-name feature2))) 261 (eif-feature-partial-name feature2)))
251
252 (defun eif-feature-map-tags (function regexp)
253 "Apply FUNCTION to all current feature tags that match REGEXP and return a list of the results.
254 Feature tags come from the file named by br-feature-tags-file."
255 (let ((identifier-chars (concat "[" eif-identifier-chars "]*"))
256 (results))
257 ;; Ensure match to feature names only; also handle "^" and "$" meta-chars
258 (setq regexp
259 (concat "^\\(" eif-identifier "\\)"
260 eif-type-tag-separator
261 br-feature-type-regexp " "
262 (if (equal (substring regexp 0 1) "^")
263 (progn (setq regexp (substring regexp 1)) nil)
264 identifier-chars)
265 (if (equal (substring regexp -1) "$")
266 (substring regexp 0 -1)
267 (concat regexp identifier-chars))
268 "[ \t\n\r\f]"))
269 (save-excursion
270 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
271 (goto-char 1)
272 (while (re-search-forward regexp nil t)
273 (setq results (cons (funcall function) results))))
274 results))
275
276 (defun eif-feature-matches (regexp)
277 "Return an unsorted list of feature tags whose names match in part or whole to REGEXP.
278 ^ and $ characters may be used to match to the beginning and end of a feature name,
279 respectively."
280 (eif-feature-map-tags
281 ;; Backward-char is necessary in this next function since point might have
282 ;; moved past a newline.
283 (function (lambda () (backward-char) (br-feature-current)))
284 regexp))
285 262
286 (defun eif-feature-partial-name (signature &optional with-class for-display) 263 (defun eif-feature-partial-name (signature &optional with-class for-display)
287 "Extract the feature name without its class name from feature SIGNATURE. 264 "Extract the feature name without its class name from feature SIGNATURE.
288 If optional WITH-CLASS is non-nil, class name and 'eif-type-tag-separator' 265 If optional WITH-CLASS is non-nil, class name and 'eif-type-tag-separator'
289 are prepended to the name returned. If optional FOR-DISPLAY is non-nil, a 266 are prepended to the name returned. If optional FOR-DISPLAY is non-nil, a
340 317
341 ;; Prefixed with 'eiffel' rather than 'eif' since works as a standalone 318 ;; Prefixed with 'eiffel' rather than 'eif' since works as a standalone
342 ;; feature in buffers whose major mode is 'eiffel-mode'. It is used by the 319 ;; feature in buffers whose major mode is 'eiffel-mode'. It is used by the
343 ;; browser but may also be used standalone. 320 ;; browser but may also be used standalone.
344 ;; 321 ;;
322 (defun eiffel-find-feature (feature-name)
323 "Move point to start of feature named FEATURE-NAME in current buffer.
324 Display feature including all preceding comments at the top of the window.
325 Move point and return non-nil iff FEATURE-NAME is found."
326 (interactive "sFeature to find: ")
327 (cond ((eif-locate-feature
328 feature-name (eif-routine-to-regexp feature-name)))
329 ((eif-to-attribute feature-name)
330 (let ((opoint (point)))
331 (eif-to-comments-begin)
332 (recenter 0)
333 (goto-char opoint)
334 (back-to-indentation)
335 t))))
336
345 (defun eif-find-class-name () 337 (defun eif-find-class-name ()
346 "Return class name that point is within, else nil." 338 "Return class name that point is within, else nil."
347 (if (= (point) (point-max)) (skip-chars-backward " \t\n")) 339 (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
348 (save-excursion 340 (save-excursion
349 (skip-chars-forward " \t") 341 (skip-chars-forward " \t")
480 (skip-chars-forward " \t\n")) 472 (skip-chars-forward " \t\n"))
481 (if (looking-at eif-feature-name) 473 (if (looking-at eif-feature-name)
482 (buffer-substring (match-beginning 0) (match-end 0)))) 474 (buffer-substring (match-beginning 0) (match-end 0))))
483 475
484 476
485 (defun eiffel-find-feature (feature-name) 477 ;; ************************************************************************
486 "Move point to start of feature named FEATURE-NAME in current buffer. 478 ;; Private variables
487 Display feature including all preceding comments at the top of the window. 479 ;; ************************************************************************
488 Move point and return non-nil iff FEATURE-NAME is found."
489 (interactive "sFeature to find: ")
490 (cond ((eif-locate-feature
491 feature-name (eif-routine-to-regexp feature-name)))
492 ((eif-to-attribute feature-name)
493 (let ((opoint (point)))
494 (eif-to-comments-begin)
495 (recenter 0)
496 (goto-char opoint)
497 (back-to-indentation)
498 t))))
499
500 ;;; ************************************************************************
501 ;;; Private variables
502 ;;; ************************************************************************
503 480
504 (defconst eif-feature-name 481 (defconst eif-feature-name
505 (concat 482 (concat
506 "\\(" 483 "\\("
507 "\\(prefix[ \t]+\"\\(not\\|\\+\\|-\\)\"\\)" 484 "\\(prefix[ \t]+\"\\(not\\|\\+\\|-\\)\"\\)"