* interp/lisplib.boot (laodIfNecessaryAndExists): Remove as unused.

	(loadLibIfnecessary): Fold definition into loadIfNecessary.
	(loadDB): New.
	(writeAttributes): Likewise.
	(finalizeLisplib): Use it.
	* interp/daase.lisp (MAKE-DATABASES): Fix SQUEEZE snafu.
	* interp/c-util.boot (extendsCategoryForm): Prefer existing
	translation of category definition to re-evaluation on the fly.

4 files changed, 47 insertions, 12 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 2adf1737..b75e7032 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,16 @@
 2011-08-29  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/lisplib.boot (laodIfNecessaryAndExists): Remove as unused.
+	(loadLibIfnecessary): Fold definition into loadIfNecessary.
+	(loadDB): New.
+	(writeAttributes): Likewise.
+	(finalizeLisplib): Use it.
+	* interp/daase.lisp (MAKE-DATABASES): Fix SQUEEZE snafu.
+	* interp/c-util.boot (extendsCategoryForm): Prefer existing
+	translation of category definition to re-evaluation on the fly.
+
+2011-08-29  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/lisplib.boot	(loadLib): Remove deadcode.
 	(isDomainForm): Tidy.
 	(isFunctor): Likewise.
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 24a3a041..ecc72c79 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1027,7 +1027,14 @@ extendsCategoryForm(domain,form,form') ==
   domain = "$" and form = $definition => 
     extendsCategoryForm(domain, $currentCategoryBody, form')
   isCategoryForm(form,$EmptyEnvironment) =>
-          --Constructs the associated vector
+    -- If we have an existing definition for this category, use it.
+    (db := constructorDB form.op) and loadDB db =>
+      form' is ['SIGNATURE,op,types,:.] => assoc([op,args],dbOperations db)
+      form' is ['ATTRIBUTE,a] => assoc(a,dbAttributes db)
+      subst := pairList(dbConstructorForm(db).args,form.args)
+      or/[extendsCategoryForm(domain,applySubst(subst,cat),form')
+           for [cat,:.] in dbAncestors db]
+    -- Otherwise constructs the associated domain shell
     formVec:=(compMakeCategoryObject(form,$e)).expr
             --Must be $e to pick up locally bound domains
     form' is ["SIGNATURE",op,args,:.] =>
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index 678c390f..f4fad844 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -1242,11 +1242,17 @@
      (when (setq dbstruct (|constructorDB| con))
            (setf (|dbDualSignature| dbstruct)
                  (cons nil (mapcar #'|categoryForm?|
-                                   (cddar (|dbConstructorModemap| dbstruct)))))
-           (when (and (|categoryForm?| con)
+				   ;; The DBs have been munged by SQUEEZE
+				   ;; in WRITE-BROWSEDB, WRITE-OPERATIONDB
+				   ;; WRITE-CATEGORYDB.  Unsqueeze a copy
+				   ;; of them before checking for category
+				   ;; form-ness.  This is sick!  FIXME.
+				   (unsqueeze (copy-tree
+                                   (cddar (|dbConstructorModemap| dbstruct)))))))
+           (when (and (eq (|dbConstructorKind| dbstruct) '|category|)
                       (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1))
                  (setq d (caar d))
-                 (when (= (length d) (length (|getConstructorForm| con)))
+                 (when (= (length d) (length (|dbConstructorForm| dbstruct)))
                        (format t "   ~a has a default domain of ~a~%" con (car d))
                        (setf (|dbDefaultDomain| dbstruct) (car d)))))))
                                         ; note: genCategoryTable creates *ancestors-hash*. write-interpdb
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index de8a2cad..5d1446bc 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -339,18 +339,14 @@ loadLibNoUpdate(cname, libName, fullLibName) ==
   stopTimingProcess 'load
   'T
  
-loadIfNecessary u == loadLibIfNecessary(u,true)
- 
-loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil)
- 
-loadLibIfNecessary(u,mustExist) ==
+loadIfNecessary u ==
   u is '$EmptyMode => u
-  cons? u => loadLibIfNecessary(first u,mustExist)
+  cons? u => loadIfNecessary first u
   value:=
     functionp(u) or macrop(u) => u
     property(u,'LOADED) => u
     loadLib u => u
-  null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame)))
+  not $InteractiveMode and (null (y:= getProplist(u,$CategoryFrame))
     or (null symbolLassoc('isFunctor,y)) and (null symbolLAssoc('isCategory,y))) =>
       y:= getConstructorKindFromDB u =>
          y = "category" =>
@@ -358,6 +354,18 @@ loadLibIfNecessary(u,mustExist) ==
          updateCategoryFrameForConstructor u
       throwKeyedMsg("S2IL0005",[u])
   value
+
+++ Load the module associated with `db' and return the module's path.
+loadDB db ==
+  try
+    startTimingProcess 'load
+    dbBeingDefined? db => nil
+    ctor := dbConstructor db
+    property(ctor,'LOADED) => db  --FIXME: this should be a db operation
+    lib := findModule ctor or return nil
+    loadModule(lib,ctor)
+    property(ctor,'LOADED) := lib
+  finally stopTimingProcess 'load
  
 convertOpAlist2compilerInfo(opalist) ==
    "append"/[[formatSig(op,sig) for sig in siglist]
@@ -548,6 +556,9 @@ writeSuperDomain(ctor,domPred,file) ==
 writeOperations(ctor,ops,file) ==
   writeInfo(ctor,ops,'operationAlist,'dbOperations,file)
 
+writeAttributes(ctor,ats,file) ==
+ writeInfo(ctor,ats,'attributes,'dbAttributes,file)
+
 writeConstructorModemap(ctor,mm,file) ==
   writeInfo(ctor,mm,'constructorModemap,'dbConstructorModemap,file)
 
@@ -590,7 +601,7 @@ finalizeLisplib(ctor,libName) ==
   lisplibWrite('"signaturesAndLocals",
     removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist,
                                     $lisplibVariableAlist),$libFile)
-  lisplibWrite('"attributes",removeZeroOne dbAttributes db,$libFile)
+  writeAttributes(ctor,removeZeroOne dbAttributes db,$libFile)
   lisplibWrite('"predicates",removeZeroOne  $lisplibPredicates,$libFile)
   lisplibWrite('"abbreviation",dbAbbreviation constructorDB ctor,$libFile)
   writePrincipals(ctor,removeZeroOne $lisplibParents,$libFile)