aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/interp/ChangeLog25
-rw-r--r--src/interp/Makefile.in2
-rw-r--r--src/interp/Makefile.pamphlet2
-rw-r--r--src/interp/clammed.boot.pamphlet5
-rw-r--r--src/interp/i-coerce.boot.pamphlet24
-rw-r--r--src/interp/i-eval.boot.pamphlet4
-rw-r--r--src/interp/i-funsel.boot.pamphlet64
-rw-r--r--src/interp/nrunfast.boot.pamphlet35
-rw-r--r--src/interp/nrungo.boot.pamphlet3
-rw-r--r--src/interp/nrunopt.boot.pamphlet18
-rw-r--r--src/interp/sys-globals.boot3
-rw-r--r--src/interp/template.boot4
-rw-r--r--src/interp/xrun.boot498
13 files changed, 106 insertions, 581 deletions
diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog
index a609d474..4dff06ac 100644
--- a/src/interp/ChangeLog
+++ b/src/interp/ChangeLog
@@ -1,3 +1,28 @@
+2007-10-16 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * Makefile.pamphlet (INOBJS): Lose xrun.$(FASLEXT).
+ * clammed.boot.pamphlet (coerceConvertMmSelection): Merge
+ modification in late xrun.boot.
+ * i-coerce.boot.pamphlet (equalOne): Likewise.
+ (equalZero): Likewise.
+ (algEqual): Likewise.
+ (coerceByFunction): Likewise.
+ * i-eval.boot.pamphlet (evalFrom): Likewise.
+ (findFunctionInDomain): Likewise.
+ (findFunctionInDomain1): Likewise.
+ (findFunctionInCategory): Likewise.
+ * nrunfast.boot.pamphlet (replaceGoGetSlot): Likewise.
+ (lazyMatchArg2): Likewise.
+ (newExpandTypeSlot): Likewise.
+ (newExpandLocalTypeForm): Likewise.
+ (newExpandLocalTypeArgs): Likewise.
+ (sigDomainVal): Likewise.
+ * nrungo.boot.pamphlet (lazyCompareSigEqual): Likewise.
+ * nrunopt.boot.pamphlet (NRTmakeCategoryAlist): Likewise.
+ * sys-globals.boot ($noSubsumption): Likewise.
+ * template.boot (evalSlotDomain): Likewise.
+ * xrun.boot: Remove.
+
2007-10-15 Gabriel Dos Reis <gdr@cs.tamu.edu>
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index 68d89f86..b63d4067 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -92,7 +92,7 @@ OBJS= vmlisp.$(FASLEXT) hash.$(FASLEXT) \
interpsys_modules = $(patsubst %.$(FASLEXT), "%", $(OBJS))
INOBJS= varini.$(FASLEXT) \
setvart.$(FASLEXT) intint.$(FASLEXT) \
- xrun.$(FASLEXT) interop.$(FASLEXT) \
+ interop.$(FASLEXT) \
patches.$(FASLEXT)
IN_modules = $(patsubst %.$(FASLEXT), "%", $(INOBJS))
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index 8abc606d..679c8769 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -369,7 +369,7 @@ constants.
<<environment>>=
INOBJS= varini.$(FASLEXT) \
setvart.$(FASLEXT) intint.$(FASLEXT) \
- xrun.$(FASLEXT) interop.$(FASLEXT) \
+ interop.$(FASLEXT) \
patches.$(FASLEXT)
IN_modules = $(patsubst %.$(FASLEXT), "%", $(INOBJS))
diff --git a/src/interp/clammed.boot.pamphlet b/src/interp/clammed.boot.pamphlet
index d0689739..af4ea229 100644
--- a/src/interp/clammed.boot.pamphlet
+++ b/src/interp/clammed.boot.pamphlet
@@ -65,15 +65,14 @@ canCoerce(t1, t2) ==
canCoerce1(t1, newMode) and canCoerce1(newMode, t2)
nil
---------------------> NEW DEFINITION (see interop.boot.pamphlet)
coerceConvertMmSelection(funName,m1,m2) ==
-- calls selectMms with $Coerce=NIL and tests for required
-- target type. funName is either 'coerce or 'convert.
$declaredMode : local:= NIL
$reportBottomUpFlag : local:= NIL
l := selectMms1(funName,m2,[m1],[m1],NIL)
- mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and
- isEqualOrSubDomain(m1, first rest rest sig)]
+ mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and
+ hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1]
mmS and CAR mmS
hasFileProperty(p,id,abbrev) == hasFilePropertyNoCache(p,id,abbrev)
diff --git a/src/interp/i-coerce.boot.pamphlet b/src/interp/i-coerce.boot.pamphlet
index e69d13b2..f7c690a4 100644
--- a/src/interp/i-coerce.boot.pamphlet
+++ b/src/interp/i-coerce.boot.pamphlet
@@ -399,27 +399,22 @@ domainOne(domain) == getConstantFromDomain('(One),domain)
domainZero(domain) == getConstantFromDomain('(Zero),domain)
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
equalOne(object, domain) ==
-- tries using constant One and "=" from domain
-- object should not be wrapped
- eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
- SPADCALL(object,getConstantFromDomain('(One),domain),eqfunc)
+ algEqual(object, getConstantFromDomain('(One),domain), domain)
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
equalZero(object, domain) ==
-- tries using constant Zero and "=" from domain
-- object should not be wrapped
- eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
- SPADCALL(object,getConstantFromDomain('(Zero),domain),eqfunc)
+ algEqual(object, getConstantFromDomain('(Zero),domain), domain)
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
algEqual(object1, object2, domain) ==
-- sees if 2 objects of the same domain are equal by using the
-- "=" from the domain
-- objects should not be wrapped
-- eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
- eqfunc := compiledLookupCheck("=",[$Boolean,domain,domain],evalDomain domain)
+ eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain)
SPADCALL(object1,object2, eqfunc)
--% main algorithms for canCoerceFrom and coerceInteractive
@@ -1389,7 +1384,6 @@ coercionFailure() ==
-- does the throw on coercion failure
THROW('coerceFailure,$coerceFailure)
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
coerceByFunction(T,m2) ==
-- using the new modemap selection without coercions
-- should not be called by canCoerceFrom
@@ -1401,12 +1395,12 @@ coerceByFunction(T,m2) ==
dcVector := evalDomain ud
fun :=
isWrapped x =>
- NRTcompiledLookup("=", [$Boolean, ud, ud], dcVector)
- NRTcompileEvalForm("=", [$Boolean, ud, ud], dcVector)
+ NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector)
+ NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector)
[fn,:d]:= fun
isWrapped x =>
x:= unwrap x
- objNewWrap(SPADCALL(CAR x,CDR x,fun),m2)
+ mkObjWrap(SPADCALL(CAR x,CDR x,fun),m2)
x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL)
code := ['SPADCALL, a, b, fun]
objNew(code,$Boolean)
@@ -1417,12 +1411,14 @@ coerceByFunction(T,m2) ==
[[dc,tar,:args],slot,.]:= mm
dcVector := evalDomain(dc)
fun:=
+--+
isWrapped x =>
- NRTcompiledLookup(funName,[tar,:args],dcVector)
- NRTcompileEvalForm(funName,[tar,:args],dcVector)
+ NRTcompiledLookup(funName,slot,dcVector)
+ NRTcompileEvalForm(funName,slot,dcVector)
[fn,:d]:= fun
fn = function Undef => NIL
isWrapped x =>
+--+
$: fluid := dcVector
val := CATCH('coerceFailure, SPADCALL(unwrap x,fun))
(val = $coerceFailure) => NIL
diff --git a/src/interp/i-eval.boot.pamphlet b/src/interp/i-eval.boot.pamphlet
index 0803bae7..3ec9050b 100644
--- a/src/interp/i-eval.boot.pamphlet
+++ b/src/interp/i-eval.boot.pamphlet
@@ -218,10 +218,8 @@ splitIntoBlocksOf200 a ==
[[first (r:=x) for x in tails a for i in 1..200],
:splitIntoBlocksOf200 rest r]
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
evalForm(op,opName,argl,mmS) ==
-- applies the first applicable function
-
for mm in mmS until form repeat
[sig,fun,cond]:= mm
(CAR sig) = 'interpOnly => form := CAR sig
@@ -256,7 +254,7 @@ evalForm(op,opName,argl,mmS) ==
newType? CAAR mm =>
mm' := first ncSigTransform mm
ncGetFunction(opName, first mm', rest mm')
- NRTcompileEvalForm(opName,rest sig,dcVector)
+ NRTcompileEvalForm(opName,fun,dcVector)
null fun0 => throwKeyedMsg("S2IE0008",[opName])
[bpi,:domain] := fun0
EQ(bpi,function Undef) =>
diff --git a/src/interp/i-funsel.boot.pamphlet b/src/interp/i-funsel.boot.pamphlet
index 6e34e518..bea96021 100644
--- a/src/interp/i-funsel.boot.pamphlet
+++ b/src/interp/i-funsel.boot.pamphlet
@@ -826,25 +826,27 @@ selectMostGeneralMm mmList ==
for genMmArg in CDAR genMm] => genMm := mm
genMm
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
- -- looks for a modemap for op with signature args1 -> tar
+ -- looks for a modemap for op with signature args1 -> tar
-- in the domain of computation dc
-- tar may be NIL (= unknown)
null isLegitimateMode(tar, nil, nil) => nil
dcName:= CAR dc
- member(dcName,'(Union Record Mapping)) =>
+ member(dcName,'(Union Record Mapping Enumeration)) =>
-- First cut code that ignores args2, $Coerce and $SubDom
-- When domains no longer have to have Set, the hard coded 6 and 7
-- should go.
op = '_= =>
- #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL
- tar and tar ^= '(Boolean) => NIL
- [[[dc, '(Boolean), dc, dc], 6, [NIL, NIL]]]
+ #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL
+ tar and tar ^= '(Boolean) => NIL
+ [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]]
op = 'coerce =>
- #args1 ^= 1 or args1.0 ^= dc => NIL
- tar and tar ^= $OutputForm => NIL
- [[[dc, $OutputForm, dc], 7, [NIL, NIL]]]
+ #args1 ^= 1
+ dcName='Enumeration and (args1.0=$Symbol or tar=dc)=>
+ [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]]
+ args1.0 ^= dc => NIL
+ tar and tar ^= $Expression => NIL
+ [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]]
member(dcName,'(Record Union)) =>
findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom)
NIL
@@ -857,24 +859,22 @@ findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
q := NIL
r := NIL
for mm in CDR p repeat
- -- CDAR of mm is the signature argument list
- if isHomogeneousList CDAR mm then q := [mm,:q]
- else r := [mm,:r]
+ -- CDAR of mm is the signature argument list
+ if isHomogeneousList CDAR mm then q := [mm,:q]
+ else r := [mm,:r]
q := allOrMatchingMms(q,args1,tar,dc)
for mm in q repeat
- mm:= subCopy(mm,SL)
- fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
+ fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
r := reverse r
else r := CDR p
r := allOrMatchingMms(r,args1,tar,dc)
if not fun then -- consider remaining modemaps
for mm in r repeat
- mm:= subCopy(mm,SL)
- fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
+ fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
if not fun and $reportBottomUpFlag then
sayMSG concat
['" -> no appropriate",:bright op,'"found in",
- :bright prefix2String dc]
+ :bright prefix2String dc]
fun
allOrMatchingMms(mms,args1,tar,dc) ==
@@ -897,38 +897,41 @@ isHomogeneousList y ==
"and"/[x = z for x in CDR y]
NIL
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
-findFunctionInDomain1(mm,op,tar,args1,args2,SL) ==
+findFunctionInDomain1(omm,op,tar,args1,args2,SL) ==
+ dc:= CDR (dollarPair := ASSQ('$,SL))
+ -- need to drop '$ from SL
+ mm:= subCopy(omm, SL)
-- tests whether modemap mm is appropriate for the function
-- defined by op, target type tar and argument types args
$RTC:local:= NIL
-- $RTC is a list of run-time checks to be performed
- dc:= CDR ASSQ('$,SL)
+
[sig,slot,cond,y] := mm
- if CONTAINED('_#, sig) or CONTAINED('construct, sig) then
+ [osig,:.] := omm
+ osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL))
+ if CONTAINED('_#, sig) or CONTAINED('construct,sig) then
sig := [replaceSharpCalls t for t in sig]
matchMmCond cond and matchMmSig(mm,tar,args1,args2) and
EQ(y,'Subsumed) and
-- hmmmm: do Union check in following because (as in DP)
-- Unions are subsumed by total modemaps which are in the
-- mm list in findFunctionInDomain.
- y := 'ELT -- if subsumed fails try it again
+ y := 'ELT -- if subsumed fails try it again
not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and
- (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f
- EQ(y,'ELT) => [[CONS(dc,sig),slot,nreverse $RTC]]
- EQ(y,'CONST) => [[CONS(dc,sig),slot,nreverse $RTC]]
--- EQ(y,'ASCONST) => [[CONS(dc,sig),slot,nreverse $RTC]]
+ (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f
+ EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]]
+ EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]]
+ EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]]
y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]]
sayKeyedMsg("S2IF0006",[y])
NIL
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
- -- looks for a modemap for op with signature args1 -> tar
+ -- looks for a modemap for op with signature args1 -> tar
-- in the domain of computation dc
-- tar may be NIL (= unknown)
dcName:= CAR dc
- not MEMQ(dcName,'(Record Union)) => NIL
+ not MEMQ(dcName,'(Record Union Enumeration)) => NIL
fun:= NIL
-- cat := constructorCategory dc
makeFunc := GETL(dcName,"makeFunctionList") or
@@ -952,12 +955,11 @@ findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
impls and
SL:= constructSubst dc
for mm in impls repeat
- mm:= subCopy(mm,SL)
fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
if not fun and $reportBottomUpFlag then
sayMSG concat
['" -> no appropriate",:bright op,'"found in",
- :bright prefix2String dc]
+ :bright prefix2String dc]
fun
matchMmCond(cond) ==
diff --git a/src/interp/nrunfast.boot.pamphlet b/src/interp/nrunfast.boot.pamphlet
index e6a29b12..12a6aec4 100644
--- a/src/interp/nrunfast.boot.pamphlet
+++ b/src/interp/nrunfast.boot.pamphlet
@@ -84,7 +84,6 @@ newGoGet(:l) ==
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
@@ -103,7 +102,7 @@ replaceGoGetSlot env ==
if $monitorNewWorld then
sayLooking(concat('"%l","..",form2String thisDomainForm,
'" wants",'"%l",'" "),op,sig,goGetDomain)
- slot := .basicLookup(op,sig,goGetDomain,goGetDomain)
+ slot := basicLookup(op,sig,goGetDomain,goGetDomain)
slot = nil =>
$returnNowhereFromGoGet = true =>
['nowhere,:goGetDomain] --see newGetDomainOpTable
@@ -431,7 +430,6 @@ newCompareSig(sig, numvec, index, dollar, domain) ==
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
@@ -442,11 +440,14 @@ lazyMatchArg2(s,a,dollar,domain,typeFlag) ==
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)
+ KAR s = QCAR d.0 and
+ lazyMatchArgDollarCheck(replaceSharpCalls 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
+ lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style
a = '$ => s = devaluate dollar
+ a = "$$" => s = devaluate domain
STRINGP a =>
+ STRINGP s => a = s
s is ['QUOTE,y] and PNAME y = a
IDENTP s and PNAME s = a
atom a => a = s
@@ -524,49 +525,45 @@ lookupInDomainByName(op,domain,arg) ==
--=======================================================
-- 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)
+ newExpandLocalType(sigDomainVal(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
+ ATOM lazyt => lazyt
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,:[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
+ u = '$ => u
INTEGERP u =>
typeFlag => newExpandTypeSlot(u, dollar,domain)
domain.u
u is ['NRTEVAL,y] => nrtEval(y,domain)
u is ['QUOTE,y] => y
+ u = "$$" => domain.0
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
@@ -576,8 +573,14 @@ domainVal(dollar,domain,index) ==
index = 0 => dollar
index = 2 => domain
domain.index
-
-
+
+-- ??? This function should be merged into the preceding one.
+sigDomainVal(dollar,domain,index) ==
+--returns a domain or a lazy slot
+ index = 0 => "$"
+ index = 2 => domain
+ domain.index
+
--=======================================================
-- Convert Lazy Domain to Domain Form
--=======================================================
diff --git a/src/interp/nrungo.boot.pamphlet b/src/interp/nrungo.boot.pamphlet
index 72a8e153..f0ecf57f 100644
--- a/src/interp/nrungo.boot.pamphlet
+++ b/src/interp/nrungo.boot.pamphlet
@@ -255,9 +255,8 @@ compareSig(sig,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
+ tslot = '$ => s = tslot -- 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 =>
diff --git a/src/interp/nrunopt.boot.pamphlet b/src/interp/nrunopt.boot.pamphlet
index 672131fc..803828da 100644
--- a/src/interp/nrunopt.boot.pamphlet
+++ b/src/interp/nrunopt.boot.pamphlet
@@ -359,32 +359,32 @@ bitsOf n ==
--=======================================================================
-- 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]
+ $catAncestorAlist: local := NIL
+ 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)
+ 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-----------------
+ for x in slot1 repeat
+ RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,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, ['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 ==
+encodeCatform x ==
k := NRTassocIndex x => k
atom x or atom rest x => x
[first x,:[encodeCatform y for y in rest x]]
diff --git a/src/interp/sys-globals.boot b/src/interp/sys-globals.boot
index 072c4ac0..144e13cd 100644
--- a/src/interp/sys-globals.boot
+++ b/src/interp/sys-globals.boot
@@ -397,7 +397,7 @@ $constructorLineNumber := 0
$maxSignatureLineNumber := 0
++
-$noSubsumption := false
+$noSubsumption :=true
SPADERRORSTREAM := _*ERROR_-OUTPUT_*
@@ -408,3 +408,4 @@ _/WSNAME := "NOBOOT"
++
CHR := nil
TOK := nil
+
diff --git a/src/interp/template.boot b/src/interp/template.boot
index 78018e07..d77f8630 100644
--- a/src/interp/template.boot
+++ b/src/interp/template.boot
@@ -89,18 +89,18 @@ stuffSlots(dollar,template) ==
pp item
--------------------> NEW DEFINITION (see interop.boot.pamphlet)
---------------------> NEW DEFINITION (override in xrun.boot.pamphlet)
evalSlotDomain(u,dollar) ==
$returnNowhereFromGoGet: local := false
$ : fluid := dollar
$lookupDefaults : local := nil -- new world
u = '$ => dollar
+ u = "$$" => dollar
FIXP u =>
VECP (y := dollar.u) => y
y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous?
y is [v,:.] =>
VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt]
- GETDATABASE(v,'CONSTRUCTOR?) =>
+ constructor? v or MEMQ(v,'(Record Union Mapping)) =>
lazyDomainSet(y,dollar,u) --new style has lazyt
y
y
diff --git a/src/interp/xrun.boot b/src/interp/xrun.boot
deleted file mode 100644
index 925d1c16..00000000
--- a/src/interp/xrun.boot
+++ /dev/null
@@ -1,498 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007, 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.
-
-
-)package "BOOT"
-
-$noSubsumption:=true
---$MERGELIB := nil
-------- from nrunopt.boot -----------
-
---------------------> NEW DEFINITION (see nrunopt.boot.pamphlet)
-NRTmakeCategoryAlist() ==
- $depthAssocCache: local := MAKE_-HASHTABLE 'ID
- $catAncestorAlist: local := NIL
- 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(CONS("$$",sixEtc),CONS('$,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 (see nrunopt.boot.pamphlet)
-encodeCatform x ==
- k := NRTassocIndex x => k
- atom x or atom rest x => x
- [first x,:[encodeCatform y for y in rest x]]
-
-------- from nrunfast.boot -----------
-
---------------------> NEW DEFINITION (see nrunfast.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
-
---=======================================================
--- Expand Signature from Encoded Slot Form
---=======================================================
---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet)
-newExpandGoGetTypeSlot(slot,dollar,domain) ==
- newExpandTypeSlot(slot,domain,domain)
-
---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet)
-newExpandTypeSlot(slot, dollar, domain) ==
---> returns domain form for dollar.slot
- newExpandLocalType(sigDomainVal(dollar, domain, slot), dollar,domain)
-
-
---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet)
-newExpandLocalType(lazyt,dollar,domain) ==
- VECP lazyt => lazyt.0
- ATOM lazyt => lazyt
- lazyt is [vec,.,:lazyForm] and VECP vec => --old style
- newExpandLocalTypeForm(lazyForm,dollar,domain)
- newExpandLocalTypeForm(lazyt,dollar,domain) --new style
-
---------------------> NEW DEFINITION (see nrunfast.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 (see nrunfast.boot.pamphlet)
-newExpandLocalTypeArgs(u,dollar,domain,typeFlag) ==
- u = '$ => u
- INTEGERP u =>
- typeFlag => newExpandTypeSlot(u, dollar,domain)
- domain.u
- u is ['NRTEVAL,y] => nrtEval(y,domain)
- u is ['QUOTE,y] => y
- u = "$$" => domain.0
- atom u => u --can be first, rest, etc.
- newExpandLocalTypeForm(u,dollar,domain)
-
---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet)
-nrtEval(expr,dom) ==
- $:fluid := dom
- eval expr
-
-sigDomainVal(dollar,domain,index) ==
---returns a domain or a lazy slot
- index = 0 => "$"
- index = 2 => domain
- domain.index
-
---------------------> NEW DEFINITION (see nrunfast.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(replaceSharpCalls s,d.0,dollar.0,domainArg)
- --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase)
- lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style
- a = '$ => s = devaluate dollar
- a = "$$" => s = devaluate domain
- STRINGP a =>
- STRINGP s => a = s
- 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
-
-------- from template.boot -----------
-
---------------------> NEW DEFINITION (see template.boot.pamphlet)
-evalSlotDomain(u,dollar) ==
- $returnNowhereFromGoGet: local := false
- $ : fluid := dollar
- $lookupDefaults : local := nil -- new world
- u = '$ => dollar
- u = "$$" => dollar
- FIXP u =>
- VECP (y := dollar.u) => y
- y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous?
- y is [v,:.] =>
- VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt]
- constructor? v or MEMQ(v,'(Record Union Mapping)) =>
- lazyDomainSet(y,dollar,u) --new style has lazyt
- y
- y
- u is ['NRTEVAL,y] => eval y
- u is ['QUOTE,y] => y
- u is ['Record,:argl] =>
- FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)]
- for [.,tag,dom] in argl])
- u is ['Union,:argl] and first argl is ['_:,.,.] =>
- APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)]
- for [.,tag,dom] in argl])
- u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl])
- systemErrorHere '"evalSlotDomain"
-
-
-------- from nrungo.boot -----------
-
---------------------> NEW DEFINITION (see nrungo.boot.pamphlet)
-lazyCompareSigEqual(s,tslot,dollar,domain) ==
- tslot = '$ => s = tslot -- 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)
-
-------- from i-funsel.boot -----------
-
---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet)
-findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
- -- looks for a modemap for op with signature args1 -> tar
- -- in the domain of computation dc
- -- tar may be NIL (= unknown)
- null isLegitimateMode(tar, nil, nil) => nil
- dcName:= CAR dc
- member(dcName,'(Union Record Mapping Enumeration)) =>
- -- First cut code that ignores args2, $Coerce and $SubDom
- -- When domains no longer have to have Set, the hard coded 6 and 7
- -- should go.
- op = '_= =>
- #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL
- tar and tar ^= '(Boolean) => NIL
- [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]]
- op = 'coerce =>
- #args1 ^= 1
- dcName='Enumeration and (args1.0=$Symbol or tar=dc)=>
- [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]]
- args1.0 ^= dc => NIL
- tar and tar ^= $Expression => NIL
- [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]]
- member(dcName,'(Record Union)) =>
- findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom)
- NIL
- fun:= NIL
- ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and
- SL := constructSubst dc
- -- if the arglist is homogeneous, first look for homogeneous
- -- functions. If we don't find any, look at remaining ones
- if isHomogeneousList args1 then
- q := NIL
- r := NIL
- for mm in CDR p repeat
- -- CDAR of mm is the signature argument list
- if isHomogeneousList CDAR mm then q := [mm,:q]
- else r := [mm,:r]
- q := allOrMatchingMms(q,args1,tar,dc)
- for mm in q repeat
- fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
- r := reverse r
- else r := CDR p
- r := allOrMatchingMms(r,args1,tar,dc)
- if not fun then -- consider remaining modemaps
- for mm in r repeat
- fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
- if not fun and $reportBottomUpFlag then
- sayMSG concat
- ['" -> no appropriate",:bright op,'"found in",
- :bright prefix2String dc]
- fun
-
---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet)
-findFunctionInDomain1(omm,op,tar,args1,args2,SL) ==
- dc:= CDR (dollarPair := ASSQ('$,SL))
- -- need to drop '$ from SL
- mm:= subCopy(omm, SL)
- -- tests whether modemap mm is appropriate for the function
- -- defined by op, target type tar and argument types args
- $RTC:local:= NIL
- -- $RTC is a list of run-time checks to be performed
-
- [sig,slot,cond,y] := mm
- [osig,:.] := omm
- osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL))
- if CONTAINED('_#, sig) or CONTAINED('construct,sig) then
- sig := [replaceSharpCalls t for t in sig]
- matchMmCond cond and matchMmSig(mm,tar,args1,args2) and
- EQ(y,'Subsumed) and
- -- hmmmm: do Union check in following because (as in DP)
- -- Unions are subsumed by total modemaps which are in the
- -- mm list in findFunctionInDomain.
- y := 'ELT -- if subsumed fails try it again
- not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and
- (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f
- EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]]
- EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]]
- EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]]
- y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]]
- sayKeyedMsg("S2IF0006",[y])
- NIL
-
---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet)
-findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
- -- looks for a modemap for op with signature args1 -> tar
- -- in the domain of computation dc
- -- tar may be NIL (= unknown)
- dcName:= CAR dc
- not MEMQ(dcName,'(Record Union Enumeration)) => NIL
- fun:= NIL
- -- cat := constructorCategory dc
- makeFunc := GETL(dcName,"makeFunctionList") or
- systemErrorHere '"findFunctionInCategory"
- [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame)
- -- get list of implementations and remove sharps
- maxargs := -1
- impls := nil
- for [a,b,d] in funlist repeat
- not EQ(a,op) => nil
- d is ['XLAM,xargs,:.] =>
- if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs)
- else maxargs := MAX(maxargs,1)
- impls := cons([b,nil,true,d],impls)
- impls := cons([b,d,true,d],impls)
- impls := NREVERSE impls
- if maxargs ^= -1 then
- SL:= NIL
- for i in 1..maxargs repeat
- impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls)
- impls and
- SL:= constructSubst dc
- for mm in impls repeat
- fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL))
- if not fun and $reportBottomUpFlag then
- sayMSG concat
- ['" -> no appropriate",:bright op,'"found in",
- :bright prefix2String dc]
- fun
-
-------- from i-eval.boot -----------
-
---------------------> NEW DEFINITION (see i-eval.boot.pamphlet)
-evalForm(op,opName,argl,mmS) ==
- -- applies the first applicable function
- for mm in mmS until form repeat
- [sig,fun,cond]:= mm
- (CAR sig) = 'interpOnly => form := CAR sig
- #argl ^= #CDDR sig => 'skip ---> RDJ 6/95
- form:=
- $genValue or null cond =>
- [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL
- for x in argl for t in CDDR sig]
- [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL
- for x in argl for t in CDDR sig for c in cond]
- form or null argl =>
- dc:= CAR sig
- form :=
- dc='local => --[fun,:form]
- atom fun =>
- fun in $localVars => ['SPADCALL,:form,fun]
- [fun,:form,NIL]
- ['SPADCALL,:form,fun]
- dc is ["__FreeFunction__",:freeFun] =>
- ['SPADCALL,:form,freeFun]
- fun is ['XLAM,xargs,:xbody] =>
- rec := first form
- xbody is [['RECORDELT,.,ind,len]] =>
- optRECORDELT([CAAR xbody,rec,ind,len])
- xbody is [['SETRECORDELT,.,ind,len,.]] =>
- optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form])
- xbody is [['RECORDCOPY,.,len]] =>
- optRECORDCOPY([CAAR xbody,rec,len])
- ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)]
- dcVector := evalDomain dc
- fun0 :=
- newType? CAAR mm =>
- mm' := first ncSigTransform mm
- ncGetFunction(opName, first mm', rest mm')
- NRTcompileEvalForm(opName,fun,dcVector)
- null fun0 => throwKeyedMsg("S2IE0008",[opName])
- [bpi,:domain] := fun0
- EQ(bpi,function Undef) =>
- sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig])
- NIL
- if $NRTmonitorIfTrue = true then
- sayBrightlyNT ['"Applying ",first fun0,'" to:"]
- pp [devaluateDeeply x for x in form]
- _$:fluid := domain
- ['SPADCALL, :form, fun0]
- not form => nil
--- not form => throwKeyedMsg("S2IE0008",[opName])
- form='interpOnly => rewriteMap(op,opName,argl)
- targetType := CADR sig
- if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType
- evalFormMkValue(op,form,targetType)
-
-------- from clammed.boot -----------
-
---------------------> NEW DEFINITION (see interop.boot.pamphlet)
-coerceConvertMmSelection(funName,m1,m2) ==
- -- calls selectMms with $Coerce=NIL and tests for required
- -- target type. funName is either 'coerce or 'convert.
- $declaredMode : local:= NIL
- $reportBottomUpFlag : local:= NIL
- l := selectMms1(funName,m2,[m1],[m1],NIL)
- mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and
- hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1]
- mmS and CAR mmS
-
-------- from i-coerce.boot -----------
-
---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet)
-coerceByFunction(T,m2) ==
- -- using the new modemap selection without coercions
- -- should not be called by canCoerceFrom
- x := objVal T
- x = '_$fromCoerceable_$ => NIL
- m2 is ['Union,:.] => NIL
- m1 := objMode T
- m2 is ['Boolean,:.] and m1 is ['Equation,ud] =>
- dcVector := evalDomain ud
- fun :=
- isWrapped x =>
- NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector)
- NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector)
- [fn,:d]:= fun
- isWrapped x =>
- x:= unwrap x
- mkObjWrap(SPADCALL(CAR x,CDR x,fun),m2)
- x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL)
- code := ['SPADCALL, a, b, fun]
- objNew(code,$Boolean)
- -- If more than one function is found, any should suffice, I think -scm
- if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then
- mm := coerceConvertMmSelection(funName := 'convert,m1,m2)
- mm =>
- [[dc,tar,:args],slot,.]:= mm
- dcVector := evalDomain(dc)
- fun:=
---+
- isWrapped x =>
- NRTcompiledLookup(funName,slot,dcVector)
- NRTcompileEvalForm(funName,slot,dcVector)
- [fn,:d]:= fun
- fn = function Undef => NIL
- isWrapped x =>
---+
- $: fluid := dcVector
- val := CATCH('coerceFailure, SPADCALL(unwrap x,fun))
- (val = $coerceFailure) => NIL
- objNewWrap(val,m2)
- env := fun
- code := ['failCheck, ['SPADCALL, x, env]]
--- tar is ['Union,:.] => objNew(['failCheck,code],m2)
- objNew(code,m2)
- -- try going back to types like RN instead of QF I
- m1' := eqType m1
- m2' := eqType m2
- (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2')
- NIL
-
---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet)
-equalOne(object, domain) ==
- -- tries using constant One and "=" from domain
- -- object should not be wrapped
- algEqual(object, getConstantFromDomain('(One),domain), domain)
-
---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet)
-equalZero(object, domain) ==
- -- tries using constant Zero and "=" from domain
- -- object should not be wrapped
- algEqual(object, getConstantFromDomain('(Zero),domain), domain)
-
---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet)
-algEqual(object1, object2, domain) ==
- -- sees if 2 objects of the same domain are equal by using the
- -- "=" from the domain
- -- objects should not be wrapped
--- eqfunc := getFunctionFromDomain("=",domain,[domain,domain])
- eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain)
- SPADCALL(object1,object2, eqfunc)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-08 17:06:44 +0000