Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-eif-ft.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;!emacs
2 ;;
3 ;; FILE: br-eif-ft.el
4 ;; SUMMARY: Eiffel OO-Browser class and feature functions.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: oop, tools
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 03-Oct-90
12 ;; LAST-MOD: 11-May-95 at 11:24:33 by Bob Weiner
13 ;;
14 ;; Copyright (C) 1990-1995 Free Software Foundation, Inc.
15 ;; See the file BR-COPY for license information.
16 ;;
17 ;; This file is part of the OO-Browser.
18 ;;
19 ;; DESCRIPTION:
20 ;; DESCRIP-END.
21
22 ;; ************************************************************************
23 ;; Other required Elisp libraries
24 ;; ************************************************************************
25
26 (require 'eif-calls)
27
28 ;; ************************************************************************
29 ;; Public variables
30 ;; ************************************************************************
31
32 (defconst eif-type-tag-separator ","
33 "String that separates a tags type from its normalized definition form.")
34
35 ;; ************************************************************************
36 ;; Public functions
37 ;; ************************************************************************
38
39 (defun eif-feature-implementors (ftr-name)
40 "Return unsorted list of Eiffel feature tags which implement FTR-NAME."
41 (eif-feature-matches (concat "^" (regexp-quote ftr-name) "$")))
42
43 (defun eif-feature-name-to-regexp (name)
44 "Converts feature NAME into a regular expression matching the feature's name tag."
45 (if (string-match (concat "^" br-feature-type-regexp " ") name)
46 (setq name (substring name (match-end 0))))
47 (format "%s%s%s %s[ \n]"
48 eif-identifier eif-type-tag-separator br-feature-type-regexp
49 (regexp-quote name)))
50
51 (fset 'eif-feature-signature-to-name 'eif-feature-partial-name)
52
53 (defun eif-feature-signature-to-regexp (signature)
54 "Given an Eiffel class or feature SIGNATURE, return regexp to match its definition."
55 (let ((regexp) class name type)
56 (setq regexp
57 (cond ((string-match (concat eif-type-tag-separator
58 "\\(" br-feature-type-regexp "\\) ")
59 signature)
60 (setq name (substring signature (match-end 0))
61 type (string-to-char
62 (substring
63 signature (match-beginning 1) (match-end 1))))
64 (cond ((memq type '(?- ?1 ?>))
65 ;; routine
66 (eif-routine-to-regexp name))
67 ((= type ?=)
68 ;; attribute
69 (eif-attribute-to-regexp name))))
70 ((equal 0 (string-match eif-identifier signature))
71 ;; Assume is a class name
72 (concat eif-class-name-before (regexp-quote signature)
73 eif-class-name-after))))
74 (or regexp
75 (error "(eif-feature-signature-to-regexp): Invalid format, '%s'"
76 signature))))
77
78 (defun eif-feature-tree-command-p (class-or-signature)
79 "Display definition of CLASS-OR-SIGNATURE if a signature and return t, else return nil."
80 (if (br-in-browser) (br-to-view-window))
81 (br-feature-found-p (br-feature-file class-or-signature)
82 class-or-signature))
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)))))
103
104 (defun eif-get-feature-tags (feature-file feature-list)
105 "Save Eiffel feature tags defined in FEATURE-FILE to 'br-feature-tags-file'.
106 Assume FEATURE-FILE has already been read into a buffer and that
107 'br-feature-tags-init' has been called. FEATURE-LIST is the list
108 of tags to save."
109 (interactive)
110 (let ((obuf (current-buffer)))
111 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
112 (goto-char 1)
113 ;; Delete any prior feature tags associated with feature-file
114 (if (search-forward feature-file nil 'end)
115 (progn (forward-line -1)
116 (let ((start (point)))
117 (search-forward "\^L" nil 'end 2)
118 (backward-char 1)
119 (delete-region start (point))
120 )))
121 (if feature-list
122 (progn (insert "\^L\n" feature-file "\n")
123 (mapcar (function (lambda (tag) (insert tag "\n")))
124 feature-list)))
125 (set-buffer obuf)))
126
127 (defun eif-scan-features-in-class (class start end)
128 "Return unordered list of Eiffel feature definitions in CLASS.
129 START and END give buffer region to search."
130 (save-excursion
131 (save-restriction
132 (narrow-to-region start end)
133 (goto-char start)
134 (let ((attributes-and-routines (eif-parse-features t)))
135 (append
136 (mapcar
137 (function (lambda (routine)
138 (concat class eif-type-tag-separator routine)))
139 (cdr attributes-and-routines))
140 (mapcar
141 (function (lambda (attribute)
142 (concat class eif-type-tag-separator attribute)))
143 (car attributes-and-routines)))))))
144
145 (defun eif-sort-features (feature-list)
146 (sort feature-list 'eif-feature-lessp))
147
148 (defun eif-to-definition (&optional identifier)
149 "If point is within an Eiffel class or feature name, try to move to its definition.
150 With optional IDENTIFIER, do the same instead for it."
151 (interactive)
152 (let ((cl (or identifier (eif-find-class-name))))
153 (cond
154 ((eif-keyword-p) nil)
155 ((br-check-for-class cl))
156 ((eif-feature cl))
157 ((progn
158 (beep)
159 (message
160 "(OO-Browser): Select an Eiffel identifier to move to its definition.")
161 nil))
162 )))
163
164 ;; ************************************************************************
165 ;; Private functions
166 ;; ************************************************************************
167
168 (defun eif-export-feature-p ()
169 "Return nil unless point is within a class export clause."
170 (save-excursion
171 (let ((end (point)))
172 (beginning-of-line)
173 ;; If in a comment, return nil.
174 (if (search-forward "--" end t)
175 nil
176 (goto-char (point-min))
177 (and (re-search-forward eif-export-key-regexp end t)
178 (not (re-search-forward "^\\(inherit\\|feature\\)\\([ \t]\\|$\\)" end t)))))))
179
180 (defun eif-feature (&optional ftr)
181 "Return nil if definition is not found for optional FTR or feature declared at point."
182 (interactive)
183 (let ((class-deferred)
184 (class)
185 (deferred-p)
186 (ftr-def-class))
187 (cond ((or ftr (and (eif-export-feature-p)
188 (setq ftr (eif-to-feature-decl))))
189 (if (and (setq class-deferred (eif-get-class-name-from-source))
190 (setq class (car class-deferred)
191 deferred-p (cdr class-deferred)
192 ftr-def-class (eif-find-ancestors-feature
193 (list class) deferred-p ftr)))
194 (cond ((equal (car ftr-def-class) class) t)
195 ((equal (cdr ftr-def-class) ftr)
196 ;; Feature inherited but not renamed.
197 (message
198 "Feature '%s' of class '%s' inherited from class '%s'."
199 ftr class (car ftr-def-class)))
200 ;; Feature inherited and renamed.
201 (t (message "Feature '%s', class '%s' from feature '%s', class '%s'."
202 ftr class (cdr ftr-def-class)
203 (car ftr-def-class))
204 t))
205 (beep)
206 (message "(OO-Browser): '%s' feature not found." ftr)
207 t))
208 ((and (not ftr) (eif-feature-def-p)))
209 ;;
210 ;; Later we might add the case of a feature invocation here.
211 ;;
212 )))
213
214 (defun eif-feature-def-p ()
215 "If point is within a feature definition's name, display feature including leading comments."
216 (let ((opoint (point)))
217 (beginning-of-line)
218 (if (or (looking-at eif-routine-regexp)
219 (looking-at eif-attribute-regexp))
220 (progn (setq opoint (match-beginning eif-feature-name-grpn))
221 (eif-to-comments-begin)
222 (recenter 0)
223 (goto-char opoint)
224 t)
225 (goto-char opoint)
226 nil)))
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
259 (defun eif-feature-lessp (feature1 feature2)
260 (string-lessp (eif-feature-partial-name feature1)
261 (eif-feature-partial-name feature2)))
262
263 (defun eif-feature-partial-name (signature &optional with-class for-display)
264 "Extract the feature name without its class name from feature SIGNATURE.
265 If optional WITH-CLASS is non-nil, class name and 'eif-type-tag-separator'
266 are prepended to the name returned. If optional FOR-DISPLAY is non-nil, a
267 feature type character is prepended to the name for display in a browser
268 listing."
269 (if (string-match (concat eif-type-tag-separator
270 "\\(" br-feature-type-regexp " \\)")
271 signature)
272 (let ((class (substring signature 0 (match-beginning 0)))
273 (name (substring signature (match-end 0))))
274 (cond ((and with-class for-display)
275 signature)
276 (with-class
277 (concat class eif-type-tag-separator name))
278 (for-display
279 (substring signature (match-beginning 1)))
280 (t name)))
281 signature))
282
283 (defun eif-feature-tag-class (element-tag)
284 "Extract the class name from ELEMENT-TAG."
285 (if (string-match eif-type-tag-separator element-tag)
286 (substring element-tag 0 (match-beginning 0))
287 ""))
288
289 (defun eif-find-ancestors-feature (class-list deferred-class ftr)
290 (let* ((classes class-list)
291 (cl)
292 (file)
293 (found-ftr))
294 (if (null class-list)
295 nil
296 (while (and (not found-ftr) classes)
297 (setq cl (car classes)
298 file (br-class-path cl))
299 (and file (setq found-ftr
300 (br-feature-found-p file ftr deferred-class)))
301 ;; If found-ftr is a cons cell, then only one parent class need
302 ;; be searched to look for ftr.
303 (if (consp found-ftr)
304 (setq class-list (list (car found-ftr))
305 ftr (cdr found-ftr)))
306 (setq classes (cdr classes)))
307 (cond ((consp found-ftr)
308 (eif-find-ancestors-feature class-list deferred-class ftr))
309 ((null found-ftr)
310 (eif-find-ancestors-feature
311 (apply 'append (mapcar (function
312 (lambda (cl) (br-get-parents cl)))
313 class-list))
314 deferred-class
315 ftr))
316 (t (cons cl ftr))))))
317
318 ;; Prefixed with 'eiffel' rather than 'eif' since works as a standalone
319 ;; feature in buffers whose major mode is 'eiffel-mode'. It is used by the
320 ;; browser but may also be used standalone.
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
337 (defun eif-find-class-name ()
338 "Return class name that point is within, else nil."
339 (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
340 (save-excursion
341 (skip-chars-forward " \t")
342 (skip-chars-backward eif-identifier-chars)
343 (skip-chars-backward " \t\n")
344 (backward-char 1)
345 (and (looking-at eif-class-name-pat)
346 (eif-set-case
347 (buffer-substring (match-beginning 2)
348 (match-end 2))))))
349
350 (defun eif-find-feature (feature-name)
351 "With point selecting a class in a listing buffer, move point to definition of FEATURE-NAME in viewer window.
352 Move point and return non-nil iff FEATURE-NAME is found."
353 (interactive "sFeature to find: ")
354 ;; If selected class is displayed, don't go to start of class
355 (if (equal (br-class-path (br-find-class-name))
356 (progn
357 (br-to-from-viewer)
358 (expand-file-name buffer-file-name)))
359 nil
360 (br-edit))
361 (if (eiffel-find-feature feature-name)
362 (progn (recenter 0)
363 t)
364 (br-to-from-viewer)
365 (and (interactive-p)
366 (progn
367 (beep)
368 (message "(OO-Browser): No '%s' feature found." feature-name)))))
369
370 (defun eif-feature-locate-p (feature-tag)
371 (let (start class)
372 (if (string-match (concat "\\`[^\]\[]+" eif-type-tag-separator)
373 feature-tag)
374 ;; First move to the proper class implementation, so that if two
375 ;; classes in the same file have the same feature signature, we still
376 ;; end up at the right one.
377 (progn
378 (setq class (substring feature-tag 0 (1- (match-end 0))))
379 (re-search-forward
380 (concat eif-class-name-before (regexp-quote class)
381 eif-class-name-after)
382 nil t)))
383 (if (not (re-search-forward
384 (eif-feature-signature-to-regexp feature-tag) nil t))
385 nil
386 (setq start (match-beginning 0))
387 (goto-char start)
388 (skip-chars-forward " \t\n")
389 (eif-to-comments-begin)
390 (recenter 0)
391 (goto-char start)
392 t)))
393
394 (defun eif-keyword-p ()
395 "Return t if point is within an Eiffel keyword, else nil."
396 (if (= (point) (point-max)) (skip-chars-backward " \t\n"))
397 (save-excursion
398 (skip-chars-forward " \t")
399 (skip-chars-backward eif-identifier-chars)
400 (and (looking-at eif-identifier)
401 (br-member-sorted-strings (buffer-substring (match-beginning 0)
402 (match-end 0))
403 eif-reserved-words))))
404
405 (defun eif-locate-feature (ftr ftr-pat)
406 (let ((opoint (point)))
407 (goto-char (point-min))
408 (if (and (re-search-forward "^feature\\([ \t]\\|$\\)" nil t)
409 (re-search-forward ftr-pat nil t))
410 (progn (goto-char (match-beginning eif-feature-name-grpn))
411 (setq opoint (point))
412 (eif-to-comments-begin)
413 (recenter 0)
414 (goto-char opoint)
415 t)
416 (goto-char opoint)
417 (and (interactive-p) (error (format "Feature '%s' not found."
418 ftr))))))
419
420 (defun eif-renamed-feature-p (ftr)
421 (goto-char (point-min))
422 (let ((rename-regexp "[ \t\n]+rename[ \t\n]")
423 (rename-match
424 (concat eif-identifier "[ \t\n]+as[ \t\n]+" ftr "[,; \t\n]"))
425 (prev-feature-nm)
426 (prev-class)
427 (parents))
428 (while (and (setq prev-feature-nm
429 (and (re-search-forward rename-regexp nil t)
430 (re-search-forward rename-match nil t)))
431 (setq prev-feature-nm
432 (buffer-substring (match-beginning 1) (match-end 1))
433 prev-class (match-beginning 0))
434 (progn (backward-char 1)
435 (eif-in-comment-p))))
436 (if prev-feature-nm
437 (progn (goto-char prev-class)
438 (setq parents (eif-get-parents-from-source buffer-file-name))
439 (if (re-search-backward (concat
440 "[^[][ \t\n]+\\("
441 (mapconcat
442 (function (lambda (cl)
443 (eif-set-case-type cl)))
444 parents
445 "\\|")
446 "\\)")
447 nil t)
448 (progn (setq prev-class (eif-set-case (buffer-substring
449 (match-beginning 1)
450 (match-end 1))))
451 (cons prev-class prev-feature-nm))
452 (beep)
453 (message
454 "(OO-Browser): Internal error - no class associated with rename clause."))))))
455
456 (defun eif-to-feature-decl ()
457 (let ((end))
458 (while (and (progn (skip-chars-backward "^, \t\n")
459 (and (not (= (preceding-char) ?,))
460 (not (looking-at "export[ \t\n]+"))))
461 (progn (skip-chars-backward " \t\n")
462 (setq end (point))
463 (beginning-of-line)
464 (if (search-forward "--" end t)
465 (progn (goto-char end)
466 (skip-chars-forward " \t\n")
467 nil)
468 (goto-char end)
469 t)))))
470 (if (looking-at "export[ \t\n]+")
471 (goto-char (match-end 0))
472 (skip-chars-forward " \t\n"))
473 (if (looking-at eif-feature-name)
474 (buffer-substring (match-beginning 0) (match-end 0))))
475
476
477 ;; ************************************************************************
478 ;; Private variables
479 ;; ************************************************************************
480
481 (defconst eif-feature-name
482 (concat
483 "\\("
484 "\\(prefix[ \t]+\"\\(not\\|\\+\\|-\\)\"\\)"
485 "\\|infix[ \t]+\"\\(div\\|mod\\|^\\|<=?\\|>=?\\|\+\\|-\\|\\*\\|/"
486 "\\|and then\\|and\\|or else\\|or\\|xor\\|implies\\)"
487 "\\|" eif-identifier "\\)")
488 "Regexp matching any Eiffel feature name.
489 Will also match class names and keywords, so tests for these should precede
490 use of this expression.")
491
492 (defconst eif-export-key-regexp
493 "\\(^[ \t]*\\|[ \t]+\\)export[ \t\n]+"
494 "Regexp matching the Eiffel export keyword in context.")
495
496 (defconst eif-class-repeat (concat "repeat[ \t]+" eif-identifier)
497 "Match to an Eiffel 'repeat <class>' phrase. Grouping 1 is class name.")
498
499 (defconst eif-exported-feature
500 (concat "\\(,\\|export[ \t\n]+\\(--.*[ \t\n]+\\)*\\)"
501 eif-feature-name "\\([ \t]*{[^}]+}\\)?"
502 "\\([ \t]*[\n,]\\|[ \t]+--\\)")
503 "Regexp to match to a feature declaration in an export clause.
504 Exclude 'repeat <class>' phrases. Feature name is grouping 3.")
505
506
507 (provide 'br-eif-ft)