Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-clos.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.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
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 29-Jul-90
12 ;; LAST-MOD: 21-Sep-95 at 12:29:40 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 ;;
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)