|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: br-smt.el
|
|
|
4 ;; SUMMARY: Support routines for Smalltalk inheritance browsing and error parsing.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: oop, tools
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
100
|
9 ;; ORG: InfoDock Associates
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 26-Jul-90
|
|
100
|
12 ;; LAST-MOD: 20-Feb-97 at 07:00:21 by Bob Weiner
|
|
0
|
13 ;;
|
|
100
|
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 ;;
|
|
100
|
21 ;; See `smt-class-def-regexp' for regular expression that matches class
|
|
0
|
22 ;; definitions.
|
|
|
23 ;;
|
|
|
24 ;; DESCRIP-END.
|
|
|
25
|
|
|
26 ;;; ************************************************************************
|
|
|
27 ;;; Other required Elisp libraries
|
|
|
28 ;;; ************************************************************************
|
|
|
29
|
|
|
30 (require 'br-lib)
|
|
|
31
|
|
|
32 ;;; ************************************************************************
|
|
|
33 ;;; User visible variables
|
|
|
34 ;;; ************************************************************************
|
|
|
35
|
|
|
36 (defvar smt-lib-search-dirs nil
|
|
|
37 "List of directories below which Smalltalk Library source files are found.
|
|
|
38 Subdirectories of Library source are also searched. A Library is a stable
|
|
|
39 group of classes.")
|
|
|
40
|
|
|
41 (defvar smt-sys-search-dirs nil
|
|
|
42 "List of directories below which Smalltalk System source files are found.
|
|
|
43 Subdirectories of System source are also searched. A System class is one
|
|
|
44 that is not yet reusable and is likely to change before release.")
|
|
|
45
|
|
|
46 (defconst smt-narrow-view-to-class nil
|
|
|
47 "*Non-nil means narrow buffer to just the matching class definition when displayed.")
|
|
|
48
|
|
|
49 ;;; ************************************************************************
|
|
|
50 ;;; Internal functions
|
|
|
51 ;;; ************************************************************************
|
|
|
52
|
|
|
53 (defun smt-get-classes-from-source (filename &rest ignore)
|
|
|
54 "Scans FILENAME and returns cons of class list with parents-class alist.
|
|
|
55 Handles multiple inheritance. Assumes file existence and readability have
|
|
|
56 already been checked."
|
|
|
57 (let ((no-kill (get-file-buffer filename))
|
|
|
58 classes class parents parent-cons)
|
|
|
59 (if no-kill
|
|
|
60 (set-buffer no-kill)
|
|
|
61 (funcall br-view-file-function filename))
|
|
|
62 (save-restriction
|
|
|
63 (save-excursion
|
|
|
64 (widen)
|
|
|
65 (goto-char (point-min))
|
|
|
66 (while (re-search-forward smt-class-def-regexp nil t)
|
|
|
67 (setq class (buffer-substring (match-beginning 3) (match-end 3))
|
|
|
68 parent-cons
|
|
|
69 (cons
|
|
|
70 (and (match-end 1) (> (match-end 1) 0)
|
|
|
71 (list (buffer-substring
|
|
|
72 (match-beginning 1)
|
|
|
73 (match-end 1))))
|
|
|
74 class))
|
|
|
75 ;; Assume class name not found within a comment.
|
|
|
76 (setq classes (cons class classes)
|
|
|
77 parents (cons parent-cons parents)))))
|
|
|
78 (or no-kill (kill-buffer (current-buffer)))
|
|
|
79 (cons classes (delq nil parents))))
|
|
|
80
|
|
|
81 (defun smt-get-parents-from-source (filename class-name)
|
|
|
82 "Scan source in FILENAME and return list of parents of CLASS-NAME.
|
|
|
83 Assume file existence has already been checked."
|
|
|
84 (or (null class-name)
|
|
|
85 (car (car (br-rassoc
|
|
|
86 class-name
|
|
|
87 (cdr (smt-get-classes-from-source filename)))))))
|
|
|
88
|
|
|
89 (defun smt-select-path (paths-htable-elt &optional feature-p)
|
|
|
90 "Select proper pathname from PATHS-HTABLE-ELT based upon value of optional FEATURE-P.
|
|
|
91 Selection is between path of class definition and path for features associated
|
|
|
92 with the class."
|
|
|
93 (cdr paths-htable-elt))
|
|
|
94
|
|
|
95 (defun smt-set-case (type)
|
|
|
96 "Return string TYPE identifier for use as a class name."
|
|
|
97 type)
|
|
|
98
|
|
|
99 (defun smt-set-case-type (class-name)
|
|
|
100 "Return string CLASS-NAME for use as a type identifier."
|
|
|
101 class-name)
|
|
|
102
|
|
|
103 (defun smt-to-class-end ()
|
|
|
104 "Assuming point is at start of class, move to best guess start of line after end of class."
|
|
|
105 (interactive)
|
|
|
106 (goto-char (point-max)))
|
|
|
107
|
|
|
108 (defun smt-to-comments-begin ()
|
|
|
109 "Skip back from current point past any preceding Smalltalk comments.
|
|
|
110 Presently a no-op."
|
|
|
111 )
|
|
|
112
|
|
|
113 ;;; ************************************************************************
|
|
|
114 ;;; Internal variables
|
|
|
115 ;;; ************************************************************************
|
|
|
116
|
|
|
117 (defconst smt-type-tag-separator "@"
|
|
|
118 "String that separates a tag's type from its normalized definition form.
|
|
|
119 This should be a single character which is unchanged when quoted for use as a
|
|
|
120 literal in a regular expression.")
|
|
|
121
|
|
|
122 (defconst smt-subclass-separator
|
|
|
123 "\\(variableSubclass:\\|variableWordSubclass:\\|variableByteSubclass:\\|subclass:\\)"
|
|
|
124 "Regexp matching delimiter following parent identifier.")
|
|
|
125
|
|
|
126 (defconst smt-identifier-chars "a-zA-Z0-9"
|
|
|
127 "String of chars and char ranges that may be used within a Smalltalk identifier.")
|
|
|
128
|
|
|
129 (defconst smt-identifier (concat "\\([a-zA-Z][" smt-identifier-chars "]*\\)")
|
|
|
130 "Regular expression matching a Smalltalk identifier.")
|
|
|
131
|
|
|
132
|
|
|
133 (defconst smt-class-name-before
|
|
|
134 (concat "^[ \t]*" smt-identifier
|
|
|
135 "[ \t\n]+" smt-subclass-separator
|
|
|
136 "[ \t\n]*#")
|
|
|
137 "Regexp preceding the class name in a class definition.")
|
|
|
138
|
|
|
139 (defconst smt-class-name-after
|
|
|
140 ""
|
|
|
141 "Regexp following the class name in a class definition.")
|
|
|
142
|
|
|
143 (defconst smt-class-def-regexp
|
|
|
144 (concat smt-class-name-before smt-identifier smt-class-name-after)
|
|
|
145 "Regular expression used to match to class definitions in source text.
|
|
100
|
146 Class name identifier is grouped expression 3. `subclass:' inheritance
|
|
0
|
147 indicator is grouped expression 2. Parent identifier is grouped
|
|
|
148 expression 1.")
|
|
|
149
|
|
|
150
|
|
|
151 (defconst smt-lang-prefix "smt-"
|
|
|
152 "Prefix string that starts \"br-smt.el\" symbol names.")
|
|
|
153
|
|
|
154 (defconst smt-src-file-regexp ".\\.st$"
|
|
|
155 "Regular expression matching a unique part of Smalltalk source file name and no others.")
|
|
|
156
|
|
|
157 (defvar smt-children-htable nil
|
|
|
158 "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
|
|
100
|
159 Used to traverse Smalltalk inheritance graph. `br-build-children-htable' builds
|
|
0
|
160 this list.")
|
|
|
161 (defvar smt-parents-htable nil
|
|
|
162 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
|
|
100
|
163 Used to traverse Smalltalk inheritance graph. `br-build-parents-htable' builds
|
|
0
|
164 this list.")
|
|
|
165 (defvar smt-paths-htable nil
|
|
|
166 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
|
|
|
167 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
|
|
100
|
168 `br-build-paths-htable' builds this list.")
|
|
0
|
169
|
|
|
170
|
|
|
171 (defvar smt-lib-parents-htable nil
|
|
|
172 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
|
|
|
173 Only classes from stable software libraries are used to build the list.")
|
|
|
174 (defvar smt-lib-paths-htable nil
|
|
|
175 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
|
|
|
176 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
|
|
|
177 Only classes from stable software libraries are used to build the list.")
|
|
|
178
|
|
|
179 (defvar smt-sys-parents-htable nil
|
|
|
180 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
|
|
|
181 Only classes from systems that are likely to change are used to build the list.")
|
|
|
182 (defvar smt-sys-paths-htable nil
|
|
|
183 "Alist whose elements are of the form: (LIST-OF-CLASS-NAMES . FILE-PATH).
|
|
|
184 FILE-PATH gives the location of classes found in LIST-OF-CLASS-NAMES.
|
|
|
185 Only classes from systems that are likely to change are used to build the
|
|
|
186 list.")
|
|
|
187
|
|
|
188 (defvar smt-lib-prev-search-dirs nil
|
|
100
|
189 "Used to check if `smt-lib-classes-htable' must be regenerated.")
|
|
0
|
190 (defvar smt-sys-prev-search-dirs nil
|
|
100
|
191 "Used to check if `smt-sys-classes-htable' must be regenerated.")
|
|
0
|
192
|
|
|
193 (defvar smt-env-spec nil
|
|
|
194 "Non-nil value means Environment specification has been given but not yet built.
|
|
|
195 Nil means current Environment has been built, though it may still require updating.")
|
|
|
196
|
|
|
197 (provide 'br-smt)
|
