diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 5 | ||||
| -rw-r--r-- | src/interp/Makefile.in | 4 | ||||
| -rw-r--r-- | src/interp/buildom.boot | 228 | ||||
| -rw-r--r-- | src/interp/functor.boot | 2 | ||||
| -rw-r--r-- | src/interp/i-map.boot | 1 | ||||
| -rw-r--r-- | src/interp/i-special.boot | 25 | ||||
| -rw-r--r-- | src/interp/nrunfast.boot | 27 | ||||
| -rw-r--r-- | src/interp/nrungo.boot | 324 |
8 files changed, 289 insertions, 327 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 5e1421e5..f18f74f7 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,10 @@ 2011-03-02 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/nrungo.boot: Move content to buildom.boot, i-map.boot, + i-special.boot, nrunfast.boot. Delete. + +2011-03-02 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/i-eval.boot (mkEvalable): Exit early on niladic constructors. * interp/define.boot (compDefineFunctor1): If bootstrapping, mark functor as incomplete. diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index d5594734..a4b5f730 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -105,7 +105,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \ msgdb.$(FASLEXT) \ newaux.$(FASLEXT) newfort.$(FASLEXT) \ nrunfast.$(FASLEXT) \ - nrungo.$(FASLEXT) nrunopt.$(FASLEXT) \ + nrunopt.$(FASLEXT) \ osyscmd.$(FASLEXT) \ packtran.$(FASLEXT) \ pf2sex.$(FASLEXT) \ @@ -357,7 +357,7 @@ define.$(FASLEXT): g-error.$(FASLEXT) modemap.$(FASLEXT) \ nruncomp.$(FASLEXT) database.$(FASLEXT) database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) \ cattable.$(FASLEXT) compat.$(FASLEXT) g-cndata.$(FASLEXT) -functor.$(FASLEXT): category.$(FASLEXT) nrungo.$(FASLEXT) lisplib.$(FASLEXT) +functor.$(FASLEXT): category.$(FASLEXT) interop.$(FASLEXT) lisplib.$(FASLEXT) category.$(FASLEXT): g-util.$(FASLEXT) g-cndata.$(FASLEXT) cattable.$(FASLEXT): simpbool.$(FASLEXT) g-util.$(FASLEXT) compat.$(FASLEXT): pathname.$(FASLEXT) diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot index 7fd36e0f..d8ab5e6c 100644 --- a/src/interp/buildom.boot +++ b/src/interp/buildom.boot @@ -60,6 +60,234 @@ $commonCategoryDefaults == $FirstParamSlot == 6 +--% 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 + +--======================================================= +-- 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 + +--======================================================= +-- 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) + +--======================================================= +-- 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") + +--======================================================= +-- Lookup Addlist (from lookupInDomainTable or lookupInDomain) +--======================================================= +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 + +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) + +--======================================================= +-- Lookup Function in Slot 1 (via SPADCALL) +--======================================================= +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 + --% Record -- Want to eventually have the elts and setelts. -- Record is a macro in BUILDOM LISP. It takes out the colons. diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 5393aefe..cc6e9611 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -33,7 +33,7 @@ import lisplib -import nrungo +import interop import category namespace BOOT diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot index 4448342c..c373eaf9 100644 --- a/src/interp/i-map.boot +++ b/src/interp/i-map.boot @@ -41,6 +41,7 @@ $mapTarget := nil $mapReturnTypes := nil $mapName := 'noMapName $mapThrowCount := 0 -- times a "return" occurs in map +$insideCompileBodyIfTrue := false --% Generating internal names for functions diff --git a/src/interp/i-special.boot b/src/interp/i-special.boot index 3f2b3f50..03238888 100644 --- a/src/interp/i-special.boot +++ b/src/interp/i-special.boot @@ -2083,6 +2083,31 @@ uppretend t == --% Handlers for REDUCE +-----------------------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 + getReduceFunction(op,type,result, locale) == -- return the function cell for operation with the signature -- (type,type) -> type, possible from locale diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index a51288f8..834c6365 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -244,6 +244,33 @@ newLookupInTable(op,sig,dollar,[domain,opvec],flag) == --======================================================= +-- 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 + +--======================================================= -- Lookup Addlist (from lookupInDomainTable or lookupInDomain) --======================================================= newLookupInAddChain(op,sig,addFormDomain,dollar) == 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 |