Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-smt.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-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
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 26-Jul-90
12 ;; LAST-MOD: 21-Sep-95 at 12:31:20 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 ;; See 'smt-class-def-regexp' for regular expression that matches class
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.
146 Class name identifier is grouped expression 3. 'subclass:' inheritance
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).
159 Used to traverse Smalltalk inheritance graph. 'br-build-children-htable' builds
160 this list.")
161 (defvar smt-parents-htable nil
162 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
163 Used to traverse Smalltalk inheritance graph. 'br-build-parents-htable' builds
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.
168 'br-build-paths-htable' builds this list.")
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
189 "Used to check if 'smt-lib-classes-htable' must be regenerated.")
190 (defvar smt-sys-prev-search-dirs nil
191 "Used to check if 'smt-sys-classes-htable' must be regenerated.")
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)