|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: br-clos.el
|
|
|
4 ;; SUMMARY: Support routines for CLOS inheritance browsing.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: lisp, oop, tools
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
24
|
9 ;; ORG: InfoDock Associates
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 29-Jul-90
|
|
24
|
12 ;; LAST-MOD: 21-Feb-97 at 17:22:13 by Bob Weiner
|
|
0
|
13 ;;
|
|
24
|
14 ;; Copyright (C) 1990-1995, 1997 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 ;;
|
|
|
21 ;; Properly supports CLOS multiple inheritance.
|
|
|
22 ;;
|
|
|
23 ;; See 'clos-class-def-regexp' for regular expression that matches class
|
|
|
24 ;; definitions.
|
|
|
25 ;;
|
|
|
26 ;; DESCRIP-END.
|
|
|
27
|
|
|
28 ;;; ************************************************************************
|
|
|
29 ;;; Other required Elisp libraries
|
|
|
30 ;;; ************************************************************************
|
|
|
31
|
|
|
32 (require 'br-lib)
|
|
|
33
|
|
|
34 ;;; ************************************************************************
|
|
|
35 ;;; User visible variables
|
|
|
36 ;;; ************************************************************************
|
|
|
37
|
|
|
38 (defvar clos-lib-search-dirs nil
|
|
|
39 "List of directories below which CLOS Library source files are found.
|
|
|
40 Subdirectories of Library source are also searched. A Library is a stable
|
|
|
41 group of classes.")
|
|
|
42
|
|
|
43 (defvar clos-sys-search-dirs nil
|
|
|
44 "List of directories below which CLOS System source files are found.
|
|
|
45 Subdirectories of System source are also searched. A System class is one
|
|
|
46 that is not yet reusable and is likely to change before release.")
|
|
|
47
|
|
|
48 (defconst clos-narrow-view-to-class nil
|
|
|
49 "*Non-nil means narrow buffer to just the matching class definition when displayed.")
|
|
|
50
|
|
|
51 ;;; ************************************************************************
|
|
|
52 ;;; Internal functions
|
|
|
53 ;;; ************************************************************************
|
|
|
54
|
|
|
55 (defun clos-get-classes-from-source (filename &optional skip-tags
|
|
|
56 skip-tags-cleanup)
|
|
|
57 "Scans FILENAME and returns cons of class list with parents-class alist.
|
|
|
58 Handles multiple inheritance. Assumes file existence and readability have
|
|
|
59 already been checked.
|
|
|
60 With optional SKIP-TAGS non-nil, does not compute and store lookup tags
|
|
|
61 for element definitions. If SKIP-TAGS is nil, normally a cleanup
|
|
|
62 function is called after scanning the elements. SKIP-TAGS-CLEANUP
|
|
|
63 non-nil suppresses this action."
|
|
|
64 (let ((no-kill (get-file-buffer filename))
|
|
|
65 classes class parents parent-cons parent-list signatures)
|
|
|
66 (if no-kill
|
|
|
67 (set-buffer no-kill)
|
|
|
68 (funcall br-view-file-function filename))
|
|
|
69 (save-excursion
|
|
|
70 (save-restriction
|
|
|
71 (widen)
|
|
|
72 (goto-char (point-min))
|
|
|
73 (if skip-tags
|
|
|
74 nil
|
|
|
75 (setq signatures (clos-scan-features))
|
|
|
76 (goto-char (point-min)))
|
|
|
77 (while (re-search-forward clos-class-def-regexp nil t)
|
|
|
78 (setq class (buffer-substring (match-beginning 1) (match-end 1))
|
|
|
79 parent-list nil)
|
|
|
80 (while (looking-at clos-parent-regexp)
|
|
|
81 (setq parent-list
|
|
|
82 (cons (buffer-substring
|
|
|
83 (match-beginning 1)
|
|
|
84 (match-end 1))
|
|
|
85 parent-list))
|
|
|
86 (goto-char (match-end 0)))
|
|
|
87 (setq parent-list (nreverse parent-list))
|
|
|
88 (if (and (null parent-list)
|
|
|
89 (not (equal class "t")))
|
|
|
90 ;; All classes have t as an ancestor, so if
|
|
|
91 ;; no parents are listed, make t the sole parent.
|
|
|
92 (setq parent-list '("t")))
|
|
|
93 (setq parent-cons (cons parent-list class))
|
|
|
94 ;; Don't have to check whether class-def pattern begins
|
|
|
95 ;; after a comment since the regexp used for matching
|
|
|
96 ;; precludes this.
|
|
|
97 (setq classes (cons class classes)
|
|
|
98 parents (cons parent-cons parents)))))
|
|
|
99 (if skip-tags
|
|
|
100 nil
|
|
|
101 (clos-get-feature-tags
|
|
|
102 buffer-file-name (clos-sort-features signatures))
|
|
|
103 (or skip-tags-cleanup (br-feature-tags-save)))
|
|
|
104 (or no-kill (kill-buffer (current-buffer)))
|
|
|
105 (cons classes (delq nil parents))))
|
|
|
106
|
|
|
107 (defun clos-get-parents-from-source (filename class-name)
|
|
|
108 "Scan source in FILENAME and return list of parents of CLASS-NAME.
|
|
|
109 Assume file existence has already been checked."
|
|
|
110 (cond ((null class-name) nil)
|
|
|
111 ((equal filename br-null-path)
|
|
|
112 ;; This means there is no source for this class, so
|
|
|
113 ;; since all classes have t as an ancestor and there is no where
|
|
|
114 ;; to look for parents, make t the sole parent.
|
|
|
115 '("t"))
|
|
|
116 (t (car (car (br-rassoc
|
|
|
117 class-name
|
|
|
118 (cdr (clos-get-classes-from-source filename t))))))))
|
|
|
119
|
|
|
120 (defun clos-select-path (paths-htable-elt &optional feature-p)
|
|
|
121 "Select proper pathname from PATHS-HTABLE-ELT based upon value of optional FEATURE-P.
|
|
|
122 Selection is between path of class definition and path for features associated
|
|
|
123 with the class."
|
|
|
124 (let ((elt (cdr paths-htable-elt)))
|
|
|
125 (if (consp elt)
|
|
|
126 (if feature-p (cdr elt) (car elt))
|
|
|
127 ;; Both paths are the same.
|
|
|
128 elt)))
|
|
|
129
|
|
|
130 (defun clos-set-case (type)
|
|
|
131 "Return string TYPE identifier for use as a class name."
|
|
|
132 type)
|
|
|
133
|
|
|
134 (defun clos-set-case-type (class-name)
|
|
|
135 "Return string CLASS-NAME for use as a type identifier."
|
|
|
136 class-name)
|
|
|
137
|
|
|
138 (defun clos-to-class-end ()
|
|
|
139 "Assuming point is at start of class, move to start of line after end of class."
|
|
|
140 (interactive)
|
|
|
141 (goto-char (point-max))
|
|
|
142 )
|
|
|
143
|
|
|
144 (defun clos-to-comments-begin ()
|
|
|
145 "Skip back from current point past any preceding CLOS comments."
|
|
|
146 (let ((opoint))
|
|
|
147 (while
|
|
|
148 (progn (setq opoint (point))
|
|
|
149 ;; To previous line
|
|
|
150 (if (= 0 (forward-line -1))
|
|
|
151 (cond
|
|
|
152 ;; If begins with ";", then is a comment.
|
|
|
153 ((looking-at "[ \t]*\\(;\\|$\\)"))
|
|
|
154 (nil)))))
|
|
|
155 (goto-char opoint)
|
|
|
156 ;; Skip past whitespace
|
|
|
157 (skip-chars-forward " \t\n")
|
|
|
158 (beginning-of-line)))
|
|
|
159
|
|
|
160 ;;; ************************************************************************
|
|
|
161 ;;; Internal variables
|
|
|
162 ;;; ************************************************************************
|
|
|
163
|
|
|
164 (defconst clos-class-keyword
|
|
|
165 "(defclass[ \t]+"
|
|
|
166 "Keyword regexp preceding a clos class definition.")
|
|
|
167
|
|
|
168 (defconst clos-class-name-before
|
|
|
169 (concat "^[ \t]*" clos-class-keyword)
|
|
|
170 "Regexp preceding the class name in a class definition.")
|
|
|
171
|
|
|
172 (defconst clos-class-name-after
|
|
|
173 "[ \t\n]*\("
|
|
|
174 "Regexp following the class name in a class definition.")
|
|
|
175
|
|
|
176
|
|
|
177 (defconst clos-identifier-chars "a-zA-Z0-9+*/_~!@$%^&=:<>{}|.-"
|
|
|
178 "String of chars and char ranges that may be used within a CLOS identifier.")
|
|
|
179
|
|
|
180 (defconst clos-type-identifier-chars "][a-zA-Z0-9+*/_~!@$%^&=<>{}|.-"
|
|
|
181 "String of chars and char ranges that may be used within a CLOS class name.
|
|
|
182 No colons allowed.")
|
|
|
183
|
|
|
184 (defconst clos-identifier (concat "\\([" clos-identifier-chars "]+\\)")
|
|
|
185 "Regular expression matching a CLOS identifier.")
|
|
|
186
|
|
|
187 (defconst clos-class-def-regexp
|
|
|
188 (concat clos-class-name-before clos-identifier clos-class-name-after)
|
|
|
189 "Regular expression used to match to class definitions in source text.
|
|
|
190 Class name identifier is grouped expression 1. Parent class names
|
|
|
191 follow this expression, which terminates with the parenthesis that begins
|
|
|
192 the parent class group.")
|
|
|
193
|
|
|
194 (defconst clos-lang-prefix "clos-"
|
|
|
195 "Prefix string that starts \"br-clos.el\" symbol names.")
|
|
|
196
|
|
|
197 (defconst clos-parent-regexp
|
|
|
198 (concat "[ \t\n]*" clos-identifier)
|
|
|
199 "Parent identifier is grouped expression 1.")
|
|
|
200
|
|
|
201 (defconst clos-src-file-regexp ".\\.\\(lisp\\|lsp\\|cl\\|el\\)$"
|
|
|
202 "Regular expression matching a unique part of CLOS source file names and no others.")
|
|
|
203
|
|
|
204 (defvar clos-children-htable nil
|
|
|
205 "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
|
|
|
206 Used to traverse CLOS inheritance graph. 'br-build-children-htable' builds
|
|
|
207 this list.")
|
|
|
208 (defvar clos-parents-htable nil
|
|
|
209 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
|
|
|
210 Used to traverse CLOS inheritance graph. 'br-build-parents-htable' builds
|
|
|
211 this list.")
|
|
|
212 (defvar clos-paths-htable nil
|
|
|
213 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
|
|
|
214 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
|
|
|
215 'br-build-paths-htable' builds this list.")
|
|
|
216
|
|
|
217
|
|
|
218 (defvar clos-lib-parents-htable nil
|
|
|
219 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
|
|
|
220 Only classes from stable software libraries are used to build the list.")
|
|
|
221 (defvar clos-lib-paths-htable nil
|
|
|
222 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
|
|
|
223 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
|
|
|
224 Only classes from stable software libraries are used to build the list.")
|
|
|
225
|
|
|
226 (defvar clos-sys-parents-htable nil
|
|
|
227 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
|
|
|
228 Only classes from systems that are likely to change are used to build the list.")
|
|
|
229 (defvar clos-sys-paths-htable nil
|
|
|
230 "Alist whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
|
|
|
231 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
|
|
|
232 Only classes from systems that are likely to change are used to build the
|
|
|
233 list.")
|
|
|
234
|
|
|
235 (defvar clos-lib-prev-search-dirs nil
|
|
|
236 "Used to check if 'clos-lib-classes-htable' must be regenerated.")
|
|
|
237 (defvar clos-sys-prev-search-dirs nil
|
|
|
238 "Used to check if 'clos-sys-classes-htable' must be regenerated.")
|
|
|
239
|
|
|
240 (defvar clos-env-spec nil
|
|
|
241 "Non-nil value means Environment specification has been given but not yet built.
|
|
|
242 Nil means current Environment has been built, though it may still require updating.")
|
|
|
243
|
|
|
244 (provide 'br-clos)
|
