diff options
Diffstat (limited to 'src/interp/nrungo.boot.pamphlet')
| -rw-r--r-- | src/interp/nrungo.boot.pamphlet | 417 |
1 files changed, 417 insertions, 0 deletions
diff --git a/src/interp/nrungo.boot.pamphlet b/src/interp/nrungo.boot.pamphlet new file mode 100644 index 00000000..72a8e153 --- /dev/null +++ b/src/interp/nrungo.boot.pamphlet @@ -0,0 +1,417 @@ +\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} +<<license>>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<<license>> + +--======================================================= +-- 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} |