4 ;; SUMMARY: Support routines for CLOS inheritance browsing.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: lisp, oop, tools
11 ;; ORIG-DATE: 29-Jul-90
12 ;; LAST-MOD: 13-Jul-99 at 17:04:32 by Bob Weiner
14 ;; Copyright (C) 1990-1995, 1997 BeOpen.com
15 ;; See the file BR-COPY for license information.
17 ;; This file is part of the OO-Browser.
21 ;; Properly supports CLOS multiple inheritance.
23 ;; See 'clos-class-def-regexp' for regular expression that matches class
28 ;;; ************************************************************************
29 ;;; Other required Elisp libraries
30 ;;; ************************************************************************
34 ;;; ************************************************************************
35 ;;; User visible variables
36 ;;; ************************************************************************
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
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.")
48 (defconst clos-narrow-view-to-class nil
49 "*Non-nil means narrow buffer to just the matching class definition when displayed.")
51 ;;; ************************************************************************
52 ;;; Internal functions
53 ;;; ************************************************************************
55 (defun clos-get-classes-from-source (filename &optional skip-tags
57 "Scans FILENAME and returns cons of class list with parents-class alist.
58 Handles multiple inheritance. Assumes file existence and readability have
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)
68 (funcall br-view-file-function filename))
72 (goto-char (point-min))
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 (br-buffer-substring (match-beginning 1) (match-end 1))
80 (while (looking-at clos-parent-regexp)
82 (cons (br-buffer-substring
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
97 (setq classes (cons class classes)
98 parents (cons parent-cons parents)))))
101 (clos-output-feature-tags filename signatures)
102 (or skip-tags-cleanup (br-feature-build-htables)))
103 (or no-kill (kill-buffer (current-buffer)))
104 (cons classes (delq nil parents))))
106 (defun clos-get-parents-from-source (filename class-name)
107 "Scan source in FILENAME and return list of parents of CLASS-NAME.
108 Assume file existence has already been checked."
109 (cond ((null class-name) nil)
110 ((equal filename br-null-path)
111 ;; This means there is no source for this class, so
112 ;; since all classes have t as an ancestor and there is no where
113 ;; to look for parents, make t the sole parent.
115 (t (car (car (br-rassoc
117 (cdr (clos-get-classes-from-source filename t))))))))
119 (defun clos-select-path (paths-htable-elt &optional feature-p)
120 "Select proper pathname from PATHS-HTABLE-ELT based upon value of optional FEATURE-P.
121 Selection is between path of class definition and path for features associated
123 (let ((elt (cdr paths-htable-elt)))
125 (if feature-p (cdr elt) (car elt))
126 ;; Both paths are the same.
129 (defun clos-set-case (type)
130 "Return string TYPE identifier for use as a class name."
133 (defun clos-set-case-type (class-name)
134 "Return string CLASS-NAME for use as a type identifier."
137 (defun clos-to-class-end ()
138 "Assuming point is at start of class, move to start of line after end of class."
140 (goto-char (point-max))
143 (defun clos-to-comments-begin ()
144 "Skip back from current point past any preceding CLOS comments."
147 (progn (setq opoint (point))
149 (if (= 0 (forward-line -1))
151 ;; If begins with ";", then is a comment.
152 ((looking-at "[ \t]*\\(;\\|$\\)"))
155 ;; Skip past whitespace
156 (skip-chars-forward " \t\n\r\f")
157 (beginning-of-line)))
159 ;;; ************************************************************************
160 ;;; Internal variables
161 ;;; ************************************************************************
163 (defconst clos-class-keyword
165 "Keyword regexp preceding a clos class definition.")
167 (defconst clos-class-name-before
168 (concat "^[ \t]*" clos-class-keyword)
169 "Regexp preceding the class name in a class definition.")
171 (defconst clos-class-name-after
173 "Regexp following the class name in a class definition.")
176 (defconst clos-identifier-chars "a-zA-Z0-9+*/_~!@$%^&=:<>{}|.-"
177 "String of chars and char ranges that may be used within a CLOS identifier.")
179 (defconst clos-type-identifier-chars "\]\[a-zA-Z0-9+*/_~!@$%^&=<>{}|.-"
180 "String of chars and char ranges that may be used within a CLOS class name.
183 (defconst clos-identifier (concat "\\([" clos-identifier-chars "]+\\)")
184 "Regular expression matching a CLOS identifier.")
186 (defconst clos-class-def-regexp
187 (concat clos-class-name-before clos-identifier clos-class-name-after)
188 "Regular expression used to match to class definitions in source text.
189 Class name identifier is grouped expression 1. Parent class names
190 follow this expression, which terminates with the parenthesis that begins
191 the parent class group.")
193 (defconst clos-lang-prefix "clos-"
194 "Prefix string that starts \"br-clos.el\" symbol names.")
196 (defconst clos-parent-regexp
197 (concat "[ \t\n\r]*" clos-identifier)
198 "Parent identifier is grouped expression 1.")
200 (defconst clos-src-file-regexp ".\\.\\(lisp\\|lsp\\|cl\\|el\\)$"
201 "Regular expression matching a unique part of CLOS source file names and no others.")
203 (defvar clos-children-htable nil
204 "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
205 Used to traverse CLOS inheritance graph. 'br-build-children-htable' builds
207 (defvar clos-parents-htable nil
208 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
209 Used to traverse CLOS inheritance graph. 'br-build-parents-htable' builds
211 (defvar clos-paths-htable nil
212 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
213 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
214 'br-build-paths-htable' builds this list.")
217 (defvar clos-lib-parents-htable nil
218 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
219 Only classes from stable software libraries are used to build the list.")
220 (defvar clos-lib-paths-htable nil
221 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
222 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
223 Only classes from stable software libraries are used to build the list.")
225 (defvar clos-sys-parents-htable nil
226 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
227 Only classes from systems that are likely to change are used to build the list.")
228 (defvar clos-sys-paths-htable nil
229 "Alist whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
230 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
231 Only classes from systems that are likely to change are used to build the
234 (defvar clos-lib-prev-search-dirs nil
235 "Used to check if 'clos-lib-classes-htable' must be regenerated.")
236 (defvar clos-sys-prev-search-dirs nil
237 "Used to check if 'clos-sys-classes-htable' must be regenerated.")
239 (defvar clos-env-spec nil
240 "Non-nil value means Environment specification has been given but not yet built.
241 Nil means current Environment has been built, though it may still require updating.")