From 2de9e63b642be619b8ea6889fb9f78dd31b50675 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sun, 11 Nov 2007 18:33:27 +0000 Subject: remove more pamphlets --- src/interp/nruncomp.boot | 749 ++++++++++++++++++++++++++++++++++++ src/interp/nruncomp.boot.pamphlet | 773 -------------------------------------- src/interp/nrunfast.boot | 650 ++++++++++++++++++++++++++++++++ src/interp/nrunfast.boot.pamphlet | 670 --------------------------------- src/interp/nrungo.boot | 399 ++++++++++++++++++++ src/interp/nrungo.boot.pamphlet | 419 --------------------- src/interp/nruntime.boot | 63 ++++ src/interp/nruntime.boot.pamphlet | 83 ---- 8 files changed, 1861 insertions(+), 1945 deletions(-) create mode 100644 src/interp/nruncomp.boot delete mode 100644 src/interp/nruncomp.boot.pamphlet create mode 100644 src/interp/nrunfast.boot delete mode 100644 src/interp/nrunfast.boot.pamphlet create mode 100644 src/interp/nrungo.boot delete mode 100644 src/interp/nrungo.boot.pamphlet create mode 100644 src/interp/nruntime.boot delete mode 100644 src/interp/nruntime.boot.pamphlet (limited to 'src') diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot new file mode 100644 index 00000000..7fdf8d2b --- /dev/null +++ b/src/interp/nruncomp.boot @@ -0,0 +1,749 @@ +-- 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" +import '"simpbool" +)package "BOOT" + +-----------------------------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 ) +-- 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 ) +-- (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 ( )) +-- (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 + + + diff --git a/src/interp/nruncomp.boot.pamphlet b/src/interp/nruncomp.boot.pamphlet deleted file mode 100644 index 0d8f0986..00000000 --- a/src/interp/nruncomp.boot.pamphlet +++ /dev/null @@ -1,773 +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} - -<>= --- 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. - -@ -<<*>>= -<> - -import '"c-util" -import '"simpbool" -)package "BOOT" - ------------------------------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 ) --- 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 ) --- (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 ( )) --- (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} diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot new file mode 100644 index 00000000..36da8cc4 --- /dev/null +++ b/src/interp/nrunfast.boot @@ -0,0 +1,650 @@ +-- 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" + +--======================================================================= +-- Basic Functions +--======================================================================= +initNewWorld() == + $NRTflag := true + $NRTvec := true + $NRTmakeCompactDirect := true + $NRTquick := true + $NRTmakeShortDirect := true + $newWorld := true + $monitorNewWorld := false + $consistencyCheck := false + $spadLibFT := 'NRLIB + $NRTmonitorIfTrue := false + $updateCatTableIfTrue := false + $doNotCompressHashTableIfTrue := true + +isNewWorldDomain domain == INTEGERP domain.3 --see HasCategory/Attribute + +getDomainByteVector dom == CDDR dom.4 + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +getOpCode(op,vec,max) == +--search Op vector for "op" returning code if found, nil otherwise + res := nil + for i in 0..max by 2 repeat + EQ(QVELT(vec,i),op) => return (res := QSADD1 i) + res + +--======================================================= +-- Lookup From Compiled Code +--======================================================= +newGoGet(:l) == + [:arglist,env] := l + slot := replaceGoGetSlot env + APPLY(first slot,[:arglist,rest slot]) --SPADCALL it! + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +replaceGoGetSlot env == + [thisDomain,index,:op] := env + thisDomainForm := devaluate thisDomain + bytevec := getDomainByteVector thisDomain + numOfArgs := bytevec.index + goGetDomainSlotIndex := bytevec.(index := QSADD1 index) + goGetDomain := + goGetDomainSlotIndex = 0 => thisDomain + thisDomain.goGetDomainSlotIndex + if PAIRP goGetDomain then + goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) + sig := + [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) + for i in 0..numOfArgs] + thisSlot := bytevec.(QSADD1 index) + if $monitorNewWorld then + sayLooking(concat('"%l","..",form2String thisDomainForm, + '" wants",'"%l",'" "),op,sig,goGetDomain) + slot := basicLookup(op,sig,goGetDomain,goGetDomain) + slot = nil => + $returnNowhereFromGoGet = true => + ['nowhere,:goGetDomain] --see newGetDomainOpTable + sayBrightly concat('"Function: ",formatOpSignature(op,sig), + '" is missing from domain: ",form2String goGetDomain.0) + keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) + if $monitorNewWorld then + sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) + SETELT(thisDomain,thisSlot,slot) + if $monitorNewWorld then + sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) + slot + +--======================================================= +-- Lookup Function in Slot 1 (via SPADCALL) +--======================================================= +lookupFF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) + +lookupUF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupInCompactTable(op,sig,dollar,env) == + newLookupInTable(op,sig,dollar,env,true) + +newLookupInTable(op,sig,dollar,[domain,opvec],flag) == + dollar = nil => systemError() + $lookupDefaults = true => + newLookupInCategories(op,sig,domain,dollar) --lookup first in my cats + or newLookupInAddChain(op,sig,domain,dollar) + --fast path when called from newGoGet + success := false + if $monitorNewWorld then + sayLooking(concat('"---->",form2String devaluate domain, + '"----> searching op table for:","%l"," "),op,sig,dollar) + someMatch := false + numvec := getDomainByteVector domain + predvec := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return + flag => newLookupInAddChain(op,sig,domain,dollar) + nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + numArgs := QSDIFFERENCE(#sig,1) + success := nil + $isDefaultingPackage: local := + -- use special defaulting handler when dollar non-trivial + dollar ^= domain and isDefaultPackageForm? devaluate domain + while finish > start repeat + PROGN + i := start + numArgs ^= (numTableArgs :=numvec.i) => nil + predIndex := numvec.(i := QSADD1 i) + NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil + loc := newCompareSig(sig,numvec,(i := QSADD1 i),dollar,domain) + null loc => nil --signifies no match + loc = 1 => (someMatch := true) + loc = 0 => + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + i := start + 2 + someMatch := true --mark so that if subsumption fails, look for original + subsumptionSig := + [newExpandTypeSlot(numvec.(QSPLUS(i,j)), + dollar,domain) for j in 0..numTableArgs] + if $monitorNewWorld then + sayBrightly [formatOpSignature(op,sig),'"--?-->", + formatOpSignature(op,subsumptionSig)] + nil + slot := domain.loc + null atom slot => + EQ(QCAR slot,'newGoGet) => someMatch:=true + --treat as if operation were not there + --if EQ(QCAR slot,'newGoGet) then + -- UNWIND_-PROTECT --break infinite recursion + -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), + -- if domain.loc = 'skip then domain.loc := slot) + return (success := slot) + slot = 'skip => --recursive call from above 'replaceGoGetSlot + return (success := newLookupInAddChain(op,sig,domain,dollar)) + systemError '"unexpected format" + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + NE(success,'failed) and success => + if $monitorNewWorld then + sayLooking1('"<----",uu) where uu() == + PAIRP success => [first success,:devaluate rest success] + success + success + subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u + flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) + nil + + +isDefaultPackageForm? x == x is [op,:.] + and IDENTP op and (s := PNAME op).(MAXINDEX s) = "&" + + +--======================================================= +-- Lookup Addlist (from lookupInDomainTable or lookupInDomain) +--======================================================= +newLookupInAddChain(op,sig,addFormDomain,dollar) == + if $monitorNewWorld then sayLooking1('"looking up add-chain: ",addFormDomain) + addFunction:=newLookupInDomain(op,sig,addFormDomain,dollar,5) + addFunction => + if $monitorNewWorld then + sayLooking1(concat('"<----add-chain function found for ", + form2String devaluate addFormDomain,'"<----"),CDR addFunction) + addFunction + nil + +--======================================================= +-- Lookup In Domain (from lookupInAddChain) +--======================================================= +newLookupInDomain(op,sig,addFormDomain,dollar,index) == + addFormCell := addFormDomain.index => + INTEGERP KAR addFormCell => + or/[newLookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] + if null VECP addFormCell then lazyDomainSet(addFormCell,addFormDomain,index) + lookupInDomainVector(op,sig,addFormDomain.index,dollar) + nil + +--======================================================= +-- Category Default Lookup (from goGet or lookupInAddChain) +--======================================================= +newLookupInCategories(op,sig,dom,dollar) == + slot4 := dom.4 + catVec := CADR slot4 + SIZE catVec = 0 => nil --early exit if no categories + INTEGERP KDR catVec.0 => + newLookupInCategories1(op,sig,dom,dollar) --old style + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + packageVec := QCAR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + for i in 0..MAXINDEX packageVec | + (entry := packageVec.i) and entry ^= 'T repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := catVec.i + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + --VECP infovec => ----new world + true => ----new world + opvec := infovec.1 + max := MAXINDEX opvec + code := getOpCode(op,opvec,max) + null code => nil + byteVector := CDDDR infovec.3 + endPos := + code+2 > max => SIZE byteVector + opvec.(code+2) + not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil + --numOfArgs := byteVector.(opvec.code) + --numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + ----old world + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u | #sig = #x.0]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true then + sayBrightlyNT '" not in: " + pp (packageForm and devaluate package or entry) + nil + if $monitorNewWorld then + sayLooking1('"candidate default package instantiated: ",success) + success + entry + null package => nil + if $monitorNewWorld then + sayLooking1('"Looking at instantiated package ",package) + res := basicLookup(op,sig,package,dollar) => + if $monitorNewWorld = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +nrunNumArgCheck(num,bytevec,start,finish) == + args := bytevec.start + num = args => true + (start := start + args + 4) = finish => nil + nrunNumArgCheck(num,bytevec,start,finish) + +newLookupInCategories1(op,sig,dom,dollar) == + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + slot4 := dom.4 + packageVec := CAR slot4 + catVec := CAR QCDR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + for i in 0..MAXINDEX packageVec | (entry := ELT(packageVec,i)) + and (VECP entry or (predIndex := CDR (node := ELT(catVec,i))) and + (EQ(predIndex,0) or testBitVector(predvec,predIndex))) repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := QCAR node + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + VECP infovec => + opvec := infovec.1 + max := MAXINDEX opvec + code := getOpCode(op,opvec,max) + null code => nil + byteVector := CDDR infovec.3 + numOfArgs := byteVector.(opvec.code) + numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u | #sig = #x.0]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true then + sayBrightlyNT '" not in: " + pp (packageForm and devaluate package or entry) + nil + if $monitorNewWorld then + sayLooking1('"candidate default package instantiated: ",success) + success + entry + null package => nil + if $monitorNewWorld then + sayLooking1('"Looking at instantiated package ",package) + res := lookupInDomainVector(op,sig,package,dollar) => + if $monitorNewWorld = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +--======================================================= +-- Compare Signature to One Derived from Table +--======================================================= +newCompareSig(sig, numvec, index, dollar, domain) == + k := index + null (target := first sig) + or lazyMatchArg(target,numvec.k,dollar,domain) => + and/[lazyMatchArg(s,numvec.(k := i),dollar,domain) + for s in rest sig for i in (index+1)..] => numvec.(QSINC1 k) + nil + nil + +--======================================================= +-- Compare Signature to One Derived from Table +--======================================================= +lazyMatchArg(s,a,dollar,domain) == lazyMatchArg2(s,a,dollar,domain,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lazyMatchArg2(s,a,dollar,domain,typeFlag) == + if s = '$ then +-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup + s := devaluate dollar -- calls from HasCategory can have $s + INTEGERP a => + not typeFlag => s = domain.a + a = 6 and $isDefaultingPackage => s = devaluate dollar + VECP (d := domainVal(dollar,domain,a)) => + s = d.0 => true + domainArg := ($isDefaultingPackage => domain.6.0; domain.0) + KAR s = QCAR d.0 and + lazyMatchArgDollarCheck(replaceSharpCalls s,d.0,dollar.0,domainArg) + --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) + lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style + a = '$ => s = devaluate dollar + a = "$$" => s = devaluate domain + STRINGP a => + STRINGP s => a = s + s is ['QUOTE,y] and PNAME y = a + IDENTP s and PNAME s = a + atom a => a = s + op := opOf a + op = 'NRTEVAL => s = nrtEval(CADR a,domain) + op = 'QUOTE => s = CADR a + lazyMatch(s,a,dollar,domain) + --above line is temporarily necessary until system is compiled 8/15/90 +--s = a + +lazyMatch(source,lazyt,dollar,domain) == + lazyt is [op,:argl] and null atom source and op=CAR source + and #(sargl := CDR source) = #argl => + MEMQ(op,'(Record Union)) and first argl is [":",:.] => + and/[stag = atag and lazyMatchArg(s,a,dollar,domain) + for [.,stag,s] in sargl for [.,atag,a] in argl] + MEMQ(op,'(Union Mapping QUOTE)) => + and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl] + coSig := GETDATABASE(op,'COSIG) + NULL coSig => error ["bad Constructor op", op] + and/[lazyMatchArg2(s,a,dollar,domain,flag) + for s in sargl for a in argl for flag in rest coSig] + STRINGP source and lazyt is ['QUOTE,=source] => true + NUMBERP source => + lazyt is ['_#, slotNum] => source = #(domain.slotNum) + lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum) + nil + source is ['construct,:l] => l = lazyt + -- A hideous hack on the same lines as the previous four lines JHD/MCD + nil + + +lazyMatchArgDollarCheck(s,d,dollarName,domainName) == + #s ^= #d => nil + scoSig := GETDATABASE(opOf s,'COSIG) or return nil + if MEMQ(opOf s, '(Union Mapping Record)) then + scoSig := [true for x in s] + and/[fn for x in rest s for arg in rest d for xt in rest scoSig] where + fn() == + x = arg => true + x is ['elt,someDomain,opname] => lookupInDomainByName(opname,evalDomain someDomain,arg) + x = '$ and (arg = dollarName or arg = domainName) => true + x = dollarName and arg = domainName => true + ATOM x or ATOM arg => false + xt and CAR x = CAR arg => + lazyMatchArgDollarCheck(x,arg,dollarName,domainName) + false + +lookupInDomainByName(op,domain,arg) == + atom arg => nil + opvec := domain . 1 . 2 + numvec := getDomainByteVector domain + predvec := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + success := false + while finish > start repeat + i := start + numberOfArgs :=numvec.i + predIndex := numvec.(i := QSADD1 i) + NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil + slotIndex := numvec.(i + 2 + numberOfArgs) + newStart := QSPLUS(start,QSPLUS(numberOfArgs,4)) + slot := domain.slotIndex + null atom slot and EQ(CAR slot,CAR arg) and EQ(CDR slot,CDR arg) => return (success := true) + start := QSPLUS(start,QSPLUS(numberOfArgs,4)) + success + +--======================================================= +-- Expand Signature from Encoded Slot Form +--======================================================= +newExpandGoGetTypeSlot(slot,dollar,domain) == + newExpandTypeSlot(slot,domain,domain) + +newExpandTypeSlot(slot, dollar, domain) == +--> returns domain form for dollar.slot + newExpandLocalType(sigDomainVal(dollar, domain, slot), dollar,domain) + + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +newExpandLocalType(lazyt,dollar,domain) == + VECP lazyt => lazyt.0 + ATOM lazyt => lazyt + lazyt is [vec,.,:lazyForm] and VECP vec => --old style + newExpandLocalTypeForm(lazyForm,dollar,domain) + newExpandLocalTypeForm(lazyt,dollar,domain) --new style + +newExpandLocalTypeForm([functorName,:argl],dollar,domain) == + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] + for [.,tag,dom] in argl]] + MEMQ(functorName, '(Union Mapping)) => + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] + functorName = 'QUOTE => [functorName,:argl] + coSig := GETDATABASE(functorName,'COSIG) + NULL coSig => error ["bad functorName", functorName] + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) + for a in argl for flag in rest coSig]] + +newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == + u = '$ => u + INTEGERP u => + typeFlag => newExpandTypeSlot(u, dollar,domain) + domain.u + u is ['NRTEVAL,y] => nrtEval(y,domain) + u is ['QUOTE,y] => y + u = "$$" => domain.0 + atom u => u --can be first, rest, etc. + newExpandLocalTypeForm(u,dollar,domain) + +nrtEval(expr,dom) == + $:fluid := dom + eval expr + +domainVal(dollar,domain,index) == +--returns a domain or a lazy slot + index = 0 => dollar + index = 2 => domain + domain.index + +-- ??? This function should be merged into the preceding one. +sigDomainVal(dollar,domain,index) == +--returns a domain or a lazy slot + index = 0 => "$" + index = 2 => domain + domain.index + +--======================================================= +-- Convert Lazy Domain to Domain Form +--======================================================= + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lazyDomainSet(lazyForm,thisDomain,slot) == + form := + lazyForm is [vec,.,:u] and VECP vec => u --old style + lazyForm --new style + slotDomain := evalSlotDomain(form,thisDomain) + if $monitorNewWorld then + sayLooking1(concat(form2String devaluate thisDomain, + '" activating lazy slot ",slot,'": "),slotDomain) + name := CAR form + SETELT(thisDomain,slot,slotDomain) + +--======================================================= +-- HasCategory/Attribute +--======================================================= +-- PLEASE NOTE: This function has the rather charming side-effect that +-- e.g. it works if domform is an Aldor Category. This is being used +-- by extendscategoryForm in c-util to allow Aldor domains to be used +-- in spad code. Please do not break this! An example is the use of +-- Interval (an Aldor domain) by SIGNEF in limitps.spad. MCD. +newHasTest(domform,catOrAtt) == + domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) => + ofCategory(domform, catOrAtt) + catOrAtt = '(Type) => true + GETDATABASE(opOf domform, 'ASHARP?) => fn(domform,catOrAtt) where + -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where + fn(a,b) == + categoryForm?(a) => assoc(b, ancestorsOf(a, nil)) + isPartialMode a => throwKeyedMsg("S2IS0025",NIL) + b is ["SIGNATURE",:opSig] => + HasSignature(evalDomain a,opSig) + b is ["ATTRIBUTE",attr] => HasAttribute(evalDomain a,attr) + hasCaty(a,b,NIL) ^= 'failed + HasCategory(evalDomain a,b) => true -- for asharp domains: must return Boolean + op := opOf catOrAtt + isAtom := atom catOrAtt + null isAtom and op = 'Join => + and/[newHasTest(domform,x) for x in rest catOrAtt] +-- we will refuse to say yes for 'Cat has Cat' +--GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL) +-- on second thoughts we won't! + GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => + domform = catOrAtt => 'T + for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] | aCat = catOrAtt repeat + return evalCond cond where + evalCond x == + ATOM x => x + [pred,:l] := x + pred = 'has => + l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2) + l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1) + newHasTest(first l ,first rest l) + pred = 'OR => or/[evalCond i for i in l] + pred = 'AND => and/[evalCond i for i in l] + x + null isAtom and constructor? op => + domain := eval mkEvalable domform + newHasCategory(domain,catOrAtt) + newHasAttribute(eval mkEvalable domform,catOrAtt) + +lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 + n := MAXINDEX catvec + xop := CAR x + or/[ELT(auxvec,i) for i in 0..n | + xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] + +lazyMatchAssocV1(x,vec,domain) == --old style slot4 + n := MAXINDEX vec + xop := CAR x + or/[QCDR QVELT(vec,i) for i in 0..n | + xop = CAR (lazyt := CAR QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)] + +--newHasAttribute(domain,attrib) == +-- predIndex := LASSOC(attrib,domain.2) => +-- EQ(predIndex,0) => true +-- predvec := domain.3 +-- testBitVector(predvec,predIndex) +-- false + +--======================================================= +-- Utility Functions +--======================================================= + +sayLooking(prefix,op,sig,dom) == + $monitorNewWorld := false + dollar := devaluate dom + atom dollar or VECP dollar or "or"/[VECP x for x in dollar] => systemError nil + sayBrightly + concat(prefix,formatOpSignature(op,sig),bright '"from ",form2String dollar) + $monitorNewWorld := true + +sayLooking1(prefix,dom) == + $monitorNewWorld := false + dollar := + VECP dom => devaluate dom + devaluateList dom + sayBrightly concat(prefix,form2String dollar) + $monitorNewWorld := true + +cc() == -- don't remove this function + clearConstructorCaches() + clearClams() diff --git a/src/interp/nrunfast.boot.pamphlet b/src/interp/nrunfast.boot.pamphlet deleted file mode 100644 index 5f914bd7..00000000 --- a/src/interp/nrunfast.boot.pamphlet +++ /dev/null @@ -1,670 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nrunfast.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -import '"c-util" -)package "BOOT" - ---======================================================================= --- Basic Functions ---======================================================================= -initNewWorld() == - $NRTflag := true - $NRTvec := true - $NRTmakeCompactDirect := true - $NRTquick := true - $NRTmakeShortDirect := true - $newWorld := true - $monitorNewWorld := false - $consistencyCheck := false - $spadLibFT := 'NRLIB - $NRTmonitorIfTrue := false - $updateCatTableIfTrue := false - $doNotCompressHashTableIfTrue := true - -isNewWorldDomain domain == INTEGERP domain.3 --see HasCategory/Attribute - -getDomainByteVector dom == CDDR dom.4 - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -getOpCode(op,vec,max) == ---search Op vector for "op" returning code if found, nil otherwise - res := nil - for i in 0..max by 2 repeat - EQ(QVELT(vec,i),op) => return (res := QSADD1 i) - res - ---======================================================= --- Lookup From Compiled Code ---======================================================= -newGoGet(:l) == - [:arglist,env] := l - slot := replaceGoGetSlot env - APPLY(first slot,[:arglist,rest slot]) --SPADCALL it! - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -replaceGoGetSlot env == - [thisDomain,index,:op] := env - thisDomainForm := devaluate thisDomain - bytevec := getDomainByteVector thisDomain - numOfArgs := bytevec.index - goGetDomainSlotIndex := bytevec.(index := QSADD1 index) - goGetDomain := - goGetDomainSlotIndex = 0 => thisDomain - thisDomain.goGetDomainSlotIndex - if PAIRP goGetDomain then - goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) - sig := - [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) - for i in 0..numOfArgs] - thisSlot := bytevec.(QSADD1 index) - if $monitorNewWorld then - sayLooking(concat('"%l","..",form2String thisDomainForm, - '" wants",'"%l",'" "),op,sig,goGetDomain) - slot := basicLookup(op,sig,goGetDomain,goGetDomain) - slot = nil => - $returnNowhereFromGoGet = true => - ['nowhere,:goGetDomain] --see newGetDomainOpTable - sayBrightly concat('"Function: ",formatOpSignature(op,sig), - '" is missing from domain: ",form2String goGetDomain.0) - keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) - if $monitorNewWorld then - sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) - SETELT(thisDomain,thisSlot,slot) - if $monitorNewWorld then - sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) - slot - ---======================================================= --- Lookup Function in Slot 1 (via SPADCALL) ---======================================================= -lookupFF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) - -lookupUF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupInCompactTable(op,sig,dollar,env) == - newLookupInTable(op,sig,dollar,env,true) - -newLookupInTable(op,sig,dollar,[domain,opvec],flag) == - dollar = nil => systemError() - $lookupDefaults = true => - newLookupInCategories(op,sig,domain,dollar) --lookup first in my cats - or newLookupInAddChain(op,sig,domain,dollar) - --fast path when called from newGoGet - success := false - if $monitorNewWorld then - sayLooking(concat('"---->",form2String devaluate domain, - '"----> searching op table for:","%l"," "),op,sig,dollar) - someMatch := false - numvec := getDomainByteVector domain - predvec := domain.3 - max := MAXINDEX opvec - k := getOpCode(op,opvec,max) or return - flag => newLookupInAddChain(op,sig,domain,dollar) - nil - maxIndex := MAXINDEX numvec - start := ELT(opvec,k) - finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) - maxIndex - if QSGREATERP(finish,maxIndex) then systemError '"limit too large" - numArgs := QSDIFFERENCE(#sig,1) - success := nil - $isDefaultingPackage: local := - -- use special defaulting handler when dollar non-trivial - dollar ^= domain and isDefaultPackageForm? devaluate domain - while finish > start repeat - PROGN - i := start - numArgs ^= (numTableArgs :=numvec.i) => nil - predIndex := numvec.(i := QSADD1 i) - NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil - loc := newCompareSig(sig,numvec,(i := QSADD1 i),dollar,domain) - null loc => nil --signifies no match - loc = 1 => (someMatch := true) - loc = 0 => - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - i := start + 2 - someMatch := true --mark so that if subsumption fails, look for original - subsumptionSig := - [newExpandTypeSlot(numvec.(QSPLUS(i,j)), - dollar,domain) for j in 0..numTableArgs] - if $monitorNewWorld then - sayBrightly [formatOpSignature(op,sig),'"--?-->", - formatOpSignature(op,subsumptionSig)] - nil - slot := domain.loc - null atom slot => - EQ(QCAR slot,'newGoGet) => someMatch:=true - --treat as if operation were not there - --if EQ(QCAR slot,'newGoGet) then - -- UNWIND_-PROTECT --break infinite recursion - -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), - -- if domain.loc = 'skip then domain.loc := slot) - return (success := slot) - slot = 'skip => --recursive call from above 'replaceGoGetSlot - return (success := newLookupInAddChain(op,sig,domain,dollar)) - systemError '"unexpected format" - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - NE(success,'failed) and success => - if $monitorNewWorld then - sayLooking1('"<----",uu) where uu() == - PAIRP success => [first success,:devaluate rest success] - success - success - subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u - flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) - nil - - -isDefaultPackageForm? x == x is [op,:.] - and IDENTP op and (s := PNAME op).(MAXINDEX s) = "&" - - ---======================================================= --- Lookup Addlist (from lookupInDomainTable or lookupInDomain) ---======================================================= -newLookupInAddChain(op,sig,addFormDomain,dollar) == - if $monitorNewWorld then sayLooking1('"looking up add-chain: ",addFormDomain) - addFunction:=newLookupInDomain(op,sig,addFormDomain,dollar,5) - addFunction => - if $monitorNewWorld then - sayLooking1(concat('"<----add-chain function found for ", - form2String devaluate addFormDomain,'"<----"),CDR addFunction) - addFunction - nil - ---======================================================= --- Lookup In Domain (from lookupInAddChain) ---======================================================= -newLookupInDomain(op,sig,addFormDomain,dollar,index) == - addFormCell := addFormDomain.index => - INTEGERP KAR addFormCell => - or/[newLookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] - if null VECP addFormCell then lazyDomainSet(addFormCell,addFormDomain,index) - lookupInDomainVector(op,sig,addFormDomain.index,dollar) - nil - ---======================================================= --- Category Default Lookup (from goGet or lookupInAddChain) ---======================================================= -newLookupInCategories(op,sig,dom,dollar) == - slot4 := dom.4 - catVec := CADR slot4 - SIZE catVec = 0 => nil --early exit if no categories - INTEGERP KDR catVec.0 => - newLookupInCategories1(op,sig,dom,dollar) --old style - $lookupDefaults : local := nil - if $monitorNewWorld = true then sayBrightly concat('"----->", - form2String devaluate dom,'"-----> searching default packages for ",op) - predvec := dom.3 - packageVec := QCAR slot4 ---the next three lines can go away with new category world - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - for i in 0..MAXINDEX packageVec | - (entry := packageVec.i) and entry ^= 'T repeat - package := - VECP entry => - if $monitorNewWorld then - sayLooking1('"already instantiated cat package",entry) - entry - IDENTP entry => - cat := catVec.i - packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) - success := - --VECP infovec => ----new world - true => ----new world - opvec := infovec.1 - max := MAXINDEX opvec - code := getOpCode(op,opvec,max) - null code => nil - byteVector := CDDDR infovec.3 - endPos := - code+2 > max => SIZE byteVector - opvec.(code+2) - not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil - --numOfArgs := byteVector.(opvec.code) - --numOfArgs ^= #(QCDR sig) => nil - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - ----old world - table := HGET($Slot1DataBase,entry) or systemError nil - (u := LASSQ(op,table)) - and (v := or/[rest x for x in u | #sig = #x.0]) => - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - nil - null success => - if $monitorNewWorld = true then - sayBrightlyNT '" not in: " - pp (packageForm and devaluate package or entry) - nil - if $monitorNewWorld then - sayLooking1('"candidate default package instantiated: ",success) - success - entry - null package => nil - if $monitorNewWorld then - sayLooking1('"Looking at instantiated package ",package) - res := basicLookup(op,sig,package,dollar) => - if $monitorNewWorld = true then - sayBrightly '"candidate default package succeeds" - return res - if $monitorNewWorld = true then - sayBrightly '"candidate fails -- continuing to search categories" - nil - -nrunNumArgCheck(num,bytevec,start,finish) == - args := bytevec.start - num = args => true - (start := start + args + 4) = finish => nil - nrunNumArgCheck(num,bytevec,start,finish) - -newLookupInCategories1(op,sig,dom,dollar) == - $lookupDefaults : local := nil - if $monitorNewWorld = true then sayBrightly concat('"----->", - form2String devaluate dom,'"-----> searching default packages for ",op) - predvec := dom.3 - slot4 := dom.4 - packageVec := CAR slot4 - catVec := CAR QCDR slot4 ---the next three lines can go away with new category world - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - for i in 0..MAXINDEX packageVec | (entry := ELT(packageVec,i)) - and (VECP entry or (predIndex := CDR (node := ELT(catVec,i))) and - (EQ(predIndex,0) or testBitVector(predvec,predIndex))) repeat - package := - VECP entry => - if $monitorNewWorld then - sayLooking1('"already instantiated cat package",entry) - entry - IDENTP entry => - cat := QCAR node - packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) - success := - VECP infovec => - opvec := infovec.1 - max := MAXINDEX opvec - code := getOpCode(op,opvec,max) - null code => nil - byteVector := CDDR infovec.3 - numOfArgs := byteVector.(opvec.code) - numOfArgs ^= #(QCDR sig) => nil - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - table := HGET($Slot1DataBase,entry) or systemError nil - (u := LASSQ(op,table)) - and (v := or/[rest x for x in u | #sig = #x.0]) => - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - nil - null success => - if $monitorNewWorld = true then - sayBrightlyNT '" not in: " - pp (packageForm and devaluate package or entry) - nil - if $monitorNewWorld then - sayLooking1('"candidate default package instantiated: ",success) - success - entry - null package => nil - if $monitorNewWorld then - sayLooking1('"Looking at instantiated package ",package) - res := lookupInDomainVector(op,sig,package,dollar) => - if $monitorNewWorld = true then - sayBrightly '"candidate default package succeeds" - return res - if $monitorNewWorld = true then - sayBrightly '"candidate fails -- continuing to search categories" - nil - ---======================================================= --- Compare Signature to One Derived from Table ---======================================================= -newCompareSig(sig, numvec, index, dollar, domain) == - k := index - null (target := first sig) - or lazyMatchArg(target,numvec.k,dollar,domain) => - and/[lazyMatchArg(s,numvec.(k := i),dollar,domain) - for s in rest sig for i in (index+1)..] => numvec.(QSINC1 k) - nil - nil - ---======================================================= --- Compare Signature to One Derived from Table ---======================================================= -lazyMatchArg(s,a,dollar,domain) == lazyMatchArg2(s,a,dollar,domain,true) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lazyMatchArg2(s,a,dollar,domain,typeFlag) == - if s = '$ then --- a = 0 => return true --needed only if extra call in newGoGet to basicLookup - s := devaluate dollar -- calls from HasCategory can have $s - INTEGERP a => - not typeFlag => s = domain.a - a = 6 and $isDefaultingPackage => s = devaluate dollar - VECP (d := domainVal(dollar,domain,a)) => - s = d.0 => true - domainArg := ($isDefaultingPackage => domain.6.0; domain.0) - KAR s = QCAR d.0 and - lazyMatchArgDollarCheck(replaceSharpCalls s,d.0,dollar.0,domainArg) - --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) - lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style - a = '$ => s = devaluate dollar - a = "$$" => s = devaluate domain - STRINGP a => - STRINGP s => a = s - s is ['QUOTE,y] and PNAME y = a - IDENTP s and PNAME s = a - atom a => a = s - op := opOf a - op = 'NRTEVAL => s = nrtEval(CADR a,domain) - op = 'QUOTE => s = CADR a - lazyMatch(s,a,dollar,domain) - --above line is temporarily necessary until system is compiled 8/15/90 ---s = a - -lazyMatch(source,lazyt,dollar,domain) == - lazyt is [op,:argl] and null atom source and op=CAR source - and #(sargl := CDR source) = #argl => - MEMQ(op,'(Record Union)) and first argl is [":",:.] => - and/[stag = atag and lazyMatchArg(s,a,dollar,domain) - for [.,stag,s] in sargl for [.,atag,a] in argl] - MEMQ(op,'(Union Mapping QUOTE)) => - and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl] - coSig := GETDATABASE(op,'COSIG) - NULL coSig => error ["bad Constructor op", op] - and/[lazyMatchArg2(s,a,dollar,domain,flag) - for s in sargl for a in argl for flag in rest coSig] - STRINGP source and lazyt is ['QUOTE,=source] => true - NUMBERP source => - lazyt is ['_#, slotNum] => source = #(domain.slotNum) - lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum) - nil - source is ['construct,:l] => l = lazyt - -- A hideous hack on the same lines as the previous four lines JHD/MCD - nil - - -lazyMatchArgDollarCheck(s,d,dollarName,domainName) == - #s ^= #d => nil - scoSig := GETDATABASE(opOf s,'COSIG) or return nil - if MEMQ(opOf s, '(Union Mapping Record)) then - scoSig := [true for x in s] - and/[fn for x in rest s for arg in rest d for xt in rest scoSig] where - fn() == - x = arg => true - x is ['elt,someDomain,opname] => lookupInDomainByName(opname,evalDomain someDomain,arg) - x = '$ and (arg = dollarName or arg = domainName) => true - x = dollarName and arg = domainName => true - ATOM x or ATOM arg => false - xt and CAR x = CAR arg => - lazyMatchArgDollarCheck(x,arg,dollarName,domainName) - false - -lookupInDomainByName(op,domain,arg) == - atom arg => nil - opvec := domain . 1 . 2 - numvec := getDomainByteVector domain - predvec := domain.3 - max := MAXINDEX opvec - k := getOpCode(op,opvec,max) or return nil - maxIndex := MAXINDEX numvec - start := ELT(opvec,k) - finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) - maxIndex - if QSGREATERP(finish,maxIndex) then systemError '"limit too large" - success := false - while finish > start repeat - i := start - numberOfArgs :=numvec.i - predIndex := numvec.(i := QSADD1 i) - NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil - slotIndex := numvec.(i + 2 + numberOfArgs) - newStart := QSPLUS(start,QSPLUS(numberOfArgs,4)) - slot := domain.slotIndex - null atom slot and EQ(CAR slot,CAR arg) and EQ(CDR slot,CDR arg) => return (success := true) - start := QSPLUS(start,QSPLUS(numberOfArgs,4)) - success - ---======================================================= --- Expand Signature from Encoded Slot Form ---======================================================= -newExpandGoGetTypeSlot(slot,dollar,domain) == - newExpandTypeSlot(slot,domain,domain) - -newExpandTypeSlot(slot, dollar, domain) == ---> returns domain form for dollar.slot - newExpandLocalType(sigDomainVal(dollar, domain, slot), dollar,domain) - - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -newExpandLocalType(lazyt,dollar,domain) == - VECP lazyt => lazyt.0 - ATOM lazyt => lazyt - lazyt is [vec,.,:lazyForm] and VECP vec => --old style - newExpandLocalTypeForm(lazyForm,dollar,domain) - newExpandLocalTypeForm(lazyt,dollar,domain) --new style - -newExpandLocalTypeForm([functorName,:argl],dollar,domain) == - MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => - [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] - for [.,tag,dom] in argl]] - MEMQ(functorName, '(Union Mapping)) => - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] - functorName = 'QUOTE => [functorName,:argl] - coSig := GETDATABASE(functorName,'COSIG) - NULL coSig => error ["bad functorName", functorName] - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) - for a in argl for flag in rest coSig]] - -newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == - u = '$ => u - INTEGERP u => - typeFlag => newExpandTypeSlot(u, dollar,domain) - domain.u - u is ['NRTEVAL,y] => nrtEval(y,domain) - u is ['QUOTE,y] => y - u = "$$" => domain.0 - atom u => u --can be first, rest, etc. - newExpandLocalTypeForm(u,dollar,domain) - -nrtEval(expr,dom) == - $:fluid := dom - eval expr - -domainVal(dollar,domain,index) == ---returns a domain or a lazy slot - index = 0 => dollar - index = 2 => domain - domain.index - --- ??? This function should be merged into the preceding one. -sigDomainVal(dollar,domain,index) == ---returns a domain or a lazy slot - index = 0 => "$" - index = 2 => domain - domain.index - ---======================================================= --- Convert Lazy Domain to Domain Form ---======================================================= - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lazyDomainSet(lazyForm,thisDomain,slot) == - form := - lazyForm is [vec,.,:u] and VECP vec => u --old style - lazyForm --new style - slotDomain := evalSlotDomain(form,thisDomain) - if $monitorNewWorld then - sayLooking1(concat(form2String devaluate thisDomain, - '" activating lazy slot ",slot,'": "),slotDomain) - name := CAR form - SETELT(thisDomain,slot,slotDomain) - ---======================================================= --- HasCategory/Attribute ---======================================================= --- PLEASE NOTE: This function has the rather charming side-effect that --- e.g. it works if domform is an Aldor Category. This is being used --- by extendscategoryForm in c-util to allow Aldor domains to be used --- in spad code. Please do not break this! An example is the use of --- Interval (an Aldor domain) by SIGNEF in limitps.spad. MCD. -newHasTest(domform,catOrAtt) == - domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) => - ofCategory(domform, catOrAtt) - catOrAtt = '(Type) => true - GETDATABASE(opOf domform, 'ASHARP?) => fn(domform,catOrAtt) where - -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where - fn(a,b) == - categoryForm?(a) => assoc(b, ancestorsOf(a, nil)) - isPartialMode a => throwKeyedMsg("S2IS0025",NIL) - b is ["SIGNATURE",:opSig] => - HasSignature(evalDomain a,opSig) - b is ["ATTRIBUTE",attr] => HasAttribute(evalDomain a,attr) - hasCaty(a,b,NIL) ^= 'failed - HasCategory(evalDomain a,b) => true -- for asharp domains: must return Boolean - op := opOf catOrAtt - isAtom := atom catOrAtt - null isAtom and op = 'Join => - and/[newHasTest(domform,x) for x in rest catOrAtt] --- we will refuse to say yes for 'Cat has Cat' ---GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL) --- on second thoughts we won't! - GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => - domform = catOrAtt => 'T - for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] | aCat = catOrAtt repeat - return evalCond cond where - evalCond x == - ATOM x => x - [pred,:l] := x - pred = 'has => - l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2) - l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1) - newHasTest(first l ,first rest l) - pred = 'OR => or/[evalCond i for i in l] - pred = 'AND => and/[evalCond i for i in l] - x - null isAtom and constructor? op => - domain := eval mkEvalable domform - newHasCategory(domain,catOrAtt) - newHasAttribute(eval mkEvalable domform,catOrAtt) - -lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 - n := MAXINDEX catvec - xop := CAR x - or/[ELT(auxvec,i) for i in 0..n | - xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] - -lazyMatchAssocV1(x,vec,domain) == --old style slot4 - n := MAXINDEX vec - xop := CAR x - or/[QCDR QVELT(vec,i) for i in 0..n | - xop = CAR (lazyt := CAR QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)] - ---newHasAttribute(domain,attrib) == --- predIndex := LASSOC(attrib,domain.2) => --- EQ(predIndex,0) => true --- predvec := domain.3 --- testBitVector(predvec,predIndex) --- false - ---======================================================= --- Utility Functions ---======================================================= - -sayLooking(prefix,op,sig,dom) == - $monitorNewWorld := false - dollar := devaluate dom - atom dollar or VECP dollar or "or"/[VECP x for x in dollar] => systemError nil - sayBrightly - concat(prefix,formatOpSignature(op,sig),bright '"from ",form2String dollar) - $monitorNewWorld := true - -sayLooking1(prefix,dom) == - $monitorNewWorld := false - dollar := - VECP dom => devaluate dom - devaluateList dom - sayBrightly concat(prefix,form2String dollar) - $monitorNewWorld := true - -cc() == -- don't remove this function - clearConstructorCaches() - clearClams() -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot new file mode 100644 index 00000000..229ad785 --- /dev/null +++ b/src/interp/nrungo.boot @@ -0,0 +1,399 @@ +-- 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" + +--======================================================= +-- Lookup From Interpreter +--======================================================= + +NRTevalDomain form == + form is ['SETELT,:.] => eval form + evalDomain form + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +compiledLookup(op,sig,dollar) == +--called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, +-- getFunctionFromDomain, optDeltaEntry, retractByFunction + if not VECP dollar then dollar := NRTevalDomain dollar + basicLookup(op,sig,dollar,dollar) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +basicLookup(op,sig,domain,dollar) == + domain.1 is ['lookupInDomain,:.] => lookupInDomainVector(op,sig,domain,dollar) + ----------new world code follows------------ + $lookupDefaults : local := nil -- new world + u := lookupInDomainVector(op,sig,domain,dollar) => u + $lookupDefaults := true + lookupInDomainVector(op,sig,domain,dollar) + +compiledLookupCheck(op,sig,dollar) == + fn := compiledLookup(op,sig,dollar) + + -- NEW COMPILER COMPATIBILITY ON + + if (fn = nil) and (op = "^") then + fn := compiledLookup("**",sig,dollar) + else if (fn = nil) and (op = "**") then + fn := compiledLookup("^",sig,dollar) + + -- NEW COMPILER COMPATIBILITY OFF + + fn = nil => + keyedSystemError("S2NR0001",[op,formatSignature sig,dollar.0]) + fn + +--======================================================= +-- Lookup From Compiled Code +--======================================================= +goGet(:l) == + [:arglist,env] := l + arglist is ['goGet,:.] => stop() + [[.,[op,initSig,:code]],thisDomain] := env + domainSlot := QSQUOTIENT(code,8192) + code1 := QSREMAINDER(code,8192) + if QSODDP code1 then isConstant := true + code2 := QSQUOTIENT(code1,2) + if QSODDP code2 then explicitLookupDomainIfTrue := true + index := QSQUOTIENT(code2,2) + kind := (isConstant = true => 'CONST; 'ELT) + sig := [NRTreplaceLocalTypes(s,thisDomain) for s in initSig] + sig := substDomainArgs(thisDomain,sig) + lookupDomain := + domainSlot = 0 => thisDomain + thisDomain.domainSlot -- where we look for the operation + if PAIRP lookupDomain then lookupDomain := NRTevalDomain lookupDomain + dollar := -- what matches $ in signatures + explicitLookupDomainIfTrue => lookupDomain + thisDomain + if PAIRP dollar then dollar := NRTevalDomain dollar + fn:= basicLookup(op,sig,lookupDomain,dollar) + fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0]) + val:= APPLY(first fn,[:arglist,rest fn]) + SETELT(thisDomain,index,fn) + val + +NRTreplaceLocalTypes(t,dom) == + atom t => + not INTEGERP t => t + t:= dom.t + if PAIRP t then t:= NRTevalDomain t + t.0 + MEMQ(CAR t,'(Mapping Union Record _:)) => + [CAR t,:[NRTreplaceLocalTypes(x,dom) for x in rest t]] + t + +substDomainArgs(domain,object) == + form := devaluate domain + SUBLISLIS([form,:rest form],["$$",:$FormalMapVariableList],object) + +--======================================================= +-- Lookup Function in Slot 1 (via SPADCALL) +--======================================================= +domainTableLookup(op,sig,dollar,env) == lookupInTable(op,sig,dollar,env) +lookupInTable(op,sig,dollar,[domain,table]) == + EQ(table,'derived) => lookupInAddChain(op,sig,domain,dollar) + success := false + someMatch := false + while not success for [sig1,:code] in LASSQ(op,table) repeat + success := + null compareSig(sig,sig1,dollar.0,domain) => false + code is ['subsumed,a] => + subsumptionSig := + EQSUBSTLIST(rest(domain.0),$FormalMapVariableList,a) + someMatch:=true + false + predIndex := QSQUOTIENT(code,8192) + predIndex ^= 0 and null lookupPred($predVector.predIndex,dollar,domain) + => false + loc := QSQUOTIENT(QSREMAINDER(code,8192),2) + loc = 0 => + someMatch := true + nil + slot := domain.loc + EQCAR(slot,'goGet) => + lookupDisplay(op,sig,domain,'" !! goGet found, will ignore") + lookupInAddChain(op,sig,domain,dollar) or 'failed + NULL slot => + lookupDisplay(op,sig,domain,'" !! null slot entry, continuing") + lookupInAddChain(op,sig,domain,dollar) or 'failed + lookupDisplay(op,sig,domain,'" !! found in NEW table!!") + slot + NE(success,'failed) and success => success + subsumptionSig and (u:= SPADCALL(op,subsumptionSig,dollar,domain.1)) => u + someMatch => lookupInAddChain(op,sig,domain,dollar) + nil + +--======================================================= +-- Lookup Addlist (from lookupInDomainTable or lookupInDomain) +--======================================================= +lookupInAddChain(op,sig,addFormDomain,dollar) == + addFunction:=lookupInDomain(op,sig,addFormDomain,dollar,5) + defaultingFunction addFunction => + lookupInCategories(op,sig,addFormDomain,dollar) or addFunction + addFunction or lookupInCategories(op,sig,addFormDomain,dollar) + + +defaultingFunction op == + not(op is [.,:dom]) => false + not VECP dom => false + not (#dom > 0) => false + not (dom.0 is [packageName,:.]) => false + not IDENTP packageName => false + pname := PNAME packageName + pname.(MAXINDEX pname) = char "&" + +--======================================================= +-- Lookup In Domain (from lookupInAddChain) +--======================================================= +lookupInDomain(op,sig,addFormDomain,dollar,index) == + addFormCell := addFormDomain.index => + INTEGERP KAR addFormCell => + or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] + if null VECP addFormCell then addFormCell := eval addFormCell + lookupInDomainVector(op,sig,addFormCell,dollar) + nil + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupInDomainVector(op,sig,domain,dollar) == + slot1 := domain.1 + SPADCALL(op,sig,dollar,slot1) + +--======================================================= +-- Category Default Lookup (from goGet or lookupInAddChain) +--======================================================= +lookupInCategories(op,sig,dom,dollar) == + catformList := dom.4.0 + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + r := or/[lookupInDomainVector(op,nsig, + eval EQSUBSTLIST(valueList,varList,catform),dollar) + for catform in catformList | pred] where pred() == + (table := HGET($Slot1DataBase,first catform)) and + (u := LASSQ(op,table)) --compare without checking predicates + and (v := or/[rest x for x in u | #sig = #x.0]) + -- following lines commented out because compareSig needs domain + -- and (v := or/[rest x for x in u | + -- compareSig(sig,x.0,dollar.0, catform)]) + r or lookupDisplay(op,sig,'"category defaults",'"-- not found") + +--======================================================= +-- Predicates +--======================================================= +lookupPred(pred,dollar,domain) == + pred = true => true + pred = 'asserted => false + pred is ['AND,:pl] or pred is ['and,:pl] => + and/[lookupPred(p,dollar,domain) for p in pl] + pred is ['OR,:pl] or pred is ['or,:pl] => + or/[lookupPred(p,dollar,domain) for p in pl] + pred is ['NOT,p] or pred is ['not,p] => not lookupPred(p,dollar,domain) + pred is ['is,dom1,dom2] => domainEqual(dom1,dom2) + pred is ['has,a,b] => + VECP a => + keyedSystemError("S2GE0016",['"lookupPred", + '"vector as first argument to has"]) + a := eval mkEvalable substDollarArgs(dollar,domain,a) + b := substDollarArgs(dollar,domain,b) + HasCategory(a,b) + keyedSystemError("S2NR0002",[pred]) + +substDollarArgs(dollar,domain,object) == + form := devaluate domain + SUBLISLIS([devaluate dollar,:rest form], + ["$",:$FormalMapVariableList],object) + +compareSig(sig,tableSig,dollar,domain) == + not (#sig = #tableSig) => false + null (target := first sig) + or lazyCompareSigEqual(target,first tableSig,dollar,domain) => + and/[lazyCompareSigEqual(s,t,dollar,domain) + for s in rest sig for t in rest tableSig] + +lazyCompareSigEqual(s,tslot,dollar,domain) == + tslot = '$ => s = tslot -- devaluate dollar --needed for browser + INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => + lazyt is [.,.,.,[.,item,.]] and + item is [.,[functorName,:.]] and functorName = CAR s => + compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) + nil + compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) + + +compareSigEqual(s,t,dollar,domain) == + EQUAL(s,t) => true + ATOM t => + u := + EQ(t,'$) => dollar + isSharpVar t => + VECP domain => ELT(rest domain.0,POSN1(t,$FormalMapVariableList)) + ELT(rest domain,POSN1(t,$FormalMapVariableList)) + STRINGP t and IDENTP s => (s := PNAME s; t) + nil + s = '$ => compareSigEqual(dollar,u,dollar,domain) + u => compareSigEqual(s,u,dollar,domain) + EQUAL(s,u) + EQ(s,'$) => compareSigEqual(dollar,t,dollar,domain) + ATOM s => nil + #s ^= #t => nil + match := true + for u in s for v in t repeat + not compareSigEqual(u,v,dollar,domain) => return(match:=false) + match + +-----------------------Compiler for Interpreter--------------------------------- +NRTcompileEvalForm(opName,sigTail,dcVector) == + u := NRTcompiledLookup(opName,sigTail,dcVector) + not ($insideCompileBodyIfTrue = true) => MKQ u + k := NRTgetMinivectorIndex(u,opName,sigTail,dcVector) + ['ELT,"$$$",k] --$$$ denotes minivector + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +NRTcompiledLookup(op,sig,dom) == + if CONTAINED('_#,sig) then + sig := [NRTtypeHack t for t in sig] + compiledLookupCheck(op,sig,dom) + +NRTtypeHack t == + ATOM t => t + CAR t = '_# => # CADR t + [CAR t,:[NRTtypeHack tt for tt in CDR t]] + +NRTgetMinivectorIndex(u,op,sig,domVector) == + s := # $minivector + k := or/[k for k in 0..(s-1) + for x in $minivector | EQ(x,u)] => k + $minivector := [:$minivector,u] + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,[op,sig,devaluate domVector]] +-- pp '"-- minivectorCode -->" +-- pp $minivectorCode + s + +NRTisRecurrenceRelation(op,body,minivectorName) == + -- returns [body p1 p2 ... pk] for a k-term recurrence relation + -- where the n-th term is computed using the (n-1)st,...,(n-k)th + -- whose values are initially computed using the expressions + -- p1,...,pk respectively; body has #2,#3,... in place of + -- f(k-1),f(k-2),... + + body isnt ['COND,:pcl] => false + -- body should have a conditional expression which + -- gives k boundary values, one general term plus possibly an + -- "out of domain" condition +--pcl is [:.,[ ''T,:mess]] and not (CONTAINED('throwMessage,mess) or +-- CONTAINED('throwKeyedMsg,mess)) => NIL + pcl := [x for x in pcl | not (x is [''T,:mess] and + (CONTAINED('throwMessage,mess) or + CONTAINED('throwKeyedMsg,mess)))] + integer := EVALFUN $Integer + iequalSlot:=compiledLookupCheck("=",'((Boolean) $ $),integer) + lesspSlot:=compiledLookupCheck("<",'((Boolean) $ $),integer) + bf := '(Boolean) + notpSlot:= compiledLookupCheck("not",'((Boolean)(Boolean)),EVALFUN bf) + for [p,c] in pcl repeat + p is ['SPADCALL,sharpVar,n1,['ELT,=minivectorName,slot]] + and EQ(iequalSlot,$minivector.slot) => + initList:= [[n1,:c],:initList] + sharpList := insert(sharpVar,sharpList) + n:=n1 + miscList:= [[p,c],:miscList] + miscList isnt [[generalPred,generalTerm]] or sharpList isnt [sharpArg] => + return false + --first general term starts at n + + --Must have at least one special value; insist that they be consecutive + null initList => false + specialValues:= MSORT ASSOCLEFT initList + or/[null INTEGERP n for n in specialValues] => false + minIndex:= "MIN"/specialValues + not (and/[i=x for i in minIndex..(minIndex+n-1) for x in specialValues]) => + sayKeyedMsg("S2IX0005", + ["append"/[['" ",sv] for sv in specialValues]]) + return nil + + --Determine the order k of the recurrence and index n of first general term + k:= #specialValues + n:= k+minIndex + --Check general predicate + predOk := + generalPred is '(QUOTE T) => true + generalPred is ['SPADCALL,m,=sharpArg,['ELT,=minivectorName,slot]] + and EQ(lesspSlot,$minivector.slot)=> m+1 + generalPred is ['SPADCALL,['SPADCALL,=sharpArg,m, + ['ELT,=minivectorName,slot]], ['ELT,=minivectorName,notSlot]] + and EQ(lesspSlot,$minivector.slot) + and EQ(notpSlot,$minivector.notSlot) => m + generalPred is ['NOT,['SPADCALL,=sharpArg,m,['ELT,=minivectorName, =lesspSlot]]] + and EQ(lesspSlot,$minivector.slot) => m + return nil + INTEGERP predOk and predOk ^= n => + sayKeyedMsg("S2IX0006",[n,m]) + return nil + + --Check general term for references to just the k previous values + diffCell:=compiledLookupCheck("-",'($ $ $),integer) + diffSlot := or/[i for i in 0.. for x in $minivector | EQ(x,diffCell)] + or return nil + --Check general term for references to just the k previous values + sharpPosition := PARSE_-INTEGER SUBSTRING(sharpArg,1,nil) + al:= mkDiffAssoc(op,generalTerm,k,sharpPosition,sharpArg,diffSlot,minivectorName) + null al => false + '$failed in al => false + body:= generalTerm + for [a,:b] in al repeat + body:= substitute(b,a,body) + result:= [body,sharpArg,n-1,:NREVERSE [LASSOC(i,initList) or + systemErrorHere('"NRTisRecurrenceRelation") + for i in minIndex..(n-1)]] + +mkDiffAssoc(op,body,k,sharpPosition,sharpArg,diffSlot,vecname) == + -- returns alist which should not have any entries = $failed + -- form substitution list of the form: + -- ( ((f (,DIFFERENCE #1 1)) . #2) ((f (,DIFFERENCE #1 2)) . #3) ...) + -- but also checking that all difference values lie in 1..k + atom body => nil + body is ['COND,:pl] => + "union"/[mkDiffAssoc(op,c,k,sharpPosition,sharpArg,diffSlot,vecname) for [p,c] in pl] + body is [fn,:argl] => + (fn = op) and argl.(sharpPosition-1) is + ['SPADCALL,=sharpArg,n,['ELT,=vecname,=diffSlot]] => + NUMP n and n > 0 and n <= k => + [[body,:$TriangleVariableList.n]] + ['$failed] + "union"/[mkDiffAssoc(op,x,k,sharpPosition,sharpArg,diffSlot,vecname) for x in argl] + systemErrorHere '"mkDiffAssoc" diff --git a/src/interp/nrungo.boot.pamphlet b/src/interp/nrungo.boot.pamphlet deleted file mode 100644 index 96f7aaa0..00000000 --- a/src/interp/nrungo.boot.pamphlet +++ /dev/null @@ -1,419 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nrungo.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -import '"c-util" -)package "BOOT" - ---======================================================= --- Lookup From Interpreter ---======================================================= - -NRTevalDomain form == - form is ['SETELT,:.] => eval form - evalDomain form - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -compiledLookup(op,sig,dollar) == ---called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, --- getFunctionFromDomain, optDeltaEntry, retractByFunction - if not VECP dollar then dollar := NRTevalDomain dollar - basicLookup(op,sig,dollar,dollar) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -basicLookup(op,sig,domain,dollar) == - domain.1 is ['lookupInDomain,:.] => lookupInDomainVector(op,sig,domain,dollar) - ----------new world code follows------------ - $lookupDefaults : local := nil -- new world - u := lookupInDomainVector(op,sig,domain,dollar) => u - $lookupDefaults := true - lookupInDomainVector(op,sig,domain,dollar) - -compiledLookupCheck(op,sig,dollar) == - fn := compiledLookup(op,sig,dollar) - - -- NEW COMPILER COMPATIBILITY ON - - if (fn = nil) and (op = "^") then - fn := compiledLookup("**",sig,dollar) - else if (fn = nil) and (op = "**") then - fn := compiledLookup("^",sig,dollar) - - -- NEW COMPILER COMPATIBILITY OFF - - fn = nil => - keyedSystemError("S2NR0001",[op,formatSignature sig,dollar.0]) - fn - ---======================================================= --- Lookup From Compiled Code ---======================================================= -goGet(:l) == - [:arglist,env] := l - arglist is ['goGet,:.] => stop() - [[.,[op,initSig,:code]],thisDomain] := env - domainSlot := QSQUOTIENT(code,8192) - code1 := QSREMAINDER(code,8192) - if QSODDP code1 then isConstant := true - code2 := QSQUOTIENT(code1,2) - if QSODDP code2 then explicitLookupDomainIfTrue := true - index := QSQUOTIENT(code2,2) - kind := (isConstant = true => 'CONST; 'ELT) - sig := [NRTreplaceLocalTypes(s,thisDomain) for s in initSig] - sig := substDomainArgs(thisDomain,sig) - lookupDomain := - domainSlot = 0 => thisDomain - thisDomain.domainSlot -- where we look for the operation - if PAIRP lookupDomain then lookupDomain := NRTevalDomain lookupDomain - dollar := -- what matches $ in signatures - explicitLookupDomainIfTrue => lookupDomain - thisDomain - if PAIRP dollar then dollar := NRTevalDomain dollar - fn:= basicLookup(op,sig,lookupDomain,dollar) - fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0]) - val:= APPLY(first fn,[:arglist,rest fn]) - SETELT(thisDomain,index,fn) - val - -NRTreplaceLocalTypes(t,dom) == - atom t => - not INTEGERP t => t - t:= dom.t - if PAIRP t then t:= NRTevalDomain t - t.0 - MEMQ(CAR t,'(Mapping Union Record _:)) => - [CAR t,:[NRTreplaceLocalTypes(x,dom) for x in rest t]] - t - -substDomainArgs(domain,object) == - form := devaluate domain - SUBLISLIS([form,:rest form],["$$",:$FormalMapVariableList],object) - ---======================================================= --- Lookup Function in Slot 1 (via SPADCALL) ---======================================================= -domainTableLookup(op,sig,dollar,env) == lookupInTable(op,sig,dollar,env) -lookupInTable(op,sig,dollar,[domain,table]) == - EQ(table,'derived) => lookupInAddChain(op,sig,domain,dollar) - success := false - someMatch := false - while not success for [sig1,:code] in LASSQ(op,table) repeat - success := - null compareSig(sig,sig1,dollar.0,domain) => false - code is ['subsumed,a] => - subsumptionSig := - EQSUBSTLIST(rest(domain.0),$FormalMapVariableList,a) - someMatch:=true - false - predIndex := QSQUOTIENT(code,8192) - predIndex ^= 0 and null lookupPred($predVector.predIndex,dollar,domain) - => false - loc := QSQUOTIENT(QSREMAINDER(code,8192),2) - loc = 0 => - someMatch := true - nil - slot := domain.loc - EQCAR(slot,'goGet) => - lookupDisplay(op,sig,domain,'" !! goGet found, will ignore") - lookupInAddChain(op,sig,domain,dollar) or 'failed - NULL slot => - lookupDisplay(op,sig,domain,'" !! null slot entry, continuing") - lookupInAddChain(op,sig,domain,dollar) or 'failed - lookupDisplay(op,sig,domain,'" !! found in NEW table!!") - slot - NE(success,'failed) and success => success - subsumptionSig and (u:= SPADCALL(op,subsumptionSig,dollar,domain.1)) => u - someMatch => lookupInAddChain(op,sig,domain,dollar) - nil - ---======================================================= --- Lookup Addlist (from lookupInDomainTable or lookupInDomain) ---======================================================= -lookupInAddChain(op,sig,addFormDomain,dollar) == - addFunction:=lookupInDomain(op,sig,addFormDomain,dollar,5) - defaultingFunction addFunction => - lookupInCategories(op,sig,addFormDomain,dollar) or addFunction - addFunction or lookupInCategories(op,sig,addFormDomain,dollar) - - -defaultingFunction op == - not(op is [.,:dom]) => false - not VECP dom => false - not (#dom > 0) => false - not (dom.0 is [packageName,:.]) => false - not IDENTP packageName => false - pname := PNAME packageName - pname.(MAXINDEX pname) = char "&" - ---======================================================= --- Lookup In Domain (from lookupInAddChain) ---======================================================= -lookupInDomain(op,sig,addFormDomain,dollar,index) == - addFormCell := addFormDomain.index => - INTEGERP KAR addFormCell => - or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] - if null VECP addFormCell then addFormCell := eval addFormCell - lookupInDomainVector(op,sig,addFormCell,dollar) - nil - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupInDomainVector(op,sig,domain,dollar) == - slot1 := domain.1 - SPADCALL(op,sig,dollar,slot1) - ---======================================================= --- Category Default Lookup (from goGet or lookupInAddChain) ---======================================================= -lookupInCategories(op,sig,dom,dollar) == - catformList := dom.4.0 - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - r := or/[lookupInDomainVector(op,nsig, - eval EQSUBSTLIST(valueList,varList,catform),dollar) - for catform in catformList | pred] where pred() == - (table := HGET($Slot1DataBase,first catform)) and - (u := LASSQ(op,table)) --compare without checking predicates - and (v := or/[rest x for x in u | #sig = #x.0]) - -- following lines commented out because compareSig needs domain - -- and (v := or/[rest x for x in u | - -- compareSig(sig,x.0,dollar.0, catform)]) - r or lookupDisplay(op,sig,'"category defaults",'"-- not found") - ---======================================================= --- Predicates ---======================================================= -lookupPred(pred,dollar,domain) == - pred = true => true - pred = 'asserted => false - pred is ['AND,:pl] or pred is ['and,:pl] => - and/[lookupPred(p,dollar,domain) for p in pl] - pred is ['OR,:pl] or pred is ['or,:pl] => - or/[lookupPred(p,dollar,domain) for p in pl] - pred is ['NOT,p] or pred is ['not,p] => not lookupPred(p,dollar,domain) - pred is ['is,dom1,dom2] => domainEqual(dom1,dom2) - pred is ['has,a,b] => - VECP a => - keyedSystemError("S2GE0016",['"lookupPred", - '"vector as first argument to has"]) - a := eval mkEvalable substDollarArgs(dollar,domain,a) - b := substDollarArgs(dollar,domain,b) - HasCategory(a,b) - keyedSystemError("S2NR0002",[pred]) - -substDollarArgs(dollar,domain,object) == - form := devaluate domain - SUBLISLIS([devaluate dollar,:rest form], - ["$",:$FormalMapVariableList],object) - -compareSig(sig,tableSig,dollar,domain) == - not (#sig = #tableSig) => false - null (target := first sig) - or lazyCompareSigEqual(target,first tableSig,dollar,domain) => - and/[lazyCompareSigEqual(s,t,dollar,domain) - for s in rest sig for t in rest tableSig] - -lazyCompareSigEqual(s,tslot,dollar,domain) == - tslot = '$ => s = tslot -- devaluate dollar --needed for browser - INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => - lazyt is [.,.,.,[.,item,.]] and - item is [.,[functorName,:.]] and functorName = CAR s => - compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) - nil - compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) - - -compareSigEqual(s,t,dollar,domain) == - EQUAL(s,t) => true - ATOM t => - u := - EQ(t,'$) => dollar - isSharpVar t => - VECP domain => ELT(rest domain.0,POSN1(t,$FormalMapVariableList)) - ELT(rest domain,POSN1(t,$FormalMapVariableList)) - STRINGP t and IDENTP s => (s := PNAME s; t) - nil - s = '$ => compareSigEqual(dollar,u,dollar,domain) - u => compareSigEqual(s,u,dollar,domain) - EQUAL(s,u) - EQ(s,'$) => compareSigEqual(dollar,t,dollar,domain) - ATOM s => nil - #s ^= #t => nil - match := true - for u in s for v in t repeat - not compareSigEqual(u,v,dollar,domain) => return(match:=false) - match - ------------------------Compiler for Interpreter--------------------------------- -NRTcompileEvalForm(opName,sigTail,dcVector) == - u := NRTcompiledLookup(opName,sigTail,dcVector) - not ($insideCompileBodyIfTrue = true) => MKQ u - k := NRTgetMinivectorIndex(u,opName,sigTail,dcVector) - ['ELT,"$$$",k] --$$$ denotes minivector - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -NRTcompiledLookup(op,sig,dom) == - if CONTAINED('_#,sig) then - sig := [NRTtypeHack t for t in sig] - compiledLookupCheck(op,sig,dom) - -NRTtypeHack t == - ATOM t => t - CAR t = '_# => # CADR t - [CAR t,:[NRTtypeHack tt for tt in CDR t]] - -NRTgetMinivectorIndex(u,op,sig,domVector) == - s := # $minivector - k := or/[k for k in 0..(s-1) - for x in $minivector | EQ(x,u)] => k - $minivector := [:$minivector,u] - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,[op,sig,devaluate domVector]] --- pp '"-- minivectorCode -->" --- pp $minivectorCode - s - -NRTisRecurrenceRelation(op,body,minivectorName) == - -- returns [body p1 p2 ... pk] for a k-term recurrence relation - -- where the n-th term is computed using the (n-1)st,...,(n-k)th - -- whose values are initially computed using the expressions - -- p1,...,pk respectively; body has #2,#3,... in place of - -- f(k-1),f(k-2),... - - body isnt ['COND,:pcl] => false - -- body should have a conditional expression which - -- gives k boundary values, one general term plus possibly an - -- "out of domain" condition ---pcl is [:.,[ ''T,:mess]] and not (CONTAINED('throwMessage,mess) or --- CONTAINED('throwKeyedMsg,mess)) => NIL - pcl := [x for x in pcl | not (x is [''T,:mess] and - (CONTAINED('throwMessage,mess) or - CONTAINED('throwKeyedMsg,mess)))] - integer := EVALFUN $Integer - iequalSlot:=compiledLookupCheck("=",'((Boolean) $ $),integer) - lesspSlot:=compiledLookupCheck("<",'((Boolean) $ $),integer) - bf := '(Boolean) - notpSlot:= compiledLookupCheck("not",'((Boolean)(Boolean)),EVALFUN bf) - for [p,c] in pcl repeat - p is ['SPADCALL,sharpVar,n1,['ELT,=minivectorName,slot]] - and EQ(iequalSlot,$minivector.slot) => - initList:= [[n1,:c],:initList] - sharpList := insert(sharpVar,sharpList) - n:=n1 - miscList:= [[p,c],:miscList] - miscList isnt [[generalPred,generalTerm]] or sharpList isnt [sharpArg] => - return false - --first general term starts at n - - --Must have at least one special value; insist that they be consecutive - null initList => false - specialValues:= MSORT ASSOCLEFT initList - or/[null INTEGERP n for n in specialValues] => false - minIndex:= "MIN"/specialValues - not (and/[i=x for i in minIndex..(minIndex+n-1) for x in specialValues]) => - sayKeyedMsg("S2IX0005", - ["append"/[['" ",sv] for sv in specialValues]]) - return nil - - --Determine the order k of the recurrence and index n of first general term - k:= #specialValues - n:= k+minIndex - --Check general predicate - predOk := - generalPred is '(QUOTE T) => true - generalPred is ['SPADCALL,m,=sharpArg,['ELT,=minivectorName,slot]] - and EQ(lesspSlot,$minivector.slot)=> m+1 - generalPred is ['SPADCALL,['SPADCALL,=sharpArg,m, - ['ELT,=minivectorName,slot]], ['ELT,=minivectorName,notSlot]] - and EQ(lesspSlot,$minivector.slot) - and EQ(notpSlot,$minivector.notSlot) => m - generalPred is ['NOT,['SPADCALL,=sharpArg,m,['ELT,=minivectorName, =lesspSlot]]] - and EQ(lesspSlot,$minivector.slot) => m - return nil - INTEGERP predOk and predOk ^= n => - sayKeyedMsg("S2IX0006",[n,m]) - return nil - - --Check general term for references to just the k previous values - diffCell:=compiledLookupCheck("-",'($ $ $),integer) - diffSlot := or/[i for i in 0.. for x in $minivector | EQ(x,diffCell)] - or return nil - --Check general term for references to just the k previous values - sharpPosition := PARSE_-INTEGER SUBSTRING(sharpArg,1,nil) - al:= mkDiffAssoc(op,generalTerm,k,sharpPosition,sharpArg,diffSlot,minivectorName) - null al => false - '$failed in al => false - body:= generalTerm - for [a,:b] in al repeat - body:= substitute(b,a,body) - result:= [body,sharpArg,n-1,:NREVERSE [LASSOC(i,initList) or - systemErrorHere('"NRTisRecurrenceRelation") - for i in minIndex..(n-1)]] - -mkDiffAssoc(op,body,k,sharpPosition,sharpArg,diffSlot,vecname) == - -- returns alist which should not have any entries = $failed - -- form substitution list of the form: - -- ( ((f (,DIFFERENCE #1 1)) . #2) ((f (,DIFFERENCE #1 2)) . #3) ...) - -- but also checking that all difference values lie in 1..k - atom body => nil - body is ['COND,:pl] => - "union"/[mkDiffAssoc(op,c,k,sharpPosition,sharpArg,diffSlot,vecname) for [p,c] in pl] - body is [fn,:argl] => - (fn = op) and argl.(sharpPosition-1) is - ['SPADCALL,=sharpArg,n,['ELT,=vecname,=diffSlot]] => - NUMP n and n > 0 and n <= k => - [[body,:$TriangleVariableList.n]] - ['$failed] - "union"/[mkDiffAssoc(op,x,k,sharpPosition,sharpArg,diffSlot,vecname) for x in argl] - systemErrorHere '"mkDiffAssoc" -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nruntime.boot b/src/interp/nruntime.boot new file mode 100644 index 00000000..460f3e62 --- /dev/null +++ b/src/interp/nruntime.boot @@ -0,0 +1,63 @@ +-- 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" + +unloadOneConstructor(cnam,fn) == + REMPROP(cnam,'LOADED) + SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) + +devaluateDeeply x == + VECP x => devaluate x + atom x => x + [devaluateDeeply y for y in x] + +lookupDisplay(op,sig,vectorOrForm,suffix) == + null $NRTmonitorIfTrue => nil + prefix := (suffix = '"" => ">"; "<") + sayBrightly + concat(prefix,formatOpSignature(op,sig), + '" from ", prefix2String devaluateDeeply vectorOrForm,suffix) + +isInstantiated [op,:argl] == + u:= lassocShiftWithFunction(argl,HGET($ConstructorCache,op),'domainEqualList) + => CDRwithIncrement u + nil + +isCategoryPackageName nam == + p := PNAME opOf nam + p.(MAXINDEX p) = char '_& + + diff --git a/src/interp/nruntime.boot.pamphlet b/src/interp/nruntime.boot.pamphlet deleted file mode 100644 index eaa39365..00000000 --- a/src/interp/nruntime.boot.pamphlet +++ /dev/null @@ -1,83 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nruntime.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{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. - -@ -<<*>>= -<> - -import '"c-util" -)package "BOOT" - -unloadOneConstructor(cnam,fn) == - REMPROP(cnam,'LOADED) - SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) - -devaluateDeeply x == - VECP x => devaluate x - atom x => x - [devaluateDeeply y for y in x] - -lookupDisplay(op,sig,vectorOrForm,suffix) == - null $NRTmonitorIfTrue => nil - prefix := (suffix = '"" => ">"; "<") - sayBrightly - concat(prefix,formatOpSignature(op,sig), - '" from ", prefix2String devaluateDeeply vectorOrForm,suffix) - -isInstantiated [op,:argl] == - u:= lassocShiftWithFunction(argl,HGET($ConstructorCache,op),'domainEqualList) - => CDRwithIncrement u - nil - -isCategoryPackageName nam == - p := PNAME opOf nam - p.(MAXINDEX p) = char '_& - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3