aboutsummaryrefslogtreecommitdiff
path: root/src/interp/nruncomp.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/nruncomp.boot.pamphlet')
-rw-r--r--src/interp/nruncomp.boot.pamphlet769
1 files changed, 0 insertions, 769 deletions
diff --git a/src/interp/nruncomp.boot.pamphlet b/src/interp/nruncomp.boot.pamphlet
deleted file mode 100644
index fbc94289..00000000
--- a/src/interp/nruncomp.boot.pamphlet
+++ /dev/null
@@ -1,769 +0,0 @@
-\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}