|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: br-clos-ft.el
|
|
|
4 ;; SUMMARY: CLOS OO-Browser class and element functions.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: lisp, oop, tools
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
100
|
9 ;; ORG: InfoDock Associates
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 03-Oct-90
|
|
100
|
12 ;; LAST-MOD: 31-Oct-96 at 17:04:54 by Bob Weiner
|
|
0
|
13 ;;
|
|
100
|
14 ;; Copyright (C) 1990-1996 Free Software Foundation, Inc.
|
|
0
|
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 (mapcar 'require '(br-clos set))
|
|
|
27
|
|
|
28 ;;; ************************************************************************
|
|
|
29 ;;; Public variables
|
|
|
30 ;;; ************************************************************************
|
|
|
31
|
|
|
32 (defconst clos-type-identifier
|
|
|
33 (concat "[" clos-type-identifier-chars "]+"))
|
|
|
34
|
|
|
35 (defconst clos-type-tag-separator ","
|
|
|
36 "String that separates a tags type from its normalized definition form.")
|
|
|
37
|
|
|
38 (defconst clos-def-form-match "\([^ \t\n\r]+[ \t\n\r]+")
|
|
|
39
|
|
100
|
40 (defconst clos-tag-fields-regexp
|
|
|
41 (concat "\\`\\(" clos-type-identifier "\\)"
|
|
0
|
42 clos-type-tag-separator
|
|
|
43 clos-def-form-match "['\(]?"
|
|
|
44 "\\((setf[^\)]+)\\|[^\(;,]+\\)\\( *(.*)\\)?")
|
|
|
45 "Regexp matching a fully qualified, normalized clos feature tag.
|
|
|
46 Class name is grouping 1. Feature name is grouping 2. Optional
|
|
|
47 argument list (aliased features don't have one) is grouping 3.")
|
|
|
48
|
|
|
49 ;;; ************************************************************************
|
|
|
50 ;;; Public functions
|
|
|
51 ;;; ************************************************************************
|
|
|
52
|
|
|
53 (defun clos-add-default-classes ()
|
|
|
54 ;; Add to 'system' class table.
|
|
|
55 (let ((classes (set:create (mapcar 'cdr clos-element-type-alist))))
|
|
|
56 ;; Methods are broken out into individual classes, so don't add "method"
|
|
|
57 ;; as a default class.
|
|
|
58 (setq classes (set:remove "method" classes))
|
|
|
59 (mapcar
|
|
|
60 (function (lambda (class)
|
|
|
61 (br-add-class (concat "[" class "]")
|
|
|
62 br-null-path nil)))
|
|
|
63 classes)))
|
|
|
64
|
|
|
65 (defun clos-class-routine-to-regexp (class routine-name args)
|
|
|
66 "Return regexp matching definition of CLASS's ROUTINE-NAME with ARGS.
|
|
|
67 ARGs should be a string or nil if routine definition had no argument list,
|
|
|
68 i.e. an alias."
|
|
|
69 (setq class (regexp-quote class)
|
|
|
70 routine-name (regexp-quote routine-name)
|
|
|
71 args (if (stringp args) (regexp-quote args) args))
|
|
|
72 ;; Search for CLOS method definition based on first typed argument.
|
|
|
73 (concat "(defmethod[ \t\n\r]+"
|
|
|
74 routine-name "[ \t\n\r]"
|
|
|
75 ;; Alias defmethods don't have an argument list, so don't
|
|
|
76 ;; try to find one unless signature had an argument list.
|
|
|
77 (if (not args)
|
|
|
78 "+"
|
|
|
79 (concat "*[^\)]*[ \t\n\r]" class "[ \t\n\r]*\)"))
|
|
|
80 "\\|"
|
|
|
81 ;; Search for BWlib routine definition where class name is
|
|
|
82 ;; prepended with a colon to the routine name.
|
|
|
83 (concat "(defmethod[ \t\n\r]+" class ":" routine-name
|
|
|
84 "[ \t\n\r]"
|
|
|
85 ;; BWlib alias defmethods don't have an argument list,
|
|
|
86 ;; so don't try to find one unless signature had an
|
|
|
87 ;; argument list.
|
|
|
88 (if (not args) "+" "*\("))))
|
|
|
89
|
|
|
90 (defun clos-feature-implementors (ftr-name)
|
|
|
91 "Return unsorted list of clos feature tags which implement FTR-NAME."
|
|
|
92 (if (string-match "[ \t]+$" ftr-name)
|
|
|
93 (setq ftr-name (substring ftr-name 0 (match-beginning 0))))
|
|
|
94 (clos-feature-matches (concat "^" (regexp-quote ftr-name) "$")))
|
|
|
95
|
|
|
96 (defun clos-feature-locate-p (feature-tag)
|
|
|
97 (let (start)
|
|
|
98 (if (not (re-search-forward
|
|
|
99 (clos-feature-signature-to-regexp feature-tag) nil t))
|
|
|
100 nil
|
|
|
101 (setq start (match-beginning 0))
|
|
|
102 (goto-char start)
|
|
|
103 (skip-chars-forward " \t\n")
|
|
|
104 (clos-to-comments-begin)
|
|
|
105 (recenter 0)
|
|
|
106 (goto-char start)
|
|
|
107 t)))
|
|
|
108
|
|
100
|
109 (defun clos-feature-map-class-tags (function class)
|
|
|
110 "Apply FUNCTION to all feature tags from CLASS and return a list of the results.
|
|
|
111 Feature tags come from the file named by br-feature-tags-file."
|
|
|
112 (let ((obuf (current-buffer))
|
|
|
113 (class-tag (concat "\n" class clos-type-tag-separator))
|
|
|
114 (results))
|
|
|
115 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
|
116 (goto-char 1)
|
|
|
117 ;; Feature defs (methods) for a single class could occur in any file,
|
|
|
118 ;; according to Common Lisp rules.
|
|
|
119 (while (search-forward class-tag nil t)
|
|
|
120 (setq results (cons (funcall function) results))
|
|
|
121 ;; Might have deleted current tag and would miss next tag unless point
|
|
|
122 ;; is moved backwards.
|
|
|
123 (backward-char))
|
|
|
124 (set-buffer obuf)
|
|
|
125 results))
|
|
|
126
|
|
0
|
127 (defun clos-feature-name-to-regexp (name)
|
|
|
128 "Converts feature NAME into a regular expression matching the feature's name tag."
|
|
|
129 (if (string-match (concat "^" br-feature-type-regexp " ") name)
|
|
|
130 (setq name (substring name (match-end 0))))
|
|
|
131 (format "%s%s\(\\(%s\\) %s[ \n]"
|
|
|
132 clos-type-identifier clos-type-tag-separator clos-def-form-regexp
|
|
|
133 (regexp-quote name)))
|
|
|
134
|
|
|
135 (defun clos-feature-signature-to-name (signature &optional with-class for-display)
|
|
|
136 "Extracts the feature name from SIGNATURE.
|
|
|
137 The feature's class name is dropped from signature unless optional WITH-CLASS
|
|
|
138 is non-nil. If optional FOR-DISPLAY is non-nil, a \"- \" is prepended to
|
|
|
139 the name for display in a browser listing."
|
|
|
140 (concat (if for-display "- ")
|
|
|
141 (clos-feature-partial-name signature with-class)))
|
|
|
142
|
|
|
143 (defun clos-feature-signature-to-regexp (signature)
|
|
|
144 "Given a clos element SIGNATURE, return regexp to match its definition."
|
|
|
145 (cond ((string-match (concat "\\`[^ \t\n\r;]+" clos-type-tag-separator)
|
|
|
146 signature)
|
|
|
147 (clos-element-def-to-regexp
|
|
|
148 (substring signature (match-end 0))))
|
|
|
149 ((string-match (concat "\\(" clos-arg-identifier "\\):\\("
|
|
|
150 clos-element-identifier
|
|
|
151 "\\)[ \t\n\r]*\\(\(\\)?")
|
|
|
152 signature)
|
|
|
153 (clos-class-routine-to-regexp
|
|
|
154 (substring signature (match-beginning 1) (match-end 1))
|
|
|
155 (substring signature (match-beginning 2) (match-end 2))
|
|
|
156 (if (= ?\( (elt signature (match-end 0)))
|
|
|
157 (substring signature (match-beginning 3)))))))
|
|
|
158
|
|
100
|
159 (defun clos-feature-tag-regexp (class feature-name)
|
|
|
160 "Return a regexp that matches to the feature tag entry for CLASS' FEATURE-NAME."
|
|
|
161 (concat "^" (regexp-quote class) clos-type-tag-separator
|
|
|
162 clos-def-form-match "['\(]?"
|
|
|
163 (regexp-quote feature-name) "\\( *(.*)\\)?"))
|
|
|
164
|
|
0
|
165 (defun clos-feature-tree-command-p (class-or-signature)
|
|
|
166 "Display definition of CLASS-OR-SIGNATURE if a signature and return t, else return nil."
|
|
|
167 (if (br-in-browser) (br-to-view-window))
|
|
|
168 (br-feature-found-p (br-feature-file class-or-signature)
|
|
|
169 class-or-signature))
|
|
|
170
|
|
|
171 (defun clos-list-features (class &optional indent)
|
|
100
|
172 "Return sorted list of Clos feature tags lexically defined in CLASS.
|
|
|
173 Optional INDENT is unused but is required for multi-language OO-Browser conformance."
|
|
|
174 ;; Use nreverse here so that stable sort ends up leaving same named
|
|
|
175 ;; features in the order they were defined in the source file.
|
|
|
176 (clos-sort-features
|
|
|
177 (nreverse (clos-feature-map-class-tags 'br-feature-current class))))
|
|
0
|
178
|
|
|
179 (defun clos-scan-features ()
|
|
|
180 "Return reverse ordered list of clos feature definitions in current buffer.
|
|
|
181 Assume point is at the beginning of a widened buffer."
|
|
|
182 (save-excursion
|
|
|
183 (let ((features) (tag-list)
|
|
|
184 ;; t if current file is an Emacs Lisp file and therefore may
|
|
|
185 ;; contain BWlib method definitions. BWlib is a simple CLOS-like
|
|
|
186 ;; object system for Emacs Lisp written by the author of the
|
|
|
187 ;; OO-Browser for use in InfoDock, but not yet released.
|
|
|
188 (bwlib-flag (and buffer-file-name
|
|
|
189 (string-match "\\.el$" buffer-file-name)
|
|
|
190 t))
|
|
|
191 def-form)
|
|
|
192 (while (re-search-forward clos-element-def nil t)
|
|
|
193 (setq tag-list (mapcar
|
|
|
194 'clos-feature-normalize
|
|
|
195 (clos-element-tag-list
|
|
|
196 (setq def-form
|
|
|
197 (buffer-substring
|
|
|
198 (match-beginning clos-def-form-grpn)
|
|
|
199 (match-end clos-def-form-grpn)))
|
|
|
200 (buffer-substring (match-beginning clos-feature-grpn)
|
|
|
201 (match-end clos-feature-grpn))
|
|
|
202 (if (string-match clos-def-form-with-args-regexp
|
|
|
203 def-form)
|
|
|
204 (clos-scan-routine-arglist))
|
|
|
205 bwlib-flag))
|
|
|
206 features (nconc features tag-list)))
|
|
|
207 features)))
|
|
|
208
|
|
|
209 (defun clos-scan-routine-arglist ()
|
|
|
210 "Return list of routine's formal parameters. Leaves point after arglist.
|
|
|
211 Requires that caller has left point in front of arglist.
|
|
|
212 If routine is an alias, get argument list from the routine aliased, if
|
|
|
213 defined, else return nil."
|
|
|
214 (skip-chars-forward " \t\n\r")
|
|
|
215 (if (= (following-char) ?\()
|
|
|
216 (buffer-substring (point) (progn (progn (forward-list) (point))))
|
|
|
217 ;; No arglist, treat as an alias.
|
|
|
218 (let ((aliased-function (read (current-buffer)))
|
|
|
219 arg-list)
|
|
|
220 (setq aliased-function
|
|
|
221 (condition-case ()
|
|
|
222 (cond ((fboundp 'indirect-function)
|
|
|
223 (indirect-function aliased-function))
|
|
|
224 ((fboundp 'hypb:indirect-function)
|
|
|
225 (indirect-function aliased-function))
|
|
|
226 (t aliased-function))
|
|
|
227 (void-function nil)))
|
|
|
228 (if (null aliased-function)
|
|
|
229 nil
|
|
|
230 (setq arg-list
|
|
|
231 (cond ((fboundp 'action:params)
|
|
|
232 (action:params aliased-function))
|
|
|
233 ((listp aliased-function)
|
|
|
234 (if (eq (car aliased-function) 'autoload)
|
|
|
235 (error "(clos-scan-routine-arglist): Arglist unknown for autoload functions: %s" aliased-function)
|
|
|
236 (car (cdr aliased-function))))
|
|
|
237 ((funcall (if (fboundp 'compiled-function-p)
|
|
|
238 'compiled-function-p
|
|
|
239 'byte-code-function-p)
|
|
|
240 aliased-function)
|
|
|
241 ;; Turn into a list for extraction
|
|
|
242 (car (cdr (cons nil (append aliased-function nil)))))))
|
|
|
243 (if arg-list (prin1-to-string arg-list))))))
|
|
|
244
|
|
|
245 (defun clos-sort-features (feature-list)
|
|
|
246 (sort feature-list 'clos-feature-lessp))
|
|
|
247
|
|
|
248 ;; !! Need to write clos-to-definition function.
|
|
|
249 ;; Move from an identifier to its definition as best as possible.
|
|
|
250 ;; Use the following temporarily.
|
|
|
251 (fset 'clos-to-definition 'smart-lisp)
|
|
|
252
|
|
|
253 ;;; ************************************************************************
|
|
|
254 ;;; Private functions
|
|
|
255 ;;; ************************************************************************
|
|
|
256
|
|
|
257 (defun clos-element-def-to-regexp (element-def)
|
|
|
258 "Convert a normalized clos element definition to a regular expression that will match to its definition in the source code."
|
|
|
259 (setq element-def (regexp-quote element-def))
|
|
|
260 (mapconcat (function (lambda (c)
|
|
|
261 (if (= c ?\ )
|
|
|
262 "[ \t\n\r]+\\(;.*[ \t\n\r]+\\)?"
|
|
|
263 (char-to-string c))))
|
|
|
264 element-def nil))
|
|
|
265
|
|
|
266 (defun clos-feature-def-p ()
|
|
|
267 "Return nil unless point is within a feature definition.
|
|
|
268 If point is within a comment, return nil.
|
|
|
269 Leaves point at start of the definition for visual clarity."
|
|
|
270 (if (clos-skip-to-statement)
|
|
|
271 (looking-at "\(def")))
|
|
|
272
|
|
|
273 (defun clos-feature-partial-name (signature &optional with-class)
|
|
|
274 "Extract the feature name without its class name from feature SIGNATURE.
|
|
|
275 If optional WITH-CLASS is non-nil, class name and 'clos-type-tag-separator'
|
|
|
276 are prepended to the name returned."
|
|
100
|
277 (if (string-match clos-tag-fields-regexp signature)
|
|
0
|
278 (let ((class (substring signature
|
|
|
279 (match-beginning 1) (match-end 1)))
|
|
|
280 (name (substring signature (match-beginning 2)
|
|
|
281 (match-end 2))))
|
|
|
282 (setq name (br-delete-space name))
|
|
|
283 (if (string-match (concat "\\`" class ":") name)
|
|
|
284 (setq name (substring name (match-end 0))))
|
|
|
285 (if with-class
|
|
|
286 (concat class clos-type-tag-separator name)
|
|
|
287 name))
|
|
|
288 signature))
|
|
|
289
|
|
|
290 (defun clos-feature-lessp (routine1 routine2)
|
|
|
291 (string-lessp (clos-feature-partial-name routine1)
|
|
|
292 (clos-feature-partial-name routine2)))
|
|
|
293
|
|
100
|
294 (defun clos-feature-map-tags (function regexp)
|
|
|
295 "Apply FUNCTION to all current feature tags that match REGEXP and return a list of the results.
|
|
|
296 Feature tags come from the file named by br-feature-tags-file."
|
|
|
297 (let ((identifier-chars (concat "[" clos-identifier-chars "]*"))
|
|
|
298 (results))
|
|
|
299 ;; Ensure match to feature names only; also handle "^" and "$" meta-chars
|
|
|
300 (setq regexp
|
|
|
301 (concat "^\\(" clos-type-identifier "\\)"
|
|
|
302 clos-type-tag-separator
|
|
|
303 clos-def-form-match "['\(]?"
|
|
|
304 (if (equal (substring regexp 0 1) "^")
|
|
|
305 (progn (setq regexp (substring regexp 1)) nil)
|
|
|
306 identifier-chars)
|
|
|
307 (if (equal (substring regexp -1) "$")
|
|
|
308 (substring regexp 0 -1)
|
|
|
309 (concat regexp identifier-chars))
|
|
|
310 "[ \t\n\r\f]"))
|
|
|
311 (save-excursion
|
|
|
312 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
|
313 (goto-char 1)
|
|
|
314 (while (re-search-forward regexp nil t)
|
|
|
315 (setq results (cons (funcall function) results))))
|
|
|
316 results))
|
|
|
317
|
|
70
|
318 (defun clos-feature-matches (regexp)
|
|
100
|
319 "Return an unsorted list of feature tags whose names match in part or whole to REGEXP.
|
|
|
320 ^ and $ characters may be used to match to the beginning and end of a feature name,
|
|
|
321 respectively."
|
|
|
322 (clos-feature-map-tags
|
|
|
323 ;; Backward-char is necessary in this next function since point might have
|
|
|
324 ;; moved past a newline.
|
|
|
325 (function (lambda () (backward-char) (br-feature-current)))
|
|
|
326 regexp))
|
|
|
327
|
|
0
|
328
|
|
|
329 (defun clos-feature-normalize (routine)
|
|
|
330 (let* ((len (length routine))
|
|
|
331 (normal-feature (make-string len ?\ ))
|
|
|
332 (n 0) (i 0)
|
|
|
333 (space-list '(?\ ?\t ?\n ?\r))
|
|
|
334 (space-regexp "[ \t\n\r]+")
|
|
|
335 chr)
|
|
|
336 (while (< i len)
|
|
|
337 (setq chr (aref routine i))
|
|
|
338 (cond
|
|
|
339 ;; Convert sequences of space characters to a single space.
|
|
|
340 ((memq chr space-list)
|
|
|
341 (aset normal-feature n ?\ )
|
|
|
342 (if (string-match space-regexp routine i)
|
|
|
343 (setq i (match-end 0)
|
|
|
344 n (1+ n))
|
|
|
345 (setq i (1+ i)
|
|
|
346 n (1+ n))))
|
|
|
347 ;;
|
|
|
348 ;; Remove ; style comments
|
|
|
349 ((= chr ?\;)
|
|
|
350 (setq i (1+ i))
|
|
|
351 (while (and (< i len) (/= (aref routine i) ?\n))
|
|
|
352 (setq i (1+ i))))
|
|
|
353 (t ;; Normal character
|
|
|
354 (aset normal-feature n chr)
|
|
|
355 (setq i (1+ i)
|
|
|
356 n (1+ n)))))
|
|
|
357 (substring normal-feature 0 n)))
|
|
|
358
|
|
|
359 (defun clos-element-tag-list (element-type element arglist-string
|
|
|
360 &optional bwlib-flag)
|
|
|
361 "Return list of tags (strings) of ELEMENT-TYPE, ELEMENT and its ARGLIST-STRING.
|
|
|
362 All three arguments should be strings.
|
|
|
363 Optional BWLIB-FLAG non-nil means check for BWlib expressions of the form:
|
|
|
364 \(defmethod class:method-name (args)...)."
|
|
|
365 (let* ((element-category (downcase element-type))
|
|
|
366 (element-tag-function
|
|
|
367 (intern-soft (concat "clos-" element-category "-tag-list")))
|
|
|
368 (args (if (or (null arglist-string)
|
|
|
369 (string-equal arglist-string ""))
|
|
|
370 ""
|
|
|
371 (concat " " arglist-string)))
|
|
|
372 element-def-and-type)
|
|
|
373 (cond ((fboundp element-tag-function)
|
|
|
374 ;; If any such function is defined, it must return a list of
|
|
|
375 ;; element-tags generated from the defining form, even if it
|
|
|
376 ;; generates only 1 tag.
|
|
|
377 (funcall element-tag-function element-type element arglist-string))
|
|
|
378 ((and bwlib-flag
|
|
|
379 (string-match clos-def-form-with-args-regexp element-category)
|
|
|
380 (string-match "\\`['\(]?\\([^ \t\n\r]+\\):" element))
|
|
|
381 ;; BWlib element definition support
|
|
|
382 (list
|
|
|
383 (format "%s%s\(%s %s%s"
|
|
|
384 (substring element (match-beginning 1) (match-end 1))
|
|
|
385 clos-type-tag-separator
|
|
|
386 element-type element args)))
|
|
|
387 ((equal element-category "defmethod")
|
|
|
388 ;; CLOS defmethod
|
|
|
389 (let ((arglist (if (string-equal args "")
|
|
|
390 t
|
|
|
391 (read arglist-string)))
|
|
|
392 (class)
|
|
|
393 (tags))
|
|
|
394 (if (nlistp arglist)
|
|
|
395 ;; Add to CLOS default 't' class.
|
|
|
396 (list (format "t%s\(defmethod %s"
|
|
|
397 clos-type-tag-separator element))
|
|
|
398 ;; If any argument in arglist is itself a list, then this is a
|
|
|
399 ;; CLOS method definition with one or more (<arg-name>
|
|
|
400 ;; <type-name>) arguments. We generate one tag for each arg
|
|
|
401 ;; list, with the tag's class = <type-name>. We stop looking
|
|
|
402 ;; for specialized arguments if we encounter a keyword
|
|
|
403 ;; beginning with '&'.
|
|
|
404 (setq tags
|
|
|
405 (delq
|
|
|
406 nil
|
|
|
407 (mapcar
|
|
|
408 (function
|
|
|
409 (lambda (arg)
|
|
|
410 (cond ((null arglist)
|
|
|
411 ;; Encountered &keyword, so ignore rest of
|
|
|
412 ;; args.
|
|
|
413 nil)
|
|
|
414 ((null arg) nil)
|
|
|
415 ((nlistp arg)
|
|
|
416 (and (symbolp arg)
|
|
|
417 (= ?& (aref (symbol-name arg) 0))
|
|
|
418 ;; Encountered &keyword, set up to
|
|
|
419 ;; ignore rest of args.
|
|
|
420 (setq arglist nil)))
|
|
|
421 (t
|
|
|
422 ;; Typed argument
|
|
|
423 (setq class (car (cdr arg)))
|
|
|
424 ;; Type may be of the form: (eql <form>)
|
|
|
425 ;; which is used to compute the type. We
|
|
|
426 ;; can't compute this here, however, so
|
|
|
427 ;; ignore such types.
|
|
|
428 (if (listp class)
|
|
|
429 nil
|
|
|
430 (setq class (symbol-name class))
|
|
|
431 (format "%s%s\(defmethod %s%s"
|
|
|
432 class clos-type-tag-separator
|
|
|
433 element args))))))
|
|
|
434 arglist)))
|
|
|
435 (or tags
|
|
|
436 ;; Add this method to CLOS default 't' class since none of
|
|
|
437 ;; its parameters were specialized.
|
|
|
438 (list (format "t%s\(defmethod %s%s"
|
|
|
439 clos-type-tag-separator element args))))))
|
|
|
440 ((setq element-def-and-type (assoc element-category
|
|
|
441 clos-element-type-alist))
|
|
|
442 (list (format "[%s]%s\(%s %s%s"
|
|
|
443 (cdr element-def-and-type)
|
|
|
444 clos-type-tag-separator
|
|
|
445 element-type element args)))
|
|
|
446 (t (beep)
|
|
|
447 (message
|
|
|
448 "(clos-element-tag): '%s' is an unknown definition type"
|
|
|
449 element-type)
|
|
|
450 (sit-for 3)))))
|
|
|
451
|
|
|
452 (defun clos-feature-tag-class (element-tag)
|
|
|
453 "Extract the class name from ELEMENT-TAG."
|
|
|
454 (if (string-match (format "\\([^ \t%s]+\\)%s"
|
|
|
455 clos-type-tag-separator
|
|
|
456 clos-type-tag-separator)
|
|
|
457 element-tag)
|
|
|
458 (substring element-tag (match-beginning 1) (match-end 1))
|
|
|
459 ""))
|
|
|
460
|
|
|
461 (defun clos-files-with-source (class)
|
|
|
462 "Use CLASS to compute set of files that match to a clos source file regexp.
|
|
|
463 Return as a list."
|
|
|
464 (let ((file (if class (br-class-path class) buffer-file-name)))
|
|
|
465 (and file
|
|
|
466 (let* ((src-file-regexp (concat "^" (br-filename-head file)
|
|
|
467 clos-src-file-regexp))
|
|
|
468 (dir (file-name-directory file))
|
|
|
469 (files (directory-files dir nil src-file-regexp)))
|
|
|
470 (mapcar (function (lambda (f) (concat dir f)))
|
|
|
471 files)))))
|
|
|
472
|
|
|
473 (defun clos-find-class-name ()
|
|
|
474 "Return current word as a potential class name."
|
|
|
475 (save-excursion
|
|
|
476 (let* ((start)
|
|
|
477 (ignore " \t\n\r ;,\(\){}")
|
|
|
478 (pat (concat "^" ignore)))
|
|
|
479 (forward-char 1)
|
|
|
480 (skip-chars-backward ignore)
|
|
|
481 (skip-chars-backward pat)
|
|
|
482 (setq start (point))
|
|
|
483 (skip-chars-forward (concat pat ":"))
|
|
|
484 (buffer-substring start (point)))))
|
|
|
485
|
|
|
486 (defun clos-get-class-name-from-source ()
|
|
|
487 "Return class name from closest class definition preceding point or nil."
|
|
|
488 (save-excursion
|
|
|
489 (if (re-search-backward clos-class-def-regexp nil t)
|
|
|
490 (buffer-substring (match-beginning 1) (match-end 1)))))
|
|
|
491
|
|
|
492 (defun clos-get-feature-tags (feature-file &optional feature-list)
|
|
|
493 "Scan clos FEATURE-FILE and hold feature tags in 'br-feature-tags-file'.
|
|
|
494 Assume FEATURE-FILE has already been read into a buffer and that
|
|
|
495 'br-feature-tags-init' has been called. Optional FEATURE-LIST can be
|
|
|
496 provided so that a non-standard scan function can be used before calling
|
|
|
497 this function."
|
|
|
498 (interactive)
|
|
|
499 (let ((obuf (current-buffer)))
|
|
|
500 (or feature-list
|
|
|
501 (setq feature-list (clos-sort-features
|
|
|
502 (nreverse (clos-scan-features)))))
|
|
|
503 (set-buffer (funcall br-find-file-noselect-function br-feature-tags-file))
|
|
|
504 (goto-char 1)
|
|
|
505 ;; Delete any prior feature tags associated with feature-file
|
|
|
506 (if (search-forward feature-file nil 'end)
|
|
|
507 (progn (forward-line -1)
|
|
|
508 (let ((start (point)))
|
|
|
509 (search-forward "\^L" nil 'end 2)
|
|
|
510 (backward-char 1)
|
|
|
511 (delete-region start (point))
|
|
|
512 )))
|
|
|
513 (if feature-list
|
|
|
514 (progn (insert "\^L\n" feature-file "\n")
|
|
|
515 (mapcar (function (lambda (tag) (insert tag "\n")))
|
|
|
516 feature-list)))
|
|
|
517 (set-buffer obuf)))
|
|
|
518
|
|
|
519 (defun clos-skip-past-comments ()
|
|
|
520 "Skip over comments immediately following point."
|
|
|
521 (skip-chars-forward " \t\n")
|
|
|
522 (while
|
|
|
523 (cond ((looking-at "//")
|
|
|
524 (equal (forward-line 1) 0))
|
|
|
525 ((looking-at "/\\*")
|
|
|
526 (re-search-forward "\\*/" nil t))
|
|
|
527 (t nil))))
|
|
|
528
|
|
|
529 (defun clos-skip-to-statement ()
|
|
|
530 (let ((bol (save-excursion (beginning-of-line) (point))))
|
|
|
531 (if (save-excursion (search-backward ";" bol t))
|
|
|
532 nil ;; In a comment
|
|
|
533 ;; Find definition beginning.
|
|
|
534 (re-search-backward "^\(\\|" nil t))))
|
|
|
535
|
|
|
536 ;;; ************************************************************************
|
|
|
537 ;;; Private variables
|
|
|
538 ;;; ************************************************************************
|
|
|
539
|
|
|
540 (defconst clos-element-identifier
|
|
|
541 (let ((identifier "[^][ \t\n\r;,`'{}()]+"))
|
|
|
542 ;; Initial optional paren is for defstructs of the form:
|
|
|
543 ;; (defstruct (identifier options))
|
|
|
544 (concat "['\(]?\\(" identifier
|
|
|
545 "\\|(setf[ \t\n\r]+" identifier "[ \t\n\r]*)\\)"
|
|
|
546 "\\([ \t\n\r]+'?:" identifier "\\)?"))
|
|
|
547 "Regular expression matching a clos element name.
|
|
|
548 If a method, this includes any method qualifier. Optional method qualifier
|
|
|
549 is of the form: :before, :after or :around. \(setf <slot>) names the writer
|
|
|
550 method for <slot>.")
|
|
|
551
|
|
|
552 (defconst clos-comment-regexp "\\([ \t\n\r]*;.*[\n\r]\\)*[ \t\n\r]*")
|
|
|
553
|
|
|
554 (defvar clos-element-type-alist
|
|
|
555 '(("defconstant" . "constant")
|
|
|
556 ("defconst" . "constant")
|
|
|
557 ("defun" . "function")
|
|
|
558 ("defgeneric" . "generic")
|
|
|
559 ("defmacro" . "macro")
|
|
|
560 ("defmethod" . "method")
|
|
|
561 ("defpackage" . "package")
|
|
|
562 ("defparameter" . "parameter")
|
|
|
563 ("defsetf" . "setfunction")
|
|
|
564 ("defstruct" . "structure")
|
|
|
565 ("deftype" . "type")
|
|
|
566 ("defvar" . "variable")
|
|
|
567 ("fset" . "function"))
|
|
|
568 "*Alist of (<element-definition-function-string> . <element-type-string>) elements.
|
|
|
569
|
|
|
570 Reread the definition of 'clos-def-form-regexp' if you change this variable,
|
|
|
571 as its value depends on this variable. You may also need to add to the
|
|
|
572 definition of 'clos-def-form-with-args-regexp'.")
|
|
|
573
|
|
|
574 (defconst clos-def-form-regexp
|
|
|
575 (mapconcat 'identity (mapcar 'car clos-element-type-alist) "\\|")
|
|
|
576 "*Regexp of Common Lisp/Clos form names that define new element types.
|
|
|
577 Defclass is omitted since the OO-Browser handles that separately.")
|
|
|
578
|
|
|
579 (defconst clos-def-form-with-args-regexp
|
|
|
580 "defun\\|defgeneric\\|defmacro\\|defmethod\\|defsetf\\|fset"
|
|
|
581 "*Regexp of Common Lisp/Clos defining forms whose signature includes arguments.")
|
|
|
582
|
|
|
583 (defconst clos-feature-def-regexp
|
|
|
584 (concat "(\\(" clos-def-form-regexp "\\)[ \t\n\r]+\\(\\('?"
|
|
|
585 clos-type-identifier ":\\)?"
|
|
|
586 "\\(" clos-element-identifier "\\)\\)"
|
|
|
587 clos-comment-regexp)
|
|
|
588 "Regexp matching a clos element definition.
|
|
|
589 Defining form, e.g. defun, is group 'clos-def-form-grpn'.
|
|
|
590 Class plus element name is group 'clos-feature-grpn'.
|
|
|
591 Class name is group 'clos-feature-type-grpn.
|
|
|
592 Element name, with optional qualifier but without class, is group
|
|
|
593 'clos-feature-name-grpn'.")
|
|
|
594
|
|
|
595 (defconst clos-def-form-grpn 1)
|
|
|
596 (defconst clos-feature-grpn 2)
|
|
|
597 (defconst clos-feature-type-grpn 3)
|
|
|
598 (defconst clos-feature-name-grpn 4)
|
|
|
599
|
|
|
600 (defconst clos-element-def (concat "^[ \t]*" clos-feature-def-regexp)
|
|
|
601 "Regexp matching a clos element definition.
|
|
|
602 See 'clos-feature-def-regexp' for grouping definitions.")
|
|
|
603
|
|
|
604 (defconst clos-arg-identifier (concat "[" clos-identifier-chars "]+")
|
|
|
605 "Regular expression matching a clos function argument identifier.")
|
|
|
606
|
|
|
607 (provide 'br-clos-ft)
|
