;;;;;;;;;;;;;;;;;;;;;;;;;;;;; db.l ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Functions for building and releasing a forest of data bases.
;    See the file "template" plus the discussion in the "lowlevel.l" file for
;        a picture and an idea of how data bases are arranged internally.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Copyright (c) 1983 ,  The Regents of the University of California.
; All rights reserved.  
; Authors: Joseph Faletti and Michael Deering.

; Clear out the *db* conscells in the two parts of the data base,
;    thus releasing the old buckets for GC, IF they aren't pointed
;    to from elsewhere.
(de cleardb (&optional (db *db*))
  (let ((parent (getdbparent db))
	(db1 (getdb1 db))
	(db2 (getdb2 db)))
       (cond (parent (connectdb db parent))
	     (  t  (for slotnum 0 (1- *db1size*)
			(rplacd (cxr slotnum db1) nil))
		   (for slotnum 0 (1- *db2size*)
			(rplacd (cxr slotnum db2) nil))))
       t))
 
; Used by builddb to connect the sibling's buckets with its parent's.
; Also used by cleardb on a sibling.
(de connectdb (newdb olddb)
  (let ((newdb1 (getdb1 newdb))
	(newdb2 (getdb2 newdb))
	(olddb1 (getdb1 olddb))
	(olddb2 (getdb2 olddb)))
       (for slotnum 0 (1- *db1size*)
	    (rplacd (cxr slotnum newdb1) (cxr slotnum olddb1)))
       (for slotnum 0 (1- *db2size*)
	    (rplacd (cxr slotnum newdb2) (cxr slotnum olddb2)))
       t))
 
; Set the size for data bases to 2 to the "poweroftwo" -- actually
;    the next smaller prime number.
;    *Availablesizes* is in inits.l and is designed to
;        make the data bases a factor of 4 apart
;        EXCEPT in Franz, where the largest are equal-sized.
(de setdbsize (poweroftwo)
  (let (pair rebuilddb)
       (and *activedbnames*
	    (progn (and *warn*
			(msg t "SETDBSIZE: Warning: Size change "
			     "is causing the release of all databases."
			     t "     You must rebuild all "
			     "but the default yourself." t))
		   (mapcar (funl (dbname) (releasedb (eval dbname)))
			   (copy *activedbnames*))
		   (setq rebuilddb t)
		   ))
       (and (or (<& poweroftwo 2.)
		(>& poweroftwo 13.))
	    (progn (msg t "SETDBSIZE: Database size is a power to raise 2 to"
			t "    and must be greater than 1 and less than 14."
			t "    It cannot be " poweroftwo "." t)
		   (pearlbreak)))
       (or (setq pair (assq poweroftwo *availablesizes*))
	   (progn (msg t "SETDBSIZE: "
		       "Database sizes are integer powers to raise 2 to." t)
		  (pearlbreak)))
       (setq *db2size* (cdr pair))
       ; The sizes of the two parts of the data base are 
       ;   in a 1 to 4 ratio.
       (setq pair (assq (- poweroftwo 2.) *availablesizes*))
       (setq *db1size* (cdr pair))
       (and rebuilddb
	    (setq *db* (builddb *maindb*)))
       t))
 
; (BUILDDB NEWDB OLDDB)  Build an extension to OLDDB called NEWDB.  If OLDDB
;     is NIL then build at the bottom level, else add as a leaf of the tree.
; The new data base is stored under the atom which is its name,
;     unlike the rest of PEARL objects (i.e., no special-prefix atom).
; Each new leaf has each of its hash buckets tied into the buckets of the
;     parent so that nextitem need not know how many data bases it is
;     dealing with.
(df builddb (l)
  (let ((newdbname (car l))
	(olddbname (cadr l)))
       (and (memq newdbname *activedbnames*)
	    (progn (msg t "BUILDDB: " newdbname
			" is already an active database name." t)
		   (pearlbreak)))
       (and olddbname
	    ; Two db's given but old one bad.
	    (not (memq olddbname *activedbnames*))
	    (progn (msg t "BUILDDB: " olddbname
			" is not an active database name." t)
		   (pearlbreak)))
       (let ((newdb (makhunk 7))
	     (olddb (and olddbname
			 (eval olddbname)))
	     (db1 (makhunk *db1size*))
	     (db2 (makhunk *db2size*)))
	    (push newdbname *activedbnames*)
	    (putdbname newdbname newdb)
	    (set newdbname newdb)
	    (puttypetag '*pearldb* newdb)
	    (putdbchildren nil newdb)
	    (setdbactive newdb)
	    (putdbparent olddb newdb)
	    (putdb1 db1 newdb)
	    (putdb2 db2 newdb)
	    ; add the *db* conscells.
	    (for slotnum 0 (1- *db1size*)
		 (rplacx slotnum db1 (cons '*db* nil)))
	    (for slotnum 0 (1- *db2size*)
		 (rplacx slotnum db2 (cons '*db* nil)))
	    (and olddb ; Two db's.
		 ; add to parent's children.
		 (putdbchildren (cons newdb (getdbchildren olddb))
				olddb)
		 ; Connectdb does the extra work for adding to the tree.
		 (connectdb newdb olddb))
	    newdb)))
 
; Release a data base.   If its children are also released, then
;    it can be garbage collected.  If not, do not mark it inactive
;    until they are.
(de releasedb (db)
  (and (not (databasep db))
       (progn (msg t "RELEASEDB: Argument is not a database." t)
	      (pearlbreak)))
  (let ((dbname (getdbname db))
	(parent (getdbparent db)))
       (and (not (memq dbname *activedbnames*))
	    (progn (msg t "RELEASEDB: Trying to release an inactive database: "
			db t)
		   (pearlbreak)))
       (cond ((null (getdbchildren db))    ; No children.
	      (setq *activedbnames* (delq (getdbname db) *activedbnames*))
	      (and (equal *activedbnames* '(nil))
		   (setq *activedbnames* nil))
	      (set dbname (unbound))
	      (putdbname nil db)
	      (and parent
		   (putdbchildren (delq db (getdbchildren parent)) parent))
	      (cleardbactive db)
	      (putdbparent nil db)
	      (while (and parent                        ; There's a parent --
			  (null (getdbchildren parent)) ; with 0 children --
			  (not (getdbactive parent)))   ; that's inactive.
		     (cleardb parent)
		     (putdb1 nil parent)
		     (putdb2 nil parent)
		     ; Save next parent with prog1 and then remove self from
		     ; parent's child list and clear out own parent pointer
		     (setq parent
			   (prog1
			    (getdbparent parent)  ; To be the new parent
			    (and (getdbparent parent)
				 (putdbchildren
				  (delq parent
					(getdbchildren (getdbparent parent)))
				  (getdbparent parent))
				 )
			    (putdbparent nil parent))))
	      (cleardb db)
	      (puttypetag '*pearlinactivedb* db)
	      (putdb1 nil db)
	      (putdb2 nil db))
	     ( t (setq *activedbnames* (delq dbname *activedbnames*))
		 (and (equal *activedbnames* '(nil))
		      (setq *activedbnames* nil))
		 (set dbname (unbound))
		 (putdbname nil db)
		 (cleardbactive db)
		 (puttypetag '*pearlinactivedb* db)
		 (putdb1 nil db)
		 (putdb2 nil db)))
       t))
 

; vi: set lisp: