diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/compiler.boot | 16 | ||||
| -rw-r--r-- | src/interp/define.boot | 10 | ||||
| -rw-r--r-- | src/interp/functor.boot | 12 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 31 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 4 |
5 files changed, 37 insertions, 36 deletions
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 3e828bba..49aa460a 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1231,26 +1231,26 @@ compElt(form,m,E) == --% HAS compHas: (%Form,%Mode,%Env) -> %Maybe %Triple -compHas(pred is ["has",a,b],m,$e) == - $e:= chaseInferences(pred,$e) - predCode:= compHasFormat pred - coerce([predCode,$Boolean,$e],m) +compHas(pred is ["has",a,b],m,e) == + e := chaseInferences(pred,e) + predCode := compHasFormat(pred,e) + coerce([predCode,$Boolean,e],m) --used in various other places to make the discrimination -compHasFormat (pred is ["has",olda,b]) == +compHasFormat(pred is ["has",olda,b],e) == argl := rest $form formals := TAKE(#argl,$FormalMapVariableList) a := applySubst(pairList(formals,argl),olda) - [a,:.] := comp(a,$EmptyMode,$e) or return nil + [a,.,e] := comp(a,$EmptyMode,e) or return nil a := applySubst(pairList(argl,formals),a) b is ["ATTRIBUTE",c] => ["HasAttribute",a,["QUOTE",c]] b is ["SIGNATURE",op,sig,:.] => ["HasSignature",a, mkList [MKQ op,mkList [mkTypeForm type for type in sig]]] b is ["Join",:l] or b is ["CATEGORY",.,:l] => - ["AND",:[compHasFormat ["has",olda,c] for c in l]] - isCategoryForm(b,$e) => ["HasCategory",a,mkTypeForm b] + ["AND",:[compHasFormat(["has",olda,c],e) for c in l]] + isCategoryForm(b,e) => ["HasCategory",a,mkTypeForm b] stackAndThrow('"Second argument to %1b must be a category, or a signature or an attribute",["has"]) --% IF diff --git a/src/interp/define.boot b/src/interp/define.boot index f4675b08..ef251ab9 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -360,8 +360,8 @@ getInfovecCode() == ['LIST, MKQ makeDomainTemplate $template, MKQ makeCompactDirect $NRTslot1Info, - MKQ NRTgenFinalAttributeAlist(), - NRTmakeCategoryAlist(), + MKQ NRTgenFinalAttributeAlist $e, + NRTmakeCategoryAlist $e, MKQ $lookupFunction] --======================================================================= @@ -425,7 +425,7 @@ makeCompactDirect1(op,items) == n is [p,:.] => p --the rest is linenumber of function definition n predCode := - s is [pred,:.] => predicateBitIndex pred + s is [pred,:.] => predicateBitIndex(pred,$e) 0 --> drop items which are not present (predCode = -1) predCode = -1 => return nil @@ -480,7 +480,7 @@ depthAssoc x == getCatAncestors x == [CAAR y for y in parentsOf opOf x] -NRTmakeCategoryAlist() == +NRTmakeCategoryAlist e == $depthAssocCache: local := hashTable 'EQ $catAncestorAlist: local := nil pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] @@ -488,7 +488,7 @@ NRTmakeCategoryAlist() == opcAlist := reverse! SORTBY(function NRTcatCompare,pcAlist) newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] slot1 := [[a,:k] for [a,:b] in applySubst($pairlis,opcAlist) - | (k := predicateBitIndex b) ~= -1] + | (k := predicateBitIndex(b,e)) ~= -1] slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] sixEtc := [5 + i for i in 1..#$pairlis] formals := ASSOCRIGHT $pairlis diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 20ed8c36..33e7c592 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -445,7 +445,7 @@ DescendCode(code,flag,viewAssoc) == reverse! [v for u in reverse codelist | (v:= DescendCode(u,flag,viewAssoc))~=nil]] code is ['%when,:condlist] => - c:= [[u2:= ProcessCond first u,:q] for u in condlist] where q() == + c:= [[u2:= ProcessCond(first u,$e),:q] for u in condlist] where q() == null u2 => nil f:= TruthP u2 => flag; @@ -473,7 +473,7 @@ DescendCode(code,flag,viewAssoc) == code:=['%store,['%tref,['%tref,'$,5],#$locals-#u],code] $epilogue:= TruthP flag => [code,:$epilogue] - [['%when,[ProcessCond flag,code]],:$epilogue] + [['%when,[ProcessCond(flag,$e),code]],:$epilogue] nil code code -- doItIf deletes entries from $locals so can't optimize this @@ -488,7 +488,7 @@ DescendCode(code,flag,viewAssoc) == if not $insideCategoryPackageIfTrue then updateCapsuleDirectory([second(u).args,third u],flag) ConstantCreator u => - if flag ~= true then u:= ['%when,[ProcessCond flag,u]] + if flag ~= true then u:= ['%when,[ProcessCond(flag,$e),u]] $ConstantAssignments:= [u,:$ConstantAssignments] nil u @@ -508,9 +508,9 @@ ConstantCreator u == u is ['CONS,:.] => false true -ProcessCond cond == +ProcessCond(cond,e) == ncond := applySubst($pairlis,cond) - integer? POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond + integer? POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef(ncond,e) cond TryGDC cond == @@ -688,7 +688,7 @@ InvestigateConditions(catvecListMaker,env) == ICformat(u,env) == u isnt [.,:.] => u - u is ["has",:.] => compHasFormat u + u is ["has",:.] => compHasFormat(u,env) u is ['AND,:l] or u is ['and,:l] => l:= removeDuplicates [ICformat(v,env) for [v,:l'] in tails l | not listMember?(v,l')] diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 25b00464..5d952942 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -64,17 +64,18 @@ simplifyAttributeAlist al == [[a,:pred],:simplifyAttributeAlist s] nil -NRTgenFinalAttributeAlist() == - [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ~= -1] - -predicateBitIndex x == - pn(x,false) where - pn(x,flag) == - u := simpBool transHasCode x +NRTgenFinalAttributeAlist e == + [[a,:k] for [a,:b] in $NRTattributeAlist + | (k := predicateBitIndex(b,e)) ~= -1] + +predicateBitIndex(x,e) == + pn(x,false,e) where + pn(x,flag,e) == + u := simpBool transHasCode(x,e) u is 'T => 0 u = nil => -1 p := POSN1(u,$NRTslot1PredicateList) => p + 1 - not flag => pn(predicateBitIndexRemop x,true) + not flag => pn(predicateBitIndexRemop x,true,e) systemError nil predicateBitIndexRemop p== @@ -84,9 +85,9 @@ predicateBitIndexRemop p== p is ["has",'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) p -predicateBitRef x == +predicateBitRef(x,e) == x is 'T => 'T - ['testBitVector,'pv_$,predicateBitIndex x] + ['testBitVector,'pv_$,predicateBitIndex(x,e)] makePrefixForm(u,op) == u := MKPF(u,op) @@ -96,12 +97,12 @@ makePrefixForm(u,op) == --======================================================================= -- Generate Slot 3 Predicate Vector --======================================================================= -makePredicateBitVector pl == --called by buildFunctor +makePredicateBitVector(pl,e) == --called by buildFunctor if $insideCategoryPackageIfTrue then pl := union(pl,$categoryPredicateList) $predGensymAlist := nil --bound by buildFunctor, used by optHas for p in removeAttributePredicates pl repeat - pred := simpBool transHasCode p + pred := simpBool transHasCode(p,e) pred isnt [.,:.] => 'skip --skip over T and nil if isHasDollarPred pred then lasts := insert(pred,lasts) @@ -151,12 +152,12 @@ removeAttributePredicates pl == p fnl p == [fn x for x in p] -transHasCode x == +transHasCode(x,e) == x isnt [.,:.] => x op := x.op op in '(HasCategory HasAttribute) => x - op="has" => compHasFormat x - [transHasCode y for y in x] + op="has" => compHasFormat(x,e) + [transHasCode(y,e) for y in x] mungeAddGensyms(u,gal) == ['%list,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 6171d4eb..3070bd71 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -473,7 +473,7 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) == $GENNO: local:= 0 --bound in compDefineFunctor1, then as parameter here $catvecList: local := nil --list of vectors v1..vn for each view $hasCategoryAlist: local := nil --list of GENSYMs bound to (HasCategory ..) items - $catsig: local := nil --target category (used in ProcessCond) + $catsig: local := nil --target category $SetFunctions: local := nil --copy of p view with preds telling when fnct defined $ConstantAssignments: local := nil --code for creation of constants $epilogue: local := nil --code to set slot 5, things to be done last @@ -514,7 +514,7 @@ buildFunctor($definition is [name,:args],sig,code,$locals,$e) == [$uncondAlist,:$condAlist] := --bound in compDefineFunctor1 NRTsetVector4Part1(viewNames,catvecListMaker,condCats) [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := - makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList] + makePredicateBitVector([:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList],$e) storeOperationCode := DescendCode(code,true,nil) NRTaddDeltaCode() |