diff options
Diffstat (limited to 'src/interp/xruncomp.boot')
| -rw-r--r-- | src/interp/xruncomp.boot | 330 |
1 files changed, 330 insertions, 0 deletions
diff --git a/src/interp/xruncomp.boot b/src/interp/xruncomp.boot new file mode 100644 index 00000000..4b558a3e --- /dev/null +++ b/src/interp/xruncomp.boot @@ -0,0 +1,330 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +------- from info.boot ----------- + +-- modemap is of the form : ((op (targ arg1 arg2 ... argn)) pred (elt $ n)) + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +evalAndSub(domainName,viewName,functorForm,form,$e) == + $lhsOfColon: local:= domainName + isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] + --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 + if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) + opAlist:= getOperationAlist(domainName,functorForm,form) + substAlist:= substNames(domainName,viewName,functorForm,opAlist) + [substAlist,$e] + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +substNames(domainName,viewName,functorForm,opalist) == + functorForm := SUBSTQ("$$","$", functorForm) + nameForDollar := + isCategoryPackageName functorForm => CADR functorForm + domainName + + -- following calls to SUBSTQ must copy to save RPLAC's in + -- putInLocalDomainReferences + [[:SUBSTQ("$","$$",SUBSTQ(nameForDollar,"$",modemapform)), + [sel, viewName,if domainName = "$" then pos else + CADAR modemapform]] + for [:modemapform,[sel,"$",pos]] in + EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, opalist)] + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +addModemap1(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + if mc='Rep then +-- if fn is [kind,'Rep,.] and + -- save old sig for NRUNTIME +-- (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] + sig:= substitute("$",'Rep,sig) + currentProplist:= getProplist(op,e) or nil + newModemapList:= + mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) + newProplist:= augProplist(currentProplist,'modemap,newModemapList) + newProplist':= augProplist(newProplist,"FLUID",true) + unErrorRef op + --There may have been a warning about op having no value + addBinding(op,newProplist',e) + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +addConstructorModemaps(name,form is [functorName,:.],e) == + $InteractiveMode: local:= nil + e:= putDomainsInScope(name,e) --frame + fn := GETL(functorName,"makeFunctionList") + [funList,e]:= FUNCALL(fn,name,form,e) + for [op,sig,opcode] in funList repeat + if opcode is [sel,dc,n] and sel='ELT then + nsig := substitute("$$$",name,sig) + nsig := substitute('$,"$$$",substitute("$$",'$,nsig)) + opcode := [sel,dc,nsig] + e:= addModemap(op,name,sig,true,opcode,e) + e + +------- from info.boot ----------- + +--------------------> NEW DEFINITION (see info.boot.pamphlet) +actOnInfo(u,$e) == + null u => $e + u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) + $e:= + put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e + ) + u is ["COND",:l] => + --there is nowhere %else that this sort of thing exists + for [ante,:conseq] in l repeat + if member(hasToInfo ante,Info) then for v in conseq repeat + $e:= actOnInfo(v,$e) + $e + u is ["ATTRIBUTE",name,att] => + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["ATTRIBUTE",att]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + --there is nowhere %else that this sort of thing exists + u is ["SIGNATURE",name,operator,modemap] => + implem:= + (implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) => + CADADR implem + name = "$" => ['ELT,name,-1] + ['ELT,name,substitute('$,name,modemap)] + $e:= addModemap(operator,name,modemap,true,implem,$e) + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + u is ["has",name,cat] => + [vval,vmode,venv]:= GetValue name + cat=vmode => $e --stating the already known + u:= compMakeCategoryObject(cat,$e) => + --we are adding information about a category + [catvec,.,$e]:= u + [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) + -- member(vmode,CAR catvec.4) => + -- JHD 82/08/08 01:40 This does not mean that we can ignore the + -- extension, since this may not be compatible with the view we + -- were passed + + --we are adding a principal descendant of what was already known + -- $e:= augModemapsFromCategory(name,name,nil,catvec,$e) + -- SAY("augmenting ",name,": ",cat) + -- put(name, "value", (vval, cat, venv), $e) + member(cat,first ocatvec.4) or + ASSOC(cat,CADR ocatvec.4) is [.,"T",.] => $e + --SAY("Category extension error: + --cat shouldn't be a join + --what was being asserted is an ancestor of what was known + if name="$" + then $e:= augModemapsFromCategory(name,name,name,cat,$e) + else + viewName:=genDomainViewName(name,cat) + genDomainView(viewName,name,cat,"HasCategory") + if not MEMQ(viewName,$functorLocalParameters) then + $functorLocalParameters:=[:$functorLocalParameters,viewName] + SAY("augmenting ",name,": ",cat) + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + SAY("extension of ",vval," to ",cat," ignored") + $e + systemError '"knownInfo" + +------- from nruncomp.boot ----------- + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +genDeltaEntry opMmPair == +--called from compApplyModemap +--$NRTdeltaLength=0.. always equals length of $NRTdeltaList + [.,[odc,:.],.] := opMmPair + --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) + [op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair + if $profileCompiler = true then profileRecord(dc,op,sig) + eltOrConst = 'XLAM => cform + if eltOrConst = 'Subsumed then eltOrConst := 'ELT + if atom dc then + dc = "$" => nsig := sig + if NUMBERP nsig then nsig := substitute('$,dc,substitute("$$","$",sig)) + -- following hack needed to invert Rep to $ substitution +-- if odc = 'Rep and cform is [.,.,osig] then sig:=osig + newimp := optDeltaEntry(op,nsig,dc,eltOrConst) => newimp + setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => + ['applyFun,['compiledLookupCheck,MKQ op, + mkList consSig(nsig,dc),consDomainForm(dc,nil)]] + odc := dc + if null atom dc then dc := substitute("$$",'$,dc) + -- sig := substitute('$,dc,sig) + -- cform := substitute('$,dc,cform) + opModemapPair := + [op,[dc,:[genDeltaSig x for x in nsig]],["T",cform]] -- force pred to T + if null NRTassocIndex dc and dc ^= $NRTaddForm and + (member(dc,$functorLocalParameters) or null atom dc) then + --create "domain" entry to $NRTdeltaList + $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= (compOrCroak(odc,$EmptyMode,$e)).expr +-- dc + RPLACA(saveNRTdeltaListComp,compEntry) + u := + [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == + (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 + --n + 1 since $NRTdeltaLength is 1 too large + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + 0 + u + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == + --converts a domain form to a lazy domain form; everything other than + --the operation name should be assigned a slot + null firstTime and (k:= NRTassocIndex x) => k + VECP x => systemErrorHere '"NRTencode" + PAIRP x => + QCAR x='Record or x is ['Union,['_:,a,b],:.] => + [QCAR x,:[['_:,a,encode(b,c,false)] + for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] + constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => + [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] + ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] + MEMQ(x,$formalArgList) => + v := $FormalMapVariableList.(POSN1(x,$formalArgList)) + firstTime => ["local",v] + v + x = '$ => x + x = "$$" => x + ['QUOTE,x] + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +consDomainName(x,dc) == + x = dc => ''$ + x = '$ => ''$ + x = "$$" => ['devaluate,'$] + x is [op,:argl] => + (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => + mkList [MKQ op, + :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] + for [.,tag,dom] in argl]] + isFunctor op or op = 'Mapping or constructor? op => + -- call to constructor? needed if op was compiled in $bootStrapMode + mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] + substitute('$,"$$",x) + x = [] => x + (y := LASSOC(x,$devaluateList)) => y + k:=NRTassocIndex x => + ['devaluate,['ELT,'$,k]] + get(x,'value,$e) => + isDomainForm(x,$e) => ['devaluate,x] + x + MKQ x + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +NRTassignCapsuleFunctionSlot(op,sig) == +--called from compDefineCapsuleFunction + opSig := [op,sig] + [.,.,implementation] := NRTisExported? opSig or return nil + --if opSig is not exported, it is local and need not be assigned + if $insideCategoryPackageIfTrue then + sig := substitute('$,CADR($functorForm),sig) + sig := [genDeltaSig x for x in sig] + opModemapPair := [op,['_$,:sig],["T",implementation]] + POSN1(opModemapPair,$NRTdeltaList) => nil --already there + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp := [nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +changeDirectoryInSlot1() == --called by NRTbuildFunctor + --3 cases: + -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs + -- otherwise called from compFunctorBody (all lookups are forwarded): + -- $NRTdeltaList = nil ===> all slot numbers become nil + $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where + sigloc [opsig,pred,fnsel] == + if pred ^= 'T then + pred := simpBool pred + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => + if $insideCategoryPackageIfTrue then + opsig := substitute('$,CADR($functorForm),opsig) + [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] + [opsig,pred,fnsel] + sortedOplist := listSort(function GLESSEQP, + COPY_-LIST $lisplibOperationAlist,function CADR) + $lastPred :local := nil + $newEnv :local := $e + $domainShell.1 := [fn entry for entry in sortedOplist] where + fn [[op,sig],pred,fnsel] == + if $lastPred ^= pred then + $newEnv := deepChaseInferences(pred,$e) + $lastPred := pred + newfnsel := + fnsel is ['Subsumed,op1,sig1] => + ['Subsumed,op1,genSlotSig(sig1,"T",$newEnv)] + fnsel + [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] + +------- from compiler.boot ----------- + +--------------------> NEW DEFINITION (see compiler.boot.pamphlet) +getFormModemaps(form is [op,:argl],e) == + op is ["elt",domain,op1] => + [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] + null atom op => nil + modemapList:= get(op,"modemap",e) + if $insideCategoryPackageIfTrue then + modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ^= '$] + if op="elt" + then modemapList:= eltModemapFilter(LAST argl,modemapList,e) or return nil + else + if op="setelt" then modemapList:= + seteltModemapFilter(CADR argl,modemapList,e) or return nil + nargs:= #argl + finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] + modemapList and null finalModemapList => + stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] + finalModemapList + +------- from functor.boot ----------- + +--------------------> NEW DEFINITION (see functor.boot.pamphlet) +LookUpSigSlots(sig,siglist) == +--+ must kill any implementations below of the form (ELT $ NIL) + if $insideCategoryPackageIfTrue then + sig := substitute('$,CADR($functorForm),sig) + siglist := $lisplibOperationAlist + REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) + and KADDR implem] + |