[unix-history] / .ref-BSD-4_3_Net_2 / usr / src / usr.bin / lisp / pearl / hook.l

;;;;;;;;;;;;;;;;;;;;;;;;;;;;; hook.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for filling in, running and processing the results of
;    both slot and base hooks.  Also, hidden and visible.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 ,  The Regents of the University of California.
; All rights reserved.  
; Authors: Joseph Faletti and Michael Deering.

; Convert an equal sign followed by an atom into (*SLOT* atom) 
;    for use in both predicates and hooks.
(drm \=
  (lambda ()
	  (let ((nextchar (tyipeek)))
	       (cond ((\=&  9. nextchar) '\=)
		     ((\=& 10. nextchar) '\=)
		     ((\=& 13. nextchar) '\=)
		     ((\=& 32. nextchar) '\=)
		     ((\=& 41. nextchar) '\=)
		     ((eqstr (ascii nextchar) '\=)
		      (readc)
		      '\=\=)
		     ( t  (list '*slot* (read)))))))
 
; Convert a slotname into a slot number for a particular type of structure.
(defmacro numberofslot (slotname defblock)
  `(for slotnum 1 (getstructlength ,defblock)
	(and (memq ,slotname (getslotname slotnum ,defblock))
	     (return slotnum)))
  )
 
; Fill a predicate or hook (FCN) in with the right things, using
;         VALUE  for   *  or  >*,
;	  ITEM   for   ** or  >** and to find variables and slotvalues,
;     and DEFBLOCK to find slotnumbers.
(de fillin1 (fcn value item defblock)
  (cond ((null fcn) nil)
	((atom fcn) (cond ((eq '** fcn) (list 'quote item))
			  ((eq '* fcn) (list 'quote value))
			  ((eq '>** fcn) (list 'quote item))
			  ((eq '>* fcn) (list 'quote value))
			  ( t fcn)))
	((dtpr fcn)
	 (cond ((eq '*slot* (car fcn))
		(list 'quote
		      (getvalue (numberofslot (cadr fcn) defblock)
				item)))
	       ((eq '*var* (car fcn))
		(list 'quote
		      (valueof (cadr fcn) item)))
	       ((eq '*global* (car fcn))
		(cadr fcn))
	       ( t (mapcar (funl (x) (fillin1 x value item defblock))
			   fcn))))
	(  t  fcn)))

; Fill a two-item predicate or hook (FCN) in with the right things, using
;         VAL1   for   *
;         VAL2   for   >*
;	  ITEM1  for   ** and to find variables and slotvalues,
;	  ITEM2  for   >**
;         RESULT for   ?
;     and DEFBLOCK to find slotnumbers.
; Must be made into a LEXPR in UCI Lisp because of number of arguments.
(de fillin2 (fcn val1 val2 item1 item2 defblock result)
  (cond ((null fcn) nil)
	((atom fcn) (cond ((eq '** fcn)  (list 'quote item1))
			  ((eq '>** fcn) (list 'quote item2))
			  ((eq '* fcn)   (list 'quote val1))
			  ((eq '>* fcn)  (list 'quote val2))
			  ((eq '\? fcn)  (list 'quote result))
			  ( t fcn)))
	((dtpr fcn)
	 (cond ((eq '*slot* (car fcn))
		(list 'quote
		      (getvalue (numberofslot (cadr fcn) defblock)
				item1)))
	       ((eq '*var* (car fcn))
		(list 'quote
		      (valueof (cadr fcn) item1)))
	       ((eq '*global* (car fcn))
		(cadr fcn))
	       ( t (mapcar (funl (x) (fillin2 x val1 val2
					      item1 item2
					      defblock result))
			   fcn))))
	( t   fcn)))
 
; If an atom, apply it, else fill it in and evaluate it.
(defmacro executehook1 (fcn value item defblock)
  `(cond ((atom ,fcn) (apply* ,fcn (ncons ,value)))
	 (  t  (eval (fillin1 ,fcn ,value ,item ,defblock)))))
 
; If an atom, apply it, else fill it in and evaluate it.
(defmacro executehook2 (fcn val1 val2 item1 item2 defblock result)
  `(cond ((atom ,fcn) (apply* ,fcn (list ,val1 ,val2)))
	 (  t  (eval (fillin2 ,fcn ,val1 ,val2
			      ,item1 ,item2 ,defblock ,result)))))

; If slothooks are supposed to be run, run them and check for *done*,
;    *fail* or *use*, doing the appropriate thing.  Can almost be
;    used alone but assumes SLOTNUM, ITEM, RESULT, and VALUE.
(defmacro checkrunhandleslothooks1 (fcn runhooksatom)
  `(and *runallslothooks*
	,runhooksatom
	(setq result
	      (let ((defblock (getdefinition item))
		    (alist (getslothooks slotnum item))
		    (retvalue nil)
		    pair)
		   (while (and (not retvalue)
			       (setq pair (pop alist)))
			  (and (eq (car pair) ,fcn)
			       (setq retvalue
				     (executehook1 (cdr pair) value
						   item defblock))
			       (or (and (dtpr retvalue)
					(memq (car retvalue)
					      '(*fail* *done* *use*)))
				   (setq retvalue nil))))
		    retvalue))
	(dtpr result)
	(selectq (car result)
		 (*done* (and (cdr result)
			      (return (cadr result)))
			 (return value))
		 (*fail* (and (cdr result)
			      (return (cadr result)))
			 (return '*fail*))
		 (*use* (setq value (cadr result))))))

; *done* and *fail* cause an immediate return.  *use* changes the
;     value that was going to be used.
(defmacro handlehookresult (oldval newval)
  `(and (dtpr ,newval)
	(selectq (car ,newval)
		 (*done* (and (cdr ,newval)
			      (return (cadr ,newval)))
			 (return ,oldval))
		 (*fail* (and (cdr ,newval)
			      (return (cadr ,newval)))
			 (return '*fail*))
		 (*use* (setq ,oldval (cadr ,newval))))))

; If slothooks are supposed to be run, run them and check for *done*,
;    *fail* or *use*, doing the appropriate thing.  Can almost be
;    used alone but assumes RESULT and ITEM.
(defmacro checkrunhandlebasehooks1 (fcn runhooksatom)
  `(and *runallbasehooks*
	,runhooksatom
	(setq result
	      (let ((retvalue nil)
		    alist
		    pair
		    defblock)
		   (and item
			(setq defblock (getdefinition item))
			(setq alist (getbasehooks defblock)))
		   (while (and (not retvalue)
			       (setq pair (pop alist)))
			  (and (eq (car pair) ,fcn)
			       (setq retvalue
				     (executehook1 (cdr pair) item
						   item defblock))
			       (or (and (dtpr retvalue)
					(memq (car retvalue)
					      '(*fail* *done* *use*)))
				   (setq retvalue nil))))
		   retvalue))
	(dtpr result)
	(selectq (car result)
		 (*done* (and (cdr result)
			      (return (cadr result)))
			 (return item))
		 (*fail* (and (cdr result)
			      (return (cadr result)))
			 (return '*fail*))
		 (*use* (setq item (cadr result))))))

; If slothooks are supposed to be run, run them.  Assumes SLOTNUM,
;    ITEM, and VALUE.  This is not a standalone function, since it
;    does not handle RESULT but rather returns it.
(defmacro checkandrunslothooks2 (fcn hooks val1 val2 item1 item2)
  `(let ((defblock (getdefinition ,item1))
	 (retvalue nil)
	 pair)
	(while (and (not retvalue)
		    (setq pair (pop ,hooks)))
	       (and (eq (car pair) ,fcn)
		    (setq retvalue
			  (executehook2 (cdr pair) ,val1 ,val2
					,item1 ,item2 defblock result))
		    (or (and (dtpr retvalue)
			     (memq (car retvalue)
				   '(*fail* *done* *use*)))
			(setq retvalue nil))))
	 retvalue))

; Assumes XVAL or YVAL is where you want changes.
(defmacro doslothooks2< (fcn runhookatom)
  `(cond ((and *runallslothooks*
	       ,runhookatom)
	  (setq newxval nil)
	  (setq newyval nil)
	  (and (setq xhooks (getslothooks slotnum item1))
	       (setq newxval
		     (checkandrunslothooks2 ,fcn xhooks xval yval
					    item1 item2)))
	  (and (setq yhooks (getslothooks slotnum item2))
	       (setq newyval
		     (checkandrunslothooks2 ,fcn yhooks yval xval
					    item2 item1)))
	  (handlehookresult xval newxval)
	  (handlehookresult yval newyval))))

; Assumes RESULT is where you want changes.
(defmacro doslothooks2> (fcn runhookatom)
  `(cond ((and *runallslothooks*
	       ,runhookatom)
	  (setq newxval nil)
	  (setq newyval nil)
	  (and (setq xhooks (getslothooks slotnum item1))
	       (setq newxval
		     (checkandrunslothooks2 ,fcn xhooks xval yval
					    item1 item2)))
	  (and (setq yhooks (getslothooks slotnum item2))
	       (setq newyval
		     (checkandrunslothooks2 ,fcn yhooks yval xval
					    item2 item1)))
	  (handlehookresult result newxval)
	  (handlehookresult result newyval))))

(defmacro checkandrunbasehooks2 (fcn item1 item2)
  `(let* ((retvalue nil)
	  (defblock (getdefinition ,item1))
	  (alist (getbasehooks defblock))
	  pair)
	 (while (and (not retvalue)
		     (setq pair (pop alist)))
		(and (eq (car pair) ,fcn)
		     (setq retvalue
			   (executehook2 (cdr pair) ,item1 ,item2
					 ,item1 ,item2 defblock result))
		     (or (and (dtpr retvalue)
			      (memq (car retvalue)
				    '(*fail* *done* *use*)))
			 (setq retvalue nil))))
	 retvalue))

; Assumes ITEM1 and ITEM2 are where you want changes.
(defmacro dobasehooks2< (fcn runhookatom)
  `(cond ((and *runallbasehooks*
	       ,runhookatom)
	  (setq newitem1 (checkandrunbasehooks2 ,fcn item1 item2))
	  (setq newitem2 (checkandrunbasehooks2 ,fcn item2 item1))
	  (handlehookresult item1 newitem1)
	  (handlehookresult item2 newitem2))))

; Assumes RESULT is where you want changes.
(defmacro dobasehooks2> (fcn runhookatom)
  `(cond ((and *runallbasehooks*
	       ,runhookatom)
	  (setq newitem1 (checkandrunbasehooks2 ,fcn item1 item2))
	  (setq newitem2 (checkandrunbasehooks2 ,fcn item2 item1))
	  (handlehookresult result newitem1)
	  (handlehookresult result newitem2))))

; Runbasehooks for single items for the user.
(de runbasehooks1 (fcn item)
  (and (null item)
       (progn (msg t "RUNBASEIFS1: Null item given to run hooks on." t)
	      (pearlbreak)))
  (let* ((retvalue nil)
	 (defblock (getdefinition item))
	 (alist (getbasehooks defblock))
	 pair)
	(while (and (not retvalue)
		    (setq pair (pop alist)))
	       (and (eq (car pair) fcn)
		    (setq retvalue (executehook1 (cdr pair) item item defblock))
		    (or (and (dtpr retvalue)
			     (memq (car retvalue) '(*fail* *done* *use*)))
			(setq retvalue nil))))
	retvalue))

; Runbasehooks for two items for the user.
(de runbasehooks2 (fcn item1 item2 result)
  (and (null item1)
       (progn (msg t "RUNBASEIFS2: Null first item given to run hooks on." t)
	      (pearlbreak)))
  (and (null item2)
       (progn (msg t "RUNBASEIFS2: Null second item given to run hooks on." t)
	      (pearlbreak)))
  (let* ((retvalue nil)
	 (defblock (getdefinition item1))
	 (alist (getbasehooks defblock))
	 pair)
	(while (and (not retvalue)
		    (setq pair (pop alist)))
	       (and (eq (car pair) fcn)
		    (setq retvalue
			  (executehook2 (cdr pair) item1 item2
					item1 item2 defblock result))
		    (or (and (dtpr retvalue)
			     (memq (car retvalue) '(*fail* *done* *use*)))
			(setq retvalue nil))))
	retvalue))

; Run slot hooks for the slot named SLOTNAME for one item for the user.
(de runslothooks1 (fcn item slotname value)
  (and (null item)
       (progn (msg t "RUNSLOTIFS1: Null item given to run hooks on." t)
	      (pearlbreak)))
  (let* ((retvalue nil)
	 (defblock (getdefinition item))
	 (slotnum (numberofslot slotname defblock))
	 (alist (getslothooks slotnum item))
	 pair)
	(while (and (not retvalue)
		    (setq pair (pop alist)))
	       (and (eq (car pair) fcn)
		    (setq retvalue
			  (executehook1 (cdr pair) value item defblock))
		    (or (and (dtpr retvalue)
			     (memq (car retvalue) '(*fail* *done* *use*)))
			(setq retvalue nil))))
	retvalue))

; Run slot hooks for the slot named SLOTNAME for two items for the user.
; Must be made into a LEXPR in UCI Lisp because of number of arguments.
(de runslothooks2 (fcn item1 item2 slotname val1 val2 result)
  (and (null item1)
       (progn (msg t "RUNSLOTIFS1: Null first item given to run hooks on." t)
	      (pearlbreak)))
  (and (null item2)
       (progn (msg t "RUNSLOTIFS1: Null second item given to run hooks on." t)
	      (pearlbreak)))
  (let* ((retvalue1 nil)
	 (retvalue2 nil)
	 (defblock (getdefinition item1))
	 (slotnum (numberofslot slotname defblock))
	 (alist (getslothooks slotnum item1))
	 pair)
	(while (and (not retvalue1)
		    (setq pair (pop alist)))
	       (and (eq (car pair) fcn)
		    (setq retvalue1
			  (executehook2 (cdr pair) val1 val2
					item1 item2 defblock result))
		    (or (and (dtpr retvalue1)
			     (memq (car retvalue1) '(*fail* *done* *use*)))
			(setq retvalue1 nil))))
	(setq defblock (getdefinition item2))
	(setq slotnum (numberofslot slotname defblock))
	(setq alist (getslothooks slotnum item2))
	(while (and (not retvalue2)
		    (setq pair (pop alist)))
	       (and (eq (car pair) fcn)
		    (setq retvalue2
			  (executehook2 (cdr pair) val2 val1
					item2 item1 defblock result))
		    (or (and (dtpr retvalue2)
			     (memq (car retvalue2) '(*fail* *done* *use*)))
			(setq retvalue2 nil))))
	(cons retvalue1 retvalue2)))

; Run command with its associated *run...hooks* atom set to nil
;    temporarily with a let so that its hooks WON'T be run.
(defmacro hidden (command)
  (let ((name (concat '*run (car command) 'hooks*)))
       `(let ((,name nil))
	     ,command)))

; Run command with its associated *run...hooks* atom set to t
;    temporarily with a let so that its hooks WILL be run.
(defmacro visible (command)
  (let ((name (concat '*run (car command) 'hooks*)))
       `(let ((,name t))
	     ,command)))

; vi: set lisp:
Commit	Line	Data
7129096e C	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: