Cache more category objects.

3 files changed, 55 insertions, 47 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index af4680fb..dec986fa 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,17 @@
 2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
+	* interp/define.boot (NRTgetLookupFunction): Take a cache table.
+	Adjust caller.
+	(NRTextendsCategory1): Likewise.
+	(extendsCategory): Likewise.
+	(extendsCategoryBasic): Likewise.
+	(catExtendsCat?): Likewise.
+	(getCategoryObjectIfCan): New.
+	(getCategoryObject): Use it.
+	* interp/lisplib.boot (getSlot1): Remove as unused.
+
+2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
 	* interp/category.boot (SigListUnion): Take a cache table.  Adjust
 	callers.
 	(mkOr): Likewise.
diff --git a/src/interp/define.boot b/src/interp/define.boot
index a3c893d1..d15c4682 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -46,6 +46,7 @@ module define where
   compAdd: (%Form, %Mode, %Env) -> %Maybe %Triple 
   compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple
   evalCategoryForm: (%Form,%Env) -> %Maybe %Shell
+  getCategoryObjectIfCan: (%Table,%Form,%Env) -> %Maybe %Shell
   getCategoryObject: (%Table,%Form,%Env) -> %Shell
 
 
@@ -259,7 +260,9 @@ GetValue name ==
  
 actOnInfo(u,$e) ==
   null u => $e
-  u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e)
+  u is ["PROGN",:l] =>
+    for v in l repeat $e := actOnInfo(v,$e)
+    $e
   db := currentDB $e
   $e:=
     put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e
@@ -268,7 +271,7 @@ actOnInfo(u,$e) ==
       --there is nowhere %else that this sort of thing exists
     for [ante,:conseq] in l repeat
       if listMember?(hasToInfo ante,Info) then for v in conseq repeat
-        $e:= actOnInfo(v,$e)
+        $e := actOnInfo(v,$e)
     $e
   u is ["ATTRIBUTE",name,att] =>
     [vval,vmode,.]:= GetValue name
@@ -336,7 +339,7 @@ chaseInferences(pred,$e) ==
   foo hasToInfo pred where
     foo pred ==
       knownInfo(pred,$e) => nil
-      $e:= actOnInfo(pred,$e)
+      $e := actOnInfo(pred,$e)
       pred:= infoToHas pred
       for u in get("$Information","special",$e) repeat
         u is ['%when,:l] =>
@@ -528,18 +531,18 @@ getXmode(x,e) ==
 --=======================================================================
 --              Compute the lookup function (complete or incomplete)
 --=======================================================================
-NRTgetLookupFunction(db,addForm,env) ==
+NRTgetLookupFunction(db,addForm,tbl,env) ==
   $why: local := nil
   domform := dbSubstituteFormals(db,dbConstructorForm db)
   cat := dbCategory db
   addForm isnt [.,:.] =>
     ident? addForm and (m := getmode(addForm,env)) ~= nil and
       isCategoryForm(m,env) and
-        extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),env) =>
+        extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),tbl,env) =>
           'lookupIncomplete
     'lookupComplete
   addForm := dbSubstituteFormals(db,addForm)
-  NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),env) =>
+  NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),tbl,env) =>
     'lookupIncomplete
   [u,msg,:v] := $why
   SAY '"--------------non extending category----------------------"
@@ -563,55 +566,58 @@ getBaseExports(db,form) ==
   [[.,target,:tl],:.] := getConstructorModemap op
   applySubst(pairList($FormalMapVariableList,argl),target)
  
-NRTextendsCategory1(db,domform,exCategory,addForm,env) ==
+NRTextendsCategory1(db,domform,exCategory,addForm,tbl,env) ==
   addForm is ["%Comma",:r] => 
-    and/[extendsCategory(db,domform,exCategory,x,env) for x in r]
-  extendsCategory(db,domform,exCategory,addForm,env)
+    and/[extendsCategory(db,domform,exCategory,x,tbl,env) for x in r]
+  extendsCategory(db,domform,exCategory,addForm,tbl,env)
 
 --=======================================================================
 --         Compute if a domain constructor is forgetful functor
 --=======================================================================
-extendsCategory(db,dom,u,v,env) ==
+extendsCategory(db,dom,u,v,tbl,env) ==
   --does category u extend category v (yes iff u contains everything in v)
   --is dom of category u also of category v?
   u=v => true
-  v is ["Join",:l] => and/[extendsCategory(db,dom,u,x,env) for x in l]
-  v is ["CATEGORY",.,:l] => and/[extendsCategory(db,dom,u,x,env) for x in l]
+  v is ["Join",:l] => and/[extendsCategory(db,dom,u,x,tbl,env) for x in l]
+  v is ["CATEGORY",.,:l] =>
+    and/[extendsCategory(db,dom,u,x,tbl,env) for x in l]
   v is ["SubsetCategory",cat,d] =>
-    extendsCategory(db,dom,u,cat,env) and isSubset(dom,d,env)
+    extendsCategory(db,dom,u,cat,tbl,env) and isSubset(dom,d,env)
   v := substSlotNumbers(v,dbTemplate db,dbConstructorForm db)
-  extendsCategoryBasic(dom,u,v,env) => true
+  extendsCategoryBasic(dom,u,v,tbl,env) => true
   $why :=
     v is ['SIGNATURE,op,sig,:.] =>
       [u,['"  has no ",:formatOpSignature(op,sig)]]
     [u,'" has no",v]
   nil
  
-extendsCategoryBasic(dom,u,v,env) ==
+extendsCategoryBasic(dom,u,v,tbl,env) ==
   v is ['IF,p,['ATTRIBUTE,c],.] =>
-    uVec := compMakeCategoryObject(u,env).expr or return false
+    uVec := getCategoryObjectIfCan(tbl,u,env) or return false
     cons? c and isCategoryForm(c,env) =>
       LASSOC(c,categoryAncestors uVec) is [=p,:.]
     LASSOC(c,categoryAttributes uVec) is [=p,:.]
-  u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l]
+  u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,tbl,env) for x in l]
   u = v => true
   v is ['ATTRIBUTE,c] =>
-    cons? c and isCategoryForm(c,env) => extendsCategoryBasic(dom,u,c,env)
-    u is ['CATEGORY,.,:l] => or/[extendsCategoryBasic(dom,x,v,env) for x in l]
-    uVec := compMakeCategoryObject(u,env).expr or return false
+    cons? c and isCategoryForm(c,env) =>
+      extendsCategoryBasic(dom,u,c,tbl,env)
+    u is ['CATEGORY,.,:l] =>
+      or/[extendsCategoryBasic(dom,x,v,tbl,env) for x in l]
+    uVec := getCategoryObjectIfCan(tbl,u,env) or return false
     LASSOC(c,categoryAttributes uVec) is [=true]
-  isCategoryForm(v,env) => catExtendsCat?(u,v,env)
+  isCategoryForm(v,env) => catExtendsCat?(u,v,tbl,env)
   v is ['SIGNATURE,op,sig,:.] =>
-    uVec := compMakeCategoryObject(u,env).expr or return false
+    uVec := getCategoryObjectIfCan(tbl,u,env) or return false
     or/[categoryRef(uVec,i) is [[=op,=sig],:.] for i in 6..maxIndex uVec]
   u is ['CATEGORY,.,:l] =>
     v is ['IF,:.] => listMember?(v,l)
     false
   false
  
-catExtendsCat?(u,v,env) ==
+catExtendsCat?(u,v,tbl,env) ==
   u = v => true
-  uvec := compMakeCategoryObject(u,env).expr
+  uvec := getCategoryObject(tbl,u,env)
   prinAncestorList := categoryPrincipals uvec
   listMember?(v,prinAncestorList) => true
   vOp := KAR v
@@ -621,7 +627,7 @@ catExtendsCat?(u,v,env) ==
     PRINT similarForm
     sayBrightlyNT '"   but not "
     PRINT v
-  or/[catExtendsCat?(x,v,env) for x in ASSOCLEFT categoryAncestors uvec]
+  or/[catExtendsCat?(x,v,tbl,env) for x in ASSOCLEFT categoryAncestors uvec]
  
 substSlotNumbers(form,template,domain) ==
   form is [op,:.] and
@@ -1219,10 +1225,14 @@ compMakeCategoryObject(c,$e) ==
   u := evalCategoryForm(c,$e) => [u,$Category,$e]
   nil
 
-getCategoryObject(tbl,x,env) ==
+getCategoryObjectIfCan(tbl,x,env) ==
   obj := tableValue(tbl,x) => obj
   T := compMakeCategoryObject(x,env) => tableValue(tbl,x) := T.expr
-  systemErrorHere ['getCategoryObject]
+  nil
+
+getCategoryObject(tbl,x,env) ==
+  getCategoryObjectIfCan(tbl,x,env)
+    or systemErrorHere ['getCategoryObject]
 
 predicatesFromAttributes: %List %Form -> %List %Form
 predicatesFromAttributes attrList ==
@@ -1350,7 +1360,9 @@ getOperationAlist(db,name,functorForm,form) ==
   $insideFunctorIfTrue and name is "$" =>
     dbDomainShell db = nil => systemError '"$ has no shell now"
     categoryExports dbDomainShell db
-  T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; categoryExports T.expr)
+  T := compMakeCategoryObject(form,$e) =>
+    [.,.,$e] := T
+    categoryExports T.expr
   stackMessage('"not a category form: %1bp",[form])
  
 substNames(domainName,functorForm,opalist) ==
@@ -1510,7 +1522,8 @@ compDefineFunctor1(db,df is ['DEF,form,signature,body],m,$e,$formalArgList) ==
 
     $functorTarget := target := signature'.target
     $e := giveFormalParametersValues(form.args,$e)
-    [ds,.,$e] := compMakeCategoryObject(target,$e) or return
+    tbl := makeTable function valueEq?  -- category-form/object table
+    ds := getCategoryObjectIfCan(tbl,target,$e) or return
        stackAndThrow('"   cannot produce category object: %1pb",[target])
     dbDomainShell(db) := copyVector ds
     attributeList := categoryAttributes ds --see below under "loadTimeAlist"
@@ -1570,7 +1583,7 @@ compDefineFunctor1(db,df is ['DEF,form,signature,body],m,$e,$formalArgList) ==
     dbAncestors(db) := computeAncestorsOf($form,nil)
     $insideFunctorIfTrue:= false
     if not $bootStrapMode then
-      dbLookupFunction(db) := NRTgetLookupFunction(db,$NRTaddForm,$e)
+      dbLookupFunction(db) := NRTgetLookupFunction(db,$NRTaddForm,tbl,$e)
           --either lookupComplete (for forgetful guys) or lookupIncomplete
       $NRTslot1PredicateList :=
         [simpBool x for x in $NRTslot1PredicateList]
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 8dceae5d..9bb304aa 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -616,23 +616,6 @@ getSlotFromFunctor(target) ==
       systemErrorHere "getSlotFromFunctor"
   categoryRef(t.expr,2)
  
-getSlot1 domainName ==
-  $e: local:= $CategoryFrame
-  fn:= getLisplibName domainName
-  p := pathname [fn,$spadLibFT,'"*"]
-  not isExistingFile(p) =>
-    sayKeyedMsg("S2IL0003",[namestring p])
-    nil
-  (sig := getConstructorSignature domainName) =>
-    [.,target,:argMml] := sig
-    for a in $FormalMapVariableList for m in argMml repeat
-      $e:= put(a,'mode,m,$e)
-    t := compMakeCategoryObject(target,$e) or
-      systemErrorHere ["getSlot1",domainName]
-    categoryExports t.expr
-  sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"])
-  nil
- 
 transformOperationAlist operationAlist ==
   --  this transforms the operationAlist which is written out onto LISPLIBs.
   --  The original form of this list is a list of items of the form: