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