diff options
author | dos-reis <gdr@axiomatics.org> | 2011-03-03 03:55:33 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2011-03-03 03:55:33 +0000 |
commit | a2b34de25042ce40dbd1f56ba5524beb72ffef75 (patch) | |
tree | 89ce8c805e97fe244b934720a39c411b78681e05 /src/interp/nrungo.boot | |
parent | bc50325269c6765b78b8a7f8df0baf96d6dff4e8 (diff) | |
download | open-axiom-a2b34de25042ce40dbd1f56ba5524beb72ffef75.tar.gz |
* interp/nrungo.boot: Move content to buildom.boot, i-map.boot,
i-special.boot, nrunfast.boot. Delete.
Diffstat (limited to 'src/interp/nrungo.boot')
-rw-r--r-- | src/interp/nrungo.boot | 324 |
1 files changed, 0 insertions, 324 deletions
diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot deleted file mode 100644 index e459c30c..00000000 --- a/src/interp/nrungo.boot +++ /dev/null @@ -1,324 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. --- All rights reserved. --- Copyright (C) 2007-2011, Gabriel Dos Reis. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical Algorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import c_-util -import clam -import interop - -namespace BOOT - -++ -$insideCompileBodyIfTrue := false - ---% Monitoring functions - -lookupDisplay(op,sig,vectorOrForm,suffix) == - not $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 - ---======================================================= --- Lookup From Interpreter ---======================================================= - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -compiledLookup(op,sig,dollar) == ---called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, --- getFunctionFromDomain, optDeltaEntry, retractByFunction - if not vector? dollar then dollar := evalDomain dollar - -- "^" is an alternate name for "**" in OpenAxiom libraries. - -- ??? When, we get to support Aldor libraries and the equivalence - -- ??? does not hold, we may want to do the reverse lookup too. - -- ??? See compiledLookupCheck below. - if op = "^" then op := "**" - basicLookup(op,sig,dollar,dollar) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -basicLookup(op,sig,domain,dollar) == - item := domain.1 - cons? item and first item in '(lookupInDomain lookupInTable) => - lookupInDomainVector(op,sig,domain,dollar) - ----------new world code follows------------ - u := lookupInDomainAndDefaults(op,sig,domain,dollar,false) => u - lookupInDomainAndDefaults(op,sig,domain,dollar,true) - -compiledLookupCheck(op,sig,dollar) == - fn := compiledLookup(op,sig,dollar) - - -- NEW COMPILER COMPATIBILITY ON - 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 := code quo 8192 - code1 := code rem 8192 - if QSODDP code1 then isConstant := true - code2 := code1 quo 2 - if QSODDP code2 then explicitLookupDomainIfTrue := true - index := code2 quo 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 cons? lookupDomain then lookupDomain := evalDomain lookupDomain - dollar := -- what matches $ in signatures - explicitLookupDomainIfTrue => lookupDomain - thisDomain - if cons? dollar then dollar := evalDomain dollar - fn:= basicLookup(op,sig,lookupDomain,dollar) - fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0]) - val:= apply(first fn,[:arglist,rest fn]) - vectorRef(thisDomain,index) := fn - val - -NRTreplaceLocalTypes(t,dom) == - atom t => - not integer? t => t - t:= dom.t - if cons? t then t:= evalDomain t - t.0 - first t in '(Mapping Union Record _:) => - [first 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]) == - table = "derived" => lookupInAddChain(op,sig,domain,dollar) - success := false - someMatch := false - while not success for [sig1,:code] in LASSQ(op,table) repeat - success := - not compareSig(sig,sig1,dollar.0,domain) => false - code is ['subsumed,a] => - subsumptionSig := - EQSUBSTLIST(rest(domain.0),$FormalMapVariableList,a) - someMatch:=true - false - predIndex := code quo 8192 - predIndex ~= 0 and not lookupPred($predVector.predIndex,dollar,domain) - => false - loc := (code rem 8192) quo 2 - loc = 0 => - someMatch := true - nil - slot := domain.loc - slot is ["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 vector? dom => false - not (#dom > 0) => false - not (dom.0 is [packageName,:.]) => false - not IDENTP packageName => false - isDefaultPackageName packageName - ---======================================================= --- Lookup In Domain (from lookupInAddChain) ---======================================================= -lookupInDomain(op,sig,addFormDomain,dollar,index) == - addFormCell := addFormDomain.index => - integer? KAR addFormCell => - or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] - if not vector? 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) - - -++ same as lookupInDomainVector except that the use of defaults -++ (either in category packages or add-chains) is controlled -++ by `useDefaults'. -lookupInDomainAndDefaults(op,sig,domain,dollar,useDefaults) == - savedLookupDefaults := $lookupDefaults - $lookupDefaults := useDefaults - fun := lookupInDomainVector(op,sig,domain,dollar) - $lookupDefaults := savedLookupDefaults - fun - ---======================================================= --- Category Default Lookup (from goGet or lookupInAddChain) ---======================================================= -lookupInCategories(op,sig,dom,dollar) == - catformList := dom.4.0 - varList := ["$",:$FormalMapVariableList] - nsig := MSUBST(dom.0,dollar.0,sig) - -- the following lines don't need to check for predicates because - -- this code (the old runtime scheme) is used only for - -- builtin constructors -- their predicates are always true. - r := or/[lookupInDomainVector(op,nsig, - eval EQSUBSTLIST(valueList,varList,catform),dollar) - for catform in catformList | not null catform] where - valueList() == - [MKQ dom,:[MKQ dom.(5+i) for i in 1..(#rest catform)]] - r or lookupDisplay(op,sig,'"category defaults",'"-- not found") - ---======================================================= --- Predicates ---======================================================= -lookupPred(pred,dollar,domain) == - pred = true => true - pred is [op,:pl] and op in '(AND and %and) => - and/[lookupPred(p,dollar,domain) for p in pl] - pred is [op,:pl] and op in '(OR or %or) => - or/[lookupPred(p,dollar,domain) for p in pl] - pred is [op,p] and op in '(NOT not %not) => not lookupPred(p,dollar,domain) - pred is ['is,dom1,dom2] => domainEqual(dom1,dom2) - pred is ["has",a,b] => - vector? a => - keyedSystemError("S2GE0016",['"lookupPred", - '"vector as first argument to has"]) - a := eval mkEvalable substDollarArgs(dollar,domain,a) - b := substDollarArgs(dollar,domain,b) - HasCategory(a,b) - keyedSystemError("S2NR0002",[pred]) - -substDollarArgs(dollar,domain,object) == - form := devaluate domain - SUBLISLIS([devaluate dollar,:rest form], - ["$",:$FormalMapVariableList],object) - -compareSig(sig,tableSig,dollar,domain) == - not (#sig = #tableSig) => false - null (target := first sig) - or lazyCompareSigEqual(target,first tableSig,dollar,domain) => - and/[lazyCompareSigEqual(s,t,dollar,domain) - for s in rest sig for t in rest tableSig] - -lazyCompareSigEqual(s,tslot,dollar,domain) == - tslot = '$ => s = "$" or s = devaluate dollar - integer? tslot and cons?(lazyt:=domain.tslot) and cons? s => - lazyt is [.,.,.,[.,item,.]] and - item is [.,[functorName,:.]] and functorName = first s => - compareSigEqual(s,(evalDomain lazyt).0,dollar,domain) - nil - compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) - - -compareSigEqual(s,t,dollar,domain) == - s = t => true - atom t => - u := - t='$ => dollar - isSharpVar t => - vector? domain => rest(domain.0).(POSN1(t,$FormalMapVariableList)) - rest(domain).(POSN1(t,$FormalMapVariableList)) - string? t and IDENTP s => (s := symbolName s; t) - nil - s = '$ => compareSigEqual(dollar,u,dollar,domain) - u => compareSigEqual(s,u,dollar,domain) - s = u - 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 - first t = '_# => # second t - [first t,:[NRTtypeHack tt for tt in rest 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] - s |