diff options
| -rw-r--r-- | src/ChangeLog | 21 | ||||
| -rw-r--r-- | src/interp/category.boot | 118 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 20 | ||||
| -rw-r--r-- | src/interp/define.boot | 91 | ||||
| -rw-r--r-- | src/interp/functor.boot | 52 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 2 |
6 files changed, 163 insertions, 141 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index a955a89f..e8c5bec1 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,24 @@ +2011-08-19 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * interp/category.boot (mkOr): Taken environment as parameter. + Adjust callers. + (mkOr2): Likewise. + (mkAnd): Likewise. + (mkAnd2): Likewise. + (FindFundAncs): Likewise. + (CatEval): Likewise. + (AncestorP): Likewise. + (CondAncestorP): Likewise. + (DescendantP): Likewise. + * interp/compiler.boot (compMapCond): Likewise. + (compMapCond'): Likewise. + * interp/define.boot (formatPred): Likewise. + (formatInfo): Likewise. + (addInfo): Likewise. + (knownPred): Likewise. + * interp/functor.boot (InvestigateConditions): Likewise. + (ICformat): Likewise. + 2011-08-18 Alfredo Portes <doyenatccny@gmail.com> * sman/sman.c: Do not try to start graphic components diff --git a/src/interp/category.boot b/src/interp/category.boot index e73cccd9..dd5a9839 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -175,13 +175,13 @@ SigListUnion(extra,original) == original := [x,:original] else original:= [[xsig,xpred,["Subsumed",:esig]],:original] - else epred:=mkOr(epred,xpred) + else epred := mkOr(epred,xpred,$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),:ximplem] +-- e:= [esig,mkOr(xpred,epred,$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 @@ -191,18 +191,18 @@ SigListUnion(extra,original) == original:= [e,:original] original -mkOr: (%Form,%Form) -> %Form -mkOr(a,b) == +mkOr: (%Form,%Form,%Env) -> %Form +mkOr(a,b,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') ) - b is ["OR",:b'] => mkOr2(a,b') + (b is ["OR",:b'] => union(a',b'); mkOr2(b,a',e) ) + b is ["OR",:b'] => mkOr2(a,b',e) (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) => - DescendantP(acat,bcat) => [b] - DescendantP(bcat,acat) => [a] + DescendantP(acat,bcat,e) => [b] + DescendantP(bcat,acat,e) => [a] [a,b] a is ['AND,:a'] and listMember?(b,a') => [b] b is ['AND,:b'] and listMember?(a,b') => [a] @@ -212,47 +212,47 @@ mkOr(a,b) == #l = 1 => first l ["OR",:l] -mkOr2: (%Form,%Form) -> %Form -mkOr2(a,b) == +mkOr2: (%Form,%Form,%Env) -> %Form +mkOr2(a,b,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 - DescendantP(acat,ccat) => + DescendantP(acat,ccat,e) => return (aRedundant:=true) - if DescendantP(ccat,acat) then b := remove(b,c) + if DescendantP(ccat,acat,e) then b := remove(b,c) aRedundant => b [a,:b] [a,:b] -mkAnd: (%Form,%Form) -> %Form -mkAnd(a,b) == +mkAnd: (%Form,%Form,%Env) -> %Form +mkAnd(a,b,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') ) - b is ["AND",:b'] => mkAnd2(a,b') + (b is ["AND",:b'] => union(a',b'); mkAnd2(b,a',e) ) + b is ["AND",:b'] => mkAnd2(a,b',e) (a is ["has",avar,acat]) and (b is ["has",=avar,bcat]) => - DescendantP(acat,bcat) => [a] - DescendantP(bcat,acat) => [b] + DescendantP(acat,bcat,e) => [a] + DescendantP(bcat,acat,e) => [b] [a,b] [a,b] #l = 1 => first l ["AND",:l] -mkAnd2: (%Form,%Form) -> %Form -mkAnd2(a,b) == +mkAnd2: (%Form,%Form,%Env) -> %Form +mkAnd2(a,b,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 - DescendantP(ccat,acat) => + DescendantP(ccat,acat,e) => return (aRedundant:=true) - if DescendantP(acat,ccat) then b := remove(b,c) + if DescendantP(acat,ccat,e) then b := remove(b,c) aRedundant => b [a,:b] [a,:b] @@ -303,71 +303,70 @@ MachineLevelSubset(a,b) == --% Ancestor chasing code -FindFundAncs l == +FindFundAncs(l,e) == --l is a list of categories and associated conditions (a list of 2-lists --returns a list of them and all their fundamental ancestors --also as two-lists with the appropriate conditions l=nil => nil - f1:= CatEval CAAR l - canonicalForm f1 = nil => FindFundAncs rest l - ans:= FindFundAncs rest l - for u in FindFundAncs [[CatEval first x,mkAnd(CADAR l,second x)] - for x in categoryAncestors f1] repeat + f1 := CatEval(CAAR l,e) + canonicalForm f1 = nil => FindFundAncs(rest l,e) + ans := FindFundAncs(rest l,e) + for u in FindFundAncs([[CatEval(first x,e),mkAnd(CADAR l,second x,e)] + for x in categoryAncestors f1],e) repeat x:= ASSQ(first u,ans) => - ans:= [[first u,mkOr(second x,second u)],:remove(ans,x)] + ans:= [[first u,mkOr(second x,second u,e)],:remove(ans,x)] ans:= [u,:ans] --testing to see if first l is already there - x:= ASSQ(CAAR l,ans) => [[CAAR l,mkOr(CADAR l,second x)],:remove(ans,x)] + x:= ASSQ(CAAR l,ans) => [[CAAR l,mkOr(CADAR l,second x,e)],:remove(ans,x)] CADAR l=true => for x in categoryPrincipals f1 repeat - if y:= ASSQ(CatEval x,ans) then ans := remove(ans,y) + if y:= ASSQ(CatEval(x,e),ans) then ans := remove(ans,y) [first l,:ans] for x in categoryPrincipals f1 repeat - if y:= ASSQ(CatEval x,ans) then ans:= - [[first y,mkOr(CADAR l,second y)],:remove(ans,y)] + if y:= ASSQ(CatEval(x,e),ans) then ans:= + [[first y,mkOr(CADAR l,second y,e)],:remove(ans,y)] [first l,:ans] -- Our new thing may have, as an alternate view, a principal -- descendant of something previously added which is therefore -- subsumed -CatEval: %Thing -> %Shell -CatEval x == +CatEval: (%Thing,%Env) -> %Shell +CatEval(x,e) == vector? x => x - e := - $InteractiveMode => $CategoryFrame - $e + if $InteractiveMode then + e := $CategoryFrame compMakeCategoryObject(x,e).expr -AncestorP: (%Form, %List %Instantiation) -> %Form -AncestorP(xname,leaves) == +AncestorP: (%Form,%List %Instantiation,%Env) -> %Form +AncestorP(xname,leaves,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) => return y + listMember?(xname,categoryPrincipals CatEval(y,env)) => return y -CondAncestorP(xname,leaves,condition) == +CondAncestorP(xname,leaves,condition,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') => + xname = u' or listMember?(xname,categoryPrincipals CatEval(u',env)) => PredImplies(ucond,condition) => 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'. -DescendantP: (%Form,%Form) -> %Boolean -DescendantP(a,b) == +DescendantP: (%Form,%Form,%Env) -> %Boolean +DescendantP(a,b,e) == a=b => true a is ["ATTRIBUTE",:.] => false a is ["SIGNATURE",:.] => false - a:= CatEval a + a:= CatEval(a,e) b is ["ATTRIBUTE",b'] => (l := assoc(b',categoryAttributes a)) => TruthP second l listMember?(b,categoryPrincipals a) => true - AncestorP(b,[first u for u in categoryAncestors a]) => true + AncestorP(b,[first u for u in categoryAncestors a],e) => true false --% The implementation of Join @@ -388,16 +387,17 @@ JoinInner(l,$e) == pred:= second at -- The predicate under which this category is conditional listMember?(pred,get("$Information","special",$e)) => - l:= [:l,CatEval at2] + l:= [:l,CatEval(at2,$e)] --It's true, so we add this as unconditional - not (pred is ["and",:.]) => CondList:= [[CatEval at2,pred],:CondList] + pred isnt ["and",:.] => + CondList := [[CatEval(at2,$e),pred],:CondList] pred':= [u for u in rest pred | not listMember?(u,get("$Information","special",$e)) and not (u=true)] - null pred' => l:= [:l,CatEval at2] - # pred'=1 => CondList:= [[CatEval at2,pred'],:CondList] - CondList:= [[CatEval at2,["and",:pred']],:CondList] + null pred' => l:= [:l,CatEval(at2,$e)] + # pred'=1 => CondList:= [[CatEval(at2,$e),pred'],:CondList] + CondList:= [[CatEval(at2,$e),["and",:pred']],:CondList] [$NewCatVec,:l]:= l l':= [:CondList,:[[u,true] for u in l]] -- This is a list of all the categories that this extends @@ -414,17 +414,17 @@ JoinInner(l,$e) == -- this flag helps us detect this case originalVector := false -- this skips buggy code which discards needed categories - for [b,condition] in FindFundAncs l' repeat + for [b,condition] in FindFundAncs(l',$e) repeat --This loop implements Category Subsumption --as described in JHD's report if not (b.0=nil) then --It's a named category bname:= b.0 - CondAncestorP(bname,FundamentalAncestors,condition) => nil - (f:=AncestorP(bname,[first u for u in FundamentalAncestors])) => + CondAncestorP(bname,FundamentalAncestors,condition,$e) => nil + (f:=AncestorP(bname,[first u for u in FundamentalAncestors],$e)) => [.,.,index]:=assoc(f,FundamentalAncestors) FundamentalAncestors:=[[bname,condition,index],:FundamentalAncestors] - PrinAncb := categoryPrincipals CatEval bname + PrinAncb := categoryPrincipals CatEval(bname,$e) --Principal Ancestors of b reallynew:= true for anc in FundamentalAncestors repeat @@ -455,7 +455,7 @@ JoinInner(l,$e) == then ($NewCatVec.ancindex:= bname; reallynew:= nil) else if originalVector and (condition=true) then - $NewCatVec:= CatEval bname + $NewCatVec:= CatEval(bname,$e) copied:= nil FundamentalAncestors:= [[bname],:categoryAncestors $NewCatVec] --bname is Principal, so comes first @@ -516,8 +516,8 @@ JoinInner(l,$e) == second v=true => nil attl:= remove(attl,v) attl:= - second u=true => [[first u,mkOr(second v,newpred)],:attl] - [[first u,mkOr(second v,mkAnd(newpred,second u))],:attl] + second u=true => [[first u,mkOr(second v,newpred,$e)],:attl] + [[first u,mkOr(second v,mkAnd(newpred,second u,$e),$e)],:attl] sigl:= SigListUnion( [AddPredicate(DropImplementations u,newpred) for u in categoryExports(first b)],sigl) where diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index abf2f685..3e828bba 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1918,7 +1918,7 @@ compViableModemap(op,argTl,mm,e) == argTl = "failed" => nil -- 2. obtain domain-specific function, if possible - f := compMapCond(dc,fnsel) or return nil + f := compMapCond(dc,fnsel,e) or return nil -- 3. Mark `f' as used. -- We can no longer trust what the modemap says for a reference into @@ -1948,13 +1948,13 @@ compApplyModemap(form,modemap,$e) == -- 2. Select viable modemap implementation. compViableModemap(op,lt,modemap,$e) -compMapCond': (%Form,%Mode) -> %Boolean -compMapCond'(cexpr,dc) == +compMapCond': (%Form,%Mode,%Env) -> %Boolean +compMapCond'(cexpr,dc,env) == cexpr=true => true - cexpr is ["AND",:l] => and/[compMapCond'(u,dc) for u in l] - cexpr is ["OR",:l] => or/[compMapCond'(u,dc) for u in l] - cexpr is ["not",u] => not compMapCond'(u,dc) - cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) + cexpr is ["AND",:l] => and/[compMapCond'(u,dc,env) for u in l] + cexpr is ["OR",:l] => or/[compMapCond'(u,dc,env) for u in l] + cexpr is ["not",u] => not compMapCond'(u,dc,env) + cexpr is ["has",name,cat] => (knownInfo(cexpr,env) => true; false) --for the time being we'll stop here - shouldn't happen so far --$disregardConditionIfTrue => true --stackSemanticError(("not known that",'"%b",name, @@ -1965,9 +1965,9 @@ compMapCond'(cexpr,dc) == stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) false -compMapCond: (%Mode,%List %Code) -> %Code -compMapCond(dc,[cexpr,fnexpr]) == - compMapCond'(cexpr,dc) => fnexpr +compMapCond: (%Mode,%List %Code,%Env) -> %Code +compMapCond(dc,[cexpr,fnexpr],env) == + compMapCond'(cexpr,dc,env) => fnexpr stackMessage('"not known that %1pb has %2pb",[dc,cexpr]) diff --git a/src/interp/define.boot b/src/interp/define.boot index b1feafef..67802fc4 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -147,54 +147,53 @@ liftCond (clause is [ante,conseq]) == ["and",pred,conj] [clause] -formatPred u == - --Assumes that $e is set up to point to an environment +formatPred(u,e) == u is ["has",a,b] => - b isnt [.,:.] and isCategoryForm([b],$e) => ["has",a,[b]] + b isnt [.,:.] and isCategoryForm([b],e) => ["has",a,[b]] b isnt [.,:.] => ["has",a,["ATTRIBUTE",b]] - isCategoryForm(b,$e) => u + isCategoryForm(b,e) => u b is ["ATTRIBUTE",.] => u b is ["SIGNATURE",:.] => u ["has",a,["ATTRIBUTE",b]] u isnt [.,:.] => u - u is ["and",:v] => ["and",:[formatPred w for w in v]] + u is ["and",:v] => ["and",:[formatPred(w,e) for w in v]] systemError ['"formatPred",u] -formatInfo u == +formatInfo(u,e) == u isnt [.,:.] => u u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] - u is ["PROGN",:l] => ["PROGN",:[formatInfo v for v in l]] + u is ["PROGN",:l] => ["PROGN",:[formatInfo(v,e) for v in l]] u is ["ATTRIBUTE",v] => -- The parser can't tell between those attributes that really -- are attributes, and those that are category names - v isnt [.,:.] and isCategoryForm([v],$e) => ["has","$",[v]] + v isnt [.,:.] and isCategoryForm([v],e) => ["has","$",[v]] v isnt [.,:.] => ["ATTRIBUTE","$",v] - isCategoryForm(v,$e) => ["has","$",v] + isCategoryForm(v,e) => ["has","$",v] ["ATTRIBUTE","$",v] u is ["IF",a,b,c] => - c="%noBranch" => ['%when,:liftCond [formatPred a,formatInfo b]] - b="%noBranch" => ['%when,:liftCond [["not",formatPred a],formatInfo c]] - ['%when,:liftCond [formatPred a,formatInfo b],: - liftCond [["not",formatPred a],formatInfo c]] + c is "%noBranch" => + ['%when,:liftCond [formatPred(a,e),formatInfo(b,e)]] + b is "%noBranch" => + ['%when,:liftCond [["not",formatPred(a,e)],formatInfo(c,e)]] + ['%when,:liftCond [formatPred(a,e),formatInfo(b,e)],: + liftCond [["not",formatPred(a,e)],formatInfo(c,e)]] systemError ['"formatInfo",u] -addInfo u == - $Information:= [formatInfo u,:$Information] +addInfo(u,e) == + $Information:= [formatInfo(u,e),:$Information] -addInformation(m,$e) == +addInformation(m,e) == $Information: local := nil - info m where - info m == + info(m,e) where + info(m,e) == --Processes information from a mode declaration in compCapsule m isnt [.,:.] => nil - m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo u - m is ["Join",:stuff] => for u in stuff repeat info u + m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo(u,e) + m is ["Join",:stuff] => for u in stuff repeat info(u,e) nil - $e:= - put("$Information","special",[:$Information,: - get("$Information","special",$e)],$e) - $e + put("$Information","special", + [:$Information,:get("$Information","special",e)],e) hasToInfo (pred is ["has",a,b]) == b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data] @@ -203,48 +202,48 @@ hasToInfo (pred is ["has",a,b]) == ++ Return true if we are certain that the information ++ denotated by `pred' is derivable from the current environment. -knownInfo pred == +knownInfo(pred,env) == pred=true => true - listMember?(pred,get("$Information","special",$e)) => true - pred is ["OR",:l] => or/[knownInfo u for u in l] - pred is ["AND",:l] => and/[knownInfo u for u in l] - pred is ["or",:l] => or/[knownInfo u for u in l] - pred is ["and",:l] => and/[knownInfo u for u in l] + listMember?(pred,get("$Information","special",env)) => true + pred is ["OR",:l] => or/[knownInfo(u,env) for u in l] + pred is ["AND",:l] => and/[knownInfo(u,env) for u in l] + pred is ["or",:l] => or/[knownInfo(u,env) for u in l] + pred is ["and",:l] => and/[knownInfo(u,env) for u in l] pred is ["ATTRIBUTE",name,attr] => - v := compForMode(name,$EmptyMode,$e) or return + v := compForMode(name,$EmptyMode,env) or return stackAndThrow('"can't find category of %1pb",[name]) - [vv,.,.] := compMakeCategoryObject(v.mode,$e) or return + [vv,.,.] := compMakeCategoryObject(v.mode,env) or return stackAndThrow('"can't make category of %1pb",[name]) listMember?(attr,categoryAttributes vv) => true - x := assoc(attr,categoryAttributes vv) => knownInfo second x + x := assoc(attr,categoryAttributes vv) => knownInfo(second x,env) --format is a list of two elements: information, predicate false pred is ["has",name,cat] => - cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] - cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] + cat is ["ATTRIBUTE",:a] => knownInfo(["ATTRIBUTE",name,:a],env) + cat is ["SIGNATURE",:a] => knownInfo(["SIGNATURE",name,:a],env) -- unnamed category expressions imply structural checks. - cat is ["Join",:.] => and/[knownInfo ["has",name,c] for c in cat.args] + cat is ["Join",:.] => and/[knownInfo(["has",name,c],env) for c in cat.args] cat is ["CATEGORY",.,:atts] => - and/[knownInfo hasToInfo ["has",name,att] for att in atts] + and/[knownInfo(hasToInfo ["has",name,att],env) for att in atts] name is ['Union,:.] => false -- we have a named category expression - v:= compForMode(name,$EmptyMode,$e) or return + v:= compForMode(name,$EmptyMode,env) or return stackAndThrow('"can't find category of %1pb",[name]) vmode := v.mode cat = vmode => true vmode is ["Join",:l] and listMember?(cat,l) => true - [vv,.,.]:= compMakeCategoryObject(vmode,$e) or return + [vv,.,.]:= compMakeCategoryObject(vmode,env) or return stackAndThrow('"cannot find category %1pb",[vmode]) listMember?(cat,categoryPrincipals vv) => true --checks princ. ancestors - (u:=assoc(cat,categoryAncestors vv)) and knownInfo second u => true + (u:=assoc(cat,categoryAncestors vv)) and knownInfo(second u,env) => true -- previous line checks fundamental anscestors, we should check their -- principal anscestors but this requires instantiating categories - or/[AncestorP(cat,[first u]) - for u in categoryAncestors vv | knownInfo second u] => true + or/[AncestorP(cat,[first u],env) + for u in categoryAncestors vv | knownInfo(second u,env)] => true false pred is ["SIGNATURE",name,op,sig,:.] => - v:= get(op,"modemap",$e) + v:= get(op,"modemap",env) for w in v repeat ww := w.mmSignature --the actual signature part ww = sig => @@ -340,7 +339,7 @@ infoToHas a == chaseInferences(pred,$e) == foo hasToInfo pred where foo pred == - knownInfo pred => nil + knownInfo(pred,$e) => nil $e:= actOnInfo(pred,$e) pred:= infoToHas pred for u in get("$Information","special",$e) repeat @@ -1114,7 +1113,7 @@ getModemap(x is [op,:.],e) == addModemap(op,mc,sig,pred,fn,$e) == $InteractiveMode => $e - if knownInfo pred then pred:=true + if knownInfo(pred,$e) then pred:=true $insideCapsuleFunctionIfTrue => $CapsuleModemapFrame := addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) @@ -1919,7 +1918,7 @@ getSignature(op,argModeList,$e) == removeDuplicates [sig for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ - and sig.source = argModeList and knownInfo pred]) => first sigl + and sig.source = argModeList and knownInfo(pred,$e)]) => first sigl null sigl => (u:= getmode(op,$e)) is ['Mapping,:sig] => sig SAY '"************* USER ERROR **********" diff --git a/src/interp/functor.boot b/src/interp/functor.boot index d3c5823c..f8a2ff11 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -585,7 +585,7 @@ makeMissingFunctionEntry(alist,i) == --% Under what conditions may views exist? -InvestigateConditions catvecListMaker == +InvestigateConditions(catvecListMaker,env) == -- given a principal view and a list of secondary views, -- discover under what conditions the secondary view are -- always present. @@ -626,8 +626,10 @@ InvestigateConditions catvecListMaker == [true,:[true for u in secondaries]] $HackSlot4:= MinimalPrimary=MaximalPrimary => nil - MaximalPrimaries:=[MaximalPrimary,:categoryPrincipals CatEval MaximalPrimary] - MinimalPrimaries:=[MinimalPrimary,:categoryPrincipals CatEval MinimalPrimary] + MaximalPrimaries := + [MaximalPrimary,:categoryPrincipals CatEval(MaximalPrimary,env)] + MinimalPrimaries := + [MinimalPrimary,:categoryPrincipals CatEval(MinimalPrimary,env)] MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) [[x] for x in MaximalPrimaries] ($Conditions:= Conds($principal,nil)) where @@ -657,31 +659,31 @@ InvestigateConditions catvecListMaker == # u=1 => first u ['AND,:u] for [v,:.] in newS repeat - for v' in [v,:categoryPrincipals CatEval v] repeat + for v' in [v,:categoryPrincipals CatEval(v,env)] repeat if (w:=assoc(v',$HackSlot4)) then - w.rest := if rest w then mkOr(u,rest w) else u - (list:= update(list,u,secondaries,newS)) where - update(list,cond,secondaries,newS) == + 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) == (list2:= - [flist(sec,newS,old,cond) for sec in secondaries for old in list]) where - flist(sec,newS,old,cond) == + [flist(sec,newS,old,cond,env) for sec in secondaries for old in list]) where + flist(sec,newS,old,cond,env) == old=true => old for [newS2,:morecond] in newS repeat old:= - not AncestorP(sec,[newS2]) => old - cond2:= mkAnd(cond,morecond) + not AncestorP(sec,[newS2],env) => old + cond2 := mkAnd(cond,morecond,env) null old => cond2 - mkOr(cond2,old) + mkOr(cond2,old,env) old list2 - list:= [[sec,:ICformat u] for u in list for sec in secondaries] + list:= [[sec,:ICformat(u,env)] for u in list for sec in secondaries] pv:= getPossibleViews $principal -- $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 for u in $HackSlot4]) where - reshape u == - ['%when,[TryGDC ICformat rest u], + ($HackSlot4:= [reshape(u,env) for u in $HackSlot4]) where + reshape(u,env) == + ['%when,[TryGDC ICformat(rest u,env)], ['%otherwise,['RPLACA,'(CAR TrueDomain), ['delete,['QUOTE,first u],'(CAAR TrueDomain)]]]] $supplementaries:= @@ -690,32 +692,32 @@ InvestigateConditions catvecListMaker == and not (true=rest u) and not listMember?(first u,pv)] [true,:[LASSOC(ms,list) for ms in masterSecondaries]] -ICformat u == +ICformat(u,env) == u isnt [.,:.] => u u is ["has",:.] => compHasFormat u u is ['AND,:l] or u is ['and,:l] => - l:= removeDuplicates [ICformat v for [v,:l'] in tails l + l:= removeDuplicates [ICformat(v,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) + l1 := mkAnd(u,l1,env) l1 u is ['OR,:l] => (l:= ORreduce l) - # l=1 => ICformat first l - l:= ORreduce removeDuplicates [ICformat u for u in l] + # l=1 => ICformat(first l,env) + l:= ORreduce removeDuplicates [ICformat(u,env) for u in l] --causes multiple ANDs to be squashed, etc. -- and duplicates that have been built up by tidying - (l:= Hasreduce l) where - Hasreduce l == + (l:= Hasreduce(l,env)) where + Hasreduce(l,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 DescendantP(cond,cond2) then l:= remove(l,u) + if DescendantP(cond,cond2,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, @@ -723,7 +725,7 @@ ICformat u == --check that v causes descendants to go for v in l | v is ['HasCategory, =name,['QUOTE, cond2]] repeat - if DescendantP(cond,cond2) then l:= remove(l,u) + if DescendantP(cond,cond2,env) then l:= remove(l,u) --v subsumes u l # l=1 => first l diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index d8703729..8f0fff7d 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -491,7 +491,7 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) == catvecListMaker := removeDuplicates [comp($catsig,$EmptyMode,$e).expr, :[compCategories u for [u,:.] in categoryAncestors $domainShell]] - condCats := InvestigateConditions [$catsig,:rest catvecListMaker] + condCats := InvestigateConditions([$catsig,:rest catvecListMaker],$e) -- a list, one %for each element of catvecListMaker -- indicating under what conditions this -- category should be present. true => always |