4 ;; SUMMARY: Eiffel OO-Browser class and feature functions.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: oop, tools
11 ;; ORIG-DATE: 03-Oct-90
12 ;; LAST-MOD: 10-May-01 at 05:42:39 by Bob Weiner
14 ;; Copyright (C) 1990-1996 BeOpen.com
15 ;; See the file BR-COPY for license information.
17 ;; This file is part of the OO-Browser.
22 ;;; ************************************************************************
23 ;;; Other required Elisp libraries
24 ;;; ************************************************************************
29 ;;; ************************************************************************
31 ;;; ************************************************************************
33 (defconst eif-type-tag-separator ","
34 "String that separates a tags type from its normalized definition form.
35 This should be a single character which is unchanged when quoted for use as a
36 literal in a regular expression.")
38 (defconst eif-tag-fields-regexp
39 ;; The \\\\? below is necessary because we sometimes use this expression to
40 ;; test against a string that has been regexp-quoted and some of the
41 ;; characters in br-feature-type-regexp will then be preceded by \\.
42 (format "^\\([^%s \n]+\\)%s\\\\?\\(%s \\)\\([^%s\n]+\\)"
43 eif-type-tag-separator eif-type-tag-separator
44 br-feature-type-regexp eif-type-tag-separator)
45 "Regexp matching the fields of an Eiffel feature tag line.
46 Group 1 is the class of the feature. Group 2 is the prefix preceding the
47 feature when displayed within a listing buffer. Group 3 is the feature
50 ;;; ************************************************************************
52 ;;; ************************************************************************
54 (defun eif-add-default-classes ()
55 (if br-c-tags-flag (c-add-default-classes)))
57 (defun eif-feature-implementors (ftr-name)
58 "Return unsorted list of Eiffel feature tags which implement FTR-NAME."
59 (eif-feature-matches (concat "^" (regexp-quote ftr-name) "$")))
61 (defun eif-feature-name-to-regexp (name)
62 "Converts feature NAME into a regular expression matching the feature's name tag."
63 (if (string-match (concat "^" br-feature-type-regexp " ") name)
64 (setq name (substring name (match-end 0))))
65 (format "%s%s%s %s[ \n\r]"
66 eif-identifier eif-type-tag-separator br-feature-type-regexp
69 (defun eif-feature-signature-to-name (feature-sig-or-tag &optional with-class for-display)
70 "Extract the feature name without its class name from FEATURE-SIG-OR-TAG.
71 If optional WITH-CLASS is non-nil, class name and :: are prepended to the
72 name returned. If optional FOR-DISPLAY is non-nil, a feature type character
73 is prepended to the name for display in a browser listing."
74 (cond ((br-feature-tag-p feature-sig-or-tag)
75 (br-feature-tag-name feature-sig-or-tag with-class for-display))
76 ((string-match (concat eif-type-tag-separator
77 "\\(" br-feature-type-regexp " \\)")
79 (let ((class (substring feature-sig-or-tag 0 (match-beginning 0)))
80 (name (substring feature-sig-or-tag (match-end 0))))
81 (cond ((and with-class for-display)
82 (concat class "::" (substring feature-sig-or-tag
83 (match-beginning 1))))
85 (concat class "::" name))
87 (substring feature-sig-or-tag (match-beginning 1)))
89 (t feature-sig-or-tag)))
91 (defun eif-feature-signature-to-regexp (signature)
92 "Given an Eiffel class or feature SIGNATURE, return regexp to match its definition."
93 (let ((regexp) name type)
94 (cond ((string-match (concat "\\`" br-feature-type-regexp " ")
96 (setq name (substring signature (match-end 0))
98 (substring signature 0 1)))
100 (cond ((memq type '(?- ?1 ?> ?/))
102 (eif-routine-to-regexp name))
105 (eif-attribute-to-regexp name)))))
106 ((equal 0 (string-match eif-identifier signature))
107 ;; Assume is a class name
109 (concat eif-class-name-before
110 (regexp-quote signature)
111 eif-class-name-after))))
113 (error "(eif-feature-signature-to-regexp): Invalid format, `%s'"
116 (defun eif-output-feature-tags (feature-file feature-tags-list)
117 "Write Eiffel FEATURE-FILE's FEATURE-TAGS-LIST into `br-feature-tags-file'.
118 Assume `br-feature-tags-init' has been called."
121 (br-feature-set-tags-buffer)
123 ;; Delete any prior feature tags associated with feature-file
124 (if (search-forward feature-file nil 'end)
125 (progn (forward-line -1)
126 (let ((start (point)))
127 (search-forward "\^L" nil 'end 2)
129 (delete-region start (point)))))
130 (if feature-tags-list
131 (progn (insert "\^L\n")
132 ;; Quote pathname to avoid read errors on MS OSes.
133 (prin1 feature-file (current-buffer))
135 (mapcar (function (lambda (tag) (insert tag "\n")))
136 feature-tags-list)))))
138 (defun eif-scan-features-in-class (class start end)
139 "Return unordered list of Eiffel feature definitions in CLASS.
140 START and END give buffer region to search."
143 (narrow-to-region start end)
145 (let ((attributes-and-routines (eif-parse-features t)))
148 (function (lambda (routine)
149 (concat class eif-type-tag-separator routine)))
150 (cdr attributes-and-routines))
152 (function (lambda (attribute)
153 (concat class eif-type-tag-separator attribute)))
154 (car attributes-and-routines)))))))
156 (defun eif-to-definition (&optional identifier)
157 "If point is within an Eiffel class or feature name, try to move to its definition.
158 With optional IDENTIFIER, do the same instead for it."
160 (let ((cl (or identifier (eif-find-class-name))))
162 ((eif-keyword-p) nil)
163 ((br-check-for-class cl))
168 "(OO-Browser): Select an Eiffel identifier to move to its definition.")
172 ;;; ************************************************************************
173 ;;; Private functions
174 ;;; ************************************************************************
176 (defun eif-export-feature-p ()
177 "Return nil unless point is within a class export clause."
181 ;; If in a comment, return nil.
182 (if (search-forward "--" end t)
184 (goto-char (point-min))
185 (and (re-search-forward eif-export-key-regexp end t)
186 (not (re-search-forward "^\\(inherit\\|feature\\)\\([ \t]\\|$\\)" end t)))))))
188 (defun eif-feature (&optional ftr)
189 "Return nil if definition is not found for optional FTR or feature declared at point."
191 (let ((class-deferred)
195 (cond ((or ftr (and (eif-export-feature-p)
196 (setq ftr (eif-to-feature-decl))))
197 (if (and (setq class-deferred (eif-get-class-name-from-source))
198 (setq class (car class-deferred)
199 deferred-p (cdr class-deferred)
200 ftr-def-class (eif-find-ancestors-feature
201 (list class) deferred-p ftr)))
202 (cond ((equal (car ftr-def-class) class) t)
203 ((equal (cdr ftr-def-class) ftr)
204 ;; Feature inherited but not renamed.
206 "Feature `%s' of class `%s' inherited from class `%s'."
207 ftr class (car ftr-def-class)))
208 ;; Feature inherited and renamed.
209 (t (message "Feature `%s', class `%s' from feature `%s', class `%s'."
210 ftr class (cdr ftr-def-class)
214 (message "(OO-Browser): `%s' feature not found." ftr)
216 ((and (not ftr) (eif-feature-def-p)))
218 ;; Later we might add the case of a feature invocation here.
222 (defun eif-feature-def-p ()
223 "If point is within a feature definition's name, display feature including leading comments."
224 (let ((opoint (point)))
226 (if (or (looking-at eif-routine-regexp)
227 (looking-at eif-attribute-regexp))
228 (progn (setq opoint (match-beginning eif-feature-name-grpn))
229 (br-display-code opoint))
233 (defun eif-feature-map-tags (function regexp)
234 "Apply FUNCTION to all current feature tags that match REGEXP and return a list of the results."
235 (let ((identifier-chars (concat "[" eif-identifier-chars "]*")))
236 ;; Ensure handle "^" and "$" meta-chars.
238 (concat (format "\\`%s " br-feature-type-regexp)
239 (if (equal (substring regexp 0 1) "^")
240 (progn (setq regexp (substring regexp 1)) nil)
242 (if (equal (substring regexp -1) "$")
243 (substring regexp 0 -1)
244 (concat regexp identifier-chars))
246 (br-feature-map-tags function regexp)))
248 (defun eif-feature-matches (regexp)
249 "Return an unsorted list of feature tags whose names match in part or whole to REGEXP.
250 ^ and $ characters may be used to match to the beginning and end of a feature name,
252 (eif-feature-map-tags 'identity regexp))
254 (defun eif-find-ancestors-feature (class-list deferred-class ftr)
255 (let* ((classes class-list)
259 (if (null class-list)
261 (while (and (not found-ftr) classes)
262 (setq cl (car classes)
263 file (br-class-path cl))
264 (and file (setq found-ftr
265 (br-feature-found-p file ftr deferred-class)))
266 ;; If found-ftr is a cons cell, then only one parent class need
267 ;; be searched to look for ftr.
268 (if (consp found-ftr)
269 (setq class-list (list (car found-ftr))
270 ftr (cdr found-ftr)))
271 (setq classes (cdr classes)))
272 (cond ((consp found-ftr)
273 (eif-find-ancestors-feature class-list deferred-class ftr))
275 (eif-find-ancestors-feature
276 (apply 'append (mapcar (function
277 (lambda (cl) (br-get-parents cl)))
281 (t (cons cl ftr))))))
283 (defun eif-find-class-name ()
284 "Return class name that point is within, else nil."
285 (if (= (point) (point-max)) (skip-chars-backward " \t\n\r"))
287 (skip-chars-forward " \t")
288 (skip-chars-backward eif-identifier-chars)
289 (skip-chars-backward " \t\n\r\f")
291 (and (looking-at eif-class-name-pat)
292 (br-buffer-substring (match-beginning 2)
295 (defun eif-find-feature (feature-name)
296 "With point selecting a class in a listing buffer, move point to definition of FEATURE-NAME in viewer window.
297 Move point and return non-nil iff FEATURE-NAME is found."
298 (interactive "sFeature to find: ")
299 ;; If selected class is displayed, don't go to start of class
300 (if (equal (br-class-path (br-find-class-name))
303 (expand-file-name buffer-file-name)))
306 (if (eiffel-find-feature feature-name)
313 (message "(OO-Browser): No `%s' feature found." feature-name)))))
315 (defun eif-feature-locate-p (feature-tag)
316 (let (start class feature-sig)
317 (if (br-feature-tag-p feature-tag)
318 (setq class (br-feature-tag-class feature-tag)
319 name (br-feature-tag-name feature-tag nil nil)
320 feature-sig (br-feature-tag-signature feature-tag))
321 (setq feature-sig feature-tag
322 name (br-feature-name feature-tag)
325 ;; First move to the proper class implementation, so that if two
326 ;; classes in the same file have the same feature signature, we still
327 ;; end up at the right one.
329 (if (not (br-default-class-p class))
331 (concat eif-class-name-before (regexp-quote class)
332 eif-class-name-after)
334 ((string-match (concat "\\`[^\]\[]+" eif-type-tag-separator)
336 (setq class (substring feature-sig 0 (1- (match-end 0))))
338 (concat eif-class-name-before (regexp-quote class)
339 eif-class-name-after)
341 (if (not (re-search-forward
342 (eif-feature-signature-to-regexp feature-sig) nil t))
344 (goto-char (match-beginning 0))
345 (if (search-forward name nil t) (goto-char (match-beginning 0)))
347 (br-display-code start))))
349 (defun eif-keyword-p ()
350 "Return t if point is within an Eiffel keyword, else nil."
351 (if (= (point) (point-max)) (skip-chars-backward " \t\n\r"))
353 (skip-chars-forward " \t")
354 (skip-chars-backward eif-identifier-chars)
355 (and (looking-at eif-identifier)
356 (hash-key-p (br-buffer-substring (match-beginning 0)
358 eif-reserved-words-htable))))
360 (defun eif-locate-feature (ftr ftr-pat)
361 (let ((opoint (point)))
362 (goto-char (point-min))
363 (if (and (re-search-forward "^feature\\([ \t]\\|$\\)" nil t)
364 (re-search-forward ftr-pat nil t))
365 (progn (goto-char (match-beginning 0))
366 (if (search-forward ftr nil t)
367 (goto-char (match-beginning 0)))
368 (setq opoint (point))
369 (br-display-code opoint))
371 (and (interactive-p) (error "Feature `%s' not found." ftr)))))
373 (defun eif-renamed-feature-p (ftr)
374 (goto-char (point-min))
375 (let ((rename-regexp "[ \t\n\r]+rename[ \t\n\r]")
377 (concat eif-identifier "[ \t\n\r]+as[ \t\n\r]+" ftr "[,; \t\n\r]"))
381 (while (and (setq prev-feature-nm
382 (and (re-search-forward rename-regexp nil t)
383 (re-search-forward rename-match nil t)))
384 (setq prev-feature-nm
385 (br-buffer-substring (match-beginning 1) (match-end 1))
386 prev-class (match-beginning 0))
387 (progn (backward-char 1)
388 (eif-in-comment-p))))
390 (progn (goto-char prev-class)
391 (setq parents (eif-get-parents-from-source
392 buffer-file-name nil))
393 (if (re-search-backward (concat
395 (mapconcat 'identity parents "\\|")
398 (progn (setq prev-class (br-buffer-substring
401 (cons prev-class prev-feature-nm))
404 "(OO-Browser): Internal error - no class associated with rename clause."))))))
406 (defun eif-to-feature-decl ()
408 (while (and (progn (skip-chars-backward "^, \t\n\r")
409 (and (not (eq (preceding-char) ?,))
410 (not (looking-at "export[ \t\n\r]+"))))
411 (progn (skip-chars-backward " \t\n\r")
414 (if (search-forward "--" end t)
415 (progn (goto-char end)
416 (skip-chars-forward " \t\n\r")
420 (if (looking-at "export[ \t\n\r]+")
421 (goto-char (match-end 0))
422 (skip-chars-forward " \t\n\r"))
423 (if (looking-at eif-feature-name)
424 (br-buffer-substring (match-beginning 0) (match-end 0))))
426 ;; Prefixed with `eiffel' rather than `eif' since works as a standalone
427 ;; feature in buffers whose major mode is `eiffel-mode'. It is used by the
428 ;; browser but may also be used standalone.
430 (defun eiffel-find-feature (feature-name)
431 "Move point to start of feature named FEATURE-NAME in current buffer.
432 Display feature including all preceding comments at the top of the window.
433 Move point and return non-nil iff FEATURE-NAME is found."
434 (interactive "sFeature to find: ")
435 (cond ((eif-locate-feature
436 feature-name (eif-routine-to-regexp feature-name)))
437 ((eif-to-attribute feature-name)
438 (br-display-code (point))
439 (back-to-indentation)
442 ;;; ************************************************************************
443 ;;; Private variables
444 ;;; ************************************************************************
446 (defconst eif-feature-name
449 "\\(prefix[ \t]+\"\\(not\\|\\+\\|-\\)\"\\)"
450 "\\|infix[ \t]+\"\\(div\\|mod\\|^\\|<=?\\|>=?\\|\+\\|-\\|\\*\\|/"
451 "\\|and then\\|and\\|or else\\|or\\|xor\\|implies\\)"
452 "\\|" eif-identifier "\\)")
453 "Regexp matching any Eiffel feature name.
454 Will also match class names and keywords, so tests for these should precede
455 use of this expression.")
457 (defconst eif-export-key-regexp
458 "\\(^[ \t]*\\|[ \t]+\\)export[ \t\n\r]+"
459 "Regexp matching the Eiffel export keyword in context.")
461 (defconst eif-class-repeat (concat "repeat[ \t]+" eif-identifier)
462 "Match to an Eiffel `repeat <class>' phrase. Grouping 1 is class name.")
464 (defconst eif-exported-feature
465 (concat "\\(,\\|export[ \t\n\r]+\\(--.*[ \t\n\r]+\\)*\\)"
466 eif-feature-name "\\([ \t]*{[^\}]+}\\)?"
467 "\\([ \t]*[\n\r,]\\|[ \t]+--\\)")
468 "Regexp to match to a feature declaration in an export clause.
469 Exclude `repeat <class>' phrases. Feature name is grouping 3.")