Cache category objects some more.

4 files changed, 101 insertions, 86 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index f7892e25..af4680fb 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,20 @@
 2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
+	* interp/category.boot (SigListUnion): Take a cache table.  Adjust
+	callers.
+	(mkOr): Likewise.
+	(mkOr2): Likewise.
+	(mkAnd): Likewise.
+	(mkAnd2): Likewise.
+	(FindFundAncs): Likewise.
+	(CatEval): Likewise.
+	(ancestors?): Likewise.
+	(descendant?): Likewise.
+	(filterConditionalCategories): Likewise.
+	* interp/functor.boot (ICformat): Likewise.
+
+2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
 	* interp/define.boot (getCategoryObject): New.
 	* interp/functor.boot (InvestigateConditions): Use it.
 	(getViewsConditions): Likewise.
diff --git a/src/interp/category.boot b/src/interp/category.boot
index b018b875..cec0b2bb 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -137,7 +137,7 @@ DropImplementations a ==
     [[:sig,'constant],pred]
   a
  
-SigListUnion(extra,original,principal) ==
+SigListUnion(extra,original,principal,tbl) ==
   --augments original %with everything in extra that is not in original
   for (o:=[[ofn,osig,:.],opred,:.]) in original repeat
     -- The purpose of this loop is to detect cases when the
@@ -173,13 +173,13 @@ SigListUnion(extra,original,principal) ==
             original := [x,:original]
           else
             original:= [[xsig,xpred,["Subsumed",:esig]],:original]
-       else epred := mkOr(epred,xpred,$e)
+       else epred := mkOr(epred,xpred,tbl,$e)
 -- this used always to be done, as noted below, but that's not safe
       if not(ximplem is [["Subsumed",:.],:.]) then eimplem:= ximplem
       if eimplem then esig:=[first esig,second esig] 
            -- in case there's a constant marker
       e:= [esig,epred,:eimplem]
---    e:= [esig,mkOr(xpred,epred,$e),:ximplem]
+--    e:= [esig,mkOr(xpred,epred,tbl,$e),:ximplem]
 -- Original version -gets it wrong if the new operator is only
 -- present under certain conditions
         -- We must pick up the previous implementation, if any
@@ -189,18 +189,18 @@ SigListUnion(extra,original,principal) ==
     original:= [e,:original]
   original
  
-mkOr: (%Form,%Form,%Env) -> %Form
-mkOr(a,b,e) ==
+mkOr: (%Form,%Form,%Table,%Env) -> %Form
+mkOr(a,b,tbl,e) ==
   a=true => true
   b=true => true
   b=a => a
   l:=
     a is ["OR",:a'] =>
-      (b is ["OR",:b'] => union(a',b'); mkOr2(b,a',e) )
-    b is ["OR",:b'] => mkOr2(a,b',e)
+      (b is ["OR",:b'] => union(a',b'); mkOr2(b,a',tbl,e) )
+    b is ["OR",:b'] => mkOr2(a,b',tbl,e)
     (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) =>
-      descendant?(acat,bcat,e) => [b]
-      descendant?(bcat,acat,e) => [a]
+      descendant?(acat,bcat,tbl,e) => [b]
+      descendant?(bcat,acat,tbl,e) => [a]
       [a,b]
     a is ['AND,:a'] and listMember?(b,a') => [b]
     b is ['AND,:b'] and listMember?(a,b') => [a]
@@ -210,47 +210,47 @@ mkOr(a,b,e) ==
   #l = 1 => first l
   ["OR",:l]
  
-mkOr2: (%Form,%Form,%Env) -> %Form
-mkOr2(a,b,e) ==
+mkOr2: (%Form,%Form,%Table,%Env) -> %Form
+mkOr2(a,b,tbl,e) ==
   --a is a condition, "b" a list of them
   listMember?(a,b) => b
   a is ["has",avar,acat] =>
     aRedundant:=false
     for c in b | c is ["has",=avar,ccat] repeat
-      descendant?(acat,ccat,e) =>
+      descendant?(acat,ccat,tbl,e) =>
         return (aRedundant:=true)
-      if descendant?(ccat,acat,e) then b := remove(b,c)
+      if descendant?(ccat,acat,tbl,e) then b := remove(b,c)
     aRedundant => b
     [a,:b]
   [a,:b]
  
-mkAnd: (%Form,%Form,%Env) -> %Form
-mkAnd(a,b,e) ==
+mkAnd: (%Form,%Form,%Table,%Env) -> %Form
+mkAnd(a,b,tbl,e) ==
   a=true => b
   b=true => a
   b=a => a
   l:=
     a is ["AND",:a'] =>
-      (b is ["AND",:b'] => union(a',b'); mkAnd2(b,a',e) )
-    b is ["AND",:b'] => mkAnd2(a,b',e)
+      (b is ["AND",:b'] => union(a',b'); mkAnd2(b,a',tbl,e) )
+    b is ["AND",:b'] => mkAnd2(a,b',tbl,e)
     (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) =>
-      descendant?(acat,bcat,e) => [a]
-      descendant?(bcat,acat,e) => [b]
+      descendant?(acat,bcat,tbl,e) => [a]
+      descendant?(bcat,acat,tbl,e) => [b]
       [a,b]
     [a,b]
   #l = 1 => first l
   ["AND",:l]
  
-mkAnd2: (%Form,%Form,%Env) -> %Form
-mkAnd2(a,b,e) ==
+mkAnd2: (%Form,%Form,%Table,%Env) -> %Form
+mkAnd2(a,b,tbl,e) ==
   --a is a condition, "b" a list of them
   listMember?(a,b) => b
   a is ["has",avar,acat] =>
     aRedundant:=false
     for c in b | c is ["has",=avar,ccat] repeat
-      descendant?(ccat,acat,e) =>
+      descendant?(ccat,acat,tbl,e) =>
         return (aRedundant:=true)
-      if descendant?(acat,ccat,e) then b := remove(b,c)
+      if descendant?(acat,ccat,tbl,e) then b := remove(b,c)
     aRedundant => b
     [a,:b]
   [a,:b]
@@ -294,68 +294,67 @@ MachineLevelSubset(a,b) ==
 ++ Given a list `l' of 2-list [cat,pred] of category object and associated
 ++ predicate, return a list of similar structures of all fundamental
 ++ ancestors with appropriate conditions.
-FindFundAncs(l,e) ==
+FindFundAncs(l,tbl,e) ==
   l = nil => nil
   [hd:=[f1,p1],:l] := l
-  canonicalForm f1 = nil => FindFundAncs(l,e)
-  ans := FindFundAncs(l,e)
-  for u in FindFundAncs([[CatEval(first x,e),mkAnd(p1,second x,e)]
-   for x in categoryAncestors f1],e) repeat
+  canonicalForm f1 = nil => FindFundAncs(l,tbl,e)
+  ans := FindFundAncs(l,tbl,e)
+  for u in FindFundAncs([[CatEval(first x,tbl,e),mkAnd(p1,second x,tbl,e)]
+   for x in categoryAncestors f1],tbl,e) repeat
     x := objectAssoc(first u,ans) =>
-      ans := [[first u,mkOr(second x,second u,e)],:remove(ans,x)]
+      ans := [[first u,mkOr(second x,second u,tbl,e)],:remove(ans,x)]
     ans := [u,:ans]
   --testing to see if hd is already there
-  x := objectAssoc(f1,ans) => [[f1,mkOr(p1,second x,e)],:remove(ans,x)]
+  x := objectAssoc(f1,ans) => [[f1,mkOr(p1,second x,tbl,e)],:remove(ans,x)]
   p1 is true =>
     for x in categoryPrincipals f1 repeat
-      if y := objectAssoc(CatEval(x,e),ans) then ans := remove(ans,y)
+      if y := objectAssoc(CatEval(x,tbl,e),ans) then ans := remove(ans,y)
     [hd,:ans]
   for x in categoryPrincipals f1 repeat
-    if y := objectAssoc(CatEval(x,e),ans) then ans:=
-      [[first y,mkOr(p1,second y,e)],:remove(ans,y)]
+    if y := objectAssoc(CatEval(x,tbl,e),ans) then ans:=
+      [[first y,mkOr(p1,second y,tbl,e)],:remove(ans,y)]
   [hd,:ans]
   -- Our new thing may have, as an alternate view, a principal
   -- descendant of something previously added which is therefore
   -- subsumed
  
-CatEval: (%Thing,%Env) -> %Shell
-CatEval(x,e) ==
+CatEval: (%Thing,%Table,%Env) -> %Shell
+CatEval(x,tbl,e) ==
   vector? x => x
   if $InteractiveMode then
     e := $CategoryFrame
-  compMakeCategoryObject(x,e).expr
+  getCategoryObject(tbl,x,e)
  
-ancestor?: (%Form,%List %Instantiation,%Env) -> %Form
-ancestor?(xname,leaves,env) ==
+ancestor?: (%Form,%List %Instantiation,%Table,%Env) -> %Form
+ancestor?(xname,leaves,tbl,env) ==
   -- checks for being a principal ancestor of one of the leaves
   listMember?(xname,leaves) => xname
   for y in leaves repeat
-    listMember?(xname,categoryPrincipals CatEval(y,env)) => return y
+    listMember?(xname,categoryPrincipals CatEval(y,tbl,env)) => return y
  
-CondAncestorP(xname,leaves,condition,env) ==
+conditionalAncestor?(xname,leaves,condition,tbl,env) ==
   -- checks for being a principal ancestor of one of the leaves
   for u in leaves repeat
     u':=first u
     ucond:=
       null rest u => true
       second u
-    xname = u' or listMember?(xname,categoryPrincipals CatEval(u',env)) =>
+    xname = u' or listMember?(xname,categoryPrincipals CatEval(u',tbl,env)) =>
       predicateImplies(condition,ucond) => return u'
 
 
 ++ Returns true if the form `a' designates a category that is any 
 ++ kind of descendant of the category designated by the form `b'.
-descendant?: (%Form,%Form,%Env) -> %Boolean
-descendant?(a,b,e) ==
+descendant?: (%Form,%Form,%Table,%Env) -> %Boolean
+descendant?(a,b,tbl,e) ==
   a=b => true
   a is ["ATTRIBUTE",:.] => false
   a is ["SIGNATURE",:.] => false
-  a:= CatEval(a,e)
+  a:= CatEval(a,tbl,e)
   b is ["ATTRIBUTE",b'] =>
     (l := assoc(b',categoryAttributes a)) => TruthP second l
   listMember?(b,categoryPrincipals a) => true
-  ancestor?(b,[first u for u in categoryAncestors a],e) => true
-  false
+  ancestor?(b,[first u for u in categoryAncestors a],tbl,e)
  
 --% The implementation of Join
 
@@ -367,7 +366,7 @@ descendant?(a,b,e) ==
 ++ The end result is a 2-list, the first component being a list of
 ++ (catobj,pred) pairs and the second component being the list of
 ++ newly discovered unconditional categories.
-filterConditionalCategories(l,e) ==
+filterConditionalCategories(l,tbl,e) ==
   conditionals := nil
   unconditionals := nil
   for cat in l repeat
@@ -379,20 +378,21 @@ filterConditionalCategories(l,e) ==
       not isCategoryForm(at,e) => $Attributes := [first at,:$Attributes]
       listMember?(pred,get("$Information","special",e)) =>
         --It's true, so we add it as unconditional
-        unconditionals := [CatEval(at,e),:unconditionals]
+        unconditionals := [CatEval(at,tbl,e),:unconditionals]
       pred isnt ["and",:.] =>
-        conditionals := [[CatEval(at,e),pred],:conditionals]
+        conditionals := [[CatEval(at,tbl,e),pred],:conditionals]
       -- Predicate is a conjunctive; decompose it.
       pred' := [x for x in pred.args |
                   not listMember?(x,get("$Information","special",e))
                     and x isnt true]
-      pred' = nil => unconditionals := [CatEval(at,e),:unconditionals]
-      pred' is [x] => conditionals := [[CatEval(at,e),x],:conditionals]
-      conditionals := [[CatEval(at,e),["and",:pred']],:conditionals]
+      pred' = nil => unconditionals := [CatEval(at,tbl,e),:unconditionals]
+      pred' is [x] => conditionals := [[CatEval(at,tbl,e),x],:conditionals]
+      conditionals := [[CatEval(at,tbl,e),["and",:pred']],:conditionals]
   [conditionals,reverse! unconditionals]
  
 JoinInner(l,$e) ==
-  [CondList,uncondList] := filterConditionalCategories(l,$e)
+  tbl := makeTable function valueEq?
+  [CondList,uncondList] := filterConditionalCategories(l,tbl,$e)
   [principal,:l] := [:l,:uncondList]
   principal := mkBuffer principal
   l' := [:CondList,:[[u,true] for u in l]]
@@ -405,12 +405,12 @@ JoinInner(l,$e) ==
   if name := canonicalForm bufferData principal then
     FundamentalAncestors := [[name],:FundamentalAncestors]
   -- this skips buggy code which discards needed categories
-  for [b,condition] in FindFundAncs(l',$e) | bname := b.0 repeat
-    CondAncestorP(bname,FundamentalAncestors,condition,$e) => nil
-    f := ancestor?(bname,[first u for u in FundamentalAncestors],$e) =>
+  for [b,condition] in FindFundAncs(l',tbl,$e) | bname := b.0 repeat
+    conditionalAncestor?(bname,FundamentalAncestors,condition,tbl,$e) => nil
+    f := ancestor?(bname,[first u for u in FundamentalAncestors],tbl,$e) =>
       [.,.,index] := assoc(f,FundamentalAncestors)
       FundamentalAncestors := [[bname,condition,index],:FundamentalAncestors]
-    PrinAncb := categoryPrincipals CatEval(bname,$e)
+    PrinAncb := categoryPrincipals CatEval(bname,tbl,$e)
              --Principal Ancestors of b
     reallynew := true
     -- This loop implements Category Subsumption
@@ -441,7 +441,7 @@ JoinInner(l,$e) ==
       bufferRef(principal,n) := b.0
   for b in l repeat
     sigl := SigListUnion([DropImplementations u for u in categoryExports b],
-             sigl,principal)
+             sigl,principal,tbl)
     attl := S_+(categoryAttributes b,attl)
     globalDomains := [:globalDomains,:S_-(categoryParameters b,globalDomains)]
   for b in CondList repeat
@@ -455,11 +455,11 @@ JoinInner(l,$e) ==
       second v is true => nil
       attl := remove(attl,v)
       attl :=
-        second u is true => [[first u,mkOr(second v,newpred,$e)],:attl]
-        [[first u,mkOr(second v,mkAnd(newpred,second u,$e),$e)],:attl]
+        second u is true => [[first u,mkOr(second v,newpred,tbl,$e)],:attl]
+        [[first u,mkOr(second v,mkAnd(newpred,second u,tbl,$e),tbl,$e)],:attl]
     sigl := SigListUnion(
         [AddPredicate(DropImplementations u,newpred)
-           for u in categoryExports(first b)],sigl,principal) where
+           for u in categoryExports(first b)],sigl,principal,tbl) where
           AddPredicate(op is [sig,oldpred,:implem],newpred) ==
             newpred is true => op
             oldpred is true => [sig,newpred,:implem]
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 0ddfd5b6..a3c893d1 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -233,7 +233,7 @@ knownInfo(pred,env,tbl == makeTable function valueEq?) ==
     -- previous line checks fundamental anscestors, we should check their
     --   principal anscestors but this requires instantiating categories
 
-    or/[ancestor?(cat,[first u],env) 
+    or/[ancestor?(cat,[first u],tbl,env) 
          for u in categoryAncestors vv | knownInfo(second u,env,tbl)] =>
             tableValue(tbl,pred) := true
     false
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index b0def0eb..356c66de 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -587,9 +587,9 @@ InvestigateConditions(db,catvecListMaker,tbl,env) ==
   $HackSlot4:=
     MinimalPrimary=MaximalPrimary => nil
     MaximalPrimaries :=
-      [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,env)]
+      [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,tbl,env)]
     MinimalPrimaries :=
-      [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,env)]
+      [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,tbl,env)]
     MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries)
     [[x] for x in MaximalPrimaries]
   ($Conditions:= Conds($principal,nil)) where
@@ -619,31 +619,31 @@ InvestigateConditions(db,catvecListMaker,tbl,env) ==
       # u=1 => first u
       ['AND,:u]
     for [v,:.] in newS repeat
-      for v' in [v,:categoryPrincipals CatEval(v,env)] repeat
+      for v' in [v,:categoryPrincipals CatEval(v,tbl,env)] repeat
         if (w:=assoc(v',$HackSlot4)) then
-          w.rest := if rest w then mkOr(u,rest w,env) else u
-    (list:= update(list,u,secondaries,newS,env)) where
-      update(list,cond,secondaries,newS,env) ==
+          w.rest := if rest w then mkOr(u,rest w,tbl,env) else u
+    (list:= update(list,u,secondaries,newS,tbl,env)) where
+      update(list,cond,secondaries,newS,tbl,env) ==
         (list2:=
-          [flist(sec,newS,old,cond,env) for sec in secondaries for old in list]) where
-            flist(sec,newS,old,cond,env) ==
+          [flist(sec,newS,old,cond,tbl,env) for sec in secondaries for old in list]) where
+            flist(sec,newS,old,cond,tbl,env) ==
               old=true => old
               for [newS2,:morecond] in newS repeat
                 old:=
-                  not ancestor?(sec,[newS2],env) => old
-                  cond2 := mkAnd(cond,morecond,env)
+                  not ancestor?(sec,[newS2],tbl,env) => old
+                  cond2 := mkAnd(cond,morecond,tbl,env)
                   null old => cond2
-                  mkOr(cond2,old,env)
+                  mkOr(cond2,old,tbl,env)
               old
         list2
-  list:= [[sec,:ICformat(u,env)] for u in list for sec in secondaries]
+  list:= [[sec,:ICformat(u,tbl,env)] for u in list for sec in secondaries]
   pv:= getPossibleViews($principal,tbl)
   -- $HackSlot4 is used in SetVector4 to ensure that conditional
   -- extensions of the principal view are handles correctly
   -- here we build the code necessary to remove spurious extensions
-  ($HackSlot4:= [reshape(u,env) for u in $HackSlot4]) where
-    reshape(u,env) ==
-      ['%when,[TryGDC ICformat(rest u,env)],
+  ($HackSlot4:= [reshape(u,tbl,env) for u in $HackSlot4]) where
+    reshape(u,tbl,env) ==
+      ['%when,[TryGDC ICformat(rest u,tbl,env)],
              ['%otherwise,['RPLACA,'(CAR TrueDomain),
                              ['delete, quote first u,'(CAAR TrueDomain)]]]]
   $supplementaries:=
@@ -652,32 +652,32 @@ InvestigateConditions(db,catvecListMaker,tbl,env) ==
         and not (true=rest u) and not listMember?(first u,pv)]
   [true,:[LASSOC(ms,list) for ms in masterSecondaries]]
  
-ICformat(u,env) ==
+ICformat(u,tbl,env) ==
       u isnt [.,:.] => u
       u is ["has",:.] => compHasFormat(u,env)
       u is ['AND,:l] or u is ['and,:l] =>
-        l:= removeDuplicates [ICformat(v,env) for [v,:l'] in tails l
+        l:= removeDuplicates [ICformat(v,tbl,env) for [v,:l'] in tails l
                                 | not listMember?(v,l')]
              -- we could have duplicates after, even if not before
         # l=1 => first l
         l1:= first l
         for u in rest l repeat
-          l1 := mkAnd(u,l1,env)
+          l1 := mkAnd(u,l1,tbl,env)
         l1
       u is ['OR,:l] =>
         (l:= ORreduce l)
-        # l=1 => ICformat(first l,env)
-        l:= ORreduce removeDuplicates [ICformat(u,env) for u in l]
+        # l=1 => ICformat(first l,tbl,env)
+        l:= ORreduce removeDuplicates [ICformat(u,tbl,env) for u in l]
                  --causes multiple ANDs to be squashed, etc.
                  -- and duplicates that have been built up by tidying
-        (l:= Hasreduce(l,env)) where
-          Hasreduce(l,env) ==
+        (l:= Hasreduce(l,tbl,env)) where
+          Hasreduce(l,tbl,env) ==
             for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE,
               cond] repeat
                                   --check that v causes descendants to go
                 for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE,
                   cond2]] repeat
-                       if descendant?(cond,cond2,env) then l:= remove(l,u)
+                       if descendant?(cond,cond2,tbl,env) then l:= remove(l,u)
                        --v subsumes u
             for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat
               for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE,
@@ -685,7 +685,7 @@ ICformat(u,env) ==
                                     --check that v causes descendants to go
                   for v in l | v is ['HasCategory, =name,['QUOTE,
                     cond2]] repeat
-                        if descendant?(cond,cond2,env) then l:= remove(l,u)
+                        if descendant?(cond,cond2,tbl,env) then l:= remove(l,u)
                          --v subsumes u
             l
         # l=1 => first l