* interp/c-util.boot (categoryHierarchy): New.

	* interp/category.boot (mkCategory): Use it.
	* interp/define.boot (NRTgetLookupFunction): Tidy.
	(catExtendsCat?): Lose last argument.  Adjust callers.

4 files changed, 33 insertions, 25 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 7cd76c99..c0e9bcbf 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,10 @@
+2011-08-08  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* interp/c-util.boot (categoryHierarchy): New.
+	* interp/category.boot (mkCategory): Use it.
+	* interp/define.boot (NRTgetLookupFunction): Tidy.
+	(catExtendsCat?): Lose last argument.  Adjust callers.
+
 2011-08-07  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* interp/define.boot (templateVal): Fold into expantTypeArgs. Remove. 
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index af1888ec..1d281ea8 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -81,6 +81,10 @@ macro categoryExports d ==
 macro categoryAttributes d ==
   categoryRef(d,2)
 
+++ Return a 3-list of data describing the hierarchy of category `c'.
+macro categoryHierarchy c ==
+  categoryRef(c,4)
+
 ++ Return the predicate values associated with the domain object.
 ++ This is an integer interpreted as bit vector
 macro domainPredicates d ==
diff --git a/src/interp/category.boot b/src/interp/category.boot
index 1a9073e2..80d1fe86 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -120,10 +120,10 @@ mkCategory(domainOrPackage,sigList,attList,domList,PrincipalAncestor) ==
   if PrincipalAncestor ~= nil then
     for x in 6..#PrincipalAncestor-1 repeat 
       categoryRef(v,x) := PrincipalAncestor.x
-    categoryRef(v,4) :=
+    categoryHierarchy(v) :=
       [first PrincipalAncestor.4,second PrincipalAncestor.4,OldLocals]
   else
-    categoryRef(v,4) := [nil,nil,OldLocals] --associated categories and domains
+    categoryHierarchy(v) := [nil,nil,OldLocals]
   categoryRef(v,5) := domList
   for [nsig,:n] in NSigList repeat 
     categoryRef(v,n) := nsig
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 22c0711d..80145927 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -274,17 +274,16 @@ NRTgetLookupFunction(domform,exCategory,addForm) ==
   addForm := applySubst($pairlis,addForm)
   $why: local := nil
   addForm isnt [.,:.] => 'lookupComplete
-  extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm)
-  if null extends then 
-    [u,msg,:v] := $why
-    SAY '"--------------non extending category----------------------"
-    sayPatternMsg('"%1p of category %2p", [domform,u])
-    if v ~= nil then
-      sayPatternMsg('"%1b %2p",[msg,first v])
-    else
-      sayPatternMsg('"%1b",[msg])
-    SAY '"----------------------------------------------------------"
-  extends => 'lookupIncomplete
+  NRTextendsCategory1(domform,exCategory,getExportCategory addForm) =>
+    'lookupIncomplete
+  [u,msg,:v] := $why
+  SAY '"--------------non extending category----------------------"
+  sayPatternMsg('"%1p of category %2p", [domform,u])
+  if v ~= nil then
+    sayPatternMsg('"%1b %2p",[msg,first v])
+  else
+    sayPatternMsg('"%1b",[msg])
+  SAY '"----------------------------------------------------------"
   'lookupComplete
 
 getExportCategory form ==
@@ -320,27 +319,25 @@ extendsCategory(dom,u,v) ==
  
 extendsCategoryBasic(dom,u,v) ==
   v is ['IF,p,['ATTRIBUTE,c],.] =>
-    uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr
+    uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr
     cons? c and isCategoryForm(c,nil) =>
-      slot4 := vectorRef(uVec,4)
-      LASSOC(c,second slot4) is [=p,:.]
-    slot2 := vectorRef(uVec,2)
-    LASSOC(c,slot2) is [=p,:.]
+      LASSOC(c,second categoryHierarchy uVec) is [=p,:.]
+    LASSOC(c,categoryAttributes uVec) is [=p,:.]
   u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l]
   u = v => true
-  uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr
-  isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec)
+  isCategoryForm(v,nil) => catExtendsCat?(u,v)
   v is ['SIGNATURE,op,sig] =>
-    or/[vectorRef(uVec,i) is [[=op,=sig],:.] for i in 6..maxIndex uVec]
+    uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr
+    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,uvec) ==
+catExtendsCat?(u,v) ==
   u = v => true
-  uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr
-  slot4 := vectorRef(uvec,4)
+  uvec := compMakeCategoryObject(u,$EmptyEnvironment).expr
+  slot4 := categoryHierarchy uvec
   prinAncestorList := first slot4
   listMember?(v,prinAncestorList) => true
   vOp := KAR v
@@ -350,7 +347,7 @@ catExtendsCat?(u,v,uvec) ==
     PRINT similarForm
     sayBrightlyNT '"   but not "
     PRINT v
-  or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT second slot4]
+  or/[catExtendsCat?(x,v) for x in ASSOCLEFT second slot4]
  
 substSlotNumbers(form,template,domain) ==
   form is [op,:.] and