aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/c-util.boot10
-rw-r--r--src/interp/compiler.boot131
-rw-r--r--src/interp/functor.boot8
-rw-r--r--src/interp/g-opt.boot1
-rw-r--r--src/interp/macros.lisp3
-rw-r--r--src/interp/modemap.boot2
-rw-r--r--src/interp/nruncomp.boot5
-rw-r--r--src/interp/parse.boot9
-rw-r--r--src/interp/sys-constants.boot4
-rw-r--r--src/interp/wi1.boot11
-rw-r--r--src/interp/wi2.boot5
11 files changed, 98 insertions, 91 deletions
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index 1c7dec58..c7274eb8 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -684,16 +684,6 @@ printSignature(before,op,[target,:argSigList]) ==
printAny target
TERPRI()
-pmatch(s,p) == pmatchWithSl(s,p,"ok")
-
-pmatchWithSl(s,p,al) ==
- s=$EmptyMode => nil
- s=p => al
- v:= assoc(p,al) => s=rest v or al
- MEMQ(p,$PatternVariableList) => [[p,:s],:al]
- null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and
- pmatchWithSl(rest s,rest p,al')
-
elapsedTime() ==
currentTime:= TEMPUS_-FUGIT()
elapsedSeconds:= (currentTime-$previousTime)*QUOTIENT(1.0,$timerTicksPerSecond)
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 7c5a764d..f59babe7 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -610,17 +610,15 @@ compFormWithModemap(form,m,e,modemap) ==
if ss in sv then
[map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap)
-- SAY ["new map is",map]
- not (target':= coerceable(target,m,e)) => nil
- map:= [target',:rest map]
- [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil
+ not coerceable(target,m,e) => nil
+ [f,Tl]:= compApplyModemap(form,modemap,e) or return nil
--generate code; return
T:=
- [x',m',e'] where
- m':= SUBLIS(sl,map.(1))
+ [x',target,e'] where
x':=
form':= [f,:[t.expr for t in Tl]]
- m'=$Category or isCategoryForm(m',e) => form'
+ target=$Category or isCategoryForm(target,e) => form'
-- try to deal with new-style Unions where we know the conditions
op = "elt" and f is ['XLAM,:.] and IDENTP(z := first argl) and
(c:=get(z,'condition,e)) and
@@ -1282,16 +1280,33 @@ compImport(["import",:doms],m,e) ==
--% meaning, or may need special handling because or short-circuiting
--% etc.
-++ compile a logical negation form `(not ...)'.
-compNot: (%Form,%Mode,%Env) -> %Maybe %Triple
-compNot(x,m,e) ==
+++ Compile a logical negation form `(not ...)'.
+compLogicalNot: (%Form,%Mode,%Env) -> %Maybe %Triple
+compLogicalNot(x,m,e) ==
x isnt ["not", y] => nil
-- ??? For the time being compiler values cannot handle operations
-- ??? selected through general modemaps, and their semantics
-- ??? are quite hardwired with their syntax.
-- ??? Eventually, we should not need to do this.
$normalizeTree => compIf(["IF",y,"false","true"],m,e)
- compForm(x,m,e)
+ yT := comp(y,$EmptyMode,e) or return nil
+ yT.mode = $Boolean =>
+ e := getInverseEnvironment(y,yT.env)
+ convert([["NOT",yT.expr],$Boolean,e],m)
+ compResolveCall("not",[yT],m,yT.env)
+
+
+++ Compile an exclusive `xor' expression.
+compExclusiveOr: (%Form,%Mode,%Env) -> %Maybe %Triple
+compExclusiveOr(x,m,e) ==
+ x isnt ["xor",a,b] => nil
+ aT := comp(a,$EmptyMode,e) or return nil
+ e :=
+ aT.mode = $Boolean => getSuccessEnvironment(a,aT.env)
+ aT.env
+ bT := comp(b,$EmptyMode,e) or return nil
+ compResolveCall("xor",[aT,bT],m,bT.env)
+
--% Case
compCase: (%Form,%Mode,%Env) -> %Maybe %Triple
@@ -1430,9 +1445,7 @@ tryCourtesyCoercion(T,m) ==
coerce(T,m) ==
T' := tryCourtesyCoercion(T,m) => T'
- -- if from from coerceable, this coerce was just a trial coercion
- -- from compFormWithModemap to filter through the modemaps
- T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil
+ isSomeDomainVariable m => nil
stackMessage('"Cannot coerce %1b of mode %2pb to mode %3pb",
[T.expr,T.mode,m])
@@ -1509,9 +1522,7 @@ belongsTo?(m,cat,e) ==
coerceable(m,m',e) ==
m=m' => m
- -- must find any free parameters in m
- sl:= pmatch(m',m) => SUBLIS(sl,m')
- coerce(["$fromCoerceable$",m,e],m') => m'
+ tryCourtesyCoercion(["$fromCoerceable$",m,e],m') => m'
nil
coerceExit: (%Triple,%Mode) -> %Maybe %Triple
@@ -1660,61 +1671,55 @@ compCat(form is [functorName,:argl],m,e) ==
--% APPLY MODEMAPS
-compApplyModemap(form,modemap,$e,sl) ==
+++ `op' has been selected as a viable candidate exported operation,
+++ for argument triple list `argTl', modemap `mm'.
+++ Return the most refined implementation that makes the call successful.
+compViableModemap(op,argTl,mm) ==
+ [[dc,.,:margl],fnsel] := mm
+ -- 1. Give up if the call is hopeless.
+ argTl := [coerce(x,m) or return "failed" for x in argTl for m in margl]
+ argTl = "failed" => nil
+
+ -- 2. obtain domain-specific function, if possible
+ f := compMapCond(dc,fnsel) or return nil
+
+ -- 3. Mark `f' as used.
+ -- We can no longer trust what the modemap says for a reference into
+ -- an exterior domain (it is calculating the displacement based on view
+ -- information which is no longer valid; thus ignore this index and
+ -- store the signature instead.
+ f is [op1,.,.] and MEMQ(op1,'(ELT CONST Subsumed)) =>
+ [genDeltaEntry [op,:mm],argTl]
+ [f,argTl]
+
+compApplyModemap(form,modemap,$e) ==
[op,:argl] := form --form to be compiled
- [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing
+ [[mc,mr,:margl],fnsel] := modemap --modemap we are testing
-- $e is the current environment
- -- sl substitution list, nil means bottom-up, otherwise top-down
-- 0. fail immediately if #argl=#margl
-
if #argl^=#margl then return nil
-- 1. use modemap to evaluate arguments, returning failed if
-- not possible
-
lt:=
- [[.,m',$e]:=
- comp(y,g,$e) or return "failed" where
- g:= SUBLIS(sl,m) where
- sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl]
+ [[.,.,$e]:= comp(y,m,$e) or return "failed"
+ for y in argl for m in margl]
lt="failed" => return nil
- -- 2. coerce each argument to final domain, returning failed
- -- if not possible
-
- lt':= [coerce(y,d) or return "failed"
- for y in lt for d in SUBLIS(sl,margl)]
- lt'="failed" => return nil
+ -- 2. Select viable modemap implementation.
+ compViableModemap(op,lt,modemap)
- -- 3. obtain domain-specific function, if possible, and return
-
- --$bindings is bound by compMapCond
- [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil
-
---+ can no longer trust what the modemap says for a reference into
---+ an exterior domain (it is calculating the displacement based on view
---+ information which is no longer valid; thus ignore this index and
---+ store the signature instead.
-
- f is [op1,d,.] and MEMQ(op1,'(ELT CONST Subsumed)) =>
- [genDeltaEntry [op,:modemap],lt',$bindings]
- [f,lt',$bindings]
-
-compMapCond(op,mc,$bindings,fnsel) ==
- or/[compMapCond'(u,op,mc,$bindings) for u in fnsel]
-
-compMapCond'([cexpr,fnexpr],op,dc,bindings) ==
- compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings)
+compMapCond(dc,[cexpr,fnexpr]) ==
+ compMapCond'(cexpr,dc) => fnexpr
stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
-compMapCond''(cexpr,dc) ==
+compMapCond'(cexpr,dc) ==
cexpr=true => true
- --cexpr = "true" => true
- cexpr is ["AND",:l] => and/[compMapCond''(u,dc) for u in l]
- cexpr is ["OR",:l] => or/[compMapCond''(u,dc) for u in l]
- cexpr is ["not",u] => not compMapCond''(u,dc)
+ cexpr is ["AND",:l] => and/[compMapCond'(u,dc) for u in l]
+ cexpr is ["OR",:l] => or/[compMapCond'(u,dc) for u in l]
+ cexpr is ["not",u] => not compMapCond'(u,dc)
cexpr is ["has",name,cat] => (knownInfo cexpr => true; false)
--for the time being we'll stop here - shouldn't happen so far
--$disregardConditionIfTrue => true
@@ -1726,9 +1731,18 @@ compMapCond''(cexpr,dc) ==
stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
false
-compMapCondFun(fnexpr,op,dc,bindings) ==
- [fnexpr,bindings]
+--%
+
+compResolveCall(op,argTs,m,$e) ==
+ outcomes :=
+ [t for mm in getModemapList(op,#argTs,$e) | t := tryMM] where
+ tryMM() ==
+ not coerceable(mm.mmTarget,m,$e) =>nil
+ compViableModemap(op,argTs,mm) isnt [f,Ts] => nil
+ coerce([["call",f,:[T.expr for T in Ts]],mm.mmTarget,$e],m)
+ #outcomes ^= 1 => nil
+ first outcomes
--% %Match
@@ -1927,13 +1941,14 @@ for x in [["|", :"compSuchthat"],_
["exit", :"compExit"],_
["has", :"compHas"],_
["IF", : "compIf"],_
+ ["xor",: "compExclusiveOr"],_
["import", :"compImport"],_
["is", :"compIs"],_
["Join", :"compJoin"],_
["leave", :"compLeave"],_
["%LET", :"compSetq"],_
["MDEF", :"compMacro"],_
- ["not", :"compNot"],_
+ ["not", :"compLogicalNot"],_
["pretend", :"compPretend"],_
["Record", :"compCat"],_
["RecordCategory", :"compConstructorCategory"],_
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index e31d5399..595d5a6e 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -565,10 +565,10 @@ DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) ==
j:=j-1
j > i+2 =>
for k in i..j repeat copyvec.k:=delete([name,:count+k-i],copyvec.k)
- code:=[['REPLACE, name, instantiatedBase,
- INTERN('"START1",'"KEYWORD"), count,
- INTERN('"START2",'"KEYWORD"), i,
- INTERN('"END2",'"KEYWORD"), j+1],:code]
+ code:=[["REPLACE", name, instantiatedBase,
+ KEYWORD::START1, count,
+ KEYWORD::START2, i,
+ KEYWORD::END2, j+1],:code]
copyvec.i =>
v:=["getShellEntry",instantiatedBase,i]
for u in copyvec.i repeat
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 30e253f2..5b07aad2 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -176,6 +176,7 @@ optCallSpecially(q,x,n,R) ==
nil
optCallEval u ==
+ u is ["Boolean"] => Boolean()
u is ["List",:.] => List Integer()
u is ["Vector",:.] => Vector Integer()
u is ["PrimitiveArray",:.] => PrimitiveArray Integer()
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index edb0b652..809c5c1e 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -184,9 +184,6 @@
(defmacro TL (&rest L) `(tail . ,L))
-
-(defmacro SPADCONST (&rest L) (cons 'qrefelt L))
-
(DEFUN LASTELEM (X) (car (last X)))
(defun LISTOFATOMS (X)
diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot
index fce0fb46..d836c3ed 100644
--- a/src/interp/modemap.boot
+++ b/src/interp/modemap.boot
@@ -80,7 +80,7 @@ domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList]
getModemap(x is [op,:.],e) ==
for modemap in get(op,'modemap,e) repeat
- if u:= compApplyModemap(x,modemap,e,nil) then return
+ if u:= compApplyModemap(x,modemap,e) then return
([.,.,sl]:= u; SUBLIS(sl,modemap))
getUniqueSignature(form,e) ==
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index a5f356f0..dcb5ecbe 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -775,11 +775,6 @@ NRTputInHead bod ==
bod is ["QUOTE",:.] => bod
bod is ["CLOSEDFN",:.] => bod
bod is ["SPADCONST",dom,ind] =>
- RPLACA(bod,$elt)
- dom = '_$ => nil
- k:= NRTassocIndex dom =>
- RPLACA(LASTNODE bod,[$elt,'_$,k])
- bod
keyedSystemError("S2GE0016",['"NRTputInHead",
'"unexpected SPADCONST form"])
NRTputInHead first bod
diff --git a/src/interp/parse.boot b/src/interp/parse.boot
index 2e5febe1..3dacec05 100644
--- a/src/interp/parse.boot
+++ b/src/interp/parse.boot
@@ -285,12 +285,6 @@ parseOr t ==
parseIf ["IF",y,parseOr ["or",:rest u],"true"]
parseIf ["IF",x,"true",parseOr ["or",:rest u]]
-parseExclusiveOr: %ParseForm -> %Form
-parseExclusiveOr t ==
- t isnt ["xor",a,b] => systemErrorHere "parseExclusiveOr"
- parseIf ["IF",a,parseIf ["IF",b,:'(false true)],b]
-
-
parseExit: %ParseForm -> %Form
parseExit t ==
t isnt ["exit",a,:b] => systemErrorHere "parseExit"
@@ -504,6 +498,5 @@ for x in [["<=", :"parseLessEqual"],_
["SEGMENT", :"parseSegment"],_
["SEQ", :"parseSeq"],_
["VCONS", :"parseVCONS"],_
- ["where", :"parseWhere"],_
- ["xor", :"parseExclusiveOr"]] repeat
+ ["where", :"parseWhere"]] repeat
MAKEPROP(first x, "parseTran", rest x)
diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot
index f4468e15..74d7f3bf 100644
--- a/src/interp/sys-constants.boot
+++ b/src/interp/sys-constants.boot
@@ -304,6 +304,10 @@ $BasicPredicates ==
++ FIXME: Check that the names on this list are not renamed.
$SideEffectFreeFunctionList ==
'(_null _
+ _not _
+ _and _
+ _or _
+ _xor _
_case _
Zero _
One _
diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot
index f149f1b2..201a8a71 100644
--- a/src/interp/wi1.boot
+++ b/src/interp/wi1.boot
@@ -83,6 +83,17 @@ addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
--Previous line should save some space
[[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist]
+
+pmatch(s,p) == pmatchWithSl(s,p,"ok")
+
+pmatchWithSl(s,p,al) ==
+ s=$EmptyMode => nil
+ s=p => al
+ v:= assoc(p,al) => s=rest v or al
+ MEMQ(p,$PatternVariableList) => [[p,:s],:al]
+ null atom p and null atom s and (al':= pmatchWithSl(first s,first p,al)) and
+ pmatchWithSl(rest s,rest p,al')
+
--======================================================================
-- From define.boot
--======================================================================
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index 85969666..46075fdb 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -542,7 +542,7 @@ compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) ==
not (target':= coerceable(target,m,e)) => nil
markMap := map
map:= [target',:rest map]
- [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil
+ [f,Tl,sl]:= compApplyModemap(form,modemap,e) or return nil
--generate code; return
T:=
@@ -605,7 +605,8 @@ compElt(origForm,m,E) ==
compForm(origForm,m,E)
pause op == op
-compApplyModemap(form,modemap,$e,sl) ==
+compApplyModemap(form,modemap,$e) ==
+ sl := nil
[op,:argl] := form --form to be compiled
[[mc,mr,:margl],:fnsel] := modemap --modemap we are testing
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 06:42:44 +0000