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