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

	(categoryAncestors): Likewise.
	* interp/functor.boot (DescendCodeAdd): Tidy.
	(DescendCodeVarAdd): Fix thinko.  Iterator over $domainShell.
	Don't pretend constants have ELT implementations.
	* interp/nruncomp.boot (buildFunctor): Tidy.

4 files changed, 39 insertions, 21 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 685ae8bc..164311a1 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,14 @@
 2011-08-16  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
+	* interp/c-util.boot (categoryPrincipals): New.
+	(categoryAncestors): Likewise.
+	* interp/functor.boot (DescendCodeAdd): Tidy.
+	(DescendCodeVarAdd): Fix thinko.  Iterator over $domainShell.
+	Don't pretend constants have ELT implementations.
+	* interp/nruncomp.boot (buildFunctor): Tidy.
+
+2011-08-16  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
 	* interp/modemap.boot (addModemap0): Don't special-case
 	CategoryDefaults. 
 	* interp/define.boot (processFunctor): Fold into caller.  Remove.
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 9b633a04..4ad94273 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -89,6 +89,14 @@ macro categoryAttributes d ==
 macro categoryHierarchy c ==
   categoryRef(c,4)
 
+++ Return the list of principal ancestors of category `c'.  
+macro categoryPrincipals c ==
+  first categoryHierarchy c
+
+++ Return the list of [ancestor,predicate,index] data of catagory `c'.  
+macro categoryAncestors c ==
+  second categoryHierarchy c
+
 ++ Reference a 3-list
 ++   [lookupFunction,thisDomain,optable]
 ++ necessary for function lookup in a domain:
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index e3782d26..fc44b8c8 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -364,12 +364,13 @@ mkTypeForm x ==
  
 DescendCodeAdd(base,flag) ==
   base isnt [.,:.] => DescendCodeVarAdd(base,flag)
-  not (modemap:=get(opOf base,'modemap,$CategoryFrame)) =>
-      if getmode(opOf base,$e) is ["Mapping",target,:formalArgModes]
-         then formalArgs:= take(#formalArgModes,$FormalMapVariableList)
+  modemap := get(base.op,'modemap,$CategoryFrame)
+  modemap = nil  =>
+      if getmode(base.op,$e) is ["Mapping",target,:formalArgModes]
+         then formalArgs := take(#formalArgModes,$FormalMapVariableList)
                 --argument substitution if parameterized?
  
-         else keyedSystemError("S2OR0001",[opOf base])
+         else keyedSystemError("S2OR0001",[base.op])
       DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes)
   for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat
     (ans:= DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes))=>
@@ -771,10 +772,9 @@ getViewsConditions u ==
       --if you don't want it, rest it off
  
 DescendCodeVarAdd(base,flag) ==
-   princview := first $catvecList
-   [SetFunctionSlots(sig,substitute('ELT,'CONST,implem),flag,'adding) repeat
-       for i in 6..maxIndex princview |
-         princview.i is [sig:=[op,types],:.] and
+   [SetFunctionSlots(sig,implem,flag,'adding) repeat
+       for i in 6..maxIndex $domainShell |
+         categoryRef($domainShell,i) is [sig:=[op,types],:.] and
            LASSOC([base,:substitute(base,'$,types)],get(op,'modemap,$e)) is
                   [[pred,implem]]]
  
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index fcd0ea1f..0752edc4 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -479,22 +479,23 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
   $epilogue: local := nil     --code to set slot 5, things to be done last
   $HackSlot4: local := nil  --Invention of JHD 13/July/86-set in InvestigateConditions
   $extraParms:local := nil  --Set in DomainSubstitutionFunction
-  $devaluateList: local := nil --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later
-  $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList]
+  $devaluateList: local :=
+    --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later
+    [[arg,:b] for arg in args for b in $ModeVariableList]
   $supplementaries: local := nil
    --set in InvestigateConditions to represent any additional
    --category membership tests that may be needed(see buildFunctor for details)
 
   oldtime:= TEMPUS_-FUGIT()
-  [$catsig,:argsig]:= sig
-  catvecListMaker:=removeDuplicates
-    [(comp($catsig,$EmptyMode,$e)).expr,
-      :[compCategories first u for u in second $domainShell.4]]
-  condCats:= InvestigateConditions [$catsig,:rest catvecListMaker]
+  [$catsig,:argsig] := sig
+  catvecListMaker := removeDuplicates
+    [comp($catsig,$EmptyMode,$e).expr,
+      :[compCategories u for [u,:.] in categoryAncestors $domainShell]]
+  condCats := InvestigateConditions [$catsig,:rest catvecListMaker]
   -- a list, one %for each element of catvecListMaker
   -- indicating under what conditions this
   -- category should be present.  true => always
-  makeCatvecCode:= first catvecListMaker
+  makeCatvecCode := first catvecListMaker
   emptyVector := vector []
   domainShell := newShell($NRTbase + $NRTdeltaLength)
   for i in 0..4 repeat
@@ -539,21 +540,21 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) ==
     createPredVecCode := ["pv$",predBitVectorCode1]
 
   --CODE: part 1
-  codePart1:= [setVector0Code, slot3Code,:slamCode] where
-    setVector0Code:=['%store,['%tref,"$",0],"dv$"]
+  codePart1 := [setVector0Code, slot3Code,:slamCode] where
+    setVector0Code := ['%store,['%tref,"$",0],"dv$"]
     slot3Code := ['%store,['%tref,"$",3],"pv$"]
-    slamCode:=
+    slamCode :=
       isCategoryPackageName name => nil
       [NRTaddToSlam($definition,"$")]
 
   --CODE: part 3
   $ConstantAssignments :=
       [NRTputInLocalReferences code for code in $ConstantAssignments]
-  codePart3:= [:$ConstantAssignments,:$epilogue]
+  codePart3 := [:$ConstantAssignments,:$epilogue]
   ans := ["%bind",bindings,
            :washFunctorBody optFunctorBody
               [:codePart1,:codePart2,:codePart3],"$"]
-  $getDomainCode:= nil
+  $getDomainCode := nil
     --if we didn't kill this, DEFINE would insert it in the wrong place
   SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime]
   ans