Mercurial > hg > xemacs-beta

comparison lisp/oobr/eif-calls.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: eif-calls.el
4 ;; SUMMARY: Produce first level static call tree for Eiffel class.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: oop, tools
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 7-Dec-89 at 19:32:47
12 ;; LAST-MOD: 30-Aug-95 at 15:22:33 by Bob Weiner
13 ;;
14 ;; Copyright (C) 1989-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 ;;
21 ;; The default commands, 'eif-store-class-info' and 'eif-insert-class-info'
22 ;; work in tandem to display the parents, attributes and routines with
23 ;; routine call summaries for a class.
24 ;; The command {M-x eif-info-use-short}, will instead cause the above
25 ;; commands to run the Eiffel 'short' command on a class, thereby
26 ;; displaying its specification.
27 ;; The command {M-x eif-info-use-flat}, will instead cause the above
28 ;; commands to run the Eiffel 'flat' command on a class, thereby
29 ;; displaying its complete feature set.
30 ;; Call {M-x eif-info-use-calls} to reset these commands to their default.
31 ;;
32 ;; DESCRIP-END.
33
34 ;;; ************************************************************************
35 ;;; Other required Elisp libraries
36 ;;; ************************************************************************
37
38 (require 'br-eif)
39
40 ;;; ************************************************************************
41 ;;; Public functions
42 ;;; ************************************************************************
43
44 (defun eif-info-use-calls ()
45 "Setup to display call trees and other class summary info."
46 (interactive)
47 (fset 'eif-store-class-info 'eif-store-class-info-calls)
48 (fset 'eif-insert-class-info 'eif-insert-class-info-calls))
49 (eif-info-use-calls)
50
51 (defun eif-info-use-flat ()
52 "Setup to display the Eiffel 'flat' output for classes."
53 (interactive)
54 (fset 'eif-store-class-info 'eif-store-class-info-flat)
55 (fset 'eif-insert-class-info 'eif-insert-class-info-flat))
56
57 (defun eif-info-use-short ()
58 "Setup to display the Eiffel 'short' output for classes."
59 (interactive)
60 (fset 'eif-store-class-info 'eif-store-class-info-short)
61 (fset 'eif-insert-class-info 'eif-insert-class-info-short))
62
63 (defun eif-show-class-info (&optional class-name)
64 "Displays class specific information summary in other window.
65 This summary includes listings of textually included attributes, routines,
66 and routine calls from an Eiffel class. Use optional CLASS-NAME for class
67 text or extract from the current buffer."
68 (interactive (list (br-complete-class-name
69 nil
70 (let ((cn (car (eif-get-class-name-from-source))))
71 (if cn (concat "Class name: (default " cn ") "))))))
72 (let ((class-file-name))
73 (if (not (br-class-in-table-p class-name))
74 (if (setq class-file-name buffer-file-name)
75 (setq class-name (car (eif-get-class-name-from-source)))
76 (error "No class specified.")))
77 (if (null class-name)
78 (error "No class specified.")
79 (message "Building '%s' class info..." class-name)
80 (sit-for 2)
81 (eif-store-class-info class-name)
82 (message "Building '%s' class info...Done" class-name)
83 (br-eval-in-other-window "*Class Info*"
84 '(eif-insert-class-info class-file-name)))))
85
86 ;;; ************************************************************************
87 ;;; Internal functions
88 ;;; ************************************************************************
89
90 (defun eif-get-class-name-from-source ()
91 "Return indication of closest class definition preceding point or nil.
92 If non-nil, value is a cons cell of (class-name . deferred-class-p)."
93 (save-excursion
94 (if (or (re-search-backward eif-class-def-regexp nil t)
95 (re-search-forward eif-class-def-regexp nil t))
96 (cons (eif-set-case (buffer-substring (match-beginning 2)
97 (match-end 2)))
98 (match-end 1)))))
99
100 (defun eif-insert-class-info-calls (&optional src-file-name)
101 "Inserts textually included attributes, routines, and routine calls from 'eif-last-class-name'.
102 Uses optional SRC-FILE-NAME for lookups or class name from 'eif-last-class-name'."
103 (interactive)
104 (if (and eif-last-class-name eif-attributes-and-routines)
105 nil
106 (error (concat "Call 'eif-store-class-info' first."
107 (let ((key (car (where-is-internal 'eif-store-class-info))))
108 (and key (concat " It is bound to {" key "}."))))))
109 (let ((in-lookup-table
110 (if src-file-name
111 nil
112 (br-class-in-table-p eif-last-class-name))))
113 (if (not (or in-lookup-table src-file-name))
114 nil
115 (insert eif-last-class-name)
116 (center-line)
117 (insert "\n")
118 (insert "Parents:\n")
119 (let ((parents (if in-lookup-table
120 (br-get-parents eif-last-class-name)
121 (eif-get-parents-from-source src-file-name))))
122 (if parents
123 (mapcar (function (lambda (par) (insert " " par "\n")))
124 parents)
125 (insert " <None>\n"))
126 (let ((attribs (car eif-attributes-and-routines))
127 (routines (cdr eif-attributes-and-routines)))
128 (if parents
129 (insert "\nNon-Inherited Attributes:\n")
130 (insert "\nAttributes:\n"))
131 (if attribs
132 (mapcar (function (lambda(attr) (insert " " attr "\n")))
133 attribs)
134 (insert " <None>\n"))
135 (if parents
136 (insert
137 "\nNon-Inherited Routines with Apparent Routine Calls:\n")
138 (insert "\nRoutines with Apparent Routine Calls:\n"))
139 (if routines
140 (mapcar (function
141 (lambda(cns)
142 (insert " " (car cns) "\n")
143 (mapcar (function
144 (lambda (call)
145 (insert " " call "\n")))
146 (cdr cns))))
147 routines)
148 (insert " <None>\n"))
149 ))
150 (set-buffer-modified-p nil))))
151
152 (defun eif-store-class-info-calls (class-name)
153 "Generates cons of textually included attributes and routines (including routine calls) from CLASS-NAME.
154 It stores this cons in the global 'eif-attributes-and-routines'."
155 (interactive (list (br-complete-class-name)))
156 (setq eif-last-class-name (downcase class-name))
157 (let ((in-lookup-table (br-class-path eif-last-class-name)))
158 (if (not (or in-lookup-table buffer-file-name))
159 nil
160 (setq eif-attributes-and-routines
161 (eif-get-features-from-source
162 (if in-lookup-table
163 (br-class-path eif-last-class-name)
164 buffer-file-name))))))
165
166 (defun eif-insert-class-info-short ()
167 (interactive)
168 (insert-file-contents eif-tmp-info-file)
169 (shell-command (concat "rm -f " eif-tmp-info-file))
170 (message ""))
171
172 (defun eif-store-class-info-short (class-name)
173 (interactive (list (br-complete-class-name)))
174 (shell-command (concat "short -b 3 -p "
175 (br-class-path (br-find-class-name))
176 "> " eif-tmp-info-file)))
177
178 (defun eif-insert-class-info-flat ()
179 (interactive)
180 (insert-file-contents eif-tmp-info-file)
181 (shell-command (concat "rm -f " eif-tmp-info-file))
182 (message ""))
183
184 (defun eif-store-class-info-flat (class-name)
185 (interactive (list (br-complete-class-name)))
186 (shell-command (concat "flat -b 3 "
187 (br-class-path (br-find-class-name))
188 "> " eif-tmp-info-file)))
189
190 (defun eif-class-name-from-file-name (file-name)
191 (string-match "^.*/\\([a-z0-9_]+\\)\\.e$" file-name)
192 (if (match-beginning 1)
193 (substring file-name (match-beginning 1) (match-end 1))))
194
195 (defun eif-eval-in-other-window (buffer form)
196 "Clear out BUFFER and display result of FORM evaluation in viewer window.
197 Then return to previous window. BUFFER may be a buffer name."
198 (interactive)
199 (let ((wind (selected-window)))
200 (pop-to-buffer (get-buffer-create buffer))
201 (let (buffer-read-only)
202 (erase-buffer)
203 (eval form))
204 (goto-char (point-min))
205 (setq buffer-read-only t)
206 (select-window wind)))
207
208 (defun eif-get-attribute-definition-regexp (identifier-regexp)
209 "Return regexp to match to IDENTIFIER-REGEXP definition.
210 Matching attribute name is grouping 'eif-feature-name-grpn'."
211 (concat eif-modifier-regexp
212 "\\(" identifier-regexp "\\)[ \t]*:[ \t]*"
213 eif-type "\\([ \t]+is[ \t]+.+\\)?[ \t]*;?[ \t]*\\(--.*\\)?$"))
214
215 (defun eif-get-features-from-source (filename &optional form)
216 "Returns cons of attribute def list and routine def list from Eiffel class FILENAME.
217 Optional FORM is a Lisp form to be evaluated instead of the default feature
218 extraction. Assumes file existence has already been checked. The cdr of
219 each element of each item in routine def list is a best guess list of
220 subroutines invoked by the routine."
221 (let* ((no-kill (get-file-buffer filename))
222 (tmp-buf (set-buffer (get-buffer-create "*tmp*")))
223 features orig-buf)
224 (setq buffer-read-only nil)
225 (erase-buffer)
226 (if no-kill
227 (set-buffer no-kill)
228 (setq orig-buf (funcall br-find-file-noselect-function filename))
229 (set-buffer orig-buf))
230 (copy-to-buffer tmp-buf (point-min) (point-max))
231 (set-buffer tmp-buf)
232 (goto-char (point-min))
233 (while (re-search-forward "^\\([^\"\n]*\\)--.*" nil t)
234 (replace-match "\\1" t nil))
235 (goto-char (point-min))
236 (if (not (re-search-forward "^feature[ \t]*$" nil t))
237 nil
238 (setq features
239 (if form
240 (eval form)
241 (eif-parse-features)))
242 (erase-buffer) ; tmp-buf
243 (or no-kill (kill-buffer orig-buf))
244 )
245 features))
246
247 (defun eif-in-comment-p ()
248 "Return nil unless point is within an Eiffel comment."
249 (save-excursion
250 (let ((end (point)))
251 (beginning-of-line)
252 (search-forward "--" end t))))
253
254 (defun eif-to-attribute (&optional identifier)
255 "Move point to attribute matching optional IDENTIFIER or next attribute def in buffer.
256 Leave point at beginning of line where feature is defined.
257 Return name of attribute matched or nil. Ignore obsolete attributes."
258 (let ((pat (if identifier
259 (eif-attribute-to-regexp identifier)
260 eif-attribute-regexp))
261 (start)
262 (found)
263 (keyword)
264 (non-attrib-keyword "local\\|require\\|ensure\\|invariant"))
265 (while (and (re-search-forward pat nil t)
266 (setq found (buffer-substring
267 (match-beginning eif-feature-name-grpn)
268 (match-end eif-feature-name-grpn))
269 start (match-beginning 0))
270 ;; Continue loop if in a comment or a local declaration.
271 (or (if (eif-in-comment-p)
272 (progn (setq found nil) t))
273 (save-excursion
274 (while (and (setq keyword
275 (re-search-backward
276 (concat
277 "\\(^\\|[ \t]+\\)\\("
278 "end\\|feature\\|"
279 non-attrib-keyword
280 "\\)[\; \t\n]")
281 nil t))
282 (eif-in-comment-p)))
283 (if (and keyword
284 (setq keyword
285 (buffer-substring
286 (match-beginning 2)
287 (match-end 2)))
288 (equal 0 (string-match non-attrib-keyword
289 keyword)))
290 (progn (setq found nil) t))))))
291 (if start (goto-char start))
292 found))
293
294 (defun eif-parse-attributes ()
295 "Returns list of attributes defined in current buffer.
296 Assumes point is at the start of buffer."
297 (let (attribs attrib lattrib reserved)
298 ;; For each attribute definition
299 (while (and (eif-to-attribute)
300 (looking-at eif-attribute-regexp))
301 (setq attrib (buffer-substring
302 (match-beginning eif-feature-name-grpn)
303 (match-end eif-feature-name-grpn))
304 lattrib (downcase attrib))
305 (goto-char (match-end 0))
306 (if (or (> (length lattrib) 9)
307 (< (length lattrib) 2))
308 nil
309 (setq reserved eif-reserved-words)
310 ;; Ensure that each attrib is not a reserved word
311 (while (if (string-equal lattrib (car reserved))
312 (setq attrib nil)
313 (string-lessp (car reserved) lattrib))
314 (setq reserved (cdr reserved))))
315 (if attrib (br-set-cons attribs attrib)))
316 (setq attribs (nreverse attribs))))
317
318 (defun eif-parse-features (&optional skip-calls)
319 "Returns cons of attribute def list and routine def list from current buffer.
320 The cdr of each item in routine def list is a best guess list of routine calls
321 invoked by the routine, unless optional SKIP-CALLS is non-nil, in which case
322 each item is just the routine name."
323 (let ((routines) attribs external routine calls non-ids reserved type)
324 ;; Get attribute definitions
325 ;; and add attributes to list of names not to consider routine invocations.
326 (setq attribs (eif-parse-attributes)
327 non-ids (append attribs eif-reserved-words)
328 attribs (mapcar (function (lambda (attribute)
329 (concat "= " attribute)))
330 attribs))
331 (goto-char (point-min))
332 ;; For each routine definition
333 (while (re-search-forward eif-routine-regexp nil t)
334 (setq routine (buffer-substring (match-beginning eif-feature-name-grpn)
335 (match-end eif-feature-name-grpn))
336 external (if (match-beginning eif-modifier-grpn)
337 (string-match "external"
338 (buffer-substring
339 (match-beginning eif-modifier-grpn)
340 (match-end eif-modifier-grpn))))
341 reserved non-ids)
342 (if (match-beginning eif-feature-args-grpn)
343 ;; Routine takes a list of arguments.
344 ;; Add ids matched to list of names not to consider routine
345 ;; invocations.
346 (setq reserved
347 (append (eif-parse-params
348 (match-beginning eif-feature-args-grpn)
349 (match-end eif-feature-args-grpn))
350 reserved)))
351 (cond (external
352 (setq routine (concat "/ " routine)))
353 ((re-search-forward
354 "^[ \t]*\\(do\\|once\\|deferred\\)[ \t\n]+" nil t)
355 (setq type (buffer-substring (match-beginning 1) (match-end 1)))
356 (cond ((string-equal type "do")
357 (setq routine (concat "- " routine)))
358 ((string-equal type "once")
359 (setq routine (concat "1 " routine)))
360 (t ;; deferred type
361 (setq routine (concat "> " routine))))
362 (if skip-calls
363 (setq routines (cons routine routines))
364 (setq calls (nreverse (eif-parse-ids reserved))
365 routines (cons (cons routine calls) routines))))))
366 (setq routines (nreverse routines))
367 (cons attribs routines)))
368
369 (defun eif-parse-ids (&optional non-ids)
370 "Ignores list of NON-IDS and returns list of Eiffel identifiers through the end of the current routine definition."
371 (let (call calls lcall call-list non-id-list same start valid-call)
372 (while (and (setq start (eif-try-for-routine-call))
373 ;; Ignore assignable entities
374 (cond ((stringp start)
375 (setq non-ids (cons (downcase start) non-ids)))
376 ;; Ignore reserved word expressions that look like
377 ;; routine calls with arguments
378 ((and (setq call
379 (downcase
380 (buffer-substring start (match-end 0))))
381 (looking-at "[ \t]*\(")
382 (br-member call non-ids)))
383 ;; Skip past rest of this routine invocation
384 ((progn
385 (while (or (progn (setq valid-call t same (point))
386 (and (setq call
387 (eif-skip-past-arg-list)
388 valid-call
389 (or (null call)
390 (= call 0)))
391 (looking-at "\\.")
392 (progn
393 (skip-chars-forward ".")
394 (if (setq valid-call
395 (looking-at
396 eif-identifier))
397 (goto-char
398 (match-end 0)))))
399 (> (point) same))
400 (if (and valid-call (looking-at "\\."))
401 (progn (skip-chars-forward ".")
402 (if (setq valid-call
403 (looking-at
404 eif-identifier))
405 (goto-char
406 (match-end 0)))))))
407 (if (and valid-call
408 (/= start (point)))
409 (progn (setq call (buffer-substring start (point))
410 lcall (downcase call))
411 ;; If at end of 'do' part of routine
412 ;; definition...
413 (if (or (string-equal lcall "ensure")
414 (and (string-equal lcall "end")
415 (looking-at
416 "[ \t]*[;]?[ \t]*[\n][ \t]*[\n]")))
417 (setq valid-call nil)
418 (if call (br-set-cons calls call))
419 )
420 valid-call)
421 nil))))))
422 (while calls
423 (setq call (car calls)
424 calls (cdr calls)
425 lcall (downcase call)
426 non-id-list
427 (or non-ids eif-reserved-words))
428 (if (br-member lcall non-id-list)
429 (setq call nil))
430 (if call (setq call-list (append call-list (list call)))))
431 call-list))
432
433 (defun eif-parse-params (start end)
434 "Returns list of Eiffel formal parameters between START and END, in reverse order."
435 (narrow-to-region start end)
436 (goto-char (point-min))
437 (let (params)
438 (while (re-search-forward eif-identifier nil t)
439 (setq params (cons (buffer-substring
440 (match-beginning 0) (match-end 0)) params))
441 (if (looking-at "[ \t]*:")
442 (progn (goto-char (match-end 0))
443 (re-search-forward eif-type nil t)))
444 )
445 (widen)
446 params))
447
448 (defun eif-skip-past-arg-list ()
449 "Skips path arg list delimited by parenthesis.
450 Leaves point after closing parenthesis. Returns number of unclosed parens
451 iff point moves, otherwise nil."
452 (let ((depth 0))
453 (if (not (looking-at "[ \t]*\("))
454 nil
455 (setq depth (1+ depth))
456 (goto-char (match-end 0))
457 (while (> depth 0)
458 (skip-chars-forward "^()\"'")
459 (cond ((= ?\" (following-char))
460 (progn (forward-char 1)
461 (skip-chars-forward "^\"")))
462 ((= ?' (following-char))
463 (progn (forward-char 1)
464 (skip-chars-forward "^'")))
465 ((setq depth (if (= ?\( (following-char))
466 (1+ depth)
467 (1- depth)))))
468 (and (not (eobp)) (forward-char 1)))
469 depth)))
470
471 (defun eif-try-for-routine-call ()
472 "Matches to best guess of next routine call.
473 Returns character position of start of valid match, nil when no match,
474 identifier string when an assignable entity, i.e. matches to a non-routine."
475 (if (re-search-forward (concat eif-identifier "\\([ \t\n]*:=\\)?") nil t)
476 (if (match-beginning 2)
477 (buffer-substring (match-beginning 1) (match-end 1))
478 (match-beginning 0))))
479
480 ;;; ************************************************************************
481 ;;; Internal variables
482 ;;; ************************************************************************
483
484 (defvar eif-reserved-words
485 '("!!" "alias" "and" "as" "bits" "boolean" "character" "check" "class" "clone" "create"
486 "creation"
487 "current" "debug" "deferred" "define" "div" "do" "double" "else" "elseif"
488 "end" "ensure" "expanded" "export" "external" "false" "feature" "forget"
489 "from" "if" "implies" "indexing" "infix" "inherit" "inspect" "integer"
490 "invariant" "is" "language" "like" "local" "loop" "mod" "name" "nochange"
491 "not" "obsolete" "old" "once" "or" "prefix" "real" "redefine" "rename"
492 "repeat" "require" "rescue" "result" "retry" "select" "then" "true"
493 "undefine" "unique" "until" "variant" "void" "when" "xor")
494 "Lexicographically ordered list of reserved words in Eiffel version 2.2.
495 Longest one is 9 characters.
496 Minor support for Eiffel 3 has now been added.")
497
498 ;; Must handle types of these forms:
499 ;; like LIST [INTEGER]
500 ;; VECTOR [INTEGER , INTEGER]
501 ;; LIST [ LIST[INTEGER]]
502 ;; yet must ignore the 'is' in:
503 ;; var: INTEGER is 0
504 (defconst eif-type
505 "\\(like[ \t]+\\)?[a-zA-Z][a-zA-Z_0-9]*\\([ \t]*\\[.+\\]\\)?"
506 "Regexp to match Eiffel entity and return value type expressions.")
507
508 (defconst eif-modifier-regexp
509 "^[ \t]*\\(frozen[ \t\n]+\\|external[ \t]+\"[^\" ]+\"[ \t\n]+\\)?"
510 "Special prefix modifiers that can precede a feature definition.")
511
512 ;; Handles attributes of these forms:
513 ;; attr: TYPE
514 ;; char: CHARACTER is 'a'
515 ;; message: STRING is "Hello, what is your name?"
516 ;; flag: BOOLEAN is true ;
517 (defconst eif-attribute-regexp
518 (eif-get-attribute-definition-regexp eif-identifier)
519 "Regexp to match to an attribute definition line.")
520
521 (defconst eif-routine-regexp
522 (concat eif-modifier-regexp "\\(" eif-identifier
523 "\\|prefix[ \t]+\"[^\" ]+\"\\|infix[ \t]+\"[^\" ]+\"\\)[ \t]*"
524 "\\(([^\)]+)[ \t]*\\)?\\(:[ \t\n]*"
525 eif-type "[ \t\n]+\\)?is[ \t]*$")
526 "Regexp to match to routine definition line.
527 Ignores obsolete routines and multiple routine definition lists.")
528 ;;; Should match a multiple feature definition list on a single line
529 ;;; (routine-regexp
530 ;;; (concat "^[ \t]*\\(\\("
531 ;;; eif-identifier "[ \t]*[,]?[ \t]*\\)+\\)"
532 ;;; "\\(([^\)]+)[ \t]*\\)?\\(:[ \t]*"
533 ;;; eif-type "[ \t]+\\)?is[ \t]*$"))
534
535 (defun eif-attribute-to-regexp (identifier)
536 "Return regexp to match to IDENTIFER attribute definition.
537 Attribute name is grouping 'eif-feature-name-grpn'."
538 (eif-get-attribute-definition-regexp (regexp-quote identifier)))
539
540 (defun eif-routine-to-regexp (identifier)
541 "Return regexp to match to IDENTIFIER's routine definition.
542 Routine name is grouping 'eif-feature-name-grpn'. Ignore obsolete routines
543 and multiple routine definition lists."
544 (concat eif-modifier-regexp "\\("
545 (regexp-quote identifier) "\\)[ \t]*"
546 "\\(([^\)]+)[ \t\n]*\\)?\\(:[ \t\n]*"
547 eif-type "[ \t\n]+\\)?is[ \t]*\\(--.*\\)?$"))
548
549 (defconst eif-modifier-grpn 1
550 "Regexp grouping for leading feature modifies, 'frozen' or 'external'.")
551
552 (defconst eif-feature-name-grpn 2
553 "Regexp grouping for feature name from (eif-attribute-to-regexp) or (eif-routine-to-regexp).")
554
555 (defconst eif-feature-args-grpn 4
556 "Regexp grouping for feature arg list for (eif-routine-to-regexp).")
557
558 (defvar eif-last-class-name nil
559 "Last class name used as parameter to 'eif-store-class-info'. Value is
560 used by 'eif-insert-class-info'.")
561
562 (defvar eif-attributes-and-routines nil
563 "Class data stored by 'eif-store-class-info' for use by 'eif-insert-class-info'.")
564
565 (defconst eif-tmp-info-file "/tmp/eif-short"
566 "Temporary file used to hold Eiffel class info.")
567
568 (provide 'eif-calls)