Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-clos-ft.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-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
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 03-Oct-90
12 ;; LAST-MOD: 6-Aug-95 at 01:52:28 by Bob Weiner
13 ;;
14 ;; Copyright (C) 1990-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 (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
40 (defconst clos-feature-tag-regexp
41 (concat "\\(" clos-type-identifier "\\)"
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)
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))))
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."
259 (if (string-match clos-feature-tag-regexp signature)
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
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))
294 (while (re-search-forward regexp nil t)
295 (backward-char) ;; Might have moved past newline.
296 (setq features (cons (br-feature-current) features)))
297 features)))
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)