Cache category objects created at functor build time.

4 files changed, 25 insertions, 15 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index c951d78a..f7892e25 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,12 @@
 2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
 
+	* interp/define.boot (getCategoryObject): New.
+	* interp/functor.boot (InvestigateConditions): Use it.
+	(getViewsConditions): Likewise.
+	(getPossibleViews): Likewise.
+
+2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
+
 	* interp/category.boot (filterConditionalCategories): Fix thinko.
 
 2013-06-01  Gabriel Dos Reis  <gdr@integrable-solutions.net>
diff --git a/src/interp/define.boot b/src/interp/define.boot
index f3f70c72..0ddfd5b6 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
+  getCategoryObject: (%Table,%Form,%Env) -> %Shell
 
 
 --%
@@ -1218,6 +1219,11 @@ compMakeCategoryObject(c,$e) ==
   u := evalCategoryForm(c,$e) => [u,$Category,$e]
   nil
 
+getCategoryObject(tbl,x,env) ==
+  obj := tableValue(tbl,x) => obj
+  T := compMakeCategoryObject(x,env) => tableValue(tbl,x) := T.expr
+  systemErrorHere ['getCategoryObject]
+
 predicatesFromAttributes: %List %Form -> %List %Form
 predicatesFromAttributes attrList ==
   removeDuplicates [second x for x in attrList]
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index 19711b83..b0def0eb 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -1,6 +1,6 @@
 -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
 -- All rights reserved.
--- Copyright (C) 2007-2012, Gabriel Dos Reis.
+-- Copyright (C) 2007-2013, Gabriel Dos Reis.
 -- All rights reserved.
 --
 -- Redistribution and use in source and binary forms, with or without
@@ -546,7 +546,7 @@ SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding"
  
 --%  Under what conditions may views exist?
  
-InvestigateConditions(db,catvecListMaker,env) ==
+InvestigateConditions(db,catvecListMaker,tbl,env) ==
   -- given a principal view and a list of secondary views,
   -- discover under what conditions the secondary view are
   -- always present.
@@ -559,8 +559,7 @@ InvestigateConditions(db,catvecListMaker,env) ==
   null secondaries => '(T)
       --return for packages which generally have no secondary views
   if $principal is [op,:.] then
-    [principal',:.]:=compMakeCategoryObject($principal,$e)
-              --Rather like eval, but quotes parameters first
+    principal' := getCategoryObject(tbl,$principal,$e)
     for u in categoryAncestors principal' repeat
       if not TruthP(cond:=second u) then
         new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,first u], '%noBranch]]
@@ -579,7 +578,7 @@ InvestigateConditions(db,catvecListMaker,env) ==
           nil
         [pessimise first a,:pessimise rest a]
   null $Conditions => [true,:[true for u in secondaries]]
-  PrincipalSecondaries:= getViewsConditions principal'
+  PrincipalSecondaries:= getViewsConditions(principal',tbl)
   MinimalPrimary:= first first PrincipalSecondaries
   MaximalPrimary := first categoryPrincipals dbDomainShell db
   necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true]
@@ -606,7 +605,7 @@ InvestigateConditions(db,catvecListMaker,env) ==
       [previous]
   $Conditions := remove!([remove!(u,nil) for u in $Conditions],nil)
   partList:=
-    [getViewsConditions partPessimise($principal,cond) for cond in $Conditions]
+    [getViewsConditions(partPessimise($principal,cond),tbl) for cond in $Conditions]
   masterSecondaries:= secondaries
   for u in partList repeat
     for [v,:.] in u repeat
@@ -638,7 +637,7 @@ InvestigateConditions(db,catvecListMaker,env) ==
               old
         list2
   list:= [[sec,:ICformat(u,env)] for u in list for sec in secondaries]
-  pv:= getPossibleViews $principal
+  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
@@ -710,22 +709,19 @@ partPessimise(a,trueconds) ==
   a is ['IF,cond,:.] => (listMember?(cond,trueconds) => a; nil)
   [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)]
  
-getPossibleViews u ==
+getPossibleViews(u,tbl) ==
   --returns a list of all the categories that can be views of this one
-  [vec,:.]:= compMakeCategoryObject(u,$e) or
-    systemErrorHere ["getPossibleViews",u]
+  vec := getCategoryObject(tbl,u,$e)
   views:= [first u for u in categoryAncestors vec]
   null vec.0 => [first categoryPrincipals vec,:views] --*
   [vec.0,:views] --*
       --the two lines marked  ensure that the principal view comes first
       --if you don't want it, rest it off
  
-getViewsConditions u ==
- 
+getViewsConditions(u,tbl) ==
   --returns a list of all the categories that can be views of this one
   --paired with the condition under which they are such views
-  [vec,:.]:= compMakeCategoryObject(u,$e) or
-    systemErrorHere ["getViewsConditions",u]
+  vec := getCategoryObject(tbl,u,$e)
   views:= [[first u,:second u] for u in categoryAncestors vec]
   null vec.0 =>
     null categoryPrincipals vec => views
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index 33539fa0..0c60a502 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -466,7 +466,8 @@ buildFunctor(db,sig,code,$locals,$e) ==
   catvecListMaker := removeDuplicates
     [comp($catsig,$EmptyMode,$e).expr,
       :[compCategories(u,$e) for [u,:.] in categoryAncestors dbDomainShell db]]
-  condCats := InvestigateConditions(db,[$catsig,:rest catvecListMaker],$e)
+  tbl := makeTable function valueEq?
+  condCats := InvestigateConditions(db,[$catsig,:rest catvecListMaker],tbl,$e)
   -- a list, one %for each element of catvecListMaker
   -- indicating under what conditions this
   -- category should be present.  true => always