Commit | Line | Data |
---|---|---|
6cbecd82 C |
1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; path.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
2 | ; Functions for accessing and changing information associated with | |
3 | ; slots of structures via a path. | |
4 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
5 | ; Copyright (c) 1983 , The Regents of the University of California. | |
6 | ; All rights reserved. | |
7 | ; Authors: Joseph Faletti and Michael Deering. | |
8 | ||
9 | ; The PATH functions provide methods for adding and accessing information | |
10 | ; in a structure. The PATH macro takes as a first argument the function | |
11 | ; to be performed and simply expands to the function. The functions | |
12 | ; available are: | |
13 | ; 1. PUTPATH -- replaces the value in the slot with one provided. | |
14 | ; 2. CLEARPATH -- replaces the value of the slot with the default. | |
15 | ; 3. ADDSETPATH -- adds the value provided to a SETOF slot (only one | |
16 | ; level of adding is currently available). | |
17 | ; 4. DELSETPATH -- deletes the value provided from a SETOF slot (note | |
18 | ; that this requires one to know the actual | |
19 | ; value to delete). | |
20 | ; 5. ADDPREDPATH -- adds a predicate (function, STRUCT, or hook) to | |
21 | ; the PREDLIST. | |
22 | ; 6. DELPREDPATH -- deletes a predicate from the PREDLIST. | |
23 | ; 7. GETPATH -- returns a pointer to the value in the slot. | |
24 | ; 8. GETPREDPATH -- returns the list of function and STRUCT | |
25 | ; predicates for the slot. | |
26 | ; 9. GETHOOKPATH -- returns the list of (dotted pair) hook | |
27 | ; functions for the slot. | |
28 | ; 10. APPLYPATH -- returns the result of APPLYing the function | |
29 | ; provided to the value for the slot. | |
30 | ; | |
31 | ; During a PATH operation, the global variable *PATHTOP* contains the | |
32 | ; top level item which is being accessed and *PATHLOCAL* is the most | |
33 | ; local item being accessed. These are most handy for use by hooks | |
34 | ; and predicates. | |
35 | ||
36 | (defmacro path (fcn item pathlist &optional val) | |
37 | (selectq fcn | |
38 | (put `(putpath ,item ,pathlist ,val)) | |
39 | (clear `(clearpath ,item ,pathlist)) | |
40 | (addset `(addsetpath ,item ,pathlist ,val)) | |
41 | (delset `(delsetpath ,item ,pathlist ,val)) | |
42 | (addpred `(addpredpath ,item ,pathlist ,val)) | |
43 | (delpred `(delpredpath ,item ,pathlist ,val)) | |
44 | (get `(getpath ,item ,pathlist)) | |
45 | (getpred `(getpredpath ,item ,pathlist)) | |
46 | (gethook `(gethookpath ,item ,pathlist)) | |
47 | (apply `(applypath ,item ,pathlist ,val)) | |
48 | (otherwise (msg t "PATH: Illegal function selector: " fcn | |
49 | ". Rest of call was: " item " " pathlist " " val t) | |
50 | (pearlbreak)))) | |
51 | ||
52 | (de putpath (item path value) | |
53 | (prog (numitempair slotnum result) | |
54 | (setq *pathtop* item) | |
55 | (setq *currentpearlstructure* item) | |
56 | (and (null (setq numitempair (followpath item path))) | |
57 | (return nil)) | |
58 | (setq slotnum (car numitempair)) | |
59 | (setq *pathlocal* (setq item (cdr numitempair))) | |
60 | (checkrunhandleslothooks1 '<put *runputpathhooks*) | |
61 | (selectq (getslotvaluetype slotnum item) | |
62 | (CONSTANT (putslotvalue slotnum value item)) | |
63 | (ADJUNCT | |
64 | (putslotvalue slotnum | |
65 | (cons value (cdr (getslotvalue slotnum item))) | |
66 | item)) | |
67 | ((LOCAL GLOBAL) | |
68 | (putslotvaluetype slotnum 'CONSTANT item) | |
69 | (putslotvalue slotnum value item))) | |
70 | (checkrunhandleslothooks1 '>put *runputpathhooks*) | |
71 | (return value))) | |
72 | ||
73 | (de clearpath (item path) | |
74 | (prog (numitempair slotnum value result) | |
75 | (setq *pathtop* item) | |
76 | (setq *currentpearlstructure* item) | |
77 | (and (null (setq numitempair (followpath item path))) | |
78 | (return nil)) | |
79 | (setq slotnum (car numitempair)) | |
80 | (setq *pathlocal* (setq item (cdr numitempair))) | |
81 | (setq value (defaultfortype (getslottype slotnum (getdefinition item)))) | |
82 | (checkrunhandleslothooks1 '<clear *runclearpathhooks*) | |
83 | (putslotvaluetype slotnum 'CONSTANT item) | |
84 | (putslotvalue slotnum value item) | |
85 | (checkrunhandleslothooks1 '>clear *runclearpathhooks*) | |
86 | (return value))) | |
87 | ||
88 | (de addsetpath (item path value) | |
89 | (prog (numitempair slotnum result) | |
90 | (setq *pathtop* item) | |
91 | (setq *currentpearlstructure* item) | |
92 | (and (null (setq numitempair (followpath item path))) | |
93 | (return nil)) | |
94 | (setq slotnum (car numitempair)) | |
95 | (setq *pathlocal* (setq item (cdr numitempair))) | |
96 | (checkrunhandleslothooks1 '<addset *runaddsetpathhooks*) | |
97 | (putslotvaluetype slotnum 'CONSTANT item) | |
98 | (putslotvalue slotnum (cons value (getvalue slotnum item)) item) | |
99 | (checkrunhandleslothooks1 '>addset *runaddsetpathhooks*) | |
100 | (return value))) | |
101 | ||
102 | (de delsetpath (item path value) | |
103 | (prog (numitempair slotnum result) | |
104 | (setq *pathtop* item) | |
105 | (setq *currentpearlstructure* item) | |
106 | (and (null (setq numitempair (followpath item path))) | |
107 | (return nil)) | |
108 | (setq slotnum (car numitempair)) | |
109 | (setq *pathlocal* (setq item (cdr numitempair))) | |
110 | (checkrunhandleslothooks1 '<delset *rundelsetpathhooks*) | |
111 | (putslotvaluetype slotnum 'CONSTANT item) | |
112 | (putslotvalue slotnum (delq value (getvalue slotnum item)) item) | |
113 | (checkrunhandleslothooks1 '>delset *rundelsetpathhooks*) | |
114 | (return value))) | |
115 | ||
116 | (de addpredpath (item path value) | |
117 | (prog (numitempair slotnum result) | |
118 | (setq *pathtop* item) | |
119 | (setq *currentpearlstructure* item) | |
120 | (and (null (setq numitempair (followpath item path))) | |
121 | (return nil)) | |
122 | (setq slotnum (car numitempair)) | |
123 | (setq *pathlocal* (setq item (cdr numitempair))) | |
124 | (checkrunhandleslothooks1 '<addpred *runaddpredpathhooks*) | |
125 | (putpred slotnum (cons value (getpred slotnum item)) item) | |
126 | (checkrunhandleslothooks1 '>addpred *runaddpredpathhooks*) | |
127 | (return value))) | |
128 | ||
129 | (de delpredpath (item path value) | |
130 | (prog (numitempair slotnum result) | |
131 | (setq *pathtop* item) | |
132 | (setq *currentpearlstructure* item) | |
133 | (and (null (setq numitempair (followpath item path))) | |
134 | (return nil)) | |
135 | (setq slotnum (car numitempair)) | |
136 | (setq *pathlocal* (setq item (cdr numitempair))) | |
137 | (checkrunhandleslothooks1 '<delpred *rundelpredpathhooks*) | |
138 | (putpred slotnum (delete value (getpred slotnum item)) item) | |
139 | (checkrunhandleslothooks1 '>delpred *rundelpredpathhooks*) | |
140 | (return value))) | |
141 | ||
142 | (de getpath (item path) | |
143 | (prog (numitempair slotnum value result) | |
144 | (setq *pathtop* item) | |
145 | (setq *currentpearlstructure* item) | |
146 | (and (null (setq numitempair (followpath item path))) | |
147 | (return nil)) | |
148 | (setq slotnum (car numitempair)) | |
149 | (setq *pathlocal* (setq item (cdr numitempair))) | |
150 | (setq value (punbound)) | |
151 | (checkrunhandleslothooks1 '<get *rungetpathhooks*) | |
152 | (or (neq value (punbound)) | |
153 | (setq value (getvalue slotnum item))) | |
154 | (checkrunhandleslothooks1 '>get *rungetpathhooks*) | |
155 | (return value))) | |
156 | ||
157 | (de getpredpath (item path) | |
158 | (prog (numitempair slotnum value result) | |
159 | (setq *pathtop* item) | |
160 | (setq *currentpearlstructure* item) | |
161 | (and (null (setq numitempair (followpath item path))) | |
162 | (return nil)) | |
163 | (setq slotnum (car numitempair)) | |
164 | (setq *pathlocal* (setq item (cadr numitempair))) | |
165 | (setq value (punbound)) | |
166 | (checkrunhandleslothooks1 '<getpred *rungetpredpathhooks*) | |
167 | (or (neq value (punbound)) | |
168 | (setq value (getpred slotnum item))) | |
169 | (checkrunhandleslothooks1 '>getpred *rungetpredpathhooks*) | |
170 | (return value))) | |
171 | ||
172 | (de gethookpath (item path value) | |
173 | (prog (numitempair slotnum result) | |
174 | (setq *pathtop* item) | |
175 | (setq *currentpearlstructure* item) | |
176 | (and (null (setq numitempair (followpath item path))) | |
177 | (return nil)) | |
178 | (setq slotnum (car numitempair)) | |
179 | (setq *pathlocal* (setq item (cadr numitempair))) | |
180 | (setq value (punbound)) | |
181 | (checkrunhandleslothooks1 '<gethook *rungethookpathhooks*) | |
182 | (or (neq value (punbound)) | |
183 | (setq value (getslothooks slotnum item))) | |
184 | (checkrunhandleslothooks1 '>gethook *rungethookpathhooks*) | |
185 | (return value))) | |
186 | ||
187 | (de applypath (fcn item path) | |
188 | (prog (numitempair slotnum value result) | |
189 | (setq *pathtop* item) | |
190 | (setq *currentpearlstructure* item) | |
191 | (and (null (setq numitempair (followpath item path))) | |
192 | (return nil)) | |
193 | (setq slotnum (car numitempair)) | |
194 | (setq *pathlocal* (setq item (cdr numitempair))) | |
195 | (setq value (getvalue slotnum item)) | |
196 | (checkrunhandleslothooks1 '<apply *runapplypathhooks*) | |
197 | (executehook1 fcn value item (getdefinition item)) | |
198 | (checkrunhandleslothooks1 '>apply *runapplypathhooks*) | |
199 | (return value))) | |
200 | ||
201 | ; This does indirection. If the path is longer and we come to a | |
202 | ; symbol, we try to find something of the type with the name | |
203 | ; that is next on the path and with the symbol in its first slot. | |
204 | ; Unfortunately, this always uses the data base in *db*. | |
205 | (defmacro findstructsymbolpair (defblock symbol) | |
206 | `(progn (and (setq bucket (gethash2 (getuniquenum ,defblock) | |
207 | (getuniquenum ,symbol) | |
208 | ; **** FIX to use different dbs (how?) | |
209 | (getdb2 *db*) | |
210 | )) | |
211 | (while (and (setq potential (pop bucket)) | |
212 | (not (and (eq (getdefinition potential) ,defblock) | |
213 | (eq (getvalue 1 potential) | |
214 | ,symbol)))) | |
215 | potential)) | |
216 | potential)) | |
217 | ||
218 | ; Follow the path down through the structures starting at item. | |
219 | (de followpath (item path) | |
220 | (or (structurep item) | |
221 | (progn (msg t "PATH: only works on structures, not on " item | |
222 | ". Requested path was: " path t) | |
223 | (pearlbreak))) | |
224 | (let (slotnum type slotname bucket potential slotlocation) | |
225 | (and (atom path) | |
226 | (setq path (ncons path))) | |
227 | (while (setq slotname (pop path)) | |
228 | (and (\=& 0 | |
229 | (setq slotnum | |
230 | (slotnametonumber slotname | |
231 | (getdefinition item)))) | |
232 | (progn (msg t "PATH: illegal slotname " slotname "requested " | |
233 | "from " item ". Remaining path is: " path t) | |
234 | (pearlbreak))) | |
235 | (and (null path) | |
236 | (return (cons slotnum item))) | |
237 | ; If a symbol slot (and more path), do indirection. | |
238 | (cond ((\=& 1 | |
239 | (setq type (getslottype slotnum | |
240 | (getdefinition item)))) | |
241 | (and (null (setq item | |
242 | (findstructsymbolpair | |
243 | (eval (defatom (pop path))) | |
244 | (getvalue slotnum item)))) | |
245 | (return nil))) | |
246 | ((\=& 0 type) (setq item (getvalue slotnum item))) | |
247 | ( t (msg t "PATH: Unable to follow path. " | |
248 | "Bad slotname is " slotname t) | |
249 | (pearlbreak)))))) | |
250 | ||
251 | ||
252 | ; vi: set lisp: |