From c75b5923cb35d83910e45f13e9d15c981ea25387 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 04:57:39 +0000 Subject: remove pamphlets - part 7 --- src/interp/nruncomp.boot | 743 +++++++++++++++++++++ src/interp/nruncomp.boot.pamphlet | 769 --------------------- src/interp/nrunfast.boot | 670 +++++++++++++++++++ src/interp/nrunfast.boot.pamphlet | 692 ------------------- src/interp/nrungo.boot | 395 +++++++++++ src/interp/nrungo.boot.pamphlet | 417 ------------ src/interp/nrunopt.boot | 903 +++++++++++++++++++++++++ src/interp/nrunopt.boot.pamphlet | 929 -------------------------- src/interp/nruntime.boot | 58 ++ src/interp/nruntime.boot.pamphlet | 80 --- src/interp/osyscmd.boot | 53 ++ src/interp/osyscmd.boot.pamphlet | 75 --- src/interp/package.boot | 274 ++++++++ src/interp/package.boot.pamphlet | 300 --------- src/interp/packtran.boot | 60 ++ src/interp/packtran.boot.pamphlet | 86 --- src/interp/pathname.boot | 143 ++++ src/interp/pathname.boot.pamphlet | 165 ----- src/interp/pf2atree.boot | 553 ++++++++++++++++ src/interp/pf2atree.boot.pamphlet | 575 ---------------- src/interp/pf2sex.boot | 461 +++++++++++++ src/interp/pf2sex.boot.pamphlet | 526 --------------- src/interp/postpar.boot | 529 +++++++++++++++ src/interp/postpar.boot.pamphlet | 555 ---------------- src/interp/profile.boot | 89 +++ src/interp/profile.boot.pamphlet | 111 ---- src/interp/pspad1.boot | 741 +++++++++++++++++++++ src/interp/pspad1.boot.pamphlet | 767 --------------------- src/interp/pspad2.boot | 661 ++++++++++++++++++ src/interp/pspad2.boot.pamphlet | 683 ------------------- src/interp/redefs.boot.pamphlet | 92 --- src/interp/rulesets.boot | 303 +++++++++ src/interp/rulesets.boot.pamphlet | 325 --------- src/interp/server.boot | 218 ++++++ src/interp/server.boot.pamphlet | 240 ------- src/interp/setq.lisp | 468 +++++++++++++ src/interp/setq.lisp.pamphlet | 496 -------------- src/interp/sfsfun-l.lisp | 69 ++ src/interp/sfsfun-l.lisp.pamphlet | 91 --- src/interp/showimp.boot | 252 +++++++ src/interp/showimp.boot.pamphlet | 278 -------- src/interp/simpbool.boot | 203 ++++++ src/interp/simpbool.boot.pamphlet | 225 ------- src/interp/slam.boot | 335 ++++++++++ src/interp/slam.boot.pamphlet | 359 ---------- src/interp/sockio.lisp | 241 +++++++ src/interp/sockio.lisp.pamphlet | 263 -------- src/interp/spad.lisp | 596 +++++++++++++++++ src/interp/spad.lisp.pamphlet | 626 ------------------ src/interp/spaderror.lisp | 113 ++++ src/interp/spaderror.lisp.pamphlet | 141 ---- src/interp/topics.boot | 9 +- src/interp/topics.boot.pamphlet | 263 -------- src/interp/wi1.boot | 1261 +++++++++++++++++++++++++++++++++++ src/interp/wi1.boot.pamphlet | 1287 ------------------------------------ src/interp/wi2.boot | 1229 ++++++++++++++++++++++++++++++++++ src/interp/wi2.boot.pamphlet | 1255 ----------------------------------- src/interp/word.boot | 400 +++++++++++ src/interp/word.boot.pamphlet | 422 ------------ 59 files changed, 12025 insertions(+), 13098 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/nrunopt.boot delete mode 100644 src/interp/nrunopt.boot.pamphlet create mode 100644 src/interp/nruntime.boot delete mode 100644 src/interp/nruntime.boot.pamphlet create mode 100644 src/interp/osyscmd.boot delete mode 100644 src/interp/osyscmd.boot.pamphlet create mode 100644 src/interp/package.boot delete mode 100644 src/interp/package.boot.pamphlet create mode 100644 src/interp/packtran.boot delete mode 100644 src/interp/packtran.boot.pamphlet create mode 100644 src/interp/pathname.boot delete mode 100644 src/interp/pathname.boot.pamphlet create mode 100644 src/interp/pf2atree.boot delete mode 100644 src/interp/pf2atree.boot.pamphlet create mode 100644 src/interp/pf2sex.boot delete mode 100644 src/interp/pf2sex.boot.pamphlet create mode 100644 src/interp/postpar.boot delete mode 100644 src/interp/postpar.boot.pamphlet create mode 100644 src/interp/profile.boot delete mode 100644 src/interp/profile.boot.pamphlet create mode 100644 src/interp/pspad1.boot delete mode 100644 src/interp/pspad1.boot.pamphlet create mode 100644 src/interp/pspad2.boot delete mode 100644 src/interp/pspad2.boot.pamphlet delete mode 100644 src/interp/redefs.boot.pamphlet create mode 100644 src/interp/rulesets.boot delete mode 100644 src/interp/rulesets.boot.pamphlet create mode 100644 src/interp/server.boot delete mode 100644 src/interp/server.boot.pamphlet create mode 100644 src/interp/setq.lisp delete mode 100644 src/interp/setq.lisp.pamphlet create mode 100644 src/interp/sfsfun-l.lisp delete mode 100644 src/interp/sfsfun-l.lisp.pamphlet create mode 100644 src/interp/showimp.boot delete mode 100644 src/interp/showimp.boot.pamphlet create mode 100644 src/interp/simpbool.boot delete mode 100644 src/interp/simpbool.boot.pamphlet create mode 100644 src/interp/slam.boot delete mode 100644 src/interp/slam.boot.pamphlet create mode 100644 src/interp/sockio.lisp delete mode 100644 src/interp/sockio.lisp.pamphlet create mode 100644 src/interp/spad.lisp delete mode 100644 src/interp/spad.lisp.pamphlet create mode 100644 src/interp/spaderror.lisp delete mode 100644 src/interp/spaderror.lisp.pamphlet delete mode 100644 src/interp/topics.boot.pamphlet create mode 100644 src/interp/wi1.boot delete mode 100644 src/interp/wi1.boot.pamphlet create mode 100644 src/interp/wi2.boot delete mode 100644 src/interp/wi2.boot.pamphlet create mode 100644 src/interp/word.boot delete mode 100644 src/interp/word.boot.pamphlet diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot new file mode 100644 index 00000000..71bb7b77 --- /dev/null +++ b/src/interp/nruncomp.boot @@ -0,0 +1,743 @@ +-- 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. + + +-----------------------------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 fbc94289..00000000 --- a/src/interp/nruncomp.boot.pamphlet +++ /dev/null @@ -1,769 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp nruncomp.boot} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- 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. - -@ -<<*>>= -<> - ------------------------------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..db9136af --- /dev/null +++ b/src/interp/nrunfast.boot @@ -0,0 +1,670 @@ +-- 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. + + +--======================================================================= +-- 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) +--------------------> NEW DEFINITION (override in xrun.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 + +--======================================================= +-- Instantiate Default Package if Signature Matches +--======================================================= + +getNewDefaultPackage(op,sig,infovec,dom,dollar) == + hohohoho() + opvec := infovec . 1 + numvec := CDDR infovec . 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" + numArgs := QSDIFFERENCE(#sig,1) + success := nil + while finish > start repeat + PROGN + i := start + numArgs ^= (numTableArgs :=numvec.i) => nil + newCompareSigCheaply(sig,numvec,(i := QSPLUS(i,2))) => + return (success := true) + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + null success => nil + defaultPackage := cacheCategoryPackage(packageVec,catVec,i) + +--======================================================= +-- 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) +--------------------> NEW DEFINITION (override in xrun.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(s,d.0,dollar.0,domainArg) + --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) + lazyMatch(s,d,dollar,domain) --new style + a = '$ => s = devaluate dollar + STRINGP a => + 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 +--======================================================= +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandGoGetTypeSlot(slot,dollar,domain) == + newExpandTypeSlot(slot,domain,domain) + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandTypeSlot(slot, dollar, domain) == +--> returns domain form for dollar.slot + newExpandLocalType(domainVal(dollar, domain, slot), dollar,domain) + + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalType(lazyt,dollar,domain) == + VECP lazyt => lazyt.0 + lazyt is [vec,.,:lazyForm] and VECP vec => --old style + newExpandLocalTypeForm(lazyForm,dollar,domain) + newExpandLocalTypeForm(lazyt,dollar,domain) --new style + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +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]] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == + u = '$ => dollar.0 -------eliminate this as $ is rep by 0 + INTEGERP u => + typeFlag => newExpandTypeSlot(u, dollar,domain) + domain.u + u is ['NRTEVAL,y] => nrtEval(y,domain) + u is ['QUOTE,y] => y + atom u => u --can be first, rest, etc. + newExpandLocalTypeForm(u,dollar,domain) + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +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 + + +--======================================================= +-- 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 : FIXNUM := 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 : FIXNUM := 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 e6a29b12..00000000 --- a/src/interp/nrunfast.boot.pamphlet +++ /dev/null @@ -1,692 +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. - -@ -<<*>>= -<> - ---======================================================================= --- 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) ---------------------> NEW DEFINITION (override in xrun.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 - ---======================================================= --- Instantiate Default Package if Signature Matches ---======================================================= - -getNewDefaultPackage(op,sig,infovec,dom,dollar) == - hohohoho() - opvec := infovec . 1 - numvec := CDDR infovec . 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" - numArgs := QSDIFFERENCE(#sig,1) - success := nil - while finish > start repeat - PROGN - i := start - numArgs ^= (numTableArgs :=numvec.i) => nil - newCompareSigCheaply(sig,numvec,(i := QSPLUS(i,2))) => - return (success := true) - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - null success => nil - defaultPackage := cacheCategoryPackage(packageVec,catVec,i) - ---======================================================= --- 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) ---------------------> NEW DEFINITION (override in xrun.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(s,d.0,dollar.0,domainArg) - --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) - lazyMatch(s,d,dollar,domain) --new style - a = '$ => s = devaluate dollar - STRINGP a => - 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 ---======================================================= ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandGoGetTypeSlot(slot,dollar,domain) == - newExpandTypeSlot(slot,domain,domain) - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandTypeSlot(slot, dollar, domain) == ---> returns domain form for dollar.slot - newExpandLocalType(domainVal(dollar, domain, slot), dollar,domain) - - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandLocalType(lazyt,dollar,domain) == - VECP lazyt => lazyt.0 - lazyt is [vec,.,:lazyForm] and VECP vec => --old style - newExpandLocalTypeForm(lazyForm,dollar,domain) - newExpandLocalTypeForm(lazyt,dollar,domain) --new style - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -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]] - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == - u = '$ => dollar.0 -------eliminate this as $ is rep by 0 - INTEGERP u => - typeFlag => newExpandTypeSlot(u, dollar,domain) - domain.u - u is ['NRTEVAL,y] => nrtEval(y,domain) - u is ['QUOTE,y] => y - atom u => u --can be first, rest, etc. - newExpandLocalTypeForm(u,dollar,domain) - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -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 - - ---======================================================= --- 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 : FIXNUM := 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 : FIXNUM := 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..379b511a --- /dev/null +++ b/src/interp/nrungo.boot @@ -0,0 +1,395 @@ +-- 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. + + +--======================================================= +-- 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] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +lazyCompareSigEqual(s,tslot,dollar,domain) == + tslot = '$ => s = 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 72a8e153..00000000 --- a/src/interp/nrungo.boot.pamphlet +++ /dev/null @@ -1,417 +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. - -@ -<<*>>= -<> - ---======================================================= --- 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] - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -lazyCompareSigEqual(s,tslot,dollar,domain) == - tslot = '$ => s = 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/nrunopt.boot b/src/interp/nrunopt.boot new file mode 100644 index 00000000..7bdba59a --- /dev/null +++ b/src/interp/nrunopt.boot @@ -0,0 +1,903 @@ +-- 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. + + +--======================================================================= +-- Generate Code to Create Infovec +--======================================================================= +getInfovecCode() == +--Function called by compDefineFunctor1 to create infovec at compile time + ['LIST, + MKQ makeDomainTemplate $template, + MKQ makeCompactDirect $NRTslot1Info, + MKQ NRTgenFinalAttributeAlist(), + NRTmakeCategoryAlist(), + MKQ $lookupFunction] + +--======================================================================= +-- Generation of Domain Vector Template (Compile Time) +--======================================================================= +makeDomainTemplate vec == +--NOTES: This function is called at compile time to create the template +-- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 + newVec := GETREFV SIZE vec + for index in 0..MAXINDEX vec repeat + item := vec.index + null item => nil + newVec.index := + atom item => item + null atom first item => makeGoGetSlot(item,index) + item + $byteVec := "append"/NREVERSE $byteVec + newVec + +makeGoGetSlot(item,index) == +--NOTES: creates byte vec strings for LATCH slots +--these parts of the $byteVec are created first; see also makeCompactDirect + [sig,whereToGo,op,:flag] := item + n := #sig - 1 + newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index] + $byteVec := [newcode,:$byteVec] + curAddress := $byteAddress + $byteAddress := $byteAddress + n + 4 + [curAddress,:op] + +--======================================================================= +-- Generate OpTable at Compile Time +--======================================================================= +--> called by getInfovecCode (see top of this file) from compDefineFunctor1 +makeCompactDirect u == + $predListLength :local := LENGTH $NRTslot1PredicateList + $byteVecAcc: local := nil + [nam,[addForm,:opList]] := u + --pp opList + d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] + $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] + LIST2VEC ("append"/d) + +makeCompactDirect1(op,items) == +--NOTES: creates byte codes for ops implemented by the domain + curAddress := $byteAddress + $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) + newcodes := + "append"/[u for y in orderBySubsumption items | u := fn y] or return nil + $byteVecAcc := [newcodes,:$byteVecAcc] + curAddress + where fn y == + [sig,:r] := y + r = ['Subsumed] => + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + [n,0,:makeCompactSigCode(sig,$isOpPackageName),0] --always followed by subsuming signature + --identified by a 0 in slot position + if r is [n,:s] then + slot := + n is [p,:.] => p --the CDR is linenumber of function definition + n + predCode := + s is [pred,:.] => predicateBitIndex pred + 0 + --> drop items which are not present (predCode = -1) + predCode = -1 => return nil + --> drop items with NIL slots if lookup function is incomplete + if null slot then + $lookupFunction = 'lookupIncomplete => return nil + slot := 1 --signals that operation is not present + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot] + res + +orderBySubsumption items == + acc := subacc := nil + for x in items repeat + not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] + acc := [x,:acc] + y := z := nil + for [a,b,:.] in subacc | b repeat + --NOTE: b = nil means that the signature a will appear in acc, that this + -- entry is be ignored (e.g. init: -> $ in ULS) + while (u := ASSOC(b,subacc)) repeat b := CADR u + u := ASSOC(b,acc) or systemError nil + if null CADR u then u := [CAR u,1] --mark as missing operation + y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed + z := insert(b,z) --mark a signature as already present + [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming + +makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where +--$isOpPackageName = true only for an exported operation of a default package + fn == + x = '_$_$ => 2 + x = '$ => 0 + NULL INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] +-- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages + x + +--======================================================================= +-- Instantiation Code (Stuffslots) +--======================================================================= +stuffDomainSlots dollar == + domname := devaluate dollar + infovec := GETL(opOf domname,'infovec) + lookupFunction := getLookupFun infovec + lookupFunction := + lookupFunction = 'lookupIncomplete => function lookupIncomplete + function lookupComplete + template := infovec.0 + if template.5 then stuffSlot(dollar,5,template.5) + for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat + stuffSlot(dollar,i,item) + dollar.1 := LIST(lookupFunction,dollar,infovec.1) + dollar.2 := infovec.2 + proto4 := infovec.3 + dollar.4 := + VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style + bitVector := dollar.3 + predvec := CAR proto4 + packagevec := CADR proto4 + auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn == + null testBitVector(bitVector,predvec.i) => nil + packagevec.i or 'T + [auxvec,:CDDR proto4] + +getLookupFun infovec == + MAXINDEX infovec = 4 => infovec.4 + 'lookupIncomplete + +stuffSlot(dollar,i,item) == + dollar.i := + atom item => [SYMBOL_-FUNCTION item,:dollar] + item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] + item is ['CONS,.,['FUNCALL,a,b]] => + b = '$ => ['makeSpadConstant,eval a,dollar,i] + sayBrightlyNT '"Unexpected constant environment!!" + pp devaluate b + nil +-- [dollar,i,:item] --old form +-- $isOpPackageName = 'T => SUBST(0,6,item) + item --new form +--======================================================================= +-- Generate Slot 2 Attribute Alist +--======================================================================= +NRTgenInitialAttributeAlist attributeList == + --alist has form ((item pred)...) where some items are constructor forms + alist := [x for x in attributeList | -- throw out constructors + null MEMQ(opOf first x,allConstructors())] + $lisplibAttributes := simplifyAttributeAlist + [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing] + +simplifyAttributeAlist al == + al is [[a,:b],:r] => + u := [x for x in r | x is [=a,:b]] + null u => [first al,:simplifyAttributeAlist rest al] + pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + s := [x for x in r | x isnt [=a,:b]] + [[a,:pred],:simplifyAttributeAlist s] + nil + +NRTgenFinalAttributeAlist() == + [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1] + +predicateBitIndex x == + pn(x,nil) where + pn(x,flag) == + u := simpBool transHasCode x + u = 'T => 0 + u = nil => -1 + p := POSN1(u,$NRTslot1PredicateList) => p + 1 + null flag => pn(predicateBitIndexRemop x,true) + systemError nil + +predicateBitIndexRemop p== +--transform attribute predicates taken out by removeAttributePredicates + p is [op,:argl] and op in '(AND and OR or NOT not) => + simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) + p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) + p + +predicateBitRef x == + x = 'T => 'T + ['testBitVector,'pv_$,predicateBitIndex x] + +makePrefixForm(u,op) == + u := MKPF(u,op) + u = ''T => 'T + u +--======================================================================= +-- Generate Slot 3 Predicate Vector +--======================================================================= +makePredicateBitVector pl == --called by NRTbuildFunctor + if $insideCategoryPackageIfTrue = true then + pl := union(pl,$categoryPredicateList) + $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas + for p in removeAttributePredicates pl repeat + pred := simpBool transHasCode p + atom pred => 'skip --skip over T and NIL + if isHasDollarPred pred then + lasts := insert(pred,lasts) + for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) + else + firsts := insert(pred,firsts) + firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) + lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) + firstCode:= + ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] + lastCode := augmentPredCode(# firstPl,lastPl) + $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates + [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 + +augmentPredCode(n,lastPl) == + ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) + delta := 2 ** n + l := [(u := MKPF([x,['augmentPredVector,$,delta]],'AND); + delta:=2 * delta; u) for x in pl] + +augmentPredVector(dollar,value) == + QSETREFV(dollar,3,value + QVELT(dollar,3)) + +isHasDollarPred pred == + pred is [op,:r] => + MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] + MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ + false + +stripOutNonDollarPreds pred == + pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => + "append"/[stripOutNonDollarPreds x for x in r] + not isHasDollarPred pred => [pred] + nil + +removeAttributePredicates pl == + [fn p for p in pl] where + fn p == + p is [op,:argl] and op in '(AND and OR or NOT not) => + makePrefixForm(fnl argl,op) + p is ['has,'$,['ATTRIBUTE,a]] => + sayBrightlyNT '"Predicate: " + PRINT p + sayBrightlyNT '" replaced by: " + PRINT LASSOC(a,$NRTattributeAlist) + p + fnl p == [fn x for x in p] + +transHasCode x == + atom x => x + op := QCAR x + MEMQ(op,'(HasCategory HasAttribute)) => x + EQ(op,'has) => compHasFormat x + [transHasCode y for y in x] + +mungeAddGensyms(u,gal) == + ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == + atom x => x + g := LASSOC(x,gal) => + n = 0 => ['LET,g,x] + g + [first x,:[fn(y,gal,n + 1) for y in rest x]] + +orderByContainment pl == + null pl or null rest pl => pl + max := first pl + for x in rest pl repeat + if (y := CONTAINED(max,x)) then + if null ASSOC(max,$predGensymAlist) + then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] + else if CONTAINED(x,max) + then if null ASSOC(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] + if y then max := x + [max,:orderByContainment delete(max,pl)] + +buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == + null l => n + n := n + n + if QCAR l then n := n + 1 + fn(rest l,n) + +buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == + null l => acc + if CAR l then acc := acc + n + fn(acc,n + n,rest l) + +testBitVector(vec,i) == +--bit vector indices are always 1 larger than position in vector + EQ(i,0) => true + LOGBITP(i - 1,vec) + +bitsOf n == + n = 0 => 0 + 1 + bitsOf (n/2) + +--======================================================================= +-- Generate Slot 4 Constructor Vectors +--======================================================================= +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +NRTmakeCategoryAlist() == + $depthAssocCache: local := MAKE_-HASHTABLE 'ID + pcAlist := [:[[x,:'T] for x in $uncondAlist],:$condAlist] + $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] + opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) + newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] + slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) + | (k := predicateBitIndex b) ^= -1] + slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] + sixEtc := [5 + i for i in 1..#$pairlis] + formals := ASSOCRIGHT $pairlis + for x in slot1 repeat RPLACA(x,EQSUBSTLIST(sixEtc,formals,CAR x)) + -----------code to make a new style slot4----------------- + predList := ASSOCRIGHT slot1 --is list of predicate indices + maxPredList := "MAX"/predList + catformvec := ASSOCLEFT slot1 + maxElement := "MAX"/$byteVec + ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], + ['CONS, MKQ LIST2VEC slot0, + ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], + ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] + --NOTE: this is new form: old form satisfies VECP CDDR form + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +encodeCatform x == + k := NRTassocIndex x => k + atom x or atom rest x => x + [first x,:[encodeCatform y for y in rest x]] + +NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) + +hasDefaultPackage catname == + defname := INTERN STRCONC(catname,'"&") + constructor? defname => defname +--MEMQ(defname,allConstructors()) => defname + nil + + +--======================================================================= +-- Generate Category Level Alist +--======================================================================= +orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) + +depthAssocList u == + u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 + REMDUP ("append"/[depthAssoc(y) for y in u]) + +depthAssoc x == + y := HGET($depthAssocCache,x) => y + x is ['Join,:u] or (u := getCatAncestors x) => + v := depthAssocList u + HPUT($depthAssocCache,x,[[x,:n],:v]) + where n == 1 + "MAX"/[rest y for y in v] + HPUT($depthAssocCache,x,[[x,:0]]) + +getCatAncestors x == [CAAR y for y in parentsOf opOf x] + +listOfEntries form == + atom form => form + form is [op,:l] => + op = 'Join => "append"/[listOfEntries x for x in l] + op = 'CATEGORY => listOfCategoryEntries rest l + op = 'PROGN => listOfCategoryEntries l + op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] + op in '(ATTRIBUTE SIGNATURE) => nil + [form] + categoryFormatError() + +listOfCategoryEntries l == + null l => nil + l is [[op,:u],:v] => + firstItemList:= + op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => + [first u] + MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil + op = 'IF and u is [pred,conseq,alternate] => + listOfCategoryEntriesIf(pred,conseq,alternate) + categoryFormatError() + [:firstItemList,:listOfCategoryEntries v] + l is ['PROGN,:l] => listOfCategoryEntries l + l is '(NIL) => nil + sayBrightly '"unexpected category format encountered:" + pp l + +listOfCategoryEntriesIf(pred,conseq,alternate) == + alternate in '(noBranch NIL) => + conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) + [fn for x in listOfEntries conseq] where fn == + x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] + ['IF,pred,x] + notPred := makePrefixForm(pred,'NOT) + conseq is ['IF,p,c,a] => + listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) + [gn for x in listOfEntries conseq] where gn == + x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] + ['IF,notPred,x] + +--======================================================================= +-- Display Template +--======================================================================= +dc(:r) == + con := KAR r + options := KDR r + ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) + null ok => + sayBrightly '"Format is: dc(,option)" + sayBrightly + '"options are: all (default), slots, atts, cats, data, ops, optable" + option := KAR options + option = 'all or null option => dcAll con + option = 'slots => dcSlots con + option = 'atts => dcAtts con + option = 'cats => dcCats con + option = 'data => dcData con + option = 'ops => dcOps con + option = 'size => dcSize( con,'full) + option = 'optable => dcOpTable con + +dcSlots con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + for i in 5..MAXINDEX template repeat + sayBrightlyNT bright i + item := template.i + item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) + null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] + atom item => sayBrightly ['"fun ",item] + item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] + sayBrightly concat('"lazy ",form2String formatSlotDomain i) + +dcOpLatchPrint(op,index) == + numvec := getCodeVector() + numOfArgs := numvec.index + whereNumber := numvec.(index := index + 1) + signumList := dcSig(numvec,index + 1,numOfArgs) + index := index + numOfArgs + 1 + namePart := concat(bright "from", + dollarPercentTran form2String formatSlotDomain whereNumber) + sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] + +getInfovec name == + u := GETL(name,'infovec) => u + GETL(name,'LOADED) => nil + fullLibName := GETDATABASE(name,'OBJECT) or return nil + startTimingProcess 'load + loadLibNoUpdate(name, name, fullLibName) + GETL(name,'infovec) + +getOpSegment index == + numOfArgs := (vec := getCodeVector()).index + [vec.i for i in index..(index + numOfArgs + 3)] + +getCodeVector() == + proto4 := $infovec.3 + u := CDDR proto4 + VECP u => u --old style + CDR u --new style + +formatSlotDomain x == + x = 0 => ["$"] + x = 2 => ["$$"] + INTEGERP x => + val := $infovec.0.x + null val => [STRCONC('"#",STRINGIMAGE (x - 5))] + formatSlotDomain val + atom x => x + x is ['NRTEVAL,y] => (atom y => [y]; y) + [first x,:[formatSlotDomain y for y in rest x]] + +--======================================================================= +-- Display OpTable +--======================================================================= +dcOpTable con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + $predvec: local := GETDATABASE(con,'PREDICATES) + opTable := $infovec.1 + for i in 0..MAXINDEX opTable repeat + op := opTable.i + i := i + 1 + startIndex := opTable.i + stopIndex := + i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() + opTable.(i + 2) + curIndex := startIndex + while curIndex < stopIndex repeat + curIndex := dcOpPrint(op,curIndex) + +dcOpPrint(op,index) == + numvec := getCodeVector() + segment := getOpSegment index + numOfArgs := numvec.index + index := index + 1 + predNumber := numvec.index + index := index + 1 + signumList := dcSig(numvec,index,numOfArgs) + index := index + numOfArgs + 1 + slotNumber := numvec.index + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + namePart := bright + slotNumber = 0 => '"subsumed by next entry" + slotNumber = 1 => '"missing" + name := $infovec.0.slotNumber + atom name => name + '"looked up" + sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] + index + 1 + +dcSig(numvec,index,numOfArgs) == + [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] + +dcPreds con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= GETDATABASE(con,'PREDICATES) + for i in 0..MAXINDEX $predvec repeat + sayBrightlyNT bright (i + 1) + sayBrightly pred2English $predvec.i + +dcAtts con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= GETDATABASE(con,'PREDICATES) + attList := $infovec.2 + for [a,:predNumber] in attList for i in 0.. repeat + sayBrightlyNT bright i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + sayBrightly [a,:suffix] + +dcCats con == + name := abbreviation? con or con + $infovec: local := getInfovec name + u := $infovec.3 + VECP CDDR u => dcCats1 con --old style slot4 + $predvec:= GETDATABASE(con,'PREDICATES) + catpredvec := CAR u + catinfo := CADR u + catvec := CADDR u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + form := catvec.i + predNumber := catpredvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcCats1 con == + $predvec:= GETDATABASE(con,'PREDICATES) + u := $infovec.3 + catvec := CADR u + catinfo := CAR u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + [form,:predNumber] := catvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcData con == + name := abbreviation? con or con + $infovec: local := getInfovec name + sayBrightly '"Operation data from slot 1" + PRINT_-FULL $infovec.1 + vec := getCodeVector() + vec := (PAIRP vec => CDR vec; vec) + sayBrightly ['"Information vector has ",SIZE vec,'" entries"] + dcData1 vec + +dcData1 vec == + n := MAXINDEX vec + tens := n / 10 + for i in 0..tens repeat + start := 10*i + sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) + sayBrightlyNT '" |" + for j in start..MIN(start + 9,n) repeat + sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) + sayNewLine() + vec + +dcSize(:options) == + con := KAR options + options := rest options + null con => dcSizeAll() + quiet := MEMQ('quiet,options) + full := MEMQ('full,options) + name := abbreviation? con or con + infovec := getInfovec name + template := infovec.0 + maxindex := MAXINDEX template + latch := 0 --# of go get slots + lazy := 0 --# of lazy domain slots + fun := 0 --# of function slots + lazyNodes := 0 --# of nodes needed for lazy domain slots + for i in 5..maxindex repeat + atom (item := template.i) => fun := fun + 1 + INTEGERP first item => latch := latch + 1 + 'T => + lazy := lazy + 1 + lazyNodes := lazyNodes + numberOfNodes item + tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) + -- functions are free in the template vector + oSize := vectorSize(SIZE infovec.1) + aSize := numberOfNodes infovec.2 + slot4 := infovec.3 + catvec := + VECP CDDR slot4 => CADR slot4 + CADDR slot4 + n := MAXINDEX catvec + cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), + nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) + codeVector := + VECP CDDR slot4 => CDDR slot4 + CDDDR slot4 + vSize := halfWordSize(SIZE codeVector) + itotal := sum(tSize,oSize,aSize,cSize,vSize) + if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] + if null quiet then + lookupFun := getLookupFun infovec + suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") + sayBrightly ['"template = ",tSize] + sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] + sayBrightly ['"attributes = ",aSize] + sayBrightly ['"categories = ",cSize] + sayBrightly ['"data vector = ",vSize] + if null quiet then + sayBrightly ['"number of function slots (one extra node) = ",fun] + sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] + sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] + sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] + vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) + vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) + --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm + if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] + etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) + if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] + vtotal + +dcSizeAll() == + count := 0 + total := 0 + for x in allConstructors() | null atom GETL(x,'infovec) repeat + count := count + 1 + s := dcSize(x,'quiet) + sayBrightly [s,'" : ",x] + total := total + s + sayBrightly '"------------total-------------" + sayBrightly [count," constructors; ",total," BYTES"] + +sum(:l) == +/l + +nodeSize(n) == 12 * n + +vectorSize(n) == 4 * (1 + n) + +halfWordSize(n) == + n < 128 => n / 2 + n < 256 => n + 2 * n + +numberOfNodes(x) == + atom x => 0 + 1 + numberOfNodes first x + numberOfNodes rest x + +template con == + con := abbreviation? con or con + ppTemplate (getInfovec con).0 + +ppTemplate vec == + for i in 0..MAXINDEX vec repeat + sayBrightlyNT bright i + pp vec.i + +infovec con == + con := abbreviation? con or con + u := getInfovec con + sayBrightly '"---------------slot 0 is template-------------------" + ppTemplate u.0 + sayBrightly '"---------------slot 1 is op table-------------------" + PRINT_-FULL u.1 + sayBrightly '"---------------slot 2 is attribute list-------------" + PRINT_-FULL u.2 + sayBrightly '"---------------slot 3.0 is catpredvec---------------" + PRINT_-FULL u.3.0 + sayBrightly '"---------------slot 3.1 is catinfovec---------------" + PRINT_-FULL u.3.1 + sayBrightly '"---------------slot 3.2 is catvec-------------------" + PRINT_-FULL u.3.2 + sayBrightly '"---------------tail of slot 3 is datavector---------" + dcData1 CDDDR u.3 + 'done + +dcAll con == + con := abbreviation? con or con + $infovec : local := getInfovec con + complete? := + #$infovec = 4 => false + $infovec.4 = 'lookupComplete + sayBrightly '"----------------Template-----------------" + dcSlots con + sayBrightly + complete? => '"----------Complete Ops----------------" + '"----------Incomplete Ops---------------" + dcOpTable con + sayBrightly '"----------------Atts-----------------" + dcAtts con + sayBrightly '"----------------Preds-----------------" + dcPreds con + sayBrightly '"----------------Cats-----------------" + dcCats con + sayBrightly '"----------------Data------------------" + dcData con + sayBrightly '"----------------Size------------------" + dcSize(con,'full) + 'done + +dcOps conname == + for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat + for [sig,slot,pred,key,:.] in u repeat + suffix := + atom pred => nil + concat('" if ",pred2English pred) + key = 'Subsumed => + sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] + sayBrightly [:formatOpSignature(op,sig),:suffix] + +--======================================================================= +-- Compute the lookup function (complete or incomplete) +--======================================================================= +NRTgetLookupFunction(domform,exCategory,addForm) == + domform := SUBLIS($pairlis,domform) + addForm := SUBLIS($pairlis,addForm) + $why: local := nil + atom addForm => 'lookupComplete + extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) + if null extends then + [u,msg,:v] := $why + sayBrightly '"--------------non extending category----------------------" + sayBrightlyNT ['"..",:bright form2String domform,"of cat "] + PRINT u + sayBrightlyNT bright msg + if v then PRINT CAR v else TERPRI() + extends => 'lookupIncomplete + 'lookupComplete + +getExportCategory form == + [op,:argl] := form + op = 'Record => ['RecordCategory,:argl] + op = 'Union => ['UnionCategory,:argl] + functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) + [[.,target,:tl],:.] := functorModemap + EQSUBSTLIST(argl,$FormalMapVariableList,target) + +NRTextendsCategory1(domform,exCategory,addForm) == + addForm is ['Tuple,:r] => + and/[extendsCategory(domform,exCategory,x) for x in r] + extendsCategory(domform,exCategory,addForm) + +--======================================================================= +-- Compute if a domain constructor is forgetful functor +--======================================================================= +extendsCategory(dom,u,v) == + --does category u extend category v (yes iff u contains everything in v) + --is dom of category u also of category v? + u=v => true + v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) + v := substSlotNumbers(v,$template,$functorForm) + extendsCategoryBasic0(dom,u,v) => true + $why := + v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] + [u,'" has no",v] + nil + +extendsCategoryBasic0(dom,u,v) == + v is ['IF,p,['ATTRIBUTE,c],.] => + uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr + null atom c and isCategoryForm(c,nil) => + slot4 := uVec.4 + LASSOC(c,CADR slot4) is [=p,:.] + slot2 := uVec.2 + LASSOC(c,slot2) is [=p,:.] + extendsCategoryBasic(dom,u,v) + +extendsCategoryBasic(dom,u,v) == + u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] + u = v => true + uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr + isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) + v is ['SIGNATURE,op,sig] => + or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] + u is ['CATEGORY,.,:l] => + v is ['IF,:.] => member(v,l) + nil + nil + +catExtendsCat?(u,v,uvec) == + u = v => true + uvec := uvec or compMakeCategoryObject(u,$EmptyEnvironment).expr + slot4 := uvec.4 + prinAncestorList := CAR slot4 + member(v,prinAncestorList) => true + vOp := KAR v + if similarForm := ASSOC(vOp,prinAncestorList) then + PRINT u + sayBrightlyNT '" extends " + PRINT similarForm + sayBrightlyNT '" but not " + PRINT v + or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] + +substSlotNumbers(form,template,domain) == + form is [op,:.] and + MEMQ(op,allConstructors()) => expandType(form,template,domain) + form is ['SIGNATURE,op,sig] => + ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] + form is ['CATEGORY,k,:u] => + ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] + expandType(form,template,domain) + +expandType(lazyt,template,domform) == + atom lazyt => expandTypeArgs(lazyt,template,domform) + [functorName,:argl] := lazyt + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] + for [.,tag,dom] in argl]] + lazyt is ['local,x] => + n := POSN1(x,$FormalMapVariableList) + ELT(domform,1 + n) + [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] + +expandTypeArgs(u,template,domform) == + u = '$ => u --template.0 -------eliminate this as $ is rep by 0 + INTEGERP u => expandType(templateVal(template, domform, u), template,domform) + u is ['NRTEVAL,y] => y --eval y + u is ['QUOTE,y] => y + atom u => u + expandType(u,template,domform) + +templateVal(template,domform,index) == +--returns a domform or a lazy slot + index = 0 => harhar() --template + template.index + diff --git a/src/interp/nrunopt.boot.pamphlet b/src/interp/nrunopt.boot.pamphlet deleted file mode 100644 index 672131fc..00000000 --- a/src/interp/nrunopt.boot.pamphlet +++ /dev/null @@ -1,929 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/nrunopt.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - ---======================================================================= --- Generate Code to Create Infovec ---======================================================================= -getInfovecCode() == ---Function called by compDefineFunctor1 to create infovec at compile time - ['LIST, - MKQ makeDomainTemplate $template, - MKQ makeCompactDirect $NRTslot1Info, - MKQ NRTgenFinalAttributeAlist(), - NRTmakeCategoryAlist(), - MKQ $lookupFunction] - ---======================================================================= --- Generation of Domain Vector Template (Compile Time) ---======================================================================= -makeDomainTemplate vec == ---NOTES: This function is called at compile time to create the template --- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 - newVec := GETREFV SIZE vec - for index in 0..MAXINDEX vec repeat - item := vec.index - null item => nil - newVec.index := - atom item => item - null atom first item => makeGoGetSlot(item,index) - item - $byteVec := "append"/NREVERSE $byteVec - newVec - -makeGoGetSlot(item,index) == ---NOTES: creates byte vec strings for LATCH slots ---these parts of the $byteVec are created first; see also makeCompactDirect - [sig,whereToGo,op,:flag] := item - n := #sig - 1 - newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index] - $byteVec := [newcode,:$byteVec] - curAddress := $byteAddress - $byteAddress := $byteAddress + n + 4 - [curAddress,:op] - ---======================================================================= --- Generate OpTable at Compile Time ---======================================================================= ---> called by getInfovecCode (see top of this file) from compDefineFunctor1 -makeCompactDirect u == - $predListLength :local := LENGTH $NRTslot1PredicateList - $byteVecAcc: local := nil - [nam,[addForm,:opList]] := u - --pp opList - d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] - $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] - LIST2VEC ("append"/d) - -makeCompactDirect1(op,items) == ---NOTES: creates byte codes for ops implemented by the domain - curAddress := $byteAddress - $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) - newcodes := - "append"/[u for y in orderBySubsumption items | u := fn y] or return nil - $byteVecAcc := [newcodes,:$byteVecAcc] - curAddress - where fn y == - [sig,:r] := y - r = ['Subsumed] => - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - [n,0,:makeCompactSigCode(sig,$isOpPackageName),0] --always followed by subsuming signature - --identified by a 0 in slot position - if r is [n,:s] then - slot := - n is [p,:.] => p --the CDR is linenumber of function definition - n - predCode := - s is [pred,:.] => predicateBitIndex pred - 0 - --> drop items which are not present (predCode = -1) - predCode = -1 => return nil - --> drop items with NIL slots if lookup function is incomplete - if null slot then - $lookupFunction = 'lookupIncomplete => return nil - slot := 1 --signals that operation is not present - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot] - res - -orderBySubsumption items == - acc := subacc := nil - for x in items repeat - not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] - acc := [x,:acc] - y := z := nil - for [a,b,:.] in subacc | b repeat - --NOTE: b = nil means that the signature a will appear in acc, that this - -- entry is be ignored (e.g. init: -> $ in ULS) - while (u := ASSOC(b,subacc)) repeat b := CADR u - u := ASSOC(b,acc) or systemError nil - if null CADR u then u := [CAR u,1] --mark as missing operation - y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed - z := insert(b,z) --mark a signature as already present - [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming - -makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where ---$isOpPackageName = true only for an exported operation of a default package - fn == - x = '_$_$ => 2 - x = '$ => 0 - NULL INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] --- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages - x - ---======================================================================= --- Instantiation Code (Stuffslots) ---======================================================================= -stuffDomainSlots dollar == - domname := devaluate dollar - infovec := GETL(opOf domname,'infovec) - lookupFunction := getLookupFun infovec - lookupFunction := - lookupFunction = 'lookupIncomplete => function lookupIncomplete - function lookupComplete - template := infovec.0 - if template.5 then stuffSlot(dollar,5,template.5) - for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat - stuffSlot(dollar,i,item) - dollar.1 := LIST(lookupFunction,dollar,infovec.1) - dollar.2 := infovec.2 - proto4 := infovec.3 - dollar.4 := - VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style - bitVector := dollar.3 - predvec := CAR proto4 - packagevec := CADR proto4 - auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn == - null testBitVector(bitVector,predvec.i) => nil - packagevec.i or 'T - [auxvec,:CDDR proto4] - -getLookupFun infovec == - MAXINDEX infovec = 4 => infovec.4 - 'lookupIncomplete - -stuffSlot(dollar,i,item) == - dollar.i := - atom item => [SYMBOL_-FUNCTION item,:dollar] - item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] - item is ['CONS,.,['FUNCALL,a,b]] => - b = '$ => ['makeSpadConstant,eval a,dollar,i] - sayBrightlyNT '"Unexpected constant environment!!" - pp devaluate b - nil --- [dollar,i,:item] --old form --- $isOpPackageName = 'T => SUBST(0,6,item) - item --new form ---======================================================================= --- Generate Slot 2 Attribute Alist ---======================================================================= -NRTgenInitialAttributeAlist attributeList == - --alist has form ((item pred)...) where some items are constructor forms - alist := [x for x in attributeList | -- throw out constructors - null MEMQ(opOf first x,allConstructors())] - $lisplibAttributes := simplifyAttributeAlist - [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing] - -simplifyAttributeAlist al == - al is [[a,:b],:r] => - u := [x for x in r | x is [=a,:b]] - null u => [first al,:simplifyAttributeAlist rest al] - pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - s := [x for x in r | x isnt [=a,:b]] - [[a,:pred],:simplifyAttributeAlist s] - nil - -NRTgenFinalAttributeAlist() == - [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1] - -predicateBitIndex x == - pn(x,nil) where - pn(x,flag) == - u := simpBool transHasCode x - u = 'T => 0 - u = nil => -1 - p := POSN1(u,$NRTslot1PredicateList) => p + 1 - null flag => pn(predicateBitIndexRemop x,true) - systemError nil - -predicateBitIndexRemop p== ---transform attribute predicates taken out by removeAttributePredicates - p is [op,:argl] and op in '(AND and OR or NOT not) => - simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) - p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) - p - -predicateBitRef x == - x = 'T => 'T - ['testBitVector,'pv_$,predicateBitIndex x] - -makePrefixForm(u,op) == - u := MKPF(u,op) - u = ''T => 'T - u ---======================================================================= --- Generate Slot 3 Predicate Vector ---======================================================================= -makePredicateBitVector pl == --called by NRTbuildFunctor - if $insideCategoryPackageIfTrue = true then - pl := union(pl,$categoryPredicateList) - $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas - for p in removeAttributePredicates pl repeat - pred := simpBool transHasCode p - atom pred => 'skip --skip over T and NIL - if isHasDollarPred pred then - lasts := insert(pred,lasts) - for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) - else - firsts := insert(pred,firsts) - firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) - lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) - firstCode:= - ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] - lastCode := augmentPredCode(# firstPl,lastPl) - $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates - [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 - -augmentPredCode(n,lastPl) == - ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) - delta := 2 ** n - l := [(u := MKPF([x,['augmentPredVector,$,delta]],'AND); - delta:=2 * delta; u) for x in pl] - -augmentPredVector(dollar,value) == - QSETREFV(dollar,3,value + QVELT(dollar,3)) - -isHasDollarPred pred == - pred is [op,:r] => - MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] - MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ - false - -stripOutNonDollarPreds pred == - pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => - "append"/[stripOutNonDollarPreds x for x in r] - not isHasDollarPred pred => [pred] - nil - -removeAttributePredicates pl == - [fn p for p in pl] where - fn p == - p is [op,:argl] and op in '(AND and OR or NOT not) => - makePrefixForm(fnl argl,op) - p is ['has,'$,['ATTRIBUTE,a]] => - sayBrightlyNT '"Predicate: " - PRINT p - sayBrightlyNT '" replaced by: " - PRINT LASSOC(a,$NRTattributeAlist) - p - fnl p == [fn x for x in p] - -transHasCode x == - atom x => x - op := QCAR x - MEMQ(op,'(HasCategory HasAttribute)) => x - EQ(op,'has) => compHasFormat x - [transHasCode y for y in x] - -mungeAddGensyms(u,gal) == - ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == - atom x => x - g := LASSOC(x,gal) => - n = 0 => ['LET,g,x] - g - [first x,:[fn(y,gal,n + 1) for y in rest x]] - -orderByContainment pl == - null pl or null rest pl => pl - max := first pl - for x in rest pl repeat - if (y := CONTAINED(max,x)) then - if null ASSOC(max,$predGensymAlist) - then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] - else if CONTAINED(x,max) - then if null ASSOC(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] - if y then max := x - [max,:orderByContainment delete(max,pl)] - -buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == - null l => n - n := n + n - if QCAR l then n := n + 1 - fn(rest l,n) - -buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == - null l => acc - if CAR l then acc := acc + n - fn(acc,n + n,rest l) - -testBitVector(vec,i) == ---bit vector indices are always 1 larger than position in vector - EQ(i,0) => true - LOGBITP(i - 1,vec) - -bitsOf n == - n = 0 => 0 - 1 + bitsOf (n/2) - ---======================================================================= --- Generate Slot 4 Constructor Vectors ---======================================================================= ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -NRTmakeCategoryAlist() == - $depthAssocCache: local := MAKE_-HASHTABLE 'ID - pcAlist := [:[[x,:'T] for x in $uncondAlist],:$condAlist] - $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] - opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) - newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] - slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) - | (k := predicateBitIndex b) ^= -1] - slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] - sixEtc := [5 + i for i in 1..#$pairlis] - formals := ASSOCRIGHT $pairlis - for x in slot1 repeat RPLACA(x,EQSUBSTLIST(sixEtc,formals,CAR x)) - -----------code to make a new style slot4----------------- - predList := ASSOCRIGHT slot1 --is list of predicate indices - maxPredList := "MAX"/predList - catformvec := ASSOCLEFT slot1 - maxElement := "MAX"/$byteVec - ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], - ['CONS, MKQ LIST2VEC slot0, - ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], - ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] - --NOTE: this is new form: old form satisfies VECP CDDR form - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -encodeCatform x == - k := NRTassocIndex x => k - atom x or atom rest x => x - [first x,:[encodeCatform y for y in rest x]] - -NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) - -hasDefaultPackage catname == - defname := INTERN STRCONC(catname,'"&") - constructor? defname => defname ---MEMQ(defname,allConstructors()) => defname - nil - - ---======================================================================= --- Generate Category Level Alist ---======================================================================= -orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) - -depthAssocList u == - u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 - REMDUP ("append"/[depthAssoc(y) for y in u]) - -depthAssoc x == - y := HGET($depthAssocCache,x) => y - x is ['Join,:u] or (u := getCatAncestors x) => - v := depthAssocList u - HPUT($depthAssocCache,x,[[x,:n],:v]) - where n == 1 + "MAX"/[rest y for y in v] - HPUT($depthAssocCache,x,[[x,:0]]) - -getCatAncestors x == [CAAR y for y in parentsOf opOf x] - -listOfEntries form == - atom form => form - form is [op,:l] => - op = 'Join => "append"/[listOfEntries x for x in l] - op = 'CATEGORY => listOfCategoryEntries rest l - op = 'PROGN => listOfCategoryEntries l - op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] - op in '(ATTRIBUTE SIGNATURE) => nil - [form] - categoryFormatError() - -listOfCategoryEntries l == - null l => nil - l is [[op,:u],:v] => - firstItemList:= - op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => - [first u] - MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil - op = 'IF and u is [pred,conseq,alternate] => - listOfCategoryEntriesIf(pred,conseq,alternate) - categoryFormatError() - [:firstItemList,:listOfCategoryEntries v] - l is ['PROGN,:l] => listOfCategoryEntries l - l is '(NIL) => nil - sayBrightly '"unexpected category format encountered:" - pp l - -listOfCategoryEntriesIf(pred,conseq,alternate) == - alternate in '(noBranch NIL) => - conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) - [fn for x in listOfEntries conseq] where fn == - x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] - ['IF,pred,x] - notPred := makePrefixForm(pred,'NOT) - conseq is ['IF,p,c,a] => - listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) - [gn for x in listOfEntries conseq] where gn == - x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] - ['IF,notPred,x] - ---======================================================================= --- Display Template ---======================================================================= -dc(:r) == - con := KAR r - options := KDR r - ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) - null ok => - sayBrightly '"Format is: dc(,option)" - sayBrightly - '"options are: all (default), slots, atts, cats, data, ops, optable" - option := KAR options - option = 'all or null option => dcAll con - option = 'slots => dcSlots con - option = 'atts => dcAtts con - option = 'cats => dcCats con - option = 'data => dcData con - option = 'ops => dcOps con - option = 'size => dcSize( con,'full) - option = 'optable => dcOpTable con - -dcSlots con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - for i in 5..MAXINDEX template repeat - sayBrightlyNT bright i - item := template.i - item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) - null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] - atom item => sayBrightly ['"fun ",item] - item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] - sayBrightly concat('"lazy ",form2String formatSlotDomain i) - -dcOpLatchPrint(op,index) == - numvec := getCodeVector() - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := dcSig(numvec,index + 1,numOfArgs) - index := index + numOfArgs + 1 - namePart := concat(bright "from", - dollarPercentTran form2String formatSlotDomain whereNumber) - sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] - -getInfovec name == - u := GETL(name,'infovec) => u - GETL(name,'LOADED) => nil - fullLibName := GETDATABASE(name,'OBJECT) or return nil - startTimingProcess 'load - loadLibNoUpdate(name, name, fullLibName) - GETL(name,'infovec) - -getOpSegment index == - numOfArgs := (vec := getCodeVector()).index - [vec.i for i in index..(index + numOfArgs + 3)] - -getCodeVector() == - proto4 := $infovec.3 - u := CDDR proto4 - VECP u => u --old style - CDR u --new style - -formatSlotDomain x == - x = 0 => ["$"] - x = 2 => ["$$"] - INTEGERP x => - val := $infovec.0.x - null val => [STRCONC('"#",STRINGIMAGE (x - 5))] - formatSlotDomain val - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatSlotDomain y for y in rest x]] - ---======================================================================= --- Display OpTable ---======================================================================= -dcOpTable con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - $predvec: local := GETDATABASE(con,'PREDICATES) - opTable := $infovec.1 - for i in 0..MAXINDEX opTable repeat - op := opTable.i - i := i + 1 - startIndex := opTable.i - stopIndex := - i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() - opTable.(i + 2) - curIndex := startIndex - while curIndex < stopIndex repeat - curIndex := dcOpPrint(op,curIndex) - -dcOpPrint(op,index) == - numvec := getCodeVector() - segment := getOpSegment index - numOfArgs := numvec.index - index := index + 1 - predNumber := numvec.index - index := index + 1 - signumList := dcSig(numvec,index,numOfArgs) - index := index + numOfArgs + 1 - slotNumber := numvec.index - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - namePart := bright - slotNumber = 0 => '"subsumed by next entry" - slotNumber = 1 => '"missing" - name := $infovec.0.slotNumber - atom name => name - '"looked up" - sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] - index + 1 - -dcSig(numvec,index,numOfArgs) == - [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] - -dcPreds con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= GETDATABASE(con,'PREDICATES) - for i in 0..MAXINDEX $predvec repeat - sayBrightlyNT bright (i + 1) - sayBrightly pred2English $predvec.i - -dcAtts con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= GETDATABASE(con,'PREDICATES) - attList := $infovec.2 - for [a,:predNumber] in attList for i in 0.. repeat - sayBrightlyNT bright i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - sayBrightly [a,:suffix] - -dcCats con == - name := abbreviation? con or con - $infovec: local := getInfovec name - u := $infovec.3 - VECP CDDR u => dcCats1 con --old style slot4 - $predvec:= GETDATABASE(con,'PREDICATES) - catpredvec := CAR u - catinfo := CADR u - catvec := CADDR u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - form := catvec.i - predNumber := catpredvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcCats1 con == - $predvec:= GETDATABASE(con,'PREDICATES) - u := $infovec.3 - catvec := CADR u - catinfo := CAR u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - [form,:predNumber] := catvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcData con == - name := abbreviation? con or con - $infovec: local := getInfovec name - sayBrightly '"Operation data from slot 1" - PRINT_-FULL $infovec.1 - vec := getCodeVector() - vec := (PAIRP vec => CDR vec; vec) - sayBrightly ['"Information vector has ",SIZE vec,'" entries"] - dcData1 vec - -dcData1 vec == - n := MAXINDEX vec - tens := n / 10 - for i in 0..tens repeat - start := 10*i - sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) - sayBrightlyNT '" |" - for j in start..MIN(start + 9,n) repeat - sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) - sayNewLine() - vec - -dcSize(:options) == - con := KAR options - options := rest options - null con => dcSizeAll() - quiet := MEMQ('quiet,options) - full := MEMQ('full,options) - name := abbreviation? con or con - infovec := getInfovec name - template := infovec.0 - maxindex := MAXINDEX template - latch := 0 --# of go get slots - lazy := 0 --# of lazy domain slots - fun := 0 --# of function slots - lazyNodes := 0 --# of nodes needed for lazy domain slots - for i in 5..maxindex repeat - atom (item := template.i) => fun := fun + 1 - INTEGERP first item => latch := latch + 1 - 'T => - lazy := lazy + 1 - lazyNodes := lazyNodes + numberOfNodes item - tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) - -- functions are free in the template vector - oSize := vectorSize(SIZE infovec.1) - aSize := numberOfNodes infovec.2 - slot4 := infovec.3 - catvec := - VECP CDDR slot4 => CADR slot4 - CADDR slot4 - n := MAXINDEX catvec - cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), - nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) - codeVector := - VECP CDDR slot4 => CDDR slot4 - CDDDR slot4 - vSize := halfWordSize(SIZE codeVector) - itotal := sum(tSize,oSize,aSize,cSize,vSize) - if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] - if null quiet then - lookupFun := getLookupFun infovec - suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") - sayBrightly ['"template = ",tSize] - sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] - sayBrightly ['"attributes = ",aSize] - sayBrightly ['"categories = ",cSize] - sayBrightly ['"data vector = ",vSize] - if null quiet then - sayBrightly ['"number of function slots (one extra node) = ",fun] - sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] - sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] - sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] - vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) - vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) - --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm - if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] - etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) - if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] - vtotal - -dcSizeAll() == - count := 0 - total := 0 - for x in allConstructors() | null atom GETL(x,'infovec) repeat - count := count + 1 - s := dcSize(x,'quiet) - sayBrightly [s,'" : ",x] - total := total + s - sayBrightly '"------------total-------------" - sayBrightly [count," constructors; ",total," BYTES"] - -sum(:l) == +/l - -nodeSize(n) == 12 * n - -vectorSize(n) == 4 * (1 + n) - -halfWordSize(n) == - n < 128 => n / 2 - n < 256 => n - 2 * n - -numberOfNodes(x) == - atom x => 0 - 1 + numberOfNodes first x + numberOfNodes rest x - -template con == - con := abbreviation? con or con - ppTemplate (getInfovec con).0 - -ppTemplate vec == - for i in 0..MAXINDEX vec repeat - sayBrightlyNT bright i - pp vec.i - -infovec con == - con := abbreviation? con or con - u := getInfovec con - sayBrightly '"---------------slot 0 is template-------------------" - ppTemplate u.0 - sayBrightly '"---------------slot 1 is op table-------------------" - PRINT_-FULL u.1 - sayBrightly '"---------------slot 2 is attribute list-------------" - PRINT_-FULL u.2 - sayBrightly '"---------------slot 3.0 is catpredvec---------------" - PRINT_-FULL u.3.0 - sayBrightly '"---------------slot 3.1 is catinfovec---------------" - PRINT_-FULL u.3.1 - sayBrightly '"---------------slot 3.2 is catvec-------------------" - PRINT_-FULL u.3.2 - sayBrightly '"---------------tail of slot 3 is datavector---------" - dcData1 CDDDR u.3 - 'done - -dcAll con == - con := abbreviation? con or con - $infovec : local := getInfovec con - complete? := - #$infovec = 4 => false - $infovec.4 = 'lookupComplete - sayBrightly '"----------------Template-----------------" - dcSlots con - sayBrightly - complete? => '"----------Complete Ops----------------" - '"----------Incomplete Ops---------------" - dcOpTable con - sayBrightly '"----------------Atts-----------------" - dcAtts con - sayBrightly '"----------------Preds-----------------" - dcPreds con - sayBrightly '"----------------Cats-----------------" - dcCats con - sayBrightly '"----------------Data------------------" - dcData con - sayBrightly '"----------------Size------------------" - dcSize(con,'full) - 'done - -dcOps conname == - for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat - for [sig,slot,pred,key,:.] in u repeat - suffix := - atom pred => nil - concat('" if ",pred2English pred) - key = 'Subsumed => - sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] - sayBrightly [:formatOpSignature(op,sig),:suffix] - ---======================================================================= --- Compute the lookup function (complete or incomplete) ---======================================================================= -NRTgetLookupFunction(domform,exCategory,addForm) == - domform := SUBLIS($pairlis,domform) - addForm := SUBLIS($pairlis,addForm) - $why: local := nil - atom addForm => 'lookupComplete - extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) - if null extends then - [u,msg,:v] := $why - sayBrightly '"--------------non extending category----------------------" - sayBrightlyNT ['"..",:bright form2String domform,"of cat "] - PRINT u - sayBrightlyNT bright msg - if v then PRINT CAR v else TERPRI() - extends => 'lookupIncomplete - 'lookupComplete - -getExportCategory form == - [op,:argl] := form - op = 'Record => ['RecordCategory,:argl] - op = 'Union => ['UnionCategory,:argl] - functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) - [[.,target,:tl],:.] := functorModemap - EQSUBSTLIST(argl,$FormalMapVariableList,target) - -NRTextendsCategory1(domform,exCategory,addForm) == - addForm is ['Tuple,:r] => - and/[extendsCategory(domform,exCategory,x) for x in r] - extendsCategory(domform,exCategory,addForm) - ---======================================================================= --- Compute if a domain constructor is forgetful functor ---======================================================================= -extendsCategory(dom,u,v) == - --does category u extend category v (yes iff u contains everything in v) - --is dom of category u also of category v? - u=v => true - v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) - v := substSlotNumbers(v,$template,$functorForm) - extendsCategoryBasic0(dom,u,v) => true - $why := - v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] - [u,'" has no",v] - nil - -extendsCategoryBasic0(dom,u,v) == - v is ['IF,p,['ATTRIBUTE,c],.] => - uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr - null atom c and isCategoryForm(c,nil) => - slot4 := uVec.4 - LASSOC(c,CADR slot4) is [=p,:.] - slot2 := uVec.2 - LASSOC(c,slot2) is [=p,:.] - extendsCategoryBasic(dom,u,v) - -extendsCategoryBasic(dom,u,v) == - u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] - u = v => true - uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr - isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) - v is ['SIGNATURE,op,sig] => - or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] - u is ['CATEGORY,.,:l] => - v is ['IF,:.] => member(v,l) - nil - nil - -catExtendsCat?(u,v,uvec) == - u = v => true - uvec := uvec or compMakeCategoryObject(u,$EmptyEnvironment).expr - slot4 := uvec.4 - prinAncestorList := CAR slot4 - member(v,prinAncestorList) => true - vOp := KAR v - if similarForm := ASSOC(vOp,prinAncestorList) then - PRINT u - sayBrightlyNT '" extends " - PRINT similarForm - sayBrightlyNT '" but not " - PRINT v - or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] - -substSlotNumbers(form,template,domain) == - form is [op,:.] and - MEMQ(op,allConstructors()) => expandType(form,template,domain) - form is ['SIGNATURE,op,sig] => - ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] - form is ['CATEGORY,k,:u] => - ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] - expandType(form,template,domain) - -expandType(lazyt,template,domform) == - atom lazyt => expandTypeArgs(lazyt,template,domform) - [functorName,:argl] := lazyt - MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => - [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] - for [.,tag,dom] in argl]] - lazyt is ['local,x] => - n := POSN1(x,$FormalMapVariableList) - ELT(domform,1 + n) - [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] - -expandTypeArgs(u,template,domform) == - u = '$ => u --template.0 -------eliminate this as $ is rep by 0 - INTEGERP u => expandType(templateVal(template, domform, u), template,domform) - u is ['NRTEVAL,y] => y --eval y - u is ['QUOTE,y] => y - atom u => u - expandType(u,template,domform) - -templateVal(template,domform,index) == ---returns a domform or a lazy slot - index = 0 => harhar() --template - template.index - -@ -\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..23606999 --- /dev/null +++ b/src/interp/nruntime.boot @@ -0,0 +1,58 @@ +-- 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. + + +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 c2d809d1..00000000 --- a/src/interp/nruntime.boot.pamphlet +++ /dev/null @@ -1,80 +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. - -@ -<<*>>= -<> - -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} diff --git a/src/interp/osyscmd.boot b/src/interp/osyscmd.boot new file mode 100644 index 00000000..996d53f8 --- /dev/null +++ b/src/interp/osyscmd.boot @@ -0,0 +1,53 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + + +InterpExecuteSpadSystemCommand string == + CATCH($intCoerceFailure, + CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) + +ExecuteInterpSystemCommand string == + string := intProcessSynonyms(string) + $currentLine:local:=string + string:=SUBSTRING(string,1,nil) + string = '"" => nil + doSystemCommand string + +--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) +parseFromString(s) == + s := next(function ncloopParse, + next(function lineoftoks,incString s)) + StreamNull s => nil + pf2Sex macroExpanded first rest first s + diff --git a/src/interp/osyscmd.boot.pamphlet b/src/interp/osyscmd.boot.pamphlet deleted file mode 100644 index c1afede2..00000000 --- a/src/interp/osyscmd.boot.pamphlet +++ /dev/null @@ -1,75 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp osyscmd.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. - -@ -<<*>>= -<> - -)package "BOOT" - - -InterpExecuteSpadSystemCommand string == - CATCH($intCoerceFailure, - CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) - -ExecuteInterpSystemCommand string == - string := intProcessSynonyms(string) - $currentLine:local:=string - string:=SUBSTRING(string,1,nil) - string = '"" => nil - doSystemCommand string - ---------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) -parseFromString(s) == - s := next(function ncloopParse, - next(function lineoftoks,incString s)) - StreamNull s => nil - pf2Sex macroExpanded first rest first s - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/package.boot b/src/interp/package.boot new file mode 100644 index 00000000..399838ef --- /dev/null +++ b/src/interp/package.boot @@ -0,0 +1,274 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +isPackageFunction() == + -- called by compile/putInLocalDomainReferences +--+ + nil + +processFunctorOrPackage(form,signature,data,localParList,m,e) == +--+ + processFunctor(form,signature,data,localParList,e) + +processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == + $GENNO: local:= 0 --for GENVAR() + $catsig: local + --used in ProcessCond + $maximalViews: local + --read by ProcessCond + $ResetItems: local + --stores those items that get SETQed, and may need re-processing + $catvecList: local:= [$domainShell] + $catNames: local:= ["$"] +--PRINT $definition +--PRINT ($catsig,:argssig) +--PRETTYPRINT code + catvec:= $domainShell --from compDefineFunctor + $getDomainCode:= optFunctorBody $getDomainCode + --the purpose of this is so ProcessCond recognises such items + code:= PackageDescendCode(code,true,nil) + if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where + setPackageCode locals == + locals':=[[u,:i] for u in locals for i in 0.. | u] + locals'' :=[] + while locals' repeat + for v in locals' repeat + [u,:i]:=v + if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] + then + locals'':=[v,:locals''] + locals':=delete(v,locals') + precomp:=code:=[] + for elem in locals'' repeat + [u,:i]:=elem + if ATOM u then u':=u + else + u':=opt(u,precomp) where + opt(u,alist) == + ATOM u => u + for v in u repeat + if (a:=ASSOC(v,alist)) then + [.,:i]:=a + u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where + replace(old,new,l) == + l isnt [h,:t] => l + h = old => [new,:t] + [h,:replace(old,new,t)] + v':=opt(v,alist) + EQ(v,v') => nil + u:=replace(v,v',u) + u + precomp:=[elem,:precomp] + code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] + nreverse code + code:= + ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], + --It is important to place this code here, + --after $ is set up + --slam functor with shell + --the order of steps in this PROGN are critical + addToSlam($definition,"$"),code,[ + "SETELT","$",0, mkDomainConstructor $definition],: +-- If we call addMutableArg this early, then recurise calls to this domain +-- (e.g. while testing predicates) will generate new domains => trouble +-- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: + [["SETELT","$",position(name,locals),name] + for name in $ResetItems | MEMQ(name,locals)], + :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) + (LIST (GENSYM)));[]) ], + "$"] + for u in $getDomainCode repeat + u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => + $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) + $packagesUsed:=union($functorLocalParameters,$packagesUsed) + $getDomainCode:= nil + --if we didn't kill this, DEFINE would insert it in the wrong place + optFunctorBody code + +subTree(u,v) == + v=u => true + ATOM v => nil + or/[subTree(u,v') for v' in v] + +mkList u == + u => ["LIST",:u] + nil + +setPackageLocals(pac,locs) == + for var in locs for i in 0.. | var^=nil repeat pac.i:= var + +PackageDescendCode(code,flag,viewAssoc) == + --flag is true if we are walking down code always executed + --nil if we are in conditional code + code=nil => nil + code="noBranch" => nil + code is ["add",base,:codelist] => + systemError '"packages may not have add clauses" + code is ["PROGN",:codelist] => + ["PROGN",: + [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] + code is ["COND",:condlist] => + c:= + ["COND",: + [[u2:= ProcessCond(first u,viewAssoc),: + (if null u2 + then nil + else + [PackageDescendCode(v,flag and TruthP u2, + if first u is ["HasCategory",dom,cat] + then [[dom,:cat],:viewAssoc] + else viewAssoc) for v in rest u])] for u in condlist]] + TruthP CAADR c => ["PROGN",:CDADR c] + c + code is ["LET",name,body,:.] => + if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] + if body is [a,:.] and isFunctor a + then $packagesUsed:=[body,:$packagesUsed] + code + code is ["CodeDefine",sig,implem] => + --Generated by doIt in COMPILER BOOT + dom:= "$" + dom:= + u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] + dom + body:= ["CONS",implem,dom] + SetFunctionSlots(sig,body,flag,"original") + code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) + --Yes, I know that's a hack, but how else do you kill a line? + code is ["LIST",:.] => nil + code is ["MDEF",:.] => nil + code is ["devaluate",:.] => nil + code is ["call",:.] => code + code is ["SETELT",:.] => code + code is ["QSETREFV",:.] => code + stackWarning ["unknown Package code ",code] + code + +mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == + domainOrPackage^="domain" => + [opSig,pred,["PAC","$",name]] where + name() == encodeFunctionName(op,domainOrPackage,sig,":",count) + null flag => [opSig,pred,["ELT","$",count]] + first flag="constant" => [[op,sig],pred,["CONST","$",count]] + systemError ["unknown variable mode: ",flag] + +optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == + RPLACA(x,functionName) + RPLACD(x,[:arglist,packageVariableOrForm]) + x + +--% Code for encoding function names inside package or domain + +encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) + == + signature':= substitute("$",package,signature) + reducedSig:= mkRepititionAssoc [:rest signature',first signature'] + encodedSig:= + ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where + encodedPair() == + n=1 => encodeItem x + STRCONC(STRINGIMAGE n,encodeItem x) + encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", + encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) + if $LISPLIB then + $lisplibSignatureAlist:= + [[encodedName,:signature'],:$lisplibSignatureAlist] + encodedName + +splitEncodedFunctionName(encodedName, sep) == + -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL + -- sep0 is the separator used in "encodeFunctionName". + sep0 := '";" + if not STRINGP encodedName then + encodedName := STRINGIMAGE encodedName + null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil + null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner +-- This is picked up in compile for inner functions in partial compilation + null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil + s1 := SUBSTRING(encodedName, 0, p1) + s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) + s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) + s4 := SUBSTRING(encodedName, p3+1, nil) + [s1, s2, s3, s4] + +mkRepititionAssoc l == + mkRepfun(l,1) where + mkRepfun(l,n) == + null l => nil + l is [x] => [[n,:x]] + l is [x, =x,:l'] => mkRepfun(rest l,n+1) + [[n,:first l],:mkRepfun(rest l,1)] + +encodeItem x == + x is [op,:argl] => getCaps op + IDENTP x => PNAME x + STRINGIMAGE x + +getCaps x == + s:= STRINGIMAGE x + clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] + null clist => '"__" + "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] + +--% abbreviation code + +getAbbreviation(name,c) == + --returns abbreviation of name with c arguments + x := constructor? name + X := ASSQ(x,$abbreviationTable) => + N:= ASSQ(name,rest X) => + C:= ASSQ(c,rest N) => rest C --already there + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest N,[[c,:newAbbreviation],:rest N]) + newAbbreviation + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) + newAbbreviation + $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] + x + +mkAbbrev(X,x) == addSuffix(alistSize rest X,x) + +alistSize c == + count(c,1) where + count(x,level) == + level=2 => #x + null x => 0 + count(CDAR x,level+1)+count(rest x,level) + +addSuffix(n,u) == + ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) + INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) + + diff --git a/src/interp/package.boot.pamphlet b/src/interp/package.boot.pamphlet deleted file mode 100644 index f97f86ac..00000000 --- a/src/interp/package.boot.pamphlet +++ /dev/null @@ -1,300 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/package.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - -isPackageFunction() == - -- called by compile/putInLocalDomainReferences ---+ - nil - -processFunctorOrPackage(form,signature,data,localParList,m,e) == ---+ - processFunctor(form,signature,data,localParList,e) - -processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == - $GENNO: local:= 0 --for GENVAR() - $catsig: local - --used in ProcessCond - $maximalViews: local - --read by ProcessCond - $ResetItems: local - --stores those items that get SETQed, and may need re-processing - $catvecList: local:= [$domainShell] - $catNames: local:= ["$"] ---PRINT $definition ---PRINT ($catsig,:argssig) ---PRETTYPRINT code - catvec:= $domainShell --from compDefineFunctor - $getDomainCode:= optFunctorBody $getDomainCode - --the purpose of this is so ProcessCond recognises such items - code:= PackageDescendCode(code,true,nil) - if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where - setPackageCode locals == - locals':=[[u,:i] for u in locals for i in 0.. | u] - locals'' :=[] - while locals' repeat - for v in locals' repeat - [u,:i]:=v - if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] - then - locals'':=[v,:locals''] - locals':=delete(v,locals') - precomp:=code:=[] - for elem in locals'' repeat - [u,:i]:=elem - if ATOM u then u':=u - else - u':=opt(u,precomp) where - opt(u,alist) == - ATOM u => u - for v in u repeat - if (a:=ASSOC(v,alist)) then - [.,:i]:=a - u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where - replace(old,new,l) == - l isnt [h,:t] => l - h = old => [new,:t] - [h,:replace(old,new,t)] - v':=opt(v,alist) - EQ(v,v') => nil - u:=replace(v,v',u) - u - precomp:=[elem,:precomp] - code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] - nreverse code - code:= - ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], - --It is important to place this code here, - --after $ is set up - --slam functor with shell - --the order of steps in this PROGN are critical - addToSlam($definition,"$"),code,[ - "SETELT","$",0, mkDomainConstructor $definition],: --- If we call addMutableArg this early, then recurise calls to this domain --- (e.g. while testing predicates) will generate new domains => trouble --- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: - [["SETELT","$",position(name,locals),name] - for name in $ResetItems | MEMQ(name,locals)], - :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) - (LIST (GENSYM)));[]) ], - "$"] - for u in $getDomainCode repeat - u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => - $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) - $packagesUsed:=union($functorLocalParameters,$packagesUsed) - $getDomainCode:= nil - --if we didn't kill this, DEFINE would insert it in the wrong place - optFunctorBody code - -subTree(u,v) == - v=u => true - ATOM v => nil - or/[subTree(u,v') for v' in v] - -mkList u == - u => ["LIST",:u] - nil - -setPackageLocals(pac,locs) == - for var in locs for i in 0.. | var^=nil repeat pac.i:= var - -PackageDescendCode(code,flag,viewAssoc) == - --flag is true if we are walking down code always executed - --nil if we are in conditional code - code=nil => nil - code="noBranch" => nil - code is ["add",base,:codelist] => - systemError '"packages may not have add clauses" - code is ["PROGN",:codelist] => - ["PROGN",: - [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] - code is ["COND",:condlist] => - c:= - ["COND",: - [[u2:= ProcessCond(first u,viewAssoc),: - (if null u2 - then nil - else - [PackageDescendCode(v,flag and TruthP u2, - if first u is ["HasCategory",dom,cat] - then [[dom,:cat],:viewAssoc] - else viewAssoc) for v in rest u])] for u in condlist]] - TruthP CAADR c => ["PROGN",:CDADR c] - c - code is ["LET",name,body,:.] => - if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] - if body is [a,:.] and isFunctor a - then $packagesUsed:=[body,:$packagesUsed] - code - code is ["CodeDefine",sig,implem] => - --Generated by doIt in COMPILER BOOT - dom:= "$" - dom:= - u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] - dom - body:= ["CONS",implem,dom] - SetFunctionSlots(sig,body,flag,"original") - code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) - --Yes, I know that's a hack, but how else do you kill a line? - code is ["LIST",:.] => nil - code is ["MDEF",:.] => nil - code is ["devaluate",:.] => nil - code is ["call",:.] => code - code is ["SETELT",:.] => code - code is ["QSETREFV",:.] => code - stackWarning ["unknown Package code ",code] - code - -mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == - domainOrPackage^="domain" => - [opSig,pred,["PAC","$",name]] where - name() == encodeFunctionName(op,domainOrPackage,sig,":",count) - null flag => [opSig,pred,["ELT","$",count]] - first flag="constant" => [[op,sig],pred,["CONST","$",count]] - systemError ["unknown variable mode: ",flag] - -optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == - RPLACA(x,functionName) - RPLACD(x,[:arglist,packageVariableOrForm]) - x - ---% Code for encoding function names inside package or domain - -encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) - == - signature':= substitute("$",package,signature) - reducedSig:= mkRepititionAssoc [:rest signature',first signature'] - encodedSig:= - ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where - encodedPair() == - n=1 => encodeItem x - STRCONC(STRINGIMAGE n,encodeItem x) - encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", - encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) - if $LISPLIB then - $lisplibSignatureAlist:= - [[encodedName,:signature'],:$lisplibSignatureAlist] - encodedName - -splitEncodedFunctionName(encodedName, sep) == - -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL - -- sep0 is the separator used in "encodeFunctionName". - sep0 := '";" - if not STRINGP encodedName then - encodedName := STRINGIMAGE encodedName - null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil - null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner --- This is picked up in compile for inner functions in partial compilation - null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil - s1 := SUBSTRING(encodedName, 0, p1) - s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) - s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) - s4 := SUBSTRING(encodedName, p3+1, nil) - [s1, s2, s3, s4] - -mkRepititionAssoc l == - mkRepfun(l,1) where - mkRepfun(l,n) == - null l => nil - l is [x] => [[n,:x]] - l is [x, =x,:l'] => mkRepfun(rest l,n+1) - [[n,:first l],:mkRepfun(rest l,1)] - -encodeItem x == - x is [op,:argl] => getCaps op - IDENTP x => PNAME x - STRINGIMAGE x - -getCaps x == - s:= STRINGIMAGE x - clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] - null clist => '"__" - "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] - ---% abbreviation code - -getAbbreviation(name,c) == - --returns abbreviation of name with c arguments - x := constructor? name - X := ASSQ(x,$abbreviationTable) => - N:= ASSQ(name,rest X) => - C:= ASSQ(c,rest N) => rest C --already there - newAbbreviation:= mkAbbrev(X,x) - RPLAC(rest N,[[c,:newAbbreviation],:rest N]) - newAbbreviation - newAbbreviation:= mkAbbrev(X,x) - RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) - newAbbreviation - $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] - x - -mkAbbrev(X,x) == addSuffix(alistSize rest X,x) - -alistSize c == - count(c,1) where - count(x,level) == - level=2 => #x - null x => 0 - count(CDAR x,level+1)+count(rest x,level) - -addSuffix(n,u) == - ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) - INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/packtran.boot b/src/interp/packtran.boot new file mode 100644 index 00000000..9634b9b6 --- /dev/null +++ b/src/interp/packtran.boot @@ -0,0 +1,60 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +-- The $useNewParser flag controls which parser will be used in the interpreter +-- If nil then the old parser is used, otherwise Bill Burge's parser is used +$useNewParser := true + +rePackageTran(sex, package) == + _*PACKAGE_* : fluid := FIND_-PACKAGE STRING package + packageTran sex + +packageTran sex == +-- destructively translate all the symbols in the given s-expression to the +-- current package + SYMBOLP sex => + EQ(_*PACKAGE_*, SYMBOL_-PACKAGE sex) => sex + INTERN STRING sex + CONSP sex => + RPLACA(sex, packageTran CAR sex) + RPLACD(sex, packageTran CDR sex) + sex + sex + +zeroOneTran sex == +-- destructively translate the symbols |0| and |1| to their +-- integer counterparts + NSUBST("$EmptyMode", "?", sex) + sex + diff --git a/src/interp/packtran.boot.pamphlet b/src/interp/packtran.boot.pamphlet deleted file mode 100644 index b1814ddf..00000000 --- a/src/interp/packtran.boot.pamphlet +++ /dev/null @@ -1,86 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp packtran.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. - -@ -<<*>>= -<> - -)package "BOOT" - --- The $useNewParser flag controls which parser will be used in the interpreter --- If nil then the old parser is used, otherwise Bill Burge's parser is used -$useNewParser := true - -rePackageTran(sex, package) == - _*PACKAGE_* : fluid := FIND_-PACKAGE STRING package - packageTran sex - -packageTran sex == --- destructively translate all the symbols in the given s-expression to the --- current package - SYMBOLP sex => - EQ(_*PACKAGE_*, SYMBOL_-PACKAGE sex) => sex - INTERN STRING sex - CONSP sex => - RPLACA(sex, packageTran CAR sex) - RPLACD(sex, packageTran CDR sex) - sex - sex - -zeroOneTran sex == --- destructively translate the symbols |0| and |1| to their --- integer counterparts - NSUBST("$EmptyMode", "?", sex) - sex - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pathname.boot b/src/interp/pathname.boot new file mode 100644 index 00000000..f10cf327 --- /dev/null +++ b/src/interp/pathname.boot @@ -0,0 +1,143 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +-- This file implements the Common Lisp pathname functions for +-- Lisp/VM. On VM, a filename is 3-list consisting of the filename, +-- filetype and filemode. We also UPCASE everything. + +-- This file also contains some other VM specific functions for +-- dealing with files. + +--% Common Lisp Pathname Functions + +pathname? p == p=[] or PATHNAMEP p + +pathname p == + p = [] => p + PATHNAMEP p => p + not PAIRP p => PATHNAME p + if #p>2 then p:=[p.0,p.1] + PATHNAME APPLY(FUNCTION MAKE_-FILENAME, p) + +namestring p == NAMESTRING pathname p + +pathnameName p == PATHNAME_-NAME pathname p + +pathnameType p == PATHNAME_-TYPE pathname p + +pathnameTypeId p == UPCASE object2Identifier pathnameType p + +pathnameDirectory p == + NAMESTRING MAKE_-PATHNAME(LispKeyword '"DIRECTORY",PATHNAME_-DIRECTORY pathname p) + +deleteFile f == _$ERASE pathname f + +isExistingFile f == +-- p := pathname f + --member(p,$existingFiles) => true + if MAKE_-INPUT_-FILENAME f + then + --$existingFiles := [p,:$existingFiles] + true + else false + +--% Scratchpad II File Name Functions + +makePathname(name,type,dir) == + -- Common Lisp version of this will have to be written + -- using MAKE-PATHNAME and the optional args. + pathname [object2String name,object2String type] + +mergePathnames(a,b) == + (fn := pathnameName(a)) = '"*" => b + fn ^= pathnameName(b) => a + (ft := pathnameType(a)) = '"*" => b + ft ^= pathnameType(b) => a + (fm := pathnameDirectory(a)) = ['"*"] => b + a + +isSystemDirectory dir == EVERY(function CHAR_=,$SPADROOT,dir) + +-- the next function is an improved version of the one in DEBUG LISP + +_/MKINFILENAM(infile) == CATCH('FILNAM, newMKINFILENAM infile) + +newMKINFILENAM(infile) == + NULL infile => nil + file := infile := pathname infile + repeat + fn := pathnameName file + nfile := $FINDFILE (file,$sourceFileTypes) + null nfile => + nfile := file + if fn = '"*" or fn = '"NIL" then sayKeyedMsg("S2IL0016",NIL) + else sayKeyedMsg("S2IL0003",[namestring file]) + ans := queryUserKeyedMsg("S2IL0017",NIL) + if (SIZE(ans) > 0) and ('")" = SUBSTRING(ans,0,1)) then n := 2 + else n := 1 + nfn := UPCASE STRING2ID_-N(ans,n) + (nfn = 0) or (nfn = 'QUIT) => + sayKeyedMsg("S2IL0018",NIL) + THROW('FILENAM,NIL) + nfn = 'CREATE => return 'fromThisLoop + file := pathname ans + return 'fromThisLoop + if nfile then pathname nfile + else NIL + + +getFunctionSourceFile fun == + null (f := getFunctionSourceFile1 fun) => NIL + if MAKE_-INPUT_-FILENAME(f) then updateSourceFiles f + f + +getFunctionSourceFile1 fun == + -- returns NIL or [fn,ft,fm] + (file := KDR GETL(fun,'DEFLOC)) => pathname file + null ((fileinfo := FUNLOC fun) or + (fileinfo := FUNLOC unabbrev fun)) => + u := bootFind fun => getFunctionSourceFile1 SETQ($FUNCTION,INTERN u) + NIL + 3 = #fileinfo => + [fn,ft,$FUNCTION] := fileinfo + newMKINFILENAM pathname [fn,ft] + [fn,$FUNCTION] := fileinfo + newMKINFILENAM pathname [fn] + +updateSourceFiles p == + p := pathname p + p := pathname [pathnameName p, pathnameType p, '"*"] + if MAKE_-INPUT_-FILENAME p and pathnameTypeId p in '(BOOT LISP META) then + $sourceFiles := insert(p, $sourceFiles) + p diff --git a/src/interp/pathname.boot.pamphlet b/src/interp/pathname.boot.pamphlet deleted file mode 100644 index 300d2c41..00000000 --- a/src/interp/pathname.boot.pamphlet +++ /dev/null @@ -1,165 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pathname.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. - -@ -<<*>>= -<> - -)package "BOOT" - --- This file implements the Common Lisp pathname functions for --- Lisp/VM. On VM, a filename is 3-list consisting of the filename, --- filetype and filemode. We also UPCASE everything. - --- This file also contains some other VM specific functions for --- dealing with files. - ---% Common Lisp Pathname Functions - -pathname? p == p=[] or PATHNAMEP p - -pathname p == - p = [] => p - PATHNAMEP p => p - not PAIRP p => PATHNAME p - if #p>2 then p:=[p.0,p.1] - PATHNAME APPLY(FUNCTION MAKE_-FILENAME, p) - -namestring p == NAMESTRING pathname p - -pathnameName p == PATHNAME_-NAME pathname p - -pathnameType p == PATHNAME_-TYPE pathname p - -pathnameTypeId p == UPCASE object2Identifier pathnameType p - -pathnameDirectory p == - NAMESTRING MAKE_-PATHNAME(LispKeyword '"DIRECTORY",PATHNAME_-DIRECTORY pathname p) - -deleteFile f == _$ERASE pathname f - -isExistingFile f == --- p := pathname f - --member(p,$existingFiles) => true - if MAKE_-INPUT_-FILENAME f - then - --$existingFiles := [p,:$existingFiles] - true - else false - ---% Scratchpad II File Name Functions - -makePathname(name,type,dir) == - -- Common Lisp version of this will have to be written - -- using MAKE-PATHNAME and the optional args. - pathname [object2String name,object2String type] - -mergePathnames(a,b) == - (fn := pathnameName(a)) = '"*" => b - fn ^= pathnameName(b) => a - (ft := pathnameType(a)) = '"*" => b - ft ^= pathnameType(b) => a - (fm := pathnameDirectory(a)) = ['"*"] => b - a - -isSystemDirectory dir == EVERY(function CHAR_=,$SPADROOT,dir) - --- the next function is an improved version of the one in DEBUG LISP - -_/MKINFILENAM(infile) == CATCH('FILNAM, newMKINFILENAM infile) - -newMKINFILENAM(infile) == - NULL infile => nil - file := infile := pathname infile - repeat - fn := pathnameName file - nfile := $FINDFILE (file,$sourceFileTypes) - null nfile => - nfile := file - if fn = '"*" or fn = '"NIL" then sayKeyedMsg("S2IL0016",NIL) - else sayKeyedMsg("S2IL0003",[namestring file]) - ans := queryUserKeyedMsg("S2IL0017",NIL) - if (SIZE(ans) > 0) and ('")" = SUBSTRING(ans,0,1)) then n := 2 - else n := 1 - nfn := UPCASE STRING2ID_-N(ans,n) - (nfn = 0) or (nfn = 'QUIT) => - sayKeyedMsg("S2IL0018",NIL) - THROW('FILENAM,NIL) - nfn = 'CREATE => return 'fromThisLoop - file := pathname ans - return 'fromThisLoop - if nfile then pathname nfile - else NIL - - -getFunctionSourceFile fun == - null (f := getFunctionSourceFile1 fun) => NIL - if MAKE_-INPUT_-FILENAME(f) then updateSourceFiles f - f - -getFunctionSourceFile1 fun == - -- returns NIL or [fn,ft,fm] - (file := KDR GETL(fun,'DEFLOC)) => pathname file - null ((fileinfo := FUNLOC fun) or - (fileinfo := FUNLOC unabbrev fun)) => - u := bootFind fun => getFunctionSourceFile1 SETQ($FUNCTION,INTERN u) - NIL - 3 = #fileinfo => - [fn,ft,$FUNCTION] := fileinfo - newMKINFILENAM pathname [fn,ft] - [fn,$FUNCTION] := fileinfo - newMKINFILENAM pathname [fn] - -updateSourceFiles p == - p := pathname p - p := pathname [pathnameName p, pathnameType p, '"*"] - if MAKE_-INPUT_-FILENAME p and pathnameTypeId p in '(BOOT LISP META) then - $sourceFiles := insert(p, $sourceFiles) - p -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pf2atree.boot b/src/interp/pf2atree.boot new file mode 100644 index 00000000..0ea1cf7f --- /dev/null +++ b/src/interp/pf2atree.boot @@ -0,0 +1,553 @@ +-- 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. + + +-- not hooked in yet + +-- BB parser tree to interpreter vectorized attributed trees. +-- Used to interface the BB parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an interpreter attributed tree. + +SETANDFILEQ($useParserSrcPos, true) +SETANDFILEQ($transferParserSrcPos, true) + +pf2Sexpr pf == packageTran (pf2Sex1)(pf) + +pf2Atree pf == + (intUnsetQuiet)() + + $insideRule: local := false + $insideApplication: local := false + $insideSEQ: local := false + + -- we set the following because we will be using some things + -- within pf2sex.boot and they are in the spadcomp package. + + ($insideRule): local := false + ($insideApplication): local := false + ($insideSEQ): local := false + + pf2Atree1 pf + +pf2Atree1 pf == + -- some simple things that are really just S-expressions + + (pfNothing?)(pf) => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfSymbol?) pf => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfLiteral?)(pf) => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfId?) pf => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + + -- Now some compound forms + + (pfApplication?)(pf) => + pfApplication2Atree pf + + (pfTuple?)(pf) => + [mkAtreeNodeWithSrcPos("Tuple",pf), + :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] + + (pfIf?)(pf) => + condPf := (pfIfCond)(pf) + condPart := pf2Atree1 condPf + thenPart := pf2Atree1 (pfIfThen)(pf) + elsePart := pf2Atree1 (pfIfElse)(pf) + ifPart := mkAtreeNodeWithSrcPos("IF", pf) + thenPart = "noBranch" => + [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], + elsePart, thenPart] + [ifPart, condPart, thenPart, elsePart] + + (pfTagged?)(pf) => + tag := (pfTaggedTag)(pf) + tagPart := + (pfTuple?) tag => + ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] + pf2Sexpr(tag) + [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, + pf2Sexpr((pfTaggedExpr)(pf))] + + (pfCoerceto?)(pf) => + [mkAtreeNodeWithSrcPos("COERCE",pf), + pf2Atree1 (pfCoercetoExpr)(pf), + pf2Sexpr((pfCoercetoType)(pf))] + + (pfPretend?)(pf) => + [mkAtreeNodeWithSrcPos("pretend",pf), + pf2Atree1 (pfPretendExpr)(pf), + pf2Sexpr((pfPretendType)(pf))] + + (pfFromdom?)(pf) => + op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) + if op = "braceFromCurly" then op := "SEQ" -- ?? + + op = 0 => + -- 0$Foo => Zero()$Foo + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("Zero",pf)]] + op = 1 => + -- 1$Foo => One()$Foo + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("One",pf)]] + INTEGERP op => + -- n$Foo => n * One()$Foo + [mkAtreeNodeWithSrcPos("*",pf), + mkAtree1WithSrcPos(op,pf), + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("One",pf)]]] + + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + mkAtreeNodeWithSrcPos(op,pf)] + + (pfSequence?)(pf) => + pfSequence2Atree pf + + (pfExit?)(pf) => + $insideSEQ => + [mkAtreeNodeWithSrcPos("exit",pf), + pf2Atree1 (pfExitCond)(pf), + pf2Atree1 (pfExitExpr)(pf)] + [mkAtreeNodeWithSrcPos("IF",pf), + pf2Atree1 (pfExitCond)(pf), + pf2Atree1 (pfExitExpr)(pf), "noBranch"] + + (pfLoop?)(pf) => + [mkAtreeNodeWithSrcPos("REPEAT",pf), + :loopIters2Atree (pf0LoopIterators)(pf)] + + (pfCollect?)(pf) => + pfCollect2Atree(pf) + + (pfForin?)(pf) => + ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], + pf2Atree1 (pfForinWhole)(pf)] + + (pfWhile?)(pf) => + ["WHILE", pf2Atree1((pfWhileCond)(pf))] + + (pfSuchthat?)(pf) => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) + ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] + + (pfDo?)(pf) => + pf2Atree1 (pfDoBody)(pf) + +-- (pfTyped?)(pf) => +-- type := pfTypedType pf +-- pfNothing? type => pf2Atree1 pfTypedId pf +-- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] + + (pfAssign?)(pf) => + -- declarations on the lhs are broken out into another + -- statement preceding the LET of the id(s) + lhsThings := (pf0AssignLhsItems)(pf) + if #lhsThings = 1 and (pfTuple?)(first lhsThings) then + lhsThings := (pf0TupleParts)(first lhsThings) + decls := nil + ids := nil + for x in lhsThings repeat + (pfTagged?)(x) => + decls := [x, :decls] + ids := [(pfTaggedTag)(x), :ids] + ids := [x, :ids] + idList := [pf2Atree1 x for x in reverse ids] + if #idList ^= 1 then idList := + [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] + else idList := first idList + x := [mkAtreeNodeWithSrcPos("LET",pf), + idList, pf2Atree1 (pfAssignRhs)(pf)] + decls => + [mkAtreeNodeWithSrcPos("SEQ",pf), + :[pf2Atree1 decl for decl in nreverse decls], x] + x + +-- (pfDefinition?)(pf) => +-- pfDefinition2Atree pf + +-- (pfLambda?)(pf) => +-- pfLambda2Atree pf +-- (pfRestrict?)(pf) => +-- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] + + (pfFree?)(pf) => + [mkAtreeNodeWithSrcPos("free",pf), + :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] + (pfLocal?)(pf) => + [mkAtreeNodeWithSrcPos("local",pf), + :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] + + (pfWrong?)(pf) => + spadThrow() + + -- next 3 are probably be handled in pfApplication2Atree + + (pfAnd?)(pf) => + [mkAtreeNodeWithSrcPos("and",pf), + pf2Atree1 (pfAndLeft)(pf), + pf2Atree1 (pfAndRight)(pf)] + (pfOr?)(pf) => + [mkAtreeNodeWithSrcPos("or",pf), + pf2Atree1 (pfOrLeft)(pf), + pf2Atree1 (pfOrRight)(pf)] + (pfNot?)(pf) => + [mkAtreeNodeWithSrcPos("not",pf), + pf2Atree1 (pfNotArg)(pf)] + +-- (pfNovalue?)(pf) => +-- intSetQuiet() +-- ["SEQ", pf2Atree1 pfNovalueExpr pf] +-- (pfRule?)(pf) => +-- pfRule2Atree pf + + (pfBreak?)(pf) => + [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] + + (pfMacro?)(pf) => + tree := mkAtree1WithSrcPos('(void), pf) + putValue(tree,objNewWrap(voidValue(),$Void)) + putModeSet(tree,[$Void]) + tree + + (pfReturn?)(pf) => + [mkAtreeNodeWithSrcPos("return",pf), + pf2Atree1 (pfReturnExpr)(pf)] + + (pfIterate?)(pf) => + [mkAtreeNodeWithSrcPos("iterate",pf)] + +-- (pfWhere?)(pf) => +-- args := [pf2Atree1 p for p in pf0WhereContext pf] +-- #args = 1 => +-- ["where", pf2Atree1 pfWhereExpr pf, :args] +-- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] + + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + +-- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) +-- + +pfApplication2Atree pf == + $insideApplication: local := true + ($insideApplication): local := true + + opPf := (pfApplicationOp)(pf) + op := packageTran ((opTran)(pfOp2Sex)(opPf)) + op = "->" => + args := (pf0TupleParts)((pfApplicationArg)(pf)) + if (pfTuple?)(CAR args) then + typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] + else + typeList := [pf2Atree1 CAR args] + args := [pf2Atree1 CADR args, :typeList] + [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] + + (symEqual)(op, '":") and $insideRule = 'left => + [mkAtreeNodeWithSrcPos("multiple",opPf), + pf2Atree (pfApplicationArg)(pf)] + + (symEqual)(op, '"?") and $insideRule = 'left => + [mkAtreeNodeWithSrcPos("optional",opPf), + pf2Atree (pfApplicationArg)(pf)] + + args := (pfApplicationArg)(pf) + + (pfTuple?)(args) => +--! symEqual(op, '"|") and $insideRule = 'left => +--! pfSuchThat2Atree args + argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] + + (symEqual)(op, '">") => + [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] + (symEqual)(op, '">=") => + [mkAtreeNodeWithSrcPos("not",opPf), + [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] + (symEqual)(op, '"<=") => + [mkAtreeNodeWithSrcPos("not",opPf), + [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] + (symEqual)(op, '"AND") => + [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] + (symEqual)(op, '"OR") => + [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] + (symEqual) (op, '"Iterate") => + [mkAtreeNodeWithSrcPos("iterate",opPf)] + (symEqual)(op, '"by") => + [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] + (symEqual)(op, '"braceFromCurly") => + argAtree and getUnname first argAtree = "SEQ" => argAtree + [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] + op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => + [mkAtreeNodeWithSrcPos("applyQuote",opPf), + mkAtreeNodeWithSrcPos(op,opPf), :argAtree] +--! val := (hasOptArgs?)(argSex) => [op, :val] + -- handle package call + (pfFromdom?)(opPf) => + opAtree := pf2Atree1 opPf + [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] + -- regular call + [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] + + op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => + [mkAtreeNodeWithSrcPos("applyQuote",opPf), + mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] + (symEqual)(op, '"braceFromCurly") => + x := pf2Atree1 args + x and getUnname x = "SEQ" => x + [mkAtreeNodeWithSrcPos("SEQ",opPf), x] + (symEqual)(op, '"by") => + [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] + -- handle package call + (pfFromdom?)(opPf) => + opAtree := pf2Atree1 opPf + [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] + -- regular call + [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] + +-- pfDefinition2Atree pf == +-- --! $insideApplication => +-- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, +-- --! pf2Atree1 pfDefinitionRhs pf] +-- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] +-- #idList ^= 1 => +-- systemError '"lhs of definition must be a single item in the interpreter" +-- id := first idList +-- rhs := (pfDefinitionRhs)(pf) +-- [argList, :body] := pfLambdaTran rhs +-- ["DEF", (argList = 'id => id; [id, :argList]), :body] + +-- pfLambdaTran pf == +-- pfLambda? pf => +-- argTypeList := nil +-- argList := nil +-- for arg in pf0LambdaArgs pf repeat +-- pfTyped? arg => +-- argList := [pfCollectArgTran pfTypedId arg, :argList] +-- pfNothing? pfTypedType arg => +-- argTypeList := [nil, :argTypeList] +-- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] +-- systemError '"definition args should be typed" +-- argList := nreverse argList +-- retType := +-- pfNothing? pfLambdaRets pf => nil +-- pf2Atree1 pfLambdaRets pf +-- argTypeList := [retType, :nreverse argTypeList] +-- [argList, :[argTypeList, [nil for arg in argTypeList], +-- pf2Atree1 pfLambdaBody pf]] +-- ['id, :['(()), '(()), pf2Atree1 pf]] +-- +-- pfLambda2Atree pf == +-- [argList, :body] := pfLambdaTran pf +-- ["ADEF", argList, :body] +-- +-- pfCollectArgTran pf == +-- pfCollect? pf => +-- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] +-- id := pf2Atree1 pfCollectBody pf +-- conds is [["|", cond]] => +-- ["|", id, cond] +-- [id, :conds] +-- pf2Atree1 pf +-- + +pfSequence2Atree pf == + $insideSEQ: local := true + ($insideSEQ): local := true + + seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) + seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) + seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + [mkAtreeNodeWithSrcPos("ruleset",pf), + [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] + seq + +pfSequence2Atree0(seqList, pf) == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => + item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, + pfSequence2Atree0(rest seqList, pf)] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] + +-- +-- float2Atree num == +-- eIndex := SEARCH('"e", num) +-- mantPart := +-- eIndex => SUBSEQ(num, 0, eIndex) +-- num +-- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) +-- dotIndex := SEARCH('".", mantPart) +-- intPart := +-- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) +-- READ_-FROM_-STRING mantPart +-- fracPartString := +-- dotIndex => SUBSEQ(mantPart, dotIndex+1) +-- '"0" +-- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, +-- LENGTH fracPartString, expPart) +-- [., frac, :exp] := bfForm +-- [["$elt", intNewFloat(), 'float], frac, exp, 10] +-- + +loopIters2Atree iterList == + -- could probably do a better job of getting accurate SrcPos info onto parts + result := nil + for iter in iterList repeat + -- ON and UNTIL forms are no longer supported + sex := pf2Sexpr(iter) + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(incr, iter)] + result := [newIter, :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] + result := [newIter, :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] + result := [newIter, :result] + sex is ['IN, var, s] => + newIter := ["IN", var, mkAtree1 s] + result := [newIter, :result] + result := [pf2Atree1(iter), :result] + nreverse result + +pfCollect2Atree pf == + atree := [mkAtree1WithSrcPos("COLLECT",pf), + :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), + pf2Atree1 (pfCollectBody)(pf)] + + -- next are for what appears to a parser screw-up + sex := ["COLLECT", + :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), + pf2Sexpr (pfCollectBody)(pf)] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + [., [., condAtree], varAtree] := atree + ["SUCHTHAT", varAtree, condAtree] + + atree + +-- +-- pfRule2Atree pf == +-- $quotedOpList:local := nil +-- $predicateList:local := nil +-- $multiVarPredicateList:local := nil +-- lhs := pfLhsRule2Atree pfRuleLhsItems pf +-- rhs := pfRhsRule2Atree pfRuleRhs pf +-- lhs := ruleLhsTran lhs +-- rulePredicateTran +-- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] +-- ["rule", lhs, rhs] +-- +-- +-- ruleLhsTran ruleLhs == +-- for pred in $predicateList repeat +-- [name, predLhs, :predRhs] := pred +-- vars := patternVarsOf predRhs +-- CDR vars => -- if there is more than one patternVariable +-- ruleLhs := NSUBST(predLhs, name, ruleLhs) +-- $multiVarPredicateList := [pred, :$multiVarPredicateList] +-- predicate := +-- [., var] := predLhs +-- ["suchThat", predLhs, ["ADEF", [var], +-- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] +-- ruleLhs := NSUBST(predicate, name, ruleLhs) +-- ruleLhs +-- +-- rulePredicateTran rule == +-- null $multiVarPredicateList => rule +-- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] +-- predBody := +-- CDR $multiVarPredicateList => +-- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in +-- $multiVarPredicateList]] +-- [[.,.,:rhs],:.] := $multiVarPredicateList +-- pvarPredTran(rhs, varList) +-- ['suchThat, rule, +-- ['construct, :[["QUOTE", var] for var in varList]], +-- ['ADEF, '(predicateVariable), +-- '((Boolean) (List (Expression (Integer)))), '(() ()), +-- predBody]] +-- +-- pvarPredTran(rhs, varList) == +-- for var in varList for i in 1.. repeat +-- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) +-- rhs +-- +-- patternVarsOf expr == +-- patternVarsOf1(expr, nil) +-- +-- patternVarsOf1(expr, varList) == +-- NULL expr => varList +-- ATOM expr => +-- null SYMBOLP expr => varList +-- SymMemQ(expr, varList) => varList +-- [expr, :varList] +-- expr is [op, :argl] => +-- for arg in argl repeat +-- varList := patternVarsOf1(arg, varList) +-- varList +-- varList +-- +-- pfLhsRule2Atree lhs == +-- $insideRule: local := 'left +-- ($insideRule): local := 'left +-- pf2Atree1 lhs +-- +-- +-- pfRhsRule2Atree rhs == +-- $insideRule: local := 'right +-- ($insideRule): local := 'right +-- pf2Atree1 rhs +-- + +-- pfSuchThat2Atree args == +-- name := GENTEMP() +-- argList := pf0TupleParts args +-- lhsSex := pf2Atree1 CAR argList +-- rhsSex := pf2Atree CADR argList +-- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] +-- name diff --git a/src/interp/pf2atree.boot.pamphlet b/src/interp/pf2atree.boot.pamphlet deleted file mode 100644 index 29e85ad1..00000000 --- a/src/interp/pf2atree.boot.pamphlet +++ /dev/null @@ -1,575 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pf2atree.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. - -@ -<<*>>= -<> - --- not hooked in yet - --- BB parser tree to interpreter vectorized attributed trees. --- Used to interface the BB parser --- technology to the interpreter. The input is a parseTree and the --- output is an interpreter attributed tree. - -SETANDFILEQ($useParserSrcPos, true) -SETANDFILEQ($transferParserSrcPos, true) - -pf2Sexpr pf == packageTran (pf2Sex1)(pf) - -pf2Atree pf == - (intUnsetQuiet)() - - $insideRule: local := false - $insideApplication: local := false - $insideSEQ: local := false - - -- we set the following because we will be using some things - -- within pf2sex.boot and they are in the spadcomp package. - - ($insideRule): local := false - ($insideApplication): local := false - ($insideSEQ): local := false - - pf2Atree1 pf - -pf2Atree1 pf == - -- some simple things that are really just S-expressions - - (pfNothing?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfSymbol?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfLiteral?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfId?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - - -- Now some compound forms - - (pfApplication?)(pf) => - pfApplication2Atree pf - - (pfTuple?)(pf) => - [mkAtreeNodeWithSrcPos("Tuple",pf), - :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] - - (pfIf?)(pf) => - condPf := (pfIfCond)(pf) - condPart := pf2Atree1 condPf - thenPart := pf2Atree1 (pfIfThen)(pf) - elsePart := pf2Atree1 (pfIfElse)(pf) - ifPart := mkAtreeNodeWithSrcPos("IF", pf) - thenPart = "noBranch" => - [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], - elsePart, thenPart] - [ifPart, condPart, thenPart, elsePart] - - (pfTagged?)(pf) => - tag := (pfTaggedTag)(pf) - tagPart := - (pfTuple?) tag => - ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] - pf2Sexpr(tag) - [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, - pf2Sexpr((pfTaggedExpr)(pf))] - - (pfCoerceto?)(pf) => - [mkAtreeNodeWithSrcPos("COERCE",pf), - pf2Atree1 (pfCoercetoExpr)(pf), - pf2Sexpr((pfCoercetoType)(pf))] - - (pfPretend?)(pf) => - [mkAtreeNodeWithSrcPos("pretend",pf), - pf2Atree1 (pfPretendExpr)(pf), - pf2Sexpr((pfPretendType)(pf))] - - (pfFromdom?)(pf) => - op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) - if op = "braceFromCurly" then op := "SEQ" -- ?? - - op = 0 => - -- 0$Foo => Zero()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("Zero",pf)]] - op = 1 => - -- 1$Foo => One()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]] - INTEGERP op => - -- n$Foo => n * One()$Foo - [mkAtreeNodeWithSrcPos("*",pf), - mkAtree1WithSrcPos(op,pf), - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]]] - - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - mkAtreeNodeWithSrcPos(op,pf)] - - (pfSequence?)(pf) => - pfSequence2Atree pf - - (pfExit?)(pf) => - $insideSEQ => - [mkAtreeNodeWithSrcPos("exit",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf)] - [mkAtreeNodeWithSrcPos("IF",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf), "noBranch"] - - (pfLoop?)(pf) => - [mkAtreeNodeWithSrcPos("REPEAT",pf), - :loopIters2Atree (pf0LoopIterators)(pf)] - - (pfCollect?)(pf) => - pfCollect2Atree(pf) - - (pfForin?)(pf) => - ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], - pf2Atree1 (pfForinWhole)(pf)] - - (pfWhile?)(pf) => - ["WHILE", pf2Atree1((pfWhileCond)(pf))] - - (pfSuchthat?)(pf) => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) - ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] - - (pfDo?)(pf) => - pf2Atree1 (pfDoBody)(pf) - --- (pfTyped?)(pf) => --- type := pfTypedType pf --- pfNothing? type => pf2Atree1 pfTypedId pf --- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] - - (pfAssign?)(pf) => - -- declarations on the lhs are broken out into another - -- statement preceding the LET of the id(s) - lhsThings := (pf0AssignLhsItems)(pf) - if #lhsThings = 1 and (pfTuple?)(first lhsThings) then - lhsThings := (pf0TupleParts)(first lhsThings) - decls := nil - ids := nil - for x in lhsThings repeat - (pfTagged?)(x) => - decls := [x, :decls] - ids := [(pfTaggedTag)(x), :ids] - ids := [x, :ids] - idList := [pf2Atree1 x for x in reverse ids] - if #idList ^= 1 then idList := - [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] - else idList := first idList - x := [mkAtreeNodeWithSrcPos("LET",pf), - idList, pf2Atree1 (pfAssignRhs)(pf)] - decls => - [mkAtreeNodeWithSrcPos("SEQ",pf), - :[pf2Atree1 decl for decl in nreverse decls], x] - x - --- (pfDefinition?)(pf) => --- pfDefinition2Atree pf - --- (pfLambda?)(pf) => --- pfLambda2Atree pf --- (pfRestrict?)(pf) => --- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] - - (pfFree?)(pf) => - [mkAtreeNodeWithSrcPos("free",pf), - :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] - (pfLocal?)(pf) => - [mkAtreeNodeWithSrcPos("local",pf), - :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] - - (pfWrong?)(pf) => - spadThrow() - - -- next 3 are probably be handled in pfApplication2Atree - - (pfAnd?)(pf) => - [mkAtreeNodeWithSrcPos("and",pf), - pf2Atree1 (pfAndLeft)(pf), - pf2Atree1 (pfAndRight)(pf)] - (pfOr?)(pf) => - [mkAtreeNodeWithSrcPos("or",pf), - pf2Atree1 (pfOrLeft)(pf), - pf2Atree1 (pfOrRight)(pf)] - (pfNot?)(pf) => - [mkAtreeNodeWithSrcPos("not",pf), - pf2Atree1 (pfNotArg)(pf)] - --- (pfNovalue?)(pf) => --- intSetQuiet() --- ["SEQ", pf2Atree1 pfNovalueExpr pf] --- (pfRule?)(pf) => --- pfRule2Atree pf - - (pfBreak?)(pf) => - [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] - - (pfMacro?)(pf) => - tree := mkAtree1WithSrcPos('(void), pf) - putValue(tree,objNewWrap(voidValue(),$Void)) - putModeSet(tree,[$Void]) - tree - - (pfReturn?)(pf) => - [mkAtreeNodeWithSrcPos("return",pf), - pf2Atree1 (pfReturnExpr)(pf)] - - (pfIterate?)(pf) => - [mkAtreeNodeWithSrcPos("iterate",pf)] - --- (pfWhere?)(pf) => --- args := [pf2Atree1 p for p in pf0WhereContext pf] --- #args = 1 => --- ["where", pf2Atree1 pfWhereExpr pf, :args] --- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] - - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - --- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) --- - -pfApplication2Atree pf == - $insideApplication: local := true - ($insideApplication): local := true - - opPf := (pfApplicationOp)(pf) - op := packageTran ((opTran)(pfOp2Sex)(opPf)) - op = "->" => - args := (pf0TupleParts)((pfApplicationArg)(pf)) - if (pfTuple?)(CAR args) then - typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] - else - typeList := [pf2Atree1 CAR args] - args := [pf2Atree1 CADR args, :typeList] - [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] - - (symEqual)(op, '":") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("multiple",opPf), - pf2Atree (pfApplicationArg)(pf)] - - (symEqual)(op, '"?") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("optional",opPf), - pf2Atree (pfApplicationArg)(pf)] - - args := (pfApplicationArg)(pf) - - (pfTuple?)(args) => ---! symEqual(op, '"|") and $insideRule = 'left => ---! pfSuchThat2Atree args - argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] - - (symEqual)(op, '">") => - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] - (symEqual)(op, '">=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] - (symEqual)(op, '"<=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] - (symEqual)(op, '"AND") => - [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] - (symEqual)(op, '"OR") => - [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] - (symEqual) (op, '"Iterate") => - [mkAtreeNodeWithSrcPos("iterate",opPf)] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] - (symEqual)(op, '"braceFromCurly") => - argAtree and getUnname first argAtree = "SEQ" => argAtree - [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), :argAtree] ---! val := (hasOptArgs?)(argSex) => [op, :val] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] - - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - (symEqual)(op, '"braceFromCurly") => - x := pf2Atree1 args - x and getUnname x = "SEQ" => x - [mkAtreeNodeWithSrcPos("SEQ",opPf), x] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - --- pfDefinition2Atree pf == --- --! $insideApplication => --- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, --- --! pf2Atree1 pfDefinitionRhs pf] --- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] --- #idList ^= 1 => --- systemError '"lhs of definition must be a single item in the interpreter" --- id := first idList --- rhs := (pfDefinitionRhs)(pf) --- [argList, :body] := pfLambdaTran rhs --- ["DEF", (argList = 'id => id; [id, :argList]), :body] - --- pfLambdaTran pf == --- pfLambda? pf => --- argTypeList := nil --- argList := nil --- for arg in pf0LambdaArgs pf repeat --- pfTyped? arg => --- argList := [pfCollectArgTran pfTypedId arg, :argList] --- pfNothing? pfTypedType arg => --- argTypeList := [nil, :argTypeList] --- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] --- systemError '"definition args should be typed" --- argList := nreverse argList --- retType := --- pfNothing? pfLambdaRets pf => nil --- pf2Atree1 pfLambdaRets pf --- argTypeList := [retType, :nreverse argTypeList] --- [argList, :[argTypeList, [nil for arg in argTypeList], --- pf2Atree1 pfLambdaBody pf]] --- ['id, :['(()), '(()), pf2Atree1 pf]] --- --- pfLambda2Atree pf == --- [argList, :body] := pfLambdaTran pf --- ["ADEF", argList, :body] --- --- pfCollectArgTran pf == --- pfCollect? pf => --- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] --- id := pf2Atree1 pfCollectBody pf --- conds is [["|", cond]] => --- ["|", id, cond] --- [id, :conds] --- pf2Atree1 pf --- - -pfSequence2Atree pf == - $insideSEQ: local := true - ($insideSEQ): local := true - - seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) - seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) - seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - [mkAtreeNodeWithSrcPos("ruleset",pf), - [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] - seq - -pfSequence2Atree0(seqList, pf) == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => - item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, - pfSequence2Atree0(rest seqList, pf)] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] - --- --- float2Atree num == --- eIndex := SEARCH('"e", num) --- mantPart := --- eIndex => SUBSEQ(num, 0, eIndex) --- num --- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) --- dotIndex := SEARCH('".", mantPart) --- intPart := --- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) --- READ_-FROM_-STRING mantPart --- fracPartString := --- dotIndex => SUBSEQ(mantPart, dotIndex+1) --- '"0" --- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, --- LENGTH fracPartString, expPart) --- [., frac, :exp] := bfForm --- [["$elt", intNewFloat(), 'float], frac, exp, 10] --- - -loopIters2Atree iterList == - -- could probably do a better job of getting accurate SrcPos info onto parts - result := nil - for iter in iterList repeat - -- ON and UNTIL forms are no longer supported - sex := pf2Sexpr(iter) - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter)] - result := [newIter, :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, s] => - newIter := ["IN", var, mkAtree1 s] - result := [newIter, :result] - result := [pf2Atree1(iter), :result] - nreverse result - -pfCollect2Atree pf == - atree := [mkAtree1WithSrcPos("COLLECT",pf), - :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), - pf2Atree1 (pfCollectBody)(pf)] - - -- next are for what appears to a parser screw-up - sex := ["COLLECT", - :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), - pf2Sexpr (pfCollectBody)(pf)] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - [., [., condAtree], varAtree] := atree - ["SUCHTHAT", varAtree, condAtree] - - atree - --- --- pfRule2Atree pf == --- $quotedOpList:local := nil --- $predicateList:local := nil --- $multiVarPredicateList:local := nil --- lhs := pfLhsRule2Atree pfRuleLhsItems pf --- rhs := pfRhsRule2Atree pfRuleRhs pf --- lhs := ruleLhsTran lhs --- rulePredicateTran --- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] --- ["rule", lhs, rhs] --- --- --- ruleLhsTran ruleLhs == --- for pred in $predicateList repeat --- [name, predLhs, :predRhs] := pred --- vars := patternVarsOf predRhs --- CDR vars => -- if there is more than one patternVariable --- ruleLhs := NSUBST(predLhs, name, ruleLhs) --- $multiVarPredicateList := [pred, :$multiVarPredicateList] --- predicate := --- [., var] := predLhs --- ["suchThat", predLhs, ["ADEF", [var], --- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] --- ruleLhs := NSUBST(predicate, name, ruleLhs) --- ruleLhs --- --- rulePredicateTran rule == --- null $multiVarPredicateList => rule --- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] --- predBody := --- CDR $multiVarPredicateList => --- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in --- $multiVarPredicateList]] --- [[.,.,:rhs],:.] := $multiVarPredicateList --- pvarPredTran(rhs, varList) --- ['suchThat, rule, --- ['construct, :[["QUOTE", var] for var in varList]], --- ['ADEF, '(predicateVariable), --- '((Boolean) (List (Expression (Integer)))), '(() ()), --- predBody]] --- --- pvarPredTran(rhs, varList) == --- for var in varList for i in 1.. repeat --- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) --- rhs --- --- patternVarsOf expr == --- patternVarsOf1(expr, nil) --- --- patternVarsOf1(expr, varList) == --- NULL expr => varList --- ATOM expr => --- null SYMBOLP expr => varList --- SymMemQ(expr, varList) => varList --- [expr, :varList] --- expr is [op, :argl] => --- for arg in argl repeat --- varList := patternVarsOf1(arg, varList) --- varList --- varList --- --- pfLhsRule2Atree lhs == --- $insideRule: local := 'left --- ($insideRule): local := 'left --- pf2Atree1 lhs --- --- --- pfRhsRule2Atree rhs == --- $insideRule: local := 'right --- ($insideRule): local := 'right --- pf2Atree1 rhs --- - --- pfSuchThat2Atree args == --- name := GENTEMP() --- argList := pf0TupleParts args --- lhsSex := pf2Atree1 CAR argList --- rhsSex := pf2Atree CADR argList --- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] --- name -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pf2sex.boot b/src/interp/pf2sex.boot new file mode 100644 index 00000000..da4c7b19 --- /dev/null +++ b/src/interp/pf2sex.boot @@ -0,0 +1,461 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +$dotdot := INTERN('"..", '"BOOT") +$specificMsgTags := nil + +-- Pftree to s-expression translation. Used to interface the new parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an old-parser-style s-expression + +pf2Sex pf == + intUnsetQuiet() + $insideRule:local := false + $insideApplication: local := false + $insideSEQ: local := false + pf2Sex1 pf + +pf2Sex1 pf == + pfNothing? pf => + "noBranch" + pfSymbol? pf => + $insideRule = 'left => + s := pfSymbolSymbol pf + ["constant", ["QUOTE", s]] + ["QUOTE", pfSymbolSymbol pf] + pfLiteral? pf => + pfLiteral2Sex pf + pfId? pf => + $insideRule => + s := pfIdSymbol pf + SymMemQ(s, '(%pi %e %i)) => s + ["QUOTE", s] + pfIdSymbol pf + pfApplication? pf => + pfApplication2Sex pf + pfTuple? pf => + ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] + pfIf? pf => + ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] + pfTagged? pf => + tag := pfTaggedTag pf + tagPart := + pfTuple? tag => + ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] + pf2Sex1 tag + [":", tagPart, pf2Sex1 pfTaggedExpr pf] + pfCoerceto? pf => + ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] + pfPretend? pf => + ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] + pfFromdom? pf => + op := opTran pf2Sex1 pfFromdomWhat pf +-- if op = "braceFromCurly" then op := "brace" + if op = "braceFromCurly" then op := "SEQ" + ["$elt", pf2Sex1 pfFromdomDomain pf, op] + pfSequence? pf => + pfSequence2Sex pf + pfExit? pf => + $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] + ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] + pfLoop? pf => + ["REPEAT", :loopIters2Sex pf0LoopIterators pf] + pfCollect? pf => + pfCollect2Sex pf + pfForin? pf => + ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] + pfWhile? pf => + ["WHILE", pf2Sex1 pfWhileCond pf] + pfSuchthat? pf => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) + ["|", pf2Sex1 pfSuchthatCond pf] + pfDo? pf => + pf2Sex1 pfDoBody pf + pfTyped? pf => + type := pfTypedType pf + pfNothing? type => pf2Sex1 pfTypedId pf + [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] + pfAssign? pf => + idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] + if #idList ^= 1 then idList := ['Tuple, :idList] + else idList := first idList + ["LET", idList, pf2Sex1 pfAssignRhs pf] + pfDefinition? pf => + pfDefinition2Sex pf + pfLambda? pf => + pfLambda2Sex pf + pfMLambda? pf => + "/throwAway" + pfRestrict? pf => + ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] + pfFree? pf => + ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] + pfLocal? pf => + ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] + pfWrong? pf => + spadThrow() + pfAnd? pf => + ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] + pfOr? pf => + ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] + pfNot? pf => + ["not", pf2Sex1 pfNotArg pf] + pfNovalue? pf => + intSetQuiet() + ["SEQ", pf2Sex1 pfNovalueExpr pf] + pfRule? pf => + pfRule2Sex pf + pfBreak? pf => + ["break", pfBreakFrom pf] + pfMacro? pf => + "/throwAway" + pfReturn? pf => + ["return", pf2Sex1 pfReturnExpr pf] + pfIterate? pf => + ["iterate"] + pfWhere? pf => + args := [pf2Sex1 p for p in pf0WhereContext pf] + #args = 1 => + ["where", pf2Sex1 pfWhereExpr pf, :args] + ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] + + -- under strange circumstances/piling, system commands can wind + -- up in expressions. This just passes it through as a string for + -- the user to figure out what happened. + pfAbSynOp(pf) = "command" => tokPart(pf) + + keyedSystemError('"S2GE0017", ['"pf2Sex1"]) + +pfLiteral2Sex pf == + type := pfLiteralClass pf + type = 'integer => + READ_-FROM_-STRING pfLiteralString pf + type = 'string or type = 'char => + pfLiteralString pf + type = 'float => + float2Sex pfLiteralString pf + type = 'symbol => + $insideRule => + s := pfSymbolSymbol pf + ["QUOTE", s] + pfSymbolSymbol pf + type = 'expression => + ["QUOTE", pfLeafToken pf] + keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) + +symEqual(sym, sym2) == EQ(sym, sym2) + +SymMemQ(sy, l) == MEMQ(sy, l) + +pmDontQuote? sy == + SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ + sin cos tan cot sec csc asin acos atan acot asec acsc _ + sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) + +pfOp2Sex pf == + alreadyQuoted := pfSymbol? pf + op := pf2Sex1 pf + op is ["QUOTE", realOp] => + $insideRule = 'left => realOp + $insideRule = 'right => + pmDontQuote? realOp => realOp + $quotedOpList := [op, :$quotedOpList] + op + symEqual(realOp, "|") => realOp + symEqual(realOp, ":") => realOp + symEqual(realOp, "?") => realOp + op + op + +pfApplication2Sex pf == + $insideApplication: local := true + op := pfOp2Sex pfApplicationOp pf + op := opTran op + op = "->" => + args := pf0TupleParts pfApplicationArg pf + if pfTuple? CAR args then + typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] + else + typeList := [pf2Sex1 CAR args] + args := [pf2Sex1 CADR args, :typeList] + ["Mapping", :args] + symEqual(op, ":") and $insideRule = 'left => + ["multiple", pf2Sex pfApplicationArg pf] + symEqual(op, "?") and $insideRule = 'left => + ["optional", pf2Sex pfApplicationArg pf] + args := pfApplicationArg pf + pfTuple? args => + symEqual(op, "|") and $insideRule = 'left => + pfSuchThat2Sex args + argSex := rest pf2Sex1 args + symEqual(op, ">") => + ["<", CADR argSex, CAR argSex] + symEqual(op, ">=") => + ["not", ["<", CAR argSex, CADR argSex]] + symEqual(op, "<=") => + ["not", ["<", CADR argSex, CAR argSex]] +-- symEqual(op, "reduce") and (#argSex) = 2 => +-- ["REDUCE", first argSex, 0, CADR argSex] + symEqual(op, "AND") => + ["and", CAR argSex, CADR argSex] + symEqual(op, "OR") => + ["or", CAR argSex, CADR argSex] + symEqual(op, "Iterate") => + ["iterate"] + symEqual(op, "by") => + ["BY", :argSex] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", :argSex]] + argSex is ["SEQ",:.] => argSex + ["SEQ", :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, :argSex] + val := hasOptArgs? argSex => [op, :val] + [op, :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, pf2Sex1 args] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", pf2Sex1 args]] + x := pf2Sex1 args + x is ["SEQ", :.] => x + ["SEQ", x] + symEqual(op, "by") => + ["BY", pf2Sex1 args] + [op, pf2Sex1 args] + +hasOptArgs? argSex == + nonOpt := nil + opt := nil + for arg in argSex repeat + arg is ["OPTARG", lhs, rhs] => + opt := [[lhs, rhs], :opt] + nonOpt := [arg, :nonOpt] + null opt => nil + NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) + +pfDefinition2Sex pf == + $insideApplication => + ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, + pf2Sex1 pfDefinitionRhs pf] + idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf] + #idList ^= 1 => + systemError '"lhs of definition must be a single item in the interpreter" + id := first idList + rhs := pfDefinitionRhs pf + [argList, :body] := pfLambdaTran rhs + ["DEF", (argList = 'id => id; [id, :argList]), :body] + +pfLambdaTran pf == + pfLambda? pf => + argTypeList := nil + argList := nil + for arg in pf0LambdaArgs pf repeat + pfTyped? arg => + argList := [pfCollectArgTran pfTypedId arg, :argList] + pfNothing? pfTypedType arg => + argTypeList := [nil, :argTypeList] + argTypeList := [pf2Sex1 pfTypedType arg, :argTypeList] + systemError '"definition args should be typed" + argList := nreverse argList + retType := + pfNothing? pfLambdaRets pf => nil + pf2Sex1 pfLambdaRets pf + argTypeList := [retType, :nreverse argTypeList] + [argList, :[argTypeList, [nil for arg in argTypeList], + pf2Sex1 pfLambdaBody pf]] + ['id, :['(()), '(()), pf2Sex1 pf]] + +pfLambda2Sex pf == + [argList, :body] := pfLambdaTran pf + ["ADEF", argList, :body] + +pfCollectArgTran pf == + pfCollect? pf => + conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] + id := pf2Sex1 pfCollectBody pf + conds is [["|", cond]] => + ["|", id, cond] + [id, :conds] + pf2Sex1 pf + +opTran op == + op = $dotdot => "SEGMENT" + op = "[]" => "construct" + op = "{}" => "braceFromCurly" + op = "IS" => "is" + op + +pfSequence2Sex pf == + $insideSEQ:local := true + seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] + seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + ["ruleset", ["construct", :ruleList]] + seq + +pfSequence2Sex0 seqList == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is ["exit", cond, value] => + item := ["IF", cond, value, pfSequence2Sex0 rest seqList] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + ["SEQ", :nreverse seqTranList] + +float2Sex num == + eIndex := SEARCH('"e", num) + mantPart := + eIndex => SUBSEQ(num, 0, eIndex) + num + expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) + dotIndex := SEARCH('".", mantPart) + intPart := + dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) + READ_-FROM_-STRING mantPart + fracPartString := + dotIndex => SUBSEQ(mantPart, dotIndex+1) + '"0" + bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, + LENGTH fracPartString, expPart) + $useBFasDefault => + [., frac, :exp] := bfForm + [["$elt", intNewFloat(), 'float], frac, exp, 10] + bfForm + +loopIters2Sex iterList == + result := nil + for iter in iterList repeat + sex := pf2Sex1 iter + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + result := [['STEP, var, i, incr], :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + result := [['STEP, var, i, incr, j], :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + result := [['STEP, var, i, 1, j], :result] + result := [sex, :result] + nreverse result + +pfCollect2Sex pf == + sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, + pf2Sex1 pfCollectBody pf] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + ["|", var, cond] + sex + +pfRule2Sex pf == + $quotedOpList:local := nil + $predicateList:local := nil + $multiVarPredicateList:local := nil + lhs := pfLhsRule2Sex pfRuleLhsItems pf + rhs := pfRhsRule2Sex pfRuleRhs pf + lhs := ruleLhsTran lhs + rulePredicateTran + $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] + ["rule", lhs, rhs] + + +ruleLhsTran ruleLhs == + for pred in $predicateList repeat + [name, predLhs, :predRhs] := pred + vars := patternVarsOf predRhs + CDR vars => -- if there is more than one patternVariable + ruleLhs := NSUBST(predLhs, name, ruleLhs) + $multiVarPredicateList := [pred, :$multiVarPredicateList] + predicate := + [., var] := predLhs + ["suchThat", predLhs, ["ADEF", [var], + '((Boolean) (Expression (Integer))), '(() ()), predRhs]] + ruleLhs := NSUBST(predicate, name, ruleLhs) + ruleLhs + +rulePredicateTran rule == + null $multiVarPredicateList => rule + varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] + predBody := + CDR $multiVarPredicateList => + ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in + $multiVarPredicateList]] + [[.,.,:rhs],:.] := $multiVarPredicateList + pvarPredTran(rhs, varList) + ['suchThat, rule, + ['construct, :[["QUOTE", var] for var in varList]], + ['ADEF, '(predicateVariable), + '((Boolean) (List (Expression (Integer)))), '(() ()), + predBody]] + +pvarPredTran(rhs, varList) == + for var in varList for i in 1.. repeat + rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) + rhs + +patternVarsOf expr == + patternVarsOf1(expr, nil) + +patternVarsOf1(expr, varList) == + NULL expr => varList + ATOM expr => + null SYMBOLP expr => varList + SymMemQ(expr, varList) => varList + [expr, :varList] + expr is [op, :argl] => + for arg in argl repeat + varList := patternVarsOf1(arg, varList) + varList + varList + +pfLhsRule2Sex lhs == + $insideRule: local := 'left + pf2Sex1 lhs + + +pfRhsRule2Sex rhs == + $insideRule: local := 'right + pf2Sex1 rhs + +pfSuchThat2Sex args == + name := GENTEMP() + argList := pf0TupleParts args + lhsSex := pf2Sex1 CAR argList + rhsSex := pf2Sex CADR argList + $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] + name + + + + diff --git a/src/interp/pf2sex.boot.pamphlet b/src/interp/pf2sex.boot.pamphlet deleted file mode 100644 index a5ea9b6e..00000000 --- a/src/interp/pf2sex.boot.pamphlet +++ /dev/null @@ -1,526 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pf2sex.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{Changes} -In the function [[float2Sex]] we need to special case the return value -if the global variable [[$useBFasDefault]] is set to true. This variable -allows ``big'' floating point values. - -The change can be seen from this email from Greg Vanuxem: -\begin{verbatim} -Attached is the patch (pf2sex.patch) that allows the use -of DoubleFloat by default in the interpreter. Test it. - -(1) -> 1.7+7.2 - - (1) 8.9 - Type: Float -(2) -> 1.7-7.2 - - (2) - 5.5 - Type: Float -(3) -> -1.7-7.2 - - (3) - 8.9 - Type: Float -(4) -> )boot $useBFasDefault:=false - -(SPADLET |$useBFasDefault| NIL) -Value = NIL - -(4) -> 1.7+7.2 - - (4) 8.9000000000000004 - Type: DoubleFloat -(5) -> 1.7-7.2 - - (5) - 5.5 - Type: DoubleFloat -(6) -> -1.7-7.2 - - (6) - 8.9000000000000004 - Type: DoubleFloat - - - -\end{verbatim} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - -$dotdot := INTERN('"..", '"BOOT") -$specificMsgTags := nil - --- Pftree to s-expression translation. Used to interface the new parser --- technology to the interpreter. The input is a parseTree and the --- output is an old-parser-style s-expression - -pf2Sex pf == - intUnsetQuiet() - $insideRule:local := false - $insideApplication: local := false - $insideSEQ: local := false - pf2Sex1 pf - -pf2Sex1 pf == - pfNothing? pf => - "noBranch" - pfSymbol? pf => - $insideRule = 'left => - s := pfSymbolSymbol pf - ["constant", ["QUOTE", s]] - ["QUOTE", pfSymbolSymbol pf] - pfLiteral? pf => - pfLiteral2Sex pf - pfId? pf => - $insideRule => - s := pfIdSymbol pf - SymMemQ(s, '(%pi %e %i)) => s - ["QUOTE", s] - pfIdSymbol pf - pfApplication? pf => - pfApplication2Sex pf - pfTuple? pf => - ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] - pfIf? pf => - ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] - pfTagged? pf => - tag := pfTaggedTag pf - tagPart := - pfTuple? tag => - ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] - pf2Sex1 tag - [":", tagPart, pf2Sex1 pfTaggedExpr pf] - pfCoerceto? pf => - ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] - pfPretend? pf => - ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] - pfFromdom? pf => - op := opTran pf2Sex1 pfFromdomWhat pf --- if op = "braceFromCurly" then op := "brace" - if op = "braceFromCurly" then op := "SEQ" - ["$elt", pf2Sex1 pfFromdomDomain pf, op] - pfSequence? pf => - pfSequence2Sex pf - pfExit? pf => - $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] - ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] - pfLoop? pf => - ["REPEAT", :loopIters2Sex pf0LoopIterators pf] - pfCollect? pf => - pfCollect2Sex pf - pfForin? pf => - ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] - pfWhile? pf => - ["WHILE", pf2Sex1 pfWhileCond pf] - pfSuchthat? pf => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) - ["|", pf2Sex1 pfSuchthatCond pf] - pfDo? pf => - pf2Sex1 pfDoBody pf - pfTyped? pf => - type := pfTypedType pf - pfNothing? type => pf2Sex1 pfTypedId pf - [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] - pfAssign? pf => - idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] - if #idList ^= 1 then idList := ['Tuple, :idList] - else idList := first idList - ["LET", idList, pf2Sex1 pfAssignRhs pf] - pfDefinition? pf => - pfDefinition2Sex pf - pfLambda? pf => - pfLambda2Sex pf - pfMLambda? pf => - "/throwAway" - pfRestrict? pf => - ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] - pfFree? pf => - ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] - pfLocal? pf => - ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] - pfWrong? pf => - spadThrow() - pfAnd? pf => - ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] - pfOr? pf => - ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] - pfNot? pf => - ["not", pf2Sex1 pfNotArg pf] - pfNovalue? pf => - intSetQuiet() - ["SEQ", pf2Sex1 pfNovalueExpr pf] - pfRule? pf => - pfRule2Sex pf - pfBreak? pf => - ["break", pfBreakFrom pf] - pfMacro? pf => - "/throwAway" - pfReturn? pf => - ["return", pf2Sex1 pfReturnExpr pf] - pfIterate? pf => - ["iterate"] - pfWhere? pf => - args := [pf2Sex1 p for p in pf0WhereContext pf] - #args = 1 => - ["where", pf2Sex1 pfWhereExpr pf, :args] - ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] - - -- under strange circumstances/piling, system commands can wind - -- up in expressions. This just passes it through as a string for - -- the user to figure out what happened. - pfAbSynOp(pf) = "command" => tokPart(pf) - - keyedSystemError('"S2GE0017", ['"pf2Sex1"]) - -pfLiteral2Sex pf == - type := pfLiteralClass pf - type = 'integer => - READ_-FROM_-STRING pfLiteralString pf - type = 'string or type = 'char => - pfLiteralString pf - type = 'float => - float2Sex pfLiteralString pf - type = 'symbol => - $insideRule => - s := pfSymbolSymbol pf - ["QUOTE", s] - pfSymbolSymbol pf - type = 'expression => - ["QUOTE", pfLeafToken pf] - keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) - -symEqual(sym, sym2) == EQ(sym, sym2) - -SymMemQ(sy, l) == MEMQ(sy, l) - -pmDontQuote? sy == - SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ - sin cos tan cot sec csc asin acos atan acot asec acsc _ - sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) - -pfOp2Sex pf == - alreadyQuoted := pfSymbol? pf - op := pf2Sex1 pf - op is ["QUOTE", realOp] => - $insideRule = 'left => realOp - $insideRule = 'right => - pmDontQuote? realOp => realOp - $quotedOpList := [op, :$quotedOpList] - op - symEqual(realOp, "|") => realOp - symEqual(realOp, ":") => realOp - symEqual(realOp, "?") => realOp - op - op - -pfApplication2Sex pf == - $insideApplication: local := true - op := pfOp2Sex pfApplicationOp pf - op := opTran op - op = "->" => - args := pf0TupleParts pfApplicationArg pf - if pfTuple? CAR args then - typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] - else - typeList := [pf2Sex1 CAR args] - args := [pf2Sex1 CADR args, :typeList] - ["Mapping", :args] - symEqual(op, ":") and $insideRule = 'left => - ["multiple", pf2Sex pfApplicationArg pf] - symEqual(op, "?") and $insideRule = 'left => - ["optional", pf2Sex pfApplicationArg pf] - args := pfApplicationArg pf - pfTuple? args => - symEqual(op, "|") and $insideRule = 'left => - pfSuchThat2Sex args - argSex := rest pf2Sex1 args - symEqual(op, ">") => - ["<", CADR argSex, CAR argSex] - symEqual(op, ">=") => - ["not", ["<", CAR argSex, CADR argSex]] - symEqual(op, "<=") => - ["not", ["<", CADR argSex, CAR argSex]] --- symEqual(op, "reduce") and (#argSex) = 2 => --- ["REDUCE", first argSex, 0, CADR argSex] - symEqual(op, "AND") => - ["and", CAR argSex, CADR argSex] - symEqual(op, "OR") => - ["or", CAR argSex, CADR argSex] - symEqual(op, "Iterate") => - ["iterate"] - symEqual(op, "by") => - ["BY", :argSex] - symEqual(op, "braceFromCurly") => --- ["brace", ["construct", :argSex]] - argSex is ["SEQ",:.] => argSex - ["SEQ", :argSex] - op is [qt, realOp] and symEqual(qt, "QUOTE") => - ["applyQuote", op, :argSex] - val := hasOptArgs? argSex => [op, :val] - [op, :argSex] - op is [qt, realOp] and symEqual(qt, "QUOTE") => - ["applyQuote", op, pf2Sex1 args] - symEqual(op, "braceFromCurly") => --- ["brace", ["construct", pf2Sex1 args]] - x := pf2Sex1 args - x is ["SEQ", :.] => x - ["SEQ", x] - symEqual(op, "by") => - ["BY", pf2Sex1 args] - [op, pf2Sex1 args] - -hasOptArgs? argSex == - nonOpt := nil - opt := nil - for arg in argSex repeat - arg is ["OPTARG", lhs, rhs] => - opt := [[lhs, rhs], :opt] - nonOpt := [arg, :nonOpt] - null opt => nil - NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) - -pfDefinition2Sex pf == - $insideApplication => - ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, - pf2Sex1 pfDefinitionRhs pf] - idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf] - #idList ^= 1 => - systemError '"lhs of definition must be a single item in the interpreter" - id := first idList - rhs := pfDefinitionRhs pf - [argList, :body] := pfLambdaTran rhs - ["DEF", (argList = 'id => id; [id, :argList]), :body] - -pfLambdaTran pf == - pfLambda? pf => - argTypeList := nil - argList := nil - for arg in pf0LambdaArgs pf repeat - pfTyped? arg => - argList := [pfCollectArgTran pfTypedId arg, :argList] - pfNothing? pfTypedType arg => - argTypeList := [nil, :argTypeList] - argTypeList := [pf2Sex1 pfTypedType arg, :argTypeList] - systemError '"definition args should be typed" - argList := nreverse argList - retType := - pfNothing? pfLambdaRets pf => nil - pf2Sex1 pfLambdaRets pf - argTypeList := [retType, :nreverse argTypeList] - [argList, :[argTypeList, [nil for arg in argTypeList], - pf2Sex1 pfLambdaBody pf]] - ['id, :['(()), '(()), pf2Sex1 pf]] - -pfLambda2Sex pf == - [argList, :body] := pfLambdaTran pf - ["ADEF", argList, :body] - -pfCollectArgTran pf == - pfCollect? pf => - conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] - id := pf2Sex1 pfCollectBody pf - conds is [["|", cond]] => - ["|", id, cond] - [id, :conds] - pf2Sex1 pf - -opTran op == - op = $dotdot => "SEGMENT" - op = "[]" => "construct" - op = "{}" => "braceFromCurly" - op = "IS" => "is" - op - -pfSequence2Sex pf == - $insideSEQ:local := true - seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] - seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - ["ruleset", ["construct", :ruleList]] - seq - -pfSequence2Sex0 seqList == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is ["exit", cond, value] => - item := ["IF", cond, value, pfSequence2Sex0 rest seqList] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - ["SEQ", :nreverse seqTranList] - -float2Sex num == - eIndex := SEARCH('"e", num) - mantPart := - eIndex => SUBSEQ(num, 0, eIndex) - num - expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) - dotIndex := SEARCH('".", mantPart) - intPart := - dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) - READ_-FROM_-STRING mantPart - fracPartString := - dotIndex => SUBSEQ(mantPart, dotIndex+1) - '"0" - bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, - LENGTH fracPartString, expPart) - $useBFasDefault => - [., frac, :exp] := bfForm - [["$elt", intNewFloat(), 'float], frac, exp, 10] - bfForm - -loopIters2Sex iterList == - result := nil - for iter in iterList repeat - sex := pf2Sex1 iter - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - result := [['STEP, var, i, incr], :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - result := [['STEP, var, i, incr, j], :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - result := [['STEP, var, i, 1, j], :result] - result := [sex, :result] - nreverse result - -pfCollect2Sex pf == - sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, - pf2Sex1 pfCollectBody pf] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - ["|", var, cond] - sex - -pfRule2Sex pf == - $quotedOpList:local := nil - $predicateList:local := nil - $multiVarPredicateList:local := nil - lhs := pfLhsRule2Sex pfRuleLhsItems pf - rhs := pfRhsRule2Sex pfRuleRhs pf - lhs := ruleLhsTran lhs - rulePredicateTran - $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] - ["rule", lhs, rhs] - - -ruleLhsTran ruleLhs == - for pred in $predicateList repeat - [name, predLhs, :predRhs] := pred - vars := patternVarsOf predRhs - CDR vars => -- if there is more than one patternVariable - ruleLhs := NSUBST(predLhs, name, ruleLhs) - $multiVarPredicateList := [pred, :$multiVarPredicateList] - predicate := - [., var] := predLhs - ["suchThat", predLhs, ["ADEF", [var], - '((Boolean) (Expression (Integer))), '(() ()), predRhs]] - ruleLhs := NSUBST(predicate, name, ruleLhs) - ruleLhs - -rulePredicateTran rule == - null $multiVarPredicateList => rule - varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] - predBody := - CDR $multiVarPredicateList => - ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in - $multiVarPredicateList]] - [[.,.,:rhs],:.] := $multiVarPredicateList - pvarPredTran(rhs, varList) - ['suchThat, rule, - ['construct, :[["QUOTE", var] for var in varList]], - ['ADEF, '(predicateVariable), - '((Boolean) (List (Expression (Integer)))), '(() ()), - predBody]] - -pvarPredTran(rhs, varList) == - for var in varList for i in 1.. repeat - rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) - rhs - -patternVarsOf expr == - patternVarsOf1(expr, nil) - -patternVarsOf1(expr, varList) == - NULL expr => varList - ATOM expr => - null SYMBOLP expr => varList - SymMemQ(expr, varList) => varList - [expr, :varList] - expr is [op, :argl] => - for arg in argl repeat - varList := patternVarsOf1(arg, varList) - varList - varList - -pfLhsRule2Sex lhs == - $insideRule: local := 'left - pf2Sex1 lhs - - -pfRhsRule2Sex rhs == - $insideRule: local := 'right - pf2Sex1 rhs - -pfSuchThat2Sex args == - name := GENTEMP() - argList := pf0TupleParts args - lhsSex := pf2Sex1 CAR argList - rhsSex := pf2Sex CADR argList - $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] - name - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot new file mode 100644 index 00000000..c5a3619d --- /dev/null +++ b/src/interp/postpar.boot @@ -0,0 +1,529 @@ +-- 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 '"postprop" +)package "BOOT" + +$postStack := [] + +--% Yet Another Parser Transformation File +--These functions are used by for BOOT and SPAD code +--(see new2OldLisp, e.g.) + +postTransform y == + x:= y + u:= postTran x + if u is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) then u:= + [":",["LISTOF",:l,y],t] + postTransformCheck u + aplTran u + +displayPreCompilationErrors() == + n:= #($postStack:= REMDUP NREVERSE $postStack) + n=0 => nil + errors:= + 1 '"errors" + '"error" + if $InteractiveMode + then sayBrightly ['" Semantic ",errors,'" detected: "] + else + heading:= + $topOp ^= '$topOp => ['" ",$topOp,'" has"] + ['" You have"] + sayBrightly [:heading,'%b,n,'%d,'"precompilation ",errors,'":"] + if 1 + postAtom x + op := first x + SYMBOLP op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) + op is ["elt",a,b] => + u:= postTran [b,:rest x] + [postTran op,:rest u] + op is ["Scripts",:.] => + postScriptsForm(op,"append"/[unTuple postTran y for y in rest x]) + op^=(y:= postOp op) => [y,:postTranList rest x] + postForm x + +postTranList x == [postTran y for y in x] + +postBigFloat x == + [.,mant,:expon] := x + $BOOT => INT2RNUM(mant) * INT2RNUM(10) ** expon + eltword := if $InteractiveMode then "$elt" else "elt" + postTran [[eltword,'(Float),"float"],[",",[",",mant,expon],10]] + +postAdd ["add",a,:b] == + null b => postCapsule a + ["add",postTran a,postCapsule first b] + +checkWarning msg == postError concat('"Parsing error: ",msg) + +checkWarningIndentation() == + checkWarning ['"Apparent indentation error following",:bright "add"] + +postCapsule x == + x isnt [op,:.] => checkWarningIndentation() + INTEGERP op or op = "==" => ["CAPSULE",postBlockItem x] + op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] + op = "if" => ["CAPSULE",postBlockItem x] + checkWarningIndentation() + +postQUOTE x == x + +postColon u == + u is [":",x] => [":",postTran x] + u is [":",x,y] => [":",postTran x,:postType y] + +postColonColon u == + -- for Lisp package calling + -- boot syntax is package::fun but probably need to parenthesize it + $BOOT and u is ["::",package,fun] => + INTERN(STRINGIMAGE fun, package) + postForm u + +postAtSign ["@",x,y] == ["@",postTran x,:postType y] + +postPretend ["pretend",x,y] == ["pretend",postTran x,:postType y] + +postConstruct u == + u is ["construct",b] => + a:= (b is [",",:.] => comma2Tuple b; b) + a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] + a is ["Tuple",:l] => + or/[x is [":",y] for x in l] => postMakeCons l + or/[x is ["SEGMENT",:.] for x in l] => tuple2List l + ["construct",:postTranList l] + ["construct",postTran a] + u + +postError msg == + BUMPERRORCOUNT 'precompilation + xmsg:= + $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg] + msg + $postStack:= [xmsg,:$postStack] + nil + +postMakeCons l == + null l => "nil" + l is [[":",a],:l'] => + l' => ["append",postTran a,postMakeCons l'] + postTran a + ["cons",postTran first l,postMakeCons rest l] + +postAtom x == + $BOOT => x + x=0 => '(Zero) + x=1 => '(One) + EQ(x,'T) => 'T_$ -- rename T in spad code to T$ + IDENTP x and GETDATABASE(x,'NILADIC) => LIST x + x + +postBlock ["Block",:l,x] == + ["SEQ",:postBlockItemList l,["exit",postTran x]] + +postBlockItemList l == [postBlockItem x for x in l] + +postBlockItem x == + x:= postTran x + x is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) => + [":",["LISTOF",:l,y],t] + x + +postCategory (u is ["CATEGORY",:l]) == + --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible + null l => u + op := + $insidePostCategoryIfTrue = true => "PROGN" + "CATEGORY" + [op,:[fn x for x in l]] where fn x == + $insidePostCategoryIfTrue: local := true + postTran x + +postComma u == postTuple comma2Tuple u + +comma2Tuple u == ["Tuple",:postFlatten(u,",")] + +postDef [defOp,lhs,rhs] == +--+ + lhs is ["macro",name] => postMDef ["==>",name,rhs] + + if not($BOOT) then recordHeaderDocumentation nil + if $maxSignatureLineNumber ^= 0 then + $docList := [["constructor",:$headerDocumentation],:$docList] + $maxSignatureLineNumber := 0 + --reset this for next constructor; see recordDocumentation + lhs:= postTran lhs + [form,targetType]:= + lhs is [":",:.] => rest lhs + [lhs,nil] + if null $InteractiveMode and atom form then form := LIST form + newLhs:= + atom form => form + [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] + [op,:postDefArgs argl] + argTypeList:= + atom form => nil + [(x is [":",.,t] => t; nil) for x in rest form] + typeList:= [targetType,:argTypeList] + if atom form then form := [form] + specialCaseForm := [nil for x in form] + ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] + +postDefArgs argl == + null argl => argl + argl is [[":",a],:b] => + b => postError + ['" Argument",:bright a,'"of indefinite length must be last"] + atom a or a is ["QUOTE",:.] => a + postError + ['" Argument",:bright a,'"of indefinite length must be a name"] + [first argl,:postDefArgs rest argl] + +postMDef(t) == + [.,lhs,rhs] := t + $InteractiveMode and not $BOOT => + lhs := postTran lhs + null IDENTP lhs => throwKeyedMsg("S2IP0001",NIL) + ["MDEF",lhs,NIL,NIL,postTran rhs] + lhs:= postTran lhs + [form,targetType]:= + lhs is [":",:.] => rest lhs + [lhs,nil] + form:= + atom form => LIST form + form + newLhs:= [(x is [":",a,:.] => a; x) for x in form] + typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] + ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] + +postElt (u is [.,a,b]) == + a:= postTran a + b is ["Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] + ["elt",a,postTran b] + +postExit ["=>",a,b] == ["IF",postTran a,["exit",postTran b],"noBranch"] + + +postFlatten(x,op) == + x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] + LIST x + +postForm (u is [op,:argl]) == + x:= + atom op => + argl':= postTranList argl + op':= + true=> op + $BOOT => op + GET(op,'Led) or GET(op,'Nud) or op = 'IN => op + numOfArgs:= (argl' is [["Tuple",:l]] => #l; 1) + INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) + [op',:argl'] + op is ["Scripts",:.] => [:postTran op,:postTranList argl] + u:= postTranList u + if u is [["Tuple",:.],:.] then + postError ['" ",:bright u, + '"is illegal because tuples cannot be applied_!",'%l, + '" Did you misuse infix dot?"] + u + x is [.,["Tuple",:y]] => [first x,:y] + x + +postQuote [.,a] == ["QUOTE",a] + +postScriptsForm(["Scripts",op,a],argl) == + [getScriptName(op,a,#argl),:postTranScripts a,:argl] + +postScripts ["Scripts",op,a] == + [getScriptName(op,a,0),:postTranScripts a] + +getScriptName(op,a,numberOfFunctionalArgs) == + if null IDENTP op then + postError ['" ",op,'" cannot have scripts"] + INTERNL("*",STRINGIMAGE numberOfFunctionalArgs, + decodeScripts a,PNAME op) + +postTranScripts a == + a is ["PrefixSC",b] => postTranScripts b + a is [";",:b] => "append"/[postTranScripts y for y in b] + a is [",",:b] => + ("append"/[fn postTran y for y in b]) where + fn x == + x is ["Tuple",:y] => y + LIST x + LIST postTran a + +decodeScripts a == + a is ["PrefixSC",b] => STRCONC(STRINGIMAGE 0,decodeScripts b) + a is [";",:b] => APPLX('STRCONC,[decodeScripts x for x in b]) + a is [",",:b] => + STRINGIMAGE fn a where fn a == (a is [",",:b] => +/[fn x for x in b]; 1) + STRINGIMAGE 1 + +postIf t == + t isnt ["if",:l] => t + ["IF",:[(null (x:= postTran x) and null $BOOT => "noBranch"; x) + for x in l]] + +postJoin ["Join",a,:l] == + a:= postTran a + l:= postTranList l + if l is [b] and b is [name,:.] and MEMQ(name,'(ATTRIBUTE SIGNATURE)) then l + := LIST ["CATEGORY",b] + al:= + a is ["Tuple",:c] => c + LIST a + ["Join",:al,:l] + +postMapping u == + u isnt ["->",source,target] => u + ["Mapping",postTran target,:unTuple postTran source] + +postOp x == + x=":=" => + $BOOT => "SPADLET" + "LET" + x=":-" => "LETD" + x="Attribute" => "ATTRIBUTE" + x + +postRepeat ["REPEAT",:m,x] == ["REPEAT",:postIteratorList m,postTran x] + +postSEGMENT ["SEGMENT",a,b] == + key:= [a,'"..",:(b => [b]; nil)] + postError ['" Improper placement of segment",:bright key] + +postCollect [constructOp,:m,x] == + x is [["elt",D,"construct"],:y] => + postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] + itl:= postIteratorList m + x:= (x is ["construct",r] => r; x) --added 84/8/31 + y:= postTran x + finish(constructOp,itl,y) where + finish(op,itl,y) == + y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] + y is ["Tuple",:l] => + newBody:= + or/[x is [":",y] for x in l] => postMakeCons l + or/[x is ["SEGMENT",:.] for x in l] => tuple2List l + ["construct",:postTranList l] + ["REDUCE","append",0,[op,:itl,newBody]] + [op,:itl,y] + +postTupleCollect [constructOp,:m,x] == + postCollect [constructOp,:m,["construct",x]] + +postIteratorList x == + x is [p,:l] => + (p:= postTran p) is ["IN",y,u] => + u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] + [["IN",y,postInSeq u],:postIteratorList l] + [p,:postIteratorList l] + x + +postin arg == + arg isnt ["in",i,seq] => systemErrorHere '"postin" + ["in",postTran i, postInSeq seq] + +postIn arg == + arg isnt ["IN",i,seq] => systemErrorHere '"postIn" + ["IN",postTran i,postInSeq seq] + +postInSeq seq == + seq is ["SEGMENT",p,q] => postTranSegment(p,q) + seq is ["Tuple",:l] => tuple2List l + postTran seq + +postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] + +tuple2List l == + l is [a,:l'] => + u:= tuple2List l' + a is ["SEGMENT",p,q] => + null u => ["construct",postTranSegment(p,q)] + $InteractiveMode and null $BOOT => + ["append",["construct",postTranSegment(p,q)],tuple2List l'] + ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] + null u => ["construct",postTran a] + ["cons",postTran a,tuple2List l'] + nil + +SEGMENT(a,b) == [i for i in a..b] + +postReduce ["Reduce",op,expr] == + $InteractiveMode or expr is ["COLLECT",:.] => + ["REDUCE",op,0,postTran expr] + postReduce ["Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr], + ["construct", g]]] + +postFlattenLeft(x,op) ==-- + x is [ =op,a,b] => [:postFlattenLeft(a,op),b] + [x] + +postSemiColon u == postBlock ["Block",:postFlattenLeft(u,";")] + +postSequence ["Sequence",:l] == ['(elt $ makeRecord),:postTranList l] + +--------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) +postSignature ["Signature",op,sig] == + sig is ["->",:.] => + sig1:= postType sig + op:= postAtom (STRINGP op => INTERN op; op) + ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] + +killColons x == + atom x => x + x is ["Record",:.] => x + x is ["Union",:.] => x + x is [":",.,y] => killColons y + [killColons first x,:killColons rest x] + +postSlash ['_/,a,b] == + STRINGP a => postTran ["Reduce",INTERN a,b] + ['_/,postTran a,postTran b] + +removeSuperfluousMapping sig1 == + --get rid of this asap + sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] + sig1 + +postType typ == + typ is ["->",source,target] => + source="constant" => [LIST postTran target,"constant"] + LIST ["Mapping",postTran target,:unTuple postTran source] + typ is ["->",target] => LIST ["Mapping",postTran target] + LIST postTran typ + +postTuple u == + u is ["Tuple"] => u + u is ["Tuple",:l,a] => (["Tuple",:postTranList rest u]) +--u is ["Tuple",:l,a] => (--a:= postTran a; ["Tuple",:postTranList rest u]) + --RDJ: don't understand need for above statement that is commented out + +postWhere ["where",a,b] == + x:= + b is ["Block",:c] => c + LIST b + ["where",postTran a,:postTranList x] + +postWith ["with",a] == + $insidePostCategoryIfTrue: local := true + a:= postTran a + a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a] + a is ["PROGN",:b] => ["CATEGORY",:b] + a + +postTransformCheck x == + $defOp: local:= nil + postcheck x + +postcheck x == + atom x => nil + x is ["DEF",form,[target,:.],:.] => + (setDefOp form; postcheckTarget target; postcheck rest rest x) + x is ["QUOTE",:.] => nil + postcheck first x + postcheck rest x + +setDefOp f == + if f is [":",g,:.] then f := g + f := (atom f => f; first f) + if $topOp then $defOp:= f else $topOp:= f + +postcheckTarget x == + -- doesn't seem that useful! + isPackageType x => nil + x is ["Join",:.] => nil + NIL + +isPackageType x == not CONTAINED("$",x) + +unTuple x == + x is ["Tuple",:y] => y + LIST x + +--% APL TRANSFORMATION OF INPUT + +aplTran x == + $BOOT => x + $GENNO: local := 0 + u:= aplTran1 x + containsBang u => throwKeyedMsg("S2IP0002",NIL) + u + +containsBang u == + atom u => EQ(u,"_!") + u is [="QUOTE",.] => false + or/[containsBang x for x in u] + +aplTran1 x == + atom x => x + [op,:argl1] := x + argl := aplTranList argl1 + -- unary case f ! y + op = "_!" => + argl is [f,y] => + y is [op',:y'] and op' = "_!" => aplTran1 [op,op,f,:y'] + $BOOT => ["COLLECT",["IN",g:=GENVAR(),aplTran1 y],[f,g]] + ["map",f,aplTran1 y] + x --do not handle yet + -- multiple argument case + hasAplExtension argl is [arglAssoc,:futureArgl] => + -- choose the last aggregate type to be result of reshape + ["reshape",["COLLECT",:[["IN",g,["ravel",a]] for [g,:a] in arglAssoc], + aplTran1 [op,:futureArgl]],CDAR arglAssoc] + [op,:argl] + +aplTranList x == + atom x => x + [aplTran1 first x,:aplTranList rest x] + +hasAplExtension argl == + or/[x is ["_!",:.] for x in argl] => + u:= [futureArg for x in argl] where futureArg() == + x is ["_!",y] => + z:= deepestExpression y + arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] + substitute(g,z,y) + x + [arglAssoc,:u] + nil + +deepestExpression x == + x is ["_!",y] => deepestExpression y + x diff --git a/src/interp/postpar.boot.pamphlet b/src/interp/postpar.boot.pamphlet deleted file mode 100644 index 67cf814a..00000000 --- a/src/interp/postpar.boot.pamphlet +++ /dev/null @@ -1,555 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp postpar.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 '"postprop" -)package "BOOT" - -$postStack := [] - ---% Yet Another Parser Transformation File ---These functions are used by for BOOT and SPAD code ---(see new2OldLisp, e.g.) - -postTransform y == - x:= y - u:= postTran x - if u is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) then u:= - [":",["LISTOF",:l,y],t] - postTransformCheck u - aplTran u - -displayPreCompilationErrors() == - n:= #($postStack:= REMDUP NREVERSE $postStack) - n=0 => nil - errors:= - 1 '"errors" - '"error" - if $InteractiveMode - then sayBrightly ['" Semantic ",errors,'" detected: "] - else - heading:= - $topOp ^= '$topOp => ['" ",$topOp,'" has"] - ['" You have"] - sayBrightly [:heading,'%b,n,'%d,'"precompilation ",errors,'":"] - if 1 - postAtom x - op := first x - SYMBOLP op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) - op is ["elt",a,b] => - u:= postTran [b,:rest x] - [postTran op,:rest u] - op is ["Scripts",:.] => - postScriptsForm(op,"append"/[unTuple postTran y for y in rest x]) - op^=(y:= postOp op) => [y,:postTranList rest x] - postForm x - -postTranList x == [postTran y for y in x] - -postBigFloat x == - [.,mant,:expon] := x - $BOOT => INT2RNUM(mant) * INT2RNUM(10) ** expon - eltword := if $InteractiveMode then "$elt" else "elt" - postTran [[eltword,'(Float),"float"],[",",[",",mant,expon],10]] - -postAdd ["add",a,:b] == - null b => postCapsule a - ["add",postTran a,postCapsule first b] - -checkWarning msg == postError concat('"Parsing error: ",msg) - -checkWarningIndentation() == - checkWarning ['"Apparent indentation error following",:bright "add"] - -postCapsule x == - x isnt [op,:.] => checkWarningIndentation() - INTEGERP op or op = "==" => ["CAPSULE",postBlockItem x] - op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] - op = "if" => ["CAPSULE",postBlockItem x] - checkWarningIndentation() - -postQUOTE x == x - -postColon u == - u is [":",x] => [":",postTran x] - u is [":",x,y] => [":",postTran x,:postType y] - -postColonColon u == - -- for Lisp package calling - -- boot syntax is package::fun but probably need to parenthesize it - $BOOT and u is ["::",package,fun] => - INTERN(STRINGIMAGE fun, package) - postForm u - -postAtSign ["@",x,y] == ["@",postTran x,:postType y] - -postPretend ["pretend",x,y] == ["pretend",postTran x,:postType y] - -postConstruct u == - u is ["construct",b] => - a:= (b is [",",:.] => comma2Tuple b; b) - a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] - a is ["Tuple",:l] => - or/[x is [":",y] for x in l] => postMakeCons l - or/[x is ["SEGMENT",:.] for x in l] => tuple2List l - ["construct",:postTranList l] - ["construct",postTran a] - u - -postError msg == - BUMPERRORCOUNT 'precompilation - xmsg:= - $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg] - msg - $postStack:= [xmsg,:$postStack] - nil - -postMakeCons l == - null l => "nil" - l is [[":",a],:l'] => - l' => ["append",postTran a,postMakeCons l'] - postTran a - ["cons",postTran first l,postMakeCons rest l] - -postAtom x == - $BOOT => x - x=0 => '(Zero) - x=1 => '(One) - EQ(x,'T) => 'T_$ -- rename T in spad code to T$ - IDENTP x and GETDATABASE(x,'NILADIC) => LIST x - x - -postBlock ["Block",:l,x] == - ["SEQ",:postBlockItemList l,["exit",postTran x]] - -postBlockItemList l == [postBlockItem x for x in l] - -postBlockItem x == - x:= postTran x - x is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) => - [":",["LISTOF",:l,y],t] - x - -postCategory (u is ["CATEGORY",:l]) == - --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible - null l => u - op := - $insidePostCategoryIfTrue = true => "PROGN" - "CATEGORY" - [op,:[fn x for x in l]] where fn x == - $insidePostCategoryIfTrue: local := true - postTran x - -postComma u == postTuple comma2Tuple u - -comma2Tuple u == ["Tuple",:postFlatten(u,",")] - -postDef [defOp,lhs,rhs] == ---+ - lhs is ["macro",name] => postMDef ["==>",name,rhs] - - if not($BOOT) then recordHeaderDocumentation nil - if $maxSignatureLineNumber ^= 0 then - $docList := [["constructor",:$headerDocumentation],:$docList] - $maxSignatureLineNumber := 0 - --reset this for next constructor; see recordDocumentation - lhs:= postTran lhs - [form,targetType]:= - lhs is [":",:.] => rest lhs - [lhs,nil] - if null $InteractiveMode and atom form then form := LIST form - newLhs:= - atom form => form - [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] - [op,:postDefArgs argl] - argTypeList:= - atom form => nil - [(x is [":",.,t] => t; nil) for x in rest form] - typeList:= [targetType,:argTypeList] - if atom form then form := [form] - specialCaseForm := [nil for x in form] - ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] - -postDefArgs argl == - null argl => argl - argl is [[":",a],:b] => - b => postError - ['" Argument",:bright a,'"of indefinite length must be last"] - atom a or a is ["QUOTE",:.] => a - postError - ['" Argument",:bright a,'"of indefinite length must be a name"] - [first argl,:postDefArgs rest argl] - -postMDef(t) == - [.,lhs,rhs] := t - $InteractiveMode and not $BOOT => - lhs := postTran lhs - null IDENTP lhs => throwKeyedMsg("S2IP0001",NIL) - ["MDEF",lhs,NIL,NIL,postTran rhs] - lhs:= postTran lhs - [form,targetType]:= - lhs is [":",:.] => rest lhs - [lhs,nil] - form:= - atom form => LIST form - form - newLhs:= [(x is [":",a,:.] => a; x) for x in form] - typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] - ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] - -postElt (u is [.,a,b]) == - a:= postTran a - b is ["Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] - ["elt",a,postTran b] - -postExit ["=>",a,b] == ["IF",postTran a,["exit",postTran b],"noBranch"] - - -postFlatten(x,op) == - x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] - LIST x - -postForm (u is [op,:argl]) == - x:= - atom op => - argl':= postTranList argl - op':= - true=> op - $BOOT => op - GET(op,'Led) or GET(op,'Nud) or op = 'IN => op - numOfArgs:= (argl' is [["Tuple",:l]] => #l; 1) - INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) - [op',:argl'] - op is ["Scripts",:.] => [:postTran op,:postTranList argl] - u:= postTranList u - if u is [["Tuple",:.],:.] then - postError ['" ",:bright u, - '"is illegal because tuples cannot be applied_!",'%l, - '" Did you misuse infix dot?"] - u - x is [.,["Tuple",:y]] => [first x,:y] - x - -postQuote [.,a] == ["QUOTE",a] - -postScriptsForm(["Scripts",op,a],argl) == - [getScriptName(op,a,#argl),:postTranScripts a,:argl] - -postScripts ["Scripts",op,a] == - [getScriptName(op,a,0),:postTranScripts a] - -getScriptName(op,a,numberOfFunctionalArgs) == - if null IDENTP op then - postError ['" ",op,'" cannot have scripts"] - INTERNL("*",STRINGIMAGE numberOfFunctionalArgs, - decodeScripts a,PNAME op) - -postTranScripts a == - a is ["PrefixSC",b] => postTranScripts b - a is [";",:b] => "append"/[postTranScripts y for y in b] - a is [",",:b] => - ("append"/[fn postTran y for y in b]) where - fn x == - x is ["Tuple",:y] => y - LIST x - LIST postTran a - -decodeScripts a == - a is ["PrefixSC",b] => STRCONC(STRINGIMAGE 0,decodeScripts b) - a is [";",:b] => APPLX('STRCONC,[decodeScripts x for x in b]) - a is [",",:b] => - STRINGIMAGE fn a where fn a == (a is [",",:b] => +/[fn x for x in b]; 1) - STRINGIMAGE 1 - -postIf t == - t isnt ["if",:l] => t - ["IF",:[(null (x:= postTran x) and null $BOOT => "noBranch"; x) - for x in l]] - -postJoin ["Join",a,:l] == - a:= postTran a - l:= postTranList l - if l is [b] and b is [name,:.] and MEMQ(name,'(ATTRIBUTE SIGNATURE)) then l - := LIST ["CATEGORY",b] - al:= - a is ["Tuple",:c] => c - LIST a - ["Join",:al,:l] - -postMapping u == - u isnt ["->",source,target] => u - ["Mapping",postTran target,:unTuple postTran source] - -postOp x == - x=":=" => - $BOOT => "SPADLET" - "LET" - x=":-" => "LETD" - x="Attribute" => "ATTRIBUTE" - x - -postRepeat ["REPEAT",:m,x] == ["REPEAT",:postIteratorList m,postTran x] - -postSEGMENT ["SEGMENT",a,b] == - key:= [a,'"..",:(b => [b]; nil)] - postError ['" Improper placement of segment",:bright key] - -postCollect [constructOp,:m,x] == - x is [["elt",D,"construct"],:y] => - postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] - itl:= postIteratorList m - x:= (x is ["construct",r] => r; x) --added 84/8/31 - y:= postTran x - finish(constructOp,itl,y) where - finish(op,itl,y) == - y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] - y is ["Tuple",:l] => - newBody:= - or/[x is [":",y] for x in l] => postMakeCons l - or/[x is ["SEGMENT",:.] for x in l] => tuple2List l - ["construct",:postTranList l] - ["REDUCE","append",0,[op,:itl,newBody]] - [op,:itl,y] - -postTupleCollect [constructOp,:m,x] == - postCollect [constructOp,:m,["construct",x]] - -postIteratorList x == - x is [p,:l] => - (p:= postTran p) is ["IN",y,u] => - u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] - [["IN",y,postInSeq u],:postIteratorList l] - [p,:postIteratorList l] - x - -postin arg == - arg isnt ["in",i,seq] => systemErrorHere '"postin" - ["in",postTran i, postInSeq seq] - -postIn arg == - arg isnt ["IN",i,seq] => systemErrorHere '"postIn" - ["IN",postTran i,postInSeq seq] - -postInSeq seq == - seq is ["SEGMENT",p,q] => postTranSegment(p,q) - seq is ["Tuple",:l] => tuple2List l - postTran seq - -postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] - -tuple2List l == - l is [a,:l'] => - u:= tuple2List l' - a is ["SEGMENT",p,q] => - null u => ["construct",postTranSegment(p,q)] - $InteractiveMode and null $BOOT => - ["append",["construct",postTranSegment(p,q)],tuple2List l'] - ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] - null u => ["construct",postTran a] - ["cons",postTran a,tuple2List l'] - nil - -SEGMENT(a,b) == [i for i in a..b] - -postReduce ["Reduce",op,expr] == - $InteractiveMode or expr is ["COLLECT",:.] => - ["REDUCE",op,0,postTran expr] - postReduce ["Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr], - ["construct", g]]] - -postFlattenLeft(x,op) ==-- - x is [ =op,a,b] => [:postFlattenLeft(a,op),b] - [x] - -postSemiColon u == postBlock ["Block",:postFlattenLeft(u,";")] - -postSequence ["Sequence",:l] == ['(elt $ makeRecord),:postTranList l] - ---------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) -postSignature ["Signature",op,sig] == - sig is ["->",:.] => - sig1:= postType sig - op:= postAtom (STRINGP op => INTERN op; op) - ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] - -killColons x == - atom x => x - x is ["Record",:.] => x - x is ["Union",:.] => x - x is [":",.,y] => killColons y - [killColons first x,:killColons rest x] - -postSlash ['_/,a,b] == - STRINGP a => postTran ["Reduce",INTERN a,b] - ['_/,postTran a,postTran b] - -removeSuperfluousMapping sig1 == - --get rid of this asap - sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] - sig1 - -postType typ == - typ is ["->",source,target] => - source="constant" => [LIST postTran target,"constant"] - LIST ["Mapping",postTran target,:unTuple postTran source] - typ is ["->",target] => LIST ["Mapping",postTran target] - LIST postTran typ - -postTuple u == - u is ["Tuple"] => u - u is ["Tuple",:l,a] => (["Tuple",:postTranList rest u]) ---u is ["Tuple",:l,a] => (--a:= postTran a; ["Tuple",:postTranList rest u]) - --RDJ: don't understand need for above statement that is commented out - -postWhere ["where",a,b] == - x:= - b is ["Block",:c] => c - LIST b - ["where",postTran a,:postTranList x] - -postWith ["with",a] == - $insidePostCategoryIfTrue: local := true - a:= postTran a - a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a] - a is ["PROGN",:b] => ["CATEGORY",:b] - a - -postTransformCheck x == - $defOp: local:= nil - postcheck x - -postcheck x == - atom x => nil - x is ["DEF",form,[target,:.],:.] => - (setDefOp form; postcheckTarget target; postcheck rest rest x) - x is ["QUOTE",:.] => nil - postcheck first x - postcheck rest x - -setDefOp f == - if f is [":",g,:.] then f := g - f := (atom f => f; first f) - if $topOp then $defOp:= f else $topOp:= f - -postcheckTarget x == - -- doesn't seem that useful! - isPackageType x => nil - x is ["Join",:.] => nil - NIL - -isPackageType x == not CONTAINED("$",x) - -unTuple x == - x is ["Tuple",:y] => y - LIST x - ---% APL TRANSFORMATION OF INPUT - -aplTran x == - $BOOT => x - $GENNO: local := 0 - u:= aplTran1 x - containsBang u => throwKeyedMsg("S2IP0002",NIL) - u - -containsBang u == - atom u => EQ(u,"_!") - u is [="QUOTE",.] => false - or/[containsBang x for x in u] - -aplTran1 x == - atom x => x - [op,:argl1] := x - argl := aplTranList argl1 - -- unary case f ! y - op = "_!" => - argl is [f,y] => - y is [op',:y'] and op' = "_!" => aplTran1 [op,op,f,:y'] - $BOOT => ["COLLECT",["IN",g:=GENVAR(),aplTran1 y],[f,g]] - ["map",f,aplTran1 y] - x --do not handle yet - -- multiple argument case - hasAplExtension argl is [arglAssoc,:futureArgl] => - -- choose the last aggregate type to be result of reshape - ["reshape",["COLLECT",:[["IN",g,["ravel",a]] for [g,:a] in arglAssoc], - aplTran1 [op,:futureArgl]],CDAR arglAssoc] - [op,:argl] - -aplTranList x == - atom x => x - [aplTran1 first x,:aplTranList rest x] - -hasAplExtension argl == - or/[x is ["_!",:.] for x in argl] => - u:= [futureArg for x in argl] where futureArg() == - x is ["_!",y] => - z:= deepestExpression y - arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] - substitute(g,z,y) - x - [arglAssoc,:u] - nil - -deepestExpression x == - x is ["_!",y] => deepestExpression y - x -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/profile.boot b/src/interp/profile.boot new file mode 100644 index 00000000..b5cb25a1 --- /dev/null +++ b/src/interp/profile.boot @@ -0,0 +1,89 @@ +-- 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. + + +--$profileCompiler := true +$profileAlist := nil + +profileWrite() == --called from finalizeLisplib + outStream := MAKE_-OUTSTREAM CONCAT(LIBSTREAM_-DIRNAME $libFile,'"/info") + _*PRINT_-PRETTY_* :local := 'T + PRINT_-FULL(profileTran $profileAlist,outStream) + SHUT outStream + +profileTran alist == + $profileHash := MAKE_-HASH_-TABLE() + for [opSig,:info] in alist repeat + op := opOf opSig + sig := KAR KDR opSig + HPUT($profileHash,op,[[sig,:info],:HGET($profileHash,op)]) + [[key,:HGET($profileHash,key)] for key in mySort HKEYS $profileHash] + +profileRecord(label,name,info) == --name: info is var: type or op: sig +--$profileAlist is ((op . alist1) ...) where +-- alist1 is ((label . alist2) ...) where +-- alist2 is ((name . info) ...) + if $insideCapsuleFunctionIfTrue then + op := $op + argl := CDR $form + opSig := [$op,$signatureOfForm] + else + op := 'constructor + argl := nil + opSig := [op] + if label = 'locals and MEMQ(name,argl) then label := 'arguments + alist1 := LASSOC(opSig,$profileAlist) + alist2 := LASSOC(label,alist1) + newAlist2 := insertAlist(name,info,alist2) + newAlist1 := insertAlist(label,newAlist2,alist1) + $profileAlist := insertAlist(opSig,newAlist1,$profileAlist) + $profileAlist + +profileDisplay() == + profileDisplayOp('constructor,LASSOC('constructor,$profileAlist) ) + for [op,:alist1] in $profileAlist | op ^= 'constructor repeat + profileDisplayOp(op,alist1) + +profileDisplayOp(op,alist1) == + sayBrightly op + if LASSOC('arguments,alist1) then + sayBrightly '" arguments" + for [x,:t] in MSORT LASSOC('arguments,alist1) repeat + sayBrightly concat('" ",x,": ",prefix2String t) + if LASSOC('locals,alist1) then + sayBrightly '" locals" + for [x,:t] in MSORT LASSOC('locals,alist1) repeat + sayBrightly concat('" ",x,": ",prefix2String t) + for [con,:alist2] in alist1 | not MEMQ(con,'(locals arguments)) repeat + sayBrightly concat('" ",prefix2String con) + for [op1,:sig] in MSORT alist2 repeat + sayBrightly ['" ",:formatOpSignature(op1,sig)] + diff --git a/src/interp/profile.boot.pamphlet b/src/interp/profile.boot.pamphlet deleted file mode 100644 index e3b83f66..00000000 --- a/src/interp/profile.boot.pamphlet +++ /dev/null @@ -1,111 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp profile.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. - -@ -<<*>>= -<> - ---$profileCompiler := true -$profileAlist := nil - -profileWrite() == --called from finalizeLisplib - outStream := MAKE_-OUTSTREAM CONCAT(LIBSTREAM_-DIRNAME $libFile,'"/info") - _*PRINT_-PRETTY_* :local := 'T - PRINT_-FULL(profileTran $profileAlist,outStream) - SHUT outStream - -profileTran alist == - $profileHash := MAKE_-HASH_-TABLE() - for [opSig,:info] in alist repeat - op := opOf opSig - sig := KAR KDR opSig - HPUT($profileHash,op,[[sig,:info],:HGET($profileHash,op)]) - [[key,:HGET($profileHash,key)] for key in mySort HKEYS $profileHash] - -profileRecord(label,name,info) == --name: info is var: type or op: sig ---$profileAlist is ((op . alist1) ...) where --- alist1 is ((label . alist2) ...) where --- alist2 is ((name . info) ...) - if $insideCapsuleFunctionIfTrue then - op := $op - argl := CDR $form - opSig := [$op,$signatureOfForm] - else - op := 'constructor - argl := nil - opSig := [op] - if label = 'locals and MEMQ(name,argl) then label := 'arguments - alist1 := LASSOC(opSig,$profileAlist) - alist2 := LASSOC(label,alist1) - newAlist2 := insertAlist(name,info,alist2) - newAlist1 := insertAlist(label,newAlist2,alist1) - $profileAlist := insertAlist(opSig,newAlist1,$profileAlist) - $profileAlist - -profileDisplay() == - profileDisplayOp('constructor,LASSOC('constructor,$profileAlist) ) - for [op,:alist1] in $profileAlist | op ^= 'constructor repeat - profileDisplayOp(op,alist1) - -profileDisplayOp(op,alist1) == - sayBrightly op - if LASSOC('arguments,alist1) then - sayBrightly '" arguments" - for [x,:t] in MSORT LASSOC('arguments,alist1) repeat - sayBrightly concat('" ",x,": ",prefix2String t) - if LASSOC('locals,alist1) then - sayBrightly '" locals" - for [x,:t] in MSORT LASSOC('locals,alist1) repeat - sayBrightly concat('" ",x,": ",prefix2String t) - for [con,:alist2] in alist1 | not MEMQ(con,'(locals arguments)) repeat - sayBrightly concat('" ",prefix2String con) - for [op1,:sig] in MSORT alist2 repeat - sayBrightly ['" ",:formatOpSignature(op1,sig)] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot new file mode 100644 index 00000000..b936eb77 --- /dev/null +++ b/src/interp/pspad1.boot @@ -0,0 +1,741 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +$escapeWords := ["always", "assert", "but", "define", + "delay", "do", "except", "export", "extend", "fix", "fluid", + "from", "generate", "goto", "import", "inline", "never", "select", + "try", "yield"] +$pileStyle := false +$commentIndentation := 8 +$braceIndentation := 8 +$doNotResetMarginIfTrue := true +$marginStack := nil +$numberOfSpills := 0 +$lineFragmentBuffer:= nil +$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) +$lineBuffer := nil +$formatForcePren := nil +$underScore := char ('__) +$rightBraceFlag := nil +$semicolonFlag := nil +$newLineWritten := nil +$comments := nil +$noColonDeclaration := false +$renameAlist := '( + (SmallInteger . SingleInteger) + (SmallFloat . DoubleFloat) + (Void . _(_)) + (xquo . exquo) + (setelt . set_!) + (_$ . _%) + (_$_$ . _$) + (_*_* . _^) + (_^_= . _~_=) + (_^ . _~)) + +--$opRenameAlist := '( +-- (and . AND) +-- (or . OR) +-- (not . NOT)) + + +--====================================================================== +-- Main Translator Function +--====================================================================== +--% lisp-fragment to boot-fragment functions +lisp2Boot x == + --entry function + $fieldNames := nil + $pilesAreOkHere: local:= true + $commentsToPrint: local:= nil + $lineBuffer: local + $braceStack: local := nil + $marginStack: local:= [0] + --$autoLine is true except when inside a try---if true, lines are allowed to break + $autoLine:= true + $lineFragmentBuffer:= nil + $bc:=0 --brace count + $m:= 0 + $c:= $m + $numberOfSpills:= 0 + $lineLength:= 80 + format x + formatOutput REVERSE $lineFragmentBuffer + [fragmentsToLine y for y in REVERSE $lineBuffer] + +fragmentsToLine fragments == + string:= lispStringList2String fragments + line:= GETSTR 240 + for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) + line + +lispStringList2String x == + null x => '"" + atom x => STRINGIMAGE x + CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) + lispStringList2String CAR x + +--% routines for buffer and margin adjustment + +formatOutput x == + for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat + startY:= rest start + for [loc,comment] in stack repeat + commentY:= rest loc + gap:= startY-commentY + gap>0 => before:= [[commentY,first loc,gap,comment],:before] + gap=0 => same:= [[startY,1,gap,comment],:same] + true => after:= [[startY,first loc,-gap,comment],:after] + if before then putOut before + if same then + [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] + line:= fragmentsToLine x + x:= + #line+#y>$lineLength => + (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) + [line,y] + consLineBuffer x + for y in extraLines repeat consLineBuffer LIST y + if after then putOut after + $commentsToPrint:= nil + +consLineBuffer x == $lineBuffer := [x,:$lineBuffer] + +putOut x == + eject ("min"/[gap for [.,.,gap,:.] in x]) + for u in orderList x repeat addComment u + +eject n == for i in 2..n repeat consLineBuffer nil + +addComment u == + for x in mkCommentLines u repeat consLineBuffer LIST x + +mkCommentLines [.,n,.,s] == + lines:= breakComments s + lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] + [:l,last]:= lines1 + [:l,fragmentsToLine [last,"_}"]] + +breakComments s == + n:= containsString(s,PNAME "ENDOFLINECHR") => + #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] + LIST SUBSTRING(s,0,n) + LIST s + +containsString(x,y) == + --if string x contains string y, return start index + for i in 0..MAXINDEX x-MAXINDEX y repeat + and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i + +--====================================================================== +-- Character/String Buffer Functions +--====================================================================== +consBuffer item == + if item = '"failed" then item := 'failed + n:= + STRINGP item => 2+#item + IDENTP item => #PNAME item + #STRINGIMAGE item + columnsLeft:= $lineLength-$c + if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 + columnsLeft:= $lineLength-$c + --cheat for semicolons, strings, and delimiters: they are NEVER too long + not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => + $autoLine => + --is true except within try + formatOutput REVERSE $lineFragmentBuffer + $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) + $lineFragmentBuffer:= LIST nBlanks $c + consBuffer item + nil + $lineFragmentBuffer:= + ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] + NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] + STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] + sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] + $lineFragmentBuffer + $rightBraceFlag := item = "}" + $semicolonFlag := item = "; " --prevents consecutive semicolons + $c:= $c+n + +isSpecialBufferItem item == + item = "; " or STRINGP item => true + false + +isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") + +--====================================================================== +-- Formatting/Line Control Functions +--====================================================================== +newLine() == + null $autoLine => nil + $newLineWritten := true + formatOutput REVERSE $lineFragmentBuffer + $lineFragmentBuffer:= LIST nBlanks $m + $c:= $m + +optNewLine() == + $newLineWritten => newLine() + $c + +spillLine() == + null $autoLine => nil + formatOutput REVERSE $lineFragmentBuffer + $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) + $lineFragmentBuffer:= LIST nBlanks $c + $c + +indent() == + $m:= $m+2*($numberOfSpills+1) + $marginStack:= [$m,:$marginStack] + $numberOfSpills:= 0 + $m + +undent() == +-- $doNotResetMarginIfTrue=true => +-- pp '"hoho" +-- $c + $marginStack is [m,:r] => + $marginStack := r + $m := m + 0 + +spill(fn,a) == + u := try FUNCALL(fn,a) => u + (nearMargin() or spillLine()) and FUNCALL(fn,a) + +formatSpill(fn,a) == + u := try FUNCALL(fn,a) => u + v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) + w := stay or undent() + v and w + +formatSpill2(fn,f,a) == + u := try FUNCALL(fn,f,a) => u + v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) + w := stay or undent() + v and w + +nearMargin() == + $c=$m or $c=$m+1 => $c + +--====================================================================== +-- Main Formatting Functions +--====================================================================== +format(x,:options) == + oldC:= $c + qualification := IFCAR options + newCOrNil:= + x is [op,:argl] => + if op = 'return then argl := rest argl + n := #argl + op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) + op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => + formatDollar(name,p,argl) + op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => + formatDollar1(CAR argl,CADR argl) + fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) + if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op + n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => + formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) + n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => + formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) + formatForm x + formatAtom x + null newCOrNil => ($c:= oldC; nil) + null FIXP newCOrNil => error() + $c:= newCOrNil + + +getOp(op,kind) == + kind = 'Led => + MEMQ(op,'(_div _exquo)) => nil + GET(op,'Led) + GET(op,'Nud) + +formatDollar(name,p,argl) == + name := markMacroTran name + n := #argl + kind := (n=1 => "Nud"; "Led") + IDENTP name and GETL(p,kind) => format([p,:argl],name) + formatForcePren [p,:argl] and + (try (format "$$" and formatForcePren name) + or (indent() and format "$__" and formatForcePren name and undent())) + +formatMacroCheck name == + ATOM name => name + u := or/[x for [x,:y] in $globalMacroStack | y = name] => u + u := or/[x for [x,:y] in $localMacroStack | y = name] => u + [op,:argl] := name + MEMQ(op,'(Record Union)) => + pp ['"Cannot find: ",name] + name + [op,:[formatMacroCheck x for x in argl]] + +formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) + +formatDollar1(name,arg) == + id := + IDENTP name => name + name is [p] and GETL(p,'NILADIC) => p + name + format arg and format "$$" and formatForcePren id + + +formatForcePren x == + $formatForcePren: local := true + format x + +formatAtom(x,:options) == + if u := LASSOC(x,$renameAlist) then x := u + null x or isIdentifier x => + if MEMQ(x,$escapeWords) then + consBuffer $underScore + consBuffer ident2PrintImage PNAME x + consBuffer x + +formatFn(fn,x,$m,$c) == FUNCALL(fn,x) + +formatFree(['free,:u]) == + format 'free and format " " and formatComma u + +formatUnion(['Union,:r]) == + $count : local := 0 + formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == + x is [":",y,'Branch] => fn STRINGIMAGE y + STRINGP x => [":", INTERN x, ['Enumeration,x]] + x is [":",:.] => x + tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) + [":", tag, x] + +formatTestForPartial u == + u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => + ['Partial, S] + u + +formatEnumeration(y is ['Enumeration,:r]) == + r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" + formatForm y + +formatRecord(u) == formatFormNoColonDecl u + +formatFormNoColonDecl u == + $noColonDeclaration: local := true + formatForm u + +formatElt(u) == + u is ["elt",a,b] => formatApplication rest u + formatForm u + +formatForm (u) == + [op,:argl] := u + if MEMQ(op, '(Record Union)) then + $fieldNames := union(getFieldNames argl,$fieldNames) + MEMQ(op,'((QUOTE T) true)) => format "true" + MEMQ(op,'(false nil)) => format op + u='(Zero) => format 0 + u='(One) => format 1 + 1=#argl => formatApplication u + formatFunctionCall u + +formatFunctionCall u == + $pilesAreOkHere: local + spill("formatFunctionCall1",u) + +formatFunctionCall1 [op,:argl] == +--null argl and getConstructorProperty(op,'niladic) => formatOp op + null argl => + GETL(op,'NILADIC) => formatOp op + formatOp op and format "()" + formatOp op and formatFunctionCallTail argl + +formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" + +formatComma argl == + format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c + +formatOp op == + atom op => formatAtom op + formatPren op + +formatApplication u == + [op,a] := u + MEMQ(a, $fieldNames) => formatSelection u + atom op => + formatHasDotLeadOp a => formatOpPren(op,a) + formatApplication0 u + formatSelection u + +formatHasDotLeadOp u == + u is [op,:.] and (op = "." or not atom op) + +formatApplication0 u == +--format as f(x) as f x if possible + $pilesAreOkHere: local + formatSpill("formatApplication1",u) + +formatApplication1 u == + [op,x] := u + formatHasDollarOp x or $formatForcePren or + pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) + try (formatOp op and format " ") and + (try formatApplication2 x or + format "(" and formatApplication2 x and format ")") + +formatHasDollarOp x == + x is ["elt",a,b] and isTypeProbably? a + +isTypeProbably? x == + IDENTP x and UPPER_-CASE_-P (PNAME x).0 + +formatOpPren(op,x) == formatOp op and formatPren x + +formatApplication2 x == + leadOp := + x is [['elt,.,y],:.] => y + opOf x + MEMQ(leadOp,'(COLLECT LIST construct)) or + pspadBindingPowerOf("left",x)<1000 => formatPren x + format x + +formatDot ["dot",a,x] == + try (formatOp a and format ".") and + ATOM x => format x + formatPren x + +formatSelection u == + $pilesAreOkHere: local + formatSpill("formatSelection1",u) + +formatSelection1 [f,x] == formatSelectionOp f and format "." and + ATOM x => format x + formatPren x + +formatSelectionOp op == + op is [f,.] and not GET(f,'Nud) or + 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op + formatPren1("formatSelectionOp1",op) + +formatSelectionOp1 f == + f is [op,:argl] => + argl is [a] => + not ATOM op and ATOM a => formatSelection1 [op,a] + formatPren f + format f + formatOp f + +formatPren a == + $pilesAreOkHere: local + formatSpill("formatPrenAux",a) + +formatPrenAux a == format "_(" and format a and format "_)" + +formatPren1(f,a) == + $pilesAreOkHere: local + formatSpill2("formatPren1Aux",f,a) + +formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" + +formatLeft(fn,x,op,key) == + lbp:= formatOpBindingPower(op,key,"left") + formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) + FUNCALL(fn,x) + +formatRight(fn,x,op,key) == + --are there exceptional cases where piles are ok? + x is ['LET,:.] => FUNCALL(fn,x) + --decide on basis of binding power whether prens are needed + rbp := formatOpBindingPower(op,key,"right") + lbp := formatOpBindingPower(opOf x,key,"left") + lbp < rbp => formatPren1(fn,x) + FUNCALL(fn,x) + +formatCut a == formatSpill("format",a) + +--====================================================================== +-- Prefix/Infix Operators +--====================================================================== +formatPrefix(op,arg,lbp,rbp,:options) == + qualification := IFCAR options + $pilesAreOkHere: local + formatPrefixOp(op,qualification) and + (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) + +formatPrefixOp(op,:options) == + qualification := IFCAR options + op=char '" " => format " =" + qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => + formatQual(op,qualification) and format " " + format op + +formatQual(op,D) == + null D => format op + format op and format "$$" and format D + +formatInfix(op,[a,b],lbp,rbp,:options) == + qualification := IFCAR options + $pilesAreOkHere: local + (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) + then formatPren b else format b) + +formatGetBindingPowerOf(leftOrRight,x) == +-- this function is nearly identical with getBindingPowerOf +-- leftOrRight = "left" => 0 +-- 1 + pspadBindingPowerOf(leftOrRight,x) + +pspadBindingPowerOf(key,x) == + --binding powers can be found in file NEWAUX LISP + x is ['REDUCE,:.] => (key='left => 130; key='right => 0) + x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) + x is ["COND",:.] => (key="left" => 130; key="right" => 0) + x is [op,:argl] => + if op is [a,:.] then op:= a + op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 + op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) + (n:= #argl)=1 => + key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m + key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m + 1000 + n>1 => + key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m + key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m + op="ELT" => 1002 + 1000 + 1000 + 1002 + +pspadOpBindingPower(op,LedOrNud,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + MEMQ(op,'(_:)) and LedOrNud = 'Led => + leftOrRight = 'left => 195 + 196 + exception:= + leftOrRight="left" => 0 + 105 + bp:= + leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) + rightBindingPowerOf(op,LedOrNud) + bp^=exception => bp + 1000 + +formatOpBindingPower(op,key,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + op = '_$ => 1002 + MEMQ(op,'(_:)) and key = 'Led => + leftOrRight = 'left => 195 + 196 + MEMQ(op,'(_^_= _>_=)) => 400 + op = "not" and key = "Nud" => + leftOrRight = 'left => 1000 + 1001 + GETL(op,key) is [.,.,:r] => + leftOrRight = 'left => KAR r or 0 + KAR KDR r or 1 + 1000 + +formatInfixOp(op,:options) == + qualification := IFCAR options + qualification or + (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " + format op + +--====================================================================== +-- Special Handlers: DEF forms +--====================================================================== + +formatDEF def == formatDEF0(def,$DEFdepth + 1) + +formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == + if not MEMQ(KAR form,'(Exports Implementation)) then + $form := + form is [":",a,:.] => a + form + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $abb :local := constructor? opOf $form + if $DEFdepth < 2 then + condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] + $numberOfSpills := -1 + consComments(condoc,'"+++ ") + form := formatDeftranForm(form,tlist) + u := ["DEF",form,tlist,sclist,body] + v := formatDEF1 u => v + $insideDEF: local := $DEFdepth > 1 + $DEFdepth = 1 => + exname := 'Exports + impname := 'Implementation + form is [":",.,=exname] or body = impname => nil + exports := + form is [":",a,b] => + form := a + [["MDEF",exname,'(NIL),'(NIL),b]] + nil + [op,:argl] := form +-- decls := [x for x in argl | x is [":",:.]] +-- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] +-- $DEFdepth := $DEFdepth - 1 + formatWHERE(["where", + ["DEF",[":",form,exname],[nil for x in form],sclist,impname], + ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) + $insideTypeExpression: local := true + body := formatDeftran(body,false) + body is ["add",a,:b] => formatAddDef(form,a,b) +--body is ["with",a,:b] => formatWithDef(form,a,b) + tryBreakNB(format form and format " == ",body,"==","Led") + +formatDEF1 ["DEF",form,tlist,b,body] == + $insideDEF: local := $DEFdepth > 1 + $insideEXPORTS: local := form = 'Exports + $insideTypeExpression: local := true + form := formatDeftran(form,false) + body := formatDeftran(body,false) + ---------> terrible, hideous, but temporary, hack + if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] + prefix := (opOf tlist = 'Category => "define "; nil) + body is ["add",a,b] => formatAddDef(form,a,b) + body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) + prefix => + tryBreak(format prefix and format form and format " == ",body,"==","Led") + tryBreak(format form and format " == ",body,"==","Led") + +formatDefForm(form,:options) == + prefix := IFCAR options + $insideTypeExpression : local := true + form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) + prefix => format prefix and format form + format form + +formatAddDef(form,a,b) == + $insideCAPSULE : local := true + $insideDEF : local := false + formatDefForm form or return nil + $marginStack := [0] + $m := $c := 0 + $insideTypeExpression : local := false + cap := (b => b; "") + tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") + and format " add ", cap,"add","Led") + +formatWithDef(form,a,b,separator,:options) == + prefix := IFCAR options + $insideEXPORTS : local := true + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + a1 := formatWithKillSEQ a + b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") + and format " with ",first b,"with","Led") + tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") + +formatWithKillSEQ x == + x is ['SEQ,['exit,.,y]] => ['BRACE, y] + x + +formatBrace ['BRACE, x] == format "{" and format x and format "}" + +formatWith ["with",a,:b] == + $pilesAreOkHere: local := true + b => + tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") + tryBreak(format "with ",a,"with","Nud") + +formatWithDefault ["withDefault",a,b] == + if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then + part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] + if IFCAR init then + a:= IFCAR init + b:= [part2] + else + a := part2 + b := nil + $pilesAreOkHere: local := true + b => + tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") + tryBreak(format "with ",a,"with","Nud") + +formatDefaultDefs ["default",a, :b] == + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + b => + tryBreak(formatLeft("format",a,"default","Led") and + format " default ", first b,"default","Led") + tryBreak(format "default ",a,"default","Nud") +--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace + +formatAdd ["add",a,:b] == + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + b => + tryBreakNB(formatLeft("format",a,"and","Led") and + format " and ", first b,"and","Led") + tryBreakNB(format "add ",a,"and","Nud") +--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace + +formatMDEF ["MDEF",form,.,.,body] == + form is '(Rep) => formatDEF ["DEF",form,.,.,body] + $insideEXPORTS: local := form = 'Exports + $insideTypeExpression: local := true + body := formatDeftran(body,false) + name := opOf form + tryBreakNB(format name and format " ==> ",body,"==","Led") + and ($insideCAPSULE and $c or format(";")) + +insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue + or $noColonDeclaration + +formatImport ["import",a] == + addFieldNames a + addFieldNames macroExpand(a,$e) + format "import from " and formatLocal1 a + +addFieldNames a == + a is [op,:r] and MEMQ(op,'(Record Union)) => + $fieldNames := union(getFieldNames r,$fieldNames) + a is ['List,:b] => addFieldNames b + nil + +getFieldNames r == + r is [[":",a,b],:r] => [a,:getFieldNames r] + nil + +formatLocal ["local",a] == format "local " and formatLocal1 a + +formatLocal1 a == + $insideTypeExpression: local := true + format a + diff --git a/src/interp/pspad1.boot.pamphlet b/src/interp/pspad1.boot.pamphlet deleted file mode 100644 index 408ff6f5..00000000 --- a/src/interp/pspad1.boot.pamphlet +++ /dev/null @@ -1,767 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/pspad1.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - -$escapeWords := ["always", "assert", "but", "define", - "delay", "do", "except", "export", "extend", "fix", "fluid", - "from", "generate", "goto", "import", "inline", "never", "select", - "try", "yield"] -$pileStyle := false -$commentIndentation := 8 -$braceIndentation := 8 -$doNotResetMarginIfTrue := true -$marginStack := nil -$numberOfSpills := 0 -$lineFragmentBuffer:= nil -$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) -$lineBuffer := nil -$formatForcePren := nil -$underScore := char ('__) -$rightBraceFlag := nil -$semicolonFlag := nil -$newLineWritten := nil -$comments := nil -$noColonDeclaration := false -$renameAlist := '( - (SmallInteger . SingleInteger) - (SmallFloat . DoubleFloat) - (Void . _(_)) - (xquo . exquo) - (setelt . set_!) - (_$ . _%) - (_$_$ . _$) - (_*_* . _^) - (_^_= . _~_=) - (_^ . _~)) - ---$opRenameAlist := '( --- (and . AND) --- (or . OR) --- (not . NOT)) - - ---====================================================================== --- Main Translator Function ---====================================================================== ---% lisp-fragment to boot-fragment functions -lisp2Boot x == - --entry function - $fieldNames := nil - $pilesAreOkHere: local:= true - $commentsToPrint: local:= nil - $lineBuffer: local - $braceStack: local := nil - $marginStack: local:= [0] - --$autoLine is true except when inside a try---if true, lines are allowed to break - $autoLine:= true - $lineFragmentBuffer:= nil - $bc:=0 --brace count - $m:= 0 - $c:= $m - $numberOfSpills:= 0 - $lineLength:= 80 - format x - formatOutput REVERSE $lineFragmentBuffer - [fragmentsToLine y for y in REVERSE $lineBuffer] - -fragmentsToLine fragments == - string:= lispStringList2String fragments - line:= GETSTR 240 - for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) - line - -lispStringList2String x == - null x => '"" - atom x => STRINGIMAGE x - CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) - lispStringList2String CAR x - ---% routines for buffer and margin adjustment - -formatOutput x == - for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat - startY:= rest start - for [loc,comment] in stack repeat - commentY:= rest loc - gap:= startY-commentY - gap>0 => before:= [[commentY,first loc,gap,comment],:before] - gap=0 => same:= [[startY,1,gap,comment],:same] - true => after:= [[startY,first loc,-gap,comment],:after] - if before then putOut before - if same then - [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] - line:= fragmentsToLine x - x:= - #line+#y>$lineLength => - (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) - [line,y] - consLineBuffer x - for y in extraLines repeat consLineBuffer LIST y - if after then putOut after - $commentsToPrint:= nil - -consLineBuffer x == $lineBuffer := [x,:$lineBuffer] - -putOut x == - eject ("min"/[gap for [.,.,gap,:.] in x]) - for u in orderList x repeat addComment u - -eject n == for i in 2..n repeat consLineBuffer nil - -addComment u == - for x in mkCommentLines u repeat consLineBuffer LIST x - -mkCommentLines [.,n,.,s] == - lines:= breakComments s - lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] - [:l,last]:= lines1 - [:l,fragmentsToLine [last,"_}"]] - -breakComments s == - n:= containsString(s,PNAME "ENDOFLINECHR") => - #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] - LIST SUBSTRING(s,0,n) - LIST s - -containsString(x,y) == - --if string x contains string y, return start index - for i in 0..MAXINDEX x-MAXINDEX y repeat - and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i - ---====================================================================== --- Character/String Buffer Functions ---====================================================================== -consBuffer item == - if item = '"failed" then item := 'failed - n:= - STRINGP item => 2+#item - IDENTP item => #PNAME item - #STRINGIMAGE item - columnsLeft:= $lineLength-$c - if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 - columnsLeft:= $lineLength-$c - --cheat for semicolons, strings, and delimiters: they are NEVER too long - not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => - $autoLine => - --is true except within try - formatOutput REVERSE $lineFragmentBuffer - $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) - $lineFragmentBuffer:= LIST nBlanks $c - consBuffer item - nil - $lineFragmentBuffer:= - ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] - NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] - STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] - sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] - $lineFragmentBuffer - $rightBraceFlag := item = "}" - $semicolonFlag := item = "; " --prevents consecutive semicolons - $c:= $c+n - -isSpecialBufferItem item == - item = "; " or STRINGP item => true - false - -isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") - ---====================================================================== --- Formatting/Line Control Functions ---====================================================================== -newLine() == - null $autoLine => nil - $newLineWritten := true - formatOutput REVERSE $lineFragmentBuffer - $lineFragmentBuffer:= LIST nBlanks $m - $c:= $m - -optNewLine() == - $newLineWritten => newLine() - $c - -spillLine() == - null $autoLine => nil - formatOutput REVERSE $lineFragmentBuffer - $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) - $lineFragmentBuffer:= LIST nBlanks $c - $c - -indent() == - $m:= $m+2*($numberOfSpills+1) - $marginStack:= [$m,:$marginStack] - $numberOfSpills:= 0 - $m - -undent() == --- $doNotResetMarginIfTrue=true => --- pp '"hoho" --- $c - $marginStack is [m,:r] => - $marginStack := r - $m := m - 0 - -spill(fn,a) == - u := try FUNCALL(fn,a) => u - (nearMargin() or spillLine()) and FUNCALL(fn,a) - -formatSpill(fn,a) == - u := try FUNCALL(fn,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) - w := stay or undent() - v and w - -formatSpill2(fn,f,a) == - u := try FUNCALL(fn,f,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) - w := stay or undent() - v and w - -nearMargin() == - $c=$m or $c=$m+1 => $c - ---====================================================================== --- Main Formatting Functions ---====================================================================== -format(x,:options) == - oldC:= $c - qualification := IFCAR options - newCOrNil:= - x is [op,:argl] => - if op = 'return then argl := rest argl - n := #argl - op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) - op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => - formatDollar(name,p,argl) - op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => - formatDollar1(CAR argl,CADR argl) - fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) - if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op - n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => - formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) - n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => - formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) - formatForm x - formatAtom x - null newCOrNil => ($c:= oldC; nil) - null FIXP newCOrNil => error() - $c:= newCOrNil - - -getOp(op,kind) == - kind = 'Led => - MEMQ(op,'(_div _exquo)) => nil - GET(op,'Led) - GET(op,'Nud) - -formatDollar(name,p,argl) == - name := markMacroTran name - n := #argl - kind := (n=1 => "Nud"; "Led") - IDENTP name and GETL(p,kind) => format([p,:argl],name) - formatForcePren [p,:argl] and - (try (format "$$" and formatForcePren name) - or (indent() and format "$__" and formatForcePren name and undent())) - -formatMacroCheck name == - ATOM name => name - u := or/[x for [x,:y] in $globalMacroStack | y = name] => u - u := or/[x for [x,:y] in $localMacroStack | y = name] => u - [op,:argl] := name - MEMQ(op,'(Record Union)) => - pp ['"Cannot find: ",name] - name - [op,:[formatMacroCheck x for x in argl]] - -formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) - -formatDollar1(name,arg) == - id := - IDENTP name => name - name is [p] and GETL(p,'NILADIC) => p - name - format arg and format "$$" and formatForcePren id - - -formatForcePren x == - $formatForcePren: local := true - format x - -formatAtom(x,:options) == - if u := LASSOC(x,$renameAlist) then x := u - null x or isIdentifier x => - if MEMQ(x,$escapeWords) then - consBuffer $underScore - consBuffer ident2PrintImage PNAME x - consBuffer x - -formatFn(fn,x,$m,$c) == FUNCALL(fn,x) - -formatFree(['free,:u]) == - format 'free and format " " and formatComma u - -formatUnion(['Union,:r]) == - $count : local := 0 - formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == - x is [":",y,'Branch] => fn STRINGIMAGE y - STRINGP x => [":", INTERN x, ['Enumeration,x]] - x is [":",:.] => x - tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) - [":", tag, x] - -formatTestForPartial u == - u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => - ['Partial, S] - u - -formatEnumeration(y is ['Enumeration,:r]) == - r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" - formatForm y - -formatRecord(u) == formatFormNoColonDecl u - -formatFormNoColonDecl u == - $noColonDeclaration: local := true - formatForm u - -formatElt(u) == - u is ["elt",a,b] => formatApplication rest u - formatForm u - -formatForm (u) == - [op,:argl] := u - if MEMQ(op, '(Record Union)) then - $fieldNames := union(getFieldNames argl,$fieldNames) - MEMQ(op,'((QUOTE T) true)) => format "true" - MEMQ(op,'(false nil)) => format op - u='(Zero) => format 0 - u='(One) => format 1 - 1=#argl => formatApplication u - formatFunctionCall u - -formatFunctionCall u == - $pilesAreOkHere: local - spill("formatFunctionCall1",u) - -formatFunctionCall1 [op,:argl] == ---null argl and getConstructorProperty(op,'niladic) => formatOp op - null argl => - GETL(op,'NILADIC) => formatOp op - formatOp op and format "()" - formatOp op and formatFunctionCallTail argl - -formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" - -formatComma argl == - format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c - -formatOp op == - atom op => formatAtom op - formatPren op - -formatApplication u == - [op,a] := u - MEMQ(a, $fieldNames) => formatSelection u - atom op => - formatHasDotLeadOp a => formatOpPren(op,a) - formatApplication0 u - formatSelection u - -formatHasDotLeadOp u == - u is [op,:.] and (op = "." or not atom op) - -formatApplication0 u == ---format as f(x) as f x if possible - $pilesAreOkHere: local - formatSpill("formatApplication1",u) - -formatApplication1 u == - [op,x] := u - formatHasDollarOp x or $formatForcePren or - pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) - try (formatOp op and format " ") and - (try formatApplication2 x or - format "(" and formatApplication2 x and format ")") - -formatHasDollarOp x == - x is ["elt",a,b] and isTypeProbably? a - -isTypeProbably? x == - IDENTP x and UPPER_-CASE_-P (PNAME x).0 - -formatOpPren(op,x) == formatOp op and formatPren x - -formatApplication2 x == - leadOp := - x is [['elt,.,y],:.] => y - opOf x - MEMQ(leadOp,'(COLLECT LIST construct)) or - pspadBindingPowerOf("left",x)<1000 => formatPren x - format x - -formatDot ["dot",a,x] == - try (formatOp a and format ".") and - ATOM x => format x - formatPren x - -formatSelection u == - $pilesAreOkHere: local - formatSpill("formatSelection1",u) - -formatSelection1 [f,x] == formatSelectionOp f and format "." and - ATOM x => format x - formatPren x - -formatSelectionOp op == - op is [f,.] and not GET(f,'Nud) or - 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op - formatPren1("formatSelectionOp1",op) - -formatSelectionOp1 f == - f is [op,:argl] => - argl is [a] => - not ATOM op and ATOM a => formatSelection1 [op,a] - formatPren f - format f - formatOp f - -formatPren a == - $pilesAreOkHere: local - formatSpill("formatPrenAux",a) - -formatPrenAux a == format "_(" and format a and format "_)" - -formatPren1(f,a) == - $pilesAreOkHere: local - formatSpill2("formatPren1Aux",f,a) - -formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" - -formatLeft(fn,x,op,key) == - lbp:= formatOpBindingPower(op,key,"left") - formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) - FUNCALL(fn,x) - -formatRight(fn,x,op,key) == - --are there exceptional cases where piles are ok? - x is ['LET,:.] => FUNCALL(fn,x) - --decide on basis of binding power whether prens are needed - rbp := formatOpBindingPower(op,key,"right") - lbp := formatOpBindingPower(opOf x,key,"left") - lbp < rbp => formatPren1(fn,x) - FUNCALL(fn,x) - -formatCut a == formatSpill("format",a) - ---====================================================================== --- Prefix/Infix Operators ---====================================================================== -formatPrefix(op,arg,lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local - formatPrefixOp(op,qualification) and - (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) - -formatPrefixOp(op,:options) == - qualification := IFCAR options - op=char '" " => format " =" - qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => - formatQual(op,qualification) and format " " - format op - -formatQual(op,D) == - null D => format op - format op and format "$$" and format D - -formatInfix(op,[a,b],lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local - (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) - then formatPren b else format b) - -formatGetBindingPowerOf(leftOrRight,x) == --- this function is nearly identical with getBindingPowerOf --- leftOrRight = "left" => 0 --- 1 - pspadBindingPowerOf(leftOrRight,x) - -pspadBindingPowerOf(key,x) == - --binding powers can be found in file NEWAUX LISP - x is ['REDUCE,:.] => (key='left => 130; key='right => 0) - x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) - x is ["COND",:.] => (key="left" => 130; key="right" => 0) - x is [op,:argl] => - if op is [a,:.] then op:= a - op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 - op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) - (n:= #argl)=1 => - key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m - 1000 - n>1 => - key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m - op="ELT" => 1002 - 1000 - 1000 - 1002 - -pspadOpBindingPower(op,LedOrNud,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - MEMQ(op,'(_:)) and LedOrNud = 'Led => - leftOrRight = 'left => 195 - 196 - exception:= - leftOrRight="left" => 0 - 105 - bp:= - leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) - rightBindingPowerOf(op,LedOrNud) - bp^=exception => bp - 1000 - -formatOpBindingPower(op,key,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - op = '_$ => 1002 - MEMQ(op,'(_:)) and key = 'Led => - leftOrRight = 'left => 195 - 196 - MEMQ(op,'(_^_= _>_=)) => 400 - op = "not" and key = "Nud" => - leftOrRight = 'left => 1000 - 1001 - GETL(op,key) is [.,.,:r] => - leftOrRight = 'left => KAR r or 0 - KAR KDR r or 1 - 1000 - -formatInfixOp(op,:options) == - qualification := IFCAR options - qualification or - (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " - format op - ---====================================================================== --- Special Handlers: DEF forms ---====================================================================== - -formatDEF def == formatDEF0(def,$DEFdepth + 1) - -formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == - if not MEMQ(KAR form,'(Exports Implementation)) then - $form := - form is [":",a,:.] => a - form - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $abb :local := constructor? opOf $form - if $DEFdepth < 2 then - condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] - $numberOfSpills := -1 - consComments(condoc,'"+++ ") - form := formatDeftranForm(form,tlist) - u := ["DEF",form,tlist,sclist,body] - v := formatDEF1 u => v - $insideDEF: local := $DEFdepth > 1 - $DEFdepth = 1 => - exname := 'Exports - impname := 'Implementation - form is [":",.,=exname] or body = impname => nil - exports := - form is [":",a,b] => - form := a - [["MDEF",exname,'(NIL),'(NIL),b]] - nil - [op,:argl] := form --- decls := [x for x in argl | x is [":",:.]] --- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] --- $DEFdepth := $DEFdepth - 1 - formatWHERE(["where", - ["DEF",[":",form,exname],[nil for x in form],sclist,impname], - ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) - $insideTypeExpression: local := true - body := formatDeftran(body,false) - body is ["add",a,:b] => formatAddDef(form,a,b) ---body is ["with",a,:b] => formatWithDef(form,a,b) - tryBreakNB(format form and format " == ",body,"==","Led") - -formatDEF1 ["DEF",form,tlist,b,body] == - $insideDEF: local := $DEFdepth > 1 - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - form := formatDeftran(form,false) - body := formatDeftran(body,false) - ---------> terrible, hideous, but temporary, hack - if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] - prefix := (opOf tlist = 'Category => "define "; nil) - body is ["add",a,b] => formatAddDef(form,a,b) - body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) - prefix => - tryBreak(format prefix and format form and format " == ",body,"==","Led") - tryBreak(format form and format " == ",body,"==","Led") - -formatDefForm(form,:options) == - prefix := IFCAR options - $insideTypeExpression : local := true - form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) - prefix => format prefix and format form - format form - -formatAddDef(form,a,b) == - $insideCAPSULE : local := true - $insideDEF : local := false - formatDefForm form or return nil - $marginStack := [0] - $m := $c := 0 - $insideTypeExpression : local := false - cap := (b => b; "") - tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") - and format " add ", cap,"add","Led") - -formatWithDef(form,a,b,separator,:options) == - prefix := IFCAR options - $insideEXPORTS : local := true - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - a1 := formatWithKillSEQ a - b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") - and format " with ",first b,"with","Led") - tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") - -formatWithKillSEQ x == - x is ['SEQ,['exit,.,y]] => ['BRACE, y] - x - -formatBrace ['BRACE, x] == format "{" and format x and format "}" - -formatWith ["with",a,:b] == - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatWithDefault ["withDefault",a,b] == - if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then - part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] - if IFCAR init then - a:= IFCAR init - b:= [part2] - else - a := part2 - b := nil - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatDefaultDefs ["default",a, :b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreak(formatLeft("format",a,"default","Led") and - format " default ", first b,"default","Led") - tryBreak(format "default ",a,"default","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatAdd ["add",a,:b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreakNB(formatLeft("format",a,"and","Led") and - format " and ", first b,"and","Led") - tryBreakNB(format "add ",a,"and","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatMDEF ["MDEF",form,.,.,body] == - form is '(Rep) => formatDEF ["DEF",form,.,.,body] - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - body := formatDeftran(body,false) - name := opOf form - tryBreakNB(format name and format " ==> ",body,"==","Led") - and ($insideCAPSULE and $c or format(";")) - -insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue - or $noColonDeclaration - -formatImport ["import",a] == - addFieldNames a - addFieldNames macroExpand(a,$e) - format "import from " and formatLocal1 a - -addFieldNames a == - a is [op,:r] and MEMQ(op,'(Record Union)) => - $fieldNames := union(getFieldNames r,$fieldNames) - a is ['List,:b] => addFieldNames b - nil - -getFieldNames r == - r is [[":",a,b],:r] => [a,:getFieldNames r] - nil - -formatLocal ["local",a] == format "local " and formatLocal1 a - -formatLocal1 a == - $insideTypeExpression: local := true - format a - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad2.boot b/src/interp/pspad2.boot new file mode 100644 index 00000000..d97d4cea --- /dev/null +++ b/src/interp/pspad2.boot @@ -0,0 +1,661 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +--====================================================================== +-- Constructor Transformation Functions +--====================================================================== +formatDeftranForm(form,tlist) == + [ttype,:atypeList] := tlist + if form is [":",f,t] then + form := f + ttype := t + if form is ['elt,a,b] then ----> a.b ====> apply(b,a) + form := + isTypeProbably? a => + atypeList := REVERSE atypeList + ["$$", b, a] + ["apply",a, b] + op := KAR form + argl := KDR form + if or/[t for t in atypeList] then + form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] + if ttype then form := [":",form,ttype] + form + +formatDeftran(u,SEQflag) == + u is ['Join,:x] => formatDeftranJoin(u,SEQflag) + u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) + u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) + u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) + u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => + formatDeftranColon(u,SEQflag) + u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) + u is ['SEQ,:l,[.,n,x]] => + v := [:l,x] + a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] + b := formatDeftranSEQ(x,false) + if b is [:.,c] and c = '(void) then b := DROP(-1, b) + [:m,y] := [:a,:b] + ['SEQ,:m,['exit,n,y]] +-- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => +-- formatDeftran([op,:CDR arg],nil) + u is ["^",a] => formatDeftran(['not,a],SEQflag) + u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) + u is ['IF,a,b,c] => + a := formatDeftran(a,nil) + b := formatDeftran(b,nil) + c := formatDeftran(c,nil) + null SEQflag and $insideDEF => + [:y,last] := formatDeftranIf(a,b,c) + ['SEQ,:y,['exit,1,last]] + ['IF,a,b,c] + u is ['Union,:argl] => + ['Union,:[x for a in argl + | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] + u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and + ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => + formatDeftran([op,:nitl,nbody],SEQflag) + u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] + u is ["DEF",:.] => formatCapsuleFunction(u) + u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] + u = 'nil => 'empty + u + +formatCapsuleFunction ["DEF",form,tlist,b,body] == + $insideDEF : local := true + ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] + +formatDeftranCapsule(l,x,SEQflag) == + $insideCAPSULE: local := true + formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) + +formatDeftranRepper([op,a],SEQflag) == + a is [op1,b] and MEMQ(op1,'(rep per)) => + op = op1 => formatDeftran(a,SEQflag) + formatDeftran(b,SEQflag) + a is ["::",b,t] => + b := formatDeftran(b,SEQflag) + t := formatDeftran(t,SEQflag) + a := ["::",b,t] + op = 'per and t = "$" or op = 'rep and t = 'Rep => a + [op,a] + a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] + a is ['IF,p,b,c] => + formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) + a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) + a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => + formatDeftran [op1,a,b] + a is ['return,n,r] => + MEMQ(opOf r,'(true false)) => a + ['return,n,[op,formatDeftran(r,SEQflag)]] + a is ['error,:.] => a + [op,formatDeftran(a,SEQflag)] + +formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ + a := formatDeftran(a,SEQflag) + t := formatDeftran(t,SEQflag) + a is ["UNCOERCE",b] => b + a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => + op1 = "pretend" or op = "pretend" => ["pretend",b,t] + null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] + a + a is [=op,b,t1] => + t1 = t => a + [op,b,t] + t = "$" => + a is ['rep,b] => b + a is ['per,b] => a + [op,a,t] + t = "Rep" => + a is ['per,b] => b + a is ['rep,b] => a + [op,a,t] + [op,a,t] + +formatSeqRepper(op,x) == + x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] + x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] + atom x => x + [formatSeqRepper(op,y) for y in x] + +formatDeftranJoin(u,SEQflag) == + ['Join,:cats,lastcat] := u + lastcat is ['CATEGORY,kind,:l,x] => + cat := + CDR cats => ['Join,:cats] + first cats + formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) + u + +formatENUM ['MyENUM, x] == format "'" and format x and format "'" + +formatDeftranREPEAT(itl,body) == +--do nothing unless "itl" contains UNTIL statements + u := [x for x in itl | x is ["UNTIL",p]] or return nil + nitl := SETDIFFERENCE(itl,u) + pred := MKPF([p for ['UNTIL,p] in u],'or) + cond := ['IF,pred,['leave,n,nil],'noBranch] + nbody := + body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] + ['SEQ,body,['exit,n,cond]] + [nitl,:nbody] + +formatDeftranSEQ(x,flag) == + u := formatDeftran(x,flag) + u is ['SEQ,:.] => rest u + [u] + +formatDeftranIf(a,b,c) == + b = 'noBranch => + a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); + iop := LASSOC(op, al) or rassoc(op, al)) => + [["=>",[iop, :r],c]] + a is [op,r] and MEMQ(op,'(NOT not NULL null)) => + [["=>", r, c]] + [["=>", ['not, a], c]] + post := + c = 'noBranch => nil + c is ['SEQ,:.] => CDR c + [c] + [["=>",a,b],:post] + +formatWHERE ["where",a,b] == + $insideTypeExpression: local := nil + $insideCAPSULE: local := false + tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") + +--====================================================================== +-- Special Handlers: Categories +--====================================================================== +formatATTRIBUTE ['ATTRIBUTE,att] == format att + +formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] + +formatCategory ['Category] == format " " and format "Category" + +formatCATEGORY cat == + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $insideEXPORTS : local := true + format ["with",formatDeftranCategory cat] + +formatSIGNATURE ['SIGNATURE,op,types,:r] == + MEMQ('constant,r) => format op and format ": " and (u := format first types) and + formatSC() and formatComments(u,op,types) + format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and + formatComments(u,op,types) + +formatDefault ["default",a] == + $insideCategoryIfTrue : local := false + $insideCAPSULE: local := true + $insideTypeExpression: local := false + tryBreak(format "default ",a,"with","Nud") +--====================================================================== +-- Special Handlers: Control Structures +--====================================================================== +formatUNCOERCE ['UNCOERCE,x] == format x + +formatIF ['IF,a,b,c] == + c = 'noBranch => formatIF2(a,b,"if ") + b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] + formatIF2(a,b,"if ") and newLine() and formatIF3 c + +formatIF2(a,b,prefix) == + tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") + +formatIF3 x == + x is ['IF,a,b,c] => + c = 'noBranch => tryBreak(format "else if " + and format a and format " then ",b,"then","Nud") + formatIF2(a,b,"else if ") and newLine() and formatIF3 c + tryBreak(format "else ",x,"else","Nud") + +formatBlock(l,x) == + null l => format x + $pilesAreOkHere: local + format "{ " and format first l and + (and/[formatSC() and format y for y in rest l]) + and formatSC() and format x and format " }" + +formatExit ["exit",.,u] == format u + +formatvoid ["void"] == format "()" + +formatLeave ["leave",.,u] == format "break" + +formatCOLLECT u == formatSpill("formatCOLLECT1",u) + +formatCOLLECT1 ["COLLECT",:iteratorList,body] == + $pilesAreOkHere: local + format "[" and format body and format " " and + formatSpill("formatIteratorTail",iteratorList) + +formatIteratorTail iteratorList == + formatIterator first iteratorList and + (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" + +--====================================================================== +-- Special Handlers: Keywords +--====================================================================== + +formatColon [":",a,b] == + b is ['with,c,:d] => formatColonWith(a,c,d) + if not $insideTypeExpression then + insideCat() => nil + format + $insideDEF => "local " + "default " + op := + $insideCAPSULE and not $insideDEF => ": " + insideCat() => ": " + ":" + b := (atom b => b; markMacroTran b) + a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b + formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), + formatOpBindingPower(":","Led","right")) + +formatColonWith(form,a,b) == + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $insideEXPORTS : local := true + $pilesAreOkHere: local := true + $insideTypeExpression : local := false + b => tryBreak(formatDefForm form and format ": " + and format a and format " with ",first b,"with","Led") + tryBreak(formatDefForm form and format ": with ",a,"with","Nud") + +formatCOND ["COND",:l] == + originalC:= $c + and/[x is [a,[.,.,b]] for x in l] => + (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and + formatIfExit(a,b) and + (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC + formatIfThenElse l + +formatPROGN ["PROGN",:l] == + l is [:u,x] => formatPiles(u,x) + error '"formatPROGN" + +formatELT ["ELT",a,b] == formatApplication [a,b] + +formatCONS ["CONS",a,b] == + $pilesAreOkHere: local + format "[" and formatConstructItem a and formatTail b + +formatTail x == + null x => format "]" + format "," and formatTail1 x + +formatTail1 x == + x is ["CONS",a,b] => formatConstructItem a and formatTail b + x is ["APPEND",a,b] => + null b => formatConstructItem a and format "]" + format ":" and formatConstructItem a and formatTail b + format ":" and formatConstructItem x and format "]" + +-- x = "." => format " " +formatConstructItem x == format x + +formatLET ["LET",a,b] == + $insideTypeExpression: local := true + a = "Rep" or atom a and constructor? opOf b => + tryBreakNB(formatAtom a and format " == ",b,":=","Led") + tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") + +formatIfExit(a,b) == + --called from SCOND or COND only + $numberOfSpills: local:= 0 + curMargin:= $m + curMarginStack:= $currentMarginStack + $doNotResetMarginIfTrue:= true + format a and format " => " and formatRight("formatCut",b,"=>","Led") => + ($currentMarginStack:= curMarginStack; $m:= curMargin) + +formatIfThenElse x == formatSpill("formatIf1",x) + +formatIf1 x == + x is [[a,:r],:c] and null c => + b:= + r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] + first r + isTrue a => format b + format "if " and format a and format " then " and format b + format "if " and format a and + (try + (format " then " and format b and format " else " + and formatIfThenElse c) or spillLine() + and format " then " and format b and +-- ($c:= $m:= $m+6) and + ($numberOfSpills:= $numberOfSpills-1) + and spillLine() and format " else " and formatIfThenElse c) + +formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" + +formatMI ["MI",a,b] == format a + +formatMapping ['Mapping,target,:sources] == + $noColonDeclaration: local := true + formatTuple ['Tuple,:sources] and format " -> " and format target + +formatTuple ['Tuple,:types] == + null types => format "()" + null rest types => format first types + formatFunctionCallTail types + +formatConstruct(['construct,:u]) == + format "[" and (null u or format first u and + "and"/[format "," and formatCut x for x in rest u]) and format "]" + +formatNextConstructItem x == + try format x or ($m := $m + 2) and newLine() and format x + +formatREPEAT ["REPEAT",:iteratorList,body] == + tryBreakNB(null iteratorList or (formatIterator first iteratorList and + (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") + and format "repeat ",body,"repeat","Led") + +formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") + +formatMap ["+->",a,b] == + $noColonDeclaration: local := true + tryBreak(format a and format " +-> ", b, "+->","Led") + +formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) + +formatreduce ["reduce",op,u] == formatReduce1(op,u) + +formatReduce1(op,u) == + if STRINGP op then op := INTERN op + id := LASSOC(op, + '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) + formatFunctionCall + id => ['reduce,op,u,id] + ['reduce,op,u] + +formatIterator u == + $noColonDeclaration : local := true + u is ["IN",x,y] => + format "for " and formatLeft("format",x,"in","Led") and format " in " and + formatRight("format",y,"in","Led") + u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") + u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") + u is ["|",x] => format "| " and formatRight("format",x,"|","Led") + u is ["STEP",i,init,step,:v] => + final := IFCAR v + format "for " and formatLeft("format",i,"in","Led") and format " in " and + (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) + error "formatIterator" + +formatStepOne? step == + step = 1 or step = '(One) => true + step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) + false + +formatBy ['by,seg,step] == format seg and format " by " and format step + +formatSCOND ["SCOND",:l] == + $pilesAreOkHere => + --called from formatPileLine or formatBlock + --if from formatPileLine + initialC:= $c + and/[x is [a,["exit",.,b]] for x in l] => + first l is [a,["exit",.,b]] and formatIfExit(a,b) and + (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC + formatIfThenElse l and initialC + and/[x is [a,["exit",.,b]] for x in l] => + first l is [a,["exit",.,b]] and formatIfExit(a,b) and + (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c + --warning: and/(...) returns T if there are no entries + formatIfThenElse l + +formatSEGMENT ["SEGMENT",a,b] == + $pilesAreOkHere: local + (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and + formatInfixOp ".." and + (null b and $c or + (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) + +formatSexpr x == + atom x => + null x or IDENTP x => consBuffer ident2PrintImage PNAME x + consBuffer x + spill("formatNonAtom",x) + +formatNonAtom x == + format "_(" and formatSexpr first x and + (and/[format " " and formatSexpr y for y in rest x]) + and (y:= LASTATOM x => format " . " + and formatSexpr y; true) and format "_)" + +formatCAPSULE ['CAPSULE,:l,x] == + $insideCAPSULE: local := true + try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) + +formatPAREN [.,:argl] == formatFunctionCallTail argl + +formatSEQ ["SEQ",:l,[.,.,x]] == + try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) + +--====================================================================== +-- Comment Handlers +--====================================================================== +formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == + $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] + format x + +formatComments(u,op,types) == + $numberOfSpills :local := $commentIndentation/2 - 1 + not $insideEXPORTS => u + alist := LASSOC(op,$comments) or + sayBrightly ['"No documentation for ",op] + return u + ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) + consComments(LASSOC(ftypes,alist),'"++ ") + u + +consComments(s,plusPlus) == + s is [word,:r] and null atom r => consComments(r, plusPlus) + s := first s + null s => nil + s := consCommentsTran s + indent() and newLine() or return nil + columnsLeft := $lineLength - $m - 2 + while (m := MAXINDEX s) >= columnsLeft repeat + k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] + k := (k => k + 1; columnsLeft) + piece := SUBSTRING(s,0,k) + formatDoCommentLine [plusPlus,piece] + s := SUBSTRING(s,k,nil) + formatDoCommentLine [plusPlus,s] + undent() + $m + +consCommentsTran s == + m := MAXINDEX s + k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => + r := charPosition(char '_},s,k + 6) + r = m + 1 => s + STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) + s + +formatDoCommentLine line == + $lineBuffer := consLineBuffer [nBlanks $c,:line] + $c := $m+2*$numberOfSpills + +--====================================================================== +-- Pile Handlers +--====================================================================== +formatPreferPile y == + y is ["SEQ",:l,[.,.,x]] => + (u:= formatPiles(l,x)) => u + formatSpill("format",y) + formatSpill("format",y) + +formatPiles(l,x) == + $insideTypeExpression : local := false + not $pilesAreOkHere => nil + originalC:= $c + lines:= [:l,x] + --piles must begin at margin + originalC=$m or indent() and newLine() or return nil + null (formatPileLine($m,first lines,false)) => nil + not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil + (originalC=$m or undent()) and originalC --==> brace + +formatPileLine($m,x,newLineIfTrue) == + if newLineIfTrue then newLine() or return nil + $numberOfSpills: local:= 0 + $newLineWritten := nil + format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) + and (x is ['DEF,:.] and optNewLine() or $c) + +--====================================================================== +-- Utility Functions +--====================================================================== +nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] + +isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") + +isTrue x == x="true" or x is '(QUOTE T) + +nary2Binary(u,op) == + u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) + errhuh() + +string2PrintImage s == + u:= GETSTR (2*SIZE s) + for i in 0..MAXINDEX s repeat + (if MEMQ(s.i,'(_( _{ _) _} _! _")) then + SUFFIX('__,u); u:= SUFFIX(s.i,u)) + u + +ident2PrintImage s == + m := MAXINDEX s + if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) + u:= GETSTR (2*SIZE s) + if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) + u:= SUFFIX(s.(0),u) + for i in 1..MAXINDEX s repeat + if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) + or (c = char '_!)) then SUFFIX('__,u) + u:= SUFFIX(s.i,u) + INTERN u + +isIdentifier x == + IDENTP x => + s:= PNAME x + #s = 0 => nil + ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] + #s>1 => + or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => + and/[s.i^=char '" " for i in 1..m] => true + +isGensym x == + s := STRINGIMAGE x + n := MAXINDEX s + s.0 = char '_G and and/[DIGITP s.i for i in 1..n] + +--====================================================================== +-- Macro Helpers +--====================================================================== +tryToFit(s,x) == +--% try to format on current line; see macro try in file PSPADAUX LISP + --returns nil if unable to format stuff in x on a single line + x => ($back:= rest $back; $c) + restoreState() + nil + +restoreState(:options) == + back := IFCAR options or $back + [ + [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, + $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] + := back + if null options then $back := back + [$newLineWritten, $autoLine, $rightBraceFlag, + $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, + $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, + $doNotResetMarginIfTrue,$noColonDeclaration] + := flags + nil + +saveState(:options) == + flags := + [$newLineWritten, $autoLine, $rightBraceFlag, + $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, + $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, + $doNotResetMarginIfTrue,$noColonDeclaration] + newState := + [ + [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, + $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] + if not KAR options then $back := newState + newState + +formatSC() == + $pileStyle or $semicolonFlag => $c + format "; " + +wrapBraces(x,y,z) == y + +formatLB() == + $pileStyle => $c + $numberOfSpills := + $c > $lineLength / 2 => $braceIndentation/3 - 1 + $braceIndentation/2 - 1 + format "{" + +restoreC() == --used by macro "embrace" + originalC := CAR $braceStack + $braceStack := CDR $braceStack + formatRB originalC + +saveC() == --used by macro "embrace" + $braceStack := [$c,:$braceStack] + +saveD() == --used by macro "embrace" + $braceStack := [$c,:$braceStack] + +restoreD() == --used by macro "indentNB" + originalC := CAR $braceStack + $braceStack := CDR $braceStack + originalC + +formatRB(originalC) == --called only by restoreC + while $marginStack and $m > originalC repeat undent() + if $m < originalC then $marginStack := [originalC,:$marginStack] + $m := originalC + $pileStyle => $m + newLine() and format "}" and $m --==> brace + diff --git a/src/interp/pspad2.boot.pamphlet b/src/interp/pspad2.boot.pamphlet deleted file mode 100644 index 54e9a584..00000000 --- a/src/interp/pspad2.boot.pamphlet +++ /dev/null @@ -1,683 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pspad2.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. - -@ -<<*>>= -<> - -)package "BOOT" - ---====================================================================== --- Constructor Transformation Functions ---====================================================================== -formatDeftranForm(form,tlist) == - [ttype,:atypeList] := tlist - if form is [":",f,t] then - form := f - ttype := t - if form is ['elt,a,b] then ----> a.b ====> apply(b,a) - form := - isTypeProbably? a => - atypeList := REVERSE atypeList - ["$$", b, a] - ["apply",a, b] - op := KAR form - argl := KDR form - if or/[t for t in atypeList] then - form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] - if ttype then form := [":",form,ttype] - form - -formatDeftran(u,SEQflag) == - u is ['Join,:x] => formatDeftranJoin(u,SEQflag) - u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) - u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) - u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) - u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => - formatDeftranColon(u,SEQflag) - u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - u is ['SEQ,:l,[.,n,x]] => - v := [:l,x] - a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] - b := formatDeftranSEQ(x,false) - if b is [:.,c] and c = '(void) then b := DROP(-1, b) - [:m,y] := [:a,:b] - ['SEQ,:m,['exit,n,y]] --- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => --- formatDeftran([op,:CDR arg],nil) - u is ["^",a] => formatDeftran(['not,a],SEQflag) - u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) - u is ['IF,a,b,c] => - a := formatDeftran(a,nil) - b := formatDeftran(b,nil) - c := formatDeftran(c,nil) - null SEQflag and $insideDEF => - [:y,last] := formatDeftranIf(a,b,c) - ['SEQ,:y,['exit,1,last]] - ['IF,a,b,c] - u is ['Union,:argl] => - ['Union,:[x for a in argl - | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] - u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and - ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => - formatDeftran([op,:nitl,nbody],SEQflag) - u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] - u is ["DEF",:.] => formatCapsuleFunction(u) - u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] - u = 'nil => 'empty - u - -formatCapsuleFunction ["DEF",form,tlist,b,body] == - $insideDEF : local := true - ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] - -formatDeftranCapsule(l,x,SEQflag) == - $insideCAPSULE: local := true - formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - -formatDeftranRepper([op,a],SEQflag) == - a is [op1,b] and MEMQ(op1,'(rep per)) => - op = op1 => formatDeftran(a,SEQflag) - formatDeftran(b,SEQflag) - a is ["::",b,t] => - b := formatDeftran(b,SEQflag) - t := formatDeftran(t,SEQflag) - a := ["::",b,t] - op = 'per and t = "$" or op = 'rep and t = 'Rep => a - [op,a] - a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] - a is ['IF,p,b,c] => - formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) - a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) - a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => - formatDeftran [op1,a,b] - a is ['return,n,r] => - MEMQ(opOf r,'(true false)) => a - ['return,n,[op,formatDeftran(r,SEQflag)]] - a is ['error,:.] => a - [op,formatDeftran(a,SEQflag)] - -formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ - a := formatDeftran(a,SEQflag) - t := formatDeftran(t,SEQflag) - a is ["UNCOERCE",b] => b - a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => - op1 = "pretend" or op = "pretend" => ["pretend",b,t] - null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] - a - a is [=op,b,t1] => - t1 = t => a - [op,b,t] - t = "$" => - a is ['rep,b] => b - a is ['per,b] => a - [op,a,t] - t = "Rep" => - a is ['per,b] => b - a is ['rep,b] => a - [op,a,t] - [op,a,t] - -formatSeqRepper(op,x) == - x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] - x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] - atom x => x - [formatSeqRepper(op,y) for y in x] - -formatDeftranJoin(u,SEQflag) == - ['Join,:cats,lastcat] := u - lastcat is ['CATEGORY,kind,:l,x] => - cat := - CDR cats => ['Join,:cats] - first cats - formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) - u - -formatENUM ['MyENUM, x] == format "'" and format x and format "'" - -formatDeftranREPEAT(itl,body) == ---do nothing unless "itl" contains UNTIL statements - u := [x for x in itl | x is ["UNTIL",p]] or return nil - nitl := SETDIFFERENCE(itl,u) - pred := MKPF([p for ['UNTIL,p] in u],'or) - cond := ['IF,pred,['leave,n,nil],'noBranch] - nbody := - body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] - ['SEQ,body,['exit,n,cond]] - [nitl,:nbody] - -formatDeftranSEQ(x,flag) == - u := formatDeftran(x,flag) - u is ['SEQ,:.] => rest u - [u] - -formatDeftranIf(a,b,c) == - b = 'noBranch => - a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); - iop := LASSOC(op, al) or rassoc(op, al)) => - [["=>",[iop, :r],c]] - a is [op,r] and MEMQ(op,'(NOT not NULL null)) => - [["=>", r, c]] - [["=>", ['not, a], c]] - post := - c = 'noBranch => nil - c is ['SEQ,:.] => CDR c - [c] - [["=>",a,b],:post] - -formatWHERE ["where",a,b] == - $insideTypeExpression: local := nil - $insideCAPSULE: local := false - tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") - ---====================================================================== --- Special Handlers: Categories ---====================================================================== -formatATTRIBUTE ['ATTRIBUTE,att] == format att - -formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] - -formatCategory ['Category] == format " " and format "Category" - -formatCATEGORY cat == - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $insideEXPORTS : local := true - format ["with",formatDeftranCategory cat] - -formatSIGNATURE ['SIGNATURE,op,types,:r] == - MEMQ('constant,r) => format op and format ": " and (u := format first types) and - formatSC() and formatComments(u,op,types) - format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and - formatComments(u,op,types) - -formatDefault ["default",a] == - $insideCategoryIfTrue : local := false - $insideCAPSULE: local := true - $insideTypeExpression: local := false - tryBreak(format "default ",a,"with","Nud") ---====================================================================== --- Special Handlers: Control Structures ---====================================================================== -formatUNCOERCE ['UNCOERCE,x] == format x - -formatIF ['IF,a,b,c] == - c = 'noBranch => formatIF2(a,b,"if ") - b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] - formatIF2(a,b,"if ") and newLine() and formatIF3 c - -formatIF2(a,b,prefix) == - tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") - -formatIF3 x == - x is ['IF,a,b,c] => - c = 'noBranch => tryBreak(format "else if " - and format a and format " then ",b,"then","Nud") - formatIF2(a,b,"else if ") and newLine() and formatIF3 c - tryBreak(format "else ",x,"else","Nud") - -formatBlock(l,x) == - null l => format x - $pilesAreOkHere: local - format "{ " and format first l and - (and/[formatSC() and format y for y in rest l]) - and formatSC() and format x and format " }" - -formatExit ["exit",.,u] == format u - -formatvoid ["void"] == format "()" - -formatLeave ["leave",.,u] == format "break" - -formatCOLLECT u == formatSpill("formatCOLLECT1",u) - -formatCOLLECT1 ["COLLECT",:iteratorList,body] == - $pilesAreOkHere: local - format "[" and format body and format " " and - formatSpill("formatIteratorTail",iteratorList) - -formatIteratorTail iteratorList == - formatIterator first iteratorList and - (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" - ---====================================================================== --- Special Handlers: Keywords ---====================================================================== - -formatColon [":",a,b] == - b is ['with,c,:d] => formatColonWith(a,c,d) - if not $insideTypeExpression then - insideCat() => nil - format - $insideDEF => "local " - "default " - op := - $insideCAPSULE and not $insideDEF => ": " - insideCat() => ": " - ":" - b := (atom b => b; markMacroTran b) - a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b - formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), - formatOpBindingPower(":","Led","right")) - -formatColonWith(form,a,b) == - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $insideEXPORTS : local := true - $pilesAreOkHere: local := true - $insideTypeExpression : local := false - b => tryBreak(formatDefForm form and format ": " - and format a and format " with ",first b,"with","Led") - tryBreak(formatDefForm form and format ": with ",a,"with","Nud") - -formatCOND ["COND",:l] == - originalC:= $c - and/[x is [a,[.,.,b]] for x in l] => - (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and - formatIfExit(a,b) and - (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC - formatIfThenElse l - -formatPROGN ["PROGN",:l] == - l is [:u,x] => formatPiles(u,x) - error '"formatPROGN" - -formatELT ["ELT",a,b] == formatApplication [a,b] - -formatCONS ["CONS",a,b] == - $pilesAreOkHere: local - format "[" and formatConstructItem a and formatTail b - -formatTail x == - null x => format "]" - format "," and formatTail1 x - -formatTail1 x == - x is ["CONS",a,b] => formatConstructItem a and formatTail b - x is ["APPEND",a,b] => - null b => formatConstructItem a and format "]" - format ":" and formatConstructItem a and formatTail b - format ":" and formatConstructItem x and format "]" - --- x = "." => format " " -formatConstructItem x == format x - -formatLET ["LET",a,b] == - $insideTypeExpression: local := true - a = "Rep" or atom a and constructor? opOf b => - tryBreakNB(formatAtom a and format " == ",b,":=","Led") - tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") - -formatIfExit(a,b) == - --called from SCOND or COND only - $numberOfSpills: local:= 0 - curMargin:= $m - curMarginStack:= $currentMarginStack - $doNotResetMarginIfTrue:= true - format a and format " => " and formatRight("formatCut",b,"=>","Led") => - ($currentMarginStack:= curMarginStack; $m:= curMargin) - -formatIfThenElse x == formatSpill("formatIf1",x) - -formatIf1 x == - x is [[a,:r],:c] and null c => - b:= - r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] - first r - isTrue a => format b - format "if " and format a and format " then " and format b - format "if " and format a and - (try - (format " then " and format b and format " else " - and formatIfThenElse c) or spillLine() - and format " then " and format b and --- ($c:= $m:= $m+6) and - ($numberOfSpills:= $numberOfSpills-1) - and spillLine() and format " else " and formatIfThenElse c) - -formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" - -formatMI ["MI",a,b] == format a - -formatMapping ['Mapping,target,:sources] == - $noColonDeclaration: local := true - formatTuple ['Tuple,:sources] and format " -> " and format target - -formatTuple ['Tuple,:types] == - null types => format "()" - null rest types => format first types - formatFunctionCallTail types - -formatConstruct(['construct,:u]) == - format "[" and (null u or format first u and - "and"/[format "," and formatCut x for x in rest u]) and format "]" - -formatNextConstructItem x == - try format x or ($m := $m + 2) and newLine() and format x - -formatREPEAT ["REPEAT",:iteratorList,body] == - tryBreakNB(null iteratorList or (formatIterator first iteratorList and - (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") - and format "repeat ",body,"repeat","Led") - -formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") - -formatMap ["+->",a,b] == - $noColonDeclaration: local := true - tryBreak(format a and format " +-> ", b, "+->","Led") - -formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) - -formatreduce ["reduce",op,u] == formatReduce1(op,u) - -formatReduce1(op,u) == - if STRINGP op then op := INTERN op - id := LASSOC(op, - '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) - formatFunctionCall - id => ['reduce,op,u,id] - ['reduce,op,u] - -formatIterator u == - $noColonDeclaration : local := true - u is ["IN",x,y] => - format "for " and formatLeft("format",x,"in","Led") and format " in " and - formatRight("format",y,"in","Led") - u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") - u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") - u is ["|",x] => format "| " and formatRight("format",x,"|","Led") - u is ["STEP",i,init,step,:v] => - final := IFCAR v - format "for " and formatLeft("format",i,"in","Led") and format " in " and - (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) - error "formatIterator" - -formatStepOne? step == - step = 1 or step = '(One) => true - step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) - false - -formatBy ['by,seg,step] == format seg and format " by " and format step - -formatSCOND ["SCOND",:l] == - $pilesAreOkHere => - --called from formatPileLine or formatBlock - --if from formatPileLine - initialC:= $c - and/[x is [a,["exit",.,b]] for x in l] => - first l is [a,["exit",.,b]] and formatIfExit(a,b) and - (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC - formatIfThenElse l and initialC - and/[x is [a,["exit",.,b]] for x in l] => - first l is [a,["exit",.,b]] and formatIfExit(a,b) and - (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c - --warning: and/(...) returns T if there are no entries - formatIfThenElse l - -formatSEGMENT ["SEGMENT",a,b] == - $pilesAreOkHere: local - (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and - formatInfixOp ".." and - (null b and $c or - (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) - -formatSexpr x == - atom x => - null x or IDENTP x => consBuffer ident2PrintImage PNAME x - consBuffer x - spill("formatNonAtom",x) - -formatNonAtom x == - format "_(" and formatSexpr first x and - (and/[format " " and formatSexpr y for y in rest x]) - and (y:= LASTATOM x => format " . " - and formatSexpr y; true) and format "_)" - -formatCAPSULE ['CAPSULE,:l,x] == - $insideCAPSULE: local := true - try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - -formatPAREN [.,:argl] == formatFunctionCallTail argl - -formatSEQ ["SEQ",:l,[.,.,x]] == - try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - ---====================================================================== --- Comment Handlers ---====================================================================== -formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == - $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] - format x - -formatComments(u,op,types) == - $numberOfSpills :local := $commentIndentation/2 - 1 - not $insideEXPORTS => u - alist := LASSOC(op,$comments) or - sayBrightly ['"No documentation for ",op] - return u - ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) - consComments(LASSOC(ftypes,alist),'"++ ") - u - -consComments(s,plusPlus) == - s is [word,:r] and null atom r => consComments(r, plusPlus) - s := first s - null s => nil - s := consCommentsTran s - indent() and newLine() or return nil - columnsLeft := $lineLength - $m - 2 - while (m := MAXINDEX s) >= columnsLeft repeat - k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] - k := (k => k + 1; columnsLeft) - piece := SUBSTRING(s,0,k) - formatDoCommentLine [plusPlus,piece] - s := SUBSTRING(s,k,nil) - formatDoCommentLine [plusPlus,s] - undent() - $m - -consCommentsTran s == - m := MAXINDEX s - k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => - r := charPosition(char '_},s,k + 6) - r = m + 1 => s - STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) - s - -formatDoCommentLine line == - $lineBuffer := consLineBuffer [nBlanks $c,:line] - $c := $m+2*$numberOfSpills - ---====================================================================== --- Pile Handlers ---====================================================================== -formatPreferPile y == - y is ["SEQ",:l,[.,.,x]] => - (u:= formatPiles(l,x)) => u - formatSpill("format",y) - formatSpill("format",y) - -formatPiles(l,x) == - $insideTypeExpression : local := false - not $pilesAreOkHere => nil - originalC:= $c - lines:= [:l,x] - --piles must begin at margin - originalC=$m or indent() and newLine() or return nil - null (formatPileLine($m,first lines,false)) => nil - not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil - (originalC=$m or undent()) and originalC --==> brace - -formatPileLine($m,x,newLineIfTrue) == - if newLineIfTrue then newLine() or return nil - $numberOfSpills: local:= 0 - $newLineWritten := nil - format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) - and (x is ['DEF,:.] and optNewLine() or $c) - ---====================================================================== --- Utility Functions ---====================================================================== -nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] - -isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") - -isTrue x == x="true" or x is '(QUOTE T) - -nary2Binary(u,op) == - u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) - errhuh() - -string2PrintImage s == - u:= GETSTR (2*SIZE s) - for i in 0..MAXINDEX s repeat - (if MEMQ(s.i,'(_( _{ _) _} _! _")) then - SUFFIX('__,u); u:= SUFFIX(s.i,u)) - u - -ident2PrintImage s == - m := MAXINDEX s - if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) - u:= GETSTR (2*SIZE s) - if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) - u:= SUFFIX(s.(0),u) - for i in 1..MAXINDEX s repeat - if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) - or (c = char '_!)) then SUFFIX('__,u) - u:= SUFFIX(s.i,u) - INTERN u - -isIdentifier x == - IDENTP x => - s:= PNAME x - #s = 0 => nil - ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] - #s>1 => - or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => - and/[s.i^=char '" " for i in 1..m] => true - -isGensym x == - s := STRINGIMAGE x - n := MAXINDEX s - s.0 = char '_G and and/[DIGITP s.i for i in 1..n] - ---====================================================================== --- Macro Helpers ---====================================================================== -tryToFit(s,x) == ---% try to format on current line; see macro try in file PSPADAUX LISP - --returns nil if unable to format stuff in x on a single line - x => ($back:= rest $back; $c) - restoreState() - nil - -restoreState(:options) == - back := IFCAR options or $back - [ - [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, - $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] - := back - if null options then $back := back - [$newLineWritten, $autoLine, $rightBraceFlag, - $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, - $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, - $doNotResetMarginIfTrue,$noColonDeclaration] - := flags - nil - -saveState(:options) == - flags := - [$newLineWritten, $autoLine, $rightBraceFlag, - $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, - $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, - $doNotResetMarginIfTrue,$noColonDeclaration] - newState := - [ - [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, - $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] - if not KAR options then $back := newState - newState - -formatSC() == - $pileStyle or $semicolonFlag => $c - format "; " - -wrapBraces(x,y,z) == y - -formatLB() == - $pileStyle => $c - $numberOfSpills := - $c > $lineLength / 2 => $braceIndentation/3 - 1 - $braceIndentation/2 - 1 - format "{" - -restoreC() == --used by macro "embrace" - originalC := CAR $braceStack - $braceStack := CDR $braceStack - formatRB originalC - -saveC() == --used by macro "embrace" - $braceStack := [$c,:$braceStack] - -saveD() == --used by macro "embrace" - $braceStack := [$c,:$braceStack] - -restoreD() == --used by macro "indentNB" - originalC := CAR $braceStack - $braceStack := CDR $braceStack - originalC - -formatRB(originalC) == --called only by restoreC - while $marginStack and $m > originalC repeat undent() - if $m < originalC then $marginStack := [originalC,:$marginStack] - $m := originalC - $pileStyle => $m - newLine() and format "}" and $m --==> brace - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/redefs.boot.pamphlet b/src/interp/redefs.boot.pamphlet deleted file mode 100644 index 519c3fbb..00000000 --- a/src/interp/redefs.boot.pamphlet +++ /dev/null @@ -1,92 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp redefs.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. - -@ -<<*>>= -<> - -)package "BOOT" - -BLANKS n== MAKE_-FULL_-CVEC (n) - -object2String x== - STRINGP x=>x - IDENTP x=> PNAME x - STRINGIMAGE x - -sayMSG x== shoeConsole x -sayBrightly x== - brightPrint x - TERPRI() -;;char x==CHAR(PNAME x,0) -pathname x==CONCAT(PNAME(x.0),'".",PNAME(x.1)) -CVECP x== STRINGP x -concat(:l) == concatList l - -concatList [x,:y] == - null y => x - null x => concatList y - concat1(x,concatList y) - -concat1(x,y) == - null x => y - atom x => (null y => x; atom y => [x,y]; [x,:y]) - null y => x - atom y => [:x,y] - [:x,:y] - ---$FILESIZE x== --- a:=OPEN MAKE_-INPUT_-FILENAME x --- b:=FILE_-LENGTH a --- CLOSE a --- b -SPADCATCH(x,y)==CATCH(x,y) -SPADTHROW(x,y)==THROW(x,y) -listSort(f,l)== SORT(l,f) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/rulesets.boot b/src/interp/rulesets.boot new file mode 100644 index 00000000..66f79f7b --- /dev/null +++ b/src/interp/rulesets.boot @@ -0,0 +1,303 @@ +-- 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. + + +--% Mode and Type Resolution Rule Data and Ruleset Creation + +--% resolveTT Rules + +-- These rules are applied only once at the outermost position of a term +-- some things can't be done by term rewriting conveniently (e.g. set +-- difference), so a form is created which is interpreted by +-- resolveTTRed later. The meanings of these forms are: +-- Incl(x,y): y if x is a member of y, failed otherwise +-- SetEqual(x,y): x if y is a permutation of x, failed otherwise +-- SetComp(x,y): x-y, if y is a subset of x, failed otherwise +-- SetInter(x,y): intersection of x and y, if nonempty, failed otherwise +-- SetDiff(x,y): x-y, if x and y have a nonempty intersection, failed ... + +-- These first rules will be expanded for each of MP, DMP and NDMP + +SETANDFILEQ($mpolyTTRules,'( _ + ((Resolve (RN) (mpoly1 x t1)) . (mpoly1 x (Resolve (RN) t1))) _ + ((Resolve (UP x t1) (mpoly1 y t2)) . _ + (Resolve t1 (mpoly1 (Incl x y) t2))) _ + ((Resolve (mpoly1 x t1) (G t2)) . _ + (mpoly1 x (G (VarEqual t1 t2)))) _ + ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ + (mpoly1 (Incl x y) t2)) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 x (Resolve t1 (mpoly1 (SetComp y x) t2)))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 (SetInter x y) (Resolve _ + (mpoly1 (SetDiff x y) t1) (mpoly1 (SetDiff y x) t2)))) _ + )) + +-- These are the general rules, excluding those above. + +SETANDFILEQ($generalTTRules, '( _ + ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (EQ t1) (B)) . (B)) _ + ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (M t1) (SM x t2)) . (M (Resolve t1 t2))) _ + ((Resolve (M t1) (RM x y t2)) . (M (Resolve t1 t2))) _ + ((Resolve (SM x t1) (RM y y t2)) . _ + (SM (VarEqual x y) (Resolve t1 t2))) _ + ((Resolve (V t1) (L t2)) . (V (Resolve t1 t2))) _ + ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ + ((Resolve (F) (RN)) . (F) ) _ + _ + ((Resolve (OV x) (OV y)) . (OV (SetUnion x y))) _ + ((Resolve (P t1) (UP y t2)) . (Resolve (P t1) t2)) _ + _ + ((Resolve (UP y t1) (G t2)) . (UP y (G (VarEqual t1 t2)))) _ + ((Resolve (P t1) (P t2)) . (P (Resolve t1 t2))) _ + ((Resolve (G t1) (G t2)) . (G (Resolve t1 t2))) _ + ((Resolve (G t1) (P t2)) . (P (G (VarEqual t1 t2)))) _ + _ + ((Resolve (AF t1) (EF t2)) . (EF (Resolve t1 t2))) _ + ((Resolve (AF t1) (LF t2)) . (LF (Resolve t1 t2))) _ + ((Resolve (AF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + ((Resolve (EF t1) (LF t2)) . (LF (Resolve t1 t2))) _ + ((Resolve (EF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + ((Resolve (LF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + _ + ((Resolve (RN) (P t1)) . (P (Resolve (RN) t1))) _ + ((Resolve (RN) (UP x t1)) . (UP x (Resolve (RN) t1))) _ + ((Resolve (RN) (UPS x t1)) . (UPS x (Resolve (RN) t1))) _ + ((Resolve (RN) (CFPS x t1)) . (CFPS x (Resolve (RN) t1))) _ + _ + ((Resolve (RR) (EF t1)) . (EF (Resolve (RR) t1))) _ + ((Resolve (P t1) (AF t2)) . (AF (Resolve t1 t2 ))) _ + ((Resolve (P t1) (EF t2)) . (EF (Resolve t1 t2 ))) _ + ((Resolve (P t1) (LF t2)) . (LF (Resolve t1 t2 ))) _ + _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP x (Resolve t1 (DMP (SetComp y x) t2)))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP y (Resolve (MP (SetComp x y) t1) t2))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP (SetInter x y) (Resolve _ + (MP (SetDiff x y) t1) (DMP (SetDiff y x) t2)))) _ + _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP y (Resolve (MP (SetComp x y) t1) t2))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP (SetInter x y) (Resolve _ + (MP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ + _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP y (Resolve (DMP (SetComp x y) t1) t2))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP (SetInter x y) (Resolve _ + (DMP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ + )) + +-- The following creates the ruleset + +createResolveTTRules() == + -- expand multivariate polynomial rules + mps := '(MP DMP NDMP) + mpRules := "append"/[SUBST(mp,'mpoly1,$mpolyTTRules) for mp in mps] + $Res := CONS('(t1 t2 x y), + EQSUBSTLIST($nameList,$abList,append($generalTTRules,mpRules))) + true + +--% resolveTM Rules + +-- Same rules as for resolveTT, with two exceptions: +-- Diff(x,y): removes y from x, if possible, failed otherwise +-- SetIncl(x,y): y if x is a subset of y, failed otherwise + +-- These first rules will be expanded for each of MP, DMP and NDMP + +SETANDFILEQ($mpolyTMRules,'( _ + ((Resolve (mpoly1 x t1) (P t2)) . (Resolve t1 (P t2))) _ + ((Resolve (mpoly1 (x) t1) (UP x t2)) . (UP x (Resolve t1 t2))) _ + ((Resolve (mpoly1 x t1) (UP y t2)) . _ + (UP y (Resolve (mpoly1 (Diff x y) t1) t2))) _ + ((Resolve (UP x t1) (mpoly1 y t2)) . _ + (Resolve t1 (mpoly1 (Incl x y) t2))) _ + ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ + (mpoly1 (Incl x y) (Resolve (I) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (Resolve t1 (mpoly2 (SetIncl x y) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (mpoly2 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (Resolve (mpoly1 (SetDiff x y) t1) (mpoly2 y t2))) _ + )) + +-- These are the general rules, excluding those above. + +SETANDFILEQ($generalTMRules,'( _ + ((Resolve (VARIABLE x) (P t1)) . (P (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (UP y t1)) . _ + (UP (VarEqual x y) (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (UPS y t1)) . _ + (UPS (VarEqual x y) (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (CFPS y t1)) . _ + (CFPS (VarEqual x y) (Resolve (RN) t1))) _ + ((Resolve (VARIABLE x) (ELFPS y t1)) . _ + (ELFPS (VarEqual x y) (Resolve (RN) t1))) _ + ((Resolve (VARIABLE x) (EF t1)) . (EF t1)) _ + ((Resolve (L (L (SY))) (M _*_*)) . (M (P (I)))) _ + ((Resolve (L (L (SY))) (SM x _*_*)) . (SM x (P (I)))) _ + ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (L (L t1)) (SM x t2)) . (SM x (Resolve t1 t2))) _ + ((Resolve (L (L t1)) (RM x y t2)) . (RM x y (Resolve t1 t2))) _ + ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (VARIABLE x) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (SM x t1) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (RM x y t1) (M t2)) . (M (Resolve t1 t2))) _ + _ + ((Resolve (M t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (SM x t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (RM x y t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (M t1) (L t2)) . (L (Resolve (L t1) t2))) _ + ((Resolve (SM x t1) (L t2)) . (L (Resolve (L t1) t2))) _ + ((Resolve (RM x y t1) (L t2)) . (L (Resolve (L t1) t2))) _ + _ + ((Resolve (M t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (SM x t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (RM x y t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (M t1) (V t2)) . (V (Resolve (V t1) t2))) _ + ((Resolve (SM x t1) (V t2)) . (V (Resolve (V t1) t2))) _ + ((Resolve (RM x y t1) (V t2)) . (V (Resolve (V t1) t2))) _ + _ + ((Resolve (L t1) (V t2)) . (V (Resolve t1 t2))) _ + ((Resolve (V t1) (L t2)) . (L (Resolve t1 t2))) _ + ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ + ((Resolve (UP x t1) (P t2)) . (Resolve t1 (P t2))) _ + )) + +-- Private abbreviation table for resolve rules +SETANDFILEQ($resolveAbbreviations, '( _ + (P . Polynomial) _ + (G . Gaussian) _ + (L . List) _ + (M . Matrix) _ + (EQ . Equation) _ + (B . Boolean) _ + (SY . Symbol) _ + (I . Integer) _ + (SM . SquareMatrix) _ + (RM . RectangularMatrix) _ + (V . Vector) _ + (FF . FactoredForm) _ + (FR . FactoredRing) _ + (RN . RationalNumber) _ + (F . Float) _ + (OV . OrderedVariableList) _ + (UP . UnivariatePoly) _ + (DMP . DistributedMultivariatePolynomial) _ + (MP . MultivariatePolynomial) _ + (HDMP . HomogeneousDistributedMultivariatePolynomial) _ + (QF . QuotientField) _ + (RF . RationalFunction) _ + (RE . RadicalExtension) _ + (RR . RationalRadicals) _ + (UPS . UnivariatePowerSeries) _ + (CFPS . ContinuedFractionPowerSeries) _ + (ELFPS . EllipticFunctionPowerSeries) _ + (EF . ElementaryFunction) _ + (VARIABLE . Variable) _ + )) + +SETANDFILEQ($newResolveAbbreviations, '( _ + (P . Polynomial) _ + (G . Complex) _ + (L . List) _ + (M . Matrix) _ + (EQ . Equation) _ + (B . Boolean) _ + (SY . Symbol) _ + (I . Integer) _ + (SM . SquareMatrix) _ + (RM . RectangularMatrix) _ + (V . Vector) _ + (FF . Factored) _ + (FR . Factored) _ + (F . Float) _ + (OV . OrderedVariableList) _ + (UP . UnivariatePolynomial) _ + (DMP . DistributedMultivariatePolynomial) _ + (MP . MultivariatePolynomial) _ + (HDMP . HomogeneousDistributedMultivariatePolynomial) _ + (QF . Fraction) _ + (UPS . UnivariatePowerSeries) _ + (VARIABLE . Variable) _ + )) + +-- The following creates the ruleset + +createResolveTMRules() == + -- expand multivariate polynomial rules + mps := '(MP DMP NDMP) + mpRules0 := "append"/[SUBST(mp,'mpoly1,$mpolyTMRules) for mp in mps] + mpRules := "append"/[SUBST(mp,'mpoly2,mpRules0) for mp in mps] + $ResMode := CONS('(t1 t2 x y), + EQSUBSTLIST($nameList,$abList,append(mpRules,$generalTMRules))) + true + +createTypeEquivRules() == + -- used by eqType, for example + $TypeEQ := CONS('(t1), EQSUBSTLIST($nameList,$abList,'( + ((QF (P t1)) . (RF t1)) + ((QF (I)) . (RN)) + ((RE (RN)) . (RR)) ))) + $TypeEqui := CONS(CAR $TypeEQ, [[b,:a] for [a,:b] in CDR $TypeEQ]) + true + +initializeRuleSets() == + $abList: local := + ASSOCLEFT $newResolveAbbreviations + $nameList: local := + ASSOCRIGHT $newResolveAbbreviations + createResolveTTRules() + createResolveTMRules() + createTypeEquivRules() + $ruleSetsInitialized := true + true diff --git a/src/interp/rulesets.boot.pamphlet b/src/interp/rulesets.boot.pamphlet deleted file mode 100644 index b2ceefa6..00000000 --- a/src/interp/rulesets.boot.pamphlet +++ /dev/null @@ -1,325 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp rulesets.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. - -@ -<<*>>= -<> - ---% Mode and Type Resolution Rule Data and Ruleset Creation - ---% resolveTT Rules - --- These rules are applied only once at the outermost position of a term --- some things can't be done by term rewriting conveniently (e.g. set --- difference), so a form is created which is interpreted by --- resolveTTRed later. The meanings of these forms are: --- Incl(x,y): y if x is a member of y, failed otherwise --- SetEqual(x,y): x if y is a permutation of x, failed otherwise --- SetComp(x,y): x-y, if y is a subset of x, failed otherwise --- SetInter(x,y): intersection of x and y, if nonempty, failed otherwise --- SetDiff(x,y): x-y, if x and y have a nonempty intersection, failed ... - --- These first rules will be expanded for each of MP, DMP and NDMP - -SETANDFILEQ($mpolyTTRules,'( _ - ((Resolve (RN) (mpoly1 x t1)) . (mpoly1 x (Resolve (RN) t1))) _ - ((Resolve (UP x t1) (mpoly1 y t2)) . _ - (Resolve t1 (mpoly1 (Incl x y) t2))) _ - ((Resolve (mpoly1 x t1) (G t2)) . _ - (mpoly1 x (G (VarEqual t1 t2)))) _ - ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ - (mpoly1 (Incl x y) t2)) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 x (Resolve t1 (mpoly1 (SetComp y x) t2)))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 (SetInter x y) (Resolve _ - (mpoly1 (SetDiff x y) t1) (mpoly1 (SetDiff y x) t2)))) _ - )) - --- These are the general rules, excluding those above. - -SETANDFILEQ($generalTTRules, '( _ - ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (EQ t1) (B)) . (B)) _ - ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (M t1) (SM x t2)) . (M (Resolve t1 t2))) _ - ((Resolve (M t1) (RM x y t2)) . (M (Resolve t1 t2))) _ - ((Resolve (SM x t1) (RM y y t2)) . _ - (SM (VarEqual x y) (Resolve t1 t2))) _ - ((Resolve (V t1) (L t2)) . (V (Resolve t1 t2))) _ - ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ - ((Resolve (F) (RN)) . (F) ) _ - _ - ((Resolve (OV x) (OV y)) . (OV (SetUnion x y))) _ - ((Resolve (P t1) (UP y t2)) . (Resolve (P t1) t2)) _ - _ - ((Resolve (UP y t1) (G t2)) . (UP y (G (VarEqual t1 t2)))) _ - ((Resolve (P t1) (P t2)) . (P (Resolve t1 t2))) _ - ((Resolve (G t1) (G t2)) . (G (Resolve t1 t2))) _ - ((Resolve (G t1) (P t2)) . (P (G (VarEqual t1 t2)))) _ - _ - ((Resolve (AF t1) (EF t2)) . (EF (Resolve t1 t2))) _ - ((Resolve (AF t1) (LF t2)) . (LF (Resolve t1 t2))) _ - ((Resolve (AF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - ((Resolve (EF t1) (LF t2)) . (LF (Resolve t1 t2))) _ - ((Resolve (EF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - ((Resolve (LF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - _ - ((Resolve (RN) (P t1)) . (P (Resolve (RN) t1))) _ - ((Resolve (RN) (UP x t1)) . (UP x (Resolve (RN) t1))) _ - ((Resolve (RN) (UPS x t1)) . (UPS x (Resolve (RN) t1))) _ - ((Resolve (RN) (CFPS x t1)) . (CFPS x (Resolve (RN) t1))) _ - _ - ((Resolve (RR) (EF t1)) . (EF (Resolve (RR) t1))) _ - ((Resolve (P t1) (AF t2)) . (AF (Resolve t1 t2 ))) _ - ((Resolve (P t1) (EF t2)) . (EF (Resolve t1 t2 ))) _ - ((Resolve (P t1) (LF t2)) . (LF (Resolve t1 t2 ))) _ - _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP x (Resolve t1 (DMP (SetComp y x) t2)))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP y (Resolve (MP (SetComp x y) t1) t2))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP (SetInter x y) (Resolve _ - (MP (SetDiff x y) t1) (DMP (SetDiff y x) t2)))) _ - _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP y (Resolve (MP (SetComp x y) t1) t2))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP (SetInter x y) (Resolve _ - (MP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ - _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP y (Resolve (DMP (SetComp x y) t1) t2))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP (SetInter x y) (Resolve _ - (DMP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ - )) - --- The following creates the ruleset - -createResolveTTRules() == - -- expand multivariate polynomial rules - mps := '(MP DMP NDMP) - mpRules := "append"/[SUBST(mp,'mpoly1,$mpolyTTRules) for mp in mps] - $Res := CONS('(t1 t2 x y), - EQSUBSTLIST($nameList,$abList,append($generalTTRules,mpRules))) - true - ---% resolveTM Rules - --- Same rules as for resolveTT, with two exceptions: --- Diff(x,y): removes y from x, if possible, failed otherwise --- SetIncl(x,y): y if x is a subset of y, failed otherwise - --- These first rules will be expanded for each of MP, DMP and NDMP - -SETANDFILEQ($mpolyTMRules,'( _ - ((Resolve (mpoly1 x t1) (P t2)) . (Resolve t1 (P t2))) _ - ((Resolve (mpoly1 (x) t1) (UP x t2)) . (UP x (Resolve t1 t2))) _ - ((Resolve (mpoly1 x t1) (UP y t2)) . _ - (UP y (Resolve (mpoly1 (Diff x y) t1) t2))) _ - ((Resolve (UP x t1) (mpoly1 y t2)) . _ - (Resolve t1 (mpoly1 (Incl x y) t2))) _ - ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ - (mpoly1 (Incl x y) (Resolve (I) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (Resolve t1 (mpoly2 (SetIncl x y) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (mpoly2 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (Resolve (mpoly1 (SetDiff x y) t1) (mpoly2 y t2))) _ - )) - --- These are the general rules, excluding those above. - -SETANDFILEQ($generalTMRules,'( _ - ((Resolve (VARIABLE x) (P t1)) . (P (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (UP y t1)) . _ - (UP (VarEqual x y) (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (UPS y t1)) . _ - (UPS (VarEqual x y) (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (CFPS y t1)) . _ - (CFPS (VarEqual x y) (Resolve (RN) t1))) _ - ((Resolve (VARIABLE x) (ELFPS y t1)) . _ - (ELFPS (VarEqual x y) (Resolve (RN) t1))) _ - ((Resolve (VARIABLE x) (EF t1)) . (EF t1)) _ - ((Resolve (L (L (SY))) (M _*_*)) . (M (P (I)))) _ - ((Resolve (L (L (SY))) (SM x _*_*)) . (SM x (P (I)))) _ - ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (L (L t1)) (SM x t2)) . (SM x (Resolve t1 t2))) _ - ((Resolve (L (L t1)) (RM x y t2)) . (RM x y (Resolve t1 t2))) _ - ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (VARIABLE x) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (SM x t1) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (RM x y t1) (M t2)) . (M (Resolve t1 t2))) _ - _ - ((Resolve (M t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (SM x t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (RM x y t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (M t1) (L t2)) . (L (Resolve (L t1) t2))) _ - ((Resolve (SM x t1) (L t2)) . (L (Resolve (L t1) t2))) _ - ((Resolve (RM x y t1) (L t2)) . (L (Resolve (L t1) t2))) _ - _ - ((Resolve (M t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (SM x t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (RM x y t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (M t1) (V t2)) . (V (Resolve (V t1) t2))) _ - ((Resolve (SM x t1) (V t2)) . (V (Resolve (V t1) t2))) _ - ((Resolve (RM x y t1) (V t2)) . (V (Resolve (V t1) t2))) _ - _ - ((Resolve (L t1) (V t2)) . (V (Resolve t1 t2))) _ - ((Resolve (V t1) (L t2)) . (L (Resolve t1 t2))) _ - ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ - ((Resolve (UP x t1) (P t2)) . (Resolve t1 (P t2))) _ - )) - --- Private abbreviation table for resolve rules -SETANDFILEQ($resolveAbbreviations, '( _ - (P . Polynomial) _ - (G . Gaussian) _ - (L . List) _ - (M . Matrix) _ - (EQ . Equation) _ - (B . Boolean) _ - (SY . Symbol) _ - (I . Integer) _ - (SM . SquareMatrix) _ - (RM . RectangularMatrix) _ - (V . Vector) _ - (FF . FactoredForm) _ - (FR . FactoredRing) _ - (RN . RationalNumber) _ - (F . Float) _ - (OV . OrderedVariableList) _ - (UP . UnivariatePoly) _ - (DMP . DistributedMultivariatePolynomial) _ - (MP . MultivariatePolynomial) _ - (HDMP . HomogeneousDistributedMultivariatePolynomial) _ - (QF . QuotientField) _ - (RF . RationalFunction) _ - (RE . RadicalExtension) _ - (RR . RationalRadicals) _ - (UPS . UnivariatePowerSeries) _ - (CFPS . ContinuedFractionPowerSeries) _ - (ELFPS . EllipticFunctionPowerSeries) _ - (EF . ElementaryFunction) _ - (VARIABLE . Variable) _ - )) - -SETANDFILEQ($newResolveAbbreviations, '( _ - (P . Polynomial) _ - (G . Complex) _ - (L . List) _ - (M . Matrix) _ - (EQ . Equation) _ - (B . Boolean) _ - (SY . Symbol) _ - (I . Integer) _ - (SM . SquareMatrix) _ - (RM . RectangularMatrix) _ - (V . Vector) _ - (FF . Factored) _ - (FR . Factored) _ - (F . Float) _ - (OV . OrderedVariableList) _ - (UP . UnivariatePolynomial) _ - (DMP . DistributedMultivariatePolynomial) _ - (MP . MultivariatePolynomial) _ - (HDMP . HomogeneousDistributedMultivariatePolynomial) _ - (QF . Fraction) _ - (UPS . UnivariatePowerSeries) _ - (VARIABLE . Variable) _ - )) - --- The following creates the ruleset - -createResolveTMRules() == - -- expand multivariate polynomial rules - mps := '(MP DMP NDMP) - mpRules0 := "append"/[SUBST(mp,'mpoly1,$mpolyTMRules) for mp in mps] - mpRules := "append"/[SUBST(mp,'mpoly2,mpRules0) for mp in mps] - $ResMode := CONS('(t1 t2 x y), - EQSUBSTLIST($nameList,$abList,append(mpRules,$generalTMRules))) - true - -createTypeEquivRules() == - -- used by eqType, for example - $TypeEQ := CONS('(t1), EQSUBSTLIST($nameList,$abList,'( - ((QF (P t1)) . (RF t1)) - ((QF (I)) . (RN)) - ((RE (RN)) . (RR)) ))) - $TypeEqui := CONS(CAR $TypeEQ, [[b,:a] for [a,:b] in CDR $TypeEQ]) - true - -initializeRuleSets() == - $abList: local := - ASSOCLEFT $newResolveAbbreviations - $nameList: local := - ASSOCRIGHT $newResolveAbbreviations - createResolveTTRules() - createResolveTMRules() - createTypeEquivRules() - $ruleSetsInitialized := true - true -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/server.boot b/src/interp/server.boot new file mode 100644 index 00000000..01a4a073 --- /dev/null +++ b/src/interp/server.boot @@ -0,0 +1,218 @@ +-- 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. + + +-- Scratchpad-II server + +-- Assoc list of interpreter frame names and unique integer identifiers + +SETANDFILEQ($frameAlist, nil) +SETANDFILEQ($frameNumber, 0) +SETANDFILEQ($currentFrameNum, 0) +SETANDFILEQ($EndServerSession, false) +SETANDFILEQ($NeedToSignalSessionManager, false) +SETANDFILEQ($sockBufferLength, 9217) + +serverReadLine(stream) == +-- used in place of READ-LINE in a scratchpad server system. + FORCE_-OUTPUT() + not $SpadServer or not IS_-CONSOLE stream => + READ_-LINE(stream) + IN_-STREAM: fluid := stream + _*EOF_*: fluid := NIL + line := + while not $EndServerSession and not _*EOF_* repeat + if $NeedToSignalSessionManager then + sockSendInt($SessionManager, $EndOfOutput) + $NeedToSignalSessionManager := false + action := serverSwitch() + action = $CallInterp => + l := READ_-LINE(stream) + $NeedToSignalSessionManager := true + return l + action = $CreateFrame => + frameName := GENTEMP('"frame") + addNewInterpreterFrame(frameName) + $frameAlist := [[$frameNumber,:frameName], :$frameAlist] + $currentFrameNum := $frameNumber + sockSendInt($SessionManager, $frameNumber) + $frameNumber := $frameNumber + 1 + sockSendString($SessionManager, MKPROMPT()) + action = $SwitchFrames => + $currentFrameNum := sockGetInt($SessionManager) + currentFrame := LASSOC($currentFrameNum, $frameAlist) + changeToNamedInterpreterFrame currentFrame + action = $EndSession => + $EndServerSession := true + action = $LispCommand => + $NeedToSignalSessionManager := true + stringBuf := MAKE_-STRING $sockBufferLength + sockGetString($MenuServer, stringBuf, $sockBufferLength) + form := unescapeStringsInForm READ_-FROM_-STRING stringBuf + protectedEVAL form + action = $QuietSpadCommand => + $NeedToSignalSessionManager := true + executeQuietCommand() + action = $SpadCommand => + $NeedToSignalSessionManager := true + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + action = $NonSmanSession => + $SpadServer := nil + action = $KillLispSystem => + BYE() + NIL + line => line + "" + +parseAndInterpret str == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + $useNewParser => + ncParseAndInterpretString str + oldParseAndInterpret str + +oldParseAndInterpret str == + tree := string2SpadTree str + tree => processInteractive(parseTransform postTransform tree, NIL) + NIL + +executeQuietCommand() == + $QuietCommand: fluid := true + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + +-- Includued for compatability with old-parser systems +serverLoop() == + IN_-STREAM: fluid := CURINSTREAM + _*EOF_*: fluid := NIL + while not $EndServerSession and not _*EOF_* repeat + if $Prompt then (PRINC MKPROMPT(); FINISH_-OUTPUT()) + $Prompt := NIL + action := serverSwitch() + action = $CallInterp => + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret READ_-LINE(CURINSTREAM) ))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + sockSendInt($SessionManager, $EndOfOutput) + action = $CreateFrame => + frameName := GENTEMP('"frame") + addNewInterpreterFrame(frameName) + $frameAlist := [[$frameNumber,:frameName], :$frameAlist] + $currentFrameNum := $frameNumber + sockSendInt($SessionManager, $frameNumber) + $frameNumber := $frameNumber + 1 + sockSendString($SessionManager, MKPROMPT()) + action = $SwitchFrames => + $currentFrameNum := sockGetInt($SessionManager) + currentFrame := LASSOC($currentFrameNum, $frameAlist) + changeToNamedInterpreterFrame currentFrame + action = $EndSession => + $EndServerSession := true + action = $LispCommand => + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + form := unescapeStringsInForm READ_-FROM_-STRING stringBuf + EVAL form + action = $QuietSpadCommand => + executeQuietCommand() + action = $SpadCommand => + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + sockSendInt($SessionManager, $EndOfOutput) + NIL + if _*EOF_* then $Prompt := true + NIL + +parseAndEvalToHypertex str == + lines := parseAndEvalToStringForHypertex str + len := LENGTH lines + sockSendInt($MenuServer, len) + for s in lines repeat + sockSendString($MenuServer, s) + +parseAndEvalToString str == + $collectOutput:local := true + $outputLines: local := nil + $IOindex: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndEvalToStringForHypertex str == + $collectOutput:local := true + $outputLines: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndEvalToStringEqNum str == + $collectOutput:local := true + $outputLines: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndInterpToString str == + v := applyWithOutputToString('parseAndEvalStr, [str]) + breakIntoLines CDR v + +parseAndEvalStr string == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + parseAndEvalStr1 string + +parseAndEvalStr1 string == + string.0 = char '")" => + doSystemCommand SUBSEQ(string, 1) + processInteractive(ncParseFromString string, NIL) + +protectedEVAL x == + error := true + val := NIL + UNWIND_-PROTECT((val := EVAL x; error := NIL), + error => (resetStackLimits(); sendHTErrorSignal())) + val diff --git a/src/interp/server.boot.pamphlet b/src/interp/server.boot.pamphlet deleted file mode 100644 index 3af5ccdb..00000000 --- a/src/interp/server.boot.pamphlet +++ /dev/null @@ -1,240 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp server.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. - -@ -<<*>>= -<> - --- Scratchpad-II server - --- Assoc list of interpreter frame names and unique integer identifiers - -SETANDFILEQ($frameAlist, nil) -SETANDFILEQ($frameNumber, 0) -SETANDFILEQ($currentFrameNum, 0) -SETANDFILEQ($EndServerSession, false) -SETANDFILEQ($NeedToSignalSessionManager, false) -SETANDFILEQ($sockBufferLength, 9217) - -serverReadLine(stream) == --- used in place of READ-LINE in a scratchpad server system. - FORCE_-OUTPUT() - not $SpadServer or not IS_-CONSOLE stream => - READ_-LINE(stream) - IN_-STREAM: fluid := stream - _*EOF_*: fluid := NIL - line := - while not $EndServerSession and not _*EOF_* repeat - if $NeedToSignalSessionManager then - sockSendInt($SessionManager, $EndOfOutput) - $NeedToSignalSessionManager := false - action := serverSwitch() - action = $CallInterp => - l := READ_-LINE(stream) - $NeedToSignalSessionManager := true - return l - action = $CreateFrame => - frameName := GENTEMP('"frame") - addNewInterpreterFrame(frameName) - $frameAlist := [[$frameNumber,:frameName], :$frameAlist] - $currentFrameNum := $frameNumber - sockSendInt($SessionManager, $frameNumber) - $frameNumber := $frameNumber + 1 - sockSendString($SessionManager, MKPROMPT()) - action = $SwitchFrames => - $currentFrameNum := sockGetInt($SessionManager) - currentFrame := LASSOC($currentFrameNum, $frameAlist) - changeToNamedInterpreterFrame currentFrame - action = $EndSession => - $EndServerSession := true - action = $LispCommand => - $NeedToSignalSessionManager := true - stringBuf := MAKE_-STRING $sockBufferLength - sockGetString($MenuServer, stringBuf, $sockBufferLength) - form := unescapeStringsInForm READ_-FROM_-STRING stringBuf - protectedEVAL form - action = $QuietSpadCommand => - $NeedToSignalSessionManager := true - executeQuietCommand() - action = $SpadCommand => - $NeedToSignalSessionManager := true - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - action = $NonSmanSession => - $SpadServer := nil - action = $KillLispSystem => - BYE() - NIL - line => line - "" - -parseAndInterpret str == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - $useNewParser => - ncParseAndInterpretString str - oldParseAndInterpret str - -oldParseAndInterpret str == - tree := string2SpadTree str - tree => processInteractive(parseTransform postTransform tree, NIL) - NIL - -executeQuietCommand() == - $QuietCommand: fluid := true - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - --- Includued for compatability with old-parser systems -serverLoop() == - IN_-STREAM: fluid := CURINSTREAM - _*EOF_*: fluid := NIL - while not $EndServerSession and not _*EOF_* repeat - if $Prompt then (PRINC MKPROMPT(); FINISH_-OUTPUT()) - $Prompt := NIL - action := serverSwitch() - action = $CallInterp => - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret READ_-LINE(CURINSTREAM) ))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - sockSendInt($SessionManager, $EndOfOutput) - action = $CreateFrame => - frameName := GENTEMP('"frame") - addNewInterpreterFrame(frameName) - $frameAlist := [[$frameNumber,:frameName], :$frameAlist] - $currentFrameNum := $frameNumber - sockSendInt($SessionManager, $frameNumber) - $frameNumber := $frameNumber + 1 - sockSendString($SessionManager, MKPROMPT()) - action = $SwitchFrames => - $currentFrameNum := sockGetInt($SessionManager) - currentFrame := LASSOC($currentFrameNum, $frameAlist) - changeToNamedInterpreterFrame currentFrame - action = $EndSession => - $EndServerSession := true - action = $LispCommand => - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - form := unescapeStringsInForm READ_-FROM_-STRING stringBuf - EVAL form - action = $QuietSpadCommand => - executeQuietCommand() - action = $SpadCommand => - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - sockSendInt($SessionManager, $EndOfOutput) - NIL - if _*EOF_* then $Prompt := true - NIL - -parseAndEvalToHypertex str == - lines := parseAndEvalToStringForHypertex str - len := LENGTH lines - sockSendInt($MenuServer, len) - for s in lines repeat - sockSendString($MenuServer, s) - -parseAndEvalToString str == - $collectOutput:local := true - $outputLines: local := nil - $IOindex: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndEvalToStringForHypertex str == - $collectOutput:local := true - $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndEvalToStringEqNum str == - $collectOutput:local := true - $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndInterpToString str == - v := applyWithOutputToString('parseAndEvalStr, [str]) - breakIntoLines CDR v - -parseAndEvalStr string == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - parseAndEvalStr1 string - -parseAndEvalStr1 string == - string.0 = char '")" => - doSystemCommand SUBSEQ(string, 1) - processInteractive(ncParseFromString string, NIL) - -protectedEVAL x == - error := true - val := NIL - UNWIND_-PROTECT((val := EVAL x; error := NIL), - error => (resetStackLimits(); sendHTErrorSignal())) - val -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/setq.lisp b/src/interp/setq.lisp new file mode 100644 index 00000000..6d80b7c4 --- /dev/null +++ b/src/interp/setq.lisp @@ -0,0 +1,468 @@ +;; 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. + + +(setq copyrights '( + "Copyright The Numerical Algorithms Group Limited 1991-94." + "All rights reserved" + "Certain derivative-work portions Copyright (C) 1998 by Leslie Lamport." + "Portions (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984." + "All rights reserved")) + +(in-package "BOOT") + +(SETQ |/MAJOR-VERSION| 7) +(SETQ /VERSION 0) +(SETQ /RELEASE 0) + +(defconstant |$cclSystem| +#+:CCL 't +#-:CCL nil +) + +;; These two variables are referred to in setvars.boot. +#+:kcl (setq input-libraries nil) +#+:kcl (setq output-library nil) + +;; For the browser, used for building local databases when a user compiles +;; their own code. +(SETQ |$newConstructorList| nil) +(SETQ |$newConlist| nil) +(SETQ |$createLocalLibDb| 't) + + +;; These were originally in SPAD LISP + +(SETQ $BOOT NIL) +(setq |$interpOnly| nil) +(SETQ |$testingSystem| NIL) +(SETQ |$publicSystem| NIL) +(SETQ |$newcompMode| NIL) +(SETQ |$newComp| NIL) +(SETQ |$newCompCompare| NIL) +(SETQ |$permitWhere| NIL) +(SETQ |$newSystem| T) +(SETQ |$compileDontDefineFunctions| 'T) +(SETQ |$compileOnlyCertainItems| NIL) +(SETQ |$devaluateList| NIL) +(SETQ |$doNotCompressHashTableIfTrue| NIL) +(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT +(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT +(SETQ |$functionLocations| NIL) +(SETQ |$functorLocalParameters| NIL) ; used in compSymbol +(SETQ /RELEASE '"UNKNOWN") +(SETQ |$insideCategoryPackageIfTrue| NIL) +(SETQ |$insideCompileBodyIfTrue| NIL) +(SETQ |$globalExposureGroupAlist| NIL) +(SETQ |$localExposureDataDefault| + (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) +(SETQ |$localExposureData| + (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) +(SETQ |$compilingInputFile| NIL) +(SETQ |$minivectorNames| NIL) +(setq |$ReadingFile| NIL) +(setq |$NonNullStream| "NonNullStream") +(setq |$NullStream| "NullStream") +(setq |$domPvar| nil) +(defvar $dalymode nil "if true then leading paren implies lisp cmd") +(setq |$Newline| #\Newline) + + +(SETQ STAKCOLUMN -1) +(SETQ ECHOMETA NIL) +(SETQ |$checkParseIfTrue| 'NIL) +(SETQ |$oldParserExpandAbbrs| NIL) +(SETQ |S:SPADKEY| NIL) ;" this is augmented by MAKESPADOP" +(SETQ |/EDIT,FT| 'SPAD) +(SETQ |/EDIT,FM| 'A) +(SETQ /EDITFILE NIL) +(SETQ INITCOLUMN 0) +(SETQ |$functionTable| NIL) +(SETQ |$spaddefs| NIL) +(SETQ |$xeditIsConsole| NIL) +(SETQ |$echoInputLines| NIL) ;; This is in SETVART also +(SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT +(SETQ |$pfKeysForBrowse| NIL) +(SETQ MARG 0) + ;" Margin for testing by ?OP" +(SETQ LCTRUE '|true|) +(SETQ |$displayParserOutput| 'T) + +(SETQ |$insideReadRulesIfTrue| NIL) +(SETQ |$consistencyCheck| 'T) +(SETQ |$useUndo| NIL) +(SETQ |$ruleSetsInitialized| NIL) + +;; tell the system not to use the new parser +(SETQ |$useNewParser| NIL) + +(SETQ |$htPrecedenceTable| NIL) + +(SETQ |$NRTmakeCompactDirect| NIL) +(SETQ |$NRTquick| NIL) +(SETQ |$NRTmakeShortDirect| NIL) +(SETQ |$newWorld| NIL) +(SETQ |$returnNowhereFromGoGet| NIL) + +(SETQ |$insideCanCoerceFrom| NIL) + +(SETQ |$useCoerceOrCroak| T) + +(SETQ |$abbreviateJoin| NIL) + +(SETQ |$InterpreterMacroAlist| + '((|%i| . (|complex| 0 1)) + (|%e| . (|exp| 1)) + (|%pi| . (|pi|)) + (|SF| . (|DoubleFloat|)) + (|%infinity| . (|infinity|)) + (|%plusInfinity| . (|plusInfinity|)) + (|%minusInfinity| . (|minusInfinity|)))) + +;; variables controlling companion pages (see copage.boot) +(SETQ |$HTCompanionWindowID| nil) +(SETQ |$HTPreviousDomain| nil) +(SETQ |$HTOperationError| nil) + +;; Common lisp control variables +;;(setq *load-verbose* nil) +(setq *print-array* nil) +(setq *print-pretty* nil) +(setq *print-circle* nil) + +(SETQ |S:SPADTOK| 'SPADSYSTOK) +(SETQ APLMODE NIL) +(SETQ RLGENSYMFG NIL) +(SETQ RLGENSYMLST NIL) +(SETQ XTOKENREADER 'SPADTOK) +(SETQ |$delimiterTokenList| + '(| | |)| |(| |{| |}| |[| |]| ENDOFLINECHR EOI EOL |END_LINE|)) +(SETQ |$generalTokenIfTrue| NIL) +(SETQ OPASSOC NIL) +(SETQ SPADSYSKEY '(EOI EOL)) + +;; These are for the output routines in OUT BOOT + +(SETQ $LINELENGTH 77) +(SETQ $MARGIN 3) +(SETQ *TALLPAR NIL) +(SETQ ALLSTAR NIL) +(SETQ BLANK " ") +(SETQ COLON ":") +(SETQ COMMA ",") +(SETQ DASH "-") +(SETQ DOLLAR "$") +(SETQ EQSIGN "=") +(SETQ LPAR "(") +(SETQ MATBORCH "*") +(SETQ PERIOD ".") +(SETQ PLUSS "+") +(SETQ RPAR ")") +(SETQ SLASH "/") +(SETQ STAR "*") +(SETQ UNDERBAR "_") +(SETQ |$fortranArrayStartingIndex| 0) + +;; These were originally in INIT LISP + +(SETQ |$dependeeClosureAlist| NIL) +(SETQ |$userModemaps| NIL) +(SETQ |$functorForm| NIL) + +(SETQ |$InitialCommandSynonymAlist| '( + (|?| . "what commands") + (|ap| . "what things") + (|apr| . "what things") + (|apropos| . "what things") + (|cache| . "set functions cache") + (|cl| . "clear") + (|cls| . "zsystemdevelopment )cls") + (|cms| . "system") + (|co| . "compiler") + (|d| . "display") + (|dep| . "display dependents") + (|dependents| . "display dependents") + (|e| . "edit") + (|expose| . "set expose add constructor") + (|fc| . "zsystemdevelopment )c") + (|fd| . "zsystemdevelopment )d") + (|fdt| . "zsystemdevelopment )dt") + (|fct| . "zsystemdevelopment )ct") + (|fctl| . "zsystemdevelopment )ctl") + (|fe| . "zsystemdevelopment )e") + (|fec| . "zsystemdevelopment )ec") + (|fect| . "zsystemdevelopment )ect") + (|fns| . "exec spadfn") + (|fortran| . "set output fortran") + (|h| . "help") + (|hd| . "system hypertex &") + (|kclam| . "boot clearClams ( )") + (|killcaches| . "boot clearConstructorAndLisplibCaches ( )") + (|patch| . "zsystemdevelopment )patch") + (|pause| . "zsystemdevelopment )pause") + (|prompt| . "set message prompt") + (|recurrence| . "set functions recurrence") + (|restore| . "history )restore") + (|save| . "history )save") + (|startGraphics| . "system $AXIOM/lib/viewman &") + (|startNAGLink| . "system $AXIOM/lib/nagman &") + (|stopGraphics| . "lisp (|sockSendSignal| 2 15)") + (|stopNAGLink| . "lisp (|sockSendSignal| 8 15)") + (|time| . "set message time") + (|type| . "set message type") + (|unexpose| . "set expose drop constructor") + (|up| . "zsystemdevelopment )update") + (|version| . "lisp *yearweek*") + (|w| . "what") + (|wc| . "what categories") + (|wd| . "what domains") + (|who| . "lisp (pprint credits)") + (|wp| . "what packages") + (|ws| . "what synonyms") +)) + +(SETQ |$CommandSynonymAlist| (COPY |$InitialCommandSynonymAlist|)) + +(SETQ |$existingFiles| (MAKE-HASHTABLE 'UEQUAL)) + +(SETQ |$instantRecord| (MAKE-HASHTABLE 'ID)) +(SETQ |$immediateDataSymbol| '|--immediateData--|) + +(SETQ |$useIntegerSubdomain| 'T) +(SETQ |$useNewFloat| 'T) + +;; the following symbol holds the canonical "failed" value +(SETQ |$failed| "failed") + +(SETQ |$constructorDataTable| NIL) + +(SETQ |$univariateDomains| '( + |UnivariatePolynomial| + |UnivariateTaylorSeries| + |UnivariateLaurentSeries| + |UnivariatePuiseuxSeries| + )) +(SETQ |$multivariateDomains| '( + |MultivariatePolynomial| + |DistributedMultivariatePolynomial| + |HomogeneousDistributedMultivariatePolynomial| + |GeneralDistributedMultivariatePolynomial| + )) + +(SETQ |$DomainsWithoutLisplibs| '( + CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) + +(SETQ |$tracedMapSignatures| ()) +(SETQ |$highlightAllowed| 'T) + ;" used in BRIGHTPRINT and is a )set variable" + +(SETQ |$printStorageIfTrue| NIL) ;; storage info disabled in common lisp + +(SETQ |$AnonymousFunction| '(|AnonymousFunction|)) +(SETQ |$Any| '(|Any|)) + +(SETQ |$OutputForm| '(|OutputForm|)) + +(SETQ |$ComplexInteger| (LIST '|Complex| |$Integer|)) +(SETQ |$QuotientField| '|Fraction|) +(SETQ |$FunctionalExpression| '|Expression|) +(SETQ |$defaultFunctionTargets| '(())) + +;; New Names +(SETQ |$SingleInteger| '(|SingleInteger|)) + +(SETQ $NE (LIST (LIST NIL))) +(SETQ |$suffix| NIL) +(SETQ |$coerceIntByMapCounter| 0) +(SETQ |$prefix| NIL) +(SETQ |$formalArgList| ()) +(SETQ |$TriangleVariableList| + '(|t#1| |t#2| |t#3| |t#4| |t#5| |t#6| |t#7| |t#8| |t#9| |t#10| + |t#11| |t#12| |t#13| |t#14| |t#15| |t#16| |t#17| |t#18| |t#19| |t#20| + |t#21| |t#22| |t#23| |t#24| |t#25| |t#26| |t#27| |t#28| |t#29| |t#30| + |t#31| |t#32| |t#33| |t#34| |t#35| |t#36| |t#37| |t#38| |t#39| |t#40| + |t#41| |t#42| |t#43| |t#44| |t#45| |t#46| |t#47| |t#48| |t#49| |t#50|)) + +(SETQ NRTPARSE NIL) +(SETQ |$NRTflag| T) +(SETQ |$NRTaddForm| NIL) +(SETQ |$NRTdeltaList| NIL) +(SETQ |$NRTbase| 0) +(SETQ |$NRTdeltaLength| 0) +(SETQ |$NRTopt| NIL) ;; turns off buggy code +(SETQ |$Slot1DataBase| NIL) +(SETQ |$NRTmonitorIfTrue| NIL) + +(SETQ |$useConvertForCoercions| NIL) + +(MAKEPROP '|One| '|defaultType| |$Integer|) +(MAKEPROP '|Zero| '|defaultType| |$Integer|) + +;; Following were originally in EXPLORE BOOT + +(SETQ |$xdatabase| NIL) +(SETQ |$CatOfCatDatabase| NIL) +(SETQ |$DomOfCatDatabase| NIL) +(SETQ |$JoinOfDomDatabase| NIL) +(SETQ |$JoinOfCatDatabase| NIL) +(SETQ |$attributeDb| NIL) + +(SETQ |$abbreviateIfTrue| NIL) +(SETQ |$deltax| 0) +(SETQ |$deltay| 0) +(SETQ |$displayDomains| 'T) +(SETQ |$displayTowardAncestors| NIL) +(SETQ |$focus| NIL) +(SETQ |$focusAccessPath| NIL) +(SETQ |$minimumSeparation| 3) +(SETQ |$origMaxColumn| 80) +(SETQ |$origMaxRow| 20) +(SETQ |$origMinColumn| 1) +(SETQ |$origMinRow| 1) + +;; ---- start of initial settings for variables used in test.boot + +(SETQ |$testOutputLineFlag| NIL) ;; referenced by charyTop, prnd + ;; to stash lines +(SETQ |$testOutputLineStack| NIL) ;; saves lines to be printed + ;; (needed to convert lines for use + ;; in hypertex) +(SETQ |$runTestFlag| NIL) ;; referenced by maPrin to stash + ;; output by recordAndPrint to not + ;; print type/time +(SETQ |$mkTestFlag| NIL) ;; referenced by READLN to stash input + ;; by maPrin to stash output + ;; by recordAndPrint to write i/o + ;; onto $testStream +(SETQ |$mkTestInputStack| NIL) ;; saves input for $testStream + ;; (see READLN) +(SETQ |$mkTestOutputStack| NIL) ;; saves output for $testStream + ;; (see maPrin) + +;; ---- end of initial settings for variables used in test.boot + + +;; Next are initial values for fluid variables in G-BOOT BOOT + +(SETQ |$inDefLET| NIL) +(SETQ |$inDefIS| NIL) +(SETQ |$letGenVarCounter| 1) +(SETQ |$isGenVarCounter| 1) + +;; Next 2 lines originally from CLAM BOOT + +;; this node is used in looking up values +(SETQ |$hashNode| (LIST NIL)) + +(SETQ ERRORINSTREAM (DEFIOSTREAM + '((DEVICE . CONSOLE) (MODE . INPUT) (QUAL . T)) 133 1)) + +(SETQ ERROROUTSTREAM + (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 80 0) ) + +(SETQ |$algebraOutputStream| + (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 255 0) ) + +;; By default, don't generate info files with old compiler. +(setq |$profileCompiler| nil) + +(setq credits '( +"An alphabetical listing of contributors to AXIOM (to October, 2006):" +"Cyril Alberga Roy Adler Christian Aistleitner" +"Richard Anderson George Andrews" +"Henry Baker Stephen Balzac Yurij Baransky" +"David R. Barton Gerald Baumgartner Gilbert Baumslag" +"Fred Blair Vladimir Bondarenko Mark Botch" +"Alexandre Bouyer Peter A. Broadbery Martin Brock" +"Manuel Bronstein Florian Bundschuh Luanne Burns" +"William Burge" +"Quentin Carpent Robert Caviness Bruce Char" +"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" +"Josh Cohen Christophe Conil Don Coppersmith" +"George Corliss Robert Corless Gary Cornell" +"Meino Cramer Claire Di Crescenzo" +"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" +"Jean Della Dora Gabriel Dos Reis Michael Dewar" +"Claire DiCrescendo Sam Dooley Lionel Ducos" +"Martin Dunstan Brian Dupee Dominique Duval" +"Robert Edwards Heow Eide-Goodman Lars Erickson" +"Richard Fateman Bertfried Fauser Stuart Feldman" +"Brian Ford Albrecht Fortenbacher George Frances" +"Constantine Frangos Timothy Freeman Korrinn Fu" +"Marc Gaetano Rudiger Gebauer Kathy Gerber" +"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" +"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" +"Matt Grayson James Griesmer Vladimir Grinberg" +"Oswald Gschnitzer Jocelyn Guidry" +"Steve Hague Vilya Harvey Satoshi Hamaguchi" +"Martin Hassner Waldek Hebisch Ralf Hemmecke" +"Henderson Antoine Hersen" +"Pietro Iglio" +"Richard Jenks" +"Kai Kaminski Grant Keady Tony Kennedy" +"Paul Kosinski Klaus Kusche Bernhard Kutzler" +"Larry Lambe Frederic Lehobey Michel Levaud" +"Howard Levy Rudiger Loos Michael Lucks" +"Richard Luczak" +"Camm Maguire Bob McElrath Michael McGettrick" +"Ian Meikle David Mentre Victor S. Miller" +"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" +"Michael Monagan Marc Moreno-Maza Scott Morrison" +"Mark Murray" +"William Naylor C. Andrew Neff John Nelder" +"Godfrey Nolan Arthur Norman Jinzhong Niu" +"Michael O'Connor Kostas Oikonomou" +"Julian A. Padget Bill Page Susan Pelzel" +"Michel Petitot Didier Pinchon Jose Alfredo Portes" +"Claude Quitte" +"Norman Ramsey Michael Richardson Renaud Rioboo" +"Jean Rivlin Nicolas Robidoux Simon Robinson" +"Michael Rothstein Martin Rubey" +"Philip Santas Alfred Scheerhorn William Schelter" +"Gerhard Schneider Martin Schoenert Marshall Schor" +"Frithjof Schulze Fritz Schwarz Nick Simicich" +"William Sit Elena Smirnova Jonathan Steinbach" +"Christine Sundaresan Robert Sutor Moss E. Sweedler" +"Eugene Surowitz" +"James Thatcher Balbir Thomas Mike Thomas" +"Dylan Thurston Barry Trager Themos T. Tsikas" +"Gregory Vanuxem" +"Bernhard Wall Stephen Watt Jaap Weel" +"Juergen Weiss M. Weller Mark Wegman" +"James Wen Thorsten Werther Michael Wester" +"John M. Wiley Berhard Will Clifton J. Williamson" +"Stephen Wilson Shmuel Winograd Robert Wisbauer" +"Sandra Wityak Waldemar Wiwianka Knut Wolf" +"Clifford Yapp David Yun" +"Richard Zippel Evelyn Zoernack Bruno Zuercher" +"Dan Zwillinger" +)) + diff --git a/src/interp/setq.lisp.pamphlet b/src/interp/setq.lisp.pamphlet deleted file mode 100644 index ae3011b7..00000000 --- a/src/interp/setq.lisp.pamphlet +++ /dev/null @@ -1,496 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/setq.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} - -\maketitle -\begin{abstract} -\end{abstract} - -\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. - -@ -<<*>>= -<> - -(setq copyrights '( - "Copyright The Numerical Algorithms Group Limited 1991-94." - "All rights reserved" - "Certain derivative-work portions Copyright (C) 1998 by Leslie Lamport." - "Portions (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984." - "All rights reserved")) - -(in-package "BOOT") - -(SETQ |/MAJOR-VERSION| 7) -(SETQ /VERSION 0) -(SETQ /RELEASE 0) - -(defconstant |$cclSystem| -#+:CCL 't -#-:CCL nil -) - -;; These two variables are referred to in setvars.boot. -#+:kcl (setq input-libraries nil) -#+:kcl (setq output-library nil) - -;; For the browser, used for building local databases when a user compiles -;; their own code. -(SETQ |$newConstructorList| nil) -(SETQ |$newConlist| nil) -(SETQ |$createLocalLibDb| 't) - - -;; These were originally in SPAD LISP - -(SETQ $BOOT NIL) -(setq |$interpOnly| nil) -(SETQ |$testingSystem| NIL) -(SETQ |$publicSystem| NIL) -(SETQ |$newcompMode| NIL) -(SETQ |$newComp| NIL) -(SETQ |$newCompCompare| NIL) -(SETQ |$permitWhere| NIL) -(SETQ |$newSystem| T) -(SETQ |$compileDontDefineFunctions| 'T) -(SETQ |$compileOnlyCertainItems| NIL) -(SETQ |$devaluateList| NIL) -(SETQ |$doNotCompressHashTableIfTrue| NIL) -(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT -(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT -(SETQ |$functionLocations| NIL) -(SETQ |$functorLocalParameters| NIL) ; used in compSymbol -(SETQ /RELEASE '"UNKNOWN") -(SETQ |$insideCategoryPackageIfTrue| NIL) -(SETQ |$insideCompileBodyIfTrue| NIL) -(SETQ |$globalExposureGroupAlist| NIL) -(SETQ |$localExposureDataDefault| - (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) -(SETQ |$localExposureData| - (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) -(SETQ |$compilingInputFile| NIL) -(SETQ |$minivectorNames| NIL) -(setq |$ReadingFile| NIL) -(setq |$NonNullStream| "NonNullStream") -(setq |$NullStream| "NullStream") -(setq |$domPvar| nil) -(defvar $dalymode nil "if true then leading paren implies lisp cmd") -(setq |$Newline| #\Newline) - - -(SETQ STAKCOLUMN -1) -(SETQ ECHOMETA NIL) -(SETQ |$checkParseIfTrue| 'NIL) -(SETQ |$oldParserExpandAbbrs| NIL) -(SETQ |S:SPADKEY| NIL) ;" this is augmented by MAKESPADOP" -(SETQ |/EDIT,FT| 'SPAD) -(SETQ |/EDIT,FM| 'A) -(SETQ /EDITFILE NIL) -(SETQ INITCOLUMN 0) -(SETQ |$functionTable| NIL) -(SETQ |$spaddefs| NIL) -(SETQ |$xeditIsConsole| NIL) -(SETQ |$echoInputLines| NIL) ;; This is in SETVART also -(SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT -(SETQ |$pfKeysForBrowse| NIL) -(SETQ MARG 0) - ;" Margin for testing by ?OP" -(SETQ LCTRUE '|true|) -(SETQ |$displayParserOutput| 'T) - -(SETQ |$insideReadRulesIfTrue| NIL) -(SETQ |$consistencyCheck| 'T) -(SETQ |$useUndo| NIL) -(SETQ |$ruleSetsInitialized| NIL) - -;; tell the system not to use the new parser -(SETQ |$useNewParser| NIL) - -(SETQ |$htPrecedenceTable| NIL) - -(SETQ |$NRTmakeCompactDirect| NIL) -(SETQ |$NRTquick| NIL) -(SETQ |$NRTmakeShortDirect| NIL) -(SETQ |$newWorld| NIL) -(SETQ |$returnNowhereFromGoGet| NIL) - -(SETQ |$insideCanCoerceFrom| NIL) - -(SETQ |$useCoerceOrCroak| T) - -(SETQ |$abbreviateJoin| NIL) - -(SETQ |$InterpreterMacroAlist| - '((|%i| . (|complex| 0 1)) - (|%e| . (|exp| 1)) - (|%pi| . (|pi|)) - (|SF| . (|DoubleFloat|)) - (|%infinity| . (|infinity|)) - (|%plusInfinity| . (|plusInfinity|)) - (|%minusInfinity| . (|minusInfinity|)))) - -;; variables controlling companion pages (see copage.boot) -(SETQ |$HTCompanionWindowID| nil) -(SETQ |$HTPreviousDomain| nil) -(SETQ |$HTOperationError| nil) - -;; Common lisp control variables -;;(setq *load-verbose* nil) -(setq *print-array* nil) -(setq *print-pretty* nil) -(setq *print-circle* nil) - -(SETQ |S:SPADTOK| 'SPADSYSTOK) -(SETQ APLMODE NIL) -(SETQ RLGENSYMFG NIL) -(SETQ RLGENSYMLST NIL) -(SETQ XTOKENREADER 'SPADTOK) -(SETQ |$delimiterTokenList| - '(| | |)| |(| |{| |}| |[| |]| ENDOFLINECHR EOI EOL |END_LINE|)) -(SETQ |$generalTokenIfTrue| NIL) -(SETQ OPASSOC NIL) -(SETQ SPADSYSKEY '(EOI EOL)) - -;; These are for the output routines in OUT BOOT - -(SETQ $LINELENGTH 77) -(SETQ $MARGIN 3) -(SETQ *TALLPAR NIL) -(SETQ ALLSTAR NIL) -(SETQ BLANK " ") -(SETQ COLON ":") -(SETQ COMMA ",") -(SETQ DASH "-") -(SETQ DOLLAR "$") -(SETQ EQSIGN "=") -(SETQ LPAR "(") -(SETQ MATBORCH "*") -(SETQ PERIOD ".") -(SETQ PLUSS "+") -(SETQ RPAR ")") -(SETQ SLASH "/") -(SETQ STAR "*") -(SETQ UNDERBAR "_") -(SETQ |$fortranArrayStartingIndex| 0) - -;; These were originally in INIT LISP - -(SETQ |$dependeeClosureAlist| NIL) -(SETQ |$userModemaps| NIL) -(SETQ |$functorForm| NIL) - -(SETQ |$InitialCommandSynonymAlist| '( - (|?| . "what commands") - (|ap| . "what things") - (|apr| . "what things") - (|apropos| . "what things") - (|cache| . "set functions cache") - (|cl| . "clear") - (|cls| . "zsystemdevelopment )cls") - (|cms| . "system") - (|co| . "compiler") - (|d| . "display") - (|dep| . "display dependents") - (|dependents| . "display dependents") - (|e| . "edit") - (|expose| . "set expose add constructor") - (|fc| . "zsystemdevelopment )c") - (|fd| . "zsystemdevelopment )d") - (|fdt| . "zsystemdevelopment )dt") - (|fct| . "zsystemdevelopment )ct") - (|fctl| . "zsystemdevelopment )ctl") - (|fe| . "zsystemdevelopment )e") - (|fec| . "zsystemdevelopment )ec") - (|fect| . "zsystemdevelopment )ect") - (|fns| . "exec spadfn") - (|fortran| . "set output fortran") - (|h| . "help") - (|hd| . "system hypertex &") - (|kclam| . "boot clearClams ( )") - (|killcaches| . "boot clearConstructorAndLisplibCaches ( )") - (|patch| . "zsystemdevelopment )patch") - (|pause| . "zsystemdevelopment )pause") - (|prompt| . "set message prompt") - (|recurrence| . "set functions recurrence") - (|restore| . "history )restore") - (|save| . "history )save") - (|startGraphics| . "system $AXIOM/lib/viewman &") - (|startNAGLink| . "system $AXIOM/lib/nagman &") - (|stopGraphics| . "lisp (|sockSendSignal| 2 15)") - (|stopNAGLink| . "lisp (|sockSendSignal| 8 15)") - (|time| . "set message time") - (|type| . "set message type") - (|unexpose| . "set expose drop constructor") - (|up| . "zsystemdevelopment )update") - (|version| . "lisp *yearweek*") - (|w| . "what") - (|wc| . "what categories") - (|wd| . "what domains") - (|who| . "lisp (pprint credits)") - (|wp| . "what packages") - (|ws| . "what synonyms") -)) - -(SETQ |$CommandSynonymAlist| (COPY |$InitialCommandSynonymAlist|)) - -(SETQ |$existingFiles| (MAKE-HASHTABLE 'UEQUAL)) - -(SETQ |$instantRecord| (MAKE-HASHTABLE 'ID)) -(SETQ |$immediateDataSymbol| '|--immediateData--|) - -(SETQ |$useIntegerSubdomain| 'T) -(SETQ |$useNewFloat| 'T) - -;; the following symbol holds the canonical "failed" value -(SETQ |$failed| "failed") - -(SETQ |$constructorDataTable| NIL) - -(SETQ |$univariateDomains| '( - |UnivariatePolynomial| - |UnivariateTaylorSeries| - |UnivariateLaurentSeries| - |UnivariatePuiseuxSeries| - )) -(SETQ |$multivariateDomains| '( - |MultivariatePolynomial| - |DistributedMultivariatePolynomial| - |HomogeneousDistributedMultivariatePolynomial| - |GeneralDistributedMultivariatePolynomial| - )) - -(SETQ |$DomainsWithoutLisplibs| '( - CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) - -(SETQ |$tracedMapSignatures| ()) -(SETQ |$highlightAllowed| 'T) - ;" used in BRIGHTPRINT and is a )set variable" - -(SETQ |$printStorageIfTrue| NIL) ;; storage info disabled in common lisp - -(SETQ |$AnonymousFunction| '(|AnonymousFunction|)) -(SETQ |$Any| '(|Any|)) - -(SETQ |$OutputForm| '(|OutputForm|)) - -(SETQ |$ComplexInteger| (LIST '|Complex| |$Integer|)) -(SETQ |$QuotientField| '|Fraction|) -(SETQ |$FunctionalExpression| '|Expression|) -(SETQ |$defaultFunctionTargets| '(())) - -;; New Names -(SETQ |$SingleInteger| '(|SingleInteger|)) - -(SETQ $NE (LIST (LIST NIL))) -(SETQ |$suffix| NIL) -(SETQ |$coerceIntByMapCounter| 0) -(SETQ |$prefix| NIL) -(SETQ |$formalArgList| ()) -(SETQ |$TriangleVariableList| - '(|t#1| |t#2| |t#3| |t#4| |t#5| |t#6| |t#7| |t#8| |t#9| |t#10| - |t#11| |t#12| |t#13| |t#14| |t#15| |t#16| |t#17| |t#18| |t#19| |t#20| - |t#21| |t#22| |t#23| |t#24| |t#25| |t#26| |t#27| |t#28| |t#29| |t#30| - |t#31| |t#32| |t#33| |t#34| |t#35| |t#36| |t#37| |t#38| |t#39| |t#40| - |t#41| |t#42| |t#43| |t#44| |t#45| |t#46| |t#47| |t#48| |t#49| |t#50|)) - -(SETQ NRTPARSE NIL) -(SETQ |$NRTflag| T) -(SETQ |$NRTaddForm| NIL) -(SETQ |$NRTdeltaList| NIL) -(SETQ |$NRTbase| 0) -(SETQ |$NRTdeltaLength| 0) -(SETQ |$NRTopt| NIL) ;; turns off buggy code -(SETQ |$Slot1DataBase| NIL) -(SETQ |$NRTmonitorIfTrue| NIL) - -(SETQ |$useConvertForCoercions| NIL) - -(MAKEPROP '|One| '|defaultType| |$Integer|) -(MAKEPROP '|Zero| '|defaultType| |$Integer|) - -;; Following were originally in EXPLORE BOOT - -(SETQ |$xdatabase| NIL) -(SETQ |$CatOfCatDatabase| NIL) -(SETQ |$DomOfCatDatabase| NIL) -(SETQ |$JoinOfDomDatabase| NIL) -(SETQ |$JoinOfCatDatabase| NIL) -(SETQ |$attributeDb| NIL) - -(SETQ |$abbreviateIfTrue| NIL) -(SETQ |$deltax| 0) -(SETQ |$deltay| 0) -(SETQ |$displayDomains| 'T) -(SETQ |$displayTowardAncestors| NIL) -(SETQ |$focus| NIL) -(SETQ |$focusAccessPath| NIL) -(SETQ |$minimumSeparation| 3) -(SETQ |$origMaxColumn| 80) -(SETQ |$origMaxRow| 20) -(SETQ |$origMinColumn| 1) -(SETQ |$origMinRow| 1) - -;; ---- start of initial settings for variables used in test.boot - -(SETQ |$testOutputLineFlag| NIL) ;; referenced by charyTop, prnd - ;; to stash lines -(SETQ |$testOutputLineStack| NIL) ;; saves lines to be printed - ;; (needed to convert lines for use - ;; in hypertex) -(SETQ |$runTestFlag| NIL) ;; referenced by maPrin to stash - ;; output by recordAndPrint to not - ;; print type/time -(SETQ |$mkTestFlag| NIL) ;; referenced by READLN to stash input - ;; by maPrin to stash output - ;; by recordAndPrint to write i/o - ;; onto $testStream -(SETQ |$mkTestInputStack| NIL) ;; saves input for $testStream - ;; (see READLN) -(SETQ |$mkTestOutputStack| NIL) ;; saves output for $testStream - ;; (see maPrin) - -;; ---- end of initial settings for variables used in test.boot - - -;; Next are initial values for fluid variables in G-BOOT BOOT - -(SETQ |$inDefLET| NIL) -(SETQ |$inDefIS| NIL) -(SETQ |$letGenVarCounter| 1) -(SETQ |$isGenVarCounter| 1) - -;; Next 2 lines originally from CLAM BOOT - -;; this node is used in looking up values -(SETQ |$hashNode| (LIST NIL)) - -(SETQ ERRORINSTREAM (DEFIOSTREAM - '((DEVICE . CONSOLE) (MODE . INPUT) (QUAL . T)) 133 1)) - -(SETQ ERROROUTSTREAM - (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 80 0) ) - -(SETQ |$algebraOutputStream| - (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 255 0) ) - -;; By default, don't generate info files with old compiler. -(setq |$profileCompiler| nil) - -(setq credits '( -"An alphabetical listing of contributors to AXIOM (to October, 2006):" -"Cyril Alberga Roy Adler Christian Aistleitner" -"Richard Anderson George Andrews" -"Henry Baker Stephen Balzac Yurij Baransky" -"David R. Barton Gerald Baumgartner Gilbert Baumslag" -"Fred Blair Vladimir Bondarenko Mark Botch" -"Alexandre Bouyer Peter A. Broadbery Martin Brock" -"Manuel Bronstein Florian Bundschuh Luanne Burns" -"William Burge" -"Quentin Carpent Robert Caviness Bruce Char" -"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" -"Josh Cohen Christophe Conil Don Coppersmith" -"George Corliss Robert Corless Gary Cornell" -"Meino Cramer Claire Di Crescenzo" -"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" -"Jean Della Dora Gabriel Dos Reis Michael Dewar" -"Claire DiCrescendo Sam Dooley Lionel Ducos" -"Martin Dunstan Brian Dupee Dominique Duval" -"Robert Edwards Heow Eide-Goodman Lars Erickson" -"Richard Fateman Bertfried Fauser Stuart Feldman" -"Brian Ford Albrecht Fortenbacher George Frances" -"Constantine Frangos Timothy Freeman Korrinn Fu" -"Marc Gaetano Rudiger Gebauer Kathy Gerber" -"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" -"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" -"Matt Grayson James Griesmer Vladimir Grinberg" -"Oswald Gschnitzer Jocelyn Guidry" -"Steve Hague Vilya Harvey Satoshi Hamaguchi" -"Martin Hassner Waldek Hebisch Ralf Hemmecke" -"Henderson Antoine Hersen" -"Pietro Iglio" -"Richard Jenks" -"Kai Kaminski Grant Keady Tony Kennedy" -"Paul Kosinski Klaus Kusche Bernhard Kutzler" -"Larry Lambe Frederic Lehobey Michel Levaud" -"Howard Levy Rudiger Loos Michael Lucks" -"Richard Luczak" -"Camm Maguire Bob McElrath Michael McGettrick" -"Ian Meikle David Mentre Victor S. Miller" -"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" -"Michael Monagan Marc Moreno-Maza Scott Morrison" -"Mark Murray" -"William Naylor C. Andrew Neff John Nelder" -"Godfrey Nolan Arthur Norman Jinzhong Niu" -"Michael O'Connor Kostas Oikonomou" -"Julian A. Padget Bill Page Susan Pelzel" -"Michel Petitot Didier Pinchon Jose Alfredo Portes" -"Claude Quitte" -"Norman Ramsey Michael Richardson Renaud Rioboo" -"Jean Rivlin Nicolas Robidoux Simon Robinson" -"Michael Rothstein Martin Rubey" -"Philip Santas Alfred Scheerhorn William Schelter" -"Gerhard Schneider Martin Schoenert Marshall Schor" -"Frithjof Schulze Fritz Schwarz Nick Simicich" -"William Sit Elena Smirnova Jonathan Steinbach" -"Christine Sundaresan Robert Sutor Moss E. Sweedler" -"Eugene Surowitz" -"James Thatcher Balbir Thomas Mike Thomas" -"Dylan Thurston Barry Trager Themos T. Tsikas" -"Gregory Vanuxem" -"Bernhard Wall Stephen Watt Jaap Weel" -"Juergen Weiss M. Weller Mark Wegman" -"James Wen Thorsten Werther Michael Wester" -"John M. Wiley Berhard Will Clifton J. Williamson" -"Stephen Wilson Shmuel Winograd Robert Wisbauer" -"Sandra Wityak Waldemar Wiwianka Knut Wolf" -"Clifford Yapp David Yun" -"Richard Zippel Evelyn Zoernack Bruno Zuercher" -"Dan Zwillinger" -)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/sfsfun-l.lisp b/src/interp/sfsfun-l.lisp new file mode 100644 index 00000000..2a15752a --- /dev/null +++ b/src/interp/sfsfun-l.lisp @@ -0,0 +1,69 @@ +;; 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. + + +(in-package "BOOT") + +;; +;; Lisp part of the Scratchpad special function interface. +;; SMW Feb 91 +;; + +;; #-:CCL +;; (defun |float| (x) (|float| x)) + +;; Conversion between spad and lisp complex representations +(defun s-to-c (c) (complex (car c) (cdr c))) +(defun c-to-s (c) (cons (realpart c) (imagpart c))) +(defun c-to-r (c) + (let ((r (realpart c)) (i (imagpart c))) + (if (or (zerop i) (< (abs i) (* 1.0E-10 (abs r)))) + r + (|error| "Result is not real.")) )) + +;; Wrappers for functions in the special function package +(defun rlngamma (x) (|lnrgamma| x) ) +(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) )) + +;; #-:CCL +(defun rgamma (x) (|rgamma| x)) +(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) )) + +(defun rpsi (n x) (|rPsi| n x) ) +(defun cpsi (n z) (c-to-s (|cPsi| n (s-to-c z)) )) + +(defun rbesselj (n x) (c-to-r (|BesselJ| n x)) )) +(defun cbesselj (v z) (c-to-s (|BesselJ| (s-to-c v) (s-to-c z)) )) + +(defun rbesseli (n x) (c-to-r (|BesselI| n x)) )) +(defun cbesseli (v z) (c-to-s (|BesselI| (s-to-c v) (s-to-c z)) )) + +(defun chyper0f1 (a z) (c-to-s (|chebf01| (s-to-c a) (s-to-c z)) )) diff --git a/src/interp/sfsfun-l.lisp.pamphlet b/src/interp/sfsfun-l.lisp.pamphlet deleted file mode 100644 index c7c992e0..00000000 --- a/src/interp/sfsfun-l.lisp.pamphlet +++ /dev/null @@ -1,91 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp sfsfun-l.lisp} -\author{Timothy Daly} -\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. - -@ -<<*>>= -<> - -(in-package "BOOT") - -;; -;; Lisp part of the Scratchpad special function interface. -;; SMW Feb 91 -;; - -;; #-:CCL -;; (defun |float| (x) (|float| x)) - -;; Conversion between spad and lisp complex representations -(defun s-to-c (c) (complex (car c) (cdr c))) -(defun c-to-s (c) (cons (realpart c) (imagpart c))) -(defun c-to-r (c) - (let ((r (realpart c)) (i (imagpart c))) - (if (or (zerop i) (< (abs i) (* 1.0E-10 (abs r)))) - r - (|error| "Result is not real.")) )) - -;; Wrappers for functions in the special function package -(defun rlngamma (x) (|lnrgamma| x) ) -(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) )) - -;; #-:CCL -(defun rgamma (x) (|rgamma| x)) -(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) )) - -(defun rpsi (n x) (|rPsi| n x) ) -(defun cpsi (n z) (c-to-s (|cPsi| n (s-to-c z)) )) - -(defun rbesselj (n x) (c-to-r (|BesselJ| n x)) )) -(defun cbesselj (v z) (c-to-s (|BesselJ| (s-to-c v) (s-to-c z)) )) - -(defun rbesseli (n x) (c-to-r (|BesselI| n x)) )) -(defun cbesseli (v z) (c-to-s (|BesselI| (s-to-c v) (s-to-c z)) )) - -(defun chyper0f1 (a z) (c-to-s (|chebf01| (s-to-c a) (s-to-c z)) )) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot new file mode 100644 index 00000000..94daf168 --- /dev/null +++ b/src/interp/showimp.boot @@ -0,0 +1,252 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +$returnNowhereFromGoGet := false + +showSummary dom == + showPredicates dom + showAttributes dom + showFrom dom + showImp dom + +--======================================================================= +-- Show Where Functions in Domain are Implemented +--======================================================================= +showImp(dom,:options) == + sayBrightly '"-------------Operation summary-----------------" + missingOnlyFlag := KAR options + domainForm := devaluate dom + [nam,:$domainArgs] := domainForm + $predicateList: local := GETDATABASE(nam,'PREDICATES) + predVector := dom.3 + u := getDomainOpTable(dom,true) + --sort into 4 groups: domain exports, unexports, default exports, others + for (x := [.,.,:key]) in u repeat + key = domainForm => domexports := [x,:domexports] + FIXP key => unexports := [x,:unexports] + isDefaultPackageForm? key => defexports := [x,:defexports] + key = 'nowhere => nowheres := [x,:nowheres] + key = 'constant => constants := [x,:constants] + others := [x,:others] --add chain domains go here + sayBrightly + nowheres => ['"Functions exported but not implemented by", + :bright form2String domainForm,'":"] + [:bright form2String domainForm,'"implements all exported operations"] + showDomainsOp1(nowheres,'nowhere) + missingOnlyFlag => 'done + + --first display those exported by the domain, then add chain guys + u := [:domexports,:constants,:SORTBY('CDDR,others)] + while u repeat + [.,.,:key] := CAR u + sayBrightly + key = 'constant => + ["Constants implemented by",:bright form2String key,'":"] + ["Functions implemented by",:bright form2String key,'":"] + u := showDomainsOp1(u,key) + u := SORTBY('CDDR,defexports) + while u repeat + [.,.,:key] := CAR u + defop := INTERN(SUBSTRING((s := PNAME CAR key),0,MAXINDEX s)) + domainForm := [defop,:CDDR key] + sayBrightly ["Default functions from",:bright form2String domainForm,'":"] + u := showDomainsOp1(u,key) + u := SORTBY('CDDR,unexports) + while u repeat + [.,.,:key] := CAR u + sayBrightly ["Not exported: "] + u := showDomainsOp1(u,key) + +--======================================================================= +-- Show Information Directly From Domains +--======================================================================= +showFrom(D,:option) == + ops := KAR option + alist := nil + domainForm := devaluate D + [nam,:.] := domainForm + $predicateList: local := GETDATABASE(nam,'PREDICATES) + for (opSig := [op,sig]) in getDomainSigs1(D,ops) repeat + u := from?(D,op,sig) + x := ASSOC(u,alist) => RPLACD(x,[opSig,:rest x]) + alist := [[u,opSig],:alist] + for [conform,:l] in alist repeat + sayBrightly concat('"From ",form2String conform,'":") + for [op,sig] in l repeat sayBrightly ['" ",:formatOpSignature(op,sig)] + +--======================================================================= +-- Functions implementing showFrom +--======================================================================= +getDomainOps D == + domname := D.0 + conname := CAR domname + $predicateList: local := GETDATABASE(conname,'PREDICATES) + REMDUP listSort(function GLESSEQP,ASSOCLEFT getDomainOpTable(D,nil)) + +getDomainSigs(D,:option) == + domname := D.0 + conname := CAR domname + $predicateList: local := GETDATABASE(conname,'PREDICATES) + getDomainSigs1(D,first option) + +getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where + u() == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] + +getDomainDocs(D,:option) == + domname := D.0 + conname := CAR domname + $predicateList: local := GETDATABASE(conname,'PREDICATES) + ops := KAR option + [[op,sig,:getInheritanceByDoc(D,op,sig)] for [op,sig] in getDomainSigs1(D,ops)] + +--======================================================================= +-- Getting Inheritance Info from Documentation in Lisplib +--======================================================================= +from?(D,op,sig) == KAR KDR getInheritanceByDoc(D,op,sig) + +getExtensionsOfDomain domain == + u := getDomainExtensionsOfDomain domain + cats := getCategoriesOfDomain domain + for x in u repeat + cats := union(cats,getCategoriesOfDomain EVAL x) + [:u,:cats] + +getDomainExtensionsOfDomain domain == + acc := nil + d := domain + while (u := devaluateSlotDomain(5,d)) repeat + acc := [u,:acc] + d := EVAL u + acc + +devaluateSlotDomain(u,dollar) == + u = '$ => devaluate dollar + FIXP u and VECP (y := dollar.u) => devaluate y + u is ['NRTEVAL,y] => MKQ eval y + u is ['QUOTE,y] => u + u is [op,:argl] => [op,:[devaluateSlotDomain(x,dollar) for x in argl]] + devaluate evalSlotDomain(u,dollar) + +getCategoriesOfDomain domain == + predkeyVec := domain.4.0 + catforms := CADR domain.4 + [fn for i in 0..MAXINDEX predkeyVec | test] where + test() == predkeyVec.i and + (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] + fn == + VECP x => devaluate x + devaluateSlotDomain(x,domain) + +getInheritanceByDoc(D,op,sig,:options) == +--gets inheritance and documentation information by looking in the LISPLIB +--for each ancestor of the domain + catList := KAR options or getExtensionsOfDomain D + getDocDomainForOpSig(op,sig,devaluate D,D) or + or/[fn for x in catList] or '(NIL NIL) + where fn() == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) + +getDocDomainForOpSig(op,sig,dollar,D) == + (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) + and (doc := or/[[d,dollar] for [s,:d] in u | compareSig(sig,s,D,dollar)]) + +--======================================================================= +-- Functions implementing showImp +--======================================================================= +showDomainsOp1(u,key) == + while u and CAR u is [op,sig,: =key] repeat + sayBrightly ['" ",:formatOpSignature(op,sig)] + u := rest u + u + +getDomainRefName(dom,nam) == + PAIRP nam => [getDomainRefName(dom,x) for x in nam] + not FIXP nam => nam + slot := dom.nam + VECP slot => slot.0 + slot is ['SETELT,:.] => getDomainRefName(dom,getDomainSeteltForm slot) + slot + +getDomainSeteltForm ['SETELT,.,.,form] == + form is ['evalSlotDomain,u,d] => devaluateSlotDomain(u,d) + VECP form => systemError() + form + +showPredicates dom == + sayBrightly '"--------------------Predicate summary-------------------" + conname := CAR dom.0 + predvector := dom.3 + predicateList := GETDATABASE(conname,'PREDICATES) + for i in 1.. for p in predicateList repeat + prefix := + testBitVector(predvector,i) => '"true : " + '"false: " + sayBrightly [prefix,:pred2English p] + +showAttributes dom == + sayBrightly '"--------------------Attribute summary-------------------" + conname := CAR dom.0 + abb := getConstructorAbbreviation conname + predvector := dom.3 + for [a,:p] in dom.2 repeat + prefix := + testBitVector(predvector,p) => '"true : " + '"false: " + sayBrightly concat(prefix,form2String a) + +showGoGet dom == + numvec := CDDR dom.4 + for i in 6..MAXINDEX dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat + numOfArgs := numvec.index + whereNumber := numvec.(index := index + 1) + signumList := + [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] + index := index + numOfArgs + 1 + namePart := + concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) + sayBrightly [i,'": ",:formatOpSignature(op,signumList),:namePart] + +formatLazyDomain(dom,x) == + VECP x => devaluate x + x is [dollar,slotNumber,:form] => formatLazyDomainForm(dom,form) + systemError nil + +formatLazyDomainForm(dom,x) == + x = 0 => ["$"] + FIXP x => formatLazyDomain(dom,dom.x) + atom x => x + x is ['NRTEVAL,y] => (atom y => [y]; y) + [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] + + + diff --git a/src/interp/showimp.boot.pamphlet b/src/interp/showimp.boot.pamphlet deleted file mode 100644 index 49b72338..00000000 --- a/src/interp/showimp.boot.pamphlet +++ /dev/null @@ -1,278 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/showimp.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - -$returnNowhereFromGoGet := false - -showSummary dom == - showPredicates dom - showAttributes dom - showFrom dom - showImp dom - ---======================================================================= --- Show Where Functions in Domain are Implemented ---======================================================================= -showImp(dom,:options) == - sayBrightly '"-------------Operation summary-----------------" - missingOnlyFlag := KAR options - domainForm := devaluate dom - [nam,:$domainArgs] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - predVector := dom.3 - u := getDomainOpTable(dom,true) - --sort into 4 groups: domain exports, unexports, default exports, others - for (x := [.,.,:key]) in u repeat - key = domainForm => domexports := [x,:domexports] - FIXP key => unexports := [x,:unexports] - isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant => constants := [x,:constants] - others := [x,:others] --add chain domains go here - sayBrightly - nowheres => ['"Functions exported but not implemented by", - :bright form2String domainForm,'":"] - [:bright form2String domainForm,'"implements all exported operations"] - showDomainsOp1(nowheres,'nowhere) - missingOnlyFlag => 'done - - --first display those exported by the domain, then add chain guys - u := [:domexports,:constants,:SORTBY('CDDR,others)] - while u repeat - [.,.,:key] := CAR u - sayBrightly - key = 'constant => - ["Constants implemented by",:bright form2String key,'":"] - ["Functions implemented by",:bright form2String key,'":"] - u := showDomainsOp1(u,key) - u := SORTBY('CDDR,defexports) - while u repeat - [.,.,:key] := CAR u - defop := INTERN(SUBSTRING((s := PNAME CAR key),0,MAXINDEX s)) - domainForm := [defop,:CDDR key] - sayBrightly ["Default functions from",:bright form2String domainForm,'":"] - u := showDomainsOp1(u,key) - u := SORTBY('CDDR,unexports) - while u repeat - [.,.,:key] := CAR u - sayBrightly ["Not exported: "] - u := showDomainsOp1(u,key) - ---======================================================================= --- Show Information Directly From Domains ---======================================================================= -showFrom(D,:option) == - ops := KAR option - alist := nil - domainForm := devaluate D - [nam,:.] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - for (opSig := [op,sig]) in getDomainSigs1(D,ops) repeat - u := from?(D,op,sig) - x := ASSOC(u,alist) => RPLACD(x,[opSig,:rest x]) - alist := [[u,opSig],:alist] - for [conform,:l] in alist repeat - sayBrightly concat('"From ",form2String conform,'":") - for [op,sig] in l repeat sayBrightly ['" ",:formatOpSignature(op,sig)] - ---======================================================================= --- Functions implementing showFrom ---======================================================================= -getDomainOps D == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - REMDUP listSort(function GLESSEQP,ASSOCLEFT getDomainOpTable(D,nil)) - -getDomainSigs(D,:option) == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - getDomainSigs1(D,first option) - -getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where - u() == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] - -getDomainDocs(D,:option) == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - ops := KAR option - [[op,sig,:getInheritanceByDoc(D,op,sig)] for [op,sig] in getDomainSigs1(D,ops)] - ---======================================================================= --- Getting Inheritance Info from Documentation in Lisplib ---======================================================================= -from?(D,op,sig) == KAR KDR getInheritanceByDoc(D,op,sig) - -getExtensionsOfDomain domain == - u := getDomainExtensionsOfDomain domain - cats := getCategoriesOfDomain domain - for x in u repeat - cats := union(cats,getCategoriesOfDomain EVAL x) - [:u,:cats] - -getDomainExtensionsOfDomain domain == - acc := nil - d := domain - while (u := devaluateSlotDomain(5,d)) repeat - acc := [u,:acc] - d := EVAL u - acc - -devaluateSlotDomain(u,dollar) == - u = '$ => devaluate dollar - FIXP u and VECP (y := dollar.u) => devaluate y - u is ['NRTEVAL,y] => MKQ eval y - u is ['QUOTE,y] => u - u is [op,:argl] => [op,:[devaluateSlotDomain(x,dollar) for x in argl]] - devaluate evalSlotDomain(u,dollar) - -getCategoriesOfDomain domain == - predkeyVec := domain.4.0 - catforms := CADR domain.4 - [fn for i in 0..MAXINDEX predkeyVec | test] where - test() == predkeyVec.i and - (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] - fn == - VECP x => devaluate x - devaluateSlotDomain(x,domain) - -getInheritanceByDoc(D,op,sig,:options) == ---gets inheritance and documentation information by looking in the LISPLIB ---for each ancestor of the domain - catList := KAR options or getExtensionsOfDomain D - getDocDomainForOpSig(op,sig,devaluate D,D) or - or/[fn for x in catList] or '(NIL NIL) - where fn() == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) - -getDocDomainForOpSig(op,sig,dollar,D) == - (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) - and (doc := or/[[d,dollar] for [s,:d] in u | compareSig(sig,s,D,dollar)]) - ---======================================================================= --- Functions implementing showImp ---======================================================================= -showDomainsOp1(u,key) == - while u and CAR u is [op,sig,: =key] repeat - sayBrightly ['" ",:formatOpSignature(op,sig)] - u := rest u - u - -getDomainRefName(dom,nam) == - PAIRP nam => [getDomainRefName(dom,x) for x in nam] - not FIXP nam => nam - slot := dom.nam - VECP slot => slot.0 - slot is ['SETELT,:.] => getDomainRefName(dom,getDomainSeteltForm slot) - slot - -getDomainSeteltForm ['SETELT,.,.,form] == - form is ['evalSlotDomain,u,d] => devaluateSlotDomain(u,d) - VECP form => systemError() - form - -showPredicates dom == - sayBrightly '"--------------------Predicate summary-------------------" - conname := CAR dom.0 - predvector := dom.3 - predicateList := GETDATABASE(conname,'PREDICATES) - for i in 1.. for p in predicateList repeat - prefix := - testBitVector(predvector,i) => '"true : " - '"false: " - sayBrightly [prefix,:pred2English p] - -showAttributes dom == - sayBrightly '"--------------------Attribute summary-------------------" - conname := CAR dom.0 - abb := getConstructorAbbreviation conname - predvector := dom.3 - for [a,:p] in dom.2 repeat - prefix := - testBitVector(predvector,p) => '"true : " - '"false: " - sayBrightly concat(prefix,form2String a) - -showGoGet dom == - numvec := CDDR dom.4 - for i in 6..MAXINDEX dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := - [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] - index := index + numOfArgs + 1 - namePart := - concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) - sayBrightly [i,'": ",:formatOpSignature(op,signumList),:namePart] - -formatLazyDomain(dom,x) == - VECP x => devaluate x - x is [dollar,slotNumber,:form] => formatLazyDomainForm(dom,form) - systemError nil - -formatLazyDomainForm(dom,x) == - x = 0 => ["$"] - FIXP x => formatLazyDomain(dom,dom.x) - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/simpbool.boot b/src/interp/simpbool.boot new file mode 100644 index 00000000..12455d20 --- /dev/null +++ b/src/interp/simpbool.boot @@ -0,0 +1,203 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +simpBool x == dnf2pf reduceDnf be x + +reduceDnf u == +-- (OR (AND ..b..) b) ==> (OR b ) + atom u => u + for x in u repeat + ok := true + for y in u repeat + x = y => 'skip + dnfContains(x,y) => return (ok := false) + ok = true => acc := [x,:acc] + nreverse acc + +dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where + fn(x,y) == and/[member(u,x) for u in y] + +prove x == + world := [p for y in listOfUserIds x | (p := getPredicate y)] => + 'false = be mkpf([['NOT,x],:world],'AND) => true + 'false = be mkpf([x,:world],'AND) => false + x + 'false = (y := be x) => 'false + y = 'true => true + dnf2pf y + +simpBoolGiven(x,world) == + world => + 'false = be mkpf([['NOT,x],:world],'AND) => true + 'false = (y := be mkpf([x,:world],'AND)) => false + (u := andReduce(dnf2pf y,world)) is ['AND,:v] and + (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] + u + 'false = (y := be x) => false + 'true = y => true + dnf2pf y + +andReduce(x,y) == + x is ['AND,:r] => + y is ['AND,:s] => mkpf(S_-(r,s),'AND) + mkpf(S_-(r,[s]),'AND) + x +dnf2pf(x) == + x = 'true => 'T + x = 'false => nil + atom x => x + mkpf( + [mkpf([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) +be x == b2dnf x +b2dnf x == + x = 'T => 'true + x = NIL => 'false + atom x => bassert x + [op,:argl] := x + MEMQ(op,'(AND and)) => band argl + MEMQ(op,'(OR or)) => bor argl + MEMQ(op,'(NOT not)) => bnot first argl + bassert x +band x == + x is [h,:t] => andDnf(b2dnf h,band t) + 'true +bor x == + x is [a,:b] => orDnf(b2dnf a,bor b) + 'false +bnot x == notDnf b2dnf x +bassert x == [[nil,[x]]] +bassertNot x == [[[x],nil]] +------------------------Disjunctive Normal Form Code----------------------- +-- dnf is true | false | [coaf ... ] +-- coaf is true | false | [item ... ] +-- item is anything + +orDnf(a,b) == -- or: (dnf, dnf) -> dnf + a = 'false => b + b = 'false => a + a = 'true or b = 'true => 'true + null a => b --null list means false + a is [c] = coafOrDnf(c,b) + coafOrDnf(first a,orDnf(rest a,b)) + +andDnf(a,b) == -- and: (dnf, dnf) -> dnf + a = 'true => b + b = 'true => a + a = 'false or b = 'false => 'false + null a => 'false --null list means false + a is [c] => coafAndDnf(c,b) + x := coafAndDnf(first a,b) + y := andDnf(rest a,b) + x = 'false => y + y = 'false => x + ordUnion(x,y) + +notDnf l == -- not: dnf -> dnf + l = 'true => 'false + l = 'false => 'true + null l => 'true --null list means false + l is [x] => notCoaf x + andDnf(notCoaf first l,notDnf rest l) + +coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf + a = 'true or l = 'true => 'true + a = 'false => l + member(a,l) => l + y := notCoaf a + x := ordIntersection(y,l) + null x => orDel(a,l) + x = l => 'true + x = y => ordSetDiff(l,x) + ordUnion(notDnf ordSetDiff(y,x),l) + +coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf + a = 'true => b + a = 'false => 'false + [c,:r] := b + null r => coafAndCoaf(a,c) + x := coafAndCoaf(a,c) --dnf + y := coafAndDnf(a,r) --dnf + x = 'false => y + y = 'false => x + ordUnion(x,y) + +coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf + ordIntersection(a,q) or ordIntersection(b,p) => 'false + [[ordUnion(a,p),ordUnion(b,q)]] + +notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] + +list1 l == + l isnt [h,:t] => nil + null h => list1 t + [[h,nil,nil],:list1 t] +list2 l == + l isnt [h,:t] => nil + null h => list2 t + [[nil,h,nil],:list2 t] +list3 l == + l isnt [h,:t] => nil + null h => list3 t + [[nil,nil,h],:list3 t] +orDel(a,l) == + l is [h,:t] => + a = h => t + ?ORDER(a,h) => [a,:l] + [h,:orDel(a,t)] + [a] +ordList l == + l is [h,:t] and t => orDel(h,ordList t) + l +ordUnion(a,b) == + a isnt [c,:r] => b + b isnt [d,:s] => a + c=d => [c,:ordUnion(r,s)] + ?ORDER(a,b) => [c,:ordUnion(r,b)] + [d,:ordUnion(s,a)] +ordIntersection(a,b) == + a isnt [h,:t] => nil + member(h,b) => [h,:ordIntersection(t,b)] + ordIntersection(t,b) +ordSetDiff(a,b) == + b isnt [h,:t] => a + member(h,a) => ordSetDiff(delete(h,a),t) + ordSetDiff(a,t) +------------- +testPredList u == + for x in u repeat + y := simpBool x + x = y => nil + pp x + pp '"==========>" + pp y diff --git a/src/interp/simpbool.boot.pamphlet b/src/interp/simpbool.boot.pamphlet deleted file mode 100644 index 88021ab9..00000000 --- a/src/interp/simpbool.boot.pamphlet +++ /dev/null @@ -1,225 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp simpbool.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. - -@ -<<*>>= -<> - -)package "BOOT" - -simpBool x == dnf2pf reduceDnf be x - -reduceDnf u == --- (OR (AND ..b..) b) ==> (OR b ) - atom u => u - for x in u repeat - ok := true - for y in u repeat - x = y => 'skip - dnfContains(x,y) => return (ok := false) - ok = true => acc := [x,:acc] - nreverse acc - -dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where - fn(x,y) == and/[member(u,x) for u in y] - -prove x == - world := [p for y in listOfUserIds x | (p := getPredicate y)] => - 'false = be mkpf([['NOT,x],:world],'AND) => true - 'false = be mkpf([x,:world],'AND) => false - x - 'false = (y := be x) => 'false - y = 'true => true - dnf2pf y - -simpBoolGiven(x,world) == - world => - 'false = be mkpf([['NOT,x],:world],'AND) => true - 'false = (y := be mkpf([x,:world],'AND)) => false - (u := andReduce(dnf2pf y,world)) is ['AND,:v] and - (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] - u - 'false = (y := be x) => false - 'true = y => true - dnf2pf y - -andReduce(x,y) == - x is ['AND,:r] => - y is ['AND,:s] => mkpf(S_-(r,s),'AND) - mkpf(S_-(r,[s]),'AND) - x -dnf2pf(x) == - x = 'true => 'T - x = 'false => nil - atom x => x - mkpf( - [mkpf([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) -be x == b2dnf x -b2dnf x == - x = 'T => 'true - x = NIL => 'false - atom x => bassert x - [op,:argl] := x - MEMQ(op,'(AND and)) => band argl - MEMQ(op,'(OR or)) => bor argl - MEMQ(op,'(NOT not)) => bnot first argl - bassert x -band x == - x is [h,:t] => andDnf(b2dnf h,band t) - 'true -bor x == - x is [a,:b] => orDnf(b2dnf a,bor b) - 'false -bnot x == notDnf b2dnf x -bassert x == [[nil,[x]]] -bassertNot x == [[[x],nil]] -------------------------Disjunctive Normal Form Code----------------------- --- dnf is true | false | [coaf ... ] --- coaf is true | false | [item ... ] --- item is anything - -orDnf(a,b) == -- or: (dnf, dnf) -> dnf - a = 'false => b - b = 'false => a - a = 'true or b = 'true => 'true - null a => b --null list means false - a is [c] = coafOrDnf(c,b) - coafOrDnf(first a,orDnf(rest a,b)) - -andDnf(a,b) == -- and: (dnf, dnf) -> dnf - a = 'true => b - b = 'true => a - a = 'false or b = 'false => 'false - null a => 'false --null list means false - a is [c] => coafAndDnf(c,b) - x := coafAndDnf(first a,b) - y := andDnf(rest a,b) - x = 'false => y - y = 'false => x - ordUnion(x,y) - -notDnf l == -- not: dnf -> dnf - l = 'true => 'false - l = 'false => 'true - null l => 'true --null list means false - l is [x] => notCoaf x - andDnf(notCoaf first l,notDnf rest l) - -coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf - a = 'true or l = 'true => 'true - a = 'false => l - member(a,l) => l - y := notCoaf a - x := ordIntersection(y,l) - null x => orDel(a,l) - x = l => 'true - x = y => ordSetDiff(l,x) - ordUnion(notDnf ordSetDiff(y,x),l) - -coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf - a = 'true => b - a = 'false => 'false - [c,:r] := b - null r => coafAndCoaf(a,c) - x := coafAndCoaf(a,c) --dnf - y := coafAndDnf(a,r) --dnf - x = 'false => y - y = 'false => x - ordUnion(x,y) - -coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf - ordIntersection(a,q) or ordIntersection(b,p) => 'false - [[ordUnion(a,p),ordUnion(b,q)]] - -notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] - -list1 l == - l isnt [h,:t] => nil - null h => list1 t - [[h,nil,nil],:list1 t] -list2 l == - l isnt [h,:t] => nil - null h => list2 t - [[nil,h,nil],:list2 t] -list3 l == - l isnt [h,:t] => nil - null h => list3 t - [[nil,nil,h],:list3 t] -orDel(a,l) == - l is [h,:t] => - a = h => t - ?ORDER(a,h) => [a,:l] - [h,:orDel(a,t)] - [a] -ordList l == - l is [h,:t] and t => orDel(h,ordList t) - l -ordUnion(a,b) == - a isnt [c,:r] => b - b isnt [d,:s] => a - c=d => [c,:ordUnion(r,s)] - ?ORDER(a,b) => [c,:ordUnion(r,b)] - [d,:ordUnion(s,a)] -ordIntersection(a,b) == - a isnt [h,:t] => nil - member(h,b) => [h,:ordIntersection(t,b)] - ordIntersection(t,b) -ordSetDiff(a,b) == - b isnt [h,:t] => a - member(h,a) => ordSetDiff(delete(h,a),t) - ordSetDiff(a,t) -------------- -testPredList u == - for x in u repeat - y := simpBool x - x = y => nil - pp x - pp '"==========>" - pp y -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/slam.boot b/src/interp/slam.boot new file mode 100644 index 00000000..8427e698 --- /dev/null +++ b/src/interp/slam.boot @@ -0,0 +1,335 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +reportFunctionCompilation(op,nam,argl,body,isRecursive) == + -- for an alternate definition of this function which does not allow + -- dynamic caching, see SLAMOLD BOOT +--+ + $compiledOpNameList := [nam] + minivectorName := makeInternalMapMinivectorName(nam) + $minivectorNames := [[op,:minivectorName],:$minivectorNames] + body := SUBST(minivectorName,"$$$",body) + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,minivectorName] + SET(minivectorName,LIST2REFVEC $minivector) + argl := COPY argl -- play it safe for optimization + init := + not(isRecursive and $compileRecurrence and #argl = 1) => nil + NRTisRecurrenceRelation(nam,body,minivectorName) + init => compileRecurrenceRelation(op,nam,argl,body,init) + cacheCount:= getCacheCount op + cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) + cacheCount = 0 or null argl => + function:= [nam,['LAMBDA,[:argl,'envArg],body]] + compileInteractive function + nam + num := + FIXP cacheCount => + cacheCount < 1 => + keyedSystemError("S2IM0019",[cacheCount,op]) + cacheCount + keyedSystemError("S2IM0019",[cacheCount,op]) + sayKeyedMsg("S2IX0003",[op,num]) + auxfn := mkAuxiliaryName nam + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + null argl => [nil,[auxfn]] + argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter + [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list + cacheName := mkCacheName nam + g2:= GENSYM() --length of cache or arg-value pair + g3:= GENSYM() --value computed by calling function + secondPredPair:= + null argl => [cacheName] + [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] + thirdPredPair:= + null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] + ['(QUOTE T), + ['SETQ,g2,computeValue], + ['SETQ,g3, + ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], + ['RPLACA,g3,g1], + ['RPLACD,g3,g2], + g2] + codeBody:= + ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] + -- cannot use envArg in next statement without redoing much + -- of above. + lamex:= ['LAM,arg,codeBody] + mainFunction:= [nam,lamex] + computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] + compileInteractive mainFunction + compileInteractive computeFunction + cacheType:= 'function + cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] + cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + eval cacheResetCode + SETANDFILE(cacheName,mkCircularAlist cacheCount) + nam + +getCacheCount fn == + n:= LASSOC(fn,$cacheAlist) => n + $cacheCount + +reportFunctionCacheAll(op,nam,argl,body) == + sayKeyedMsg("S2IX0004",[op]) + auxfn:= mkAuxiliaryName nam + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + null argl => [['envArg],[auxfn, 'envArg]] + argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter + [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list + if null argl then g1:=nil + cacheName:= mkCacheName nam + g2:= GENSYM() --value computed by calling function + secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] + thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] + codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [nam,lamex] + computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] + compileInteractive mainFunction + compileInteractive computeFunction + cacheType:= 'hash_-table + cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] + cacheCountCode:= ['hashCount,cacheName] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + eval cacheResetCode + nam + +hashCount table == + +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] + +mkCircularAlist n == + l:= [[$failed,:$failed] for i in 1..n] + RPLACD(LASTNODE l,l) + +countCircularAlist(cal,n) == + +/[nodeCount x for x in cal for i in 1..n] + +predCircular(al,n) == + for i in 1..QSSUB1 n repeat al:= QCDR al + al + +assocCircular(x,al) == --like ASSOC except that al is circular + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) + forwardPointer:= CDR forwardPointer + val + +compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == + k:= #initCode + extraArgumentCode := + extraArguments := [x for x in argl | x ^= sharpArg] => + extraArguments is [x] => x + ['LIST,:extraArguments] + nil + g:= GENSYM() + gIndex:= GENSYM() + gsList:= [GENSYM() for x in initCode] + auxfn := mkAuxiliaryName(nam) + $compiledOpNameList := [:$compiledOpNameList,auxfn] + stateNam:= GENVAR() + stateVar:= GENSYM() + stateVal:= GENSYM() + lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) + decomposeCode:= + [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] + for g in gsList for i in 1..]] + gsRev:= REVERSE gsList + rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] + advanceCode:= ['LET,gIndex,['ADD1,gIndex]] + + newTripleCode := ['LIST,sharpArg,:gsList] + newStateCode := + null extraArguments => ['SETQ,stateNam,newTripleCode] + ['HPUT,stateNam,extraArgumentCode,newTripleCode] + + computeFunction:= [auxfn,['LAM,cargl,cbody]] where + cargl:= [:argl,lastArg] + returnValue:= ['PROGN,newStateCode,first gsList] + cbody:= + endTest:= + ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] + newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, + EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] + ['PROGN,:decomposeCode, + ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, + newValueCode,:rotateCode]]] + fromScratchInit:= + [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] + continueInit:= + [['LET,gIndex,['ELT,stateVar,0]], + :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] + mainFunction:= [nam,['LAM,margl,mbody]] where + margl:= [:argl,'envArg] + max:= GENSYM() + tripleCode := ['CONS,n,['LIST,:initCode]] + + -- initialSetCode initializes the global variable if necessary and + -- also binds "stateVar" to its current value + initialSetCode := + initialValueCode := + extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] + tripleCode + cacheResetCode := ['SETQ,stateNam,initialValueCode] + ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ + ['PAIRP,stateNam]]], _ + ['LET,stateVar,cacheResetCode]], _ + [''T, ['LET,stateVar,stateNam]]] + + -- when there are extra arguments, initialResetCode resets "stateVar" + -- to the hashtable entry for the extra arguments + initialResetCode := + null extraArguments => nil + [['LET,stateVar,['OR, + ['HGET,stateVar,extraArgumentCode], + ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] + + mbody := + preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] + phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], + [auxfn,:argl,stateVar]] + phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], + ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] + phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] + phrase4:= [['GT,sharpArg,n-k], + ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] + phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] + ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] + sayKeyedMsg("S2IX0001",[op]) + compileInteractive computeFunction + compileInteractive mainFunction + cacheType:= 'recurrence + cacheCountCode:= ['nodeCount,stateNam] + cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + nam + +nodeCount x == NUMOFNODES x + +recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) + +mkCacheVec(op,nam,kind,resetCode,countCode) == + [op,nam,kind,resetCode,countCode] + +-- reportCacheStore vl == +-- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") +-- sayMSG concat(centerString('"----",22,'" ")," ---- ------") +-- for x in vl repeat reportCacheStoreFor x +-- +-- op2String op == +-- u:= linearFormatName op +-- atom u => PNAME u +-- "STRCONC"/u +-- +-- reportCacheStorePrint(op,kind,count) == +-- ops:= op2String op +-- opString:= centerString(ops,22,'" ") +-- kindString:= centerString(PNAME kind,10,'" ") +-- countString:= centerString(count,19,'" ") +-- sayMSG concat(opString,kindString,countString) +-- +-- reportCacheStoreFor op == +-- u:= getI(op,'localModemap) => +-- for [['local,target,:.],[.,fn],:.] in u repeat +-- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or +-- keyedSystemError("S2GE0016",['"reportCacheStoreFor", +-- '"missing cache information vector"]) +-- reportCacheStorePrint(op,kind,eval countCode) +-- true +-- u:= getI(op,"cache") => +-- reportCacheStorePrint(op,'variable,nodeCount u) +-- nil + +clearCache x == + get(x,'localModemap,$e) or get(x,'mapBody,$e) => + for [map,:sub] in $mapSubNameAlist repeat + map=x => _/UNTRACE_,2(sub,NIL) + $e:= putHist(x,'localModemap,nil,$e) + $e:= putHist(x,'mapBody,nil,$e) + $e:= putHist(x,'localVars,nil,$e) + sayKeyedMsg("S2IX0007",[x]) + +clearLocalModemaps x == + u:= get(x,"localModemap",$e) => + for sub in ASSOCRIGHT $mapSubNameAlist repeat + _/UNTRACE_,2(sub,NIL) + $e:= putHist(x,"localModemap",nil,$e) + for mm in u repeat + [.,fn,:.] := mm + if def:= get(fn,'definition,$e) then + $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) + if cacheVec:= get(fn,'cacheInfo,$e) then + SET(cacheVec.cacheName,NIL) + -- now clear the property list of the identifier + $e := addIntSymTabBinding(x,nil,$e) + sayKeyedMsg("S2IX0007",[x]) + +compileInteractive fn == + if $InteractiveMode then startTimingProcess 'compilation + --following not used for common lisp + --removeUnnecessaryLastArguments CADR fn + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp fn + optfn := + $InteractiveMode => [timedOptimization fn] + [fn] + result := compQuietly optfn + if $InteractiveMode then stopTimingProcess 'compilation + result + +clearAllSlams x == + fn(x,nil) where + fn(thoseToClear,thoseCleared) == + for x in thoseToClear | not MEMQ(x,thoseCleared) repeat + slamListName:= mkCacheName x + SET(slamListName,nil) + thoseCleared:= ADJOIN(x,thoseCleared) + someMoreToClear:= + setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: + thoseCleared]) + NCONC(thoseToClear,someMoreToClear) + +clearSlam("functor")== + id:= mkCacheName functor + SET(id,nil) diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet deleted file mode 100644 index 4b080f02..00000000 --- a/src/interp/slam.boot.pamphlet +++ /dev/null @@ -1,359 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\File{src/interp/slam.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - -reportFunctionCompilation(op,nam,argl,body,isRecursive) == - -- for an alternate definition of this function which does not allow - -- dynamic caching, see SLAMOLD BOOT ---+ - $compiledOpNameList := [nam] - minivectorName := makeInternalMapMinivectorName(nam) - $minivectorNames := [[op,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - argl := COPY argl -- play it safe for optimization - init := - not(isRecursive and $compileRecurrence and #argl = 1) => nil - NRTisRecurrenceRelation(nam,body,minivectorName) - init => compileRecurrenceRelation(op,nam,argl,body,init) - cacheCount:= getCacheCount op - cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) - cacheCount = 0 or null argl => - function:= [nam,['LAMBDA,[:argl,'envArg],body]] - compileInteractive function - nam - num := - FIXP cacheCount => - cacheCount < 1 => - keyedSystemError("S2IM0019",[cacheCount,op]) - cacheCount - keyedSystemError("S2IM0019",[cacheCount,op]) - sayKeyedMsg("S2IX0003",[op,num]) - auxfn := mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [nil,[auxfn]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - cacheName := mkCacheName nam - g2:= GENSYM() --length of cache or arg-value pair - g3:= GENSYM() --value computed by calling function - secondPredPair:= - null argl => [cacheName] - [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] - thirdPredPair:= - null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] - ['(QUOTE T), - ['SETQ,g2,computeValue], - ['SETQ,g3, - ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], - ['RPLACA,g3,g1], - ['RPLACD,g3,g2], - g2] - codeBody:= - ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] - -- cannot use envArg in next statement without redoing much - -- of above. - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'function - cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] - cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - SETANDFILE(cacheName,mkCircularAlist cacheCount) - nam - -getCacheCount fn == - n:= LASSOC(fn,$cacheAlist) => n - $cacheCount - -reportFunctionCacheAll(op,nam,argl,body) == - sayKeyedMsg("S2IX0004",[op]) - auxfn:= mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [['envArg],[auxfn, 'envArg]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - if null argl then g1:=nil - cacheName:= mkCacheName nam - g2:= GENSYM() --value computed by calling function - secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] - thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] - codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'hash_-table - cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - nam - -hashCount table == - +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] - -mkCircularAlist n == - l:= [[$failed,:$failed] for i in 1..n] - RPLACD(LASTNODE l,l) - -countCircularAlist(cal,n) == - +/[nodeCount x for x in cal for i in 1..n] - -predCircular(al,n) == - for i in 1..QSSUB1 n repeat al:= QCDR al - al - -assocCircular(x,al) == --like ASSOC except that al is circular - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) - forwardPointer:= CDR forwardPointer - val - -compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == - k:= #initCode - extraArgumentCode := - extraArguments := [x for x in argl | x ^= sharpArg] => - extraArguments is [x] => x - ['LIST,:extraArguments] - nil - g:= GENSYM() - gIndex:= GENSYM() - gsList:= [GENSYM() for x in initCode] - auxfn := mkAuxiliaryName(nam) - $compiledOpNameList := [:$compiledOpNameList,auxfn] - stateNam:= GENVAR() - stateVar:= GENSYM() - stateVal:= GENSYM() - lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) - decomposeCode:= - [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] - for g in gsList for i in 1..]] - gsRev:= REVERSE gsList - rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] - advanceCode:= ['LET,gIndex,['ADD1,gIndex]] - - newTripleCode := ['LIST,sharpArg,:gsList] - newStateCode := - null extraArguments => ['SETQ,stateNam,newTripleCode] - ['HPUT,stateNam,extraArgumentCode,newTripleCode] - - computeFunction:= [auxfn,['LAM,cargl,cbody]] where - cargl:= [:argl,lastArg] - returnValue:= ['PROGN,newStateCode,first gsList] - cbody:= - endTest:= - ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] - newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, - EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] - ['PROGN,:decomposeCode, - ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, - newValueCode,:rotateCode]]] - fromScratchInit:= - [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] - continueInit:= - [['LET,gIndex,['ELT,stateVar,0]], - :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] - mainFunction:= [nam,['LAM,margl,mbody]] where - margl:= [:argl,'envArg] - max:= GENSYM() - tripleCode := ['CONS,n,['LIST,:initCode]] - - -- initialSetCode initializes the global variable if necessary and - -- also binds "stateVar" to its current value - initialSetCode := - initialValueCode := - extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] - tripleCode - cacheResetCode := ['SETQ,stateNam,initialValueCode] - ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ - ['PAIRP,stateNam]]], _ - ['LET,stateVar,cacheResetCode]], _ - [''T, ['LET,stateVar,stateNam]]] - - -- when there are extra arguments, initialResetCode resets "stateVar" - -- to the hashtable entry for the extra arguments - initialResetCode := - null extraArguments => nil - [['LET,stateVar,['OR, - ['HGET,stateVar,extraArgumentCode], - ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] - - mbody := - preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] - phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], - [auxfn,:argl,stateVar]] - phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], - ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] - phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] - phrase4:= [['GT,sharpArg,n-k], - ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] - phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] - ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] - sayKeyedMsg("S2IX0001",[op]) - compileInteractive computeFunction - compileInteractive mainFunction - cacheType:= 'recurrence - cacheCountCode:= ['nodeCount,stateNam] - cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - nam - -nodeCount x == NUMOFNODES x - -recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) - -mkCacheVec(op,nam,kind,resetCode,countCode) == - [op,nam,kind,resetCode,countCode] - --- reportCacheStore vl == --- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") --- sayMSG concat(centerString('"----",22,'" ")," ---- ------") --- for x in vl repeat reportCacheStoreFor x --- --- op2String op == --- u:= linearFormatName op --- atom u => PNAME u --- "STRCONC"/u --- --- reportCacheStorePrint(op,kind,count) == --- ops:= op2String op --- opString:= centerString(ops,22,'" ") --- kindString:= centerString(PNAME kind,10,'" ") --- countString:= centerString(count,19,'" ") --- sayMSG concat(opString,kindString,countString) --- --- reportCacheStoreFor op == --- u:= getI(op,'localModemap) => --- for [['local,target,:.],[.,fn],:.] in u repeat --- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or --- keyedSystemError("S2GE0016",['"reportCacheStoreFor", --- '"missing cache information vector"]) --- reportCacheStorePrint(op,kind,eval countCode) --- true --- u:= getI(op,"cache") => --- reportCacheStorePrint(op,'variable,nodeCount u) --- nil - -clearCache x == - get(x,'localModemap,$e) or get(x,'mapBody,$e) => - for [map,:sub] in $mapSubNameAlist repeat - map=x => _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,'localModemap,nil,$e) - $e:= putHist(x,'mapBody,nil,$e) - $e:= putHist(x,'localVars,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -clearLocalModemaps x == - u:= get(x,"localModemap",$e) => - for sub in ASSOCRIGHT $mapSubNameAlist repeat - _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,"localModemap",nil,$e) - for mm in u repeat - [.,fn,:.] := mm - if def:= get(fn,'definition,$e) then - $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) - if cacheVec:= get(fn,'cacheInfo,$e) then - SET(cacheVec.cacheName,NIL) - -- now clear the property list of the identifier - $e := addIntSymTabBinding(x,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -compileInteractive fn == - if $InteractiveMode then startTimingProcess 'compilation - --following not used for common lisp - --removeUnnecessaryLastArguments CADR fn - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp fn - optfn := - $InteractiveMode => [timedOptimization fn] - [fn] - result := compQuietly optfn - if $InteractiveMode then stopTimingProcess 'compilation - result - -clearAllSlams x == - fn(x,nil) where - fn(thoseToClear,thoseCleared) == - for x in thoseToClear | not MEMQ(x,thoseCleared) repeat - slamListName:= mkCacheName x - SET(slamListName,nil) - thoseCleared:= ADJOIN(x,thoseCleared) - someMoreToClear:= - setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: - thoseCleared]) - NCONC(thoseToClear,someMoreToClear) - -clearSlam("functor")== - id:= mkCacheName functor - SET(id,nil) -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/sockio.lisp b/src/interp/sockio.lisp new file mode 100644 index 00000000..d20205d1 --- /dev/null +++ b/src/interp/sockio.lisp @@ -0,0 +1,241 @@ +;; 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. + + +;; load C socket functions + +(in-package "BOOT") + +#+(and :Lucid (not :ibm/370)) +(progn + (system:define-foreign-function :c 'open_server :fixnum) + (system:define-foreign-function :c 'sock_get_int :fixnum) + (system:define-foreign-function :c 'sock_send_int :fixnum) + (system:define-foreign-function :c 'sock_get_string_buf :fixnum) + (system:define-foreign-function :c 'sock_send_string_len :fixnum) + (system:define-foreign-function :c 'sock_get_float :single) + (system:define-foreign-function :c 'sock_send_float :fixnum) + (system:define-foreign-function :c 'sock_send_wakeup :fixnum) + (system:define-foreign-function :c 'server_switch :fixnum) + (system:define-foreign-function :c 'flush_stdout :fixnum) + (system:define-foreign-function :c 'sock_send_signal :fixnum) + (system:define-foreign-function :c 'print_line :fixnum) + (system:define-foreign-function :c 'plus_infininty :single) + (system:define-foreign-function :c 'minus_infinity :single) + (system:define-foreign-function :c 'NANQ :single) +) + +#+KCL +(progn + (clines "extern double plus_infinity(), minus_infinity(), NANQ();") + (clines "extern double sock_get_float();") +;; GCL may pass strings by value. 'sock_get_string_buf' should fill +;; string with data read from connection, therefore needs address of +;; actual string buffer. We use 'sock_get_string_buf_wrapper' to +;; resolve the problem + (clines "int sock_get_string_buf_wrapper(int i, object x, int j)" + "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);" + " if (x->st.st_fillpst.st_self, j); }") + (defentry open_server (string) (int "open_server")) + (defentry sock_get_int (int) (int "sock_get_int")) + (defentry sock_send_int (int int) (int "sock_send_int")) + (defentry sock_get_string_buf (int object int) + (int "sock_get_string_buf_wrapper")) + (defentry sock_send_string_len (int string int) (int "sock_send_string_len")) + (defentry sock_get_float (int) (double "sock_get_float")) + (defentry sock_send_float (int double) (int "sock_send_float")) + (defentry sock_send_wakeup (int int) (int "sock_send_wakeup")) + (defentry server_switch () (int "server_switch")) + (defentry flush_stdout () (int "flush_stdout")) + (defentry sock_send_signal (int int) (int "sock_send_signal")) + (defentry print_line (string) (int "print_line")) + (defentry plus_infinity () (double "plus_infinity")) + (defentry minus_infinity () (double "minus_infinity")) + (defentry NANQ () (double "NANQ")) + ) + +(defun open-server (name) +#+(and :lucid :ibm/370) -2 +#-(and :lucid :ibm/370) + (open_server name)) +(defun sock-get-int (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_int type)) +(defun sock-send-int (type val) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_int type val)) +(defun sock-get-string (type buf buf-len) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_string_buf type buf buf-len)) +(defun sock-send-string (type str) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_string_len type str (length str))) +(defun sock-get-float (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_float type)) +(defun sock-send-float (type val) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_float type val)) +(defun sock-send-wakeup (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_wakeup type)) +(defun server-switch () +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (server_switch)) +(defun sock-send-signal (type signal) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_signal type signal)) +(defun print-line (str) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (print_line str)) +(defun |plusInfinity| () (plus_infinity)) +(defun |minusInfinity| () (minus_infinity)) + +;; Macros for use in Boot + +(defun |openServer| (name) + (open_server name)) +(defun |sockGetInt| (type) + (sock_get_int type)) +(defun |sockSendInt| (type val) + (sock_send_int type val)) +(defun |sockGetString| (type buf buf-len) + (sock_get_string_buf type buf buf-len)) +(defun |sockSendString| (type str) + (sock_send_string_len type str (length str))) +(defun |sockGetFloat| (type) + (sock_get_float type)) +(defun |sockSendFloat| (type val) + (sock_send_float type val)) +(defun |sockSendWakeup| (type) + (sock_send_wakeup type)) +(defun |serverSwitch| () + (server_switch)) +(defun |sockSendSignal| (type signal) + (sock_send_signal type signal)) +(defun |printLine| (str) + (print_line str)) + +;; Socket types. This list must be consistent with the one in com.h + +(defconstant SessionManager 1) +(defconstant ViewportServer 2) +(defconstant MenuServer 3) +(defconstant SessionIO 4) +(defconstant MessageServer 5) +(defconstant InterpWindow 6) +(defconstant KillSpad 7) +(defconstant DebugWindow 8) +(defconstant NAGLinkServer 8) +(defconstant Forker 9) + +;; same constants for use in BOOT +(defconstant |$SessionManager| SessionManager) +(defconstant |$ViewportServer| ViewportServer) +(defconstant |$MenuServer| MenuServer) +(defconstant |$SessionIO| SessionIO) +(defconstant |$MessageServer| MessageServer) +(defconstant |$InterpWindow| InterpWindow) +(defconstant |$KillSpad| KillSpad) +(defconstant |$DebugWindow| DebugWindow) +(defconstant |$NAGLinkServer| NAGLinkServer) +(defconstant |$Forker| Forker) + +;; Session Manager action requests + +(defconstant CreateFrame 1) +(defconstant SwitchFrames 2) +(defconstant EndOfOutput 3) +(defconstant CallInterp 4) +(defconstant EndSession 5) +(defconstant LispCommand 6) +(defconstant SpadCommand 7) +(defconstant SendXEventToHyperTeX 8) +(defconstant QuietSpadCommand 9) +(defconstant CloseClient 10) +(defconstant QueryClients 11) +(defconstant QuerySpad 12) +(defconstant NonSmanSession 13) +(defconstant KillLispSystem 14) + +(defconstant |$CreateFrame| CreateFrame) +(defconstant |$SwitchFrames| SwitchFrames) +(defconstant |$EndOfOutput| EndOfOutput) +(defconstant |$CallInterp| CallInterp) +(defconstant |$EndSession| EndSession) +(defconstant |$LispCommand| LispCommand) +(defconstant |$SpadCommand| SpadCommand) +(defconstant |$SendXEventToHyperTeX| SendXEventToHyperTeX) +(defconstant |$QuietSpadCommand| QuietSpadCommand) +(defconstant |$CloseClient| CloseClient) +(defconstant |$QueryClients| QueryClients) +(defconstant |$QuerySpad| QuerySpad) +(defconstant |$NonSmanSession| NonSmanSession) +(defconstant |$KillLispSystem| KillLispSystem) + +;; signal types (from /usr/include/sys/signal.h) +#+(and :Lucid (not :ibm/370)) +(progn + (defconstant SIGUSR1 16) ;; user defined signal 1 + (defconstant SIGUSR2 17) ;; user defined signal 2 + ) + +#+:RIOS +(progn + (defconstant SIGUSR1 30) ;; user defined signal 1 + (defconstant SIGUSR2 31) ;; user defined signal 2 + ) + +#+:IBMPS2 +(progn + (defconstant SIGUSR1 30) ;; user defined signal 1 + (defconstant SIGUSR2 31) ;; user defined signal 2 + ) + +(setq |$NaNvalue| (NANQ)) +#-:ccl + (setq |$plusInfinity| (* 1.1 MOST-POSITIVE-LONG-FLOAT)) +#+:ccl + (setq |$plusInfinity| MOST-POSITIVE-LONG-FLOAT) +(setq |$minusInfinity| (- |$plusInfinity|)) + diff --git a/src/interp/sockio.lisp.pamphlet b/src/interp/sockio.lisp.pamphlet deleted file mode 100644 index 2a585267..00000000 --- a/src/interp/sockio.lisp.pamphlet +++ /dev/null @@ -1,263 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp sockio.lisp} -\author{Timothy Daly} -\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. - -@ -<<*>>= -<> - -;; load C socket functions - -(in-package "BOOT") - -#+(and :Lucid (not :ibm/370)) -(progn - (system:define-foreign-function :c 'open_server :fixnum) - (system:define-foreign-function :c 'sock_get_int :fixnum) - (system:define-foreign-function :c 'sock_send_int :fixnum) - (system:define-foreign-function :c 'sock_get_string_buf :fixnum) - (system:define-foreign-function :c 'sock_send_string_len :fixnum) - (system:define-foreign-function :c 'sock_get_float :single) - (system:define-foreign-function :c 'sock_send_float :fixnum) - (system:define-foreign-function :c 'sock_send_wakeup :fixnum) - (system:define-foreign-function :c 'server_switch :fixnum) - (system:define-foreign-function :c 'flush_stdout :fixnum) - (system:define-foreign-function :c 'sock_send_signal :fixnum) - (system:define-foreign-function :c 'print_line :fixnum) - (system:define-foreign-function :c 'plus_infininty :single) - (system:define-foreign-function :c 'minus_infinity :single) - (system:define-foreign-function :c 'NANQ :single) -) - -#+KCL -(progn - (clines "extern double plus_infinity(), minus_infinity(), NANQ();") - (clines "extern double sock_get_float();") -;; GCL may pass strings by value. 'sock_get_string_buf' should fill -;; string with data read from connection, therefore needs address of -;; actual string buffer. We use 'sock_get_string_buf_wrapper' to -;; resolve the problem - (clines "int sock_get_string_buf_wrapper(int i, object x, int j)" - "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);" - " if (x->st.st_fillpst.st_self, j); }") - (defentry open_server (string) (int "open_server")) - (defentry sock_get_int (int) (int "sock_get_int")) - (defentry sock_send_int (int int) (int "sock_send_int")) - (defentry sock_get_string_buf (int object int) - (int "sock_get_string_buf_wrapper")) - (defentry sock_send_string_len (int string int) (int "sock_send_string_len")) - (defentry sock_get_float (int) (double "sock_get_float")) - (defentry sock_send_float (int double) (int "sock_send_float")) - (defentry sock_send_wakeup (int int) (int "sock_send_wakeup")) - (defentry server_switch () (int "server_switch")) - (defentry flush_stdout () (int "flush_stdout")) - (defentry sock_send_signal (int int) (int "sock_send_signal")) - (defentry print_line (string) (int "print_line")) - (defentry plus_infinity () (double "plus_infinity")) - (defentry minus_infinity () (double "minus_infinity")) - (defentry NANQ () (double "NANQ")) - ) - -(defun open-server (name) -#+(and :lucid :ibm/370) -2 -#-(and :lucid :ibm/370) - (open_server name)) -(defun sock-get-int (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_int type)) -(defun sock-send-int (type val) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_int type val)) -(defun sock-get-string (type buf buf-len) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_string_buf type buf buf-len)) -(defun sock-send-string (type str) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_string_len type str (length str))) -(defun sock-get-float (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_float type)) -(defun sock-send-float (type val) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_float type val)) -(defun sock-send-wakeup (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_wakeup type)) -(defun server-switch () -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (server_switch)) -(defun sock-send-signal (type signal) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_signal type signal)) -(defun print-line (str) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (print_line str)) -(defun |plusInfinity| () (plus_infinity)) -(defun |minusInfinity| () (minus_infinity)) - -;; Macros for use in Boot - -(defun |openServer| (name) - (open_server name)) -(defun |sockGetInt| (type) - (sock_get_int type)) -(defun |sockSendInt| (type val) - (sock_send_int type val)) -(defun |sockGetString| (type buf buf-len) - (sock_get_string_buf type buf buf-len)) -(defun |sockSendString| (type str) - (sock_send_string_len type str (length str))) -(defun |sockGetFloat| (type) - (sock_get_float type)) -(defun |sockSendFloat| (type val) - (sock_send_float type val)) -(defun |sockSendWakeup| (type) - (sock_send_wakeup type)) -(defun |serverSwitch| () - (server_switch)) -(defun |sockSendSignal| (type signal) - (sock_send_signal type signal)) -(defun |printLine| (str) - (print_line str)) - -;; Socket types. This list must be consistent with the one in com.h - -(defconstant SessionManager 1) -(defconstant ViewportServer 2) -(defconstant MenuServer 3) -(defconstant SessionIO 4) -(defconstant MessageServer 5) -(defconstant InterpWindow 6) -(defconstant KillSpad 7) -(defconstant DebugWindow 8) -(defconstant NAGLinkServer 8) -(defconstant Forker 9) - -;; same constants for use in BOOT -(defconstant |$SessionManager| SessionManager) -(defconstant |$ViewportServer| ViewportServer) -(defconstant |$MenuServer| MenuServer) -(defconstant |$SessionIO| SessionIO) -(defconstant |$MessageServer| MessageServer) -(defconstant |$InterpWindow| InterpWindow) -(defconstant |$KillSpad| KillSpad) -(defconstant |$DebugWindow| DebugWindow) -(defconstant |$NAGLinkServer| NAGLinkServer) -(defconstant |$Forker| Forker) - -;; Session Manager action requests - -(defconstant CreateFrame 1) -(defconstant SwitchFrames 2) -(defconstant EndOfOutput 3) -(defconstant CallInterp 4) -(defconstant EndSession 5) -(defconstant LispCommand 6) -(defconstant SpadCommand 7) -(defconstant SendXEventToHyperTeX 8) -(defconstant QuietSpadCommand 9) -(defconstant CloseClient 10) -(defconstant QueryClients 11) -(defconstant QuerySpad 12) -(defconstant NonSmanSession 13) -(defconstant KillLispSystem 14) - -(defconstant |$CreateFrame| CreateFrame) -(defconstant |$SwitchFrames| SwitchFrames) -(defconstant |$EndOfOutput| EndOfOutput) -(defconstant |$CallInterp| CallInterp) -(defconstant |$EndSession| EndSession) -(defconstant |$LispCommand| LispCommand) -(defconstant |$SpadCommand| SpadCommand) -(defconstant |$SendXEventToHyperTeX| SendXEventToHyperTeX) -(defconstant |$QuietSpadCommand| QuietSpadCommand) -(defconstant |$CloseClient| CloseClient) -(defconstant |$QueryClients| QueryClients) -(defconstant |$QuerySpad| QuerySpad) -(defconstant |$NonSmanSession| NonSmanSession) -(defconstant |$KillLispSystem| KillLispSystem) - -;; signal types (from /usr/include/sys/signal.h) -#+(and :Lucid (not :ibm/370)) -(progn - (defconstant SIGUSR1 16) ;; user defined signal 1 - (defconstant SIGUSR2 17) ;; user defined signal 2 - ) - -#+:RIOS -(progn - (defconstant SIGUSR1 30) ;; user defined signal 1 - (defconstant SIGUSR2 31) ;; user defined signal 2 - ) - -#+:IBMPS2 -(progn - (defconstant SIGUSR1 30) ;; user defined signal 1 - (defconstant SIGUSR2 31) ;; user defined signal 2 - ) - -(setq |$NaNvalue| (NANQ)) -#-:ccl - (setq |$plusInfinity| (* 1.1 MOST-POSITIVE-LONG-FLOAT)) -#+:ccl - (setq |$plusInfinity| MOST-POSITIVE-LONG-FLOAT) -(setq |$minusInfinity| (- |$plusInfinity|)) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp new file mode 100644 index 00000000..dedfa3e0 --- /dev/null +++ b/src/interp/spad.lisp @@ -0,0 +1,596 @@ +;; 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. + + +; NAME: Scratchpad Package +; PURPOSE: This is an initialization and system-building file for Scratchpad. + +(IMPORT-MODULE "bootlex") +(in-package "BOOT") + +;;; Common Block + +(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") +(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") +(defvar |$reportInstantiations| nil) +(defvar |$reportEachInstantiation| nil) +(defvar |$reportCounts| nil) +(defvar |$CategoryDefaults| nil) +(defvar |$compForModeIfTrue| nil "checked in compSymbol") +(defvar |$functorForm| nil "checked in addModemap0") +(defvar |$formalArgList| nil "checked in compSymbol") +(defvar |$newComp| nil "use new compiler") +(defvar |$newCompCompare| nil "compare new compiler with old") +(defvar |$compileOnlyCertainItems| nil "list of functions to compile") +(defvar |$newCompAtTopLevel| nil "if t uses new compiler") +(defvar |$doNotCompileJustPrint| nil "switch for compile") +(defvar |$PrintCompilerMessageIfTrue| t) +(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") +;; the following initialization of $ must not be a defvar +;; since that make $ special +(setq $ '$) ;; used in def of Ring which is Algebra($) +(defvar |$scanIfTrue| nil "if t continue compiling after errors") +(defvar |$Representation| nil "checked in compNoStacking") +(defvar |$definition| nil "checked in DomainSubstitutionFunction") +(defvar |$Attributes| nil "global attribute list used in JoinInner") +(defvar |$env| nil "checked in isDomainValuedVariable") +(defvar |$e| nil "checked in isDomainValuedVariable") +(defvar |$getPutTrace| nil) +(defvar |$specialCaseKeyList| nil "checked in optCall") +(defvar |$formulaFormat| nil "if true produce script formula output") +(defvar |$texFormat| nil "if true produce tex output") +(defvar |$fortranFormat| nil "if true produce fortran output") +(defvar |$algebraFormat| t "produce 2-d algebra output") +(defvar |$kernelWarn| NIL "") +(defvar |$kernelProtect| NIL "") +(defvar |$HiFiAccess| nil "if true maintain history file") +(defvar |$mapReturnTypes| nil) +(defvar /TRACENAMES NIL) + +(defvar INPUTSTREAM t "bogus initialization for now") + +(defvar |boot-NewKEY| NIL) +(setq /WSNAME 'NOBOOT) +(DEFVAR _ '&) +(defvar /EDIT-FM 'A1) +(defvar /EDIT-FT 'SPAD) +(defvar /RELEASE '"UNKNOWN") +(defvar /rp '/RP) +(defvar APLMODE NIL) +(defvar error-print) +(defvar ind) +(defvar INITCOLUMN 0) +(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) +(defvar LCTRUE '|true|) +(defvar m-chrbuffer) +(defvar m-chrindex) +(defvar MARG 0 "Margin for testing by ?OP") +(defvar NewFlag) +(defvar ParseMode) +(defvar RLGENSYMFG NIL) +(defvar RLGENSYMLST NIL) +(defvar S-SPADTOK 'SPADSYSTOK) +(defvar sortpred) +(defvar SPADSYSKEY '(EOI EOL)) +(defvar STAKCOLUMN -1) +(setq XTOKENREADER 'SPADTOK) +(defvar xtrans '|boot-new|) +(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) +(defvar |InteractiveMode|) +(defvar |NewFLAG| t) +(defvar |uc| 'UC) + +(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) + +(DEFUN /TRANSPAD (X) + (PROG (proplist) + (setq proplist (LIST '(FLUID . |true|) + (CONS '|special| + (COPY-TREE |$InitialDomainsInScope|)))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (COPY-TREE |$InitialModemapFrame|)))) + (RETURN (PROGN (S-PROCESS X) NIL)))) + + ;; NIL needed below since END\_UNIT is not generated by current parser + +(defun |traceComp| () + (SETQ |$compCount| 0) + (EMBED '|comp| + '(LAMBDA (X Y Z) + (PROG (U) + (SETQ |$compCount| (1+ |$compCount|)) + (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) + (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) + ('T '|no|))) + (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") + (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) + (SETQ |$compCount| (1- |$compCount|)) + (RETURN U) ))) + (|comp| $x $m $f) + (UNEMBED '|comp|)) + +(defun READ-SPAD (FN FM TO) + (LET ((proplist + (LIST '(FLUID . |true|) + (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (|makeInitialModemapFrame|)))) + (READ-SPAD0 FN 'SPAD FM TO))) + +(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) + +(defun READ-SPAD0 (FN FT FM TO) + (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) + +(defun READ-SPAD-1 () (|New,ENTRY,1|)) + +(defun UNCONS (X) + (COND ((ATOM X) X) + ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) + (T (ERROR "UNCONS")))) + +(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) + +(defun SPAD-PRINTTIME (A B) + (let (c msg) + (setq C (+ A B)) + (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) + " = " (STRINGIMAGE C) " MS.)")) + (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) + +(defun SPAD-MODETRAN (X) (D-TRAN X)) + +(defun SPAD-EVAL (X) + (COND ((ATOM X) (EVAL X)) + ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) + +;************************************************************************ +; SYSTEM COMMANDS +;************************************************************************ + +(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) + +(defun erase (FN FT) + (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) + +(defun READLISP (UPPER_CASE_FG) + (let (v expr val ) + (setq EXPR (READ-FROM-STRING + (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) + (line-buffer CURRENT-LINE)) + t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) + (VMPRINT EXPR) + (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) + (FORMAT t "~&VALUE = ~S" VAL) + (TERSYSCOMMAND))) + +(defun TERSYSCOMMAND () + (FRESH-LINE) + (SETQ CHR 'ENDOFLINECHR) + (SETQ TOK 'END_UNIT) + (|spadThrow|)) + +(defun /READ (L Q) +; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) +; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) +; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) +; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) + (SETQ /EDITFILE L) + (COND + (Q (/RQ)) + ('T (/RF)) ) + (FLAG |boot-NewKEY| 'KEY) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /EDIT (L) + (SETQ /EDITFILE L) + (/EF) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /COMPINTERP (L OPTS) + (SETQ /EDITFILE (/MKINFILENAM L)) + (COND ((EQUAL OPTS "rf") (/RF)) + ((EQUAL OPTS "rq") (/RQ)) + ('T (/RQ-LIB))) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) + +(defun /FLAG (L) + (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) + (SAY (FIRST L) " has flags: " X) + (TERSYSCOMMAND)) + +(defun |fin| () + (SETQ *EOF* 'T) + (THROW 'SPAD_READER NIL)) + + +(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) + +(defun STREAM2UC (STRM) + (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) + +(defun NEWNAMTRANS (X) + (COND + ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) + ((STRINGP X) X) + ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) + ((ATOM X) X) + ((EQCAR X 'QUOTE)) + (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) + +(defun GP2COND (L) + (COND ((NOT L) (ERROR "GP2COND")) + ((NOT (CDR L)) + (COND ((EQCAR (FIRST L) 'COLON) + (CONS (SECOND L) (LIST (LIST T 'FAIL)))) + (T (LIST (LIST T (FIRST L)))) )) + ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) + (T (ERROR "GP2COND")))) + +(FLAG JUNKTOKLIST 'KEY) + +(defmacro |report| (L) + (SUBST (SECOND L) 'x + '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) + +(defmacro |DomainSubstitutionMacro| (&rest L) + (|DomainSubstitutionFunction| (first L) (second L))) + +(defun |sort| (seq spadfn) + (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) + +#-Lucid +(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) + +#+Lucid +(defun QUOTIENT2 (X Y) ; following to force error check in division by zero + (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) + +#-Lucid +(define-function 'REMAINDER2 #'REM) + +#+Lucid +(defun REMAINDER2 (X Y) + (if (zerop y) (REM 1 Y) (REM X Y))) + +#-Lucid +(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) + +#+Lucid +(defun DIVIDE2 (X Y) + (if (zerop y) (truncate 1 Y) + (multiple-value-call #'cons (TRUNCATE X Y)))) + +(defmacro APPEND2 (x y) `(append ,x ,y)) + +(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) + +(defun |makeSF| (mantissa exponent) + (|float| (/ mantissa (expt 2 (- exponent))))) + +(define-function 'list1 #'list) +(define-function '|not| #'NOT) + +(defun |random| () (random (expt 2 26))) +(defun \,plus (x y) (+ x y)) +(defun \,times (x y) (* x y)) +(defun \,difference (x y) (- x y)) +(defun \,max (x y) (max x y)) +(defun \,min (x y) (min x y)) +;; This is used in the domain Boolean (BOOLEAN.NRLIB/code.lsp) +(defun |BooleanEquality| (x y) (if x y (null y))) + +(defun S-PROCESS (X) + (let ((|$Index| 0) + (*print-pretty* t) + ($MACROASSOC ()) + ($NEWSPAD T) + (|$compUniquelyIfTrue| nil) + |$currentFunction| + |$topOp| + (|$semanticErrorStack| ()) + (|$warningStack| ()) + (|$returnMode| |$EmptyMode|) + (|$leaveLevelStack| ()) + $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + (|$e| |$EmptyEnvironment|) + (|$genSDVar| 0) + (|$VariableCount| 0) + (|$previousTime| (TEMPUS-FUGIT))) + (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) + (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) + (SETQ |$exitModeStack| ()) + (SETQ |$postStack| nil) + (SETQ |$TraceFlag| T) + (if (NOT X) (RETURN NIL)) + (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) + (|parseTransform| (|postTransform| X)))) + ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) + (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) + (COND (|$PrintOnly| + (format t "~S =====>~%" |$currentLine|) + (RETURN (PRETTYPRINT X)))) + (if (NOT $BOOT) + (if |$InteractiveMode| + (|processInteractive| X NIL) + (if (setq U (|compTopLevel| X |$EmptyMode| + |$InteractiveFrame|)) + (SETQ |$InteractiveFrame| (third U)))) + (DEF-PROCESS X)) + (if |$semanticErrorStack| (|displaySemanticErrors|)) + (TERPRI)))) + +(MAKEPROP 'END_UNIT 'KEY T) + +(defun |process| (x) + (COND ((NOT (EQ TOK 'END_UNIT)) + (SETQ DEBUGMODE 'NO) + (SPAD_SYNTAX_ERROR) + (if |$InteractiveMode| (|spadThrow|)) + (S-PROCESS x)))) + +(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) + +(setq *PROMPT* 'LISP) + +(defun |New,ENTRY,1| () + (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* + SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) + $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS + XTOKENREADER STACK STACKX TRAPFLAG) + (SETQ XTRANS '|boot-New| + XTOKENREADER 'NewSYSTOK + SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) + (FLAG |boot-NewKEY| 'KEY) + (SETQ *PROMPT* 'Scratchpad-II) + (PROMPT) + (SETQ XCAPE '_) + (SETQ COMMENTCHR 'IGNORE) + (SETQ COLUMN 0) + (SETQ SINGLINEMODE T) ; SEE NewSYSTOK + (SETQ NewFLAG T) + (SETQ ULCASEFG T) + (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) + (if (/= 0 (setq N (NOTE STR))) + (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) + ) + '|END_OF_New|)) + +(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) + (let (zz) + (INITIALIZE) + (SETQ $previousTime (TEMPUS-FUGIT)) + (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) + (REMFLAG |boot-NewKEY| 'KEY) + INPUTSTREAM)) + +(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) + +(setq *prompt* 'new) + +(defmacro try (X) + `(LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (|tryToFit| (|saveState|) ,X))) + +(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) + '((COMMENT |formatCOMMENT|) + (SEQ |formatSEQ|) + (DEF |formatDEF|) + (LET |formatLET|) + (\: |formatColon|) + (ELT |formatELT|) + (SEGMENT |formatSEGMENT|) + (COND |formatCOND|) + (SCOND |formatSCOND|) + (QUOTE |formatQUOTE|) + (CONS |formatCONS|) + (|where| |formatWHERE|) + (APPEND |formatAPPEND|) + (REPEAT |formatREPEAT|) + (COLLECT |formatCOLLECT|) + (REDUCE |formatREDUCE|))) + +(defmacro |incTimeSum| (a b) + (if (not |$InteractiveTimingStatsIfTrue|) a + (let ((key b) (oldkey (gensym)) (val (gensym))) + `(prog (,oldkey ,val) + (setq ,oldkey (|incrementTimeSum| ,key)) + (setq ,val ,a) + (|incrementTimeSum| ,oldkey) + (return ,val))))) + +(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) + +(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) + +(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) + +(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) + +(defmacro |rplac| (&rest L) + (let (a b s) + (cond + ((EQCAR (SETQ A (CAR L)) 'ELT) + (COND ((AND (INTEGERP (SETQ B (CADDR A))) (>= B 0)) + (SETQ S "CA") + (do ((i 1 (1+ i))) ((> i b)) (SETQ S (STRCONC S "D"))) + (LIST 'RPLAC (LIST (INTERN (STRCONC S "R")) (CADR A)) (CADR L))) + ((ERROR "rplac")))) + ((PROGN + (SETQ A (CARCDREXPAND (CAR L) NIL)) + (SETQ B (CADR L)) + (COND + ((CDDR L) (ERROR 'RPLAC)) + ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) + ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) + ((ERROR 'RPLAC)))))))) + +(DEFUN ASSOCIATER (FN LST) + (COND ((NULL LST) NIL) + ((NULL (CDR LST)) (CAR LST)) + ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) + +(defun ISLOCALOP-1 (IND) + "Curindex points at character after '.'" + (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) + (if (TERMINATOR NEWCHR) (RETURN NIL)) + (setq SELECTOR + (do ((x nil)) + (nil) + (if (terminator newchr) + (reverse x) + (push (setq newchr (nextcharacter)) x)))) + (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) + (setq BUF (GETSTR (LENGTH SELECTOR))) + (mapc #'(lambda (x) (suffix x buf)) selector) + (setq buf (copy-seq selector)) + (setq TERMTOK (INTERN BUF)) + (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) + (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) + (GET TERMTOK IND)) + (return TERMTOK))) +; **** X. Random tables + +(defvar MATBORCH "*") +(defvar $MARGIN 3) +(defvar $LINELENGTH 71) +(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) +(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) +(defvar LITTLEIN " in ") +(defvar INITALPHLIST ALPHLIST) +(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) +(defvar PORDLST (COPY-tree INITXPARLST)) +(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) +(defvar LITTLEA '|a|) +(defvar LITTLEI '|i|) +(defvar *TALLPAR NIL) +(defvar ALLSTAR NIL) +(defvar BLANK " ") +(defvar PLUSS "+") +(defvar PERIOD ".") +(defvar SLASH "/") +(defvar COMMA ",") +(defvar LPAR "(") +(defvar RPAR ")") +(defvar EQSIGN "=") +(defvar DASH "-") +(defvar STAR "*") +(defvar DOLLAR "$") +(defvar COLON ":") + +(FLAG TEMPGENSYMLIST 'IS-GENSYM) + +(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) +(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) +(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) +(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) +(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) +(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) +(MAKEPROP 'LET '|Led| '(:= LET 125 124)) +(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) +(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) + +;; NAME: DECIMAL-LENGTH +;; PURPOSE: Computes number of decimal digits in print representation of x +;; This should made as efficient as possible. + +(DEFUN DECIMAL-LENGTH (X) + (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) + (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) + (IF (LESSP X 10) K (1+ K)))) + +;(DEFUN DECIMAL-LENGTH2 (X) +; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) +; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) + + +;; function to create byte and half-word vectors in new runtime system 8/90 + +#-:CCL +(defun |makeByteWordVec| (initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec| (initialvalue) + (list-to-vector initialvalue)) + +#-:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (list-to-vector initialvalue)) + +(defun |knownEqualPred| (dom) + (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) + (if fun (get (bpiname (car fun)) '|SPADreplace|) + nil))) + +(defun |hashable| (dom) + (memq (|knownEqualPred| dom) + #-Lucid '(EQ EQL EQUAL) + #+Lucid '(EQ EQL EQUAL EQUALP) + )) + +;; simpler interpface to RDEFIOSTREAM +(defun RDEFINSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) + +(defun RDEFOUTSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) + +(defmacro |spadConstant| (dollar n) + `(spadcall (svref ,dollar (the fixnum ,n)))) + + diff --git a/src/interp/spad.lisp.pamphlet b/src/interp/spad.lisp.pamphlet deleted file mode 100644 index 010aa043..00000000 --- a/src/interp/spad.lisp.pamphlet +++ /dev/null @@ -1,626 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. - -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/spad.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\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. - -@ - -<<*>>= -<> - -; NAME: Scratchpad Package -; PURPOSE: This is an initialization and system-building file for Scratchpad. - -(IMPORT-MODULE "bootlex") -(in-package "BOOT") - -;;; Common Block - -(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") -(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") -(defvar |$reportInstantiations| nil) -(defvar |$reportEachInstantiation| nil) -(defvar |$reportCounts| nil) -(defvar |$CategoryDefaults| nil) -(defvar |$compForModeIfTrue| nil "checked in compSymbol") -(defvar |$functorForm| nil "checked in addModemap0") -(defvar |$formalArgList| nil "checked in compSymbol") -(defvar |$newComp| nil "use new compiler") -(defvar |$newCompCompare| nil "compare new compiler with old") -(defvar |$compileOnlyCertainItems| nil "list of functions to compile") -(defvar |$newCompAtTopLevel| nil "if t uses new compiler") -(defvar |$doNotCompileJustPrint| nil "switch for compile") -(defvar |$PrintCompilerMessageIfTrue| t) -(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") -;; the following initialization of $ must not be a defvar -;; since that make $ special -(setq $ '$) ;; used in def of Ring which is Algebra($) -(defvar |$scanIfTrue| nil "if t continue compiling after errors") -(defvar |$Representation| nil "checked in compNoStacking") -(defvar |$definition| nil "checked in DomainSubstitutionFunction") -(defvar |$Attributes| nil "global attribute list used in JoinInner") -(defvar |$env| nil "checked in isDomainValuedVariable") -(defvar |$e| nil "checked in isDomainValuedVariable") -(defvar |$getPutTrace| nil) -(defvar |$specialCaseKeyList| nil "checked in optCall") -(defvar |$formulaFormat| nil "if true produce script formula output") -(defvar |$texFormat| nil "if true produce tex output") -(defvar |$fortranFormat| nil "if true produce fortran output") -(defvar |$algebraFormat| t "produce 2-d algebra output") -(defvar |$kernelWarn| NIL "") -(defvar |$kernelProtect| NIL "") -(defvar |$HiFiAccess| nil "if true maintain history file") -(defvar |$mapReturnTypes| nil) -(defvar /TRACENAMES NIL) - -(defvar INPUTSTREAM t "bogus initialization for now") - -(defvar |boot-NewKEY| NIL) -(setq /WSNAME 'NOBOOT) -(DEFVAR _ '&) -(defvar /EDIT-FM 'A1) -(defvar /EDIT-FT 'SPAD) -(defvar /RELEASE '"UNKNOWN") -(defvar /rp '/RP) -(defvar APLMODE NIL) -(defvar error-print) -(defvar ind) -(defvar INITCOLUMN 0) -(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) -(defvar LCTRUE '|true|) -(defvar m-chrbuffer) -(defvar m-chrindex) -(defvar MARG 0 "Margin for testing by ?OP") -(defvar NewFlag) -(defvar ParseMode) -(defvar RLGENSYMFG NIL) -(defvar RLGENSYMLST NIL) -(defvar S-SPADTOK 'SPADSYSTOK) -(defvar sortpred) -(defvar SPADSYSKEY '(EOI EOL)) -(defvar STAKCOLUMN -1) -(setq XTOKENREADER 'SPADTOK) -(defvar xtrans '|boot-new|) -(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) -(defvar |InteractiveMode|) -(defvar |NewFLAG| t) -(defvar |uc| 'UC) - -(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) - -(DEFUN /TRANSPAD (X) - (PROG (proplist) - (setq proplist (LIST '(FLUID . |true|) - (CONS '|special| - (COPY-TREE |$InitialDomainsInScope|)))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (COPY-TREE |$InitialModemapFrame|)))) - (RETURN (PROGN (S-PROCESS X) NIL)))) - - ;; NIL needed below since END\_UNIT is not generated by current parser - -(defun |traceComp| () - (SETQ |$compCount| 0) - (EMBED '|comp| - '(LAMBDA (X Y Z) - (PROG (U) - (SETQ |$compCount| (1+ |$compCount|)) - (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) - (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) - ('T '|no|))) - (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") - (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) - (SETQ |$compCount| (1- |$compCount|)) - (RETURN U) ))) - (|comp| $x $m $f) - (UNEMBED '|comp|)) - -(defun READ-SPAD (FN FM TO) - (LET ((proplist - (LIST '(FLUID . |true|) - (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (|makeInitialModemapFrame|)))) - (READ-SPAD0 FN 'SPAD FM TO))) - -(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) - -(defun READ-SPAD0 (FN FT FM TO) - (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) - -(defun READ-SPAD-1 () (|New,ENTRY,1|)) - -(defun UNCONS (X) - (COND ((ATOM X) X) - ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) - (T (ERROR "UNCONS")))) - -(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) - -(defun SPAD-PRINTTIME (A B) - (let (c msg) - (setq C (+ A B)) - (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) - " = " (STRINGIMAGE C) " MS.)")) - (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) - -(defun SPAD-MODETRAN (X) (D-TRAN X)) - -(defun SPAD-EVAL (X) - (COND ((ATOM X) (EVAL X)) - ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) - -;************************************************************************ -; SYSTEM COMMANDS -;************************************************************************ - -(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) - -(defun erase (FN FT) - (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) - -(defun READLISP (UPPER_CASE_FG) - (let (v expr val ) - (setq EXPR (READ-FROM-STRING - (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) - (line-buffer CURRENT-LINE)) - t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) - (VMPRINT EXPR) - (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) - (FORMAT t "~&VALUE = ~S" VAL) - (TERSYSCOMMAND))) - -(defun TERSYSCOMMAND () - (FRESH-LINE) - (SETQ CHR 'ENDOFLINECHR) - (SETQ TOK 'END_UNIT) - (|spadThrow|)) - -(defun /READ (L Q) -; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) -; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) -; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) -; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) - (SETQ /EDITFILE L) - (COND - (Q (/RQ)) - ('T (/RF)) ) - (FLAG |boot-NewKEY| 'KEY) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /EDIT (L) - (SETQ /EDITFILE L) - (/EF) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /COMPINTERP (L OPTS) - (SETQ /EDITFILE (/MKINFILENAM L)) - (COND ((EQUAL OPTS "rf") (/RF)) - ((EQUAL OPTS "rq") (/RQ)) - ('T (/RQ-LIB))) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) - -(defun /FLAG (L) - (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) - (SAY (FIRST L) " has flags: " X) - (TERSYSCOMMAND)) - -(defun |fin| () - (SETQ *EOF* 'T) - (THROW 'SPAD_READER NIL)) - - -(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) - -(defun STREAM2UC (STRM) - (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) - -(defun NEWNAMTRANS (X) - (COND - ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) - ((STRINGP X) X) - ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) - ((ATOM X) X) - ((EQCAR X 'QUOTE)) - (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) - -(defun GP2COND (L) - (COND ((NOT L) (ERROR "GP2COND")) - ((NOT (CDR L)) - (COND ((EQCAR (FIRST L) 'COLON) - (CONS (SECOND L) (LIST (LIST T 'FAIL)))) - (T (LIST (LIST T (FIRST L)))) )) - ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) - (T (ERROR "GP2COND")))) - -(FLAG JUNKTOKLIST 'KEY) - -(defmacro |report| (L) - (SUBST (SECOND L) 'x - '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) - -(defmacro |DomainSubstitutionMacro| (&rest L) - (|DomainSubstitutionFunction| (first L) (second L))) - -(defun |sort| (seq spadfn) - (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) - -#-Lucid -(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) - -#+Lucid -(defun QUOTIENT2 (X Y) ; following to force error check in division by zero - (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) - -#-Lucid -(define-function 'REMAINDER2 #'REM) - -#+Lucid -(defun REMAINDER2 (X Y) - (if (zerop y) (REM 1 Y) (REM X Y))) - -#-Lucid -(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) - -#+Lucid -(defun DIVIDE2 (X Y) - (if (zerop y) (truncate 1 Y) - (multiple-value-call #'cons (TRUNCATE X Y)))) - -(defmacro APPEND2 (x y) `(append ,x ,y)) - -(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) - -(defun |makeSF| (mantissa exponent) - (|float| (/ mantissa (expt 2 (- exponent))))) - -(define-function 'list1 #'list) -(define-function '|not| #'NOT) - -(defun |random| () (random (expt 2 26))) -(defun \,plus (x y) (+ x y)) -(defun \,times (x y) (* x y)) -(defun \,difference (x y) (- x y)) -(defun \,max (x y) (max x y)) -(defun \,min (x y) (min x y)) -;; This is used in the domain Boolean (BOOLEAN.NRLIB/code.lsp) -(defun |BooleanEquality| (x y) (if x y (null y))) - -(defun S-PROCESS (X) - (let ((|$Index| 0) - (*print-pretty* t) - ($MACROASSOC ()) - ($NEWSPAD T) - (|$compUniquelyIfTrue| nil) - |$currentFunction| - |$topOp| - (|$semanticErrorStack| ()) - (|$warningStack| ()) - (|$returnMode| |$EmptyMode|) - (|$leaveLevelStack| ()) - $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - (|$e| |$EmptyEnvironment|) - (|$genSDVar| 0) - (|$VariableCount| 0) - (|$previousTime| (TEMPUS-FUGIT))) - (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) - (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) - (SETQ |$exitModeStack| ()) - (SETQ |$postStack| nil) - (SETQ |$TraceFlag| T) - (if (NOT X) (RETURN NIL)) - (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) - (|parseTransform| (|postTransform| X)))) - ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) - (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) - (COND (|$PrintOnly| - (format t "~S =====>~%" |$currentLine|) - (RETURN (PRETTYPRINT X)))) - (if (NOT $BOOT) - (if |$InteractiveMode| - (|processInteractive| X NIL) - (if (setq U (|compTopLevel| X |$EmptyMode| - |$InteractiveFrame|)) - (SETQ |$InteractiveFrame| (third U)))) - (DEF-PROCESS X)) - (if |$semanticErrorStack| (|displaySemanticErrors|)) - (TERPRI)))) - -(MAKEPROP 'END_UNIT 'KEY T) - -(defun |process| (x) - (COND ((NOT (EQ TOK 'END_UNIT)) - (SETQ DEBUGMODE 'NO) - (SPAD_SYNTAX_ERROR) - (if |$InteractiveMode| (|spadThrow|)) - (S-PROCESS x)))) - -(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) - -(setq *PROMPT* 'LISP) - -(defun |New,ENTRY,1| () - (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* - SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) - $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS - XTOKENREADER STACK STACKX TRAPFLAG) - (SETQ XTRANS '|boot-New| - XTOKENREADER 'NewSYSTOK - SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) - (FLAG |boot-NewKEY| 'KEY) - (SETQ *PROMPT* 'Scratchpad-II) - (PROMPT) - (SETQ XCAPE '_) - (SETQ COMMENTCHR 'IGNORE) - (SETQ COLUMN 0) - (SETQ SINGLINEMODE T) ; SEE NewSYSTOK - (SETQ NewFLAG T) - (SETQ ULCASEFG T) - (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) - (if (/= 0 (setq N (NOTE STR))) - (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) - ) - '|END_OF_New|)) - -(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) - (let (zz) - (INITIALIZE) - (SETQ $previousTime (TEMPUS-FUGIT)) - (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) - (REMFLAG |boot-NewKEY| 'KEY) - INPUTSTREAM)) - -(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) - -(setq *prompt* 'new) - -(defmacro try (X) - `(LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (|tryToFit| (|saveState|) ,X))) - -(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) - '((COMMENT |formatCOMMENT|) - (SEQ |formatSEQ|) - (DEF |formatDEF|) - (LET |formatLET|) - (\: |formatColon|) - (ELT |formatELT|) - (SEGMENT |formatSEGMENT|) - (COND |formatCOND|) - (SCOND |formatSCOND|) - (QUOTE |formatQUOTE|) - (CONS |formatCONS|) - (|where| |formatWHERE|) - (APPEND |formatAPPEND|) - (REPEAT |formatREPEAT|) - (COLLECT |formatCOLLECT|) - (REDUCE |formatREDUCE|))) - -(defmacro |incTimeSum| (a b) - (if (not |$InteractiveTimingStatsIfTrue|) a - (let ((key b) (oldkey (gensym)) (val (gensym))) - `(prog (,oldkey ,val) - (setq ,oldkey (|incrementTimeSum| ,key)) - (setq ,val ,a) - (|incrementTimeSum| ,oldkey) - (return ,val))))) - -(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) - -(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) - -(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) - -(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) - -(defmacro |rplac| (&rest L) - (let (a b s) - (cond - ((EQCAR (SETQ A (CAR L)) 'ELT) - (COND ((AND (INTEGERP (SETQ B (CADDR A))) (>= B 0)) - (SETQ S "CA") - (do ((i 1 (1+ i))) ((> i b)) (SETQ S (STRCONC S "D"))) - (LIST 'RPLAC (LIST (INTERN (STRCONC S "R")) (CADR A)) (CADR L))) - ((ERROR "rplac")))) - ((PROGN - (SETQ A (CARCDREXPAND (CAR L) NIL)) - (SETQ B (CADR L)) - (COND - ((CDDR L) (ERROR 'RPLAC)) - ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) - ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) - ((ERROR 'RPLAC)))))))) - -(DEFUN ASSOCIATER (FN LST) - (COND ((NULL LST) NIL) - ((NULL (CDR LST)) (CAR LST)) - ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) - -(defun ISLOCALOP-1 (IND) - "Curindex points at character after '.'" - (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) - (if (TERMINATOR NEWCHR) (RETURN NIL)) - (setq SELECTOR - (do ((x nil)) - (nil) - (if (terminator newchr) - (reverse x) - (push (setq newchr (nextcharacter)) x)))) - (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) - (setq BUF (GETSTR (LENGTH SELECTOR))) - (mapc #'(lambda (x) (suffix x buf)) selector) - (setq buf (copy-seq selector)) - (setq TERMTOK (INTERN BUF)) - (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) - (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) - (GET TERMTOK IND)) - (return TERMTOK))) -; **** X. Random tables - -(defvar MATBORCH "*") -(defvar $MARGIN 3) -(defvar $LINELENGTH 71) -(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) -(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) -(defvar LITTLEIN " in ") -(defvar INITALPHLIST ALPHLIST) -(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) -(defvar PORDLST (COPY-tree INITXPARLST)) -(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) -(defvar LITTLEA '|a|) -(defvar LITTLEI '|i|) -(defvar *TALLPAR NIL) -(defvar ALLSTAR NIL) -(defvar BLANK " ") -(defvar PLUSS "+") -(defvar PERIOD ".") -(defvar SLASH "/") -(defvar COMMA ",") -(defvar LPAR "(") -(defvar RPAR ")") -(defvar EQSIGN "=") -(defvar DASH "-") -(defvar STAR "*") -(defvar DOLLAR "$") -(defvar COLON ":") - -(FLAG TEMPGENSYMLIST 'IS-GENSYM) - -(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) -(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) -(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) -(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) -(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) -(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) -(MAKEPROP 'LET '|Led| '(:= LET 125 124)) -(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) -(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) - -;; NAME: DECIMAL-LENGTH -;; PURPOSE: Computes number of decimal digits in print representation of x -;; This should made as efficient as possible. - -(DEFUN DECIMAL-LENGTH (X) - (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) - (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) - (IF (LESSP X 10) K (1+ K)))) - -;(DEFUN DECIMAL-LENGTH2 (X) -; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) -; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) - - -;; function to create byte and half-word vectors in new runtime system 8/90 - -#-:CCL -(defun |makeByteWordVec| (initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec| (initialvalue) - (list-to-vector initialvalue)) - -#-:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (list-to-vector initialvalue)) - -(defun |knownEqualPred| (dom) - (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) - (if fun (get (bpiname (car fun)) '|SPADreplace|) - nil))) - -(defun |hashable| (dom) - (memq (|knownEqualPred| dom) - #-Lucid '(EQ EQL EQUAL) - #+Lucid '(EQ EQL EQUAL EQUALP) - )) - -;; simpler interpface to RDEFIOSTREAM -(defun RDEFINSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) - -(defun RDEFOUTSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) - -(defmacro |spadConstant| (dollar n) - `(spadcall (svref ,dollar (the fixnum ,n)))) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/spaderror.lisp b/src/interp/spaderror.lisp new file mode 100644 index 00000000..da5bd161 --- /dev/null +++ b/src/interp/spaderror.lisp @@ -0,0 +1,113 @@ +;; 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. + + +;; this files contains basic routines for error handling +(in-package "BOOT") + +(defun error-format (message args) + (let ((|$BreakMode| '|break|)) + (declare (special |$BreakMode|)) + (if (stringp message) (apply #'format nil message args) nil))) + +;;(defmacro |trappedSpadEval| (form) form) ;;nop for now + +#+:akcl +(setq |$quitTag| system::*quit-tag*) +#+:akcl +(defun |resetStackLimits| () (system:reset-stack-limits)) +#-:akcl +(setq |$quitTag| (gensym)) +#-:akcl +(defun |resetStackLimits| () nil) + +;; failed union branch -- value returned for numeric failure +(setq |$numericFailure| (cons 1 "failed")) + +(defvar |$oldBreakMode|) + +;; following macro evaluates form returning Union(type-of form, "failed") + +(defmacro |trapNumericErrors| (form) + `(let ((|$oldBreakMode| |$BreakMode|) + (|$BreakMode| '|trapNumerics|) + (val)) + (setq val (catch '|trapNumerics| ,form)) + (if (eq val |$numericFailure|) val + (cons 0 val)))) + +;;;;;; considering this version for kcl +;;(defmacro |trapNumericErrors| (form) +;; `(let ((val)) +;; (setq val (errorset ,form)) +;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) + +;; the following form embeds around the akcl error handler +#+:akcl +(eval-when + (load eval) + (unembed 'system:universal-error-handler) + (embed 'system:universal-error-handler + '(lambda (type correctable? op + continue-string error-string &rest args) + (block + nil + (setq |$NeedToSignalSessionManager| T) + (if (and (boundp '|$inLispVM|) (boundp '|$BreakMode|)) + (cond ((eq |$BreakMode| '|validate|) + (|systemError| (error-format error-string args))) + ((and (eq |$BreakMode| '|trapNumerics|) + (eq type :ERROR)) + (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) + ((and (eq |$BreakMode| '|trapNumerics|) + (boundp '|$oldBreakMode|) + (setq |$BreakMode| |$oldBreakMode|) + nil)) ;; resets error handler + ((and (null |$inLispVM|) + (memq |$BreakMode| '(|nobreak| |query| |resume|))) + (let ((|$inLispVM| T)) ;; turn off handler + (return + (|systemError| (error-format error-string args))))) + ((eq |$BreakMode| '|letPrint2|) + (setq |$BreakMode| nil) + (throw '|letPrint2| nil)))) + (apply system:universal-error-handler type correctable? op + continue-string error-string args ))))) + + + + + + + + + + diff --git a/src/interp/spaderror.lisp.pamphlet b/src/interp/spaderror.lisp.pamphlet deleted file mode 100644 index 618a94e4..00000000 --- a/src/interp/spaderror.lisp.pamphlet +++ /dev/null @@ -1,141 +0,0 @@ -%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/spaderroor.lisp} Pamphlet} -\author{Timothy Daly} - -\begin{document} -\maketitle - -\begin{abstract} -\end{abstract} - -\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. - -@ -<<*>>= -<> - -;; this files contains basic routines for error handling -(in-package "BOOT") - -(defun error-format (message args) - (let ((|$BreakMode| '|break|)) - (declare (special |$BreakMode|)) - (if (stringp message) (apply #'format nil message args) nil))) - -;;(defmacro |trappedSpadEval| (form) form) ;;nop for now - -#+:akcl -(setq |$quitTag| system::*quit-tag*) -#+:akcl -(defun |resetStackLimits| () (system:reset-stack-limits)) -#-:akcl -(setq |$quitTag| (gensym)) -#-:akcl -(defun |resetStackLimits| () nil) - -;; failed union branch -- value returned for numeric failure -(setq |$numericFailure| (cons 1 "failed")) - -(defvar |$oldBreakMode|) - -;; following macro evaluates form returning Union(type-of form, "failed") - -(defmacro |trapNumericErrors| (form) - `(let ((|$oldBreakMode| |$BreakMode|) - (|$BreakMode| '|trapNumerics|) - (val)) - (setq val (catch '|trapNumerics| ,form)) - (if (eq val |$numericFailure|) val - (cons 0 val)))) - -;;;;;; considering this version for kcl -;;(defmacro |trapNumericErrors| (form) -;; `(let ((val)) -;; (setq val (errorset ,form)) -;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) - -;; the following form embeds around the akcl error handler -#+:akcl -(eval-when - (load eval) - (unembed 'system:universal-error-handler) - (embed 'system:universal-error-handler - '(lambda (type correctable? op - continue-string error-string &rest args) - (block - nil - (setq |$NeedToSignalSessionManager| T) - (if (and (boundp '|$inLispVM|) (boundp '|$BreakMode|)) - (cond ((eq |$BreakMode| '|validate|) - (|systemError| (error-format error-string args))) - ((and (eq |$BreakMode| '|trapNumerics|) - (eq type :ERROR)) - (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) - ((and (eq |$BreakMode| '|trapNumerics|) - (boundp '|$oldBreakMode|) - (setq |$BreakMode| |$oldBreakMode|) - nil)) ;; resets error handler - ((and (null |$inLispVM|) - (memq |$BreakMode| '(|nobreak| |query| |resume|))) - (let ((|$inLispVM| T)) ;; turn off handler - (return - (|systemError| (error-format error-string args))))) - ((eq |$BreakMode| '|letPrint2|) - (setq |$BreakMode| nil) - (throw '|letPrint2| nil)))) - (apply system:universal-error-handler type correctable? op - continue-string error-string args ))))) - - - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/topics.boot b/src/interp/topics.boot index 32a7d7bf..18e06e35 100644 --- a/src/interp/topics.boot +++ b/src/interp/topics.boot @@ -29,10 +29,9 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -)package "BOOT" $topicsDefaults := '( - (basic elt setelt qelt qsetelt eval xRange yRange zRange map map_! qsetelt_!) + (basic elt setelt qelt qsetelt eval xRange yRange zRange map map! qsetelt!) (conversion coerce convert retract) (hidden retractIfCan Zero One) (predicate _< _=) @@ -41,7 +40,7 @@ $topicsDefaults := '( (hyperbolic acosh acoth acsch asech asinh atanh cosh coth csch sech sinh tanh) (destructive setelt qsetelt) (extraction xRange yRange zRange elt qelt) - (transformation map map_!)) + (transformation map map!)) $topicSynonyms := '( (b . basic) @@ -139,7 +138,7 @@ skipBlanks(u,i,m) == -- Compute Topic Code for Operation --======================================================================= topicCode lst == - u := [y for x in lst] where y() == + u := [y for x in lst] where y == rename := LASSOC(x,$topicSynonyms) => rename x if null intersection('(basic extended hidden),u) then u := ['extended,:u] @@ -157,7 +156,7 @@ topicCode lst == --called to modify DOCUMENTATION property for each "con" addTopic2Documentation(con,docAlist) == alist := HGET($conTopicHash,con) or return docAlist - [y for x in docAlist] where y() == + [y for x in docAlist] where y == [op,:pairlist] := x code := LASSOC(op,alist) or 0 for sigDoc in pairlist repeat diff --git a/src/interp/topics.boot.pamphlet b/src/interp/topics.boot.pamphlet deleted file mode 100644 index a269b18c..00000000 --- a/src/interp/topics.boot.pamphlet +++ /dev/null @@ -1,263 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/topics.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -$topicsDefaults := '( - (basic elt setelt qelt qsetelt eval xRange yRange zRange map map! qsetelt!) - (conversion coerce convert retract) - (hidden retractIfCan Zero One) - (predicate _< _=) - (algebraic _+ _- _* _*_* _/ quo rem exquo) - (trignometric acos acot acsc asec asin atan cos cot csc sec sin tan) - (hyperbolic acosh acoth acsch asech asinh atanh cosh coth csch sech sinh tanh) - (destructive setelt qsetelt) - (extraction xRange yRange zRange elt qelt) - (transformation map map!)) - -$topicSynonyms := '( - (b . basic) - (h . hidden) - (e . extended) - (a . algebraic) - (g . algebraic) - (c . construct) - (d . destructive) - (v . conversion) - (m . miscellaneous) - (x . extraction) - (p . predicate) - (tg . trignometric) - (hy . hyperbolic) - (t . transformation)) - -$groupAssoc := '((extended . 1) (basic . 2) (hidden . 4)) - ---======================================================================= --- Create Hashtable of Operation Properties ---======================================================================= ---called at build-time before making DOCUMENTATION property -mkTopicHashTable() == --given $groupAssoc = ((extended . 1)(basic . 2)(xx . 4)..) - $defaultsHash := MAKE_-HASHTABLE 'ID --keys are ops, value is list of topic names - for [kind,:items] in $topicsDefaults repeat --$topicsDefaults is (( op ...) ..) - for item in items repeat - HPUT($defaultsHash,item,[kind,:HGET($defaultsHash,item)]) - $conTopicHash := MAKE_-HASHTABLE 'EQL --key is constructor name; value is - instream := OPEN '"topics.data" - while not EOFP instream repeat - line := READLINE instream - while blankLine? line repeat line := READLINE instream - m := MAXINDEX line --file "topics.data" has form: - m = -1 => 'skip --1 ConstructorName: - line.0 = char '_- => 'skip --2 constructorName or operation name - line := trimString line --3-n ... - m := MAXINDEX line -- (blank line) ... - line.m ^= (char '_:) => systemError('"wrong heading") - con := INTERN SUBSTRING(line,0,m) - alist := [lst while not EOFP instream and - not (blankLine? (line := READLINE instream)) and - line.0 ^= char '_- for i in 1.. - | lst := string2OpAlist line] - alist => HPUT($conTopicHash,con,alist) - --initialize table of topic classes - $topicHash := MAKE_-HASHTABLE 'ID --$topicHash has keys: topic and value: index - for [x,:c] in $groupAssoc repeat HPUT($topicHash,x,c) - $topicIndex := CDR LAST $groupAssoc - - --replace each property list by a topic code - --store under each construct an OR of all codes - for con in HKEYS $conTopicHash repeat - conCode := 0 - for pair in HGET($conTopicHash,con) repeat - RPLACD(pair,code := topicCode CDR pair) - conCode := LOGIOR(conCode,code) - HPUT($conTopicHash,con, - [['constructor,:conCode],:HGET($conTopicHash,con)]) - SHUT instream - ---reduce integers stored under names to 1 + its power of 2 - for key in HKEYS $topicHash repeat - HPUT($topicHash,key,INTEGER_-LENGTH HGET($topicHash,key)) - - $conTopicHash --keys are ops or 'constructor', values are codes - -blankLine? line == - MAXINDEX line = -1 or and/[line . j = (char '_ ) for j in 0..MAXINDEX line] - -string2OpAlist s == - m := #s - k := skipBlanks(s,0,m) or return nil - UPPER_-CASE_-P s.k => nil --skip constructor names - k := 0 - while (k := skipBlanks(s,k,m)) repeat - acc := [INTERN SUBSTRING(s,k,-k + (k := charPosition(char '_ ,s,k + 1))),:acc] - acc := NREVERSE acc - --now add defaults - if u := getDefaultProps first acc then acc := [first acc,:u,:rest acc] - acc - -getDefaultProps name == - u := HGET($defaultsHash,name) - if (s := PNAME name).(m := MAXINDEX s) = char '? then u := ['p,:u] - if s.m = char '_! then u := ['destructive,:u] - u - -skipBlanks(u,i,m) == - while i < m and u.i = $charBlank repeat i := i + 1 - i >= m => nil - i - ---======================================================================= --- Compute Topic Code for Operation ---======================================================================= -topicCode lst == - u := [y for x in lst] where y == - rename := LASSOC(x,$topicSynonyms) => rename - x - if null intersection('(basic extended hidden),u) then u := ['extended,:u] - bitIndexList := nil - for x in REMDUP u repeat - bitIndexList := [fn x,:bitIndexList] where fn x == - k := HGET($topicHash,x) => k - HPUT($topicHash,x,$topicIndex := $topicIndex * 2) - $topicIndex - code := +/[i for i in bitIndexList] - ---======================================================================= --- Add Codes to Documentation Property ---======================================================================= ---called to modify DOCUMENTATION property for each "con" -addTopic2Documentation(con,docAlist) == - alist := HGET($conTopicHash,con) or return docAlist - [y for x in docAlist] where y == - [op,:pairlist] := x - code := LASSOC(op,alist) or 0 - for sigDoc in pairlist repeat - sigDoc is [.,.] => RPLACD(rest sigDoc,code) - systemError sigDoc - docAlist - ---======================================================================= --- Test: Display Topics for a given constructor ---======================================================================= -td con == - $topicClasses := ASSOCRIGHT mySort - [[HGET($topicHash,key),:key] for key in HKEYS $topicHash] - hash := MAKE_-HASHTABLE 'ID - tdAdd(con,hash) - tdPrint hash - -tdAdd(con,hash) == - v := HGET($conTopicHash,con) - u := addTopic2Documentation(con,v) ---u := GETDATABASE(con,'DOCUMENTATION) - for pair in u | FIXP (code := myLastAtom pair) and (op := CAR pair) ^= 'construct repeat - for x in (names := code2Classes code) repeat HPUT(hash,x,insert(op,HGET(hash,x))) - -tdPrint hash == - for key in mySort HKEYS hash repeat - sayBrightly [key,'":"] - sayBrightlyNT '" " - for x in HGET(hash,key) repeat sayBrightlyNT ['" ",x] - TERPRI() - -topics con == - --assumes that DOCUMENTATION property already has #s added - $topicClasses := ASSOCRIGHT mySort - [[HGET($topicHash,key),:key] for key in HKEYS $topicHash] - hash := MAKE_-HASHTABLE 'ID - tdAdd(con,hash) - for x in REMDUP [CAAR y for y in ancestorsOf(getConstructorForm con,nil)] repeat - tdAdd(x,hash) - for x in HKEYS hash repeat HPUT(hash,x,mySort HGET(hash,x)) - tdPrint hash - -code2Classes cc == - cc := 2*cc - [x while cc ^= 0 for x in $topicClasses | ODDP (cc := QUOTIENT(cc,2))] - -myLastAtom x == - while x is [.,:x] repeat nil - x - ---======================================================================= --- Transfer Codes to opAlist ---======================================================================= - -transferClassCodes(conform,opAlist) == - transferCodeCon(opOf conform,opAlist) - for x in ancestorsOf(conform,nil) repeat - transferCodeCon(CAAR x,opAlist) - -transferCodeCon(con,opAlist) == - for pair in GETDATABASE(con,'DOCUMENTATION) - | FIXP (code := myLastAtom pair) repeat - u := ASSOC(QCAR pair,opAlist) => RPLACD(LASTNODE u,code) - ---======================================================================= --- Filter Operation by Topic ---======================================================================= - -filterByTopic(opAlist,topic) == - bitNumber := HGET($topicHash,topic) - [x for x in opAlist - | FIXP (code := myLastAtom x) and LOGBITP(bitNumber,code)] - -listOfTopics(conname) == - doc := GETDATABASE(conname,'DOCUMENTATION) - u := ASSOC('constructor,doc) or return nil - code := myLastAtom u ---null FIXP code => nil - mySort [key for key in HKEYS($topicHash) | LOGBITP(HGET($topicHash,key),code)] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot new file mode 100644 index 00000000..e6eb3ef2 --- /dev/null +++ b/src/interp/wi1.boot @@ -0,0 +1,1261 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +-- !! do not delete the next function ! + +spad2AsTranslatorAutoloadOnceTrigger() == nil + +pairList(u,v) == [[x,:y] for x in u for y in v] + +--====================================================================== +-- Temporary definitions---for tracing and debugging +--====================================================================== +tr fn == + $convertingSpadFile : local := true + $options: local := nil + sfn := STRINGIMAGE fn + newname := STRCONC(sfn,'".as") + $outStream :local := MAKE_-OUTSTREAM newname + markSay '"#pile" + markSay('"#include _"axiom.as_"") + markTerpri() + CATCH("SPAD__READER",compiler [INTERN sfn]) + SHUT $outStream + +stackMessage msg == +--if msg isnt ["cannot coerce: ",:.] then foobum msg + $compErrorMessageStack:= [msg,:$compErrorMessageStack] + nil + +ppFull x == + _*PRINT_-LEVEL_* : local := nil + _*PRINT_-DEPTH_* : local := nil + _*PRINT_-LENGTH_* : local := nil + pp x + +put(x,prop,val,e) == +--if prop = 'mode and CONTAINED('PART,val) then foobar val + $InteractiveMode and not EQ(e,$CategoryFrame) => + putIntSymTab(x,prop,val,e) + --e must never be $CapsuleModemapFrame + null atom x => put(first x,prop,val,e) + newProplist:= augProplistOf(x,prop,val,e) + prop="modemap" and $insideCapsuleFunctionIfTrue=true => + SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] + $CapsuleModemapFrame:= + addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), + $CapsuleModemapFrame) + e + addBinding(x,newProplist,e) + +addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == +--if CONTAINED('PART,proplist) then foobar proplist + EQ(proplist,getProplist(var,e)) => e + $InteractiveMode => addBindingInteractive(var,proplist,e) + if curContour is [[ =var,:.],:.] then curContour:= rest curContour + --Previous line should save some space + [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] + +--====================================================================== +-- From define.boot +--====================================================================== +compJoin(["Join",:argl],m,e) == + catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] + catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) + catList':= + [extract for x in catList] where + extract() == + x := markKillAll x + isCategoryForm(x,e) => + parameters:= + union("append"/[getParms(y,e) for y in rest x],parameters) + where getParms(y,e) == + atom y => + isDomainForm(y,e) => LIST y + nil + y is ['LENGTH,y'] => [y,y'] + LIST y + x + x is ["DomainSubstitutionMacro",pl,body] => + (parameters:= union(pl,parameters); body) + x is ["mkCategory",:.] => x + atom x and getmode(x,e)=$Category => x + stackSemanticError(["invalid argument to Join: ",x],nil) + x + T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] + convert(T,m) + + +compDefineFunctor(dfOriginal,m,e,prefix,fal) == + df := markInsertParts dfOriginal + $domainShell: local -- holds the category of the object being compiled + $profileCompiler: local := true + $profileAlist: local := nil + $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) + compDefineFunctor1(df,m,e,prefix,fal) + +compDefineLisplib(df,m,e,prefix,fal,fn) == + ["DEF",[op,:.],:.] := df + --fn= compDefineCategory OR compDefineFunctor + sayMSG fillerSpaces(72,'"-") + $LISPLIB: local := 'T + $op: local := op + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL -- set by makePredicateBitVector + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibForm: local := NIL + $lisplibKind: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibSlot1 : local := NIL -- used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL + $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc + $lisplibCategory: local := nil + --for categories, is rhs of definition; otherwise, is target of functor + --will eventually become the "constructorCategory" property in lisplib + --set in compDefineCategory if category, otherwise in finalizeLisplib + libName := getConstructorAbbreviation op + -- $incrementalLisplibFlag seems never to be set so next line not used + -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) + BOUNDP '$compileDocumentation and $compileDocumentation => + compileDocumentation libName + sayMSG ['" initializing ",$spadLibFT,:bright libName, + '"for",:bright op] + initializeLisplib libName + sayMSG ['" compiling into ",$spadLibFT,:bright libName] + res:= FUNCALL(fn,df,m,e,prefix,fal) + sayMSG ['" finalizing ",$spadLibFT,:bright libName] +--finalizeLisplib libName + FRESH_-LINE $algebraOutputStream + sayMSG fillerSpaces(72,'"-") + unloadOneConstructor(op,libName) + res + +compTopLevel(x,m,e) == +--+ signals that target is derived from lhs-- see NRTmakeSlot1Info + $NRTderivedTargetIfTrue: local := false + $killOptimizeIfTrue: local:= false + $forceAdd: local:= false + $compTimeSum: local := 0 + $resolveTimeSum: local := 0 + $packagesUsed: local := [] + -- The next line allows the new compiler to be tested interactively. + compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak + if x is ["where",:.] then x := markWhereTran x + def := + x is ["where",a,:.] => a + x + $originalTarget : local := + def is ["DEF",.,[target,:.],:.] => target + 'sorry + x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => + ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) + --keep old environment after top level function defs + FUNCALL(compFun,x,m,e) + +markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == + items := + tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] + [first tail] + [op,:argl] := form + [target,:atypeList] := sig + decls := [[":",a,b] for a in argl for b in atypeList | b] +-- not (and/[null x for x in atypeList]) => +-- systemError ['"unexpected WHERE argument list: ",:atypeList] + for x in items repeat + x is [":",a,b] => + a is ['LISTOF,:r] => + for y in r repeat decls := [[":",y,b],:decls] + decls := [x,:decls] + x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => + fn = target or fn is [=target] => ttype := bd + fn = body or fn is [=body] => body := bd + macros := [x,:macros] + systemError ['"unexpected WHERE item: ",x] + nargtypes := [p for arg in argl | + p := or/[t for d in decls | d is [.,=arg,t]] or + systemError ['"Missing WHERE declaration for :", arg]] + nform := form + ntarget := ttype or target + ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] + result := + REVERSE macros is [:m,e] => + mpart := + m => ['SEQ,:m,['exit,1,e]] + e + ['where,ndef,mpart] + ndef + result + +compPART(u,m,e) == +--------new------------------------------------------94/10/11 + ['PART,.,x] := u + T := comp(x,m,e) => markAny('compPART,u, T) + nil + +xxxxx x == x + +qt(n,T) == + null T => nil + if null getProplist('R,T.env) then xxxxx n + T + +qe(n,e) == + if null getProplist('R,e) then xxxxx n + e + +comp(x,m,e) == + qe(7,e) + T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) +--T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) + --------------------------------------------------------94/11/10 + nil + +comp0(x,m,e) == + qe(8,e) +--version of comp which skips the marking (see compReduce1) + T:= compNoStacking(x,m,e) => + $compStack:= nil + qt(10,T) + $compStack:= [[x,m,e,$exitModeStack],:$compStack] + nil + +compNoStacking(xOrig,m,e) == + $partExpression: local := nil + xOrig := markKillAllRecursive xOrig +-->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) +----------------------------------------------------------94/10/11 + qt(11,compNoStacking0(xOrig,m,e)) + +markKillAllRecursive x == + x is [op,:r] => +--->op = 'PART => markKillAllRecursive CADR r + op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] +----------------------------------------------------------94/10/11 + constructor? op => markKillAll x + op = 'elt and constructor? opOf CAR r => + ['elt,markKillAllRecursive CAR r,CADR r] + x + x + +compNoStackingAux($partExpression,m,e) == +-----------------not used---------------------94/10/11 + x := CADDR $partExpression + T := compNoStacking0(x,m,e) or return nil + markParts($partExpression,T) + +compNoStacking0(x,m,e) == + qe(1,e) + T := compNoStacking01(x,m,qe(51,e)) + qt(52,T) + +compNoStacking01(x,m,e) == +--compNoStacking0(x,m,e) == + if CONTAINED('MI,m) then m := markKillAll(m) + T:= comp2(x,m,e) => + (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => + [T.expr,"Rep",T.env]; qt(12,T)) + --$Representation is bound in compDefineFunctor, set by doIt + --this hack says that when something is undeclared, $ is + --preferred to the underlying representation -- RDJ 9/12/83 + T := compNoStacking1(x,m,e,$compStack) + qt(13,T) + +compNoStacking1(x,m,e,$compStack) == + u:= get(if m="$" then "Rep" else m,"value",e) => + m1 := markKillAll u.expr +--------------------> new <------------------------- + T:= comp2(x,m1,e) => coerce(T,m) + nil +--------------------> new <------------------------- + nil + +compWithMappingMode(x,m,oldE) == + ["Mapping",m',:sl] := m + $killOptimizeIfTrue: local:= true + e:= oldE + x := markKillAll x + ------------------ + m := markKillAll m + ------------------ +--if x is ['PART,.,y] then x := y +--------------------------------- + isFunctor x => + if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and + (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] + ) and extendsCategoryForm("$",target,m') then return [x,m,e] + if STRINGP x then x:= INTERN x + for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat + [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) + not null vl and not hasFormalMapVariable(x, vl) => return + [u,.,.] := comp([x,:vl],m',e) or return nil + extractCodeAndConstructTriple(u, m, oldE) + null vl and (t := comp([x], m', e)) => return + [u,.,.] := t + extractCodeAndConstructTriple(u, m, oldE) + [u,.,.]:= comp(x,m',e) or return nil + originalFun := u + if originalFun is ['WI,a,b] then u := b + uu := ['LAMBDA,vl,u] + --------------------------> 11/28 drop COMP-TRAN, optimizations + T := [uu,m,oldE] + originalFun is ['WI,a,b] => markLambda(vl,a,m,T) + markLambda(vl,originalFun,m,T) + +compAtom(x,m,e) == + T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) + x="nil" => + T:= + modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) + modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) + T => convert(T,m) +--> + FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] +-- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') + t:= + isSymbol x => + compSymbol(x,m,e) or return nil + m = $Expression and primitiveType x => [x,m,e] + STRINGP x => + x ^= '"failed" and (member('(Symbol), $localImportStack) or + member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] + [x, x, e] + [x,primitiveType x or return nil,e] + convert(t,m) + +extractCodeAndConstructTriple(u, m, oldE) == + u := markKillAll u + u is ["call",fn,:.] => + if fn is ["applyFun",a] then fn := a + [fn,m,oldE] + [op,:.,env] := u + [["CONS",["function",op],env],m,oldE] + +compSymbol(s,m,e) == + s="$NoValue" => ["$NoValue",$NoValueMode,e] + isFluid s => [s,getmode(s,e) or return nil,e] + s="true" => ['(QUOTE T),$Boolean,e] + s="false" => [false,$Boolean,e] + s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] + v:= get(s,"value",e) => +--+ + MEMQ(s,$functorLocalParameters) => + NRTgetLocalIndex s + [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile + [s,v.mode,e] --s has been SETQd + m':= getmode(s,e) => + if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and + not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s + [s,m',e] --s is a declared argument + MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] +---> + m = $Symbol or m = $Expression => [['QUOTE,s],m,e] + ---> was ['QUOTE, s] + not isFunction(s,e) => errorRef s + +compForm(form,m,e) == + if form is [['PART,.,op],:r] then form := [op,:r] + ----------------------------------------------------- 94/10/16 + T:= + compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return + stackMessageIfNone ["cannot compile","%b",form,"%d"] + T + +compForm1(form,m,e) == + [op,:argl] := form + $NumberOfArgsIfInteger: local:= #argl --see compElt + op="error" => + [[op,:[([.,.,e]:=outputComp(x,e)).expr + for x in argl]],m,e] + op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) + op is ["elt",domain,op'] => + domain := markKillAll domain + domain="Lisp" => + --op'='QUOTE and null rest argl => [first argl,m,e] + val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] + markLisp([val,m,e],m) +-------> new <------------- +-- foobar domain +-- markImport(domain,true) +-------> new <------------- + domain=$Expression and op'="construct" => compExpressionList(argl,m,e) + (op'="COLLECT") and coerceable(domain,m,e) => + (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) +-------> new <------------- + domain= 'Rep and + (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), + [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) + | x is [[ =domain,:.],:.]])) => ans +-------> new <------------- + ans := compForm2([op',:argl],m,e:= addDomain(domain,e), + [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans + (op'="construct") and coerceable(domain,m,e) => + (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) + nil + + e:= addDomain(m,e) --???unneccessary because of comp2's call??? + (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T + compToApply(op,argl,m,e) + +--% WI and MI + +compForm3(form is [op,:argl],m,e,modemapList) == +--order modemaps so that ones from Rep are moved to the front + modemapList := compFormOrderModemaps(modemapList,m = "$") + qe(22,e) + T:= + or/ + [compFormWithModemap(form,m,e,first (mml:= ml)) + for ml in tails modemapList] or return nil + qt(14,T) + result := + $compUniquelyIfTrue => + or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => + THROW("compUniquely",nil) + qt(15,T) + qt(16,T) + qt(17,markAny('compForm3,form,result)) + +compFormOrderModemaps(mml,targetIsDollar?) == +--order modemaps so that ones from Rep are moved to the front +--exceptions: if $ is the target and there are 2 modemaps with +-- identical signatures, move the $ one ahead + repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] + if repMms and targetIsDollar? then + dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" + and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] + repMms := [:dollarMms, :repMms] + null repMms => mml + [:repMms,:SETDIFFERENCE(mml,repMms)] + +compWI(["WI",a,b],m,E) == + u := comp(b,m,E) + pp (u => "====> ok"; 'NO) + u + +compMI(["MI",a,b],m,E) == + u := comp(b,m,E) + pp (u => "====> ok"; 'NO) + u + +compWhere([.,form,:exprList],m,eInit) == + $insideExpressionIfTrue: local:= false + $insideWhereIfTrue: local:= true +-- if not $insideFunctorIfTrue then +-- $originalTarget := +-- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => +-- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and +-- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and +-- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => +-- [ntarget,:rest osig] +-- osig +-- nil +-- foobum exprList + e:= eInit + u:= + for item in exprList repeat + [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" + u="failed" => return nil + $insideWhereIfTrue:= false + [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil + eFinal:= + del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) + eInit + [x,m,eFinal] + +compMacro(form,m,e) == + $macroIfTrue: local:= true + ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form + firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] + markMacro(first lhs,rhs) + rhs := + rhs is ['CATEGORY,:.] => ['"-- the constructor category"] + rhs is ['Join,:.] => ['"-- the constructor category"] + rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] + rhs is ['add,:.] => ['"-- the constructor capsule"] + formatUnabbreviated rhs + sayBrightly ['" processing macro definition",'%b, + :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] + ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + m=$EmptyMode or m=$NoValueMode => + ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +--compMacro(form,m,e) == +-- $macroIfTrue: local:= true +-- ["MDEF",lhs,signature,specialCases,rhs]:= form +-- rhs := +-- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] +-- rhs is ['Join,:.] => ['"-- the constructor category"] +-- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] +-- rhs is ['add,:.] => ['"-- the constructor capsule"] +-- formatUnabbreviated rhs +-- sayBrightly ['" processing macro definition",'%b, +-- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] +-- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) +-- m=$EmptyMode or m=$NoValueMode => +-- rhs := markMacro(lhs,rhs) +-- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +compSetq(oform,m,E) == + ["LET",form,val] := oform + T := compSetq1(form,val,m,E) => markSetq(oform,T) + nil + +compSetq1(oform,val,m,E) == + form := markKillAll oform + IDENTP form => setqSingle(form,val,m,E) + form is [":",x,y] => + [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) + compSetq(["LET",x,val],m,E') + form is [op,:l] => + op="CONS" => setqMultiple(uncons form,val,m,E) + op="Tuple" => setqMultiple(l,val,m,E) + setqSetelt(oform,form,val,m,E) + +setqSetelt(oform,[v,:s],val,m,E) == + T:= comp0(["setelt",:oform,val],m,E) or return nil +---> ------- + markComp(oform,T) + +setqSingle(id,val,m,E) == + $insideSetqSingleIfTrue: local:= true + --used for comping domain forms within functions + currentProplist:= getProplist(id,E) + m'':= get(id,'mode,E) or getmode(id,E) or + (if m=$NoValueMode then $EmptyMode else m) +-----------------------> new <------------------------- + trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) +-----------------------> new <------------------------- + T:= + (trialT and coerce(trialT,m'')) or eval or return nil where + eval() == + T:= comp(val,m'',E) => T + not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and + (T:=comp(val,maxm'',E)) => T + (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => + assignError(val,T.mode,id,m'') + T':= [x,m',e']:= convert(T,m) or return nil + if $profileCompiler = true then + null IDENTP id => nil + key := + MEMQ(id,rest $form) => 'arguments + 'locals + profileRecord(key,id,T.mode) + newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) + e':= (PAIRP id => e'; addBinding(id,newProplist,e')) + x1 := markKillAll x + if isDomainForm(x1,e') then + if isDomainInScope(id,e') then + stackWarning ["domain valued variable","%b",id,"%d", + "has been reassigned within its scope"] + e':= augModemapsFromDomain1(id,x1,e') + --all we do now is to allocate a slot number for lhs + --e.g. the LET form below will be changed by putInLocalDomainReferences +--+ + if (k:=NRTassocIndex(id)) + then + $markFreeStack := [id,:$markFreeStack] + form:=['SETELT,"$",k,x] + else form:= + $QuickLet => ["LET",id,x] + ["LET",id,x, + (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] + [form,m',e'] + +setqMultiple(nameList,val,m,e) == + val is ["CONS",:.] and m=$NoValueMode => + setqMultipleExplicit(nameList,uncons val,m,e) + val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) + --1. create a gensym, %add to local environment, compile and assign rhs + g:= genVariable() + e:= addBinding(g,nil,e) + T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil + e:= put(g,"mode",m1,e) + [x,m',e]:= convert(T,m) or return nil + --1.1 exit if result is a list + m1 is ["List",D] => + for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) + convert([["PROGN",x,["LET",nameList,g],g],m',e],m) + --2. verify that the #nameList = number of parts of right-hand-side + selectorModePairs:= + --list of modes + decompose(m1,#nameList,e) or return nil where + decompose(t,length,e) == + t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] + comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => + [[name,:mode] for [":",name,mode] in l] + stackMessage ["no multiple assigns to mode: ",t] + #nameList^=#selectorModePairs => + stackMessage [val," must decompose into ",#nameList," components"] + -- 3.generate code; return + assignList:= + [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr + for x in nameList for [y,:z] in selectorModePairs] + if assignList="failed" then NIL + else [MKPROGN [x,:assignList,g],m',e] + +setqMultipleExplicit(nameList,valList,m,e) == + #nameList^=#valList => + stackMessage ["Multiple assignment error; # of items in: ",nameList, + "must = # in: ",valList] + gensymList:= [genVariable() for name in nameList] + for g in gensymList for name in nameList repeat + e := put(g,"mode",get(name,"mode",e),e) + assignList:= + --should be fixed to declare genVar when possible + [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" + for g in gensymList for val in valList for name in nameList] + assignList="failed" => nil + reAssignList:= + [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" + for g in gensymList for name in nameList] + reAssignList="failed" => nil + T := [["PROGN",:[T.expr for T in assignList], + :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] + markMultipleExplicit(nameList,valList,T) + +canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends + atom expr => ValueFlag and level=exitCount + (op:= first expr)="QUOTE" => ValueFlag and level=exitCount + MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) + op="TAGGEDexit" => + expr is [.,count,data] => canReturn(data.expr,level,count,count=level) + level=exitCount and not ValueFlag => nil + op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] + op="TAGGEDreturn" => nil + op="CATCH" => + [.,gs,data]:= expr + (findThrow(gs,data,level,exitCount,ValueFlag) => true) where + findThrow(gs,expr,level,exitCount,ValueFlag) == + atom expr => nil + expr is ["THROW", =gs,data] => true + --this is pessimistic, but I know of no more accurate idea + expr is ["SEQ",:l] => + or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] + or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] + canReturn(data,level,exitCount,ValueFlag) + op = "COND" => + level = exitCount => + or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] + or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] + for v in rest expr] + op="IF" => + expr is [.,a,b,c] + if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then + SAY "IF statement can not cause consequents to be executed" + pp expr + canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) + or canReturn(c,level,exitCount,ValueFlag) + --now we have an ordinary form + atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] + op is ["XLAM",args,bods] => + and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] + systemErrorHere '"canReturn" --for the time being + +compList(l,m is ["List",mUnder],e) == + markImport m + markImport mUnder + null l => [NIL,m,e] + Tl:= [[.,mUnder,e]:= + comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] + Tl="failed" => nil + T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] + +compVector(l,m is ["Vector",mUnder],e) == + markImport m + markImport mUnder + null l => [$EmptyVector,m,e] + Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] + Tl="failed" => nil + [["VECTOR",:[T.expr for T in Tl]],m,e] + +compColon([":",f,t],m,e) == + $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) + --if inside an expression, ":" means to convert to m "on faith" + f := markKillAll f + $lhsOfColon: local:= f + t:= + t := markKillAll t + atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' + isDomainForm(t,e) and not $insideCategoryIfTrue => + (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) + isDomainForm(t,e) or isCategoryForm(t,e) => t + t is ["Mapping",m',:r] => t + unknownTypeError t + t + if $insideCapsuleFunctionIfTrue then markDeclaredImport t + f is ["LISTOF",:l] => + (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) + e:= + f is [op,:argl] and not (t is ["Mapping",:.]) => + --for MPOLY--replace parameters by formal arguments: RDJ 3/83 + newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), + [(x is [":",a,m] => a; x) for x in argl],t) + signature:= + ["Mapping",newTarget,: + [(x is [":",a,m] => m; + getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] + put(op,"mode",signature,e) + put(f,"mode",t,e) + if not $bootStrapMode and $insideFunctorIfTrue and + makeCategoryForm(t,e) is [catform,e] then + e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) + ["/throwAway",getmode(f,e),e] + +compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) + +compConstruct1(form is ["construct",:l],m,e) == + y:= modeIsAggregateOf("List",m,e) => + T:= compList(l,["List",CADR y],e) => convert(T,m) + y:= modeIsAggregateOf("Vector",m,e) => + T:= compVector(l,["Vector",CADR y],e) => convert(T,m) + T:= compForm(form,m,e) => T + for D in getDomainsInScope e repeat + (y:=modeIsAggregateOf("List",D,e)) and + (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => + return T' + (y:=modeIsAggregateOf("Vector",D,e)) and + (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => + return T' + +compPretend(u := ["pretend",x,t],m,e) == + t := markKillAll t + m := markKillAll m + e:= addDomain(t,e) + T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil + if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] + T1:= [T.expr,t,T.env] + t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- + T':= coerce(T1,m) => + warningMessage => + stackWarning warningMessage + markCompColonInside("@",T') + markPretend(T1,T') + nil + +compAtSign(["@",x,m'],m,e) == + m' := markKillAll m' + m := markKillAll m + e:= addDomain(m',e) + T:= comp(x,m',e) or return nil + coerce(T,m) + +compColonInside(x,m,e,m') == + m' := markKillAll m' + e:= addDomain(m',e) + T:= comp(x,$EmptyMode,e) or return nil + if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] + T:= [T.expr,m',T.env] + m := markKillAll m + T':= coerce(T,m) => + warningMessage => + stackWarning warningMessage + markCompColonInside("@",T') + stackWarning [":",m'," -- should replace by pretend"] + markCompColonInside("pretend",T') + nil + +resolve(min, mout) == + din := markKillAll min + dout := markKillAll mout + din=$NoValueMode or dout=$NoValueMode => $NoValueMode + dout=$EmptyMode => din + STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 + STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 + din^=dout and (STRINGP din or STRINGP dout) => + modeEqual(dout,$String) => dout + modeEqual(din,$String) => nil + mkUnion(din,dout) + dout + +coerce(T,m) == + T := [T.expr,markKillAll T.mode,T.env] + m := markKillAll m + if not get(m, 'isLiteral,T.env) then markImport m + $InteractiveMode => + keyedSystemError("S2GE0016",['"coerce", + '"function coerce called from the interpreter."]) +--==================> changes <====================== +--The following line is inappropriate for our needs::: +--rplac(CADR T,substitute("$",$Rep,CADR T)) + T' := coerce0(T,m) => T' + T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] +--==================> changes <====================== + coerce0(T,m) + +coerce0(T,m) == + T':= coerceEasy(T,m) => T' + T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) + T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) + T':= coerceExtraHard(T,m) => T' + T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil + T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) + stackMessage fn(T.expr,T.mode,m) where + -- if from from coerceable, this coerce was just a trial coercion + -- from compFormWithModemap to filter through the modemaps + fn(x,m1,m2) == + ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", + " to mode","%b",m2,"%d"] + +coerceSubset(T := [x,m,e],m') == + m = $SmallInteger => + m' = $Integer => [x,m',e] + m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] + nil +-- pp [m, m'] + isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] + m is ['SubDomain,=m',:.] => [x,m',e] + (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and + -- obviously this is temporary + eval substitute(x,"#1",pred) => [x,m',e] + (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary + and eval substitute(x,"*",pred) => + [x,m',e] + nil + +coerceRep(T,m) == + md := T.mode + atom md => nil + CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or + CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T + nil + +--- GET rid of XLAMs +spadCompileOrSetq form == + --bizarre hack to take account of the existence of "known" functions + --good for performance (LISPLLIB size, BPI size, NILSEC) + [nam,[lam,vl,body]] := form + CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] + if vl is [:vl',E] and body is [nam',: =vl'] then + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] + else if (ATOM body or and/[ATOM x for x in body]) + and vl is [:vl',E] and not CONTAINED(E,body) then + macform := ['XLAM,vl',body] + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] + $insideCapsuleFunctionIfTrue => first COMP LIST form + compileConstructor form + +coerceHard(T,m) == + $e: local:= T.env + m':= T.mode + STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] + modeEqual(m',m) or + (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and + modeEqual(m'',m) or + (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and + modeEqual(m'',m') => [T.expr,m,T.env] + STRINGP T.expr and T.expr=m => [T.expr,m,$e] + isCategoryForm(m,$e) => + $bootStrapMode = true => [T.expr,m,$e] + extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] + nil + nil + +coerceExtraHard(T is [x,m',e],m) == + T':= autoCoerceByModemap(T,m) => T' + isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and + member(t,l) and (T':= autoCoerceByModemap(T,t)) and + (T'':= coerce(T',m)) => T'' + m' is ['Record,:.] and m = $Expression => + [['coerceRe2E,x,['ELT,COPY m',0]],m,e] + nil + +compCoerce(u := ["::",x,m'],m,e) == + m' := markKillAll m' + e:= addDomain(m',e) + m := markKillAll m +--------------> new code <------------------- + T:= compCoerce1(x,m',e) => coerce(T,m) + T := comp(x,$EmptyMode,e) or return nil + T.mode = $SmallInteger and + MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => + compCoerce(["::",["::",x,$Integer],m'],m,e) +--------------> new code <------------------- + getmode(m',e) is ["Mapping",["UnionCategory",:l]] => + l := [markKillAll x for x in l] + T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil + coerce([T.expr,m',T.env],m) + +compCoerce1(x,m',e) == + T:= comp(x,m',e) + if null T then T := comp(x,$EmptyMode,e) + null T => return nil + m1:= + STRINGP T.mode => $String + T.mode + m':=resolve(m1,m') + T:=[T.expr,m1,T.env] + T':= coerce(T,m') => T' + T':= coerceByModemap(T,m') => T' + pred:=isSubset(m',T.mode,e) => + gg:=GENSYM() + pred:= substitute(gg,"*",pred) + code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] + [code,m',T.env] + +coerceByModemap([x,m,e],m') == +--+ modified 6/27 for new runtime system + u:= + [modemap + for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, + s] and (modeEqual(t,m') or isSubset(t,m',e)) + and (modeEqual(s,m) or isSubset(m,s,e))] or return nil + mm:=first u -- patch for non-trival conditons + fn := genDeltaEntry ['coerce,:mm] + T := [["call",fn,x],m',e] + markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) + +autoCoerceByModemap([x,source,e],target) == + u:= + [cexpr + for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ + .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil + fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) + +--====================================================================== +-- From compiler.boot +--====================================================================== +--comp3x(x,m,$e) == + +comp3(x,m,$e) == + --returns a Triple or %else nil to signalcan't do' + $e:= addDomain(m,$e) + e:= $e --for debugging purposes + m is ["Mapping",:.] => compWithMappingMode(x,m,e) + m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) + STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) + ^x or atom x => compAtom(x,m,e) + op:= first x + getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u + op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) + op=":" => compColon(x,m,e) + op="::" => compCoerce(x,m,e) + not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => + compTypeOf(x,m,e) + ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- + x is ['PART,:.] => compPART(x,m,e) + ---------------------------------- + t:= qt(14,compExpression(x,m,e)) + t is [x',m',e'] and not member(m',getDomainsInScope e') => + qt(15,[x',m',addDomain(m',e')]) + qt(16,t) + +yyyyy x == x +compExpression(x,m,e) == + $insideExpressionIfTrue: local:= true + if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x + x := compRenameOp x + atom first x and (fn:= GETL(first x,"SPECIAL")) => + FUNCALL(fn,x,m,e) + compForm(x,m,e) + +compRenameOp x == ----------> new 12/3/94 + x is [op,:r] and op is ['PART,.,op1] => + [op1,:r] + x + +compCase(["case",x,m1],m,e) == + m' := markKillAll m1 + e:= addDomain(m',e) + T:= compCase1(x,m',e) => coerce(T,m) + nil + +compCase1(x,m,e) == + x1 := + x is ['PART,.,a] => a + x + [x',m',e']:= comp(x1,$EmptyMode,e) or return nil + if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) + -------------------------------------------------------------------------- + m' isnt ['Union,:r] => nil + mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') + | map is [.,.,s,t] and modeEqual(t,m) and + (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] + or return nil + u := [cexpr for [.,cexpr] in mml] + fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + tag := genCaseTag(m, r, 1) or return nil + x1 := + switchMode => markRepper('rep, x) + x + markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) + +genCaseTag(t,l,n) == + l is [x, :l] => + x = t => + STRINGP x => INTERN x + INTERN STRCONC("value", STRINGIMAGE n) + x is ["::",=t,:.] => t + STRINGP x => genCaseTag(t, l, n) + genCaseTag(t, l, n + 1) + nil + +compIf(["IF",aOrig,b,c],m,E) == + a := markKillButIfs aOrig + [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil + [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil + [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil + xb':= coerce(Tb,mc) or return nil + x:= ["IF",xa,quotify xb'.expr,quotify xc] + (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where + Env(bEnv,cEnv,b,c,E) == + canReturn(b,0,0,true) => + (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) + canReturn(c,0,0,true) => cEnv + E + [x,mc,returnEnv] + +compBoolean(p,pWas,m,Einit) == + op := opOf p + [p',m,E]:= + fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => + APPLY(fop,[p,pWas,m,Einit]) or return nil + T := comp(p,m,Einit) or return nil + markAny('compBoolean,pWas,T) + [p',m,getSuccessEnvironment(markKillAll p,E), + getInverseEnvironment(markKillAll p,E)] + +compAnd([op,:args], pWas, m, e) == +--called ONLY from compBoolean + cargs := [T.expr for x in args + | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] + null cargs => nil + coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) + +compOr([op,:args], pWas, m, e) == +--called ONLY from compBoolean + cargs := [T.expr for x in args + | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] + null cargs => nil + coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) + +compNot([op,arg], pWas, m, e) == +--called ONLY from compBoolean + [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil + coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) + +compDefine(form,m,e) == + $tripleHits: local:= 0 + $macroIfTrue: local + $packagesUsed: local + ['DEF,.,originalSignature,.,body] := form + if not $insideFunctorIfTrue then + $originalBody := COPY body + compDefine1(form,m,e) + +compDefine1(form,m,e) == + $insideExpressionIfTrue: local:= false + --1. decompose after macro-expanding form + ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) + => [lhs,m,put(first lhs,'macro,rhs,e)] + null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and + (sig:= getSignatureFromMode(lhs,e)) => + -- here signature of lhs is determined by a previous declaration + compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) + if signature.target=$Category then $insideCategoryIfTrue:= true + if signature.target is ['Mapping,:map] then + signature:= map + form:= ['DEF,lhs,signature,specialCases,rhs] + + +-- RDJ (11/83): when argument and return types are all declared, +-- or arguments have types declared in the environment, +-- and there is no existing modemap for this signature, add +-- the modemap by a declaration, then strip off declarations and recurse + e := compDefineAddSignature(lhs,signature,e) +-- 2. if signature list for arguments is not empty, replace ('DEF,..) by +-- ('where,('DEF,..),..) with an empty signature list; +-- otherwise, fill in all NILs in the signature + not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) + signature.target=$Category => + compDefineCategory(form,m,e,nil,$formalArgList) + isDomainForm(rhs,e) and not $insideFunctorIfTrue => + if null signature.target then signature:= + [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: + rest signature] + rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) + compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, + $formalArgList) + null $form => stackAndThrow ['"bad == form ",form] + newPrefix:= + $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) + getAbbreviation($op,#rest $form) + compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) + +compDefineCategory(df,m,e,prefix,fal) == + $domainShell: local -- holds the category of the object being compiled + $lisplibCategory: local + not $insideFunctorIfTrue and $LISPLIB => + compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) + compDefineCategory1(df,m,e,prefix,fal) + +compDefineCategory1(df,m,e,prefix,fal) == + $DEFdepth : local := 0 --for conversion to new compiler 3/93 + $capsuleStack : local := nil --for conversion to new compiler 3/93 + $predicateStack:local := nil --for conversion to new compiler 3/93 + $signatureStack:local := nil --for conversion to new compiler 3/93 + $importStack : local := nil --for conversion to new compiler 3/93 + $globalImportStack : local := nil --for conversion to new compiler 3/93 + $catAddForm : local := nil --for conversion to new compiler 2/95 + $globalDeclareStack : local := nil + $globalImportDefAlist: local:= nil + $localMacroStack : local := nil --for conversion to new compiler 3/93 + $freeStack : local := nil --for conversion to new compiler 3/93 + $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 + $categoryTranForm : local := nil --for conversion to new compiler 10/93 + ['DEF,form,sig,sc,body] := df + body := markKillAll body --these parts will be replaced by compDefineLisplib + categoryCapsule := +--+ + body is ['add,cat,capsule] => + body := cat + capsule + nil + [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) +--+ next two lines +-- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil +-- else + if categoryCapsule and not $bootStrapMode then + [.,.,e] := + $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 + $categoryPredicateList: local := + makeCategoryPredicates(form,$lisplibCategory) + defform := mkCategoryPackage(form,cat,categoryCapsule) + ['DEF,[.,arg,:.],:.] := defform + $categoryNameForDollar :local := arg + compDefine1(defform,$EmptyMode,e) + else + [body,T] := $categoryTranForm + markFinish(body,T) + + [d,m,e] + +compDefineCategory2(form,signature,specialCases,body,m,e, + $prefix,$formalArgList) == + --1. bind global variables + $insideCategoryIfTrue: local:= true + $TOP__LEVEL: local + $definition: local + --used by DomainSubstitutionFunction + $form: local + $op: local + $extraParms: local + --Set in DomainSubstitutionFunction, used further down +-- 1.1 augment e to add declaration $:
+ [$op,:argl]:= $definition:= form + e:= addBinding("$",[['mode,:$definition]],e) + +-- 2. obtain signature + signature':= + [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] + e:= giveFormalParametersValues(argl,e) + +-- 3. replace arguments by $1,..., substitute into body, +-- and introduce declarations into environment + sargl:= TAKE(# argl, $TriangleVariableList) + $functorForm:= $form:= [$op,:sargl] + $formalArgList:= [:sargl,:$formalArgList] + aList:= [[a,:sa] for a in argl for sa in sargl] + formalBody:= SUBLIS(aList,body) + signature' := SUBLIS(aList,signature') +--Begin lines for category default definitions + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $frontier: local := 0 + $getDomainCode: local := nil + $addForm: local:= nil + for x in sargl for t in rest signature' repeat + [.,.,e]:= compMakeDeclaration([":",x,t],m,e) + +-- 4. compile body in environment of %type declarations for arguments + op':= $op + -- following line causes cats with no with or Join to be fresh copies + if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then + formalBody := ['Join, formalBody] + T := compOrCroak(formalBody,signature'.target,e) +--------------------> new <------------------- + $catAddForm := + $originalBody is ['add,y,:.] => y + $originalBody + $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] +--------------------> new <------------------- + body:= optFunctorBody markKillAll T.expr + if $extraParms then + formals:=actuals:=nil + for u in $extraParms repeat + formals:=[CAR u,:formals] + actuals:=[MKQ CDR u,:actuals] + body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] + if argl then body:= -- always subst for args after extraparms + ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: + [['devaluate,u] for u in sargl]]],body] + body:= + ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] + fun:= compile [op',['LAM,sargl,body]] + +-- 5. give operator a 'modemap property + pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] + parSignature:= SUBLIS(pairlis,signature') + parForm:= SUBLIS(pairlis,form) +---- lisplibWrite('"compilerInfo", +---- ['SETQ,'$CategoryFrame, +---- ['put,['QUOTE,op'],' +---- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, +---- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) + --Equivalent to the following two lines, we hope + if null sargl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) + +-- 6. put modemaps into InteractiveModemapFrame + $domainShell := + BOUNDP '$convertingSpadFile and $convertingSpadFile => nil + eval [op',:MAPCAR('MKQ,sargl)] + $lisplibCategory:= formalBody +---- if $LISPLIB then +---- $lisplibForm:= form +---- $lisplibKind:= 'category +---- modemap:= [[parForm,:parSignature],[true,op']] +---- $lisplibModemap:= modemap +---- $lisplibCategory:= formalBody +---- form':=[op',:sargl] +---- augLisplibModemapsFromCategory(form',formalBody,signature') + [fun,'(Category),e] diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet deleted file mode 100644 index a86a7da2..00000000 --- a/src/interp/wi1.boot.pamphlet +++ /dev/null @@ -1,1287 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/wi1.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - --- !! do not delete the next function ! - -spad2AsTranslatorAutoloadOnceTrigger() == nil - -pairList(u,v) == [[x,:y] for x in u for y in v] - ---====================================================================== --- Temporary definitions---for tracing and debugging ---====================================================================== -tr fn == - $convertingSpadFile : local := true - $options: local := nil - sfn := STRINGIMAGE fn - newname := STRCONC(sfn,'".as") - $outStream :local := MAKE_-OUTSTREAM newname - markSay '"#pile" - markSay('"#include _"axiom.as_"") - markTerpri() - CATCH("SPAD__READER",compiler [INTERN sfn]) - SHUT $outStream - -stackMessage msg == ---if msg isnt ["cannot coerce: ",:.] then foobum msg - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - nil - -ppFull x == - _*PRINT_-LEVEL_* : local := nil - _*PRINT_-DEPTH_* : local := nil - _*PRINT_-LENGTH_* : local := nil - pp x - -put(x,prop,val,e) == ---if prop = 'mode and CONTAINED('PART,val) then foobar val - $InteractiveMode and not EQ(e,$CategoryFrame) => - putIntSymTab(x,prop,val,e) - --e must never be $CapsuleModemapFrame - null atom x => put(first x,prop,val,e) - newProplist:= augProplistOf(x,prop,val,e) - prop="modemap" and $insideCapsuleFunctionIfTrue=true => - SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] - $CapsuleModemapFrame:= - addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), - $CapsuleModemapFrame) - e - addBinding(x,newProplist,e) - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == ---if CONTAINED('PART,proplist) then foobar proplist - EQ(proplist,getProplist(var,e)) => e - $InteractiveMode => addBindingInteractive(var,proplist,e) - if curContour is [[ =var,:.],:.] then curContour:= rest curContour - --Previous line should save some space - [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - ---====================================================================== --- From define.boot ---====================================================================== -compJoin(["Join",:argl],m,e) == - catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] - catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) - catList':= - [extract for x in catList] where - extract() == - x := markKillAll x - isCategoryForm(x,e) => - parameters:= - union("append"/[getParms(y,e) for y in rest x],parameters) - where getParms(y,e) == - atom y => - isDomainForm(y,e) => LIST y - nil - y is ['LENGTH,y'] => [y,y'] - LIST y - x - x is ["DomainSubstitutionMacro",pl,body] => - (parameters:= union(pl,parameters); body) - x is ["mkCategory",:.] => x - atom x and getmode(x,e)=$Category => x - stackSemanticError(["invalid argument to Join: ",x],nil) - x - T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] - convert(T,m) - - -compDefineFunctor(dfOriginal,m,e,prefix,fal) == - df := markInsertParts dfOriginal - $domainShell: local -- holds the category of the object being compiled - $profileCompiler: local := true - $profileAlist: local := nil - $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) - compDefineFunctor1(df,m,e,prefix,fal) - -compDefineLisplib(df,m,e,prefix,fal,fn) == - ["DEF",[op,:.],:.] := df - --fn= compDefineCategory OR compDefineFunctor - sayMSG fillerSpaces(72,'"-") - $LISPLIB: local := 'T - $op: local := op - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL -- set by makePredicateBitVector - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibForm: local := NIL - $lisplibKind: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibSlot1 : local := NIL -- used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL - $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc - $lisplibCategory: local := nil - --for categories, is rhs of definition; otherwise, is target of functor - --will eventually become the "constructorCategory" property in lisplib - --set in compDefineCategory if category, otherwise in finalizeLisplib - libName := getConstructorAbbreviation op - -- $incrementalLisplibFlag seems never to be set so next line not used - -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) - BOUNDP '$compileDocumentation and $compileDocumentation => - compileDocumentation libName - sayMSG ['" initializing ",$spadLibFT,:bright libName, - '"for",:bright op] - initializeLisplib libName - sayMSG ['" compiling into ",$spadLibFT,:bright libName] - res:= FUNCALL(fn,df,m,e,prefix,fal) - sayMSG ['" finalizing ",$spadLibFT,:bright libName] ---finalizeLisplib libName - FRESH_-LINE $algebraOutputStream - sayMSG fillerSpaces(72,'"-") - unloadOneConstructor(op,libName) - res - -compTopLevel(x,m,e) == ---+ signals that target is derived from lhs-- see NRTmakeSlot1Info - $NRTderivedTargetIfTrue: local := false - $killOptimizeIfTrue: local:= false - $forceAdd: local:= false - $compTimeSum: local := 0 - $resolveTimeSum: local := 0 - $packagesUsed: local := [] - -- The next line allows the new compiler to be tested interactively. - compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak - if x is ["where",:.] then x := markWhereTran x - def := - x is ["where",a,:.] => a - x - $originalTarget : local := - def is ["DEF",.,[target,:.],:.] => target - 'sorry - x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => - ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) - --keep old environment after top level function defs - FUNCALL(compFun,x,m,e) - -markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == - items := - tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] - [first tail] - [op,:argl] := form - [target,:atypeList] := sig - decls := [[":",a,b] for a in argl for b in atypeList | b] --- not (and/[null x for x in atypeList]) => --- systemError ['"unexpected WHERE argument list: ",:atypeList] - for x in items repeat - x is [":",a,b] => - a is ['LISTOF,:r] => - for y in r repeat decls := [[":",y,b],:decls] - decls := [x,:decls] - x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => - fn = target or fn is [=target] => ttype := bd - fn = body or fn is [=body] => body := bd - macros := [x,:macros] - systemError ['"unexpected WHERE item: ",x] - nargtypes := [p for arg in argl | - p := or/[t for d in decls | d is [.,=arg,t]] or - systemError ['"Missing WHERE declaration for :", arg]] - nform := form - ntarget := ttype or target - ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] - result := - REVERSE macros is [:m,e] => - mpart := - m => ['SEQ,:m,['exit,1,e]] - e - ['where,ndef,mpart] - ndef - result - -compPART(u,m,e) == ---------new------------------------------------------94/10/11 - ['PART,.,x] := u - T := comp(x,m,e) => markAny('compPART,u, T) - nil - -xxxxx x == x - -qt(n,T) == - null T => nil - if null getProplist('R,T.env) then xxxxx n - T - -qe(n,e) == - if null getProplist('R,e) then xxxxx n - e - -comp(x,m,e) == - qe(7,e) - T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) ---T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) - --------------------------------------------------------94/11/10 - nil - -comp0(x,m,e) == - qe(8,e) ---version of comp which skips the marking (see compReduce1) - T:= compNoStacking(x,m,e) => - $compStack:= nil - qt(10,T) - $compStack:= [[x,m,e,$exitModeStack],:$compStack] - nil - -compNoStacking(xOrig,m,e) == - $partExpression: local := nil - xOrig := markKillAllRecursive xOrig --->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) -----------------------------------------------------------94/10/11 - qt(11,compNoStacking0(xOrig,m,e)) - -markKillAllRecursive x == - x is [op,:r] => ---->op = 'PART => markKillAllRecursive CADR r - op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] -----------------------------------------------------------94/10/11 - constructor? op => markKillAll x - op = 'elt and constructor? opOf CAR r => - ['elt,markKillAllRecursive CAR r,CADR r] - x - x - -compNoStackingAux($partExpression,m,e) == ------------------not used---------------------94/10/11 - x := CADDR $partExpression - T := compNoStacking0(x,m,e) or return nil - markParts($partExpression,T) - -compNoStacking0(x,m,e) == - qe(1,e) - T := compNoStacking01(x,m,qe(51,e)) - qt(52,T) - -compNoStacking01(x,m,e) == ---compNoStacking0(x,m,e) == - if CONTAINED('MI,m) then m := markKillAll(m) - T:= comp2(x,m,e) => - (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => - [T.expr,"Rep",T.env]; qt(12,T)) - --$Representation is bound in compDefineFunctor, set by doIt - --this hack says that when something is undeclared, $ is - --preferred to the underlying representation -- RDJ 9/12/83 - T := compNoStacking1(x,m,e,$compStack) - qt(13,T) - -compNoStacking1(x,m,e,$compStack) == - u:= get(if m="$" then "Rep" else m,"value",e) => - m1 := markKillAll u.expr ---------------------> new <------------------------- - T:= comp2(x,m1,e) => coerce(T,m) - nil ---------------------> new <------------------------- - nil - -compWithMappingMode(x,m,oldE) == - ["Mapping",m',:sl] := m - $killOptimizeIfTrue: local:= true - e:= oldE - x := markKillAll x - ------------------ - m := markKillAll m - ------------------ ---if x is ['PART,.,y] then x := y ---------------------------------- - isFunctor x => - if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and - (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] - ) and extendsCategoryForm("$",target,m') then return [x,m,e] - if STRINGP x then x:= INTERN x - for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat - [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) - not null vl and not hasFormalMapVariable(x, vl) => return - [u,.,.] := comp([x,:vl],m',e) or return nil - extractCodeAndConstructTriple(u, m, oldE) - null vl and (t := comp([x], m', e)) => return - [u,.,.] := t - extractCodeAndConstructTriple(u, m, oldE) - [u,.,.]:= comp(x,m',e) or return nil - originalFun := u - if originalFun is ['WI,a,b] then u := b - uu := ['LAMBDA,vl,u] - --------------------------> 11/28 drop COMP-TRAN, optimizations - T := [uu,m,oldE] - originalFun is ['WI,a,b] => markLambda(vl,a,m,T) - markLambda(vl,originalFun,m,T) - -compAtom(x,m,e) == - T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) - x="nil" => - T:= - modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) - modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) - T => convert(T,m) ---> - FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] --- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') - t:= - isSymbol x => - compSymbol(x,m,e) or return nil - m = $Expression and primitiveType x => [x,m,e] - STRINGP x => - x ^= '"failed" and (member('(Symbol), $localImportStack) or - member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] - [x, x, e] - [x,primitiveType x or return nil,e] - convert(t,m) - -extractCodeAndConstructTriple(u, m, oldE) == - u := markKillAll u - u is ["call",fn,:.] => - if fn is ["applyFun",a] then fn := a - [fn,m,oldE] - [op,:.,env] := u - [["CONS",["function",op],env],m,oldE] - -compSymbol(s,m,e) == - s="$NoValue" => ["$NoValue",$NoValueMode,e] - isFluid s => [s,getmode(s,e) or return nil,e] - s="true" => ['(QUOTE T),$Boolean,e] - s="false" => [false,$Boolean,e] - s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] - v:= get(s,"value",e) => ---+ - MEMQ(s,$functorLocalParameters) => - NRTgetLocalIndex s - [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile - [s,v.mode,e] --s has been SETQd - m':= getmode(s,e) => - if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and - not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s - [s,m',e] --s is a declared argument - MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] ----> - m = $Symbol or m = $Expression => [['QUOTE,s],m,e] - ---> was ['QUOTE, s] - not isFunction(s,e) => errorRef s - -compForm(form,m,e) == - if form is [['PART,.,op],:r] then form := [op,:r] - ----------------------------------------------------- 94/10/16 - T:= - compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return - stackMessageIfNone ["cannot compile","%b",form,"%d"] - T - -compForm1(form,m,e) == - [op,:argl] := form - $NumberOfArgsIfInteger: local:= #argl --see compElt - op="error" => - [[op,:[([.,.,e]:=outputComp(x,e)).expr - for x in argl]],m,e] - op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) - op is ["elt",domain,op'] => - domain := markKillAll domain - domain="Lisp" => - --op'='QUOTE and null rest argl => [first argl,m,e] - val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] - markLisp([val,m,e],m) --------> new <------------- --- foobar domain --- markImport(domain,true) --------> new <------------- - domain=$Expression and op'="construct" => compExpressionList(argl,m,e) - (op'="COLLECT") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) --------> new <------------- - domain= 'Rep and - (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), - [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) - | x is [[ =domain,:.],:.]])) => ans --------> new <------------- - ans := compForm2([op',:argl],m,e:= addDomain(domain,e), - [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans - (op'="construct") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) - nil - - e:= addDomain(m,e) --???unneccessary because of comp2's call??? - (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T - compToApply(op,argl,m,e) - ---% WI and MI - -compForm3(form is [op,:argl],m,e,modemapList) == ---order modemaps so that ones from Rep are moved to the front - modemapList := compFormOrderModemaps(modemapList,m = "$") - qe(22,e) - T:= - or/ - [compFormWithModemap(form,m,e,first (mml:= ml)) - for ml in tails modemapList] or return nil - qt(14,T) - result := - $compUniquelyIfTrue => - or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => - THROW("compUniquely",nil) - qt(15,T) - qt(16,T) - qt(17,markAny('compForm3,form,result)) - -compFormOrderModemaps(mml,targetIsDollar?) == ---order modemaps so that ones from Rep are moved to the front ---exceptions: if $ is the target and there are 2 modemaps with --- identical signatures, move the $ one ahead - repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] - if repMms and targetIsDollar? then - dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" - and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] - repMms := [:dollarMms, :repMms] - null repMms => mml - [:repMms,:SETDIFFERENCE(mml,repMms)] - -compWI(["WI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compMI(["MI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compWhere([.,form,:exprList],m,eInit) == - $insideExpressionIfTrue: local:= false - $insideWhereIfTrue: local:= true --- if not $insideFunctorIfTrue then --- $originalTarget := --- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => --- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and --- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and --- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => --- [ntarget,:rest osig] --- osig --- nil --- foobum exprList - e:= eInit - u:= - for item in exprList repeat - [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" - u="failed" => return nil - $insideWhereIfTrue:= false - [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil - eFinal:= - del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) - eInit - [x,m,eFinal] - -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form - firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] - markMacro(first lhs,rhs) - rhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] - ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - ---compMacro(form,m,e) == --- $macroIfTrue: local:= true --- ["MDEF",lhs,signature,specialCases,rhs]:= form --- rhs := --- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] --- rhs is ['Join,:.] => ['"-- the constructor category"] --- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] --- rhs is ['add,:.] => ['"-- the constructor capsule"] --- formatUnabbreviated rhs --- sayBrightly ['" processing macro definition",'%b, --- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] --- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) --- m=$EmptyMode or m=$NoValueMode => --- rhs := markMacro(lhs,rhs) --- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -compSetq(oform,m,E) == - ["LET",form,val] := oform - T := compSetq1(form,val,m,E) => markSetq(oform,T) - nil - -compSetq1(oform,val,m,E) == - form := markKillAll oform - IDENTP form => setqSingle(form,val,m,E) - form is [":",x,y] => - [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) - compSetq(["LET",x,val],m,E') - form is [op,:l] => - op="CONS" => setqMultiple(uncons form,val,m,E) - op="Tuple" => setqMultiple(l,val,m,E) - setqSetelt(oform,form,val,m,E) - -setqSetelt(oform,[v,:s],val,m,E) == - T:= comp0(["setelt",:oform,val],m,E) or return nil ----> ------- - markComp(oform,T) - -setqSingle(id,val,m,E) == - $insideSetqSingleIfTrue: local:= true - --used for comping domain forms within functions - currentProplist:= getProplist(id,E) - m'':= get(id,'mode,E) or getmode(id,E) or - (if m=$NoValueMode then $EmptyMode else m) ------------------------> new <------------------------- - trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) ------------------------> new <------------------------- - T:= - (trialT and coerce(trialT,m'')) or eval or return nil where - eval() == - T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and - (T:=comp(val,maxm'',E)) => T - (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => - assignError(val,T.mode,id,m'') - T':= [x,m',e']:= convert(T,m) or return nil - if $profileCompiler = true then - null IDENTP id => nil - key := - MEMQ(id,rest $form) => 'arguments - 'locals - profileRecord(key,id,T.mode) - newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) - e':= (PAIRP id => e'; addBinding(id,newProplist,e')) - x1 := markKillAll x - if isDomainForm(x1,e') then - if isDomainInScope(id,e') then - stackWarning ["domain valued variable","%b",id,"%d", - "has been reassigned within its scope"] - e':= augModemapsFromDomain1(id,x1,e') - --all we do now is to allocate a slot number for lhs - --e.g. the LET form below will be changed by putInLocalDomainReferences ---+ - if (k:=NRTassocIndex(id)) - then - $markFreeStack := [id,:$markFreeStack] - form:=['SETELT,"$",k,x] - else form:= - $QuickLet => ["LET",id,x] - ["LET",id,x, - (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] - [form,m',e'] - -setqMultiple(nameList,val,m,e) == - val is ["CONS",:.] and m=$NoValueMode => - setqMultipleExplicit(nameList,uncons val,m,e) - val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) - --1. create a gensym, %add to local environment, compile and assign rhs - g:= genVariable() - e:= addBinding(g,nil,e) - T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil - e:= put(g,"mode",m1,e) - [x,m',e]:= convert(T,m) or return nil - --1.1 exit if result is a list - m1 is ["List",D] => - for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) - convert([["PROGN",x,["LET",nameList,g],g],m',e],m) - --2. verify that the #nameList = number of parts of right-hand-side - selectorModePairs:= - --list of modes - decompose(m1,#nameList,e) or return nil where - decompose(t,length,e) == - t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] - comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => - [[name,:mode] for [":",name,mode] in l] - stackMessage ["no multiple assigns to mode: ",t] - #nameList^=#selectorModePairs => - stackMessage [val," must decompose into ",#nameList," components"] - -- 3.generate code; return - assignList:= - [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr - for x in nameList for [y,:z] in selectorModePairs] - if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] - -setqMultipleExplicit(nameList,valList,m,e) == - #nameList^=#valList => - stackMessage ["Multiple assignment error; # of items in: ",nameList, - "must = # in: ",valList] - gensymList:= [genVariable() for name in nameList] - for g in gensymList for name in nameList repeat - e := put(g,"mode",get(name,"mode",e),e) - assignList:= - --should be fixed to declare genVar when possible - [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" - for g in gensymList for val in valList for name in nameList] - assignList="failed" => nil - reAssignList:= - [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" - for g in gensymList for name in nameList] - reAssignList="failed" => nil - T := [["PROGN",:[T.expr for T in assignList], - :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] - markMultipleExplicit(nameList,valList,T) - -canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends - atom expr => ValueFlag and level=exitCount - (op:= first expr)="QUOTE" => ValueFlag and level=exitCount - MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) - op="TAGGEDexit" => - expr is [.,count,data] => canReturn(data.expr,level,count,count=level) - level=exitCount and not ValueFlag => nil - op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] - op="TAGGEDreturn" => nil - op="CATCH" => - [.,gs,data]:= expr - (findThrow(gs,data,level,exitCount,ValueFlag) => true) where - findThrow(gs,expr,level,exitCount,ValueFlag) == - atom expr => nil - expr is ["THROW", =gs,data] => true - --this is pessimistic, but I know of no more accurate idea - expr is ["SEQ",:l] => - or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] - or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] - canReturn(data,level,exitCount,ValueFlag) - op = "COND" => - level = exitCount => - or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] - or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] - for v in rest expr] - op="IF" => - expr is [.,a,b,c] - if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then - SAY "IF statement can not cause consequents to be executed" - pp expr - canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) - or canReturn(c,level,exitCount,ValueFlag) - --now we have an ordinary form - atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - op is ["XLAM",args,bods] => - and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - systemErrorHere '"canReturn" --for the time being - -compList(l,m is ["List",mUnder],e) == - markImport m - markImport mUnder - null l => [NIL,m,e] - Tl:= [[.,mUnder,e]:= - comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] - Tl="failed" => nil - T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] - -compVector(l,m is ["Vector",mUnder],e) == - markImport m - markImport mUnder - null l => [$EmptyVector,m,e] - Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] - Tl="failed" => nil - [["VECTOR",:[T.expr for T in Tl]],m,e] - -compColon([":",f,t],m,e) == - $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) - --if inside an expression, ":" means to convert to m "on faith" - f := markKillAll f - $lhsOfColon: local:= f - t:= - t := markKillAll t - atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' - isDomainForm(t,e) and not $insideCategoryIfTrue => - (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) - isDomainForm(t,e) or isCategoryForm(t,e) => t - t is ["Mapping",m',:r] => t - unknownTypeError t - t - if $insideCapsuleFunctionIfTrue then markDeclaredImport t - f is ["LISTOF",:l] => - (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) - e:= - f is [op,:argl] and not (t is ["Mapping",:.]) => - --for MPOLY--replace parameters by formal arguments: RDJ 3/83 - newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), - [(x is [":",a,m] => a; x) for x in argl],t) - signature:= - ["Mapping",newTarget,: - [(x is [":",a,m] => m; - getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] - put(op,"mode",signature,e) - put(f,"mode",t,e) - if not $bootStrapMode and $insideFunctorIfTrue and - makeCategoryForm(t,e) is [catform,e] then - e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) - ["/throwAway",getmode(f,e),e] - -compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) - -compConstruct1(form is ["construct",:l],m,e) == - y:= modeIsAggregateOf("List",m,e) => - T:= compList(l,["List",CADR y],e) => convert(T,m) - y:= modeIsAggregateOf("Vector",m,e) => - T:= compVector(l,["Vector",CADR y],e) => convert(T,m) - T:= compForm(form,m,e) => T - for D in getDomainsInScope e repeat - (y:=modeIsAggregateOf("List",D,e)) and - (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => - return T' - (y:=modeIsAggregateOf("Vector",D,e)) and - (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => - return T' - -compPretend(u := ["pretend",x,t],m,e) == - t := markKillAll t - m := markKillAll m - e:= addDomain(t,e) - T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil - if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] - T1:= [T.expr,t,T.env] - t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- - T':= coerce(T1,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - markPretend(T1,T') - nil - -compAtSign(["@",x,m'],m,e) == - m' := markKillAll m' - m := markKillAll m - e:= addDomain(m',e) - T:= comp(x,m',e) or return nil - coerce(T,m) - -compColonInside(x,m,e,m') == - m' := markKillAll m' - e:= addDomain(m',e) - T:= comp(x,$EmptyMode,e) or return nil - if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] - T:= [T.expr,m',T.env] - m := markKillAll m - T':= coerce(T,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - stackWarning [":",m'," -- should replace by pretend"] - markCompColonInside("pretend",T') - nil - -resolve(min, mout) == - din := markKillAll min - dout := markKillAll mout - din=$NoValueMode or dout=$NoValueMode => $NoValueMode - dout=$EmptyMode => din - STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 - STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 - din^=dout and (STRINGP din or STRINGP dout) => - modeEqual(dout,$String) => dout - modeEqual(din,$String) => nil - mkUnion(din,dout) - dout - -coerce(T,m) == - T := [T.expr,markKillAll T.mode,T.env] - m := markKillAll m - if not get(m, 'isLiteral,T.env) then markImport m - $InteractiveMode => - keyedSystemError("S2GE0016",['"coerce", - '"function coerce called from the interpreter."]) ---==================> changes <====================== ---The following line is inappropriate for our needs::: ---rplac(CADR T,substitute("$",$Rep,CADR T)) - T' := coerce0(T,m) => T' - T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] ---==================> changes <====================== - coerce0(T,m) - -coerce0(T,m) == - T':= coerceEasy(T,m) => T' - T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) - T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) - T':= coerceExtraHard(T,m) => T' - T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil - T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) - stackMessage fn(T.expr,T.mode,m) where - -- if from from coerceable, this coerce was just a trial coercion - -- from compFormWithModemap to filter through the modemaps - fn(x,m1,m2) == - ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", - " to mode","%b",m2,"%d"] - -coerceSubset(T := [x,m,e],m') == - m = $SmallInteger => - m' = $Integer => [x,m',e] - m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] - nil --- pp [m, m'] - isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and - -- obviously this is temporary - eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] - nil - -coerceRep(T,m) == - md := T.mode - atom md => nil - CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or - CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T - nil - ---- GET rid of XLAMs -spadCompileOrSetq form == - --bizarre hack to take account of the existence of "known" functions - --good for performance (LISPLLIB size, BPI size, NILSEC) - [nam,[lam,vl,body]] := form - CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] - if vl is [:vl',E] and body is [nam',: =vl'] then - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] - else if (ATOM body or and/[ATOM x for x in body]) - and vl is [:vl',E] and not CONTAINED(E,body) then - macform := ['XLAM,vl',body] - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] - $insideCapsuleFunctionIfTrue => first COMP LIST form - compileConstructor form - -coerceHard(T,m) == - $e: local:= T.env - m':= T.mode - STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] - modeEqual(m',m) or - (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and - modeEqual(m'',m) or - (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and - modeEqual(m'',m') => [T.expr,m,T.env] - STRINGP T.expr and T.expr=m => [T.expr,m,$e] - isCategoryForm(m,$e) => - $bootStrapMode = true => [T.expr,m,$e] - extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] - nil - nil - -coerceExtraHard(T is [x,m',e],m) == - T':= autoCoerceByModemap(T,m) => T' - isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and - member(t,l) and (T':= autoCoerceByModemap(T,t)) and - (T'':= coerce(T',m)) => T'' - m' is ['Record,:.] and m = $Expression => - [['coerceRe2E,x,['ELT,COPY m',0]],m,e] - nil - -compCoerce(u := ["::",x,m'],m,e) == - m' := markKillAll m' - e:= addDomain(m',e) - m := markKillAll m ---------------> new code <------------------- - T:= compCoerce1(x,m',e) => coerce(T,m) - T := comp(x,$EmptyMode,e) or return nil - T.mode = $SmallInteger and - MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => - compCoerce(["::",["::",x,$Integer],m'],m,e) ---------------> new code <------------------- - getmode(m',e) is ["Mapping",["UnionCategory",:l]] => - l := [markKillAll x for x in l] - T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil - coerce([T.expr,m',T.env],m) - -compCoerce1(x,m',e) == - T:= comp(x,m',e) - if null T then T := comp(x,$EmptyMode,e) - null T => return nil - m1:= - STRINGP T.mode => $String - T.mode - m':=resolve(m1,m') - T:=[T.expr,m1,T.env] - T':= coerce(T,m') => T' - T':= coerceByModemap(T,m') => T' - pred:=isSubset(m',T.mode,e) => - gg:=GENSYM() - pred:= substitute(gg,"*",pred) - code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] - [code,m',T.env] - -coerceByModemap([x,m,e],m') == ---+ modified 6/27 for new runtime system - u:= - [modemap - for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, - s] and (modeEqual(t,m') or isSubset(t,m',e)) - and (modeEqual(s,m) or isSubset(m,s,e))] or return nil - mm:=first u -- patch for non-trival conditons - fn := genDeltaEntry ['coerce,:mm] - T := [["call",fn,x],m',e] - markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) - -autoCoerceByModemap([x,source,e],target) == - u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ - .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) - ---====================================================================== --- From compiler.boot ---====================================================================== ---comp3x(x,m,$e) == - -comp3(x,m,$e) == - --returns a Triple or %else nil to signalcan't do' - $e:= addDomain(m,$e) - e:= $e --for debugging purposes - m is ["Mapping",:.] => compWithMappingMode(x,m,e) - m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) - STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) - ^x or atom x => compAtom(x,m,e) - op:= first x - getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u - op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) - op=":" => compColon(x,m,e) - op="::" => compCoerce(x,m,e) - not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => - compTypeOf(x,m,e) - ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- - x is ['PART,:.] => compPART(x,m,e) - ---------------------------------- - t:= qt(14,compExpression(x,m,e)) - t is [x',m',e'] and not member(m',getDomainsInScope e') => - qt(15,[x',m',addDomain(m',e')]) - qt(16,t) - -yyyyy x == x -compExpression(x,m,e) == - $insideExpressionIfTrue: local:= true - if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x - x := compRenameOp x - atom first x and (fn:= GETL(first x,"SPECIAL")) => - FUNCALL(fn,x,m,e) - compForm(x,m,e) - -compRenameOp x == ----------> new 12/3/94 - x is [op,:r] and op is ['PART,.,op1] => - [op1,:r] - x - -compCase(["case",x,m1],m,e) == - m' := markKillAll m1 - e:= addDomain(m',e) - T:= compCase1(x,m',e) => coerce(T,m) - nil - -compCase1(x,m,e) == - x1 := - x is ['PART,.,a] => a - x - [x',m',e']:= comp(x1,$EmptyMode,e) or return nil - if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) - -------------------------------------------------------------------------- - m' isnt ['Union,:r] => nil - mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') - | map is [.,.,s,t] and modeEqual(t,m) and - (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] - or return nil - u := [cexpr for [.,cexpr] in mml] - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - tag := genCaseTag(m, r, 1) or return nil - x1 := - switchMode => markRepper('rep, x) - x - markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) - -genCaseTag(t,l,n) == - l is [x, :l] => - x = t => - STRINGP x => INTERN x - INTERN STRCONC("value", STRINGIMAGE n) - x is ["::",=t,:.] => t - STRINGP x => genCaseTag(t, l, n) - genCaseTag(t, l, n + 1) - nil - -compIf(["IF",aOrig,b,c],m,E) == - a := markKillButIfs aOrig - [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil - [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil - [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil - xb':= coerce(Tb,mc) or return nil - x:= ["IF",xa,quotify xb'.expr,quotify xc] - (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where - Env(bEnv,cEnv,b,c,E) == - canReturn(b,0,0,true) => - (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) - canReturn(c,0,0,true) => cEnv - E - [x,mc,returnEnv] - -compBoolean(p,pWas,m,Einit) == - op := opOf p - [p',m,E]:= - fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => - APPLY(fop,[p,pWas,m,Einit]) or return nil - T := comp(p,m,Einit) or return nil - markAny('compBoolean,pWas,T) - [p',m,getSuccessEnvironment(markKillAll p,E), - getInverseEnvironment(markKillAll p,E)] - -compAnd([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) - -compOr([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) - -compNot([op,arg], pWas, m, e) == ---called ONLY from compBoolean - [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil - coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) - -compDefine(form,m,e) == - $tripleHits: local:= 0 - $macroIfTrue: local - $packagesUsed: local - ['DEF,.,originalSignature,.,body] := form - if not $insideFunctorIfTrue then - $originalBody := COPY body - compDefine1(form,m,e) - -compDefine1(form,m,e) == - $insideExpressionIfTrue: local:= false - --1. decompose after macro-expanding form - ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] - null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and - (sig:= getSignatureFromMode(lhs,e)) => - -- here signature of lhs is determined by a previous declaration - compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) - if signature.target=$Category then $insideCategoryIfTrue:= true - if signature.target is ['Mapping,:map] then - signature:= map - form:= ['DEF,lhs,signature,specialCases,rhs] - - --- RDJ (11/83): when argument and return types are all declared, --- or arguments have types declared in the environment, --- and there is no existing modemap for this signature, add --- the modemap by a declaration, then strip off declarations and recurse - e := compDefineAddSignature(lhs,signature,e) --- 2. if signature list for arguments is not empty, replace ('DEF,..) by --- ('where,('DEF,..),..) with an empty signature list; --- otherwise, fill in all NILs in the signature - not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) - signature.target=$Category => - compDefineCategory(form,m,e,nil,$formalArgList) - isDomainForm(rhs,e) and not $insideFunctorIfTrue => - if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: - rest signature] - rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) - compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, - $formalArgList) - null $form => stackAndThrow ['"bad == form ",form] - newPrefix:= - $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) - compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -compDefineCategory(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $lisplibCategory: local - not $insideFunctorIfTrue and $LISPLIB => - compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) - compDefineCategory1(df,m,e,prefix,fal) - -compDefineCategory1(df,m,e,prefix,fal) == - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $catAddForm : local := nil --for conversion to new compiler 2/95 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $categoryTranForm : local := nil --for conversion to new compiler 10/93 - ['DEF,form,sig,sc,body] := df - body := markKillAll body --these parts will be replaced by compDefineLisplib - categoryCapsule := ---+ - body is ['add,cat,capsule] => - body := cat - capsule - nil - [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) ---+ next two lines --- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil --- else - if categoryCapsule and not $bootStrapMode then - [.,.,e] := - $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 - $categoryPredicateList: local := - makeCategoryPredicates(form,$lisplibCategory) - defform := mkCategoryPackage(form,cat,categoryCapsule) - ['DEF,[.,arg,:.],:.] := defform - $categoryNameForDollar :local := arg - compDefine1(defform,$EmptyMode,e) - else - [body,T] := $categoryTranForm - markFinish(body,T) - - [d,m,e] - -compDefineCategory2(form,signature,specialCases,body,m,e, - $prefix,$formalArgList) == - --1. bind global variables - $insideCategoryIfTrue: local:= true - $TOP__LEVEL: local - $definition: local - --used by DomainSubstitutionFunction - $form: local - $op: local - $extraParms: local - --Set in DomainSubstitutionFunction, used further down --- 1.1 augment e to add declaration $: - [$op,:argl]:= $definition:= form - e:= addBinding("$",[['mode,:$definition]],e) - --- 2. obtain signature - signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] - e:= giveFormalParametersValues(argl,e) - --- 3. replace arguments by $1,..., substitute into body, --- and introduce declarations into environment - sargl:= TAKE(# argl, $TriangleVariableList) - $functorForm:= $form:= [$op,:sargl] - $formalArgList:= [:sargl,:$formalArgList] - aList:= [[a,:sa] for a in argl for sa in sargl] - formalBody:= SUBLIS(aList,body) - signature' := SUBLIS(aList,signature') ---Begin lines for category default definitions - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $frontier: local := 0 - $getDomainCode: local := nil - $addForm: local:= nil - for x in sargl for t in rest signature' repeat - [.,.,e]:= compMakeDeclaration([":",x,t],m,e) - --- 4. compile body in environment of %type declarations for arguments - op':= $op - -- following line causes cats with no with or Join to be fresh copies - if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then - formalBody := ['Join, formalBody] - T := compOrCroak(formalBody,signature'.target,e) ---------------------> new <------------------- - $catAddForm := - $originalBody is ['add,y,:.] => y - $originalBody - $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] ---------------------> new <------------------- - body:= optFunctorBody markKillAll T.expr - if $extraParms then - formals:=actuals:=nil - for u in $extraParms repeat - formals:=[CAR u,:formals] - actuals:=[MKQ CDR u,:actuals] - body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] - if argl then body:= -- always subst for args after extraparms - ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: - [['devaluate,u] for u in sargl]]],body] - body:= - ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] - fun:= compile [op',['LAM,sargl,body]] - --- 5. give operator a 'modemap property - pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] - parSignature:= SUBLIS(pairlis,signature') - parForm:= SUBLIS(pairlis,form) ----- lisplibWrite('"compilerInfo", ----- ['SETQ,'$CategoryFrame, ----- ['put,['QUOTE,op'],' ----- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, ----- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) - --Equivalent to the following two lines, we hope - if null sargl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) - --- 6. put modemaps into InteractiveModemapFrame - $domainShell := - BOUNDP '$convertingSpadFile and $convertingSpadFile => nil - eval [op',:MAPCAR('MKQ,sargl)] - $lisplibCategory:= formalBody ----- if $LISPLIB then ----- $lisplibForm:= form ----- $lisplibKind:= 'category ----- modemap:= [[parForm,:parSignature],[true,op']] ----- $lisplibModemap:= modemap ----- $lisplibCategory:= formalBody ----- form':=[op',:sargl] ----- augLisplibModemapsFromCategory(form',formalBody,signature') - [fun,'(Category),e] -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot new file mode 100644 index 00000000..3842101e --- /dev/null +++ b/src/interp/wi2.boot @@ -0,0 +1,1229 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == + ['DEF,form,signature,$functorSpecialCases,body] := df + signature := markKillAll signature + if NRTPARSE = true then + [lineNumber,:$functorSpecialCases] := $functorSpecialCases +-- 1. bind global variables + $addForm: local + $viewNames: local:= nil + + --This list is only used in genDomainViewName, for generating names + --for alternate views, if they do not already exist. + --format: Alist: (domain name . sublist) + --sublist is alist: category . name of view + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $DEFdepth : local := 0 --for conversion to new compiler 3/93 + $capsuleStack : local := nil --for conversion to new compiler 3/93 + $predicateStack:local := nil --for conversion to new compiler 3/93 + $signatureStack:local := nil --for conversion to new compiler 3/93 + $importStack : local := nil --for conversion to new compiler 3/93 + $globalImportStack : local := nil --for conversion to new compiler 3/93 + $globalDeclareStack : local := nil + $globalImportDefAlist: local:= nil + $localMacroStack : local := nil --for conversion to new compiler 3/93 + $freeStack : local := nil --for conversion to new compiler 3/93 + $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 + $localLoopVariables: local := nil + $pathStack : local := nil + $form: local + $op: local + $signature: local + $functorTarget: local + $Representation: local + --Set in doIt, accessed in the compiler - compNoStacking + $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry + $LocalDomainAlist:= nil + $functorForm: local + $functorLocalParameters: local + $CheckVectorList: local + --prevents CheckVector from printing out same message twice + $getDomainCode: local -- code for getting views + $insideFunctorIfTrue: local:= true + $functorsUsed: local --not currently used, finds dependent functors + $setelt: local := + $QuickCode = true => 'QSETREFV + 'SETELT + $TOP__LEVEL: local + $genSDVar: local:= 0 + originale:= $e + [$op,:argl]:= form + $formalArgList:= [:argl,:$formalArgList] + $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] + $mutableDomain: local := + -- all defaulting packages should have caching turned off + isCategoryPackageName $op or + (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) + else false ) --true if domain has mutable state + signature':= + [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] + $functorForm:= $form:= [$op,:argl] + $globalImportStack := + [markKillAll x for x in rest $functorForm for typ in rest signature' + | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] + if null first signature' then signature':= + modemap2Signature getModemap($form,$e) + target:= first signature' + $functorTarget:= target + $e:= giveFormalParametersValues(argl,$e) + [ds,.,$e]:= compMakeCategoryObject(target,$e) or +--+ copy needed since slot1 is reset; compMake.. can return a cached vector + sayBrightly '" cannot produce category object:" + pp target + return nil + $domainShell:= COPY_-SEQ ds + $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") + attributeList := ds.2 --see below under "loadTimeAlist" +--+ 7 lines for $NRT follow + $goGetList: local := nil +-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 + $condAlist: local := nil + $uncondAlist: local := nil +-->>-- next global initialized here, reset by NRTbuildFunctor + $NRTslot1PredicateList: local := + REMDUP [CADR x for x in attributeList] +-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) + $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList + $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor + --this is used below to set $lisplibSlot1 global + $NRTbase: local := 6 -- equals length of $domainShell + $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 + $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts + $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList + $NRTaddList: local := nil --list of fncts not defined in capsule (added) + $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector + $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) + $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... + -- the above optimizes the calls to local domains + $template: local:= nil --stored in the lisplib (if $NRTvec = true) + $functionLocations: local := nil --locations of defined functions in source + -- generate slots for arguments first, then for $NRTaddForm in compAdd + for x in argl repeat NRTgetLocalIndex x + [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) + --The following loop sees if we can economise on ADDed operations + --by using those of Rep, if that is the same. Example: DIRPROD + if $insideCategoryPackageIfTrue^= true then + if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) + and FindRep(cb) = ab + where FindRep cb == + u:= + while cb repeat + ATOM cb => return nil + cb is [['LET,'Rep,v,:.],:.] => return (u:=v) + cb:=CDR cb + u + then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) + else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) + $signature:= signature' + operationAlist:= SUBLIS($pairlis,$domainShell.(1)) + parSignature:= SUBLIS($pairlis,signature') + parForm:= SUBLIS($pairlis,form) + +-- (3.1) now make a list of the functor's local parameters; for +-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); +-- in this case, D is replaced by D1,..,Dn (gensyms) which are set +-- to the A1,..,An view of D + if isPackageFunction() then $functorLocalParameters:= + [nil,: + [nil + for i in 6..MAXINDEX $domainShell | + $domainShell.i is [.,.,['ELT,'_$,.]]]] + --leave space for vector ops and package name to be stored +--+ + $functorLocalParameters:= + argPars := + makeFunctorArgumentParameters(argl,rest signature',first signature') + -- must do above to bring categories into scope --see line 5 of genDomainView + argl +-- 4. compile body in environment of %type declarations for arguments + op':= $op + rettype:= signature'.target + SETQ($myFunctorBody, body) --------> new <-------- + T:= compFunctorBody(body,rettype,$e,parForm) +---------------> new <--------------------- + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) +---------------> new <--------------------- + -- If only compiling certain items, then ignore the body shell. + $compileOnlyCertainItems => + reportOnFunctorCompilation() + [nil, ['Mapping, :signature'], originale] + + body':= T.expr + lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM + fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) + --The above statement stops substitutions gettting in one another's way +--+ + operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) + if $LISPLIB then + augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) + reportOnFunctorCompilation() + +-- 5. give operator a 'modemap property +-- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) + $insideFunctorIfTrue:= false + if $LISPLIB then + $lisplibKind:= + $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package + 'domain + $lisplibForm:= form + modemap:= [[parForm,:parSignature],[true,op']] + $lisplibModemap:= modemap + if null $bootStrapMode then + $NRTslot1Info := NRTmakeSlot1Info() + $isOpPackageName: local := isCategoryPackageName $op + if $isOpPackageName then lisplibWrite('"slot1DataBase", + ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) + $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) + $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) + -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended + libFn := getConstructorAbbreviation op' + $lookupFunction: local := + NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) + --either lookupComplete (for forgetful guys) or lookupIncomplete + $byteAddress :local := 0 + $byteVec :local := nil + $NRTslot1PredicateList := + [simpBool x for x in $NRTslot1PredicateList] + rwriteLispForm('loadTimeStuff, + ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) + $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 + $lisplibOperationAlist:= operationAlist + $lisplibMissingFunctions:= $CheckVectorList + lisplibWrite('"compilerInfo", + ['SETQ,'$CategoryFrame, + ['put,['QUOTE,op'],' + (QUOTE isFunctor), + ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' + QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], + ['put,['QUOTE,op' ],'(QUOTE mode), + ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) + if null argl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) + [fun,['Mapping,:signature'],originale] + +makeFunctorArgumentParameters(argl,sigl,target) == + $alternateViewList: local:= nil + $forceAdd: local:= true + $ConditionalOperators: local + target := markKillAll target + ("append"/[fn(a,augmentSig(s,findExtras(a,target))) + for a in argl for s in sigl]) where + findExtras(a,target) == + -- see if conditional information implies anything else + -- in the signature of a + target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] + target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where + findExtras1(a,x) == + x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['IF,c,p,q] => + union(findExtrasP(a,c), + union(findExtras1(a,p),findExtras1(a,q))) where + findExtrasP(a,x) == + x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] + nil + nil + augmentSig(s,ss) == + -- if we find something extra, add it to the signature + null ss => s + for u in ss repeat + $ConditionalOperators:=[CDR u,:$ConditionalOperators] + s is ['Join,:sl] => + u:=ASSQ('CATEGORY,ss) => + SUBST([:u,:ss],u,s) + ['Join,:sl,['CATEGORY,'package,:ss]] + ['Join,s,['CATEGORY,'package,:ss]] + fn(a,s) == + isCategoryForm(s,$CategoryFrame) => + s is ["Join",:catlist] => genDomainViewList0(a,rest s) + [genDomainView(a,a,s,"getDomainView")] + [a] + +compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == + ['DEF,form,originalSignature,specialCases,body] := df + signature := markKillAll originalSignature + $markFreeStack: local := nil --holds "free variables" + $localImportStack : local := nil --local import stack for function + $localDeclareStack: local := nil + $localLoopVariables: local := nil + originalDef := COPY df + [lineNumber,:specialCases] := specialCases + e := oldE + --1. bind global variables + $form: local + $op: local + $functionStats: local:= [0,0] + $argumentConditionList: local + $finalEnv: local + --used by ReplaceExitEtc to get a common environment + $initCapsuleErrorCount: local:= #$semanticErrorStack + $insideCapsuleFunctionIfTrue: local:= true + $CapsuleModemapFrame: local:= e + $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) + $insideExpressionIfTrue: local:= true + $returnMode:= m + [$op,:argl]:= form + $form:= [$op,:argl] + argl:= stripOffArgumentConditions argl + $formalArgList:= [:argl,:$formalArgList] + + --let target and local signatures help determine modes of arguments + argModeList:= + identSig:= hasSigInTargetCategory(argl,form,first signature,e) => + (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) + [getArgumentModeOrMoan(a,form,e) for a in argl] + argModeList:= stripOffSubdomainConditions(argModeList,argl) + signature':= [first signature,:argModeList] + if null identSig then --make $op a local function + oldE := put($op,'mode,['Mapping,:signature'],oldE) + + --obtain target type if not given + if null first signature' then signature':= + identSig => identSig + getSignature($op,rest signature',e) or return nil + e:= giveFormalParametersValues(argl,e) + + $signatureOfForm:= signature' --this global is bound in compCapsuleItems + $functionLocations := [[[$op,$signatureOfForm],:lineNumber], + :$functionLocations] + e:= addDomain(first signature',e) + e:= compArgumentConditions e + + if $profileCompiler then + for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) + + + --4. introduce needed domains into extendedEnv + for domain in signature' repeat e:= addDomain(domain,e) + + --6. compile body in environment with extended environment + rettype:= resolve(signature'.target,$returnMode) + + localOrExported := + null member($op,$formalArgList) and + getmode($op,e) is ['Mapping,:.] => 'local + 'exported + + --6a skip if compiling only certain items but not this one + -- could be moved closer to the top + formattedSig := formatUnabbreviated ['Mapping,:signature'] + $compileOnlyCertainItems and _ + not member($op, $compileOnlyCertainItems) => + sayBrightly ['" skipping ", localOrExported,:bright $op] + [nil,['Mapping,:signature'],oldE] + sayBrightly ['" compiling ",localOrExported, + :bright $op,'": ",:formattedSig] +---------------------> new <--------------------------------- + returnType := signature'.target +-- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) + trialT := returnType = "$" and comp(body,$EmptyMode,e) + ------------------------------------------------------ 11/1/94 + -- try comp-ing in $EmptyMode; if succeed + -- if we succeed then trialT.mode = "$" or "Rep" + -- do a coerce to get the correct result + T := (trialT and coerce(trialT,returnType)) + -------------------------------------- 11/1/94 + or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) + markChanges(originalDef,T,$signatureOfForm) + [nil,['Mapping,:signature'],oldE] + --------------------------------- + +compCapsuleInner(itemList,m,e) == + e:= addInformation(m,e) + --puts a new 'special' property of $Information + data:= ["PROGN",:itemList] + --RPLACd by compCapsuleItems and Friends + e:= compCapsuleItems(itemList,nil,e) + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + [nil,m,e] --nonsense but that's fine + localParList:= $functorLocalParameters + if $addForm then data:= ['add,$addForm,data] + code:= + $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data + processFunctorOrPackage($form,$signature,data,localParList,m,e) + [MKPF([:$getDomainCode,code],"PROGN"),m,e] + +compSingleCapsuleItem(item,$predl,$e) == + $localImportStack : local := nil + $localDeclareStack: local := nil + $markFreeStack: local := nil + newItem := macroExpandInPlace(item,qe(25,$e)) + qe(26,$e) + doIt(newItem, $predl) + qe(27,$e) + $e + +compImport(["import",:doms],m,e) == + for dom in doms repeat + dom := markKillAll dom + markImport dom + e:=addDomain(dom,e) + ["/throwAway",$NoValueMode,e] + +mkUnion(a,b) == + b="$" and $Rep is ["Union",:l] => b + a is ["Union",:l] => + b is ["Union",:l'] => ["Union",:setUnion(l,l')] + member(b, l) => a + ["Union",:setUnion([b],l)] + b is ["Union",:l] => + member(a, l) => b + ["Union",:setUnion([a],l)] + STRINGP a => ["Union",b,a] + ["Union",a,b] + +compForMode(x,m,e) == + $compForModeIfTrue: local:= true + $convert2NewCompiler: local := nil + comp(x,m,e) + +compMakeCategoryObject(c,$e) == + not isCategoryForm(c,$e) => nil + c := markKillAll c + u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] + nil + +macroExpand(x,e) == --not worked out yet + atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) + x is ['DEF,lhs,sig,spCases,rhs] => + ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), + macroExpand(rhs,e)] + x is ['MI,a,b] => + ['MI,a,macroExpand(b,e)] + macroExpandList(x,e) + +getSuccessEnvironment(a,e) == + -- the next four lines try to ensure that explicit special-case tests + -- prevent implicit ones from being generated + a is ["has",x,m] => + x := unLet x + IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) + e + a is ["is",id,m] => + id := unLet id + IDENTP id and isDomainForm(m,$EmptyEnvironment) => + e:=put(id,"specialCase",m,e) + currentProplist:= getProplist(id,e) + [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs + newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) + addBinding(id,newProplist,e) + e + a is ["case",x,m] and (x := unLet x) and IDENTP x => + put(x,"condition",[a,:get(x,"condition",e)],e) + e + +getInverseEnvironment(a,E) == + atom a => E + [op,:argl]:= a +-- the next five lines try to ensure that explicit special-case tests +-- prevent implicit ones from being generated + op="has" => + [x,m]:= argl + x := unLet x + IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) + E + a is ["case",x,m] and (x := unLet x) and IDENTP x => + --the next two lines are necessary to get 3-branched Unions to work + -- old-style unions, that is + if corrupted? get(x,"condition",E) then systemError 'condition + (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => + put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) + getUnionMode(x,E) is ["Union",:l] or systemError 'Union + if corrupted? l then systemError 'list + l':= delete(m,l) + for u in l' repeat + if u is ['_:,=m,:.] then l':= delete(u,l') + newpred:= MKPF([["case",x,m'] for m' in l'],"OR") + put(x,"condition",[newpred,:get(x,"condition",E)],E) + E + +unLet x == + x is ['LET,u,:.] => unLet u + x + +corrupted? u == + u is [op,:r] => + MEMQ(op,'(WI MI PART)) => true + or/[corrupted? x for x in r] + false + +--====================================================================== +-- From apply.boot +--====================================================================== +applyMapping([op,:argl],m,e,ml) == + #argl^=#ml-1 => nil + isCategoryForm(first ml,e) => + --is op a functor? + pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] + ml' := SUBLIS(pairlis, ml) + argl':= + [T.expr for x in argl for m' in rest ml'] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= [op,:argl'] +---------------------> new <---------------------------- + if constructor? op then form := markKillAll form +---------------------> new <---------------------------- + convert([form,first ml',e],m) + argl':= + [T.expr for x in argl for m' in rest ml] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= + not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => + nprefix := $prefix or + -- following needed for referencing local funs at capsule level + getAbbreviation($op,#rest $form) + [op',:argl',"$"] where + op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + ['call,['applyFun,op],:argl'] + pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] + convert([form,SUBLIS(pairlis,first ml),e],m) + +compFormWithModemap(form,m,e,modemap) == + compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) + +compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == + [op,:argl] := form := markKillExpr form + [[dc,:.],:.] := modemap +----------> new: <----------- + if Rep2Dollar? then + if dc = 'Rep then + modemap := SUBST('Rep,'_$,modemap) + m := SUBST('Rep,'_$,m) + else return nil +----------> new: <----------- + [map:= [.,target,:.],[pred,impl]]:= modemap + -- this fails if the subsuming modemap is conditional + --impl is ['Subsumed,:.] => nil + if isCategoryForm(target,e) and isFunctor op then + [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil + [map:= [.,target,:.],:cexpr]:= modemap + sv:=listOfSharpVars map + if sv then + -- SAY [ "compiling ", op, " in compFormWithModemap, + -- mode= ",map," sharp vars=",sv] + for x in argl for ss in $FormalMapVariableList repeat + if ss in sv then + [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) + -- SAY ["new map is",map] + not (target':= coerceable(target,m,e)) => nil + markMap := map + map:= [target',:rest map] + [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil + + --generate code; return + T:= + e':= + Tl => (LAST Tl).env + e + [x',m',e'] where + m':= SUBLIS(sl,map.(1)) + x':= + form':= [f,:[t.expr for t in Tl]] + m'=$Category or isCategoryForm(m',e) => form' + -- try to deal with new-style Unions where we know the conditions + op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and + (c:=get(z,'condition,e)) and + c is [['case,=z,c1]] and + (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => +-- first is a full tag, as placed by getInverseEnvironment +-- second is what getSuccessEnvironment will place there + ["CDR",z] + markTran(form,form',markMap,e') + qt(18,T) + convert(T,m) + +convert(T,m) == + tcheck T + qe(23,T.env) + coerce(T,resolve(T.mode,m) or return nil) + +compElt(origForm,m,E) == + form := markKillAll origForm + form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) + aDomain="Lisp" => + markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) + isDomainForm(aDomain,E) => + markImport opOf aDomain + E:= addDomain(aDomain,E) + mmList:= getModemapListFromDomain(anOp,0,aDomain,E) + modemap:= + n:=#mmList + 1=n => mmList.(0) + 0=n => + return + stackMessage ['"Operation ","%b",anOp,"%d", + '"missing from domain: ", aDomain] + stackWarning ['"more than 1 modemap for: ",anOp, + '" with dc=",aDomain,'" ===>" + ,mmList] + mmList.(0) +----------> new: <----------- + if aDomain = 'Rep then + modemap := SUBST('Rep,'_$,modemap) + m := SUBST('Rep,'_$,m) +----------> new: <----------- + [sig,[pred,val]]:= modemap + #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? +--+ + val := genDeltaEntry [opOf anOp,:modemap] + x := markTran(origForm,[val],sig,[E]) + [x,first rest sig,E] --implies fn calls used to access constants + compForm(origForm,m,E) + +pause op == op +compApplyModemap(form,modemap,$e,sl) == + [op,:argl] := form --form to be compiled + [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing + + -- $e is the current environment + -- sl substitution list, nil means bottom-up, otherwise top-down + + -- 0. fail immediately if #argl=#margl + + if #argl^=#margl then return nil + + -- 1. use modemap to evaluate arguments, returning failed if + -- not possible + + lt:= + [[.,m',$e]:= + comp(y,g,$e) or return "failed" where + g:= SUBLIS(sl,m) where + sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] + lt="failed" => return nil + + -- 2. coerce each argument to final domain, returning failed + -- if not possible + + lt':= [coerce(y,d) or return "failed" + for y in lt for d in SUBLIS(sl,margl)] + lt'="failed" => return nil + + -- 3. obtain domain-specific function, if possible, and return + + --$bindings is bound by compMapCond + [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil + +--+ can no longer trust what the modemap says for a reference into +--+ an exterior domain (it is calculating the displacement based on view +--+ information which is no longer valid; thus ignore this index and +--+ store the signature instead. + +--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => + f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => + [genDeltaEntry [op,:modemap],lt',$bindings] + markImport mc + [f,lt',$bindings] + +compMapCond''(cexpr,dc) == + cexpr=true => true + --cexpr = "true" => true +---------------> new <---------------------- + cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] + cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] +---------------> new <---------------------- + cexpr is ["not",u] => not compMapCond''(u,dc) + cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) + --for the time being we'll stop here - shouldn't happen so far + --$disregardConditionIfTrue => true + --stackSemanticError(("not known that",'%b,name, + -- '%d,"has",'%b,cat,'%d),nil) + --now it must be an attribute + member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true + --for the time being we'll stop here - shouldn't happen so far + stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] + false + +--====================================================================== +-- From nruncomp.boot +--====================================================================== +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:= item + ----94/11/07 + -- WAS: compOrCroak(item,$EmptyMode,$e).expr + RPLACA(saveNRTdeltaListComp,compEntry) + saveIndex + +optDeltaEntry(op,sig,dc,eltOrConst) == + return nil --------> kill it + $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" => + hehe fn + [op] -----------> return just the op here +-- ['XLAM,'ignore,MKQ SPADCALL fn] + GETL(compileTimeBindingOf first fn,'SPADreplace) + +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) +-- markImport dc + 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:= + dc + RPLACA(saveNRTdeltaListComp,compEntry) + chk(saveNRTdeltaListComp,102) + 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 + +--====================================================================== +-- From nruncomp.boot +--====================================================================== +parseIf t == + t isnt [p,a,b] => t + ifTran(parseTran p,parseTran a,parseTran b) where + ifTran(p,a,b) == + null($InteractiveMode) and p='true => a + null($InteractiveMode) and p='false => b + p is ['not,p'] => ifTran(p',b,a) + p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) + p is ['SEQ,:l,['exit,1,p']] => + ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] + --this assumes that l has no exits + a is ['IF, =p,a',.] => ['IF,p,a',b] + b is ['IF, =p,.,b'] => ['IF,p,a,b'] +-- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => +-- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] + ['IF,p,a,b] + +--====================================================================== +-- From parse.boot +--====================================================================== +parseNot u == ['not,parseTran first u] + +makeSimplePredicateOrNil p == nil + +--====================================================================== +-- From g-cndata.boot +--====================================================================== +mkUserConstructorAbbreviation(c,a,type) == + if $AnalyzeOnly or $convert2NewCompiler then + $abbreviationStack := [[type,a,:c],:$abbreviationStack] + if not atom c then c:= CAR c -- Existing constructors will be wrapped + constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) + clearClams() + clearConstructorCache(c) + installConstructor(c,type) + setAutoLoadProperty(c) + +--====================================================================== +-- From iterator.boot +--====================================================================== + +compreduce(form is [.,op,x],m,e) == + T := compForm(form,m,e) or return nil + y := T.expr + RPLACA(y,"REDUCE") + ------------------<== distinquish this as the special reduce form + (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and + # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) + T + +compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == +-------------------------------> 11/28 all new to preserve collect forms + markImport m + [collectOp,:itl,body]:= collectForm + $e:= e + itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] + itl="failed" => return nil + e:= $e + T0 := comp0(body,m,e) or return nil + md := T0.mode + T1 := compOrCroak(collectForm,["List",md],e) + T := [["REDUCE",op,nil,T1.expr],md,T1.env] + markReduce(form,T) + +compIterator(it,e) == + it is ["IN",x,y] => + --these two lines must be in this order, to get "for f in list f" + --to give an error message if f is undefined + ---------------> new <--------------------- + [y',m,e] := markInValue(y, e) + x := markKillAll x + ------------------ + $formalArgList:= [x,:$formalArgList] + [.,mUnder]:= + modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return + stackMessage ["mode: ",m," must be a list or vector of some mode"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),mUnder,e],e) + markReduceIn(it, [["IN",x,y'],e]) + it is ["ON",x,y] => +---------------> new <--------------------- + x := markKillAll x + ------------------ + $formalArgList:= [x,:$formalArgList] + y := markKillAll y + markImport m +---------------> new <--------------------- + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + [.,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of other modes"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),m,e],e) + [["ON",x,y'],e] + it is ["STEP",oindex,start,inc,:optFinal] => + index := markKillAll oindex + $formalArgList:= [index,:$formalArgList] + --if all start/inc/end compile as small integers, then loop + --is compiled as a small integer loop + final':= nil +---------------> new <--------------------- + u := smallIntegerStep(it,index,start,inc,optFinal,e) => u +---------------> new <--------------------- + [start,.,e]:= + comp(markKillAll start,$Integer,e) or return + stackMessage ["start value of index: ",start," must be an integer"] + [inc,.,e]:= + comp(markKillAll inc,$Integer,e) or return + stackMessage ["index increment:",inc," must be an integer"] + if optFinal is [final] then + [final,.,e]:= + comp(markKillAll final,$Integer,e) or return + stackMessage ["final value of index: ",final," must be an integer"] + optFinal:= [final] + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer +-- markImport ['Segment,indexmode] + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) + it is ["WHILE",p] => + [p',m,e]:= + comp(p,$Boolean,e) or return + stackMessage ["WHILE operand: ",p," is not Boolean valued"] + markReduceWhile(it, [["WHILE",p'],e]) + it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) + it is ["|",x] => + u:= + comp(x,$Boolean,e) or return + stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] + markReduceSuchthat(it, [["|",u.expr],u.env]) + nil + +smallIntegerStep(it,index,start,inc,optFinal,e) == + start := markKillAll start + inc := markKillAll inc + optFinal := markKillAll optFinal + startNum := source2Number start + incNum := source2Number inc + mode := get(index,"mode",e) +--fail if +----> a) index has a mode that is not $SmallInteger +----> b) one of start,inc, final won't comp as a $SmallInteger + mode and mode ^= $SmallInteger => nil + null (start':= comp(start,$SmallInteger,e)) => nil + null (inc':= comp(inc,$SmallInteger,start'.env)) => nil + if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then +-- not (FIXP startNum and FIXP incNum) => return nil +-- null FIXP startNum or ABSVAL startNum > 100 => return nil + -----> assume that optFinal is $SmallInteger + T := comp(final,$EmptyMode,inc'.env) or return nil + final' := T + maxSuperType(T.mode,e) ^= $Integer => return nil + givenRange := T.mode + indexmode:= $SmallInteger + [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, + (final' => final'.env; inc'.env)) or return nil + range := + FIXP startNum and FIXP incNum => + startNum > 0 and incNum > 0 => $PositiveInteger + startNum < 0 and incNum < 0 => $NegativeInteger + incNum > 0 => $NonNegativeInteger --startNum = 0 + $NonPositiveInteger + givenRange => givenRange + nil + e:= put(index,"range",range,e) + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + noptFinal := + final' => + [final'.expr] + nil + [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] + +source2Number n == + n := markKillAll n + n = $Zero => 0 + n = $One => 1 + n + +compRepeatOrCollect(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList + ,e) where + fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == + $until: local + [repeatOrCollect,:itl,body]:= form + itl':= + [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] + itl'="failed" => nil + targetMode:= first $exitModeStack +-- pp '"---------" +-- pp targetMode + bodyMode:= + repeatOrCollect="COLLECT" => + targetMode = '$EmptyMode => '$EmptyMode + (u:=modeIsAggregateOf('List,targetMode,e)) => + CADR u + (u:=modeIsAggregateOf('Vector,targetMode,e)) => + repeatOrCollect:='COLLECTV + CADR u + stackMessage('"Invalid collect bodytype") + return nil + -- If we're doing a collect, and the type isn't conformable + -- then we've boobed. JHD 26.July.1990 + $NoValueMode + [body',m',e']:= T := + -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or + compOrCroak(body,bodyMode,e) or return nil + markRepeatBody(body, T) + if $until then + [untilCode,.,e']:= comp($until,$Boolean,e') + itl':= substitute(["UNTIL",untilCode],'$until,itl') + form':= [repeatOrCollect,:itl',body'] + m'':= + repeatOrCollect="COLLECT" => + (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u + ["List",m'] + repeatOrCollect="COLLECTV" => + (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u + ["Vector",m'] + m' +--------> new <-------------- + markImport m'' +--------> new <-------------- + markRepeat(form,coerceExit([form',m'',e'],targetMode)) + +chaseInferences(origPred,$e) == + pred := markKillAll origPred + ----------------------------12/4/94 do this immediately + foo hasToInfo pred where + foo pred == + knownInfo pred => nil + $e:= actOnInfo(pred,$e) + pred:= infoToHas pred + for u in get("$Information","special",$e) repeat + u is ["COND",:l] => + for [ante,:conseq] in l repeat + ante=pred => [foo w for w in conseq] + ante is ["and",:ante'] and member(pred,ante') => + ante':= delete(pred,ante') + v':= + LENGTH ante'=1 => first ante' + ["and",:ante'] + v':= ["COND",[v',:conseq]] + member(v',get("$Information","special",$e)) => nil + $e:= + put("$Information","special",[v',: + get("$Information","special",$e)],$e) + nil + $e + +--====================================================================== +-- doit Code +--====================================================================== +doIt(item,$predl) == + $GENNO: local:= 0 + $coerceList: local := nil + ---> + if item is ['PART,.,a] then item := a + ------------------------------------- + item is ['SEQ,:.] => doItSeq item + isDomainForm(item,$e) => doItDomain item + item is ['LET,:.] => doItLet item + item is [":",a,t] => [.,.,$e]:= + markDeclaredImport markKillAll t + compOrCroak(item,$EmptyMode,$e) + item is ['import,:doms] => + item := ['import,:(doms := markKillAll doms)] + for dom in doms repeat + sayBrightly ['" importing ",:formatUnabbreviated dom] + [.,.,$e] := compOrCroak(item,$EmptyMode,$e) + wiReplaceNode(item,'(PROGN),10) + item is ["IF",:.] => doItIf(item,$predl,$e) + item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) + item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) + item is ['DEF,:.] => doItDef item + T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) + true => cannotDo() + +holdIt item == item + +doItIf(item is [.,p,x,y],$predl,$e) == + olde:= $e + [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] + oldFLP:=$functorLocalParameters + if x^="noBranch" then +--> new <----------------------- + qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) +---> new ----------- + x':=localExtras(oldFLP) + where localExtras(oldFLP) == + EQ(oldFLP,$functorLocalParameters) => NIL + flp1:=$functorLocalParameters + oldFLP':=oldFLP + n:=0 + while oldFLP' repeat + oldFLP':=CDR oldFLP' + flp1:=CDR flp1 + n:=n+1 + -- Now we have to add code to compile all the elements + -- of functorLocalParameters that were added during the + -- conditional compilation + nils:=ans:=[] + for u in flp1 repeat -- is =u form always an ATOM? + if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) + then + nils:=[u,:nils] + else + gv := GENSYM() + ans:=[['LET,gv,u],:ans] + nils:=[gv,:nils] + n:=n+1 + + $functorLocalParameters:=[:oldFLP,:REVERSE nils] + REVERSE ans + oldFLP:=$functorLocalParameters + if y^="noBranch" then +--> new <----------------------- + qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) +--> ----------- + y':=localExtras(oldFLP) + wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) + +doItSeq item == + ['SEQ,:l,['exit,1,x]] := item + RPLACA(item,"PROGN") + RPLACA(LASTNODE item,x) + for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) + +doItDomain item == + -- convert naked top level domains to import + u:= ['import, [first item,:rest item]] + markImport CADR u + stackWarning ["Use: import ", [first item,:rest item]] +--wiReplaceNode(item, u, 14) + RPLACA(item, first u) + RPLACD(item, rest u) + doIt(item,$predl) + +doItLet item == + qe(3,$e) + res := doItLet1 item + qe(4,$e) + res + +doItLet1 item == + ['LET,lhs,rhs,:.] := item + not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => + stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) + qe(5,$e) + code := markKillAll code + not (code is ['LET,lhs',rhs',:.] and atom lhs') => + code is ["PROGN",:.] => + stackSemanticError(["multiple assignment ",item," not allowed"],nil) + wiReplaceNode(item, code, 24) + lhs:= lhs' + if not member(KAR rhs,$NonMentionableDomainNames) and + not MEMQ(lhs, $functorLocalParameters) then + $functorLocalParameters:= [:$functorLocalParameters,lhs] + if (rhs' := rhsOfLetIsDomainForm code) then + if isFunctor rhs' then + $functorsUsed:= insert(opOf rhs',$functorsUsed) + $packagesUsed:= insert([opOf rhs'],$packagesUsed) + $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] + if lhs="Rep" then + $Representation:= (get("Rep",'value,$e)).(0) + --$Representation bound by compDefineFunctor, used in compNoStacking +--+ + if $NRTopt = true + then NRTgetLocalIndex $Representation +--+ + $LocalDomainAlist:= --see genDeltaEntry + [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] +--+ + qe(6,$e) + code is ['LET,:.] => + rhsCode:= rhs' + op := ($QuickCode => 'QSETREFV;'SETELT) + wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) + wiReplaceNode(item, code, 18) + +rhsOfLetIsDomainForm code == + code is ['LET,.,rhs',:.] => + isDomainForm(rhs',$e) => rhs' + isDomainForm(rhs' := markKillAll rhs',$e) => rhs' + false + false + +doItDef item == + ['DEF,[op,:.],:.] := item + body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) + [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) + chk(item,3) + RPLACA(item,"CodeDefine") + --Note that DescendCode, in CodeDefine, is looking for this + RPLACD(CADR item,[$signatureOfForm]) + chk(item,4) + --This is how the signature is updated for buildFunctor to recognise +--+ + functionPart:= ['dispatchFunction,t.expr] + wiReplaceNode(CDDR item,[functionPart], 20) + chk(item, 30) + +doItExpression(item,T) == + SETQ($ITEM,COPY item) + SETQ($T1,COPY T.expr) + chk(T.expr, 304) + u := markCapsuleExpression(item, T) + [code,.,$e]:= u + wiReplaceNode(item,code, 22) + +wiReplaceNode(node,ocode,key) == + ncode := CONS(first ocode, rest ocode) + code := replaceNodeInStructureBy(node,ncode) + SETQ($NODE,COPY node) + SETQ($NODE1, COPY first code) + SETQ($NODE2, COPY rest code) + RPLACA(node,first code) + RPLACD(node,rest code) + chk(code, key) + chk(node, key + 1) + +replaceNodeInStructureBy(node, x) == + $nodeCopy: local := [CAR node,:CDR node] + replaceNodeBy(node, x) + node + +replaceNodeBy(node, x) == + atom x => nil + for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) + nil + +chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == + cnt > 10000 => + sayBrightly ["--> ", key, " <---"] + hahaha(key) + atom x => cnt + VECP x => systemError nil + for y in x repeat cnt := fn(y, cnt + 1, key) + cnt + diff --git a/src/interp/wi2.boot.pamphlet b/src/interp/wi2.boot.pamphlet deleted file mode 100644 index e4dd5a8a..00000000 --- a/src/interp/wi2.boot.pamphlet +++ /dev/null @@ -1,1255 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/wi2.boot} Pamphlet} -\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. - -@ -<<*>>= -<> - -)package "BOOT" - -compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == - ['DEF,form,signature,$functorSpecialCases,body] := df - signature := markKillAll signature - if NRTPARSE = true then - [lineNumber,:$functorSpecialCases] := $functorSpecialCases --- 1. bind global variables - $addForm: local - $viewNames: local:= nil - - --This list is only used in genDomainViewName, for generating names - --for alternate views, if they do not already exist. - --format: Alist: (domain name . sublist) - --sublist is alist: category . name of view - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $localLoopVariables: local := nil - $pathStack : local := nil - $form: local - $op: local - $signature: local - $functorTarget: local - $Representation: local - --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry - $LocalDomainAlist:= nil - $functorForm: local - $functorLocalParameters: local - $CheckVectorList: local - --prevents CheckVector from printing out same message twice - $getDomainCode: local -- code for getting views - $insideFunctorIfTrue: local:= true - $functorsUsed: local --not currently used, finds dependent functors - $setelt: local := - $QuickCode = true => 'QSETREFV - 'SETELT - $TOP__LEVEL: local - $genSDVar: local:= 0 - originale:= $e - [$op,:argl]:= form - $formalArgList:= [:argl,:$formalArgList] - $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] - $mutableDomain: local := - -- all defaulting packages should have caching turned off - isCategoryPackageName $op or - (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) - else false ) --true if domain has mutable state - signature':= - [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] - $functorForm:= $form:= [$op,:argl] - $globalImportStack := - [markKillAll x for x in rest $functorForm for typ in rest signature' - | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] - if null first signature' then signature':= - modemap2Signature getModemap($form,$e) - target:= first signature' - $functorTarget:= target - $e:= giveFormalParametersValues(argl,$e) - [ds,.,$e]:= compMakeCategoryObject(target,$e) or ---+ copy needed since slot1 is reset; compMake.. can return a cached vector - sayBrightly '" cannot produce category object:" - pp target - return nil - $domainShell:= COPY_-SEQ ds - $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") - attributeList := ds.2 --see below under "loadTimeAlist" ---+ 7 lines for $NRT follow - $goGetList: local := nil --->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 - $condAlist: local := nil - $uncondAlist: local := nil --->>-- next global initialized here, reset by NRTbuildFunctor - $NRTslot1PredicateList: local := - REMDUP [CADR x for x in attributeList] --->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) - $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList - $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor - --this is used below to set $lisplibSlot1 global - $NRTbase: local := 6 -- equals length of $domainShell - $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 - $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts - $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList - $NRTaddList: local := nil --list of fncts not defined in capsule (added) - $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector - $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) - $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... - -- the above optimizes the calls to local domains - $template: local:= nil --stored in the lisplib (if $NRTvec = true) - $functionLocations: local := nil --locations of defined functions in source - -- generate slots for arguments first, then for $NRTaddForm in compAdd - for x in argl repeat NRTgetLocalIndex x - [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) - --The following loop sees if we can economise on ADDed operations - --by using those of Rep, if that is the same. Example: DIRPROD - if $insideCategoryPackageIfTrue^= true then - if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) - and FindRep(cb) = ab - where FindRep cb == - u:= - while cb repeat - ATOM cb => return nil - cb is [['LET,'Rep,v,:.],:.] => return (u:=v) - cb:=CDR cb - u - then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) - else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) - $signature:= signature' - operationAlist:= SUBLIS($pairlis,$domainShell.(1)) - parSignature:= SUBLIS($pairlis,signature') - parForm:= SUBLIS($pairlis,form) - --- (3.1) now make a list of the functor's local parameters; for --- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); --- in this case, D is replaced by D1,..,Dn (gensyms) which are set --- to the A1,..,An view of D - if isPackageFunction() then $functorLocalParameters:= - [nil,: - [nil - for i in 6..MAXINDEX $domainShell | - $domainShell.i is [.,.,['ELT,'_$,.]]]] - --leave space for vector ops and package name to be stored ---+ - $functorLocalParameters:= - argPars := - makeFunctorArgumentParameters(argl,rest signature',first signature') - -- must do above to bring categories into scope --see line 5 of genDomainView - argl --- 4. compile body in environment of %type declarations for arguments - op':= $op - rettype:= signature'.target - SETQ($myFunctorBody, body) --------> new <-------- - T:= compFunctorBody(body,rettype,$e,parForm) ----------------> new <--------------------- - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) ----------------> new <--------------------- - -- If only compiling certain items, then ignore the body shell. - $compileOnlyCertainItems => - reportOnFunctorCompilation() - [nil, ['Mapping, :signature'], originale] - - body':= T.expr - lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM - fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) - --The above statement stops substitutions gettting in one another's way ---+ - operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) - if $LISPLIB then - augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) - reportOnFunctorCompilation() - --- 5. give operator a 'modemap property --- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) - $insideFunctorIfTrue:= false - if $LISPLIB then - $lisplibKind:= - $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package - 'domain - $lisplibForm:= form - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - if null $bootStrapMode then - $NRTslot1Info := NRTmakeSlot1Info() - $isOpPackageName: local := isCategoryPackageName $op - if $isOpPackageName then lisplibWrite('"slot1DataBase", - ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) - $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) - $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) - -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended - libFn := getConstructorAbbreviation op' - $lookupFunction: local := - NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) - --either lookupComplete (for forgetful guys) or lookupIncomplete - $byteAddress :local := 0 - $byteVec :local := nil - $NRTslot1PredicateList := - [simpBool x for x in $NRTslot1PredicateList] - rwriteLispForm('loadTimeStuff, - ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) - $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 - $lisplibOperationAlist:= operationAlist - $lisplibMissingFunctions:= $CheckVectorList - lisplibWrite('"compilerInfo", - ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isFunctor), - ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' - QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], - ['put,['QUOTE,op' ],'(QUOTE mode), - ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) - if null argl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) - [fun,['Mapping,:signature'],originale] - -makeFunctorArgumentParameters(argl,sigl,target) == - $alternateViewList: local:= nil - $forceAdd: local:= true - $ConditionalOperators: local - target := markKillAll target - ("append"/[fn(a,augmentSig(s,findExtras(a,target))) - for a in argl for s in sigl]) where - findExtras(a,target) == - -- see if conditional information implies anything else - -- in the signature of a - target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] - target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where - findExtras1(a,x) == - x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['IF,c,p,q] => - union(findExtrasP(a,c), - union(findExtras1(a,p),findExtras1(a,q))) where - findExtrasP(a,x) == - x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] - nil - nil - augmentSig(s,ss) == - -- if we find something extra, add it to the signature - null ss => s - for u in ss repeat - $ConditionalOperators:=[CDR u,:$ConditionalOperators] - s is ['Join,:sl] => - u:=ASSQ('CATEGORY,ss) => - SUBST([:u,:ss],u,s) - ['Join,:sl,['CATEGORY,'package,:ss]] - ['Join,s,['CATEGORY,'package,:ss]] - fn(a,s) == - isCategoryForm(s,$CategoryFrame) => - s is ["Join",:catlist] => genDomainViewList0(a,rest s) - [genDomainView(a,a,s,"getDomainView")] - [a] - -compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == - ['DEF,form,originalSignature,specialCases,body] := df - signature := markKillAll originalSignature - $markFreeStack: local := nil --holds "free variables" - $localImportStack : local := nil --local import stack for function - $localDeclareStack: local := nil - $localLoopVariables: local := nil - originalDef := COPY df - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local - $op: local - $functionStats: local:= [0,0] - $argumentConditionList: local - $finalEnv: local - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null member($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not member($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] ----------------------> new <--------------------------------- - returnType := signature'.target --- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) - trialT := returnType = "$" and comp(body,$EmptyMode,e) - ------------------------------------------------------ 11/1/94 - -- try comp-ing in $EmptyMode; if succeed - -- if we succeed then trialT.mode = "$" or "Rep" - -- do a coerce to get the correct result - T := (trialT and coerce(trialT,returnType)) - -------------------------------------- 11/1/94 - or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) - markChanges(originalDef,T,$signatureOfForm) - [nil,['Mapping,:signature'],oldE] - --------------------------------- - -compCapsuleInner(itemList,m,e) == - e:= addInformation(m,e) - --puts a new 'special' property of $Information - data:= ["PROGN",:itemList] - --RPLACd by compCapsuleItems and Friends - e:= compCapsuleItems(itemList,nil,e) - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [nil,m,e] --nonsense but that's fine - localParList:= $functorLocalParameters - if $addForm then data:= ['add,$addForm,data] - code:= - $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data - processFunctorOrPackage($form,$signature,data,localParList,m,e) - [MKPF([:$getDomainCode,code],"PROGN"),m,e] - -compSingleCapsuleItem(item,$predl,$e) == - $localImportStack : local := nil - $localDeclareStack: local := nil - $markFreeStack: local := nil - newItem := macroExpandInPlace(item,qe(25,$e)) - qe(26,$e) - doIt(newItem, $predl) - qe(27,$e) - $e - -compImport(["import",:doms],m,e) == - for dom in doms repeat - dom := markKillAll dom - markImport dom - e:=addDomain(dom,e) - ["/throwAway",$NoValueMode,e] - -mkUnion(a,b) == - b="$" and $Rep is ["Union",:l] => b - a is ["Union",:l] => - b is ["Union",:l'] => ["Union",:setUnion(l,l')] - member(b, l) => a - ["Union",:setUnion([b],l)] - b is ["Union",:l] => - member(a, l) => b - ["Union",:setUnion([a],l)] - STRINGP a => ["Union",b,a] - ["Union",a,b] - -compForMode(x,m,e) == - $compForModeIfTrue: local:= true - $convert2NewCompiler: local := nil - comp(x,m,e) - -compMakeCategoryObject(c,$e) == - not isCategoryForm(c,$e) => nil - c := markKillAll c - u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] - nil - -macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) - x is ['DEF,lhs,sig,spCases,rhs] => - ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), - macroExpand(rhs,e)] - x is ['MI,a,b] => - ['MI,a,macroExpand(b,e)] - macroExpandList(x,e) - -getSuccessEnvironment(a,e) == - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e - a is ["is",id,m] => - id := unLet id - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and (x := unLet x) and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - e - -getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E - a is ["case",x,m] and (x := unLet x) and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - if corrupted? get(x,"condition",E) then systemError 'condition - (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => - put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) - getUnionMode(x,E) is ["Union",:l] or systemError 'Union - if corrupted? l then systemError 'list - l':= delete(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':= delete(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",E)],E) - E - -unLet x == - x is ['LET,u,:.] => unLet u - x - -corrupted? u == - u is [op,:r] => - MEMQ(op,'(WI MI PART)) => true - or/[corrupted? x for x in r] - false - ---====================================================================== --- From apply.boot ---====================================================================== -applyMapping([op,:argl],m,e,ml) == - #argl^=#ml-1 => nil - isCategoryForm(first ml,e) => - --is op a functor? - pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] - ml' := SUBLIS(pairlis, ml) - argl':= - [T.expr for x in argl for m' in rest ml'] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= [op,:argl'] ----------------------> new <---------------------------- - if constructor? op then form := markKillAll form ----------------------> new <---------------------------- - convert([form,first ml',e],m) - argl':= - [T.expr for x in argl for m' in rest ml] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= - not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:argl',"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) - ['call,['applyFun,op],:argl'] - pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] - convert([form,SUBLIS(pairlis,first ml),e],m) - -compFormWithModemap(form,m,e,modemap) == - compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) - -compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == - [op,:argl] := form := markKillExpr form - [[dc,:.],:.] := modemap -----------> new: <----------- - if Rep2Dollar? then - if dc = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) - else return nil -----------> new: <----------- - [map:= [.,target,:.],[pred,impl]]:= modemap - -- this fails if the subsuming modemap is conditional - --impl is ['Subsumed,:.] => nil - if isCategoryForm(target,e) and isFunctor op then - [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil - [map:= [.,target,:.],:cexpr]:= modemap - sv:=listOfSharpVars map - if sv then - -- SAY [ "compiling ", op, " in compFormWithModemap, - -- mode= ",map," sharp vars=",sv] - for x in argl for ss in $FormalMapVariableList repeat - if ss in sv then - [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) - -- SAY ["new map is",map] - not (target':= coerceable(target,m,e)) => nil - markMap := map - map:= [target',:rest map] - [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil - - --generate code; return - T:= - e':= - Tl => (LAST Tl).env - e - [x',m',e'] where - m':= SUBLIS(sl,map.(1)) - x':= - form':= [f,:[t.expr for t in Tl]] - m'=$Category or isCategoryForm(m',e) => form' - -- try to deal with new-style Unions where we know the conditions - op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and - (c:=get(z,'condition,e)) and - c is [['case,=z,c1]] and - (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => --- first is a full tag, as placed by getInverseEnvironment --- second is what getSuccessEnvironment will place there - ["CDR",z] - markTran(form,form',markMap,e') - qt(18,T) - convert(T,m) - -convert(T,m) == - tcheck T - qe(23,T.env) - coerce(T,resolve(T.mode,m) or return nil) - -compElt(origForm,m,E) == - form := markKillAll origForm - form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) - aDomain="Lisp" => - markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) - isDomainForm(aDomain,E) => - markImport opOf aDomain - E:= addDomain(aDomain,E) - mmList:= getModemapListFromDomain(anOp,0,aDomain,E) - modemap:= - n:=#mmList - 1=n => mmList.(0) - 0=n => - return - stackMessage ['"Operation ","%b",anOp,"%d", - '"missing from domain: ", aDomain] - stackWarning ['"more than 1 modemap for: ",anOp, - '" with dc=",aDomain,'" ===>" - ,mmList] - mmList.(0) -----------> new: <----------- - if aDomain = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) -----------> new: <----------- - [sig,[pred,val]]:= modemap - #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? ---+ - val := genDeltaEntry [opOf anOp,:modemap] - x := markTran(origForm,[val],sig,[E]) - [x,first rest sig,E] --implies fn calls used to access constants - compForm(origForm,m,E) - -pause op == op -compApplyModemap(form,modemap,$e,sl) == - [op,:argl] := form --form to be compiled - [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing - - -- $e is the current environment - -- sl substitution list, nil means bottom-up, otherwise top-down - - -- 0. fail immediately if #argl=#margl - - if #argl^=#margl then return nil - - -- 1. use modemap to evaluate arguments, returning failed if - -- not possible - - lt:= - [[.,m',$e]:= - comp(y,g,$e) or return "failed" where - g:= SUBLIS(sl,m) where - sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] - lt="failed" => return nil - - -- 2. coerce each argument to final domain, returning failed - -- if not possible - - lt':= [coerce(y,d) or return "failed" - for y in lt for d in SUBLIS(sl,margl)] - lt'="failed" => return nil - - -- 3. obtain domain-specific function, if possible, and return - - --$bindings is bound by compMapCond - [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil - ---+ can no longer trust what the modemap says for a reference into ---+ an exterior domain (it is calculating the displacement based on view ---+ information which is no longer valid; thus ignore this index and ---+ store the signature instead. - ---$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => - f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => - [genDeltaEntry [op,:modemap],lt',$bindings] - markImport mc - [f,lt',$bindings] - -compMapCond''(cexpr,dc) == - cexpr=true => true - --cexpr = "true" => true ----------------> new <---------------------- - cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] - cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] ----------------> new <---------------------- - cexpr is ["not",u] => not compMapCond''(u,dc) - cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) - --for the time being we'll stop here - shouldn't happen so far - --$disregardConditionIfTrue => true - --stackSemanticError(("not known that",'%b,name, - -- '%d,"has",'%b,cat,'%d),nil) - --now it must be an attribute - member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true - --for the time being we'll stop here - shouldn't happen so far - stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] - false - ---====================================================================== --- From nruncomp.boot ---====================================================================== -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:= item - ----94/11/07 - -- WAS: compOrCroak(item,$EmptyMode,$e).expr - RPLACA(saveNRTdeltaListComp,compEntry) - saveIndex - -optDeltaEntry(op,sig,dc,eltOrConst) == - return nil --------> kill it - $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" => - hehe fn - [op] -----------> return just the op here --- ['XLAM,'ignore,MKQ SPADCALL fn] - GETL(compileTimeBindingOf first fn,'SPADreplace) - -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) --- markImport dc - 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:= - dc - RPLACA(saveNRTdeltaListComp,compEntry) - chk(saveNRTdeltaListComp,102) - 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 - ---====================================================================== --- From nruncomp.boot ---====================================================================== -parseIf t == - t isnt [p,a,b] => t - ifTran(parseTran p,parseTran a,parseTran b) where - ifTran(p,a,b) == - null($InteractiveMode) and p='true => a - null($InteractiveMode) and p='false => b - p is ['not,p'] => ifTran(p',b,a) - p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) - p is ['SEQ,:l,['exit,1,p']] => - ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] - --this assumes that l has no exits - a is ['IF, =p,a',.] => ['IF,p,a',b] - b is ['IF, =p,.,b'] => ['IF,p,a,b'] --- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => --- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] - ['IF,p,a,b] - ---====================================================================== --- From parse.boot ---====================================================================== -parseNot u == ['not,parseTran first u] - -makeSimplePredicateOrNil p == nil - ---====================================================================== --- From g-cndata.boot ---====================================================================== -mkUserConstructorAbbreviation(c,a,type) == - if $AnalyzeOnly or $convert2NewCompiler then - $abbreviationStack := [[type,a,:c],:$abbreviationStack] - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - ---====================================================================== --- From iterator.boot ---====================================================================== - -compreduce(form is [.,op,x],m,e) == - T := compForm(form,m,e) or return nil - y := T.expr - RPLACA(y,"REDUCE") - ------------------<== distinquish this as the special reduce form - (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and - # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) - T - -compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == --------------------------------> 11/28 all new to preserve collect forms - markImport m - [collectOp,:itl,body]:= collectForm - $e:= e - itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] - itl="failed" => return nil - e:= $e - T0 := comp0(body,m,e) or return nil - md := T0.mode - T1 := compOrCroak(collectForm,["List",md],e) - T := [["REDUCE",op,nil,T1.expr],md,T1.env] - markReduce(form,T) - -compIterator(it,e) == - it is ["IN",x,y] => - --these two lines must be in this order, to get "for f in list f" - --to give an error message if f is undefined - ---------------> new <--------------------- - [y',m,e] := markInValue(y, e) - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return - stackMessage ["mode: ",m," must be a list or vector of some mode"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),mUnder,e],e) - markReduceIn(it, [["IN",x,y'],e]) - it is ["ON",x,y] => ----------------> new <--------------------- - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - y := markKillAll y - markImport m ----------------> new <--------------------- - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of other modes"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),m,e],e) - [["ON",x,y'],e] - it is ["STEP",oindex,start,inc,:optFinal] => - index := markKillAll oindex - $formalArgList:= [index,:$formalArgList] - --if all start/inc/end compile as small integers, then loop - --is compiled as a small integer loop - final':= nil ----------------> new <--------------------- - u := smallIntegerStep(it,index,start,inc,optFinal,e) => u ----------------> new <--------------------- - [start,.,e]:= - comp(markKillAll start,$Integer,e) or return - stackMessage ["start value of index: ",start," must be an integer"] - [inc,.,e]:= - comp(markKillAll inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(markKillAll final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - optFinal:= [final] - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer --- markImport ['Segment,indexmode] - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) - it is ["WHILE",p] => - [p',m,e]:= - comp(p,$Boolean,e) or return - stackMessage ["WHILE operand: ",p," is not Boolean valued"] - markReduceWhile(it, [["WHILE",p'],e]) - it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - markReduceSuchthat(it, [["|",u.expr],u.env]) - nil - -smallIntegerStep(it,index,start,inc,optFinal,e) == - start := markKillAll start - inc := markKillAll inc - optFinal := markKillAll optFinal - startNum := source2Number start - incNum := source2Number inc - mode := get(index,"mode",e) ---fail if -----> a) index has a mode that is not $SmallInteger -----> b) one of start,inc, final won't comp as a $SmallInteger - mode and mode ^= $SmallInteger => nil - null (start':= comp(start,$SmallInteger,e)) => nil - null (inc':= comp(inc,$SmallInteger,start'.env)) => nil - if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then --- not (FIXP startNum and FIXP incNum) => return nil --- null FIXP startNum or ABSVAL startNum > 100 => return nil - -----> assume that optFinal is $SmallInteger - T := comp(final,$EmptyMode,inc'.env) or return nil - final' := T - maxSuperType(T.mode,e) ^= $Integer => return nil - givenRange := T.mode - indexmode:= $SmallInteger - [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, - (final' => final'.env; inc'.env)) or return nil - range := - FIXP startNum and FIXP incNum => - startNum > 0 and incNum > 0 => $PositiveInteger - startNum < 0 and incNum < 0 => $NegativeInteger - incNum > 0 => $NonNegativeInteger --startNum = 0 - $NonPositiveInteger - givenRange => givenRange - nil - e:= put(index,"range",range,e) - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - noptFinal := - final' => - [final'.expr] - nil - [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] - -source2Number n == - n := markKillAll n - n = $Zero => 0 - n = $One => 1 - n - -compRepeatOrCollect(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList - ,e) where - fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == - $until: local - [repeatOrCollect,:itl,body]:= form - itl':= - [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] - itl'="failed" => nil - targetMode:= first $exitModeStack --- pp '"---------" --- pp targetMode - bodyMode:= - repeatOrCollect="COLLECT" => - targetMode = '$EmptyMode => '$EmptyMode - (u:=modeIsAggregateOf('List,targetMode,e)) => - CADR u - (u:=modeIsAggregateOf('Vector,targetMode,e)) => - repeatOrCollect:='COLLECTV - CADR u - stackMessage('"Invalid collect bodytype") - return nil - -- If we're doing a collect, and the type isn't conformable - -- then we've boobed. JHD 26.July.1990 - $NoValueMode - [body',m',e']:= T := - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - compOrCroak(body,bodyMode,e) or return nil - markRepeatBody(body, T) - if $until then - [untilCode,.,e']:= comp($until,$Boolean,e') - itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] - m'':= - repeatOrCollect="COLLECT" => - (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u - ["List",m'] - repeatOrCollect="COLLECTV" => - (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u - ["Vector",m'] - m' ---------> new <-------------- - markImport m'' ---------> new <-------------- - markRepeat(form,coerceExit([form',m'',e'],targetMode)) - -chaseInferences(origPred,$e) == - pred := markKillAll origPred - ----------------------------12/4/94 do this immediately - foo hasToInfo pred where - foo pred == - knownInfo pred => nil - $e:= actOnInfo(pred,$e) - pred:= infoToHas pred - for u in get("$Information","special",$e) repeat - u is ["COND",:l] => - for [ante,:conseq] in l repeat - ante=pred => [foo w for w in conseq] - ante is ["and",:ante'] and member(pred,ante') => - ante':= delete(pred,ante') - v':= - LENGTH ante'=1 => first ante' - ["and",:ante'] - v':= ["COND",[v',:conseq]] - member(v',get("$Information","special",$e)) => nil - $e:= - put("$Information","special",[v',: - get("$Information","special",$e)],$e) - nil - $e - ---====================================================================== --- doit Code ---====================================================================== -doIt(item,$predl) == - $GENNO: local:= 0 - $coerceList: local := nil - ---> - if item is ['PART,.,a] then item := a - ------------------------------------- - item is ['SEQ,:.] => doItSeq item - isDomainForm(item,$e) => doItDomain item - item is ['LET,:.] => doItLet item - item is [":",a,t] => [.,.,$e]:= - markDeclaredImport markKillAll t - compOrCroak(item,$EmptyMode,$e) - item is ['import,:doms] => - item := ['import,:(doms := markKillAll doms)] - for dom in doms repeat - sayBrightly ['" importing ",:formatUnabbreviated dom] - [.,.,$e] := compOrCroak(item,$EmptyMode,$e) - wiReplaceNode(item,'(PROGN),10) - item is ["IF",:.] => doItIf(item,$predl,$e) - item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) - item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ['DEF,:.] => doItDef item - T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) - true => cannotDo() - -holdIt item == item - -doItIf(item is [.,p,x,y],$predl,$e) == - olde:= $e - [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] - oldFLP:=$functorLocalParameters - if x^="noBranch" then ---> new <----------------------- - qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) ----> new ----------- - x':=localExtras(oldFLP) - where localExtras(oldFLP) == - EQ(oldFLP,$functorLocalParameters) => NIL - flp1:=$functorLocalParameters - oldFLP':=oldFLP - n:=0 - while oldFLP' repeat - oldFLP':=CDR oldFLP' - flp1:=CDR flp1 - n:=n+1 - -- Now we have to add code to compile all the elements - -- of functorLocalParameters that were added during the - -- conditional compilation - nils:=ans:=[] - for u in flp1 repeat -- is =u form always an ATOM? - if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) - then - nils:=[u,:nils] - else - gv := GENSYM() - ans:=[['LET,gv,u],:ans] - nils:=[gv,:nils] - n:=n+1 - - $functorLocalParameters:=[:oldFLP,:REVERSE nils] - REVERSE ans - oldFLP:=$functorLocalParameters - if y^="noBranch" then ---> new <----------------------- - qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) ---> ----------- - y':=localExtras(oldFLP) - wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) - -doItSeq item == - ['SEQ,:l,['exit,1,x]] := item - RPLACA(item,"PROGN") - RPLACA(LASTNODE item,x) - for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - -doItDomain item == - -- convert naked top level domains to import - u:= ['import, [first item,:rest item]] - markImport CADR u - stackWarning ["Use: import ", [first item,:rest item]] ---wiReplaceNode(item, u, 14) - RPLACA(item, first u) - RPLACD(item, rest u) - doIt(item,$predl) - -doItLet item == - qe(3,$e) - res := doItLet1 item - qe(4,$e) - res - -doItLet1 item == - ['LET,lhs,rhs,:.] := item - not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => - stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) - qe(5,$e) - code := markKillAll code - not (code is ['LET,lhs',rhs',:.] and atom lhs') => - code is ["PROGN",:.] => - stackSemanticError(["multiple assignment ",item," not allowed"],nil) - wiReplaceNode(item, code, 24) - lhs:= lhs' - if not member(KAR rhs,$NonMentionableDomainNames) and - not MEMQ(lhs, $functorLocalParameters) then - $functorLocalParameters:= [:$functorLocalParameters,lhs] - if (rhs' := rhsOfLetIsDomainForm code) then - if isFunctor rhs' then - $functorsUsed:= insert(opOf rhs',$functorsUsed) - $packagesUsed:= insert([opOf rhs'],$packagesUsed) - $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] - if lhs="Rep" then - $Representation:= (get("Rep",'value,$e)).(0) - --$Representation bound by compDefineFunctor, used in compNoStacking ---+ - if $NRTopt = true - then NRTgetLocalIndex $Representation ---+ - $LocalDomainAlist:= --see genDeltaEntry - [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] ---+ - qe(6,$e) - code is ['LET,:.] => - rhsCode:= rhs' - op := ($QuickCode => 'QSETREFV;'SETELT) - wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) - wiReplaceNode(item, code, 18) - -rhsOfLetIsDomainForm code == - code is ['LET,.,rhs',:.] => - isDomainForm(rhs',$e) => rhs' - isDomainForm(rhs' := markKillAll rhs',$e) => rhs' - false - false - -doItDef item == - ['DEF,[op,:.],:.] := item - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) - [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) - chk(item,3) - RPLACA(item,"CodeDefine") - --Note that DescendCode, in CodeDefine, is looking for this - RPLACD(CADR item,[$signatureOfForm]) - chk(item,4) - --This is how the signature is updated for buildFunctor to recognise ---+ - functionPart:= ['dispatchFunction,t.expr] - wiReplaceNode(CDDR item,[functionPart], 20) - chk(item, 30) - -doItExpression(item,T) == - SETQ($ITEM,COPY item) - SETQ($T1,COPY T.expr) - chk(T.expr, 304) - u := markCapsuleExpression(item, T) - [code,.,$e]:= u - wiReplaceNode(item,code, 22) - -wiReplaceNode(node,ocode,key) == - ncode := CONS(first ocode, rest ocode) - code := replaceNodeInStructureBy(node,ncode) - SETQ($NODE,COPY node) - SETQ($NODE1, COPY first code) - SETQ($NODE2, COPY rest code) - RPLACA(node,first code) - RPLACD(node,rest code) - chk(code, key) - chk(node, key + 1) - -replaceNodeInStructureBy(node, x) == - $nodeCopy: local := [CAR node,:CDR node] - replaceNodeBy(node, x) - node - -replaceNodeBy(node, x) == - atom x => nil - for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) - nil - -chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == - cnt > 10000 => - sayBrightly ["--> ", key, " <---"] - hahaha(key) - atom x => cnt - VECP x => systemError nil - for y in x repeat cnt := fn(y, cnt + 1, key) - cnt - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/word.boot b/src/interp/word.boot new file mode 100644 index 00000000..95dfc7a1 --- /dev/null +++ b/src/interp/word.boot @@ -0,0 +1,400 @@ +-- 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. + + +--======================================================================= +-- Build Directories +--======================================================================= +buildFunctionTable(dicts) == + sayKeyedMsg("S2GL0011",NIL) + buildWordTable getListOfFunctionNames dicts + +buildWordTable u == + table:= MAKE_-HASHTABLE 'ID + for s in u repeat + key := UPCASE s.0 + HPUT(table,key,[[s,:wordsOfString s],:HGET(table,key)]) + for key in HKEYS table repeat + HPUT(table,key, + listSort(function GLESSEQP,removeDupOrderedAlist + listSort(function GLESSEQP, HGET(table,key),function CAR), + function CADR)) + table + +writeFunctionTables(filemode) == + $functionTable := NIL + writeFunctionTable(filemode,'SPADU,'(SPAD)) + $functionTable := NIL + writeFunctionTable(filemode,'SPADD,'(SPADSYS)) + $functionTable := NIL + writeFunctionTable(filemode,'SPADC,'(SPADSYS SCRATCHPAD_-COMPILER)) + $functionTable := NIL + 'done + +writeFunctionTable(filemode,name,dicts) == + _$ERASE makePathname(name,'DATABASE,filemode) + stream:= writeLib1(name,'DATABASE,filemode) + if not $functionTable then + $functionTable:= buildFunctionTable dicts + for key in HKEYS $functionTable repeat + rwrite(object2Identifier key,HGET($functionTable,key),stream) + RSHUT stream + 'done + +readFunctionTable() == + sayKeyedMsg("S2GL0011",NIL) + name := + $wordDictionary = 'user => 'SPADU + $wordDictionary = 'development => 'SPADD + 'SPADC + stream:= readLib(name,'DATABASE) + table:= MAKE_-HASHTABLE 'ID + for key in RKEYIDS makePathname(name,'DATABASE,"*") repeat + HPUT(table,kk:=object2Identifier key, rread(kk,stream,nil)) + RSHUT stream + table + +removeDupOrderedAlist u == + -- removes duplicate entries in ordered alist + -- (where duplicates are adjacent) + for x in tails u repeat + (y := rest x) and first first x = first first y => RPLACD(x,rest y) + u + +getListOfFunctionNames(fnames) == + -- fnames is a list of directories + res := nil + for fn in fnames repeat + null IOSTATE(fn,'DIRECT,'_*) => 'iterate + stream:= DEFIOSTREAM(['(MODE . INPUT),['FILE,fn,'DIRECT,'_*]],80,0) + while (not PLACEP (x:= READ_-LINE stream)) repeat + (s := SIZE x) < 26 => 'iterate + res:= [SUBSTRING(x,26,NIL),:res] + SHUT stream + res + +wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] + +wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] + +wordsOfString1(s,j) == + k := or/[i for i in j..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => + tailWords:= + isBreakCharacter s.(k+1) => + n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not isBreakCharacter s.i] + null n => [SUBSTRING(s,k,nil)] + n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] + m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => + [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] + [SUBSTRING(s,k,nil)] + k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] + tailWords + nil + +isBreakCharacter x == null SMALL__LITER x + +-- SETANDFILEQ($functionTable,buildFunctionTable()) + +--======================================================================= +-- Augment Function Directories +--======================================================================= +add2WordFunctionTable fn == +--called from DEF + $functionTable and + null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => + HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) + +--======================================================================= +-- Guess Function Name +--======================================================================= +guess word == + u := bootFind word => INTERN u + nil + +bootFind word == + not $useWordFacility => NIL + list:= bootSearch word + PNAME word in list => nil --mismatch of directories: pretend it was not found + null list => centerAndHighlight('"no match found",80,'" ") + 1 = #list => doYouWant? first list + pickANumber(word,list) + +doYouWant? nam == + center80 ['"Do you mean",:bright nam,'"?"] + center80 ['"If so, type",:bright 'y,"or",:bright 'yes] + center80 ['"Anything else means",:bright 'no] + x := UPCASE queryUser nil + MEMQ(STRING2ID_-N(x,1),'(Y YES)) => nam + nil + +pickANumber(word,list) == + clearScreen() + centerNoHighlight(['"You asked for",:bright word],80,'"-") + centerAndHighlight('"Do you mean one of the following?",80,'" ") + n:= #list + xx:= (n > 99 => 3; n > 9 => 2; 1) + maxWidth:= 38 - 2*(1+xx) + [short,long] := say2Split(list,nil,nil,maxWidth) + extra:= + REMAINDER(length := # short,2) ^= 0 => 1 + 0 + halfLength:= length/2 + firstList:= TAKE(halfLength,short) + secondList:= TAKE(-halfLength,short) + secondStartIndex:= halfLength + extra + shortList:= + "append"/[[[:bright i,fillerSpaces(xx-WIDTH i,'" "),x], + [:bright(i+secondStartIndex),fillerSpaces(xx-WIDTH (i+halfLength),'" "),y]] + for i in 1.. for x in firstList for y in secondList] + say2PerLineThatFit shortList + i:= 1 + halfLength + if extra=1 then + sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),list.(i-1)] + for x in long for i in (1+length).. repeat + sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),x] + center80 ['"If so: type a number between",:bright 1,'"and",:bright n,"and ENTER"] + center80 ['"Anything else means",:bright 'no] + y := queryUser nil + x:= string2Integer y + FIXP x and x >= 1 and x <= #list => list.(x-1) + nil + +bootSearch word == +--if not $functionTable then $functionTable:= buildFunctionTable() + if not $functionTable then $functionTable:= readFunctionTable() + key := PNAME word + list := + hasWildCard? key => + pattern := patternTran key -- converts * to & + pattern.0 ^= '_& => + [x for [x,:.] in HGET($functionTable,UPCASE pattern.0)| + match?(pattern,COPY x)] + "append"/[[x for [x,:.] in HGET($functionTable,k)| match?(pattern,COPY x)] + for k in HKEYS $functionTable] + findApproximateWords(PNAME word,$functionTable) + list + +findApproximateWords(word,table) == + words:= wordsOfString word + upperWord:= UPCASE COPY word + n := #words + threshold:= + n = 1 => 3 + 4 + alist:= HGET(table,UPCASE word.0) + + --first try to break up as list of words + firstTry := [x for [x,:wordList] in alist | p] where p == + n = #wordList => + sum := 0 + for entry in wordList for part in words while sum < threshold repeat + sum:= sum + deltaWordEntry(part,entry) + sum < threshold => true + n < 3 => false + sum := 0 + badWord := false + for entry in wordList for part in words while sum < threshold repeat + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => badWord := true + sum := 1000 + sum < threshold + n+1 = #wordList => --assume one word is missing + sum := 0 + badWord := false + for entries in tails wordList for part in words + while sum < threshold repeat + entry := first entries + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => + badWord := true + entries := rest entries --skip this bad word + entry := first entries + k := deltaWordEntry(part,entry) + k < 2 => sum := sum + k + sum := 1000 + sum := 1000 + sum < threshold + n-1 = #wordList => --assume one word too many + sum := 0 + badWord := false + for entry in wordList for parts in tails words + while sum < threshold repeat + part := first parts + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => + badWord := true + parts := rest parts --skip this bad word + part := first parts + k := deltaWordEntry(part,entry) + k < 2 => sum := sum + k + sum := 1000 + sum := 1000 + sum < threshold + false + firstTry => firstTry + + --no winners, so try flattening to upper case and checking again + + wordSize := SIZE word + lastThreshold := MAX(3,wordSize/2) + vec := GETREFV lastThreshold + for [x,:.] in alist repeat + k := deltaWordEntry(upperWord,UPCASE COPY x) + k < lastThreshold => vec.k := [x,:vec.k] + or/[vec.k for k in 0..MAXINDEX vec] + +guessFromList(key,stringList) == + threshold := MAX(3,(SIZE key)/2) + vec := GETREFV threshold + for x in stringList repeat + k := deltaWordEntry(key,x) + k < threshold => vec.k := [x,:vec.k] + or/[vec.k for k in 0..MAXINDEX vec] + +deltaWordEntry(word,entry) == + word = entry => 0 + ABS(diff := SIZE word - SIZE entry) > 4 => 1000 + canForgeWord(word,entry) + +--+ Note these are optimized definitions below-- see commented out versions +--+ to understand the algorithm +canForgeWord(word,entry) == + forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) + +forge(word,w,W,entry,e,E,n) == + w > W => + e > E => n + QSADD1 QSPLUS(E-e,n) + e > E => QSADD1 QSPLUS(W-w,n) + word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) + w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) + word.w=entry.(e+1) => + word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) + forge(word,w+1,W,entry,e+2,E,QSADD1 n) + word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) + + (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => + --if word is long, can we delete chars to match 2 consective chars + deltaW >= deltaE and + (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) + and word.(k+1) = entry.(e+1) => + forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) + deltaW <= deltaE and + --if word is short, can we insert chars so as to match 2 consecutive chars + (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) + and word.(w+1) = entry.(k+1) => + forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + --check for two consecutive matches down the line + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + +--+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm +--+ canForgeWord(word,entry) ==-- +--+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) +--+ --d=deletions, i=insertions, s=substitutions, t=transpositions +--+ --list is formed only for tuning purposes-- remove later on +--+ d + i + s + t + +--+forge(word,w,W,entry,e,E,d,i,s,t) == +--+ w > W => +--+ e > E => [d,i,s,t] +--+ [d,E-e+i+1,s,t] +--+ e > E => [W-w+d+1,i,s,t] +--+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) +--+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ word.w=entry.(e+1) => +--+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) +--+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) +--+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) +--+ +--+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => +--+ --if word is long, can we delete chars to match 2 consective chars +--+ deltaW >= deltaE and +--+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) +--+ and word.(k+1) = entry.(e+1) => +--+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) +--+ deltaW <= deltaE and +--+ --if word is short, can we insert chars so as to match 2 consecutive chars +--+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) +--+ and word.(w+1) = entry.(k+1) => +--+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ --check for two consecutive matches down the line +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) + +--======================================================================= +-- String Pattern Matching +--======================================================================= +patternTran pattern == + null hasWildCard? pattern and LITER pattern.0 and + UPCASE copy pattern = pattern => + name:= abbreviation? INTERN pattern + or browseError [:bright pattern, + '"is not a constructor abbreviation"] + DOWNCASE PNAME name + maskConvert DOWNCASE pattern + +hasWildCard? str == + or/[str.i = '_? and (i=0 or not(str.(i-1) = '__ )) for i in 0..MAXINDEX str] + +maskConvert str == +--replace all ? not preceded by an underscore by & + buf:= GETSTR(#str) + j:= 0 --index into res + final := MAXINDEX str + for i in 0..final repeat + char := str.i + if char = '__ and i < final then + i:= i+1 + char := str.i + else if char = '_? then char := '_& + SUFFIX(char,buf) + buf + + +infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) + +prefix?(s,t) == substring?(s,t,0) + +suffix?(s,t) == + m := #s; n := #t + if m > n then return false + substring?(s,t,(n-m)) + +obSearch x == + vec:= OBARRAY() + pattern:= PNAME x + [y for i in 0..MAXINDEX OBARRAY() | + (IDENTP (y := vec.i) or CVEC y) and match?(pattern,COPY y)] + diff --git a/src/interp/word.boot.pamphlet b/src/interp/word.boot.pamphlet deleted file mode 100644 index ac76dca3..00000000 --- a/src/interp/word.boot.pamphlet +++ /dev/null @@ -1,422 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp word.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. - -@ -<<*>>= -<> - ---======================================================================= --- Build Directories ---======================================================================= -buildFunctionTable(dicts) == - sayKeyedMsg("S2GL0011",NIL) - buildWordTable getListOfFunctionNames dicts - -buildWordTable u == - table:= MAKE_-HASHTABLE 'ID - for s in u repeat - key := UPCASE s.0 - HPUT(table,key,[[s,:wordsOfString s],:HGET(table,key)]) - for key in HKEYS table repeat - HPUT(table,key, - listSort(function GLESSEQP,removeDupOrderedAlist - listSort(function GLESSEQP, HGET(table,key),function CAR), - function CADR)) - table - -writeFunctionTables(filemode) == - $functionTable := NIL - writeFunctionTable(filemode,'SPADU,'(SPAD)) - $functionTable := NIL - writeFunctionTable(filemode,'SPADD,'(SPADSYS)) - $functionTable := NIL - writeFunctionTable(filemode,'SPADC,'(SPADSYS SCRATCHPAD_-COMPILER)) - $functionTable := NIL - 'done - -writeFunctionTable(filemode,name,dicts) == - _$ERASE makePathname(name,'DATABASE,filemode) - stream:= writeLib1(name,'DATABASE,filemode) - if not $functionTable then - $functionTable:= buildFunctionTable dicts - for key in HKEYS $functionTable repeat - rwrite(object2Identifier key,HGET($functionTable,key),stream) - RSHUT stream - 'done - -readFunctionTable() == - sayKeyedMsg("S2GL0011",NIL) - name := - $wordDictionary = 'user => 'SPADU - $wordDictionary = 'development => 'SPADD - 'SPADC - stream:= readLib(name,'DATABASE) - table:= MAKE_-HASHTABLE 'ID - for key in RKEYIDS makePathname(name,'DATABASE,"*") repeat - HPUT(table,kk:=object2Identifier key, rread(kk,stream,nil)) - RSHUT stream - table - -removeDupOrderedAlist u == - -- removes duplicate entries in ordered alist - -- (where duplicates are adjacent) - for x in tails u repeat - (y := rest x) and first first x = first first y => RPLACD(x,rest y) - u - -getListOfFunctionNames(fnames) == - -- fnames is a list of directories - res := nil - for fn in fnames repeat - null IOSTATE(fn,'DIRECT,'_*) => 'iterate - stream:= DEFIOSTREAM(['(MODE . INPUT),['FILE,fn,'DIRECT,'_*]],80,0) - while (not PLACEP (x:= READ_-LINE stream)) repeat - (s := SIZE x) < 26 => 'iterate - res:= [SUBSTRING(x,26,NIL),:res] - SHUT stream - res - -wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] - -wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] - -wordsOfString1(s,j) == - k := or/[i for i in j..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => - tailWords:= - isBreakCharacter s.(k+1) => - n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not isBreakCharacter s.i] - null n => [SUBSTRING(s,k,nil)] - n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] - m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => - [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] - [SUBSTRING(s,k,nil)] - k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] - tailWords - nil - -isBreakCharacter x == null SMALL__LITER x - --- SETANDFILEQ($functionTable,buildFunctionTable()) - ---======================================================================= --- Augment Function Directories ---======================================================================= -add2WordFunctionTable fn == ---called from DEF - $functionTable and - null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => - HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) - ---======================================================================= --- Guess Function Name ---======================================================================= -guess word == - u := bootFind word => INTERN u - nil - -bootFind word == - not $useWordFacility => NIL - list:= bootSearch word - PNAME word in list => nil --mismatch of directories: pretend it was not found - null list => centerAndHighlight('"no match found",80,'" ") - 1 = #list => doYouWant? first list - pickANumber(word,list) - -doYouWant? nam == - center80 ['"Do you mean",:bright nam,'"?"] - center80 ['"If so, type",:bright 'y,"or",:bright 'yes] - center80 ['"Anything else means",:bright 'no] - x := UPCASE queryUser nil - MEMQ(STRING2ID_-N(x,1),'(Y YES)) => nam - nil - -pickANumber(word,list) == - clearScreen() - centerNoHighlight(['"You asked for",:bright word],80,'"-") - centerAndHighlight('"Do you mean one of the following?",80,'" ") - n:= #list - xx:= (n > 99 => 3; n > 9 => 2; 1) - maxWidth:= 38 - 2*(1+xx) - [short,long] := say2Split(list,nil,nil,maxWidth) - extra:= - REMAINDER(length := # short,2) ^= 0 => 1 - 0 - halfLength:= length/2 - firstList:= TAKE(halfLength,short) - secondList:= TAKE(-halfLength,short) - secondStartIndex:= halfLength + extra - shortList:= - "append"/[[[:bright i,fillerSpaces(xx-WIDTH i,'" "),x], - [:bright(i+secondStartIndex),fillerSpaces(xx-WIDTH (i+halfLength),'" "),y]] - for i in 1.. for x in firstList for y in secondList] - say2PerLineThatFit shortList - i:= 1 + halfLength - if extra=1 then - sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),list.(i-1)] - for x in long for i in (1+length).. repeat - sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),x] - center80 ['"If so: type a number between",:bright 1,'"and",:bright n,"and ENTER"] - center80 ['"Anything else means",:bright 'no] - y := queryUser nil - x:= string2Integer y - FIXP x and x >= 1 and x <= #list => list.(x-1) - nil - -bootSearch word == ---if not $functionTable then $functionTable:= buildFunctionTable() - if not $functionTable then $functionTable:= readFunctionTable() - key := PNAME word - list := - hasWildCard? key => - pattern := patternTran key -- converts * to & - pattern.0 ^= '_& => - [x for [x,:.] in HGET($functionTable,UPCASE pattern.0)| - match?(pattern,COPY x)] - "append"/[[x for [x,:.] in HGET($functionTable,k)| match?(pattern,COPY x)] - for k in HKEYS $functionTable] - findApproximateWords(PNAME word,$functionTable) - list - -findApproximateWords(word,table) == - words:= wordsOfString word - upperWord:= UPCASE COPY word - n := #words - threshold:= - n = 1 => 3 - 4 - alist:= HGET(table,UPCASE word.0) - - --first try to break up as list of words - firstTry := [x for [x,:wordList] in alist | p] where p == - n = #wordList => - sum := 0 - for entry in wordList for part in words while sum < threshold repeat - sum:= sum + deltaWordEntry(part,entry) - sum < threshold => true - n < 3 => false - sum := 0 - badWord := false - for entry in wordList for part in words while sum < threshold repeat - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => badWord := true - sum := 1000 - sum < threshold - n+1 = #wordList => --assume one word is missing - sum := 0 - badWord := false - for entries in tails wordList for part in words - while sum < threshold repeat - entry := first entries - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => - badWord := true - entries := rest entries --skip this bad word - entry := first entries - k := deltaWordEntry(part,entry) - k < 2 => sum := sum + k - sum := 1000 - sum := 1000 - sum < threshold - n-1 = #wordList => --assume one word too many - sum := 0 - badWord := false - for entry in wordList for parts in tails words - while sum < threshold repeat - part := first parts - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => - badWord := true - parts := rest parts --skip this bad word - part := first parts - k := deltaWordEntry(part,entry) - k < 2 => sum := sum + k - sum := 1000 - sum := 1000 - sum < threshold - false - firstTry => firstTry - - --no winners, so try flattening to upper case and checking again - - wordSize := SIZE word - lastThreshold := MAX(3,wordSize/2) - vec := GETREFV lastThreshold - for [x,:.] in alist repeat - k := deltaWordEntry(upperWord,UPCASE COPY x) - k < lastThreshold => vec.k := [x,:vec.k] - or/[vec.k for k in 0..MAXINDEX vec] - -guessFromList(key,stringList) == - threshold := MAX(3,(SIZE key)/2) - vec := GETREFV threshold - for x in stringList repeat - k := deltaWordEntry(key,x) - k < threshold => vec.k := [x,:vec.k] - or/[vec.k for k in 0..MAXINDEX vec] - -deltaWordEntry(word,entry) == - word = entry => 0 - ABS(diff := SIZE word - SIZE entry) > 4 => 1000 - canForgeWord(word,entry) - ---+ Note these are optimized definitions below-- see commented out versions ---+ to understand the algorithm -canForgeWord(word,entry) == - forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) - -forge(word,w,W,entry,e,E,n) == - w > W => - e > E => n - QSADD1 QSPLUS(E-e,n) - e > E => QSADD1 QSPLUS(W-w,n) - word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) - w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) - word.w=entry.(e+1) => - word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) - forge(word,w+1,W,entry,e+2,E,QSADD1 n) - word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) - - (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => - --if word is long, can we delete chars to match 2 consective chars - deltaW >= deltaE and - (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) - and word.(k+1) = entry.(e+1) => - forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) - deltaW <= deltaE and - --if word is short, can we insert chars so as to match 2 consecutive chars - (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) - and word.(w+1) = entry.(k+1) => - forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - --check for two consecutive matches down the line - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - ---+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm ---+ canForgeWord(word,entry) ==-- ---+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) ---+ --d=deletions, i=insertions, s=substitutions, t=transpositions ---+ --list is formed only for tuning purposes-- remove later on ---+ d + i + s + t - ---+forge(word,w,W,entry,e,E,d,i,s,t) == ---+ w > W => ---+ e > E => [d,i,s,t] ---+ [d,E-e+i+1,s,t] ---+ e > E => [W-w+d+1,i,s,t] ---+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) ---+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ word.w=entry.(e+1) => ---+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) ---+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) ---+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) ---+ ---+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => ---+ --if word is long, can we delete chars to match 2 consective chars ---+ deltaW >= deltaE and ---+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) ---+ and word.(k+1) = entry.(e+1) => ---+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) ---+ deltaW <= deltaE and ---+ --if word is short, can we insert chars so as to match 2 consecutive chars ---+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) ---+ and word.(w+1) = entry.(k+1) => ---+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ --check for two consecutive matches down the line ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) - ---======================================================================= --- String Pattern Matching ---======================================================================= -patternTran pattern == - null hasWildCard? pattern and LITER pattern.0 and - UPCASE copy pattern = pattern => - name:= abbreviation? INTERN pattern - or browseError [:bright pattern, - '"is not a constructor abbreviation"] - DOWNCASE PNAME name - maskConvert DOWNCASE pattern - -hasWildCard? str == - or/[str.i = '_? and (i=0 or not(str.(i-1) = '__ )) for i in 0..MAXINDEX str] - -maskConvert str == ---replace all ? not preceded by an underscore by & - buf:= GETSTR(#str) - j:= 0 --index into res - final := MAXINDEX str - for i in 0..final repeat - char := str.i - if char = '__ and i < final then - i:= i+1 - char := str.i - else if char = '_? then char := '_& - SUFFIX(char,buf) - buf - - -infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) - -prefix?(s,t) == substring?(s,t,0) - -suffix?(s,t) == - m := #s; n := #t - if m > n then return false - substring?(s,t,(n-m)) - -obSearch x == - vec:= OBARRAY() - pattern:= PNAME x - [y for i in 0..MAXINDEX OBARRAY() | - (IDENTP (y := vec.i) or CVEC y) and match?(pattern,COPY y)] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3