diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/interp/ChangeLog | 18 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 6 | ||||
| -rw-r--r-- | src/interp/Makefile.pamphlet | 6 | ||||
| -rw-r--r-- | src/interp/compiler.boot | 3 | ||||
| -rw-r--r-- | src/interp/functor.boot | 3 | ||||
| -rw-r--r-- | src/interp/info.boot | 8 | ||||
| -rw-r--r-- | src/interp/modemap.boot | 31 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 43 | ||||
| -rw-r--r-- | src/interp/xruncomp.boot | 333 |
9 files changed, 70 insertions, 381 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index af564d56..7c9b7e1d 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,5 +1,23 @@ 2007-12-05 Gabriel Dos Reis <gdr@cs.tamu.edu> + * Makefile.pamphlet (xruncomp.$(FASLEXT)): Remove rule. + (OCOBJS): Don't include xruncomp.$(FASLEXT) anymore. + * xruncomp.boot: Remove. + * compiler.boot (getFormModemaps): Merge from xruncomp.boot. + * functor.boot (LookUpSigSlots): Likewise. + * info.boot (actOnInfo): Likewise. + * modemap.boot (addModemap1): Likewise. + (evalAndSub): Likewise. + (substNames): Likewise. + (addConstructorModemaps): Likewise. + * nruncomp.boot (NRTencode): Likewise. + (genDeltaEntry): Likewise. + (NRTassignCapsuleFunctionSlot): Likewise. + (consDomainName): Likewise. + (changeDirectoryInSlot1): Likewise. + +2007-12-05 Gabriel Dos Reis <gdr@cs.tamu.edu> + * macros.lisp (|$highlightAllowed|): Remove. (|$lightlightFontOn|): Likewise. (|$highlightFontOff|): Likewise. diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index a3834948..768dc64a 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -99,8 +99,7 @@ OCOBJS= apply.$(FASLEXT) c-doc.$(FASLEXT) \ define.$(FASLEXT) functor.$(FASLEXT) \ info.$(FASLEXT) iterator.$(FASLEXT) \ modemap.$(FASLEXT) nruncomp.$(FASLEXT) \ - package.$(FASLEXT) htcheck.$(FASLEXT) \ - xruncomp.$(FASLEXT) + package.$(FASLEXT) htcheck.$(FASLEXT) autoload_objects += $(OCOBJS) @@ -476,9 +475,6 @@ newfort.$(FASLEXT): newfort.boot macros.$(FASLEXT) lisplib.$(FASLEXT): lisplib.boot nlib.$(FASLEXT) c-util.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< -xruncomp.$(FASLEXT): xruncomp.boot c-util.$(FASLEXT) - $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< - interop.$(FASLEXT): interop.boot c-util.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 509bb480..fb113b3d 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -231,8 +231,7 @@ OCOBJS= apply.$(FASLEXT) c-doc.$(FASLEXT) \ define.$(FASLEXT) functor.$(FASLEXT) \ info.$(FASLEXT) iterator.$(FASLEXT) \ modemap.$(FASLEXT) nruncomp.$(FASLEXT) \ - package.$(FASLEXT) htcheck.$(FASLEXT) \ - xruncomp.$(FASLEXT) + package.$(FASLEXT) htcheck.$(FASLEXT) autoload_objects += $(OCOBJS) @@ -801,9 +800,6 @@ newfort.$(FASLEXT): newfort.boot macros.$(FASLEXT) lisplib.$(FASLEXT): lisplib.boot nlib.$(FASLEXT) c-util.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< -xruncomp.$(FASLEXT): xruncomp.boot c-util.$(FASLEXT) - $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< - interop.$(FASLEXT): interop.boot c-util.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 572a0b85..9834418a 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -441,12 +441,13 @@ compForm3(form is [op,:argl],m,e,modemapList) == T T ---------------------> NEW DEFINITION (override in xruncomp.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 diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 2e581dec..c9ae53d7 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -718,9 +718,10 @@ SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" body is ['QSETREFV,:.] => body nil ---------------------> NEW DEFINITION (override in xruncomp.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] diff --git a/src/interp/info.boot b/src/interp/info.boot index b53cc314..adda1212 100644 --- a/src/interp/info.boot +++ b/src/interp/info.boot @@ -209,7 +209,6 @@ knownInfo pred == --error '"knownInfo" false ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) actOnInfo(u,$e) == null u => $e u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) @@ -231,9 +230,10 @@ actOnInfo(u,$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))) => + (implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) => CADADR implem - ['ELT,name,nil] + 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) @@ -257,7 +257,7 @@ actOnInfo(u,$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 + 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 diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index 02c93677..7dc30283 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -155,13 +155,12 @@ addEltModemap(op,mc,sig,pred,fn,e) == addModemap1(op,mc,sig,pred,fn,e) systemErrorHere '"addEltModemap" ---------------------> NEW DEFINITION (override in xruncomp.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 +-- if fn is [kind,'Rep,.] and -- save old sig for NRUNTIME - (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] +-- (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] sig:= substitute("$",'Rep,sig) currentProplist:= getProplist(op,e) or nil newModemapList:= @@ -308,7 +307,6 @@ augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == -- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm) -- catForm ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) evalAndSub(domainName,viewName,functorForm,form,$e) == $lhsOfColon: local:= domainName isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] @@ -316,7 +314,7 @@ evalAndSub(domainName,viewName,functorForm,form,$e) == if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) opAlist:= getOperationAlist(domainName,functorForm,form) substAlist:= substNames(domainName,viewName,functorForm,opAlist) - [substitute("$","$$",substAlist),$e] + [substAlist,$e] getOperationAlist(name,functorForm,form) == if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm] @@ -328,15 +326,19 @@ getOperationAlist(name,functorForm,form) == T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1)) stackMessage ["not a category form: ",form] ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -substNames(domainName,viewName,functorForm,catForm) == - EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, - -- [[[op,if KAR fnsel="PAC" then sig else SUBSTQ(domainName,"$",sig),:x],pred, - -- SUBSTQ(viewName,"$",fnsel)] for [[op,sig,:x],pred,fnsel] in catForm]) +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(domainName,"$",modemapform),SUBSTQ(viewName,"$",fnsel)] - for [:modemapform,fnsel] in catForm]) + [[:SUBSTQ("$","$$",SUBSTQ(nameForDollar,"$",modemapform)), + [sel, viewName,if domainName = "$" then pos else + CADAR modemapform]] + for [:modemapform,[sel,"$",pos]] in + EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, opalist)] compCat(form is [functorName,:argl],m,e) == fn:= GETL(functorName,"makeFunctionList") or return nil @@ -348,13 +350,16 @@ compCat(form is [functorName,:argl],m,e) == --sure if it uses any of the other signatures(see extendsCategoryForm) [form,catForm,e] ---------------------> NEW DEFINITION (override in xruncomp.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 diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 3db6237b..308c862f 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -87,9 +87,8 @@ NRTreplaceAllLocalReferences(form) == $devaluateList :local := [] NRTputInLocalReferences form ---------------------> NEW DEFINITION (override in xruncomp.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 + --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" @@ -102,9 +101,10 @@ NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] MEMQ(x,$formalArgList) => v := $FormalMapVariableList.(POSN1(x,$formalArgList)) - firstTime => ['local,v] + firstTime => ["local",v] v x = '$ => x + x = "$$" => x ['QUOTE,x] --------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- @@ -154,34 +154,37 @@ optDeltaEntry(op,sig,dc,eltOrConst) == eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn] GETL(compileTimeBindingOf first fn,'SPADreplace) ---------------------> NEW DEFINITION (override in xruncomp.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,:.]]] := 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,sig,dc,eltOrConst) => newimp +-- 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(sig,dc),consDomainForm(dc,nil)]] - --if null atom dc then + 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 sig]],['T,cform]] -- force pred to T + [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(dc,$EmptyMode,$e)).expr + compEntry:= (compOrCroak(odc,$EmptyMode,$e)).expr -- dc RPLACA(saveNRTdeltaListComp,compEntry) u := @@ -245,14 +248,15 @@ NRTgetAddForm domain == EQSUBSTLIST(rest domain,$FormalMapVariableList,first u) systemErrorHere '"NRTgetAddForm" ---------------------> NEW DEFINITION (override in xruncomp.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]] + opModemapPair := [op,['_$,:sig],["T",implementation]] POSN1(opModemapPair,$NRTdeltaList) => nil --already there $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] $NRTdeltaListComp := [nil,:$NRTdeltaListComp] @@ -268,10 +272,10 @@ consOpSig(op,sig,dc) == consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig] ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) consDomainName(x,dc) == x = dc => ''$ - x = '$ => ['devaluate,'$] + x = '$ => ''$ + x = "$$" => ['devaluate,'$] x is [op,:argl] => (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => mkList [MKQ op, @@ -280,12 +284,12 @@ consDomainName(x,dc) == 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]] - x + substitute('$,"$$",x) x = [] => x (y := LASSOC(x,$devaluateList)) => y k:=NRTassocIndex x => ['devaluate,['ELT,'$,k]] - get(x,'value,$e) or get(x,'mode,$e) => + get(x,'value,$e) => isDomainForm(x,$e) => ['devaluate,x] x MKQ x @@ -622,7 +626,6 @@ NRTaddToSlam([name,:argnames],shell) == args:= ['LIST,:ASSOCRIGHT $devaluateList] addToConstructorCache(name,args,shell) ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) changeDirectoryInSlot1() == --called by NRTbuildFunctor --3 cases: -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs @@ -634,6 +637,8 @@ changeDirectoryInSlot1() == --called by NRTbuildFunctor 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, @@ -647,7 +652,7 @@ changeDirectoryInSlot1() == --called by NRTbuildFunctor $lastPred := pred newfnsel := fnsel is ['Subsumed,op1,sig1] => - ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)] + ['Subsumed,op1,genSlotSig(sig1,"T",$newEnv)] fnsel [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] diff --git a/src/interp/xruncomp.boot b/src/interp/xruncomp.boot deleted file mode 100644 index bb5d26a2..00000000 --- a/src/interp/xruncomp.boot +++ /dev/null @@ -1,333 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007, Gabriel Dos Reis. --- 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. - - -import '"c-util" -)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] - |