Return to db.l CVS log

Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / pearl

Annotation of 42BSD/ucb/lisp/pearl/db.l, revision 1.1

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.