![[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.