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

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

Get rid of the variable "winding" scheme (which used to swap the
current buffer's variable bindings into symbol plists), simplify
variable and mode handing.

Fix a shadow attribute caching bug.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.6 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;;; UNDEFINED-VARIABLE-ERROR  --  Internal
20;;;
21;;;    Complain about an undefined Hemlock variable in a helpful fashion.
22;;;
23(defun undefined-variable-error (name)
24  (if (eq (symbol-package name) (find-package :hemlock))
25      (error "Undefined Hemlock variable ~A." name)
26      (error "Hemlock variables must be in the \"HEMLOCK\" package, but~%~
27             ~S is in the ~S package."
28             name (package-name (symbol-package name)))))
29
30;;; GET-MODE-OBJECT  --  Internal
31;;;
32;;;    Get the mode-object corresponding to name or die trying.
33;;;
34(defun get-mode-object (name)
35  (unless (stringp name) (error "Mode name ~S is not a string." name))
36  (let ((res (getstring name *mode-names*)))
37    (unless res (error "~S is not a defined mode." name))
38    res))
39
40;;; FIND-BINDING  --  Internal
41;;;
42;;;    Return the Binding object corresponding to Name in the collection
43;;; of binding Binding, or NIL if none.
44;;;
45(defun find-binding (symbol-name bindings)
46  (find symbol-name bindings :key #'variable-object-symbol-name :test #'eq))
47
48;;; GET-VARIABLE-OBJECT  --  Internal
49;;;
50;;;    Get the variable-object with the specified symbol-name, kind and where,
51;;; or die trying.
52;;;
53(defun get-variable-object (name kind &optional where)
54  (or (lookup-variable-object name kind where)
55      (undefined-variable-error name)))
56
57(defun lookup-variable-object (name kind where)
58  (ecase kind
59    (:current
60     (let ((buffer (current-buffer)))
61       (if (null buffer)
62         (lookup-variable-object name :global t)
63         (or (find-binding name (buffer-var-values buffer))
64             (loop for mode in (buffer-minor-mode-objects buffer)
65               thereis (find-binding name (mode-object-var-values mode)))
66             (find-binding name (mode-object-var-values (buffer-major-mode-object buffer)))
67             (get name 'hemlock-variable-value)))))
68    (:buffer
69     (find-binding name (buffer-var-values (ccl:require-type where 'buffer))))
70    (:mode
71     (find-binding name (mode-object-var-values (get-mode-object where))))
72    (:global
73     (get name 'hemlock-variable-value))))
74
75;;; VARIABLE-VALUE  --  Public
76;;;
77;;;    Get the value of the Hemlock variable "name".
78;;;
79(defun variable-value (name &optional (kind :current) where)
80  "Return the value of the Hemlock variable given."
81  (variable-object-value (get-variable-object name kind where)))
82
83;;; %SET-VARIABLE-VALUE  --  Internal
84;;;
85;;;   Set the Hemlock variable with the symbol name "name".
86;;;
87(defun %set-variable-value (name kind where new-value)
88  (let ((obj (get-variable-object name kind where)))
89    (invoke-hook (variable-object-hooks obj) name kind where new-value)
90    (setf (variable-object-value obj) new-value)))
91
92;;; %VALUE  --  Internal
93;;;
94;;;    This function is called by the expansion of Value.
95;;;
96(defun %value (name)
97  (variable-value name :current t))
98
99;;; %SET-VALUE  --  Internal
100;;;
101;;;    The setf-inverse of Value, set the current value.
102;;;
103(defun %set-value (name new-value)
104  (%set-variable-value name :current t new-value))
105
106
107;;; VARIABLE-HOOKS  --  Public
108;;;
109;;;    Return the list of hooks for "name".
110;;;
111(defun variable-hooks (name &optional (kind :current) where)
112  "Return the list of hook functions for the Hemlock variable given."
113  (variable-object-hooks (get-variable-object name kind where)))
114
115;;; %SET-VARIABLE-HOOKS --  Internal
116;;;
117;;;    Set the hook-list for Hemlock variable Name.
118;;;
119(defun %set-variable-hooks (name kind where new-value)
120  (setf (variable-object-hooks (get-variable-object name kind where)) new-value))
121
122;;; VARIABLE-DOCUMENTATION  --  Public
123;;;
124;;;    Return the documentation for "name".
125;;;
126(defun variable-documentation (name &optional (kind :current) where)
127  "Return the documentation for the Hemlock variable given."
128  (variable-object-documentation (get-variable-object name kind where)))
129
130;;; %SET-VARIABLE-DOCUMENTATION  --  Internal
131;;;
132;;;    Set a variables documentation.
133;;;
134(defun %set-variable-documentation (name kind where new-value)
135  (setf (variable-object-documentation (get-variable-object name kind where))
136        new-value))
137
138;;; VARIABLE-NAME  --  Public
139;;;
140;;;    Return the String Name for a Hemlock variable.
141;;;
142(defun variable-name (name &optional (kind :current) where)
143   "Return the string name of a Hemlock variable."
144  (variable-object-name (get-variable-object name kind where)))
145
146;;; HEMLOCK-BOUND-P  --  Public
147;;;
148(defun hemlock-bound-p (name &optional (kind :current) where)
149  "Returns T Name is a Hemlock variable defined in the specifed place, or
150  NIL otherwise."
151  (not (null (lookup-variable-object name kind where))))
152
153
154(declaim (special *global-variable-names*))
155
156;;; DEFHVAR  --  Public
157;;;
158;;;    Define a Hemlock variable somewhere.
159;;;
160(defun defhvar (name documentation &key mode buffer (hooks nil hook-p)
161                     (value nil value-p))
162  (let* ((symbol-name (string-to-variable name)) var)
163    (cond
164     (mode
165      (let* ((mode-obj (get-mode-object mode)))
166        (setf (getstring name (mode-object-variables mode-obj)) symbol-name)
167        (unless (setq var (find-binding symbol-name (mode-object-var-values mode-obj)))
168          (push (setq var (make-variable-object symbol-name))
169                (mode-object-var-values mode-obj)))))
170     (buffer
171      (check-type buffer buffer)
172      (setf (getstring name (buffer-variables buffer)) symbol-name)
173      (unless (setq var (find-binding symbol-name (buffer-var-values buffer)))
174        (push (setq var (make-variable-object symbol-name))
175              (buffer-var-values buffer))))
176     (t
177      (setf (getstring name *global-variable-names*) symbol-name)
178      (unless (setq var (get symbol-name 'hemlock-variable-value))
179        (setf (get symbol-name 'hemlock-variable-value)
180              (setq var (make-variable-object symbol-name))))))
181    (setf (variable-object-name var) name)
182    (when (> (length documentation) 0)
183      (setf (variable-object-documentation var) documentation))
184    (when hook-p
185      (setf (variable-object-hooks var) hooks))
186    (when value-p
187      (setf (variable-object-value var) value)))
188  name)
189
190;;; DELETE-VARIABLE  --  Public
191;;;
192;;; Make a Hemlock variable no longer bound, fixing up the saved
193;;;binding values as necessary.
194;;;
195(defun delete-variable (name &optional (kind :global) where)
196  "Delete a Hemlock variable somewhere."
197  (let* ((obj (get-variable-object name kind where))
198         (sname (variable-object-name obj)))
199    (ecase kind
200      (:buffer
201       (let* ((values (buffer-var-values where))
202              (binding (find-binding name values)))
203         (invoke-hook hemlock::delete-variable-hook name :buffer where)
204         (delete-string sname (buffer-variables where))
205         (setf (buffer-var-values where) (delete binding values))))
206      (:mode
207       (let* ((mode (get-mode-object where))
208              (values (mode-object-var-values mode))
209              (binding (find-binding name values)))
210         (invoke-hook hemlock::delete-variable-hook name :mode where)
211         (delete-string sname (mode-object-variables mode))
212         (setf (mode-object-var-values mode) (delete binding values))))
213      (:global
214       (invoke-hook hemlock::delete-variable-hook name :global nil)
215       (delete-string sname *global-variable-names*)
216       (setf (get name 'hemlock-variable-value) nil)))
217    nil))
Note: See TracBrowser for help on using the repository browser.