diff options
| -rw-r--r-- | src/ChangeLog | 9 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 8 | ||||
| -rw-r--r-- | src/interp/functor.boot | 16 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 27 |
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 |