aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog5
-rw-r--r--src/interp/Makefile.in4
-rw-r--r--src/interp/buildom.boot228
-rw-r--r--src/interp/functor.boot2
-rw-r--r--src/interp/i-map.boot1
-rw-r--r--src/interp/i-special.boot25
-rw-r--r--src/interp/nrunfast.boot27
-rw-r--r--src/interp/nrungo.boot324
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