aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2011-11-26 08:04:54 +0000
committerdos-reis <gdr@axiomatics.org>2011-11-26 08:04:54 +0000
commitdb6d06dab90131e3551f7c9f33337f115a8782fa (patch)
tree14509ff49bcb89359ed39d0f6a29d7be13d471a3 /src/interp
parent0ecaa80c84fb857d75072eeac224a8f3d80138b8 (diff)
downloadopen-axiom-db6d06dab90131e3551f7c9f33337f115a8782fa.tar.gz
* interp/br-con.boot (conOpPage1): Fix typo.
* interp/c-util.boot (registerConstructor): New. (currentConstructor): Likewise. (makeCompilationData): Initialize dbEntityBuffer. (dbEntityBuffer): New. (dbUsedEntities): Likewise. (dbEntityCount): Likewise. * interp/compiler.boot: Adjust call to getLocalIndex, NRTassocIndex * interp/define.boot: Likewise. ($NRTdeltaLength): Remove. * interp/nruncomp.boot: Likewise.
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/br-con.boot2
-rw-r--r--src/interp/c-util.boot32
-rw-r--r--src/interp/compiler.boot11
-rw-r--r--src/interp/define.boot37
-rw-r--r--src/interp/nruncomp.boot182
5 files changed, 145 insertions, 119 deletions
diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot
index 4439799b..739332b2 100644
--- a/src/interp/br-con.boot
+++ b/src/interp/br-con.boot
@@ -691,7 +691,7 @@ conOpPage1(conform,:options) ==
conform := mkConform(kind,name,args)
capitalKind := capitalize kind
signature := ncParseFromString sig
- sourceFileName := getContructorSourceFileFromDB makeSymbol name
+ sourceFileName := getConstructorSourceFileFromDB makeSymbol name
emString := ['"{\sf ",constring,'"}"]
heading := [capitalKind,'" ",:emString]
if not isExposedConstructor conname then heading := ['"Unexposed ",:heading]
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 7b3c0bdc..3bc4a2e4 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -46,6 +46,8 @@ module c_-util where
getSuccessEnvironment: (%Form,%Env) -> %Env
getInverseEnvironment: (%Form,%Env) -> %Env
giveVariableSomeValue: (%Symbol,%Mode,%Env) -> %Env
+ registerConstructor: (%Symbol,%Env) -> %Env
+ currentConstructor: %Env -> %Maybe %Symbol
-- functor data manipulation
dbInfovec: %Constructor -> %Maybe %FunctorData
@@ -136,12 +138,13 @@ macro domainData d ==
--% Operational Semantics:
--% structure CompilationData ==
--% Record(formalSubst: Substitution,implicits: List Identifier,
---% byteList: List SingleInteger)
+--% byteList: List SingleInteger,
+--% usedEntities: VectorBuffer Pair(SourceEntity,Elaboration))
--%
++ Make a fresh compilation data structure.
makeCompilationData() ==
- [nil,nil,nil]
+ [nil,nil,nil,[nil,:0]]
++ Subsitution that replaces parameters with formals.
macro dbFormalSubst db ==
@@ -162,6 +165,20 @@ macro dbImplicitData db ==
macro dbByteList db ==
third dbCompilerData db
+++ Return a buffer of entities referenced during elaboration
+++ of current functor.
+macro dbEntityBuffer db ==
+ fourth dbCompilerData db
+
+++ List (in reverse order) of used entities during elaboration of
+++ current functor.
+macro dbUsedEntities db ==
+ first dbEntityBuffer db
+
+++ Number of used entities during elaboration of current functor.
+macro dbEntityCount db ==
+ rest dbEntityBuffer db
+
++ Return the existential substitution of `db'.
dbQuerySubst db ==
x := dbImplicitData db => first x
@@ -782,7 +799,14 @@ isLiteral: (%Symbol,%Env) -> %Boolean
isLiteral(x,e) ==
get(x,"isLiteral",e) => true
false
-
+
+++ Remember the name of the constructor definition being processed.
+registerConstructor(x,e) ==
+ put('%compilerData,'%ctor,x,e)
+
+++ Retrieve the name of the constructor definition being processed.
+currentConstructor e ==
+ get('%compilerData,'%ctor,e)
makeLiteral: (%Symbol,%Env) -> %Thing
makeLiteral(x,e) ==
@@ -810,7 +834,7 @@ isSubset(x,y,e) ==
-- Expand domain representation form
x is 'Rep and not $useRepresentationHack =>
isSubset(getRepresentation e,y,e)
- y is '$ and get(y,'%form,e) = x => true
+ y is '$ and get(y,'%dc,e) = x => true
-- Or, if x has the Subsets property set by SubsetCategory.
pred := LASSOC(opOf x,get(opOf y,"Subsets",e)) => pred
-- Or, they are related by subdomain chain.
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 6fcf6ace..b3743845 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -439,7 +439,7 @@ compSymbol(s,m,e) ==
sameObject?(s,m) or isLiteral(s,e) => [quote s,s,e]
v := get(s,"value",e) =>
symbolMember?(s,$functorLocalParameters) =>
- getLocalIndex s
+ getLocalIndex(constructorDB currentConstructor e,s)
[s,v.mode,e] --s will be replaced by an ELT form in beforeCompile
[s,v.mode,e] --s has been SETQd
@@ -952,7 +952,8 @@ setqSingle(id,val,m,E) ==
--all we do now is to allocate a slot number for lhs
--e.g. the %LET form below will be changed by putInLocalDomainReferences
form :=
- k := NRTassocIndex(id) => ['%store,['%tref,'$,k],x]
+ db := constructorDB currentConstructor e'
+ k := NRTassocIndex(db,id) => ['%store,['%tref,'$,k],x]
["%LET",id,x]
[form,m',e']
@@ -2407,9 +2408,9 @@ numberize x ==
[numberize first x,:numberize rest x]
++ If there is a local reference to mode `m', return it.
-localReferenceIfThere m ==
+localReferenceIfThere(m,e) ==
m is "$" => m
- idx := NRTassocIndex m => ['%tref,'$,idx]
+ idx := NRTassocIndex(constructorDB currentConstructor e,m) => ['%tref,'$,idx]
quote m
massageLoop x == main x where
@@ -2479,7 +2480,7 @@ compRepeatOrCollect(form,m,e) ==
itl':= substitute(["UNTIL",untilCode],'$until,itl')
form':=
$loopKind = "%CollectV" =>
- ["%CollectV",localReferenceIfThere m',:itl',body']
+ ["%CollectV",localReferenceIfThere(m',e'),:itl',body']
-- We are phasing out use of LISP macros COLLECT and REPEAT.
$loopKind = "COLLECT" => ['%collect,:itl',body']
[$loopKind,:itl',body']
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 89b12476..881c996c 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -482,14 +482,14 @@ NRTmakeCategoryAlist(db,e) ==
maxElement := "MAX"/dbByteList db
['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList],
['CONS, MKQ vector slot0,
- ['CONS, MKQ vector [encodeCatform x for x in catformvec],
+ ['CONS, MKQ vector [encodeCatform(db,x) for x in catformvec],
['makeByteWordVec2,maxElement,MKQ dbByteList db]]]]
--NOTE: this is new form: old form satisfies vector? CDDR form
-encodeCatform x ==
- k := NRTassocIndex x => k
+encodeCatform(db,x) ==
+ k := NRTassocIndex(db,x) => k
x isnt [.,:.] or rest x isnt [.,:.] => x
- [first x,:[encodeCatform y for y in rest x]]
+ [first x,:[encodeCatform(db,y) for y in rest x]]
NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist)
@@ -860,7 +860,7 @@ getTargetFromRhs(lhs,rhs,e) ==
rhs is ['Union,:l] => ['UnionCategory,:l]
mode(rhs,e) where
mode(x,e) ==
- $killOptimizeIfTrue: local := true -- not yet in codegen phase.
+ $onlyAbstractSlot: local := true -- not yet in codegen phase.
compOrCroak(x,$EmptyMode,e).mode
giveFormalParametersValues(argl,e) ==
@@ -1395,6 +1395,7 @@ compDefineFunctor1(df is ['DEF,form,signature,body],
dbTemplate(db) := nil
dbLookupFunction(db) := nil
dbCapsuleDefinitions(db) := nil
+ $e := registerConstructor($op,$e)
deduceImplicitParameters(db,$e)
$formalArgList:= [:argl,:$formalArgList]
-- all defaulting packages should have caching turned off
@@ -1420,15 +1421,14 @@ compDefineFunctor1(df is ['DEF,form,signature,body],
$NRTaddForm: local := nil -- see compAdd
$NRTdeltaList: local := nil --list of misc. elts used in compiled fncts
$NRTdeltaListComp: local := nil --list of compiled forms for $NRTdeltaList
- $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector
-- Generate slots for arguments first, then implicit parameters,
-- then for $NRTaddForm (if any) in compAdd
- for x in argl repeat getLocalIndex x
- for x in dbImplicitParameters db repeat getLocalIndex x
+ for x in argl repeat getLocalIndex(db,x)
+ for x in dbImplicitParameters db repeat getLocalIndex(db,x)
[.,.,$e] := compMakeDeclaration("$",target,$e)
if not $insideCategoryPackageIfTrue then
$e := augModemapsFromCategory('_$,'_$,target,$e)
- $e := put('$,'%form,form,$e)
+ $e := put('$,'%dc,form,$e)
$signature := signature'
parSignature := dbSubstituteAllQuantified(db,signature')
parForm := dbSubstituteAllQuantified(db,form)
@@ -1705,12 +1705,12 @@ assignCapsuleFunctionSlot(db,op,sig) ==
--if opSig is not exported, it is local and need not be assigned
if $insideCategoryPackageIfTrue then
sig := substitute('$,second dbConstructorForm db,sig)
- sig := [getLocalIndex x for x in sig]
+ sig := [getLocalIndex(db,x) for x in sig]
opModemapPair := [op,['_$,:sig],["T",implementation]]
valuePosition(opModemapPair,$NRTdeltaList) => nil --already there
$NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
$NRTdeltaListComp := [nil,:$NRTdeltaListComp]
- $NRTdeltaLength := $NRTdeltaLength+1
+ dbEntityCount(db) := dbEntityCount db + 1
localOperation?(op,e) ==
not symbolMember?(op,$formalArgList) and getXmode(op,e) is ['Mapping,:.]
@@ -1960,15 +1960,16 @@ stripOffSubdomainConditions(margl,argl) ==
marg
x
-putInLocalDomainReferences (def := [opName,[lam,varl,body]]) ==
- NRTputInTail CDDADR def
+putInLocalDomainReferences(db,def := [opName,[lam,varl,body]]) ==
+ NRTputInTail(db,CDDADR def)
def
compile(db,u,signature) ==
optimizedBody := optimizeFunctionDef u
stuffToCompile :=
- $insideCapsuleFunctionIfTrue => putInLocalDomainReferences optimizedBody
+ $insideCapsuleFunctionIfTrue =>
+ putInLocalDomainReferences(db,optimizedBody)
optimizedBody
$doNotCompileJustPrint => (PRETTYPRINT stuffToCompile; first u)
$macroIfTrue => constructMacro stuffToCompile
@@ -2089,9 +2090,10 @@ compAdd(['add,$addForm,capsule],m,e) ==
['%otherwise, ['systemError,['%list,'"%b",MKQ $functorForm.op,'"%d",'"from", _
'"%b",MKQ namestring _/EDITFILE,'"%d",'"needs to be compiled"]]]],m,e]
$addFormLhs: local:= $addForm
+ db := constructorDB currentConstructor e
if $addForm is ["SubDomain",domainForm,predicate] then
$NRTaddForm := domainForm
- getLocalIndex domainForm
+ getLocalIndex(db,domainForm)
registerInlinableDomain(domainForm,e)
--need to generate slot for add form since all $ go-get
-- slots will need to access it
@@ -2100,7 +2102,7 @@ compAdd(['add,$addForm,capsule],m,e) ==
$NRTaddForm := $addForm
[$addForm,.,e]:=
$addForm is ["%Comma",:.] =>
- $NRTaddForm := ["%Comma",:[getLocalIndex x for x in $addForm.args]]
+ $NRTaddForm := ["%Comma",:[getLocalIndex(db,x) for x in $addForm.args]]
for x in $addForm.args repeat registerInlinableDomain(x,e)
compOrCroak(compTuple2Record $addForm,$EmptyMode,e)
registerInlinableDomain($addForm,e)
@@ -2209,9 +2211,10 @@ doIt(item,$predl) ==
if $optimizeRep then
registerInlinableDomain($Representation,$e)
code is ["%LET",:.] =>
+ db := constructorDB currentConstructor $e
item.op := '%store
rhsCode := rhs'
- item.args := [['%tref,'$,getLocalIndex lhs],rhsCode]
+ item.args := [['%tref,'$,getLocalIndex(db,lhs)],rhsCode]
item.op := code.op
item.rest := rest code
item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index b1724d82..af46ff4c 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -54,7 +54,6 @@ $profileCompiler := false
++
$NRTdeltaList := []
-$NRTdeltaLength := 0
++
$NRTaddForm := nil
@@ -81,16 +80,16 @@ NRTaddDeltaCode db ==
-- (6) constants, like 0 and 1, represented by (CONS .. ) form
for i in $NRTbase.. for item in reverse $NRTdeltaList
for compItem in reverse $NRTdeltaListComp repeat
- domainRef(dbTemplate db,i) := deltaTran(item,compItem)
+ domainRef(dbTemplate db,i) := deltaTran(db,item,compItem)
domainRef(dbTemplate db,5) :=
$NRTaddForm =>
$NRTaddForm is ["%Comma",:y] => reverse! y
- NRTencode($NRTaddForm,$addForm)
+ NRTencode(db,$NRTaddForm,$addForm)
nil
-deltaTran(item,compItem) ==
+deltaTran(db,item,compItem) ==
--NOTE: all items but signatures are wrapped with %domain forms
- item is ["%domain",lhs,:.] => NRTencode(lhs,compItem)
+ item is ["%domain",lhs,:.] => NRTencode(db,lhs,compItem)
[op,:modemap] := item
[dcSig,[.,[kind,:.]]] := modemap
[dc,:sig] := dcSig
@@ -98,30 +97,30 @@ deltaTran(item,compItem) ==
-- so we need only encode dc. -- gdr 2008-11-28.
dcCode :=
dc is '$ => 0
- NRTassocIndex dc or keyedSystemError("S2NR0004",[dc])
+ NRTassocIndex(db,dc) or keyedSystemError("S2NR0004",[dc])
kindFlag:= (kind is 'CONST => 'CONST; nil)
[sig,dcCode,op,:kindFlag]
-NRTreplaceAllLocalReferences(form) ==
+NRTreplaceAllLocalReferences(db,form) ==
$devaluateList :local := []
- NRTputInLocalReferences form
+ NRTputInLocalReferences(db,form)
-NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) ==
+NRTencode(db,x,y) == encode(db,x,y,true) where encode(db,x,compForm,firstTime) ==
--converts a domain form to a lazy domain form; everything other than
--the operation name should be assigned a slot
- not firstTime and (k:= NRTassocIndex x) => k
+ not firstTime and (k := NRTassocIndex(db,x)) => k
vector? x => systemErrorHere '"NRTencode"
cons? x =>
op := x.op
- op is ":" => [op,second x,encode(third x,third compForm,false)]
+ op is ":" => [op,second x,encode(db,third x,third compForm,false)]
(x' := isQuasiquote x) =>
- quasiquote encode(x',isQuasiquote compForm,false)
+ quasiquote encode(db,x',isQuasiquote compForm,false)
op is "Enumeration" => x
ident? op and (constructor? op or builtinConstructor? op) =>
- [op,:[encode(y,z,false) for y in x.args for z in compForm.args]]
+ [op,:[encode(db,y,z,false) for y in x.args for z in compForm.args]]
-- enumeration constants are like field names, they do not need
-- to be encoded.
- ['%eval,NRTreplaceAllLocalReferences copyTree simplifyVMForm compForm]
+ ['%eval,NRTreplaceAllLocalReferences(db,copyTree simplifyVMForm compForm)]
symbolMember?(x,$formalArgList) =>
v := $FormalMapVariableList.(symbolPosition(x,$formalArgList))
firstTime => ["local",v]
@@ -129,7 +128,7 @@ NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) ==
x is "$" => x
x is "$$" => x
compForm is [.,:.] =>
- ['%eval,NRTreplaceAllLocalReferences copyTree simplifyVMForm compForm]
+ ['%eval,NRTreplaceAllLocalReferences(db,copyTree simplifyVMForm compForm)]
quote compForm
--------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION-------------
@@ -188,39 +187,43 @@ optDeltaEntry(op,sig,dc,eltOrConst) ==
fun
getFunctionReplacement fun
+++ True if we are interested only in abstract slot, not the actual
+++ slot number in the template vector.
+$onlyAbstractSlot := false
+
genDeltaEntry(opMmPair,e) ==
--called from compApplyModemap
---$NRTdeltaLength=0.. always equals length of $NRTdeltaList
[op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair
if $profileCompiler then profileRecord(dc,op,sig)
eltOrConst is 'XLAM => cform
if eltOrConst is 'Subsumed then eltOrConst := 'ELT
+ $onlyAbstractSlot => [eltOrConst,'$,[op,[dc,:sig]]]
+ db := constructorDB currentConstructor e
if dc isnt [.,:.] then
dc = "$" => nsig := sig
if integer? nsig then nsig := MSUBST("$",dc,substitute("$$","$",sig))
setDifference(listOfBoundVars dc,$functorLocalParameters) ~= [] =>
['applyFun,['compiledLookupCheck,MKQ op,
- mkList consSig(nsig,dc),consDomainForm(dc,nil)]]
+ mkList consSig(db,nsig,dc),consDomainForm(db,dc,nil)]]
odc := dc
if cons? dc then
dc := substitute("$$","$",dc)
opModemapPair :=
- [op,[dc,:[getLocalIndex x for x in nsig]],["T",cform]] -- force pred to T
- if null NRTassocIndex dc and
+ [op,[dc,:[getLocalIndex(db,x) for x in nsig]],["T",cform]] -- force pred to T
+ if null NRTassocIndex(db,dc) and
(member(dc,$functorLocalParameters) or cons? dc) then
--create "%domain" entry to $NRTdeltaList
- $NRTdeltaList:= [["%domain",NRTaddInner dc],:$NRTdeltaList]
+ $NRTdeltaList:= [["%domain",NRTaddInner(db,dc)],:$NRTdeltaList]
saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
- $NRTdeltaLength := $NRTdeltaLength+1
+ dbEntityCount(db) := dbEntityCount db + 1
compEntry:= (compOrCroak(odc,$EmptyMode,e)).expr
saveNRTdeltaListComp.first := compEntry
u :=
- [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() ==
+ [eltOrConst,'$,$NRTbase + dbEntityCount db - index] where index() ==
(n := valuePosition(opModemapPair,$NRTdeltaList)) => n + 1
- --n + 1 since $NRTdeltaLength is 1 too large
$NRTdeltaList:= [opModemapPair,:$NRTdeltaList]
$NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
- $NRTdeltaLength := $NRTdeltaLength+1
+ dbEntityCount(db) := dbEntityCount db + 1
0
impl := optDeltaEntry(op,nsig,odc,eltOrConst) => impl
u
@@ -229,36 +232,36 @@ genDeltaEntry(opMmPair,e) ==
++ being compiled) of the domain or value referenced by the form `x'.
++ Otherwise, return nil this is the first time `x' is referenced, or
++ if `x' designates neither a domain nor a value (e.g. a modemap).
-NRTassocIndex: %Form -> %Maybe %Short
-NRTassocIndex x ==
+NRTassocIndex: (%Thing,%Form) -> %Maybe %Short
+NRTassocIndex(db,x) ==
null x => x
x = $NRTaddForm => 5
k := or/[i for i in 1.. for y in $NRTdeltaList
| first y = "%domain" and second y = x] =>
- $NRTbase + $NRTdeltaLength - k
+ $NRTbase + dbEntityCount db - k
nil
-getLocalIndex: %Form -> %Short
-getLocalIndex item ==
- k := NRTassocIndex item => k
+getLocalIndex: (%Thing,%Form) -> %Short
+getLocalIndex(db,item) ==
+ k := NRTassocIndex(db,item) => k
item = "$" => 0
item = "$$" => 2
item isnt [.,:.] and not symbolMember?(item,$formalArgList) => --give slots to atoms
- $NRTdeltaList:= [["%domain",NRTaddInner item],:$NRTdeltaList]
+ $NRTdeltaList:= [["%domain",NRTaddInner(db,item)],:$NRTdeltaList]
$NRTdeltaListComp:=[item,:$NRTdeltaListComp]
- index := $NRTbase + $NRTdeltaLength -- slot number to return
- $NRTdeltaLength := $NRTdeltaLength+1
+ index := $NRTbase + dbEntityCount db -- slot number to return
+ dbEntityCount(db) := dbEntityCount db + 1
index
-- when assigning slot to flag values, we don't really want to
-- compile them. Rather, we want to record them as if they were atoms.
flag := isQuasiquote item
- $NRTdeltaList:= [["%domain", NRTaddInner item], :$NRTdeltaList]
+ $NRTdeltaList:= [["%domain", NRTaddInner(db,item)], :$NRTdeltaList]
-- remember the item's place in the `delta list' and its slot number
-- before the recursive call to the compiler, as that might generate
-- more references that would extend the `delta list'.
saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp]
- saveIndex := $NRTbase + $NRTdeltaLength
- $NRTdeltaLength := $NRTdeltaLength+1
+ saveIndex := $NRTbase + dbEntityCount db
+ dbEntityCount(db) := dbEntityCount db + 1
compEntry:=
-- we don't need to compile the flag again.
-- ??? In fact we should not be compiling again at this phase.
@@ -270,27 +273,27 @@ getLocalIndex item ==
++ NRTaddInner should call following function instead of getLocalIndex
++ This would prevent putting spurious items in $NRTdeltaList
-NRTinnerGetLocalIndex x ==
+NRTinnerGetLocalIndex(db,x) ==
x isnt [.,:.] => x
op := x.op
ident? op and (constructor? op or builtinConstructor? op) =>
- getLocalIndex x
- op is "[||]" => getLocalIndex x
- NRTaddInner x
+ getLocalIndex(db,x)
+ op is "[||]" => getLocalIndex(db,x)
+ NRTaddInner(db,x)
-NRTaddInner x ==
+NRTaddInner(db,x) ==
--called by genDeltaEntry and others that affect $NRTdeltaList
do
x isnt [.,:.] => nil
- x is [":",y,z] => [x.op,y,NRTinnerGetLocalIndex z]
- x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y
+ x is [":",y,z] => [x.op,y,NRTinnerGetLocalIndex(db,z)]
+ x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex(db,y)
builtinConstructor? x.op or x.op is "[||]" =>
for y in x.args repeat
- NRTinnerGetLocalIndex y
+ NRTinnerGetLocalIndex(db,y)
cosig := getDualSignature x.op =>
for y in x.args for t in cosig.source | y isnt '$ and t repeat
- NRTinnerGetLocalIndex y
+ NRTinnerGetLocalIndex(db,y)
keyedSystemError("S2NR0003",[x])
x
@@ -298,42 +301,37 @@ NRTaddInner x ==
NRTisExported? opSig ==
or/[u for u in categoryExports $domainShell | u.0 = opSig]
-consOpSig(op,sig,dc) ==
- if cons? op then
- keyedSystemError("S2GE0016",['"consOpSig",'"bad operator in table"])
- mkList [MKQ op,mkList consSig(sig,dc)]
-
-consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig]
+consSig(db,sig,dc) == [consDomainName(db,sigpart,dc) for sigpart in sig]
-consDomainName(x,dc) ==
+consDomainName(db,x,dc) ==
x = dc => ''$
x is '$ => ''$
x is "$$" => ['devaluate,'$]
x is [op,:argl] =>
(op is 'Record) or (op is 'Union and argl is [[":",:.],:.]) =>
mkList [MKQ op,
- :[['%list,MKQ '_:,MKQ tag,consDomainName(dom,dc)]
+ :[['%list,MKQ '_:,MKQ tag,consDomainName(db,dom,dc)]
for [.,tag,dom] in argl]]
isFunctor op or op is 'Mapping or constructor? op =>
-- call to constructor? needed if op was compiled in $bootStrapMode
- mkList [MKQ op,:[consDomainName(y,dc) for y in argl]]
+ mkList [MKQ op,:[consDomainName(db,y,dc) for y in argl]]
substitute('$,"$$",x)
x = [] => x
y := LASSOC(x,$devaluateList) => y
- k := NRTassocIndex x => ['devaluate,['%vref,'$,k]]
+ k := NRTassocIndex(db,x) => ['devaluate,['%vref,'$,k]]
get(x,'value,$e) =>
isDomainForm(x,$e) => ['devaluate,x]
x
MKQ x
-consDomainForm(x,dc) ==
+consDomainForm(db,x,dc) ==
x is '$ => '$
x is [op,:argl] =>
- op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)]
- [op,:[consDomainForm(y,dc) for y in argl]]
+ op = ":" and argl is [tag, value] => [op,tag,consDomainForm(db,value,dc)]
+ [op,:[consDomainForm(db,y,dc) for y in argl]]
x = [] => x
(y := LASSOC(x,$devaluateList)) => y
- k := NRTassocIndex x => ['%vref,'$,k]
+ k := NRTassocIndex(db,x) => ['%vref,'$,k]
get(x,'value,$e) or get(x,'mode,$e) => x
MKQ x
@@ -477,7 +475,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
-- a list, one %for each element of catvecListMaker
-- indicating under what conditions this
-- category should be present. true => always
- dbTemplate(db) := newShell($NRTbase + $NRTdeltaLength)
+ dbTemplate(db) := newShell($NRTbase + dbEntityCount db)
$SetFunctions := newShell # dbTemplate db
-- list of names n1..nn for each view
viewNames := ['$,:[genvar() for u in rest catvecListMaker]]
@@ -492,7 +490,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
storeOperationCode := DescendCode(db,code,true,nil,$e)
NRTaddDeltaCode db
- storeOperationCode := NRTputInLocalReferences storeOperationCode
+ storeOperationCode := NRTputInLocalReferences(db,storeOperationCode)
NRTdescendCodeTran(db,storeOperationCode,nil) --side effects storeOperationCode
codePart2:=
argStuffCode :=
@@ -510,7 +508,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
devaluateCode:= [[b,["devaluate",a]] for [a,:b] in $devaluateList]
createDomainCode:=
[domname,['%list,MKQ name,:ASSOCRIGHT $devaluateList]]
- createViewCode:= ["$",["newShell", $NRTbase + $NRTdeltaLength]]
+ createViewCode:= ["$",["newShell", $NRTbase + dbEntityCount db]]
createPredVecCode := ["pv$",predBitVectorCode1]
--CODE: part 1
@@ -523,7 +521,7 @@ buildFunctor(db,sig,code,$locals,$e) ==
--CODE: part 3
$ConstantAssignments :=
- [NRTputInLocalReferences code for code in $ConstantAssignments]
+ [NRTputInLocalReferences(db,code) for code in $ConstantAssignments]
codePart3 := [:$ConstantAssignments,:$epilogue]
ans := ["%bind",bindings,
:washFunctorBody optFunctorBody
@@ -616,7 +614,7 @@ NRTaddToSlam([name,:argnames],shell) ==
changeDirectoryInSlot1 db == --called by buildFunctor
--3 cases:
- -- if called inside buildFunctor, $NRTdeltaLength gives different locs
+ -- if called inside buildFunctor, dbEntityCount gives different locs
-- otherwise called from compFunctorBody (all lookups are forwarded):
-- $NRTdeltaList = nil ===> all slot numbers become nil
$lisplibOperationAlist := [sigloc(db,entry) for entry in categoryExports $domainShell] where
@@ -627,25 +625,25 @@ changeDirectoryInSlot1 db == --called by buildFunctor
fnsel is [op,a,:.] and op in '(ELT CONST) =>
if $insideCategoryPackageIfTrue then
opsig := substitute('$,first dbParameters db,opsig)
- [opsig,pred,[op,a,vectorLocation(first opsig,second opsig)]]
+ [opsig,pred,[op,a,vectorLocation(db,first opsig,second opsig)]]
[opsig,pred,fnsel]
sortedOplist := listSort(function GLESSEQP,
copyList $lisplibOperationAlist,function second)
$lastPred: local := false
$newEnv: local := $e
- categoryExports($domainShell) := [fn entry for entry in sortedOplist] where
- fn [[op,sig],pred,fnsel] ==
+ categoryExports($domainShell) := [fn(db,entry) for entry in sortedOplist] where
+ fn(db,[[op,sig],pred,fnsel]) ==
if $lastPred ~= pred then
$newEnv := deepChaseInferences(pred,$e)
$lastPred := pred
newfnsel :=
fnsel is ['Subsumed,op1,sig1] =>
- ['Subsumed,op1,genSlotSig(sig1,$newEnv)]
+ ['Subsumed,op1,genSlotSig(db,sig1,$newEnv)]
fnsel
- [[op, genSlotSig(sig,$newEnv)] ,pred,newfnsel]
+ [[op, genSlotSig(db,sig,$newEnv)] ,pred,newfnsel]
-genSlotSig(sig,$e) ==
- [getLocalIndex t for t in sig]
+genSlotSig(db,sig,$e) ==
+ [getLocalIndex(db,t) for t in sig]
deepChaseInferences(pred,$e) ==
pred is [op,:preds] and op in '(AND and %and) =>
@@ -656,64 +654,64 @@ deepChaseInferences(pred,$e) ==
pred is 'T or pred is [op,:.] and op in '(NOT not %not) => $e
chaseInferences(pred,$e)
-vectorLocation(op,sig) ==
+vectorLocation(db,op,sig) ==
u := or/[i for i in 1.. for u in $NRTdeltaList
- | u is [=op,['$,: xsig],:.] and sig=NRTsubstDelta(xsig) ]
- u => $NRTdeltaLength - u + $NRTbase
+ | u is [=op,['$,: xsig],:.] and sig = NRTsubstDelta(db,xsig) ]
+ u => dbEntityCount db - u + $NRTbase
nil -- this signals that calls should be forwarded
-NRTsubstDelta sig ==
- [replaceSlotTypes t for t in sig] where
- replaceSlotTypes t ==
+NRTsubstDelta(db,sig) ==
+ [replaceSlotTypes(db,t) for t in sig] where
+ replaceSlotTypes(db,t) ==
t isnt [.,:.] =>
not integer? t => t
t = 0 => "$"
t = 2 => "$$"
t = 5 => $NRTaddForm
- u := $NRTdeltaList.($NRTdeltaLength+5-t)
+ u := $NRTdeltaList.(dbEntityCount db + 5 - t)
first u = "%domain" => second u
error "bad $NRTdeltaList entry"
- t is [":",x,t'] => [t.op,x,replaceSlotTypes t']
+ t is [":",x,t'] => [t.op,x,replaceSlotTypes(db,t')]
first t in '(Enumeration EnumerationCategory) => t
ident? first t and builtinConstructor? first t =>
- [t.op,:[replaceSlotTypes(x) for x in t.args]]
+ [t.op,:[replaceSlotTypes(db,x) for x in t.args]]
t
-----------------------------SLOT1 DATABASE------------------------------------
-NRTputInLocalReferences bod ==
- NRTputInHead bod
+NRTputInLocalReferences(db,bod) ==
+ NRTputInHead(db,bod)
-NRTputInHead bod ==
+NRTputInHead(db,bod) ==
bod isnt [.,:.] => bod
bod is ['SPADCALL,:args,fn] =>
- NRTputInTail rest bod --NOTE: args = COPY of rest bod
+ NRTputInTail(db,rest bod) --NOTE: args = COPY of rest bod
-- The following test allows function-returning expressions
fn is [elt,dom,ind] and dom ~='$ and elt in '(ELT CONST) =>
- k := NRTassocIndex dom => lastNode(bod).first := ['%vref,'_$,k]
+ k := NRTassocIndex(db,dom) => lastNode(bod).first := ['%vref,'_$,k]
nil
- NRTputInHead fn
+ NRTputInHead(db,fn)
bod
bod is ['%when,:clauses] =>
- for cc in clauses repeat NRTputInTail cc
+ for cc in clauses repeat NRTputInTail(db,cc)
bod
bod is ['QUOTE,:.] => bod
bod is ["CLOSEDFN",:.] => bod
- NRTputInHead first bod
- NRTputInTail rest bod
+ NRTputInHead(db,first bod)
+ NRTputInTail(db,rest bod)
bod
-NRTputInTail x ==
+NRTputInTail(db,x) ==
for y in tails x repeat
(u := first y) isnt [.,:.] =>
u='$ or LASSOC(u,$devaluateList) => nil
- k:= NRTassocIndex u =>
+ k:= NRTassocIndex(db,u) =>
u isnt [.,:.] => y.first := ['%vref,'_$,k]
-- u atomic means that the slot will always contain a vector
y.first := ['SPADCHECKELT,'_$,k]
--this reference must check that slot is a vector
nil
- NRTputInHead u
+ NRTputInHead(db,u)
x