Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-eif.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.el
4 ;; SUMMARY: Support routines for Eiffel inheritance browsing and error parsing.
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
12 ;; LAST-MOD: 21-Sep-95 at 14:13:50 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 ;; DESCRIP-END.
21
22 ;;; ************************************************************************
23 ;;; Other required Elisp libraries
24 ;;; ************************************************************************
25
26 (require 'br-lib)
27
28 ;;; ************************************************************************
29 ;;; User visible variables
30 ;;; ************************************************************************
31
32 (defvar eif-lib-search-dirs nil
33 "List of directories below which Eiffel Library source files are found.
34 Subdirectories of Library source are also searched. A Library is a stable
35 group of classes.")
36
37 (defvar eif-sys-search-dirs nil
38 "List of directories below which Eiffel System source files are found.
39 Subdirectories of System source are also searched. A System class is one
40 that is not yet reusable and is likely to change before release.")
41
42 (defconst eif-narrow-view-to-class nil
43 "*Non-nil means narrow buffer to just the matching class definition when displayed.")
44
45 ;;; ************************************************************************
46 ;;; Internal functions
47 ;;; ************************************************************************
48
49 (defun eif-get-classes-from-source (filename &optional skip-tags
50 skip-tags-cleanup)
51 "Scans FILENAME and returns cons of class list with parents-class alist.
52 Handles multiple inheritance. Assumes file existence and readability have
53 already been checked.
54 With optional SKIP-TAGS non-nil, does not compute and store lookup tags
55 for element definitions. If SKIP-TAGS is nil, normally a cleanup
56 function is called after scanning the elements. SKIP-TAGS-CLEANUP
57 non-nil suppresses this action."
58 ;; Multiple classes per file allowed
59 (let ((no-kill (get-file-buffer filename))
60 classes class end parents signatures start)
61 (if no-kill
62 (set-buffer no-kill)
63 (funcall br-view-file-function filename))
64 (save-excursion
65 (save-restriction
66 (widen)
67 (goto-char (point-min))
68 (while (re-search-forward eif-class-def-regexp nil t)
69 (setq start (point)
70 class
71 (eif-set-case
72 (buffer-substring (match-beginning 2) (match-end 2)))
73 classes (cons class classes)
74 parents (cons (cons (eif-get-parents-from-source
75 filename class)
76 class)
77 parents))
78 (eif-to-class-end)
79 (setq end (point))
80 (or skip-tags
81 ;; Scan class features
82 (setq signatures
83 (eif-scan-features-in-class class start end))))))
84 (if skip-tags
85 nil
86 (eif-get-feature-tags
87 buffer-file-name (eif-sort-features signatures))
88 (or skip-tags-cleanup (br-feature-tags-save)))
89 (or no-kill (kill-buffer (current-buffer)))
90 (cons classes (delq nil parents))))
91
92 (defun eif-get-parents-from-source (filename &optional class-name)
93 "Return list of downcased parents of Eiffel class in FILENAME.
94 Return nil if file is not readable. Assume that Eiffel keywords
95 'inherit' and 'feature' occur at the beginning of lines, when present."
96 (let ((parents) (par)
97 (no-kill (get-file-buffer filename))
98 (obuf (current-buffer)))
99 (if no-kill
100 (set-buffer no-kill))
101 (if (or no-kill
102 (if (file-readable-p filename)
103 (let ((br-view-file-function 'br-insert-file-contents))
104 (message "Scanning %s ..." filename)
105 (funcall br-view-file-function filename)
106 t)))
107 (progn
108 (save-restriction
109 (save-excursion
110 (widen)
111 (goto-char (point-min))
112 (let ((case-fold-search t) ;; Ignore case in searches
113 (end)
114 indent)
115 (if (or (null class-name)
116 (let ((class-def (concat eif-class-name-before
117 (eif-set-case-type class-name)
118 eif-class-name-after)))
119 (re-search-forward class-def nil t)))
120 (if (not (re-search-forward (concat "^inherit[ \t\n]+"
121 eif-parent-regexp)
122 nil t))
123 nil
124 ;; Save first parent
125 (setq parents (list
126 (eif-set-case (buffer-substring
127 (match-beginning 2)
128 (match-end 2))))
129 indent (save-excursion
130 (goto-char (match-beginning 2))
131 (current-column)))
132 ;; Save any succeeding parents
133 (save-excursion
134 (if (re-search-forward "^[a-zA-Z]" nil t)
135 (setq end (1- (point)))))
136 (forward-line 1)
137 (while (< (point) end)
138 (back-to-indentation)
139 (and (<= (current-column) indent)
140 (looking-at eif-identifier)
141 (setq par (eif-set-case (buffer-substring
142 (match-beginning 1)
143 (match-end 1))))
144 (if (or (br-member par parents)
145 (br-member-sorted-strings
146 par eif-reserved-words))
147 nil
148 (setq parents (cons par parents))))
149 (forward-line 1)))))))
150 (or no-kill (kill-buffer (current-buffer)))
151 (set-buffer obuf)
152 (nreverse parents)))))
153
154 (defun eif-select-path (paths-htable-elt &optional feature-p)
155 "Select proper pathname from PATHS-HTABLE-ELT based upon value of optional FEATURE-P.
156 Selection is between path of class definition and path for features associated
157 with the class."
158 (cdr paths-htable-elt))
159
160 (defun eif-set-case (type)
161 "Return string TYPE identifier for use as a class name."
162 (downcase type))
163
164 (defun eif-set-case-type (class-name)
165 "Return string CLASS-NAME for use as a type identifier."
166 (upcase class-name))
167
168
169 (defun eif-to-class-end ()
170 "Assuming point is at start of class, move to start of line after end of class."
171 (interactive)
172 (if (and (re-search-forward "^end[ \t\n-]" nil t)
173 (= (forward-line 1) 0))
174 nil
175 (goto-char (point-max))))
176
177 (defun eif-to-comments-begin ()
178 "Skip back from current point past any preceding blank lines and comments."
179 (let ((opoint))
180 (while
181 (progn (setq opoint (point))
182 ;; To previous line
183 (and (= 0 (forward-line -1))
184 ;; If begins with "--", then is a comment.
185 (cond ((looking-at "[ \t]*--"))
186 ((looking-at "[ \t]*$"))))))
187 (goto-char opoint)
188 ;; Skip past whitespace
189 (skip-chars-forward " \t\n")
190 (beginning-of-line)))
191
192 ;;; ************************************************************************
193 ;;; Internal variables
194 ;;; ************************************************************************
195
196 (defconst eif-class-name-before "^[ \t]*\\(deferred[ \t\n]+\\|expanded[ \t\n]+\\)?class[ \t\n]+"
197 "Regexp preceding the class name in a class definition.")
198
199 (defconst eif-class-name-after "[ \t\n]+"
200 "Regexp following the class name in a class definition.")
201
202 (defconst eif-identifier-chars "A-Za-z0-9_"
203 "String of chars and char ranges that may be used within an Eiffel identifier.")
204
205 (defconst eif-identifier (concat "\\([a-zA-Z][" eif-identifier-chars "]*\\)")
206 "Regular expression matching an Eiffel identifier.")
207
208 (defconst eif-class-def-regexp
209 (concat eif-class-name-before eif-identifier eif-class-name-after)
210 "Regular expression used to match to class definitions in source text.
211 Class name identifier is grouped expression 2.")
212
213 (defconst eif-class-name-preceding
214 "\\([\[\{>;:][ \t\n]*\\|[a-zA-z][ \t\n]+\\)"
215 "Pattern preceding any valid non-comment use of an Eiffel class/type name.")
216
217 (defconst eif-class-name-pat
218 (concat eif-class-name-preceding eif-identifier)
219 "Class name is grouped expression 2.")
220
221 (defconst eif-lang-prefix "eif-"
222 "Prefix string that starts \"br-eif.el\" symbol names.")
223
224
225 (defconst eif-parent-regexp (concat "[ \t\n]*\\(--.*[\n]\\)*[ \t\n]*"
226 eif-identifier)
227 "Parent identifier is grouped expression 2.")
228
229 (defconst eif-src-file-regexp ".\\.e$"
230 "Regular expression matching a unique part of Eiffel class filenames and no others.")
231
232 (defvar eif-children-htable nil
233 "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
234 Used to traverse Eiffel inheritance graph. 'br-build-children-htable' builds
235 this list.")
236 (defvar eif-parents-htable nil
237 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
238 Used to traverse Eiffel inheritance graph. 'br-build-parents-htable' builds
239 this list.")
240 (defvar eif-paths-htable nil
241 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
242 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
243 'br-build-paths-htable' builds this list.")
244
245 (defvar eif-lib-parents-htable nil
246 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
247 Only classes from stable software libraries are used to build the list.")
248 (defvar eif-lib-paths-htable nil
249 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
250 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
251 Only classes from stable software libraries are used to build the list.")
252
253 (defvar eif-sys-parents-htable nil
254 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
255 Only classes from systems that are likely to change are used to build the list.")
256 (defvar eif-sys-paths-htable nil
257 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
258 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
259 Only classes from systems that are likely to change are used to build the
260 list.")
261
262 (defvar eif-lib-prev-search-dirs nil
263 "Used to check if 'eif-lib-paths-htable' must be regenerated.")
264 (defvar eif-sys-prev-search-dirs nil
265 "Used to check if 'eif-sys-paths-htable' must be regenerated.")
266
267 (defvar eif-env-spec nil
268 "Non-nil value means Environment specification has been given but not yet built.
269 Nil means current Environment has been built, though it may still require updating.")
270
271 (provide 'br-eif)