![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to hash.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl|
Return to hash.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl |
1.1 ! root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; hash.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ! 2: ; Functions for hashing, inserting, and fetching items into the ! 3: ; data bases, plus operating on streams. ! 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: ; Find the next item on the CDDR list of the stream that matches the CADR of ! 10: ; the stream and return it, also updating the stream. ! 11: (de nextitem (stream) ! 12: (or (streamp stream) ! 13: (progn (msg t "NEXTITEM: Not a stream: " stream t) ! 14: (pearlbreak))) ! 15: (setq stream (cdr stream)) ; Throw away the *STREAM*. ! 16: (cond ((eq t (car stream)) ; This means function structure. ! 17: (prog1 (evalfcn (cdr stream)) ! 18: (rplacd (rplaca stream nil) nil))) ! 19: ((null (cadr stream)) nil) ; Test for empty stream ! 20: ; Stream built by standardfetch. ! 21: ; To debug or modify this, you must draw a picture of what ! 22: ; standardfetch built because of the way it is written. ! 23: ((not (dtpr (cadr stream))) ! 24: (prog (item result) ! 25: (setq item (car stream)) ! 26: (setq *currentpearlstructure* item) ! 27: (checkrunhandlebasehooks1 '<nextitem *runnextitemhooks*) ! 28: (while (and (cdr stream) ! 29: (or (eq (cadr stream) '*db*) ! 30: (not (match item (cadr stream))))) ! 31: (rplacd stream (cddr stream))) ! 32: (setq item (cadr stream)) ! 33: (rplacd stream (cddr stream)) ! 34: (checkrunhandlebasehooks1 '>nextitem *runnextitemhooks*) ! 35: (return item))) ! 36: ; Stream built by expandedfetch (or fetcheverywhere). ! 37: ; To debug or modify this, you must draw a picture of what ! 38: ; expandedfetch built because of the way it is written. ! 39: ((not (dtpr (caadr stream))) ! 40: (prog (item result) ! 41: (setq item (car stream)) ! 42: (setq *currentpearlstructure* item) ! 43: (checkrunhandlebasehooks1 '<nextitem *runnextitemhooks*) ! 44: (while (and (cdr stream) ! 45: (or (eq (caadr stream) '*db*) ! 46: (not (expandedmatch item (caadr stream))))) ! 47: (or (car (rplaca (cdr stream) (cdadr stream))) ! 48: (rplacd stream (cddr stream)))) ! 49: (setq item (caadr stream)) ! 50: (or (not (cdr stream)) ! 51: (car (rplaca (cdr stream) (cdadr stream))) ! 52: (rplacd stream (cddr stream))) ! 53: (checkrunhandlebasehooks1 '>nextitem *runnextitemhooks*) ! 54: (return item))))) ! 55: ! 56: (defmacro hashinfo (slotnum) ! 57: `(cxr ,slotnum *hashingmarks*)) ! 58: ! 59: (defmacro sethashinfo (slotnum value) ! 60: `(rplacx ,slotnum *hashingmarks* ,value)) ! 61: ! 62: (defmacro slotval (slotnum) ! 63: `(cxr ,slotnum *slotvalues*)) ! 64: ! 65: (defmacro storeslot (slotnum value) ! 66: `(rplacx ,slotnum *slotvalues* ,value)) ! 67: ! 68: ; If there is anything to hash this slot on, say so and put it in HASHV. ! 69: (defmacro hashablevalue (slotnum item defblock hashinfo) ! 70: `(not (memq (setq hashv (gethashvalue ,slotnum ,item ,defblock ,hashinfo)) ! 71: *unhashablevalues*))) ! 72: ! 73: ; If this slot is to take part in a hashing combination, (and it is the ! 74: ; second one in :: or ** hashing), then add it to the right hash bucket. ! 75: (dm hashslot (none) ! 76: '(cond ((\=& 0 hashinfo) nil) ; No hashing to be done ! 77: ((hashablevalue slotnum item defblock hashinfo) ; Sets HASHV ! 78: (and (gethash* hashinfo) ! 79: (puthash2 unique hashv db2 item)) ! 80: ; (and (gethash: hashinfo) ! 81: ; (puthash1 hashv db1 item)) ! 82: (and (gethash** hashinfo) ! 83: (cond ((null mark**) ! 84: ; First one found. ! 85: (setq mark** hashv)) ! 86: ; Second one found ! 87: ((neq t mark**) ! 88: (puthash3 unique mark** hashv db2 item) ! 89: (setq mark** t)) ! 90: ; Third or greater found. ! 91: ( t (msg t "HASH: More than two **'s in: " ! 92: (getpname defblock) t)))) ! 93: ; (and (gethash:: hashinfo) ! 94: ; (cond ((null mark::) ! 95: ; ; First one found. ! 96: ; (setq mark:: hashv)) ! 97: ; ; Second one found ! 98: ; ((neq t mark::) ! 99: ; (puthash2 mark:: hashv db2 item) ! 100: ; (setq mark:: t)) ! 101: ; ; Third or greater found. ! 102: ; ( t (msg t "HASH: More than two ::'s in: " ! 103: ; (getpname defblock) t)))) ! 104: (and (gethash*** hashinfo) ! 105: (cond ((null mark***) ! 106: ; First one found. ! 107: (setq mark*** (ncons hashv))) ! 108: ; Later ones found. ! 109: ( t (tconc mark*** hashv)))) ! 110: ))) ! 111: ! 112: ; For each of the four ways of hashing, or else just based on the type, ! 113: ; check to see if the pattern can be hashed that way and if so, ! 114: ; RETURN the right hashbucket. If the previous one can't be done, ! 115: ; try the next one but stop with the first that can be done. ! 116: ; The order is ***, **, ::, &&, *, and :. ! 117: (dm insidestandardfetch (none) ! 118: '(cond ((prog2 ! 119: (for slotnum 1 length ! 120: (and (gethash*** (hashinfo slotnum)) ! 121: (cond ((eq (punbound) ! 122: (setq hashv (slotval slotnum))) ! 123: (setq mark nil) ! 124: (return nil)) ! 125: ((null mark) ! 126: (setq mark (ncons nil)) ! 127: (tconc mark hashv) ! 128: nil) ! 129: ( t (tconc mark hashv))))) ! 130: mark) ! 131: (gethashmulti unique (car mark) db2)) ! 132: ((for slotnum 1 length ! 133: (and (gethash** (hashinfo slotnum)) ! 134: (cond ((eq (punbound) ! 135: (setq hashv (slotval slotnum))) ! 136: (return nil)) ! 137: ((null mark) (setq mark hashv) nil) ! 138: ( t (return (gethash3 unique mark hashv db2))))))) ! 139: ; ((for slotnum 1 length ! 140: ; (and (gethash:: (hashinfo slotnum)) ! 141: ; (cond ((eq (punbound) ! 142: ; (setq hashv (slotval slotnum))) ! 143: ; (return nil)) ! 144: ; ((null mark) (setq mark hashv) nil) ! 145: ; ( t (return (gethash2 mark hashv db2))))))) ! 146: ((and (not (\=& 0 focus)) ! 147: (pboundp (setq hashv (slotval focus)))) ! 148: (recursetoinsidestandardfetch (getslotvalue focus item) db1 db2)) ! 149: ((for slotnum 1 length ! 150: (and (gethash* (hashinfo slotnum)) ! 151: (and (pboundp (setq hashv ! 152: (slotval slotnum))) ! 153: (return (gethash2 unique hashv db2)))))) ! 154: ; ((for slotnum 1 length ! 155: ; (and (gethash: (hashinfo slotnum)) ! 156: ; (and (pboundp (setq hashv ! 157: ; (slotval slotnum))) ! 158: ; (return (gethash1 hashv db1)))))) ! 159: ( t (gethash1 unique db1)))) ! 160: ! 161: (de recursetoinsidestandardfetch (item db1 db2) ! 162: (let* ((defblock (getdefinition item)) ! 163: (length (getstructlength defblock)) ! 164: (*slotvalues* (makhunk (1+ length))) ! 165: (*hashingmarks* (makhunk (1+ length))) ! 166: (unique (getuniquenum defblock)) ! 167: mark hashv focus hashinfo) ! 168: (setq focus (gethashfocus defblock)) ! 169: (for slotnum 1 length ! 170: (setq hashinfo (gethashinfo slotnum defblock)) ! 171: (sethashinfo slotnum hashinfo) ! 172: (or (and (\=& 0 hashinfo) ! 173: (not (\=& focus slotnum))) ! 174: (storeslot slotnum ! 175: (gethashvalue slotnum item defblock hashinfo)))) ! 176: (insidestandardfetch))) ! 177: ! 178: ; Return a pair consisting of the ITEM and a hash-bucket-list that should ! 179: ; have what we are looking for in it. ! 180: (de standardfetch (item &optional (db *db*)) ! 181: (cond ((get (pname item) 'functionstruct) ! 182: (cons '*stream* (cons t item))) ! 183: ( t (prog (mark defblock bucket db1 db2 hashv result focus ! 184: length hashinfo unique) ! 185: (setq defblock (getdefinition item)) ! 186: (setq *currentpearlstructure* item) ! 187: (checkrunhandlebasehooks1 '<fetch *runfetchhooks*) ! 188: (setq db1 (getdb1 db)) ! 189: (setq db2 (getdb2 db)) ! 190: (setq length (getstructlength defblock)) ! 191: (setq focus (gethashfocus defblock)) ! 192: (for slotnum 1 length ! 193: (setq hashinfo (gethashinfo slotnum defblock)) ! 194: (sethashinfo slotnum hashinfo) ! 195: (or (and (\=& 0 hashinfo) ! 196: (not (\=& focus slotnum))) ! 197: (storeslot slotnum ! 198: (gethashvalue slotnum item ! 199: defblock hashinfo)))) ! 200: (setq unique (getuniquenum defblock)) ! 201: (setq bucket (insidestandardfetch)) ! 202: (checkrunhandlebasehooks1 '>fetch *runfetchhooks*) ! 203: (return (cons '*stream* (cons item bucket))))))) ! 204: ! 205: (aliasdef 'fetch 'standardfetch) ! 206: ! 207: (de expandedfetch (item &optional (db *db*)) ! 208: (cond ((get (pname item) 'functionstruct) ! 209: (cons '*stream* (cons t item))) ! 210: ( t (prog (mark defblock defblocklist buckets db1 db2 hashv result ! 211: focus length hashinfo) ! 212: (setq defblock (getdefinition item)) ! 213: (setq *currentpearlstructure* item) ! 214: (checkrunhandlebasehooks1 '<fetch *runfetchhooks*) ! 215: (setq db1 (getdb1 db)) ! 216: (setq db2 (getdb2 db)) ! 217: (setq length (getstructlength defblock)) ! 218: (setq focus (gethashfocus defblock)) ! 219: (for slotnum 1 length ! 220: (setq hashinfo (gethashinfo slotnum defblock)) ! 221: (sethashinfo slotnum hashinfo) ! 222: (or (and (\=& 0 hashinfo) ! 223: (not (\=& focus slotnum))) ! 224: (storeslot slotnum ! 225: (gethashvalue slotnum item ! 226: defblock hashinfo)))) ! 227: (setq defblocklist (cons defblock ! 228: (getexpansionlist defblock))) ! 229: ; Note that instead of being one list, buckets is a ! 230: ; list of lists. ! 231: (setq buckets ! 232: (mapcar ! 233: (funl (expandeddefblock) ! 234: (let ((unique (getuniquenum expandeddefblock))) ! 235: (insidestandardfetch))) ! 236: defblocklist)) ! 237: (dremove nil buckets) ! 238: (checkrunhandlebasehooks1 '>fetch *runfetchhooks*) ! 239: (return (cons '*stream* (cons item buckets))))))) ! 240: ! 241: ; Find the object EVERYWHERE it might be: ; (Well, only 1 for each hash method). ! 242: ; For each of the four ways of hashing, plus just based on the type, ! 243: ; check to see if the pattern can be hashed that way and if so, ! 244: ; return the right hash bucket. A list of these lists is made. ! 245: ; NIL's are removed in the main function. ! 246: ; The order is ***, **, ::, &&, *, and :. ! 247: (dm insidefetcheverywhere (none) ! 248: '(let ((bucketlist (ncons nil))) ! 249: (for slotnum 1 length ! 250: (and (gethash*** (hashinfo slotnum)) ! 251: (cond ((eq (punbound) ! 252: (setq hashv (slotval slotnum))) ! 253: (setq mark nil) ! 254: (return nil)) ! 255: ((null mark) (setq mark (ncons hashv)) nil) ! 256: ( t (tconc mark hashv))))) ! 257: (and mark ! 258: (tconc bucketlist ! 259: (gethashmulti unique (car mark) db2)) ! 260: (setq mark nil)) ! 261: (for slotnum 1 length ! 262: (and (gethash** (hashinfo slotnum)) ! 263: (cond ((eq (punbound) ! 264: (setq hashv (slotval slotnum))) ! 265: (return nil)) ! 266: ((null mark) (setq mark hashv) nil) ! 267: ( t (tconc bucketlist ! 268: (gethash3 unique mark hashv db2)) ! 269: (setq mark nil) ! 270: (return nil))))) ! 271: (and (not (\=& 0 focus)) ! 272: (pboundp (setq hashv (slotval focus))) ! 273: (tconc bucketlist ! 274: (recursetoinsidestandardfetch (getslotvalue focus item) ! 275: db1 db2))) ! 276: (for slotnum 1 length ! 277: (and (gethash* (hashinfo slotnum)) ! 278: (and (pboundp (setq hashv ! 279: (slotval slotnum))) ! 280: (tconc bucketlist ! 281: (gethash2 unique hashv db2))))) ! 282: (tconc bucketlist ! 283: (gethash1 unique db1)) ! 284: (car bucketlist))) ! 285: ! 286: ; Return a list consisting of the ITEM and a list of hash-bucket-list ! 287: ; that must have what we are looking for in it if it's there. ! 288: (de fetcheverywhere (item &optional (db *db*)) ! 289: (cond ((get (pname item) 'functionstruct) ! 290: (cons '*stream* (cons t item))) ! 291: ( t (prog (mark defblock buckets db1 db2 hashv result focus ! 292: length hashinfo unique) ! 293: (setq defblock (getdefinition item)) ! 294: (setq length (getstructlength defblock)) ! 295: (setq focus (gethashfocus defblock)) ! 296: (for slotnum 1 length ! 297: (setq hashinfo (gethashinfo slotnum defblock)) ! 298: (sethashinfo slotnum hashinfo) ! 299: (or (and (\=& 0 hashinfo) ! 300: (not (\=& focus slotnum))) ! 301: (storeslot slotnum ! 302: (gethashvalue slotnum item ! 303: defblock hashinfo)))) ! 304: (setq *currentpearlstructure* item) ! 305: (checkrunhandlebasehooks1 '<fetch *runfetchhooks*) ! 306: (setq db1 (getdb1 db)) ! 307: (setq db2 (getdb2 db)) ! 308: (setq unique (getuniquenum defblock)) ! 309: (setq buckets (insidefetcheverywhere)) ! 310: (dremove nil buckets) ! 311: (checkrunhandlebasehooks1 '>fetch *runfetchhooks*) ! 312: (return (cons '*stream* (cons item buckets))))))) ! 313: ! 314: ; Discover if a hash alias is to be used. ! 315: (dm noalias (none) ! 316: '(cond ((>& alias 0) ! 317: (cond ((gethash< hashinfo) ! 318: (cond ((gethash> hashinfo) nil) ; < > cancels ! 319: ( t t))) ! 320: ( t nil))) ! 321: ( t (cond ((gethash< hashinfo) t) ! 322: ( t (cond ((gethash> hashinfo) nil) ; < > cancels ! 323: ( t t))))))) ! 324: ! 325: ; Get the value that should be hashed for the given slot of ITEM ! 326: ; else return unbound. ! 327: (de gethashvalue (slotnum item defblock hashinfo) ! 328: (let ! 329: ((potential (getvalue slotnum item)) ! 330: alias) ! 331: (cond ((null potential) nil) ! 332: ((pboundp potential) ! 333: (let ((potdef (getdefinition potential))) ! 334: (selectq (getslottype slotnum defblock) ! 335: (0 (setq alias (gethashalias potdef)) ! 336: (cond ((or (noalias) ! 337: (\=& 0 alias)) ! 338: (getuniquenum potdef)) ! 339: ( t ! 340: (setq alias (abs alias)) ! 341: (gethashvalue alias potential potdef ! 342: (gethashinfo alias potdef))))) ! 343: (1 (getuniquenum potential)) ; Symbol. ! 344: (2 potential) ; Integer. ! 345: (3 (punbound)) ; Lisp not hashed. ! 346: (otherwise nil)))) ; SetOf not hashed (YET). ! 347: ( t (punbound))))) ! 348: ! 349: ; Fetch the first item matching the pattern. ! 350: (defmacro firstfetch (pattern) ! 351: `(nextitem (fetch ,pattern))) ! 352: ! 353: (defmacro fetchcreate (&rest rest) ! 354: `(fetch (create .,rest))) ! 355: ! 356: (defmacro inlinefetchcreate (&rest rest) ! 357: `(fetch (quote ,(create rest)))) ! 358: ! 359: (defmacro inlinecreate (&rest rest) ! 360: `(quote ,(create rest))) ! 361: ! 362: ; Build a value to pass to the function for the parameter for this slot. ! 363: (dm fcnslot (none) ! 364: '(let ((slotv (getvalue slotnum item)) ! 365: (type (getslottype slotnum defblock))) ! 366: (cond ((eq slotv (punbound)) (punbound)) ! 367: ((and (<& type 4) ! 368: (or (not (\=& 0 type)) ! 369: (not (get (getpname (getdefinition slotv)) ! 370: 'functionstruct)))) slotv) ! 371: ((\=& 0 type) ! 372: (evalfcn slotv)) ! 373: ((\=& 0 (boole 1 3 type)) ! 374: (mapcar (function evalfcn) slotv)) ! 375: ( t slotv)))) ! 376: ! 377: ; Evaluate a function structure. ! 378: (de evalfcn (item) ! 379: (cond ((dtpr item) (mapcar (function evalfcn) item)) ! 380: ((not (get (getpname (getdefinition item)) 'functionstruct)) item) ! 381: ( t (let* ((defblock (getdefinition item)) ! 382: (length (getstructlength defblock)) ! 383: (fcncall (ncons nil)) ! 384: slotv) ! 385: (tconc fcncall (getpname defblock)) ! 386: (for slotnum 1 length ! 387: (tconc fcncall (fcnslot))) ! 388: (apply* (caar fcncall) (cdar fcncall)))))) ! 389: ! 390: ; A kludge to be removed (with disguisedas) when we implement VIEWS. ! 391: (defmacro getstructorsymnum (strsym) ! 392: `(cond ((psymbolp ,strsym) (getuniquenum ,strsym)) ! 393: ( t (getuniquenum (getdefinition ,strsym))))) ! 394: ! 395: ; (DISGUISEDAS Filler Struct DB) means "Is filler a struct? ! 396: ; if there is an item in the data base DB of the form ! 397: ; (STRUCT (<first slot> FILLER) ... ) ! 398: ; then return it. If not, return NIL. ! 399: (de disguisedas (filler struct &optional (db *db*)) ! 400: (prog (fillernum bucket db2 item value) ! 401: (setq db2 (getdb2 db)) ! 402: (setq fillernum (getstructorsymnum filler)) ! 403: (setq bucket (remq '*db* ! 404: (gethash2 (getuniquenum struct) fillernum db2))) ! 405: loop ! 406: (cond ((null bucket) (return nil)) ! 407: ((and (eq struct (getdefinition (setq item (pop bucket)))) ! 408: (neq (punbound) (setq value (getvalue 1 item))) ! 409: (eq (getstructorsymnum value) fillernum)) ! 410: (return item)) ! 411: ( t (go loop))))) ! 412: ! 413: (de insertbyfocus (focus item db1 db2) ! 414: (prog (unique mark** mark:: mark*** defblock ! 415: value hashinfo hashv focusslotnum) ! 416: (setq defblock (getdefinition focus)) ! 417: (setq unique (getuniquenum defblock)) ! 418: (puthash1 unique db1 item) ! 419: (and (not (\=& 0 (setq focusslotnum (gethashfocus defblock)))) ! 420: (pboundp (setq value (getvalue focusslotnum focus))) ! 421: (insertbyfocus value item db1 db2)) ! 422: (for slotnum 1 (getstructlength defblock) ! 423: (setq hashinfo (gethashinfo slotnum defblock)) ! 424: (cond ((\=& 0 hashinfo) nil) ! 425: ((hashablevalue slotnum focus defblock hashinfo) ; Sets HASHV ! 426: (and (gethash* hashinfo) ! 427: (puthash2 unique hashv db2 item)) ! 428: ; (and (gethash: hashinfo) ! 429: ; (puthash1 hashv db1 item)) ! 430: (and (gethash** hashinfo) ! 431: (cond ((null mark**) ! 432: ; First one found. ! 433: (setq mark** hashv)) ! 434: ; Second one found ! 435: ((neq t mark**) ! 436: (puthash3 unique mark** hashv db2 item) ! 437: (setq mark** t)) ! 438: ; Third or greater found. ! 439: ( t (msg t "HASH: More than two **'s in: " ! 440: (getpname defblock) t)))) ! 441: ; (and (gethash:: hashinfo) ! 442: ; (cond ((null mark::) ! 443: ; ; First one found. ! 444: ; (setq mark:: hashv)) ! 445: ; ; Second one found ! 446: ; ((neq t mark::) ! 447: ; (puthash2 mark:: hashv db2 item) ! 448: ; (setq mark:: t)) ! 449: ; ; Third or greater found. ! 450: ; ( t (msg t "HASH: More than two ::'s in: " ! 451: ; (getpname defblock) t)))) ! 452: (and (gethash*** hashinfo) ! 453: (cond ((null mark***) ! 454: ; First one found. ! 455: (setq mark*** (ncons hashv))) ! 456: ; Later ones found. ! 457: ( t (tconc mark*** hashv)))) ! 458: ))) ! 459: (and mark*** ! 460: (puthashmulti unique (car mark***) db2 item)))) ! 461: ! 462: ; We must put this struct into the data base somewhere, ! 463: ; perhaps in several places. ! 464: (de insertdb (item &optional (db *db*)) ! 465: (or item ! 466: (progn (msg t "Trying to INSERTDB a nil item: " item t) ! 467: (pearlbreak))) ! 468: (and (dtpr item) ! 469: (progn (msg t "Trying to INSERTDB a cons-cell: " item t) ! 470: (pearlbreak))) ! 471: (cond ((get (getpname (getdefinition item)) 'functionstruct) ! 472: (evalfcn item)) ! 473: ( t ! 474: (prog (unique mark** mark:: mark*** defblock db1 db2 ! 475: value hashinfo hashv result focus) ! 476: (setq defblock (getdefinition item)) ! 477: (setq *currentpearlstructure* item) ! 478: (checkrunhandlebasehooks1 '<insertdb *runinsertdbhooks*) ! 479: (setq unique (getuniquenum defblock)) ! 480: (setq db1 (getdb1 db)) ! 481: (setq db2 (getdb2 db)) ! 482: (puthash1 unique db1 item) ! 483: (and (not (\=& 0 (setq focus (gethashfocus defblock)))) ! 484: (pboundp (setq value (getvalue focus item))) ! 485: (insertbyfocus value item db1 db2)) ! 486: ! 487: (for slotnum 1 (getstructlength defblock) ! 488: (setq hashinfo (gethashinfo slotnum defblock)) ! 489: (hashslot)) ! 490: (and mark*** ! 491: (puthashmulti unique (car mark***) db2 item)) ! 492: (checkrunhandlebasehooks1 '>insertdb *runinsertdbhooks*) ! 493: (return item))))) ! 494: ! 495: ; For each way that this slot can be hashed, destructively remove the ! 496: ; item from the correct bucket. Expects SLOTNUM, DEFBLOCK, ITEM, ! 497: ; MARK**, MARK::, MARK***, HASHV, UNIQUE, DB1, DB2. ! 498: (dm removeslot (none) ! 499: '(cond ((\=& 0 hashinfo) nil) ; No hashing to be done ! 500: ((hashablevalue slotnum item defblock hashinfo) ; Sets HASHV ! 501: (and (gethash* hashinfo) ! 502: (delq item (gethash2 unique hashv db2))) ! 503: ; (and (gethash: hashinfo) ! 504: ; (delq item (gethash1 hashv db1))) ! 505: (and (gethash** hashinfo) ! 506: (cond ((null mark**) ! 507: (setq mark** hashv)) ! 508: ((neq t mark**) ! 509: (delq item (gethash3 unique mark** hashv db2)) ! 510: (setq mark** t)) ! 511: ( t (msg t "More than two **'s in: " ! 512: (getpname defblock) t)))) ! 513: ; (and (gethash:: hashinfo) ! 514: ; (cond ((null mark::) ! 515: ; (setq mark:: hashv)) ! 516: ; ((neq t mark::) ! 517: ; (delq item (gethash2 mark:: hashv db2)) ! 518: ; (setq mark:: t)) ! 519: ; ( t (msg t "More than two ::'s in: " ! 520: ; (getpname defblock) t)))) ! 521: (and (gethash*** hashinfo) ! 522: (cond ((null mark***) ! 523: ; First one found. ! 524: (setq mark*** (ncons hashv))) ! 525: ; Later ones found. ! 526: ( t (tconc mark*** hashv)))) ! 527: ))) ! 528: ! 529: (de removebyfocus (focus item db1 db2) ! 530: (prog (unique mark** mark:: mark*** defblock hashinfo hashv focusslotnum) ! 531: (setq defblock (getdefinition focus)) ! 532: (setq unique (getuniquenum defblock)) ! 533: (dremove item (gethash1 unique db1)) ! 534: (and (not (\=& 0 (setq focusslotnum (gethashfocus defblock)))) ! 535: (removebyfocus (getvalue focusslotnum focus) item db1 db2)) ! 536: (for slotnum 1 (getstructlength defblock) ! 537: (setq hashinfo (gethashinfo slotnum defblock)) ! 538: (cond ((\=& 0 hashinfo) nil) ! 539: ((hashablevalue slotnum focus defblock hashinfo) ; Sets HASHV ! 540: (and (gethash* hashinfo) ! 541: (delq item (gethash2 unique hashv db2))) ! 542: ; (and (gethash: hashinfo) ! 543: ; (delq item (gethash1 hashv db1))) ! 544: (and (gethash** hashinfo) ! 545: (cond ((null mark**) ! 546: (setq mark** hashv)) ! 547: ((neq t mark**) ! 548: (delq item (gethash3 unique mark** hashv db2)) ! 549: (setq mark** t)) ! 550: ( t (msg t "More than two **'s in: " ! 551: (getpname defblock) t)))) ! 552: ; (and (gethash:: hashinfo) ! 553: ; (cond ((null mark::) ! 554: ; (setq mark:: hashv)) ! 555: ; ((neq t mark::) ! 556: ; (delq item (gethash2 mark:: hashv db2)) ! 557: ; (setq mark:: t)) ! 558: ; ( t (msg t "More than two ::'s in: " ! 559: ; (getpname defblock) t)))) ! 560: (and (gethash*** hashinfo) ! 561: (cond ((null mark***) ! 562: ; First one found. ! 563: (setq mark*** (ncons hashv))) ! 564: ; Later ones found. ! 565: ( t (tconc mark*** hashv)))) ! 566: ))) ! 567: (and mark*** ! 568: (delq item (gethashmulti unique mark*** db2))) ! 569: )) ! 570: ! 571: ; We may have to remove this struct from several places so look ! 572: ; every place it might have been hashed. ! 573: (de removedb (item &optional (db *db*)) ! 574: (or item ! 575: (progn (msg t "Trying to REMOVEDB a nil item: " item t) ! 576: (pearlbreak))) ! 577: (and (dtpr item) ! 578: (progn (msg t "Trying to REMOVEDB a cons-cell: " item t) ! 579: (pearlbreak))) ! 580: (or (structurep item) ! 581: (progn (msg t "Trying to REMOVEDB a non-structure: " item t) ! 582: (pearlbreak))) ! 583: (cond ((get (getpname (getdefinition item)) 'functionstruct) nil) ! 584: ( t ! 585: (prog (unique mark** mark:: mark*** defblock db1 db2 ! 586: hashinfo hashv result focus) ! 587: (setq defblock (getdefinition item)) ! 588: (setq *currentpearlstructure* item) ! 589: (checkrunhandlebasehooks1 '<removedb *runremovedbhooks*) ! 590: (setq unique (getuniquenum defblock)) ! 591: (or db ! 592: (setq db *db*)) ! 593: (setq db1 (getdb1 db)) ! 594: (setq db2 (getdb2 db)) ! 595: (delq item (gethash1 unique db1)) ! 596: (and (not (\=& 0 (setq focus (gethashfocus defblock)))) ! 597: (removebyfocus (getvalue focus item) item db1 db2)) ! 598: (for slotnum 1 (getstructlength defblock) ! 599: (setq hashinfo (gethashinfo slotnum defblock)) ! 600: (removeslot)) ! 601: (and mark*** ! 602: (delq item (gethashmulti unique mark*** db2))) ! 603: (checkrunhandlebasehooks1 '>removedb *runremovedbhooks*) ! 604: (return item))))) ! 605: ! 606: ; Find the next item on the CDDR list of the stream that is STREQUAL to ! 607: ; the CADR of the stream and return it, also updating the stream. ! 608: (de nextequal (stream) ! 609: (or (streamp stream) ! 610: (progn (msg t "NEXTEQUAL: not a stream: " stream t) ! 611: (pearlbreak))) ! 612: (setq stream (cdr stream)) ; Throw away the *STREAM*. ! 613: (cond ((eq t (car stream)) ; This means function structure. ! 614: (prog1 (evalfcn (cdr stream)) ! 615: (rplacd (rplaca stream nil) nil))) ! 616: ((null (cadr stream)) nil) ; Test for empty stream ! 617: ; Stream built by standardfetch. ! 618: ; To debug or modify this, you must draw a picture of what ! 619: ; standardfetch built because of the way it is written. ! 620: ((not (dtpr (cadr stream))) ! 621: (prog (item result) ! 622: (setq item (car stream)) ! 623: (setq *currentpearlstructure* item) ! 624: (checkrunhandlebasehooks1 '<nextequal *runnextequalhooks*) ! 625: (while (and (cdr stream) ! 626: (or (eq (cadr stream) '*db*) ! 627: (not (strequal item (cadr stream))))) ! 628: (rplacd stream (cddr stream))) ! 629: (cond ((cadr stream) ! 630: (setq item (cadr stream))) ! 631: ( t (setq item nil))) ! 632: (rplacd stream (cddr stream)) ! 633: (checkrunhandlebasehooks1 '>nextequal *runnextequalhooks*) ! 634: (return item))) ! 635: ; Stream built by expandedfetch (or fetcheverywhere). ! 636: ; To debug or modify this, you must draw a picture of what ! 637: ; expandedfetch built because of the way it is written. ! 638: ((not (dtpr (caadr stream))) ! 639: (prog (item result) ! 640: (setq item (car stream)) ! 641: (setq *currentpearlstructure* item) ! 642: (checkrunhandlebasehooks1 '<nextequal *runnextequalhooks*) ! 643: (while (and (cdr stream) ! 644: (or (eq (caadr stream) '*db*) ! 645: (not (strequal item (caadr stream))))) ! 646: (or (car (rplaca (cdr stream) (cdadr stream))) ! 647: (rplacd stream (cddr stream)))) ! 648: (cond ((cadr stream) ! 649: (setq item (caadr stream))) ! 650: ( t (setq item nil))) ! 651: (or (not (cdr stream)) ! 652: (car (rplaca (cdr stream) (cdadr stream))) ! 653: (rplacd stream (cddr stream))) ! 654: (checkrunhandlebasehooks1 '>nextequal *runnextequalhooks*) ! 655: (return item))))) ! 656: ! 657: ; Find out if an EQUAL ITEM is in the DB by using FETCH and then ! 658: ; applying NEXTEQUAL. ! 659: (de indb (item &optional (db *db*)) ! 660: (prog (result newitem answer) ! 661: (setq *currentpearlstructure* item) ! 662: (checkrunhandlebasehooks1 '<indb *runindbhooks*) ! 663: (setq newitem nil) ! 664: (and (setq answer (nextequal (fetch item db))) ! 665: (setq newitem (setq item answer))) ! 666: (checkrunhandlebasehooks1 '>indb *runindbhooks*) ! 667: (and newitem ! 668: (neq item newitem) ! 669: (setq answer item)) ! 670: (return answer))) ! 671: ! 672: ; (FOREACH STREAM FCN) applies FCN to each element returned by ! 673: ; NEXTITEM from STREAM. ! 674: (df foreach (l) ! 675: (let ((stream (eval (car l))) ! 676: (fcn (cadr l)) ! 677: item) ! 678: (while (setq item (nextitem stream)) ! 679: (apply* fcn (ncons item))))) ! 680: ! 681: ; Convert a stream to a list of actual matchers. ! 682: (de streamtolist (stream) ! 683: (let ((result (ncons nil)) ! 684: item) ! 685: (while (setq item (nextitem stream)) ! 686: (tconc result item)) ! 687: (car result))) ! 688: ! 689: ! 690: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.