Store category defaults constructor as part of category constructor DB.

6 files changed, 43 insertions, 20 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 8ebe7f45..626f47f9 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,16 @@
 2013-06-15  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
+	* interp/database.boot (dbConstructorDefault): New accessor.
+	(getCategoryConstructorDefault): New.
+	* interp/define.boot (makeCategoryAlist): Use it.
+	(hasDefaultPackage): Remove.
+	(mkCategoryPackage): First parameter is now a DB.  Take
+	environment parameter too.  Adjust caller.
+	* interp/lisplib.boot (writeCategoryDefault): New.
+	(finalizeLisplib): Call it when appropriate.
+
+2013-06-15  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
 	* interp/define.boot (makeCategoryPredicates): Tidy.  Adjust caller.
 
 2013-06-14  Gabriel Dos Reis  <gdr@integrable-solutions.net>
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 7d9dbeec..fb4a4bf8 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -305,7 +305,7 @@ cattable.$(FASLEXT): simpbool.$(FASLEXT) c-util.$(FASLEXT)
 compat.$(FASLEXT): pathname.$(FASLEXT)
 simpbool.$(FASLEXT): sys-macros.$(FASLEXT)
 newfort.$(FASLEXT): sys-macros.$(FASLEXT)
-lisplib.$(FASLEXT): nlib.$(FASLEXT) c-util.$(FASLEXT) debug.$(FASLEXT)
+lisplib.$(FASLEXT): database.$(FASLEXT) debug.$(FASLEXT)
 c-doc.$(FASLEXT): c-util.$(FASLEXT)
 server.$(FASLEXT): sys-macros.$(FASLEXT)
 
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp
index 64541852..7ce0b1d3 100644
--- a/src/interp/daase.lisp
+++ b/src/interp/daase.lisp
@@ -231,7 +231,8 @@
  capsule-definitions	    ; capsule-level definitions
  template		    ; for a category, this is the generic instance.
                             ; for a functor, this is the template.
- lookup-function	    ; for a functor, lookup function.
+ lookup-function	    ; for a functor, lookup function.  For category
+                            ; constructor, default package constructor.
  ) ; database structure
 
 (deftype |%Database| nil 'database)
diff --git a/src/interp/database.boot b/src/interp/database.boot
index e3e266fb..f9e41788 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -72,6 +72,16 @@ makeConstructor(s,k == nil,a == nil) ==
 
 --%
 
+++ Access to the default constructor of a category.
+++ Note: Meaningful only for categories
+macro dbConstructorDefault db ==
+  dbLookupFunction db
+
+getCategoryConstructorDefault: %Symbol -> %Maybe %Symbol
+getCategoryConstructorDefault ctor ==
+  builtinConstructor? ctor => nil
+  dbConstructorDefault loadDBIfNecessary constructorDB ctor
+
 getConstructorAbbreviationFromDB: %Symbol -> %Maybe %Symbol
 getConstructorAbbreviationFromDB ctor ==
   db := constructorDB ctor => dbAbbreviation db
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 84c502b5..dfcff5e3 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -380,9 +380,8 @@ makeDomainTemplate db ==
   vec := dbTemplate db
   for index in 0..maxIndex vec repeat
     item := domainRef(vec,index)
-    item = nil => nil
+    item isnt [.,:.] => nil
     domainRef(vec,index) :=
-      item isnt [.,:.] => item
       cons? first item => makeGoGetSlot(db,item,index)
       item   
   dbByteList(db) := "append"/reverse! dbByteList db
@@ -492,7 +491,7 @@ makeCategoryAlist(db,e) ==
   newPairlis := [[i,:b] for [.,:b] in dbFormalSubst db for i in 6..]
   slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist)
                    | (k := predicateBitIndex(b,e)) ~= -1]
-  slot0 := [hasDefaultPackage a.op for [a,:.] in slot1]
+  slot0 := [getCategoryConstructorDefault a.op for [a,:.] in slot1]
   sixEtc := [5 + i for i in 1..dbArity db]
   formals := substTarget dbFormalSubst db
   for x in slot1 repeat
@@ -514,11 +513,6 @@ encodeCatform(db,x) ==
   x isnt [.,:.] or rest x isnt [.,:.] => x
   [first x,:[encodeCatform(db,y) for y in rest x]]
  
-hasDefaultPackage catname ==
-  defname := makeDefaultPackageName symbolName catname
-  constructor? defname => defname
-  nil
- 
 ++ Like getmode, except that if the mode is local variable with
 ++ defined value, we want that value instead.
 getXmode(x,e) ==
@@ -996,7 +990,7 @@ compDefineCategory1(db,df is ['DEF,form,sig,body],m,e,fal) ==
   if not skipCategoryPackage? categoryCapsule then [.,.,e] :=
     $insideCategoryPackageIfTrue: local := true
     $categoryPredicateList: local := makeCategoryPredicates db
-    defaults := mkCategoryPackage(form,cat,categoryCapsule)
+    defaults := mkCategoryPackage(db,cat,categoryCapsule,e)
     T := compDefine1(nil,defaults,$EmptyMode,e)
            or return stackSemanticError(
                         ['"cannot compile defaults of",:bright opOf form],nil)
@@ -1025,10 +1019,11 @@ mkExportFromDescription desc ==
     nil
   ['SIGNATURE,desc.mapOperation,desc.mapSignature,:t]
 
-mkCategoryPackage(form is [op,:argl],cat,def) ==
-  catdb := constructorDB op
+mkCategoryPackage(db,cat,def,e) ==
+  [op,:argl] := dbConstructorForm db
   packageName:= makeDefaultPackageName symbolName op
-  packageAbb := makeSymbol strconc(symbolName dbAbbreviation catdb,'"-")
+  dbConstructorDefault(db) := packageName
+  packageAbb := makeSymbol strconc(symbolName dbAbbreviation db,'"-")
   $options:local := []
   -- This stops the next line from becoming confused
   abbreviationsSpad2Cmd ['package,packageAbb,packageName]
@@ -1040,8 +1035,8 @@ mkCategoryPackage(form is [op,:argl],cat,def) ==
     x isnt [.,:.] => oplist
     x is ['DEF,y,:.] => [opOf y,:oplist]
     fn(x.args,fn(x.op,oplist))
-  catvec := evalCategoryForm(form,$e)
-  fullCatOpList := categoryExports JoinInner([catvec],$e)
+  catvec := evalCategoryForm(dbConstructorForm db,e)
+  fullCatOpList := categoryExports JoinInner([catvec],e)
   catOpList :=
     [mkExportFromDescription desc for desc in fullCatOpList
         | symbolMember?(desc.mapOperation,capsuleDefAlist)]
@@ -1050,7 +1045,7 @@ mkCategoryPackage(form is [op,:argl],cat,def) ==
     ['CATEGORY,'package,
        :applySubst(pairList($FormalMapVariableList,argl),catOpList)]
   nils:= [nil for x in argl]
-  packageSig := [packageCategory,form,:nils]
+  packageSig := [packageCategory,dbConstructorForm db,:nils]
   $categoryPredicateList := substitute(nameForDollar,'$,$categoryPredicateList)
   substitute(nameForDollar,'$,['DEF,[packageName,:packageArgl],packageSig,def])
  
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 28534646..08b9417b 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -32,8 +32,7 @@
 -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 
-import nlib
-import c_-util
+import database
 import debug
 
 namespace BOOT
@@ -475,6 +474,11 @@ writeLookupFunction db ==
     writeLoadInfo(db,quote fun,'lookupFunction,'dbLookupFunction)
   nil
 
+writeCategoryDefault db ==
+  pac := dbConstructorDefault db
+  insn := ['%store,['dbConstructorDefault,mkCtorDBForm db],quote pac]
+  printBackendStmt(dbLibstream db,expandToVMForm insn)
+
 writeKind db ==
   writeInfo(db,dbConstructorKind db,'constructorKind,'dbConstructorKind)
 
@@ -540,7 +544,9 @@ leaveIfErrors(libName,kind) ==
 finalizeLisplib(db,libName) ==
   form := dbConstructorForm db
   writeTemplate db
-  writeLookupFunction db
+  do   -- shared slot; careful.
+    dbConstructorKind db = 'category => writeCategoryDefault db
+    writeLookupFunction db
   writeConstructorForm db
   writeKind db
   writeConstructorModemap db