![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to db.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 db.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl |
1.1 root 1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; db.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2: ; Functions for building and releasing a forest of data bases.
3: ; See the file "template" plus the discussion in the "lowlevel.l" file for
4: ; a picture and an idea of how data bases are arranged internally.
5: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6: ; Copyright (c) 1983 , The Regents of the University of California.
7: ; All rights reserved.
8: ; Authors: Joseph Faletti and Michael Deering.
9:
10: ; Clear out the *db* conscells in the two parts of the data base,
11: ; thus releasing the old buckets for GC, IF they aren't pointed
12: ; to from elsewhere.
13: (de cleardb (&optional (db *db*))
14: (let ((parent (getdbparent db))
15: (db1 (getdb1 db))
16: (db2 (getdb2 db)))
17: (cond (parent (connectdb db parent))
18: ( t (for slotnum 0 (1- *db1size*)
19: (rplacd (cxr slotnum db1) nil))
20: (for slotnum 0 (1- *db2size*)
21: (rplacd (cxr slotnum db2) nil))))
22: t))
23:
24: ; Used by builddb to connect the sibling's buckets with its parent's.
25: ; Also used by cleardb on a sibling.
26: (de connectdb (newdb olddb)
27: (let ((newdb1 (getdb1 newdb))
28: (newdb2 (getdb2 newdb))
29: (olddb1 (getdb1 olddb))
30: (olddb2 (getdb2 olddb)))
31: (for slotnum 0 (1- *db1size*)
32: (rplacd (cxr slotnum newdb1) (cxr slotnum olddb1)))
33: (for slotnum 0 (1- *db2size*)
34: (rplacd (cxr slotnum newdb2) (cxr slotnum olddb2)))
35: t))
36:
37: ; Set the size for data bases to 2 to the "poweroftwo" -- actually
38: ; the next smaller prime number.
39: ; *Availablesizes* is in inits.l and is designed to
40: ; make the data bases a factor of 4 apart
41: ; EXCEPT in Franz, where the largest are equal-sized.
42: (de setdbsize (poweroftwo)
43: (let (pair rebuilddb)
44: (and *activedbnames*
45: (progn (and *warn*
46: (msg t "SETDBSIZE: Warning: Size change "
47: "is causing the release of all databases."
48: t " You must rebuild all "
49: "but the default yourself." t))
50: (mapcar (funl (dbname) (releasedb (eval dbname)))
51: (copy *activedbnames*))
52: (setq rebuilddb t)
53: ))
54: (and (or (<& poweroftwo 2.)
55: (>& poweroftwo 13.))
56: (progn (msg t "SETDBSIZE: Database size is a power to raise 2 to"
57: t " and must be greater than 1 and less than 14."
58: t " It cannot be " poweroftwo "." t)
59: (pearlbreak)))
60: (or (setq pair (assq poweroftwo *availablesizes*))
61: (progn (msg t "SETDBSIZE: "
62: "Database sizes are integer powers to raise 2 to." t)
63: (pearlbreak)))
64: (setq *db2size* (cdr pair))
65: ; The sizes of the two parts of the data base are
66: ; in a 1 to 4 ratio.
67: (setq pair (assq (- poweroftwo 2.) *availablesizes*))
68: (setq *db1size* (cdr pair))
69: (and rebuilddb
70: (setq *db* (builddb *maindb*)))
71: t))
72:
73: ; (BUILDDB NEWDB OLDDB) Build an extension to OLDDB called NEWDB. If OLDDB
74: ; is NIL then build at the bottom level, else add as a leaf of the tree.
75: ; The new data base is stored under the atom which is its name,
76: ; unlike the rest of PEARL objects (i.e., no special-prefix atom).
77: ; Each new leaf has each of its hash buckets tied into the buckets of the
78: ; parent so that nextitem need not know how many data bases it is
79: ; dealing with.
80: (df builddb (l)
81: (let ((newdbname (car l))
82: (olddbname (cadr l)))
83: (and (memq newdbname *activedbnames*)
84: (progn (msg t "BUILDDB: " newdbname
85: " is already an active database name." t)
86: (pearlbreak)))
87: (and olddbname
88: ; Two db's given but old one bad.
89: (not (memq olddbname *activedbnames*))
90: (progn (msg t "BUILDDB: " olddbname
91: " is not an active database name." t)
92: (pearlbreak)))
93: (let ((newdb (makhunk 7))
94: (olddb (and olddbname
95: (eval olddbname)))
96: (db1 (makhunk *db1size*))
97: (db2 (makhunk *db2size*)))
98: (push newdbname *activedbnames*)
99: (putdbname newdbname newdb)
100: (set newdbname newdb)
101: (puttypetag '*pearldb* newdb)
102: (putdbchildren nil newdb)
103: (setdbactive newdb)
104: (putdbparent olddb newdb)
105: (putdb1 db1 newdb)
106: (putdb2 db2 newdb)
107: ; add the *db* conscells.
108: (for slotnum 0 (1- *db1size*)
109: (rplacx slotnum db1 (cons '*db* nil)))
110: (for slotnum 0 (1- *db2size*)
111: (rplacx slotnum db2 (cons '*db* nil)))
112: (and olddb ; Two db's.
113: ; add to parent's children.
114: (putdbchildren (cons newdb (getdbchildren olddb))
115: olddb)
116: ; Connectdb does the extra work for adding to the tree.
117: (connectdb newdb olddb))
118: newdb)))
119:
120: ; Release a data base. If its children are also released, then
121: ; it can be garbage collected. If not, do not mark it inactive
122: ; until they are.
123: (de releasedb (db)
124: (and (not (databasep db))
125: (progn (msg t "RELEASEDB: Argument is not a database." t)
126: (pearlbreak)))
127: (let ((dbname (getdbname db))
128: (parent (getdbparent db)))
129: (and (not (memq dbname *activedbnames*))
130: (progn (msg t "RELEASEDB: Trying to release an inactive database: "
131: db t)
132: (pearlbreak)))
133: (cond ((null (getdbchildren db)) ; No children.
134: (setq *activedbnames* (delq (getdbname db) *activedbnames*))
135: (and (equal *activedbnames* '(nil))
136: (setq *activedbnames* nil))
137: (set dbname (unbound))
138: (putdbname nil db)
139: (and parent
140: (putdbchildren (delq db (getdbchildren parent)) parent))
141: (cleardbactive db)
142: (putdbparent nil db)
143: (while (and parent ; There's a parent --
144: (null (getdbchildren parent)) ; with 0 children --
145: (not (getdbactive parent))) ; that's inactive.
146: (cleardb parent)
147: (putdb1 nil parent)
148: (putdb2 nil parent)
149: ; Save next parent with prog1 and then remove self from
150: ; parent's child list and clear out own parent pointer
151: (setq parent
152: (prog1
153: (getdbparent parent) ; To be the new parent
154: (and (getdbparent parent)
155: (putdbchildren
156: (delq parent
157: (getdbchildren (getdbparent parent)))
158: (getdbparent parent))
159: )
160: (putdbparent nil parent))))
161: (cleardb db)
162: (puttypetag '*pearlinactivedb* db)
163: (putdb1 nil db)
164: (putdb2 nil db))
165: ( t (setq *activedbnames* (delq dbname *activedbnames*))
166: (and (equal *activedbnames* '(nil))
167: (setq *activedbnames* nil))
168: (set dbname (unbound))
169: (putdbname nil db)
170: (cleardbactive db)
171: (puttypetag '*pearlinactivedb* db)
172: (putdb1 nil db)
173: (putdb2 nil db)))
174: t))
175:
176:
177: ; vi: set lisp:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.