diff options
| -rw-r--r-- | src/ChangeLog | 14 | ||||
| -rw-r--r-- | src/interp/br-con.boot | 2 | ||||
| -rw-r--r-- | src/interp/c-util.boot | 32 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 11 | ||||
| -rw-r--r-- | src/interp/define.boot | 37 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 182 |
6 files changed, 159 insertions, 119 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index cc4e2ab4..8af446a1 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,19 @@ 2011-11-25 Gabriel Dos Reis <gdr@cs.tamu.edu> + * 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. + +2011-11-25 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/define.boot (processDefinitionParameters): New. Abstract from compDefineCapsuleFunction. (compDefineCapsuleFunction): Use it. Tidy. 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 |