| 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: |