![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hook.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 hook.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; hook.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Functions for filling in, running and processing the results of
3: ; both slot and base hooks. Also, hidden and visible.
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: ; Convert an equal sign followed by an atom into (*SLOT* atom)
10: ; for use in both predicates and hooks.
11: (drm \=
12: (lambda ()
13: (let ((nextchar (tyipeek)))
14: (cond ((\=& 9. nextchar) '\=)
15: ((\=& 10. nextchar) '\=)
16: ((\=& 13. nextchar) '\=)
17: ((\=& 32. nextchar) '\=)
18: ((\=& 41. nextchar) '\=)
19: ((eqstr (ascii nextchar) '\=)
20: (readc)
21: '\=\=)
22: ( t (list '*slot* (read)))))))
23:
24: ; Convert a slotname into a slot number for a particular type of structure.
25: (defmacro numberofslot (slotname defblock)
26: `(for slotnum 1 (getstructlength ,defblock)
27: (and (memq ,slotname (getslotname slotnum ,defblock))
28: (return slotnum)))
29: )
30:
31: ; Fill a predicate or hook (FCN) in with the right things, using
32: ; VALUE for * or >*,
33: ; ITEM for ** or >** and to find variables and slotvalues,
34: ; and DEFBLOCK to find slotnumbers.
35: (de fillin1 (fcn value item defblock)
36: (cond ((null fcn) nil)
37: ((atom fcn) (cond ((eq '** fcn) (list 'quote item))
38: ((eq '* fcn) (list 'quote value))
39: ((eq '>** fcn) (list 'quote item))
40: ((eq '>* fcn) (list 'quote value))
41: ( t fcn)))
42: ((dtpr fcn)
43: (cond ((eq '*slot* (car fcn))
44: (list 'quote
45: (getvalue (numberofslot (cadr fcn) defblock)
46: item)))
47: ((eq '*var* (car fcn))
48: (list 'quote
49: (valueof (cadr fcn) item)))
50: ((eq '*global* (car fcn))
51: (cadr fcn))
52: ( t (mapcar (funl (x) (fillin1 x value item defblock))
53: fcn))))
54: ( t fcn)))
55:
56: ; Fill a two-item predicate or hook (FCN) in with the right things, using
57: ; VAL1 for *
58: ; VAL2 for >*
59: ; ITEM1 for ** and to find variables and slotvalues,
60: ; ITEM2 for >**
61: ; RESULT for ?
62: ; and DEFBLOCK to find slotnumbers.
63: ; Must be made into a LEXPR in UCI Lisp because of number of arguments.
64: (de fillin2 (fcn val1 val2 item1 item2 defblock result)
65: (cond ((null fcn) nil)
66: ((atom fcn) (cond ((eq '** fcn) (list 'quote item1))
67: ((eq '>** fcn) (list 'quote item2))
68: ((eq '* fcn) (list 'quote val1))
69: ((eq '>* fcn) (list 'quote val2))
70: ((eq '\? fcn) (list 'quote result))
71: ( t fcn)))
72: ((dtpr fcn)
73: (cond ((eq '*slot* (car fcn))
74: (list 'quote
75: (getvalue (numberofslot (cadr fcn) defblock)
76: item1)))
77: ((eq '*var* (car fcn))
78: (list 'quote
79: (valueof (cadr fcn) item1)))
80: ((eq '*global* (car fcn))
81: (cadr fcn))
82: ( t (mapcar (funl (x) (fillin2 x val1 val2
83: item1 item2
84: defblock result))
85: fcn))))
86: ( t fcn)))
87:
88: ; If an atom, apply it, else fill it in and evaluate it.
89: (defmacro executehook1 (fcn value item defblock)
90: `(cond ((atom ,fcn) (apply* ,fcn (ncons ,value)))
91: ( t (eval (fillin1 ,fcn ,value ,item ,defblock)))))
92:
93: ; If an atom, apply it, else fill it in and evaluate it.
94: (defmacro executehook2 (fcn val1 val2 item1 item2 defblock result)
95: `(cond ((atom ,fcn) (apply* ,fcn (list ,val1 ,val2)))
96: ( t (eval (fillin2 ,fcn ,val1 ,val2
97: ,item1 ,item2 ,defblock ,result)))))
98:
99: ; If slothooks are supposed to be run, run them and check for *done*,
100: ; *fail* or *use*, doing the appropriate thing. Can almost be
101: ; used alone but assumes SLOTNUM, ITEM, RESULT, and VALUE.
102: (defmacro checkrunhandleslothooks1 (fcn runhooksatom)
103: `(and *runallslothooks*
104: ,runhooksatom
105: (setq result
106: (let ((defblock (getdefinition item))
107: (alist (getslothooks slotnum item))
108: (retvalue nil)
109: pair)
110: (while (and (not retvalue)
111: (setq pair (pop alist)))
112: (and (eq (car pair) ,fcn)
113: (setq retvalue
114: (executehook1 (cdr pair) value
115: item defblock))
116: (or (and (dtpr retvalue)
117: (memq (car retvalue)
118: '(*fail* *done* *use*)))
119: (setq retvalue nil))))
120: retvalue))
121: (dtpr result)
122: (selectq (car result)
123: (*done* (and (cdr result)
124: (return (cadr result)))
125: (return value))
126: (*fail* (and (cdr result)
127: (return (cadr result)))
128: (return '*fail*))
129: (*use* (setq value (cadr result))))))
130:
131: ; *done* and *fail* cause an immediate return. *use* changes the
132: ; value that was going to be used.
133: (defmacro handlehookresult (oldval newval)
134: `(and (dtpr ,newval)
135: (selectq (car ,newval)
136: (*done* (and (cdr ,newval)
137: (return (cadr ,newval)))
138: (return ,oldval))
139: (*fail* (and (cdr ,newval)
140: (return (cadr ,newval)))
141: (return '*fail*))
142: (*use* (setq ,oldval (cadr ,newval))))))
143:
144: ; If slothooks are supposed to be run, run them and check for *done*,
145: ; *fail* or *use*, doing the appropriate thing. Can almost be
146: ; used alone but assumes RESULT and ITEM.
147: (defmacro checkrunhandlebasehooks1 (fcn runhooksatom)
148: `(and *runallbasehooks*
149: ,runhooksatom
150: (setq result
151: (let ((retvalue nil)
152: alist
153: pair
154: defblock)
155: (and item
156: (setq defblock (getdefinition item))
157: (setq alist (getbasehooks defblock)))
158: (while (and (not retvalue)
159: (setq pair (pop alist)))
160: (and (eq (car pair) ,fcn)
161: (setq retvalue
162: (executehook1 (cdr pair) item
163: item defblock))
164: (or (and (dtpr retvalue)
165: (memq (car retvalue)
166: '(*fail* *done* *use*)))
167: (setq retvalue nil))))
168: retvalue))
169: (dtpr result)
170: (selectq (car result)
171: (*done* (and (cdr result)
172: (return (cadr result)))
173: (return item))
174: (*fail* (and (cdr result)
175: (return (cadr result)))
176: (return '*fail*))
177: (*use* (setq item (cadr result))))))
178:
179: ; If slothooks are supposed to be run, run them. Assumes SLOTNUM,
180: ; ITEM, and VALUE. This is not a standalone function, since it
181: ; does not handle RESULT but rather returns it.
182: (defmacro checkandrunslothooks2 (fcn hooks val1 val2 item1 item2)
183: `(let ((defblock (getdefinition ,item1))
184: (retvalue nil)
185: pair)
186: (while (and (not retvalue)
187: (setq pair (pop ,hooks)))
188: (and (eq (car pair) ,fcn)
189: (setq retvalue
190: (executehook2 (cdr pair) ,val1 ,val2
191: ,item1 ,item2 defblock result))
192: (or (and (dtpr retvalue)
193: (memq (car retvalue)
194: '(*fail* *done* *use*)))
195: (setq retvalue nil))))
196: retvalue))
197:
198: ; Assumes XVAL or YVAL is where you want changes.
199: (defmacro doslothooks2< (fcn runhookatom)
200: `(cond ((and *runallslothooks*
201: ,runhookatom)
202: (setq newxval nil)
203: (setq newyval nil)
204: (and (setq xhooks (getslothooks slotnum item1))
205: (setq newxval
206: (checkandrunslothooks2 ,fcn xhooks xval yval
207: item1 item2)))
208: (and (setq yhooks (getslothooks slotnum item2))
209: (setq newyval
210: (checkandrunslothooks2 ,fcn yhooks yval xval
211: item2 item1)))
212: (handlehookresult xval newxval)
213: (handlehookresult yval newyval))))
214:
215: ; Assumes RESULT is where you want changes.
216: (defmacro doslothooks2> (fcn runhookatom)
217: `(cond ((and *runallslothooks*
218: ,runhookatom)
219: (setq newxval nil)
220: (setq newyval nil)
221: (and (setq xhooks (getslothooks slotnum item1))
222: (setq newxval
223: (checkandrunslothooks2 ,fcn xhooks xval yval
224: item1 item2)))
225: (and (setq yhooks (getslothooks slotnum item2))
226: (setq newyval
227: (checkandrunslothooks2 ,fcn yhooks yval xval
228: item2 item1)))
229: (handlehookresult result newxval)
230: (handlehookresult result newyval))))
231:
232: (defmacro checkandrunbasehooks2 (fcn item1 item2)
233: `(let* ((retvalue nil)
234: (defblock (getdefinition ,item1))
235: (alist (getbasehooks defblock))
236: pair)
237: (while (and (not retvalue)
238: (setq pair (pop alist)))
239: (and (eq (car pair) ,fcn)
240: (setq retvalue
241: (executehook2 (cdr pair) ,item1 ,item2
242: ,item1 ,item2 defblock result))
243: (or (and (dtpr retvalue)
244: (memq (car retvalue)
245: '(*fail* *done* *use*)))
246: (setq retvalue nil))))
247: retvalue))
248:
249: ; Assumes ITEM1 and ITEM2 are where you want changes.
250: (defmacro dobasehooks2< (fcn runhookatom)
251: `(cond ((and *runallbasehooks*
252: ,runhookatom)
253: (setq newitem1 (checkandrunbasehooks2 ,fcn item1 item2))
254: (setq newitem2 (checkandrunbasehooks2 ,fcn item2 item1))
255: (handlehookresult item1 newitem1)
256: (handlehookresult item2 newitem2))))
257:
258: ; Assumes RESULT is where you want changes.
259: (defmacro dobasehooks2> (fcn runhookatom)
260: `(cond ((and *runallbasehooks*
261: ,runhookatom)
262: (setq newitem1 (checkandrunbasehooks2 ,fcn item1 item2))
263: (setq newitem2 (checkandrunbasehooks2 ,fcn item2 item1))
264: (handlehookresult result newitem1)
265: (handlehookresult result newitem2))))
266:
267: ; Runbasehooks for single items for the user.
268: (de runbasehooks1 (fcn item)
269: (and (null item)
270: (progn (msg t "RUNBASEIFS1: Null item given to run hooks on." t)
271: (pearlbreak)))
272: (let* ((retvalue nil)
273: (defblock (getdefinition item))
274: (alist (getbasehooks defblock))
275: pair)
276: (while (and (not retvalue)
277: (setq pair (pop alist)))
278: (and (eq (car pair) fcn)
279: (setq retvalue (executehook1 (cdr pair) item item defblock))
280: (or (and (dtpr retvalue)
281: (memq (car retvalue) '(*fail* *done* *use*)))
282: (setq retvalue nil))))
283: retvalue))
284:
285: ; Runbasehooks for two items for the user.
286: (de runbasehooks2 (fcn item1 item2 result)
287: (and (null item1)
288: (progn (msg t "RUNBASEIFS2: Null first item given to run hooks on." t)
289: (pearlbreak)))
290: (and (null item2)
291: (progn (msg t "RUNBASEIFS2: Null second item given to run hooks on." t)
292: (pearlbreak)))
293: (let* ((retvalue nil)
294: (defblock (getdefinition item1))
295: (alist (getbasehooks defblock))
296: pair)
297: (while (and (not retvalue)
298: (setq pair (pop alist)))
299: (and (eq (car pair) fcn)
300: (setq retvalue
301: (executehook2 (cdr pair) item1 item2
302: item1 item2 defblock result))
303: (or (and (dtpr retvalue)
304: (memq (car retvalue) '(*fail* *done* *use*)))
305: (setq retvalue nil))))
306: retvalue))
307:
308: ; Run slot hooks for the slot named SLOTNAME for one item for the user.
309: (de runslothooks1 (fcn item slotname value)
310: (and (null item)
311: (progn (msg t "RUNSLOTIFS1: Null item given to run hooks on." t)
312: (pearlbreak)))
313: (let* ((retvalue nil)
314: (defblock (getdefinition item))
315: (slotnum (numberofslot slotname defblock))
316: (alist (getslothooks slotnum item))
317: pair)
318: (while (and (not retvalue)
319: (setq pair (pop alist)))
320: (and (eq (car pair) fcn)
321: (setq retvalue
322: (executehook1 (cdr pair) value item defblock))
323: (or (and (dtpr retvalue)
324: (memq (car retvalue) '(*fail* *done* *use*)))
325: (setq retvalue nil))))
326: retvalue))
327:
328: ; Run slot hooks for the slot named SLOTNAME for two items for the user.
329: ; Must be made into a LEXPR in UCI Lisp because of number of arguments.
330: (de runslothooks2 (fcn item1 item2 slotname val1 val2 result)
331: (and (null item1)
332: (progn (msg t "RUNSLOTIFS1: Null first item given to run hooks on." t)
333: (pearlbreak)))
334: (and (null item2)
335: (progn (msg t "RUNSLOTIFS1: Null second item given to run hooks on." t)
336: (pearlbreak)))
337: (let* ((retvalue1 nil)
338: (retvalue2 nil)
339: (defblock (getdefinition item1))
340: (slotnum (numberofslot slotname defblock))
341: (alist (getslothooks slotnum item1))
342: pair)
343: (while (and (not retvalue1)
344: (setq pair (pop alist)))
345: (and (eq (car pair) fcn)
346: (setq retvalue1
347: (executehook2 (cdr pair) val1 val2
348: item1 item2 defblock result))
349: (or (and (dtpr retvalue1)
350: (memq (car retvalue1) '(*fail* *done* *use*)))
351: (setq retvalue1 nil))))
352: (setq defblock (getdefinition item2))
353: (setq slotnum (numberofslot slotname defblock))
354: (setq alist (getslothooks slotnum item2))
355: (while (and (not retvalue2)
356: (setq pair (pop alist)))
357: (and (eq (car pair) fcn)
358: (setq retvalue2
359: (executehook2 (cdr pair) val2 val1
360: item2 item1 defblock result))
361: (or (and (dtpr retvalue2)
362: (memq (car retvalue2) '(*fail* *done* *use*)))
363: (setq retvalue2 nil))))
364: (cons retvalue1 retvalue2)))
365:
366: ; Run command with its associated *run...hooks* atom set to nil
367: ; temporarily with a let so that its hooks WON'T be run.
368: (defmacro hidden (command)
369: (let ((name (concat '*run (car command) 'hooks*)))
370: `(let ((,name nil))
371: ,command)))
372:
373: ; Run command with its associated *run...hooks* atom set to t
374: ; temporarily with a let so that its hooks WILL be run.
375: (defmacro visible (command)
376: (let ((name (concat '*run (car command) 'hooks*)))
377: `(let ((,name t))
378: ,command)))
379:
380: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.