![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to path.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl|
Return to path.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl |
1.1 root 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.