aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2011-05-17 18:37:35 +0000
committerdos-reis <gdr@axiomatics.org>2011-05-17 18:37:35 +0000
commit16106617d450060382974643a59ecd481efe5bca (patch)
tree4d3e01cb6b74866726f50b696e5d14cc00bd402a /src/interp
parente6d8d5bae2f449dac29859066530aafe8aa47006 (diff)
downloadopen-axiom-16106617d450060382974643a59ecd481efe5bca.tar.gz
more cleanup
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/buildom.boot77
-rw-r--r--src/interp/nrunfast.boot83
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