source: branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp @ 7833

Last change on this file since 7833 was 7833, checked in by gz, 13 years ago

checkpoint work in progress

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.2 KB
Line 
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#+CMU (ext:file-comment
8  "$Header$")
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(defstruct (binding
20            (:type vector)
21            (:copier nil)
22            (:constructor make-binding (cons object across symbol)))
23  cons          ; The cons which holds the value for the property.
24  object        ; The variable-object for the binding.
25  across        ; The next binding in this place.
26  symbol)       ; The symbol name for the variable bound.
27
28
29
30;;; UNDEFINED-VARIABLE-ERROR  --  Internal
31;;;
32;;;    Complain about an undefined Hemlock variable in a helpful fashion.
33;;;
34(defun undefined-variable-error (name)
35  (if (eq (symbol-package name) (find-package :hemlock))
36      (error "Undefined Hemlock variable ~A." name)
37      (error "Hemlock variables must be in the \"HEMLOCK\" package, but~%~
38             ~S is in the ~S package."
39             name (package-name (symbol-package name)))))
40
41;;; GET-MODE-OBJECT  --  Internal
42;;;
43;;;    Get the mode-object corresponding to name or die trying.
44;;;
45(defun get-mode-object (name)
46  (unless (stringp name) (error "Mode name ~S is not a string." name))
47  (let ((res (getstring name *mode-names*)))
48    (unless res (error "~S is not a defined mode." name))
49    res))
50
51;;; FIND-BINDING  --  Internal
52;;;
53;;;    Return the Binding object corresponding to Name in the collection
54;;; of binding Binding, or NIL if none.
55;;;
56(defun find-binding (name binding)
57  (do ((b binding (binding-across b)))
58      ((null b) nil)
59    (when (eq (binding-symbol b) name) (return b))))
60
61;;; GET-VARIABLE-OBJECT  --  Internal
62;;;
63;;;    Get the variable-object with the specified symbol-name, kind and where,
64;;; or die trying.
65;;;
66(defun get-variable-object (name kind where)
67  (case kind
68    (:current
69     (let ((obj (get name 'hemlock-variable-value)))
70       (if obj obj (undefined-variable-error name))))
71    (:buffer
72     (check-type where buffer)
73     (let ((binding (find-binding name (buffer-var-values where))))
74       (unless binding
75         (error "~S is not a defined Hemlock variable in buffer ~S." name where))
76       (binding-object binding)))
77    (:global
78     (do ((obj (get name 'hemlock-variable-value)
79               (variable-object-down obj))
80          (prev nil obj))
81         ((symbolp obj)
82          (unless prev (undefined-variable-error name))
83          (unless (eq obj :global)
84            (error "Hemlock variable ~S is not globally defined." name))
85          prev)))
86    (:mode
87     (let ((binding (find-binding name (mode-object-var-values
88                                        (get-mode-object where)))))
89       (unless binding
90         (error "~S is not a defined Hemlock variable in mode ~S." name where))
91       (binding-object binding)))
92    (t
93     (error "~S is not a defined value for Kind." kind))))
94
95;;; VARIABLE-VALUE  --  Public
96;;;
97;;;    Get the value of the Hemlock variable "name".
98;;;
99(defun variable-value (name &optional (kind :current) where)
100  "Return the value of the Hemlock variable given."
101  (variable-object-value (get-variable-object name kind where)))
102
103;;; %VALUE  --  Internal
104;;;
105;;;    This function is called by the expansion of Value.
106;;;
107(defun %value (name)
108  (let ((obj (get name 'hemlock-variable-value)))
109    (unless obj (undefined-variable-error name))
110    (variable-object-value obj)))
111
112;;; %SET-VALUE  --  Internal
113;;;
114;;;    The setf-inverse of Value, set the current value.
115;;;
116(defun %set-value (var new-value)
117  (let ((obj (get var 'hemlock-variable-value)))
118    (unless obj (undefined-variable-error var))
119    (invoke-hook (variable-object-hooks obj) var :current nil new-value)
120    (setf (variable-object-value obj) new-value)))
121
122;;; %SET-VARIABLE-VALUE  --  Internal
123;;;
124;;;   Set the Hemlock variable with the symbol name "name".
125;;;
126(defun %set-variable-value (name kind where new-value)
127  (let ((obj (get-variable-object name kind where)))
128    (invoke-hook (variable-object-hooks obj) name kind where new-value)
129    (setf (variable-object-value obj) new-value)))
130
131;;; VARIABLE-HOOKS  --  Public
132;;;
133;;;    Return the list of hooks for "name".
134;;;
135(defun variable-hooks (name &optional (kind :current) where)
136  "Return the list of hook functions for the Hemlock variable given."
137  (variable-object-hooks (get-variable-object name kind where)))
138
139;;; %SET-VARIABLE-HOOKS --  Internal
140;;;
141;;;    Set the hook-list for Hemlock variable Name.
142;;;
143(defun %set-variable-hooks (name kind where new-value)
144  (setf (variable-object-hooks (get-variable-object name kind where)) new-value))
145
146;;; VARIABLE-DOCUMENTATION  --  Public
147;;;
148;;;    Return the documentation for "name".
149;;;
150(defun variable-documentation (name &optional (kind :current) where)
151  "Return the documentation for the Hemlock variable given."
152  (variable-object-documentation (get-variable-object name kind where)))
153
154;;; %SET-VARIABLE-DOCUMENTATION  --  Internal
155;;;
156;;;    Set a variables documentation.
157;;;
158(defun %set-variable-documentation (name kind where new-value)
159  (setf (variable-object-documentation (get-variable-object name kind where))
160        new-value))
161
162;;; VARIABLE-NAME  --  Public
163;;;
164;;;    Return the String Name for a Hemlock variable.
165;;;
166(defun variable-name (name &optional (kind :current) where)
167   "Return the string name of a Hemlock variable."
168  (variable-object-name (get-variable-object name kind where)))
169
170;;; HEMLOCK-BOUND-P  --  Public
171;;;
172(defun hemlock-bound-p (name &optional (kind :current) where)
173  "Returns T Name is a Hemlock variable defined in the specifed place, or
174  NIL otherwise."
175  (case kind
176    (:current (not (null (get name 'hemlock-variable-value))))
177    (:buffer
178     (check-type where buffer)
179     (not (null (find-binding name (buffer-var-values where)))))
180    (:global
181     (do ((obj (get name 'hemlock-variable-value)
182               (variable-object-down obj)))
183         ((symbolp obj) (eq obj :global))))
184    (:mode
185     (not (null (find-binding name (mode-object-var-values
186                                    (get-mode-object where))))))))
187
188(declaim (special *global-variable-names*))
189
190;;; DEFHVAR  --  Public
191;;;
192;;;    Define a Hemlock variable somewhere.
193;;;
194(defun defhvar (name documentation &key mode buffer (hooks nil hook-p)
195                     (value nil value-p))
196  (let* ((symbol-name (string-to-variable name))
197         (new-binding (make-variable-object documentation name))
198         (plist (symbol-plist symbol-name))
199         (prop (cdr (or (member 'hemlock-variable-value plist)
200                        (setf (symbol-plist symbol-name)
201                              (list* 'hemlock-variable-value nil plist)))))
202         (kind :global) where string-table)
203    (cond
204      (mode
205       (setq kind :mode  where mode)
206       (let* ((obj (get-mode-object where))
207              (vars (mode-object-var-values obj)))
208         (setq string-table (mode-object-variables obj))
209         (unless (find-binding symbol-name vars)
210           (let ((binding (make-binding prop new-binding vars symbol-name)))
211             (cond ((member obj (buffer-mode-objects *current-buffer*))
212                    (let ((l (unwind-bindings *current-buffer* obj)))
213                      (setf (mode-object-var-values obj) binding)
214                      (wind-bindings *current-buffer* l)))
215                   (t
216                    (setf (mode-object-var-values obj) binding)))))))
217      (buffer
218       (check-type buffer buffer)
219       (setq kind :buffer  where buffer  string-table (buffer-variables buffer))
220       (let ((vars (buffer-var-values buffer)))
221         (unless (find-binding symbol-name vars)
222           (let ((binding (make-binding prop new-binding vars symbol-name)))
223             (setf (buffer-var-values buffer) binding)
224             (when (buffer-bindings-wound-p buffer)
225               (setf (variable-object-down new-binding) (car prop)
226                     (car prop) new-binding))))))
227      (t
228       (setq string-table *global-variable-names*)
229       (unless (hemlock-bound-p symbol-name :global)
230         (setf (variable-object-down new-binding) :global)
231         (when *current-buffer*
232           (let ((l (unwind-bindings *current-buffer* nil)))
233             (setf (car prop) new-binding)
234             (wind-bindings *current-buffer* l))))))
235    (setf (getstring name string-table) symbol-name)
236    (when hook-p
237      (setf (variable-hooks symbol-name kind where) hooks))
238    (when value-p
239      (setf (variable-value symbol-name kind where) value)))
240  name)
241
242;;; DELETE-BINDING  --  Internal
243;;;
244;;;    Delete a binding from a list of bindings.
245;;;
246(defun delete-binding (binding bindings)
247  (do ((b bindings (binding-across b))
248       (prev nil b))
249      ((eq b binding)
250       (cond (prev
251              (setf (binding-across prev) (binding-across b))
252              bindings)
253             (t
254              (binding-across bindings))))))
255
256;;; DELETE-VARIABLE  --  Public
257;;;
258;;; Make a Hemlock variable no longer bound, fixing up the saved
259;;;binding values as necessary.
260;;;
261(defun delete-variable (name &optional (kind :global) where)
262  "Delete a Hemlock variable somewhere."
263  (let* ((obj (get-variable-object name kind where))
264         (sname (variable-object-name obj)))
265    (case kind
266      (:buffer
267       (let* ((values (buffer-var-values where))
268              (binding (find-binding name values)))
269         (invoke-hook hemlock::delete-variable-hook name :buffer where)
270         (delete-string sname (buffer-variables where))
271         (setf (buffer-var-values where) (delete-binding binding values))
272         (when (buffer-bindings-wound-p where)
273           (setf (car (binding-cons binding)) (variable-object-down obj)))))
274      (:mode
275       (let* ((mode (get-mode-object where))
276              (values (mode-object-var-values mode))
277              (binding (find-binding name values)))
278         (invoke-hook hemlock::delete-variable-hook name :mode where)
279         (delete-string sname (mode-object-variables mode))
280         (if (member mode (buffer-mode-objects *current-buffer*))
281             (let ((l (unwind-bindings *current-buffer* mode)))
282               (setf (mode-object-var-values mode)
283                     (delete-binding binding values))
284               (wind-bindings *current-buffer* l))
285             (setf (mode-object-var-values mode)
286                   (delete-binding binding values)))))
287      (:global
288       (invoke-hook hemlock::delete-variable-hook name :global nil)
289       (delete-string sname *global-variable-names*)
290       (let ((l (unwind-bindings *current-buffer* nil)))
291         (setf (get name 'hemlock-variable-value) nil)
292         (wind-bindings *current-buffer* l)))
293      (t (error "Invalid variable kind: ~S" kind)))
294    nil))
Note: See TracBrowser for help on using the repository browser.