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