![[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] / 43BSDTahoe / ucb / lisp / pearl|
Return to hash.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / 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.