/[cmucl]/src/hemlock/vars.lisp
ViewVC logotype

Contents of /src/hemlock/vars.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Tue Mar 13 15:50:01 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.3: +2 -2 lines
Change toplevel PROCLAIMs to DECLAIMs.
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/vars.lisp,v 1.4 2001/03/13 15:50:01 pw Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Rob MacLachlan
13 ;;;
14 ;;; The file contains the routines which define Hemlock variables.
15 ;;;
16
17 (in-package "HEMLOCK-INTERNALS")
18
19 (export '(variable-value variable-hooks variable-documentation variable-name
20 hemlock-bound-p defhvar delete-variable))
21
22 (defstruct (binding
23 (:type vector)
24 (:copier nil)
25 (:constructor make-binding (cons object across symbol)))
26 cons ; The cons which holds the value for the property.
27 object ; The variable-object for the binding.
28 across ; The next binding in this place.
29 symbol) ; The symbol name for the variable bound.
30
31
32
33 ;;; UNDEFINED-VARIABLE-ERROR -- Internal
34 ;;;
35 ;;; Complain about an undefined Hemlock variable in a helpful fashion.
36 ;;;
37 (defun undefined-variable-error (name)
38 (if (eq (symbol-package name) (find-package "HEMLOCK"))
39 (error "Undefined Hemlock variable ~A." name)
40 (error "Hemlock variables must be in the \"HEMLOCK\" package, but~%~
41 ~S is in the ~S package."
42 name (package-name (symbol-package name)))))
43
44 ;;; GET-MODE-OBJECT -- Internal
45 ;;;
46 ;;; Get the mode-object corresponding to name or die trying.
47 ;;;
48 (defun get-mode-object (name)
49 (unless (stringp name) (error "Mode name ~S is not a string." name))
50 (let ((res (getstring name *mode-names*)))
51 (unless res (error "~S is not a defined mode." name))
52 res))
53
54 ;;; FIND-BINDING -- Internal
55 ;;;
56 ;;; Return the Binding object corresponding to Name in the collection
57 ;;; of binding Binding, or NIL if none.
58 ;;;
59 (defun find-binding (name binding)
60 (do ((b binding (binding-across b)))
61 ((null b) nil)
62 (when (eq (binding-symbol b) name) (return b))))
63
64 ;;; GET-VARIABLE-OBJECT -- Internal
65 ;;;
66 ;;; Get the variable-object with the specified symbol-name, kind and where,
67 ;;; or die trying.
68 ;;;
69 (defun get-variable-object (name kind where)
70 (case kind
71 (:current
72 (let ((obj (get name 'hemlock-variable-value)))
73 (if obj obj (undefined-variable-error name))))
74 (:buffer
75 (check-type where buffer)
76 (let ((binding (find-binding name (buffer-var-values where))))
77 (unless binding
78 (error "~S is not a defined Hemlock variable in buffer ~S." name where))
79 (binding-object binding)))
80 (:global
81 (do ((obj (get name 'hemlock-variable-value)
82 (variable-object-down obj))
83 (prev nil obj))
84 ((symbolp obj)
85 (unless prev (undefined-variable-error name))
86 (unless (eq obj :global)
87 (error "Hemlock variable ~S is not globally defined." name))
88 prev)))
89 (:mode
90 (let ((binding (find-binding name (mode-object-var-values
91 (get-mode-object where)))))
92 (unless binding
93 (error "~S is not a defined Hemlock variable in mode ~S." name where))
94 (binding-object binding)))
95 (t
96 (error "~S is not a defined value for Kind." kind))))
97
98 ;;; VARIABLE-VALUE -- Public
99 ;;;
100 ;;; Get the value of the Hemlock variable "name".
101 ;;;
102 (defun variable-value (name &optional (kind :current) where)
103 "Return the value of the Hemlock variable given."
104 (variable-object-value (get-variable-object name kind where)))
105
106 ;;; %VALUE -- Internal
107 ;;;
108 ;;; This function is called by the expansion of Value.
109 ;;;
110 (defun %value (name)
111 (let ((obj (get name 'hemlock-variable-value)))
112 (unless obj (undefined-variable-error name))
113 (variable-object-value obj)))
114
115 ;;; %SET-VALUE -- Internal
116 ;;;
117 ;;; The setf-inverse of Value, set the current value.
118 ;;;
119 (defun %set-value (var new-value)
120 (let ((obj (get var 'hemlock-variable-value)))
121 (unless obj (undefined-variable-error var))
122 (invoke-hook (variable-object-hooks obj) var :current nil new-value)
123 (setf (variable-object-value obj) new-value)))
124
125 ;;; %SET-VARIABLE-VALUE -- Internal
126 ;;;
127 ;;; Set the Hemlock variable with the symbol name "name".
128 ;;;
129 (defun %set-variable-value (name kind where new-value)
130 (let ((obj (get-variable-object name kind where)))
131 (invoke-hook (variable-object-hooks obj) name kind where new-value)
132 (setf (variable-object-value obj) new-value)))
133
134 ;;; VARIABLE-HOOKS -- Public
135 ;;;
136 ;;; Return the list of hooks for "name".
137 ;;;
138 (defun variable-hooks (name &optional (kind :current) where)
139 "Return the list of hook functions for the Hemlock variable given."
140 (variable-object-hooks (get-variable-object name kind where)))
141
142 ;;; %SET-VARIABLE-HOOKS -- Internal
143 ;;;
144 ;;; Set the hook-list for Hemlock variable Name.
145 ;;;
146 (defun %set-variable-hooks (name kind where new-value)
147 (setf (variable-object-hooks (get-variable-object name kind where)) new-value))
148
149 ;;; VARIABLE-DOCUMENTATION -- Public
150 ;;;
151 ;;; Return the documentation for "name".
152 ;;;
153 (defun variable-documentation (name &optional (kind :current) where)
154 "Return the documentation for the Hemlock variable given."
155 (variable-object-documentation (get-variable-object name kind where)))
156
157 ;;; %SET-VARIABLE-DOCUMENTATION -- Internal
158 ;;;
159 ;;; Set a variables documentation.
160 ;;;
161 (defun %set-variable-documentation (name kind where new-value)
162 (setf (variable-object-documentation (get-variable-object name kind where))
163 new-value))
164
165 ;;; VARIABLE-NAME -- Public
166 ;;;
167 ;;; Return the String Name for a Hemlock variable.
168 ;;;
169 (defun variable-name (name &optional (kind :current) where)
170 "Return the string name of a Hemlock variable."
171 (variable-object-name (get-variable-object name kind where)))
172
173 ;;; HEMLOCK-BOUND-P -- Public
174 ;;;
175 (defun hemlock-bound-p (name &optional (kind :current) where)
176 "Returns T Name is a Hemlock variable defined in the specifed place, or
177 NIL otherwise."
178 (case kind
179 (:current (not (null (get name 'hemlock-variable-value))))
180 (:buffer
181 (check-type where buffer)
182 (not (null (find-binding name (buffer-var-values where)))))
183 (:global
184 (do ((obj (get name 'hemlock-variable-value)
185 (variable-object-down obj)))
186 ((symbolp obj) (eq obj :global))))
187 (:mode
188 (not (null (find-binding name (mode-object-var-values
189 (get-mode-object where))))))))
190
191 (defun string-to-variable (string)
192 "Returns the symbol name of a Hemlock variable from the corresponding string
193 name."
194 (intern (nsubstitute #\- #\space (the simple-string (string-upcase string)))
195 (find-package "HEMLOCK")))
196
197 (declaim (special *global-variable-names*))
198
199 ;;; DEFHVAR -- Public
200 ;;;
201 ;;; Define a Hemlock variable somewhere.
202 ;;;
203 (defun defhvar (name documentation &key mode buffer (hooks nil hook-p)
204 (value nil value-p))
205 (let* ((symbol-name (string-to-variable name))
206 (new-binding (make-variable-object documentation name))
207 (plist (symbol-plist symbol-name))
208 (prop (cdr (or (memq 'hemlock-variable-value plist)
209 (setf (symbol-plist symbol-name)
210 (list* 'hemlock-variable-value nil plist)))))
211 (kind :global) where string-table)
212 (cond
213 (mode
214 (setq kind :mode where mode)
215 (let* ((obj (get-mode-object where))
216 (vars (mode-object-var-values obj)))
217 (setq string-table (mode-object-variables obj))
218 (unless (find-binding symbol-name vars)
219 (let ((binding (make-binding prop new-binding vars symbol-name)))
220 (cond ((memq obj (buffer-mode-objects *current-buffer*))
221 (let ((l (unwind-bindings obj)))
222 (setf (mode-object-var-values obj) binding)
223 (wind-bindings l)))
224 (t
225 (setf (mode-object-var-values obj) binding)))))))
226 (buffer
227 (check-type buffer buffer)
228 (setq kind :buffer where buffer string-table (buffer-variables buffer))
229 (let ((vars (buffer-var-values buffer)))
230 (unless (find-binding symbol-name vars)
231 (let ((binding (make-binding prop new-binding vars symbol-name)))
232 (setf (buffer-var-values buffer) binding)
233 (when (eq buffer *current-buffer*)
234 (setf (variable-object-down new-binding) (car prop)
235 (car prop) new-binding))))))
236 (t
237 (setq string-table *global-variable-names*)
238 (unless (hemlock-bound-p symbol-name :global)
239 (setf (variable-object-down new-binding) :global)
240 (let ((l (unwind-bindings nil)))
241 (setf (car prop) new-binding)
242 (wind-bindings l)))))
243 (setf (getstring name string-table) symbol-name)
244 (when hook-p
245 (setf (variable-hooks symbol-name kind where) hooks))
246 (when value-p
247 (setf (variable-value symbol-name kind where) value)))
248 name)
249
250 ;;; DELETE-BINDING -- Internal
251 ;;;
252 ;;; Delete a binding from a list of bindings.
253 ;;;
254 (defun delete-binding (binding bindings)
255 (do ((b bindings (binding-across b))
256 (prev nil b))
257 ((eq b binding)
258 (cond (prev
259 (setf (binding-across prev) (binding-across b))
260 bindings)
261 (t
262 (binding-across bindings))))))
263
264 ;;; DELETE-VARIABLE -- Public
265 ;;;
266 ;;; Make a Hemlock variable no longer bound, fixing up the saved
267 ;;;binding values as necessary.
268 ;;;
269 (defun delete-variable (name &optional (kind :global) where)
270 "Delete a Hemlock variable somewhere."
271 (let* ((obj (get-variable-object name kind where))
272 (sname (variable-object-name obj)))
273 (case kind
274 (:buffer
275 (let* ((values (buffer-var-values where))
276 (binding (find-binding name values)))
277 (invoke-hook ed::delete-variable-hook name :buffer where)
278 (delete-string sname (buffer-variables where))
279 (setf (buffer-var-values where) (delete-binding binding values))
280 (when (eq where *current-buffer*)
281 (setf (car (binding-cons binding)) (variable-object-down obj)))))
282 (:mode
283 (let* ((mode (get-mode-object where))
284 (values (mode-object-var-values mode))
285 (binding (find-binding name values)))
286 (invoke-hook ed::delete-variable-hook name :mode where)
287 (delete-string sname (mode-object-variables mode))
288 (if (memq mode (buffer-mode-objects *current-buffer*))
289 (let ((l (unwind-bindings mode)))
290 (setf (mode-object-var-values mode)
291 (delete-binding binding values))
292 (wind-bindings l))
293 (setf (mode-object-var-values mode)
294 (delete-binding binding values)))))
295 (:global
296 (invoke-hook ed::delete-variable-hook name :global nil)
297 (delete-string sname *global-variable-names*)
298 (let ((l (unwind-bindings nil)))
299 (setf (get name 'hemlock-variable-value) nil)
300 (wind-bindings l)))
301 (t (error "Invalid variable kind: ~S" kind)))
302 nil))

  ViewVC Help
Powered by ViewVC 1.1.5