diff options
Diffstat (limited to 'src/interp/nruncomp.boot.pamphlet')
| -rw-r--r-- | src/interp/nruncomp.boot.pamphlet | 769 |
1 files changed, 769 insertions, 0 deletions
diff --git a/src/interp/nruncomp.boot.pamphlet b/src/interp/nruncomp.boot.pamphlet new file mode 100644 index 00000000..fbc94289 --- /dev/null +++ b/src/interp/nruncomp.boot.pamphlet @@ -0,0 +1,769 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\$SPAD/src/interp nruncomp.boot} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<<license>>= +-- 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. + +@ +<<*>>= +<<license>> + +-----------------------------NEW buildFunctor CODE----------------------------- +NRTaddDeltaCode() == +--NOTES: This function is called from NRTbuildFunctor to initially +-- fill slots in $template. The $template so created is stored in the +-- NRLIB. On load, makeDomainTemplate is called on this $template to +-- create a template which becomes slot 0 of the infovec for the constructor. +--The template has 6 kinds of entries: +-- (1) formal arguments and local variables, represented by (QUOTE <entry>) +-- this conflicts by (5) but is ok since each is explicitly set by +-- instantiator code; +-- (2) domains, represented by lazy forms, e.g. (Foo 12 17 6) +-- (3) latch slots, represented SPADCALLable forms which goGet an operation +-- from a domain then cache the operation in the same slot +-- (4) functions, represented by identifiers which are names of functions +-- (5) identifiers/strings, parts of signatures (now parts of signatures +-- now must all have slot numbers, represented by (QUOTE <entry>) +-- (6) constants, like 0 and 1, represented by (CONS .. ) form + kvec := first $catvecList + for i in $NRTbase.. for item in REVERSE $NRTdeltaList + for compItem in REVERSE $NRTdeltaListComp + |null (s:=kvec.i) repeat + $template.i:= deltaTran(item,compItem) + $template.5 := + $NRTaddForm => + $NRTaddForm is ['Tuple,:y] => NREVERSE y + NRTencode($NRTaddForm,$addForm) + nil + +deltaTran(item,compItem) == + item is ['domain,lhs,:.] => NRTencode(lhs,compItem) + --NOTE: all items but signatures are wrapped with domain forms + [op,:modemap] := item + [dcSig,[.,[kind,:.]]] := modemap + [dc,:sig] := dcSig + sig := substitute('$,dc,substitute("$$",'$,sig)) + dcCode := + dc = '$ => + --$NRTaddForm => -5 + 0 + NRTassocIndexAdd dc or keyedSystemError("S2NR0004",[dc]) + formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig) + kindFlag:= (kind = 'CONST => 'CONST; nil) + newSig := [NRTassocIndex x or x for x in formalSig] + [newSig,dcCode,op,:kindFlag] + +--NRTencodeSig x == [NRTencode y for y in x] + +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 + --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 + ['QUOTE,x] + +--------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- +listOfBoundVars form == +-- Only called from the function genDeltaEntry below + form = '$ => [] + IDENTP form and (u:=get(form,'value,$e)) => + u:=u.expr + MEMQ(KAR u,'(Union Record)) => listOfBoundVars u + [form] + atom form => [] + CAR form = 'QUOTE => [] + EQ(CAR form,":") => listOfBoundVars CADDR form + -- We don't want to pick up the tag, only the domain + "union"/[listOfBoundVars x for x in CDR form] + +optDeltaEntry(op,sig,dc,eltOrConst) == + $killOptimizeIfTrue = true => nil + ndc := + dc = '$ => $functorForm + atom dc and (dcval := get(dc,'value,$e)) => dcval.expr + dc +--if (atom dc) and (dcval := get(dc,'value,$e)) +-- then ndc := dcval.expr +-- else ndc := dc + sig := SUBST(ndc,dc,sig) + not MEMQ(KAR ndc,$optimizableConstructorNames) => nil + dcval := optCallEval ndc + -- MSUBST guarantees to use EQUAL testing + sig := MSUBST(devaluate dcval, ndc, sig) + if rest ndc then + for new in rest devaluate dcval for old in rest ndc repeat + sig := MSUBST(new,old,sig) + -- optCallEval sends (List X) to (LIst (Integer)) etc, + -- so we should make the same transformation + fn := compiledLookup(op,sig,dcval) + if null fn then + -- following code is to handle selectors like first, rest + nsig := [quoteSelector tt for tt in sig] where + quoteSelector(x) == + not(IDENTP x) => x + get(x,'value,$e) => x + x='$ => x + MKQ x + fn := compiledLookup(op,nsig,dcval) + if null fn then return nil + 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 + if $profileCompiler = true then profileRecord(dc,op,sig) + eltOrConst = 'XLAM => cform + if eltOrConst = 'Subsumed then eltOrConst := 'ELT + -- 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 + setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => + ['applyFun,['compiledLookupCheck,MKQ op, + mkList consSig(sig,dc),consDomainForm(dc,nil)]] + --if null atom dc then + -- sig := substitute('$,dc,sig) + -- cform := substitute('$,dc,cform) + opModemapPair := + [op,[dc,:[genDeltaSig x for x in sig]],['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 +-- 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 + +genDeltaSig x == + NRTgetLocalIndex x + +genDeltaSpecialSig x == + x is [":",y,z] => [":",y,genDeltaSig z] + genDeltaSig x + +NRTassocIndexAdd x == + x = $NRTaddForm => 5 + NRTassocIndex x + +NRTassocIndex x == --returns index of "domain" entry x in al + NULL x => x + x = $NRTaddForm => 5 + k := or/[i for i in 1.. for y in $NRTdeltaList + | y.0 = 'domain and y.1 = x and ($found := y)] => + $NRTbase + $NRTdeltaLength - k + nil + +NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true) + +NRTgetLocalIndex item == NRTgetLocalIndex1(item,false) + +NRTgetLocalIndex1(item,killBindingIfTrue) == + k := NRTassocIndex item => k + item = $NRTaddForm => 5 + item = '$ => 0 + item = '_$_$ => 2 + value:= + MEMQ(item,$formalArgList) => item + nil + atom item and null MEMQ(item,'($ _$_$)) + and null value => --give slots to atoms + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + $NRTdeltaListComp:=[item,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + $NRTbase + $NRTdeltaLength - 1 + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + saveIndex := $NRTbase + $NRTdeltaLength + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= compOrCroak(item,$EmptyMode,$e).expr +-- item + RPLACA(saveNRTdeltaListComp,compEntry) + saveIndex + +NRTgetAddForm domain == + u := HGET($Slot1DataBase,first 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 + 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 + +NRTisExported? opSig == + or/[u for u in $domainShell.1 | u.0 = opSig] + +consOpSig(op,sig,dc) == + if null atom 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] + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +consDomainName(x,dc) == + x = dc => ''$ + 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]] + x + x = [] => x + (y := LASSOC(x,$devaluateList)) => y + k:=NRTassocIndex x => + ['devaluate,['ELT,'$,k]] + get(x,'value,$e) or get(x,'mode,$e) => + isDomainForm(x,$e) => ['devaluate,x] + x + MKQ x + +consDomainForm(x,dc) == + x = '$ => '$ + x is [op,:argl] => + op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)] + [op,:[consDomainForm(y,dc) for y in argl]] + x = [] => x + (y := LASSOC(x,$devaluateList)) => y + k:=NRTassocIndex x => ['ELT,'$,k] + get(x,'value,$e) or get(x,'mode,$e) => x + MKQ x + +buildFunctor($definition is [name,:args],sig,code,$locals,$e) == +--PARAMETERS +-- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber)) +-- sig: signature of constructor form +-- code: result of "doIt", converting body of capsule to CodeDefine forms, e.g. +-- (PROGN (LET Rep ...) +-- (: (ListOf x y) $) +-- (CodeDefine (<op> <signature> <functionName>)) +-- (COND ((HasCategory $ ...) (PROGN ...))) ..) +-- $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4) +-- same as $functorLocalParameters +-- this list is not augmented by this function +-- $e: environment +--GLOBAL VARIABLES REFERENCED: +-- $domainShell: passed in from compDefineFunctor1 +-- $QuickCode: compilation flag + + if code is ['add,.,newstuff] then code := newstuff + + changeDirectoryInSlot1() --this extends $NRTslot1PredicateList + + --pp '"==================" + --for item in $NRTdeltaList repeat pp item + +--LOCAL BOUND FLUID VARIABLES: + $GENNO: local:= 0 --bound in compDefineFunctor1, then as parameter here +--$frontier: local --index of first local slot=#(cat part of princ view) + $catvecList: local --list of vectors v1..vn for each view + $hasCategoryAlist: local --list of GENSYMs bound to (HasCategory ..) items + $catNames: local --list of names n1..nn for each view + $maximalViews: local --list of maximal categories for domain (???) + $catsig: local --target category (used in ProcessCond) + $SetFunctions: local --copy of p view with preds telling when fnct defined + $MissingFunctionInfo: local --now useless + --vector marking which functions are assigned + $ConstantAssignments: local --code for creation of constants + $epilogue: local := nil --code to set slot 5, things to be done last + $HackSlot4: local --Invention of JHD 13/July/86-set in InvestigateConditions + $extraParms:local --Set in DomainSubstitutionFunction, used in setVector12 + $devaluateList: local --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later + $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList] + $supplementaries: local + --set in InvestigateConditions to represent any additional + --category membership tests that may be needed(see buildFunctor for details) +------------------------ + $maximalViews: local + oldtime:= TEMPUS_-FUGIT() + [$catsig,:argsig]:= sig + catvecListMaker:=REMDUP + [(comp($catsig,$EmptyMode,$e)).expr, + :[compCategories first u for u in CADR $domainShell.4]] + condCats:= InvestigateConditions [$catsig,:rest catvecListMaker] + -- a list, one %for each element of catvecListMaker + -- indicating under what conditions this + -- category should be present. true => always + makeCatvecCode:= first catvecListMaker + emptyVector := VECTOR() +--if $NRTaddForm and null NRTassocIndex $NRTaddForm then +-- --create "domain" entry to $NRTdeltaList +-- $NRTdeltaList:= +-- [['domain,NRTaddInner $NRTaddForm,:$NRTaddForm],:$NRTdeltaList] +-- $NRTdeltaLength := $NRTdeltaLength+1 +--NRTgetLocalIndex $NRTaddForm + domainShell := GETREFV (6 + $NRTdeltaLength) + for i in 0..4 repeat domainShell.i := $domainShell.i + --we will clobber elements; copy since $domainShell may be a cached vector + $template := + $NRTvec = true => GETREFV (6 + $NRTdeltaLength) + nil + $catvecList:= [domainShell,:[emptyVector for u in CADR domainShell.4]] + $catNames := ['$] -- for DescendCode -- to be changed below for slot 4 + $maximalViews:= nil + $SetFunctions:= GETREFV SIZE domainShell + $MissingFunctionInfo:= GETREFV SIZE domainShell + $catNames:= ['$,:[GENVAR() for u in rest catvecListMaker]] + domname:='dv_$ + +--> Do this now to create predicate vector; then DescendCode can refer +--> to predicate vector if it can + [$uncondAlist,:$condAlist] := --bound in compDefineFunctor1 + NRTsetVector4Part1($catNames,catvecListMaker,condCats) + [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := + makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList] + + storeOperationCode:= DescendCode(code,true,nil,first $catNames) + outsideFunctionCode:= NRTaddDeltaCode() + storeOperationCode:= NRTputInLocalReferences storeOperationCode + if $NRTvec = true then + NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode + codePart2:= + $NRTvec = true => + argStuffCode := + [[$setelt,'$,i,v] for i in 6.. for v in $FormalMapVariableList + for arg in rest $definition] + if MEMQ($NRTaddForm,$locals) then + addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals)) + argStuffCode := [[$setelt,'$,5,addargname],:argStuffCode] + [['stuffDomainSlots,'$],:argStuffCode, + :predBitVectorCode2,storeOperationCode] + [:outsideFunctionCode,storeOperationCode] + + $CheckVectorList := NRTcheckVector domainShell +--CODE: part 1 + codePart1:= [:devaluateCode,:domainFormCode,createDomainCode, + createViewCode,setVector0Code, slot3Code,:slamCode] where + devaluateCode:= [['LET,b,['devaluate,a]] for [a,:b] in $devaluateList] + domainFormCode := [['LET,a,b] for [a,:b] in NREVERSE $NRTdomainFormList] + --$NRTdomainFormList is unused now + createDomainCode:= + ['LET,domname,['LIST,MKQ CAR $definition,:ASSOCRIGHT $devaluateList]] + createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]] + setVector0Code:=[$setelt,'$,0,'dv_$] + slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]] + slamCode:= + isCategoryPackageName opOf $definition => nil + [NRTaddToSlam($definition,'$)] + +--CODE: part 3 + $ConstantAssignments := + [NRTputInLocalReferences code for code in $ConstantAssignments] + codePart3:= [:constantCode1, + :constantCode2,:epilogue] where + constantCode1:= + name='Integer => $ConstantAssignments + nil + -- The above line is needed to get the recursion + -- Integer => FontTable => NonNegativeInteger => Integer + -- right. Otherwise NNI has 'unset' for 0 and 1 +-- setVector4c:= setVector4part3($catNames,$catvecList) + -- In particular, setVector4part3 and setVector5, + -- which generate calls to local domain-instantiators, + -- must come after operations are set in the vector. + -- The symptoms of getting this wrong are that + -- operations are not set which should be + constantCode2:= --matches previous test on Integer + name='Integer => nil + $ConstantAssignments + epilogue:= $epilogue + ans := + ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$] + $getDomainCode:= nil + --if we didn't kill this, DEFINE would insert it in the wrong place + ans:= minimalise ans + SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime] + --sayBrightly '"------------------functor code: -------------------" + --pp ans + ans + +NRTcheckVector domainShell == +--RETURNS: an alist (((op,sig),:pred) ...) of missing functions + alist := nil + for i in 6..MAXINDEX domainShell repeat +--Vector elements can be one of +-- (a) T -- item was marked +-- (b) NIL -- item is a domain; will be filled in by setVector4part3 +-- (c) categoryForm-- it was a domain view; now irrelevant +-- (d) op-signature-- store missing function info in $CheckVectorList + v:= domainShell.i + v=true => nil --item is marked; ignore + null v => nil --a domain, which setVector4part3 will fill in + atom first v => nil --category form; ignore + atom v => systemErrorHere '"CheckVector" + ASSOC(first v,alist) => nil + alist:= + [[first v,:$SetFunctions.i],:alist] + alist + +-- Obsolete once we have moved to JHD's world +NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV (6 + deltaLength) + +mkDomainCatName id == INTERN STRCONC(id,";CAT") + +NRTsetVector4(siglist,formlist,condlist) == + $uncondList: local := nil + $condList: local := nil + $count: local := 0 + for sig in reverse siglist for form in reverse formlist + for cond in reverse condlist repeat + NRTsetVector4a(sig,form,cond) + --NRTsetVector4a(first siglist,first formlist,first condlist) + + $lisplibCategoriesExtended:= [$uncondList,:$condList] + code := ['mapConsDB,MKQ REVERSE REMDUP $uncondList] + if $condList then + localVariable := GENSYM() + code := [['LET,localVariable,code]] + for [pred,list] in $condList repeat + code := + [['COND,[pred,['LET,localVariable, + ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], + :code] + code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] + g := GENSYM() + [$setelt,'$,4,['PROG2,['LET,g,code], + ['VECTOR,['catList2catPackageList,g],g]]] + +NRTsetVector4Part1(siglist,formlist,condlist) == + $uncondList: local := nil + $condList: local := nil + $count: local := 0 + for sig in reverse siglist for form in reverse formlist + for cond in reverse condlist repeat + NRTsetVector4a(sig,form,cond) + reducedUncondlist := REMDUP $uncondList + reducedConlist := + [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)] + revCondlist := reverseCondlist reducedConlist + orCondlist := [[x,:MKPF(y,'OR)] for [x,:y] in revCondlist] + [reducedUncondlist,:orCondlist] + --NRTsetVector4a(first siglist,first formlist,first condlist) + +reverseCondlist cl == + alist := nil + for [x,:y] in cl repeat + for z in y repeat + u := ASSOC(z,alist) + null u => alist := [[z,x],:alist] + member(x,CDR u) => nil + RPLACD(u,[x,:CDR u]) + alist + +NRTsetVector4Part2(uncondList,condList) == + $lisplibCategoriesExtended:= [uncondList,:condList] + code := ['mapConsDB,MKQ REVERSE REMDUP uncondList] + if condList then + localVariable := GENSYM() + code := [['LET,localVariable,code]] + for [pred,list] in condList repeat + code := + [['COND,[predicateBitRef SUBLIS($pairlis,pred),['LET,localVariable, + ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], + :code] + code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] + g := GENSYM() + [$setelt,'$,4,['PROG2,['LET,g,code], + ['VECTOR,['catList2catPackageList,g],g]]] + +mergeAppend(l1,l2) == + ATOM l1 => l2 + member(QCAR l1,l2) => mergeAppend(QCDR l1, l2) + CONS(QCAR l1, mergeAppend(QCDR l1, l2)) + +--genLoadTimeValue u == +-- name := +-- INTERN STRCONC(PNAME first $definition,'";",STRINGIZE($count:=$count+1)) +-- $NRTloadTimeAlist := [[name,:['addConsDB,MKQ u]],:$NRTloadTimeAlist] +-- --see compDefineFunctor1 +-- name + +catList2catPackageList u == +--converts ((Set) (Module R) ...) to ((Set& $) (Module& $ R)...) + [fn x for x in u] where + fn [op,:argl] == + newOp := INTERN(STRCONC(PNAME op,"&")) + addConsDB [newOp,"$",:argl] + +NRTsetVector4a(sig,form,cond) == + sig = '$ => + domainList := + [optimize COPY KAR comp(d,$EmptyMode,$e) or d for d in $domainShell.4.0] + $uncondList := APPEND(domainList,$uncondList) + if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList] + $uncondList + evalform := eval mkEvalableCategoryForm form + cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)] + $condList := [[cond,[form,:evalform.4.0]],:$condList] + +NRTmakeSlot1 domainShell == + opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect") + fun := + $NRTmakeCompactDirect => '(function lookupInCompactTable) + '(function lookupInTable) + [($QuickCode=>'QSETREFV;'SETELT), '$,1, ['LIST,fun,'$,opDirectName]] + +NRTmakeSlot1Info() == +-- 4 cases: +-- a:T == b add c --- slot1 directory has #s for entries defined in c +-- a:T == b --- slot1 has all slot #s = NIL (see compFunctorBody) +-- a == b add c --- not allowed (line 7 of getTargetFromRhs) +-- a == b --- $NRTderivedTargetIfTrue = true; set directory to NIL + pairlis := + $insideCategoryPackageIfTrue = true => + [:argl,dollarName] := rest $form + [[dollarName,:'_$],:mkSlot1sublis argl] + mkSlot1sublis rest $form + $lisplibOpAlist := transformOperationAlist SUBLIS(pairlis,$domainShell.1) + opList := + $NRTderivedTargetIfTrue => 'derived + $insideCategoryPackageIfTrue = true => slot1Filter $lisplibOpAlist + $lisplibOpAlist + addList := SUBLIS(pairlis,$NRTaddForm) + [first $form,[addList,:opList]] + +mkSlot1sublis argl == + [[a,:b] for a in argl for b in $FormalMapVariableList] + +slot1Filter opList == +--include only those ops which are defined within the capsule + [u for x in opList | u := fn x] where + fn [op,:l] == + u := [entry for entry in l | INTEGERP CADR entry] => [op,:u] + nil + +NRToptimizeHas u == +--u is a list ((pred cond)...) -- see optFunctorBody +--produces an alist: (((HasCategory a b) . GENSYM)...) + u is [a,:b] => + a='HasCategory => LASSOC(u,$hasCategoryAlist) or + $hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist] + y + a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b] + a = 'QUOTE => u + [NRToptimizeHas a,:NRToptimizeHas b] + u + +NRTaddToSlam([name,:argnames],shell) == + $mutableDomain => return nil + null argnames => addToConstructorCache(name,nil,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 + -- 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) => + [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] + +genSlotSig(sig,pred,$e) == + [genDeltaSig t for t in sig] + +deepChaseInferences(pred,$e) == + pred is ['AND,:preds] or pred is ['and,:preds] => + for p in preds repeat $e := deepChaseInferences(p,$e) + $e + pred is ['OR,pred1,:.] or pred is ['or,pred1,:.] => + deepChaseInferences(pred1,$e) + pred is 'T or pred is ['NOT,:.] or pred is ['not,:.] => $e + chaseInferences(pred,$e) + +vectorLocation(op,sig) == + u := or/[i for i in 1.. for u in $NRTdeltaList + | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ] + u => $NRTdeltaLength - u + 6 + nil -- this signals that calls should be forwarded + +NRTsubstDelta(initSig) == + sig := [replaceSlotTypes s for s in initSig] where + replaceSlotTypes(t) == + atom t => + not INTEGERP t => t + t = 0 => '$ + t = 2 => '_$_$ + t = 5 => $NRTaddForm + u:= $NRTdeltaList.($NRTdeltaLength+5-t) + CAR u = 'domain => CADR u + error "bad $NRTdeltaList entry" + MEMQ(CAR t,'(Mapping Union Record _:)) => + [CAR t,:[replaceSlotTypes(x) for x in rest t]] + t +-----------------------------SLOT1 DATABASE------------------------------------ + +updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info) + +NRTputInLocalReferences bod == + $elt: local := ($QuickCode => 'QREFELT; 'ELT) + NRTputInHead bod + +NRTputInHead bod == + atom bod => bod +-- LASSOC(bod,$devaluateList) => nil +-- k:= NRTassocIndex bod => [$elt,'_$,k] +-- systemError '"unexpected position of domain reference" +-- bod +--bod is ['LET,var,val,:extra] and IDENTP var => +-- NRTputInTail extra +-- k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k]) +-- NRTputInHead val +-- bod + bod is ['SPADCALL,:args,fn] => + NRTputInTail rest bod --NOTE: args = COPY of rest bod + -- The following test allows function-returning expressions + fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) => + k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k]) +-- sayBrightlyNT '"unexpected SPADCALL:" +-- pp fn +-- nil +-- keyedSystemError("S2GE0016",['"NRTputInHead", +-- '"unexpected SPADCALL form"]) + nil + NRTputInHead fn + bod + bod is ["COND",:clauses] => + for cc in clauses repeat NRTputInTail cc + bod + bod is ["QUOTE",:.] => bod + bod is ["CLOSEDFN",:.] => bod + bod is ["SPADCONST",dom,ind] => + RPLACA(bod,$elt) + dom = '_$ => nil + k:= NRTassocIndex dom => + RPLACA(LASTNODE bod,[$elt,'_$,k]) + bod + keyedSystemError("S2GE0016",['"NRTputInHead", + '"unexpected SPADCONST form"]) + NRTputInHead first bod + NRTputInTail rest bod + bod + +NRTputInTail x == + for y in tails x repeat + atom (u := first y) => + EQ(u,'$) or LASSOC(u,$devaluateList) => nil + k:= NRTassocIndex u => + atom u => RPLACA(y,[$elt,'_$,k]) + -- u atomic means that the slot will always contain a vector + RPLACA(y,['SPADCHECKELT,'_$,k]) + --this reference must check that slot is a vector + nil + NRTputInHead u + x + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} |