diff options
| -rw-r--r-- | src/interp/buildom.boot | 77 | ||||
| -rw-r--r-- | src/interp/nrunfast.boot | 83 |
2 files changed, 77 insertions, 83 deletions
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot index a7765057..c5881ee7 100644 --- a/src/interp/buildom.boot +++ b/src/interp/buildom.boot @@ -101,8 +101,8 @@ substDollarArgs(dollar,domain,object) == object) compareSig(sig,tableSig,dollar,domain) == - not (#sig = #tableSig) => false - null (target := first sig) + #sig ~= #tableSig => false + null(target := first sig) or lazyCompareSigEqual(target,first tableSig,dollar,domain) => and/[lazyCompareSigEqual(s,t,dollar,domain) for s in rest sig for t in rest tableSig] @@ -121,7 +121,7 @@ compareSigEqual(s,t,dollar,domain) == s = t => true atom t => u := - t='$ => dollar + t is '$ => dollar isSharpVar t => vector? domain => instantiationArgs(domain).(POSN1(t,$FormalMapVariableList)) @@ -131,7 +131,7 @@ compareSigEqual(s,t,dollar,domain) == s is '$ => compareSigEqual(dollar,u,dollar,domain) u => compareSigEqual(s,u,dollar,domain) s = u - s='$ => compareSigEqual(dollar,t,dollar,domain) + s is '$ => compareSigEqual(dollar,t,dollar,domain) atom s => nil #s ~= #t => nil match := true @@ -143,7 +143,6 @@ compareSigEqual(s,t,dollar,domain) == -- Lookup From Interpreter --======================================================= ---------------------> NEW DEFINITION (see interop.boot.pamphlet) compiledLookup(op,sig,dollar) == --called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, -- getFunctionFromDomain, optDeltaEntry, retractByFunction @@ -155,7 +154,28 @@ compiledLookup(op,sig,dollar) == if op = "^" then op := "**" basicLookup(op,sig,dollar,dollar) ---------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupInDomainVector(op,sig,domain,dollar) == + SPADCALL(op,sig,dollar,domainRef(domain,1)) + +lookupInDomain(op,sig,addFormDomain,dollar,index) == + addFormCell := vectorRef(addFormDomain,index) => + integer? KAR addFormCell => + or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] + if not vector? addFormCell then + addFormCell := eval addFormCell + lookupInDomainVector(op,sig,addFormCell,dollar) + nil + +++ same as lookupInDomainVector except that the use of defaults +++ (either in category packages or add-chains) is controlled +++ by `useDefaults'. +lookupInDomainAndDefaults(op,sig,domain,dollar,useDefaults) == + savedLookupDefaults := $lookupDefaults + $lookupDefaults := useDefaults + fun := lookupInDomainVector(op,sig,domain,dollar) + $lookupDefaults := savedLookupDefaults + fun + basicLookup(op,sig,domain,dollar) == item := domain.1 cons? item and first item in '(lookupInDomain lookupInTable) => @@ -194,7 +214,7 @@ goGet(:l) == sig := substDomainArgs(thisDomain,sig) lookupDomain := domainSlot = 0 => thisDomain - thisDomain.domainSlot -- where we look for the operation + domainRef(thisDomain,domainSlot) -- where we look for the operation if cons? lookupDomain then lookupDomain := evalDomain lookupDomain dollar := -- what matches $ in signatures explicitLookupDomainIfTrue => lookupDomain @@ -203,14 +223,14 @@ goGet(:l) == fn:= basicLookup(op,sig,lookupDomain,dollar) fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0]) val:= apply(first fn,[:arglist,rest fn]) - vectorRef(thisDomain,index) := fn + domainRef(thisDomain,index) := fn val NRTreplaceLocalTypes(t,dom) == atom t => not integer? t => t - t:= dom.t - if cons? t then t:= evalDomain t + t:= domainRef(dom,t) + if cons? t then t := evalDomain t canonicalForm t first t in '(Mapping Union Record _:) => [first t,:[NRTreplaceLocalTypes(x,dom) for x in rest t]] @@ -224,7 +244,7 @@ substDomainArgs(domain,object) == -- Category Default Lookup (from goGet or lookupInAddChain) --======================================================= lookupInCategories(op,sig,dom,dollar) == - catformList := dom.4.0 + catformList := domainRef(dom,4).0 varList := ["$",:$FormalMapVariableList] nsig := MSUBST(canonicalForm dom,canonicalForm dollar,sig) -- the following lines don't need to check for predicates because @@ -232,9 +252,9 @@ lookupInCategories(op,sig,dom,dollar) == -- builtin constructors -- their predicates are always true. r := or/[lookupInDomainVector(op,nsig, eval applySubst(pairList(varList,valueList),catform),dollar) - for catform in catformList | not null catform] where + for catform in catformList | catform ~= nil ] where valueList() == - [MKQ dom,:[MKQ dom.(5+i) for i in 1..(#rest catform)]] + [MKQ dom,:[MKQ domainRef(dom,5+i) for i in 1..(#rest catform)]] r or lookupDisplay(op,sig,'"category defaults",'"-- not found") --======================================================= @@ -249,7 +269,7 @@ defaultingFunction op == isDefaultPackageName packageName lookupInAddChain(op,sig,addFormDomain,dollar) == - addFunction:=lookupInDomain(op,sig,addFormDomain,dollar,5) + addFunction := lookupInDomain(op,sig,addFormDomain,dollar,5) defaultingFunction addFunction => lookupInCategories(op,sig,addFormDomain,dollar) or addFunction addFunction or lookupInCategories(op,sig,addFormDomain,dollar) @@ -258,35 +278,36 @@ lookupInAddChain(op,sig,addFormDomain,dollar) == -- Lookup Function in Slot 1 (via SPADCALL) --======================================================= lookupInTable(op,sig,dollar,[domain,table]) == - table = "derived" => lookupInAddChain(op,sig,domain,dollar) - success := false + table is "derived" => lookupInAddChain(op,sig,domain,dollar) + success := nil -- lookup result someMatch := false while not success for [sig1,:code] in LASSQ(op,table) repeat success := not compareSig(sig,sig1,canonicalForm dollar,domain) => false - code is ['subsumed,a] => - subsumptionSig := - applySubst(pairList($FormalMapVariableList,canonicalForm(domain).args),a) - someMatch := true - false + code is ['Subsumed,a] => + subsumptionSig := + applySubst(pairList($FormalMapVariableList,canonicalForm(domain).args),a) + someMatch := true + nil predIndex := code quo 8192 predIndex ~= 0 and not lookupPred($predVector.predIndex,dollar,domain) - => false + => nil loc := (code rem 8192) quo 2 loc = 0 => someMatch := true nil - slot := domain.loc + slot := domainRef(domain,loc) slot is ["goGet",:.] => lookupDisplay(op,sig,domain,'" !! goGet found, will ignore") lookupInAddChain(op,sig,domain,dollar) or 'failed - null slot => + slot = nil => lookupDisplay(op,sig,domain,'" !! null slot entry, continuing") lookupInAddChain(op,sig,domain,dollar) or 'failed lookupDisplay(op,sig,domain,'" !! found in NEW table!!") slot - success isnt 'failed and success => success - subsumptionSig and (u:= SPADCALL(op,subsumptionSig,dollar,domain.1)) => u + success isnt 'failed and success ~= nil => success + subsumptionSig ~= nil and + (u := SPADCALL(op,subsumptionSig,dollar,domainRef(domain,1))) => u someMatch => lookupInAddChain(op,sig,domain,dollar) nil @@ -514,7 +535,7 @@ Enumeration(:"args") == dom EnumEqual(e1,e2,dom) == - e1=e2 + scalarEq?(e1,e2) EnumPrint(enum, dom) == instantiationArgs(dom).enum @@ -524,7 +545,7 @@ createEnum(sym, dom) == val := -1 for v in args for i in 0.. repeat sym=v => return(val:=i) - val<0 => userError ['"Cannot coerce",sym,'"to",["Enumeration",:args]] + val < 0 => userError ['"Cannot coerce",sym,'"to",["Enumeration",:args]] val --% INSTANTIATORS diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index 8962ebf9..9b0eaab7 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -166,7 +166,7 @@ replaceGoGetSlot env == --======================================================= lookupComplete(op,sig,dollar,env) == - newLookupInTable(op,sig,dollar,env,nil) + newLookupInTable(op,sig,dollar,env,false) lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) @@ -189,18 +189,19 @@ newLookupInTable(op,sig,dollar,[domain,opvec],flag) == flag => newLookupInAddChain(op,sig,domain,dollar) nil idxmax := maxIndex numvec - start := opvec.k + start := vectorRef(opvec,k) finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + max > k => vectorRef(opvec,k + 2) idxmax - if QSGREATERP(finish,idxmax) then systemError '"limit too large" - numArgs := QSDIFFERENCE(#sig,1) + if finish > idxmax then + systemError '"limit too large" + numArgs := #sig - 1 success := nil $isDefaultingPackage: local := -- use special defaulting handler when dollar non-trivial dollar ~= domain and isDefaultPackageForm? devaluate domain while finish > start repeat - PROGN + do i := start numArgs ~= (numTableArgs := arrayRef(numvec,i)) => nil predIndex := arrayRef(numvec,i := i + 1) @@ -209,17 +210,17 @@ newLookupInTable(op,sig,dollar,[domain,opvec],flag) == null loc => nil --signifies no match loc = 1 => (someMatch := true) loc = 0 => - start := QSPLUS(start,QSPLUS(numTableArgs,4)) + start := start + numTableArgs + 4 i := start + 2 someMatch := true --mark so that if subsumption fails, look for original subsumptionSig := - [newExpandTypeSlot(arrayRef(numvec,QSPLUS(i,j)), + [newExpandTypeSlot(arrayRef(numvec,i + j), dollar,domain) for j in 0..numTableArgs] if $monitorNewWorld then sayBrightly [formatOpSignature(op,sig),'"--?-->", formatOpSignature(op,subsumptionSig)] nil - slot := vectorRef(domain,loc) + slot := domainRef(domain,loc) cons? slot => slot.op is 'newGoGet => someMatch:=true --treat as if operation were not there @@ -231,46 +232,18 @@ newLookupInTable(op,sig,dollar,[domain,opvec],flag) == slot is 'skip => --recursive call from above 'replaceGoGetSlot return (success := newLookupInAddChain(op,sig,domain,dollar)) systemError '"unexpected format" - start := QSPLUS(start,QSPLUS(numTableArgs,4)) + start := start + numTableArgs + 4 success isnt 'failed and success => if $monitorNewWorld then sayLooking1('"<----",uu) where uu() == cons? success => [first success,:devaluate rest success] success success - subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u - flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) + subsumptionSig ~= nil + and (u := basicLookup(op,subsumptionSig,domain,dollar)) => u + flag or someMatch ~= nil => newLookupInAddChain(op,sig,domain,dollar) nil - ---======================================================= --- Lookup In Domain (from lookupInAddChain) ---======================================================= -lookupInDomain(op,sig,addFormDomain,dollar,index) == - addFormCell := vectorRef(addFormDomain,index) => - integer? KAR addFormCell => - or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] - if not vector? addFormCell then - addFormCell := eval addFormCell - lookupInDomainVector(op,sig,addFormCell,dollar) - nil - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupInDomainVector(op,sig,domain,dollar) == - slot1 := vectorRef(domain,1) - SPADCALL(op,sig,dollar,slot1) - - -++ same as lookupInDomainVector except that the use of defaults -++ (either in category packages or add-chains) is controlled -++ by `useDefaults'. -lookupInDomainAndDefaults(op,sig,domain,dollar,useDefaults) == - savedLookupDefaults := $lookupDefaults - $lookupDefaults := useDefaults - fun := lookupInDomainVector(op,sig,domain,dollar) - $lookupDefaults := savedLookupDefaults - fun - --======================================================= -- Lookup Addlist (from lookupInDomainTable or lookupInDomain) --======================================================= @@ -300,7 +273,7 @@ newLookupInDomain(op,sig,addFormDomain,dollar,index) == -- Category Default Lookup (from goGet or lookupInAddChain) --======================================================= newLookupInCategories(op,sig,dom,dollar) == - slot4 := vectorRef(dom,4) + slot4 := domainRef(dom,4) catVec := second slot4 # catVec = 0 => nil --early exit if no categories integer? KDR canonicalForm catVec => @@ -336,8 +309,8 @@ newLookupInCategories(op,sig,dom,dollar) == null code => nil byteVector := CDDDR infovec.3 endPos := - code+2 > max => # byteVector - opvec.(code+2) + code + 2 > max => # byteVector + vectorRef(opvec,code+2) not nrunNumArgCheck(#sig.source,byteVector,opvec.code,endPos) => nil --numOfArgs := byteVector.(opvec.code) --numOfArgs ~= #sig.source => nil @@ -354,7 +327,7 @@ newLookupInCategories(op,sig,dom,dollar) == vectorRef(packageVec,i) := package package nil - not success => + success = nil => if $monitorNewWorld = true then sayBrightlyNT '" not in: " pp (packageForm and devaluate package or entry) @@ -385,12 +358,12 @@ newLookupInCategories1(op,sig,dom,dollar) == if $monitorNewWorld = true then sayBrightly concat('"----->", form2String devaluate dom,'"-----> searching default packages for ",op) predvec := domainPredicates dom - slot4 := vectorRef(dom,4) + slot4 := domainRef(dom,4) packageVec := first slot4 catVec := second slot4 --the next three lines can go away with new category world varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[vectorRef(dom,5+i) for i in 1..(#instantiationArgs dom)]] + valueList := [dom,:[domainRef(dom,5+i) for i in 1..(#instantiationArgs dom)]] valueList := [MKQ val for val in valueList] nsig := MSUBST(canonicalForm dom,canonicalForm dollar,sig) for i in 0..maxIndex packageVec | (entry := vectorRef(packageVec,i)) @@ -541,17 +514,17 @@ lazyMatchArgDollarCheck(s,d,dollarName,domainName) == lookupInDomainByName(op,domain,arg) == atom arg => nil - opvec := domain . 1 . 2 + opvec := domainRef(domain,1) . 2 numvec := getDomainByteVector domain predvec := domainPredicates domain max := maxIndex opvec k := getOpCode(op,opvec,max) or return nil idxmax := maxIndex numvec - start := opvec.k + start := vctorRef(opvec,k) finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + max > k => vectorRef(opvec,k + 2) idxmax - if QSGREATERP(finish,idxmax) then systemError '"limit too large" + if finish > idxmax then systemError '"limit too large" success := false while finish > start repeat i := start @@ -560,9 +533,9 @@ lookupInDomainByName(op,domain,arg) == predIndex ~= 0 and not testBitVector(predvec,predIndex) => nil slotIndex := arrayRef(numvec,i + 2 + numberOfArgs) newStart := QSPLUS(start,QSPLUS(numberOfArgs,4)) - slot := vectorRef(domain,slotIndex) + slot := domainRef(domain,slotIndex) cons? slot and sameObject?(first slot,first arg) and sameObject?(rest slot,rest arg) => return (success := true) - start := QSPLUS(start,QSPLUS(numberOfArgs,4)) + start := start + numberOfArgs + 4 success --======================================================= @@ -621,7 +594,7 @@ sigDomainVal(dollar,domain,index) == --returns a domain or a lazy slot index = 0 => "$" index = 2 => domain - vectorRef(domain,index) + domainRef(domain,index) --======================================================= -- Convert Lazy Domain to Domain Form @@ -636,7 +609,7 @@ lazyDomainSet(lazyForm,thisDomain,slot) == sayLooking1(concat(form2String devaluate thisDomain, '" activating lazy slot ",slot,'": "),slotDomain) name := first form - vectorRef(thisDomain,slot) := slotDomain + domainRef(thisDomain,slot) := slotDomain ++ Return a type form where all niladic constructors are |