aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/ChangeLog5
-rw-r--r--src/interp/Makefile.in3
-rw-r--r--src/interp/Makefile.pamphlet3
-rw-r--r--src/interp/apply.boot270
-rw-r--r--src/interp/compiler.boot301
5 files changed, 277 insertions, 305 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index e28e5c9a..02b9f1e0 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,10 @@
2008-08-07 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/apply.boot: Move content to compiler.boot. Remove.
+ * interp/Makefile.pamphlet (OCOBJS): Remove apply.$(OBJEXT).
+
+2008-08-07 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* lisp/core.lisp.in (boot-completed-p): New.
(|$useDynamicLink|): Likewise.
(|$effectiveFaslType|): Hold extension of linkable FASL.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index ba30803f..6d561733 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -102,7 +102,7 @@ OCOBJS= \
info.$(FASLEXT) modemap.$(FASLEXT) \
category.$(FASLEXT) define.$(FASLEXT) \
iterator.$(FASLEXT) compiler.$(FASLEXT) \
- apply.$(FASLEXT) c-doc.$(FASLEXT) \
+ c-doc.$(FASLEXT) \
profile.$(FASLEXT) functor.$(FASLEXT) \
nruncomp.$(FASLEXT) package.$(FASLEXT) \
htcheck.$(FASLEXT)
@@ -330,7 +330,6 @@ setvart.$(FASLEXT): macros.$(FASLEXT)
## OpenAxiom's compiler
wi2.$(FASLEXT): macros.$(FASLEXT) define.$(FASLEXT)
wi1.$(FASLEXT): macros.$(FASLEXT)
-apply.$(FASLEXT): compiler.$(FASLEXT)
compiler.$(FASLEXT): c-util.$(FASLEXT) modemap.$(FASLEXT) \
pathname.$(FASLEXT) define.$(FASLEXT) iterator.$(FASLEXT)
nrunopt.$(FASLEXT): c-util.$(FASLEXT)
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet
index f7aa8afe..a9ab12ce 100644
--- a/src/interp/Makefile.pamphlet
+++ b/src/interp/Makefile.pamphlet
@@ -220,7 +220,7 @@ OCOBJS= \
info.$(FASLEXT) modemap.$(FASLEXT) \
category.$(FASLEXT) define.$(FASLEXT) \
iterator.$(FASLEXT) compiler.$(FASLEXT) \
- apply.$(FASLEXT) c-doc.$(FASLEXT) \
+ c-doc.$(FASLEXT) \
profile.$(FASLEXT) functor.$(FASLEXT) \
nruncomp.$(FASLEXT) package.$(FASLEXT) \
htcheck.$(FASLEXT)
@@ -618,7 +618,6 @@ setvart.$(FASLEXT): macros.$(FASLEXT)
## OpenAxiom's compiler
wi2.$(FASLEXT): macros.$(FASLEXT) define.$(FASLEXT)
wi1.$(FASLEXT): macros.$(FASLEXT)
-apply.$(FASLEXT): compiler.$(FASLEXT)
compiler.$(FASLEXT): c-util.$(FASLEXT) modemap.$(FASLEXT) \
pathname.$(FASLEXT) define.$(FASLEXT) iterator.$(FASLEXT)
nrunopt.$(FASLEXT): c-util.$(FASLEXT)
diff --git a/src/interp/apply.boot b/src/interp/apply.boot
deleted file mode 100644
index 942f102c..00000000
--- a/src/interp/apply.boot
+++ /dev/null
@@ -1,270 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2008, 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 compiler
-namespace BOOT
-
-compAtomWithModemap: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple
-compAtomWithModemap(x,m,e,v) ==
- Tl :=
- [[transImplementation(x,map,fn),target,e]
- for map in v | map is [[.,target],[.,fn]]] =>
- --accept only monadic operators
- T:= or/[t for (t:= [.,target,.]) in Tl | modeEqual(m,target)] => T
- 1=#(Tl:= [y for t in Tl | (y:= convert(t,m))]) => first Tl
- 0<#Tl and m=$NoValueMode => first Tl
- nil
-
-transImplementation: (%Form,%Modemap,%Thing) -> %Code
-transImplementation(op,map,fn) ==
- fn := genDeltaEntry [op,:map]
- fn is ["XLAM",:.] => [fn]
- ["call",fn]
-
-compApply: (%List,%List,%Thing,%List,%Mode,%Env) -> %Maybe %Triple
-compApply(sig,varl,body,argl,m,e) ==
- argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl]
- contour:=
- [Pair(x,[["mode",m'],["value",removeEnv comp(a,m',e)]])
- for x in varl for m' in sig.source for a in argl]
- code:= [["LAMBDA",varl,body'],:[T.expr for T in argTl]]
- m':= resolve(m,sig.target)
- body':= (comp(body,m',addContour(contour,e))).expr
- [code,m',e]
-
-compToApply: (%Form,%List,%Mode,%Env) -> %Maybe %Triple
-compToApply(op,argl,m,e) ==
- T:= compNoStacking(op,$EmptyMode,e) or return nil
- m1:= T.mode
- T.expr is ["QUOTE", =m1] => nil
- compApplication(op,argl,m,T.env,T)
-
-compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple
-compApplication(op,argl,m,e,T) ==
- T.mode is ['Mapping, retm, :argml] =>
- #argl ^= #argml => nil
- retm := resolve(m, retm)
- retm = $Category or isCategoryForm(retm,e) => nil -- not handled
- argTl := [[.,.,e] := comp(x,m,e) or return "failed"
- for x in argl for m in argml]
- argTl = "failed" => nil
- form:=
- not (member(op,$formalArgList) or member(T.expr,$formalArgList)) and ATOM T.expr =>
- nprefix := $prefix or
- -- following needed for referencing local funs at capsule level
- getAbbreviation($op,#rest $form)
- [op',:[a.expr for a in argTl],"$"] where
- op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr)
- ['call, ['applyFun, T.expr], :[a.expr for a in argTl]]
- coerce([form, retm, e],resolve(retm,m))
- op = 'elt => nil
- eltForm := ['elt, op, :argl]
- comp(eltForm, m, e)
-
-++ `form' is a call to a operation described by the signature `sig'.
-++ Massage the call so that homogeneous variable length argument lists
-++ are properly tuplified.
-reshapeArgumentList: (%Form,%Signature) -> %Form
-reshapeArgumentList(form,sig) ==
- [op,:args] := form
- wantArgumentsAsTuple(args,sig) => [op,["%Comma",:args]]
- form
-
-compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple
-compFormWithModemap(form,m,e,modemap) ==
- [map:= [.,target,:sig],[pred,impl]]:= modemap
- [op,:argl] := form := reshapeArgumentList(form,sig)
- if isCategoryForm(target,e) and isFunctor op then
- [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil
- [map:= [.,target,:.],:cexpr]:= modemap
- sv:=listOfSharpVars map
- if sv then
- -- SAY [ "compiling ", op, " in compFormWithModemap,
- -- mode= ",map," sharp vars=",sv]
- for x in argl for ss in $FormalMapVariableList repeat
- 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
-
- --generate code; return
- T:=
- [x',m',e'] where
- m':= SUBLIS(sl,map.(1))
- x':=
- form':= [f,:[t.expr for t in Tl]]
- m'=$Category or isCategoryForm(m',e) => form'
- -- try to deal with new-style Unions where we know the conditions
- op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and
- (c:=get(z,'condition,e)) and
- c is [["case",=z,c1]] and
- (c1 is [":",=(CADR argl),=m] or EQ(c1,CADR argl) ) =>
--- first is a full tag, as placed by getInverseEnvironment
--- second is what getSuccessEnvironment will place there
- ["CDR",z]
- ["call",:form']
- e':=
- Tl => (LAST Tl).env
- e
- convert(T,m)
-
--- This version tends to give problems with #1 and categories
--- applyMapping([op,:argl],m,e,ml) ==
--- #argl^=#ml-1 => nil
--- mappingHasCategoryTarget :=
--- isCategoryForm(first ml,e) => --is op a functor?
--- form:= [op,:argl']
--- pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList]
--- ml:= SUBLIS(pairlis,ml)
--- true
--- false
--- argl':=
--- [T.expr for x in argl for m' in rest ml] where
--- T() == [.,.,e]:= comp(x,m',e) or return "failed"
--- if argl'="failed" then return nil
--- mappingHasCategoryTarget => convert([form,first ml,e],m)
--- form:=
--- not member(op,$formalArgList) and ATOM op =>
--- [op',:argl',"$"] where
--- op':= INTERN STRCONC(STRINGIMAGE $prefix,";",STRINGIMAGE op)
--- ["call",["applyFun",op],:argl']
--- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList]
--- convert([form,SUBLIS(pairlis,first ml),e],m)
-
-applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
-applyMapping([op,:argl],m,e,ml) ==
- #argl^=#ml-1 => nil
- isCategoryForm(first ml,e) =>
- --is op a functor?
- pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList]
- ml' := SUBLIS(pairlis, ml)
- argl':=
- [T.expr for x in argl for m' in rest ml'] where
- T() == [.,.,e]:= comp(x,m',e) or return "failed"
- if argl'="failed" then return nil
- form:= [op,:argl']
- convert([form,first ml',e],m)
- argl':=
- [T.expr for x in argl for m' in rest ml] where
- T() == [.,.,e]:= comp(x,m',e) or return "failed"
- if argl'="failed" then return nil
- form:=
- not member(op,$formalArgList) and ATOM op and not get(op,'value,e) =>
- nprefix := $prefix or
- -- following needed for referencing local funs at capsule level
- getAbbreviation($op,#rest $form)
- [op',:argl',"$"] where
- op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op)
- ['call,['applyFun,op],:argl']
- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList]
- convert([form,SUBLIS(pairlis,first ml),e],m)
-
---% APPLY MODEMAPS
-
-compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple
-compApplyModemap(form,modemap,$e,sl) ==
- [op,:argl] := form --form to be compiled
- [[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]
- 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
-
- -- 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 member(op1,'(ELT CONST Subsumed)) =>
- [genDeltaEntry [op,:modemap],lt',$bindings]
- [f,lt',$bindings]
-
-compMapCond: (%Symbol,%Mode,%Env,%List) -> %Code
-compMapCond(op,mc,$bindings,fnsel) ==
- or/[compMapCond'(u,op,mc,$bindings) for u in fnsel]
-
-compMapCond': (%List,%Symbol,%Mode,%Env) -> %Code
-compMapCond'([cexpr,fnexpr],op,dc,bindings) ==
- compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings)
- stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
-
-compMapCond'': (%Thing,%Mode) -> %Boolean
-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 ["has",name,cat] => (knownInfo cexpr => true; false)
- --for the time being we'll stop here - shouldn't happen so far
- --$disregardConditionIfTrue => true
- --stackSemanticError(("not known that",'%b,name,
- -- '%d,"has",'%b,cat,'%d),nil)
- --now it must be an attribute
- member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true
- --for the time being we'll stop here - shouldn't happen so far
- stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
- false
-
-compMapCondFun: (%Thing,%Symbol,%Mode,%Env) -> %Code
-compMapCondFun(fnexpr,op,dc,bindings) ==
- [fnexpr,bindings]
-
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 79b5d862..4a3c4ca4 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -38,6 +38,54 @@ import modemap
import define
import iterator
namespace BOOT
+module compiler where
+ coerce: (%Triple,%Mode) -> %Maybe %Triple
+ convert: (%Triple,%Mode) -> %Maybe %Triple
+ comp: (%Form,%Mode,%Env) -> %Maybe %Triple
+ compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple
+ compCompilerPredicate: (%Form,%Env) -> %Maybe %Triple
+ checkCallingConvention: (%List,%Short) -> %SimpleArray %Short
+
+
+--%
+compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple
+compNoStacking: (%Form,%Mode,%Env) -> %Maybe %Triple
+compNoStacking1: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
+compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple
+comp2: (%Form,%Mode,%Env) -> %Maybe %Triple
+comp3: (%Form,%Mode,%Env) -> %Maybe %Triple
+compExpression: (%Form,%Mode,%Env) -> %Maybe %Triple
+compAtom: (%Form,%Mode,%Env) -> %Maybe %Triple
+compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple
+compString: (%Form,%Mode,%Env) -> %Maybe %Triple
+compAtomWithModemap: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple
+compTypeOf: (%Form,%Mode,%Env) -> %Maybe %Triple
+compForm: (%Form,%Mode,%Env) -> %Maybe %Triple
+compForm1: (%Form,%Mode,%Env) -> %Maybe %Triple
+compForm2: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
+compForm3: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
+compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Maybe %Triple
+compExpressionList: (%List,%Mode,%Env) -> %Maybe %Triple
+compWithMappingMode: (%Form,%Mode,%List) -> %List
+compFormMatch: (%Modemap,%List) -> %Boolean
+compFormWithModemap: (%Form,%Mode,%Env,%Modemap) -> %Maybe %Triple
+compApply: (%List,%List,%Thing,%List,%Mode,%Env) -> %Maybe %Triple
+compToApply: (%Form,%List,%Mode,%Env) -> %Maybe %Triple
+compApplication: (%Form,%List,%Mode,%Env,%Triple) -> %Maybe %Triple
+compApplyModemap: (%Form,%Modemap,%Env,%List) -> %Maybe %Triple
+
+primitiveType: %Thing -> %Mode
+hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean
+convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple
+getFormModemaps: (%Form,%Env) -> %List
+transImplementation: (%Form,%Modemap,%Thing) -> %Code
+reshapeArgumentList: (%Form,%Signature) -> %Form
+applyMapping: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
+compMapCond: (%Symbol,%Mode,%Env,%List) -> %Code
+compMapCond': (%List,%Symbol,%Mode,%Env) -> %Code
+compMapCond'': (%Thing,%Mode) -> %Boolean
+compMapCondFun: (%Thing,%Symbol,%Mode,%Env) -> %Code
+
++ A list of routines for diagnostic reports. These functions, in an
++ abstract sense, have type: forall T: Type . String -> T, so they
@@ -62,16 +110,13 @@ compTopLevel(x,m,e) ==
--keep old environment after top level function defs
compOrCroak(x,m,e)
-compUniquely: (%Form,%Mode,%Env) -> %Maybe %Triple
compUniquely(x,m,e) ==
$compUniquelyIfTrue: local:= true
CATCH("compUniquely",comp(x,m,e))
-compOrCroak: (%Form,%Mode,%Env) -> %Maybe %Triple
compOrCroak(x,m,e) ==
compOrCroak1(x,m,e,'comp)
-compOrCroak1: (%Form,%Mode,%Env,%Thing) -> %Maybe %Triple
compOrCroak1(x,m,e,compFn) ==
fn(x,m,e,nil,nil,compFn) where
fn(x,m,e,$compStack,$compErrorMessageStack,compFn) ==
@@ -103,7 +148,6 @@ tc() ==
++ The form `x' is intended to be evaluated by the compiler, e.g. in
++ toplevel conditional definition or as sub-domain predicate.
++ Normalize operators and compile the form.
-compCompilerPredicate: (%Form,%Env) -> %Maybe %Triple
compCompilerPredicate(x,e) ==
savedNormalizeTree := $normalizeTree
$normalizeTree := true
@@ -112,13 +156,11 @@ compCompilerPredicate(x,e) ==
t
-comp: (%Form,%Mode,%Env) -> %Maybe %Triple
comp(x,m,e) ==
T:= compNoStacking(x,m,e) => ($compStack:= nil; T)
$compStack:= [[x,m,e,$exitModeStack],:$compStack]
nil
-compNoStacking: (%Form,%Mode,%Env) -> %Maybe %Triple
compNoStacking(x,m,e) ==
T:= comp2(x,m,e) =>
$useRepresentationHack and m=$EmptyMode and T.mode=$Representation =>
@@ -131,13 +173,11 @@ compNoStacking(x,m,e) ==
--hack only when `Rep' is defined the old way. -- gdr 2008/01/26
compNoStacking1(x,m,e,$compStack)
-compNoStacking1: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
compNoStacking1(x,m,e,$compStack) ==
u:= get(RepIfRepHack m,"value",e) =>
(T:= comp2(x,u.expr,e) => [T.expr,m,T.env]; nil)
nil
-comp2: (%Form,%Mode,%Env) -> %Maybe %Triple
comp2(x,m,e) ==
[y,m',e]:= comp3(x,m,e) or return nil
if $LISPLIB and isDomainForm(x,e) then
@@ -150,7 +190,6 @@ comp2(x,m,e) ==
--$bootStrapMode-test necessary for compiling Ring in $bootStrapMode
[y,m',e]
-comp3: (%Form,%Mode,%Env) -> %Maybe %Triple
comp3(x,m,$e) ==
--returns a Triple or %else nil to signalcan't do'
$e:= addDomain(m,$e)
@@ -175,20 +214,45 @@ comp3(x,m,$e) ==
[x',m',addDomain(m',e')]
t
-compTypeOf: (%Form,%Mode,%Env) -> %Maybe %Triple
compTypeOf(x:=[op,:argl],m,e) ==
$insideCompTypeOf: local := true
newModemap:= EQSUBSTLIST(argl,$FormalMapVariableList,get(op,'modemap,e))
e:= put(op,'modemap,newModemap,e)
comp3(x,m,e)
+applyMapping([op,:argl],m,e,ml) ==
+ #argl^=#ml-1 => nil
+ isCategoryForm(first ml,e) =>
+ --is op a functor?
+ pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList]
+ ml' := SUBLIS(pairlis, ml)
+ argl':=
+ [T.expr for x in argl for m' in rest ml'] where
+ T() == [.,.,e]:= comp(x,m',e) or return "failed"
+ if argl'="failed" then return nil
+ form:= [op,:argl']
+ convert([form,first ml',e],m)
+ argl':=
+ [T.expr for x in argl for m' in rest ml] where
+ T() == [.,.,e]:= comp(x,m',e) or return "failed"
+ if argl'="failed" then return nil
+ form:=
+ not member(op,$formalArgList) and ATOM op and not get(op,'value,e) =>
+ nprefix := $prefix or
+ -- following needed for referencing local funs at capsule level
+ getAbbreviation($op,#rest $form)
+ [op',:argl',"$"] where
+ op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op)
+ ['call,['applyFun,op],:argl']
+ pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList]
+ convert([form,SUBLIS(pairlis,first ml),e],m)
+
hasFormalMapVariable(x, vl) ==
$formalMapVariables: local := vl
null vl => false
ScanOrPairVec(function hasone?,x) where
hasone? x == MEMQ(x,$formalMapVariables)
-compWithMappingMode: (%Form,%Mode,%List) -> %List
compWithMappingMode(x,m is ["Mapping",m',:sl],oldE) ==
$killOptimizeIfTrue: local:= true
e:= oldE
@@ -292,7 +356,6 @@ extractCodeAndConstructTriple(u, m, oldE) ==
[op,:.,env] := u
[["CONS",["function",op],env],m,oldE]
-compExpression: (%Form,%Mode,%Env) -> %Maybe %Triple
compExpression(x,m,e) ==
$insideExpressionIfTrue: local:= true
-- special forms have dedicated compilers.
@@ -300,7 +363,21 @@ compExpression(x,m,e) ==
FUNCALL(fn,x,m,e)
compForm(x,m,e)
-compAtom: (%Form,%Mode,%Env) -> %Maybe %Triple
+compAtomWithModemap(x,m,e,v) ==
+ Tl :=
+ [[transImplementation(x,map,fn),target,e]
+ for map in v | map is [[.,target],[.,fn]]] =>
+ --accept only monadic operators
+ T:= or/[t for (t:= [.,target,.]) in Tl | modeEqual(m,target)] => T
+ 1=#(Tl:= [y for t in Tl | (y:= convert(t,m))]) => first Tl
+ 0<#Tl and m=$NoValueMode => first Tl
+ nil
+
+transImplementation(op,map,fn) ==
+ fn := genDeltaEntry [op,:map]
+ fn is ["XLAM",:.] => [fn]
+ ["call",fn]
+
compAtom(x,m,e) ==
T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => T
x="nil" =>
@@ -316,7 +393,6 @@ compAtom(x,m,e) ==
[x,primitiveType x or return nil,e]
convert(t,m)
-primitiveType: %Thing -> %Mode
primitiveType x ==
x is nil => $EmptyMode
STRINGP x => $String
@@ -327,7 +403,6 @@ primitiveType x ==
FLOATP x => $DoubleFloat
nil
-compSymbol: (%Form,%Mode,%Env) -> %Maybe %Triple
compSymbol(s,m,e) ==
s="$NoValue" => ["$NoValue",$NoValueMode,e]
isFluid s => [s,getmode(s,e) or return nil,e]
@@ -352,7 +427,6 @@ compSymbol(s,m,e) ==
++ Return true if `m' is the most recent unique type case assumption
++ on `x' that predates its declaration in environment `e'.
-hasUniqueCaseView: (%Form,%Mode,%Env) -> %Boolean
hasUniqueCaseView(x,m,e) ==
props := getProplist(x,e)
for [p,:v] in props repeat
@@ -360,13 +434,11 @@ hasUniqueCaseView(x,m,e) ==
p = "value" => return false
-convertOrCroak: (%Triple,%Mode) -> %Maybe %Triple
convertOrCroak(T,m) ==
u:= convert(T,m) => u
userError ["CANNOT CONVERT: ",T.expr,"%l"," OF MODE: ",T.mode,"%l",
" TO MODE: ",m,"%l"]
-convert: (%Triple,%Mode) -> %Maybe %Triple
convert(T,m) ==
coerce(T,resolve(T.mode,m) or return nil)
@@ -391,13 +463,6 @@ hasType(x,e) ==
--% General Forms
-compForm: (%Form,%Mode,%Env) -> %Maybe %Triple
-compForm1: (%Form,%Mode,%Env) -> %Maybe %Triple
-compForm2: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
-compForm3: (%Form,%Mode,%Env,%List) -> %Maybe %Triple
-compArgumentsAndTryAgain: (%Form,%Mode,%Env) -> %Maybe %Triple
-compExpressionList: (%List,%Mode,%Env) -> %Maybe %Triple
-
compForm(form,m,e) ==
T:=
compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return
@@ -494,7 +559,6 @@ compForm2(form is [op,:argl],m,e,modemapList) ==
++ We are about to compile a call. Returns true if each argument
++ partially matches (as could be determined by type inference) the
++ corresponding expected type in the callee's modemap.
-compFormMatch: (%Modemap,%List) -> %Boolean
compFormMatch(mm,partialModeList) == main where
main() ==
mm is [[.,.,:argModeList],:.] and match(argModeList,partialModeList)
@@ -519,12 +583,75 @@ compForm3(form is [op,:argl],m,e,modemapList) ==
T
T
+
+compFormWithModemap(form,m,e,modemap) ==
+ [map:= [.,target,:sig],[pred,impl]]:= modemap
+ [op,:argl] := form := reshapeArgumentList(form,sig)
+ if isCategoryForm(target,e) and isFunctor op then
+ [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil
+ [map:= [.,target,:.],:cexpr]:= modemap
+ sv:=listOfSharpVars map
+ if sv then
+ -- SAY [ "compiling ", op, " in compFormWithModemap,
+ -- mode= ",map," sharp vars=",sv]
+ for x in argl for ss in $FormalMapVariableList repeat
+ 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
+
+ --generate code; return
+ T:=
+ [x',m',e'] where
+ m':= SUBLIS(sl,map.(1))
+ x':=
+ form':= [f,:[t.expr for t in Tl]]
+ m'=$Category or isCategoryForm(m',e) => form'
+ -- try to deal with new-style Unions where we know the conditions
+ op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and
+ (c:=get(z,'condition,e)) and
+ c is [["case",=z,c1]] and
+ (c1 is [":",=(CADR argl),=m] or EQ(c1,CADR argl) ) =>
+-- first is a full tag, as placed by getInverseEnvironment
+-- second is what getSuccessEnvironment will place there
+ ["CDR",z]
+ ["call",:form']
+ e':=
+ Tl => (LAST Tl).env
+ e
+ convert(T,m)
+
+-- This version tends to give problems with #1 and categories
+-- applyMapping([op,:argl],m,e,ml) ==
+-- #argl^=#ml-1 => nil
+-- mappingHasCategoryTarget :=
+-- isCategoryForm(first ml,e) => --is op a functor?
+-- form:= [op,:argl']
+-- pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList]
+-- ml:= SUBLIS(pairlis,ml)
+-- true
+-- false
+-- argl':=
+-- [T.expr for x in argl for m' in rest ml] where
+-- T() == [.,.,e]:= comp(x,m',e) or return "failed"
+-- if argl'="failed" then return nil
+-- mappingHasCategoryTarget => convert([form,first ml,e],m)
+-- form:=
+-- not member(op,$formalArgList) and ATOM op =>
+-- [op',:argl',"$"] where
+-- op':= INTERN STRCONC(STRINGIMAGE $prefix,";",STRINGIMAGE op)
+-- ["call",["applyFun",op],:argl']
+-- pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList]
+-- convert([form,SUBLIS(pairlis,first ml),e],m)
+
+
++ Returns the list of candidate modemaps for a form. A modemap
++ is candidate for a form if its signature has the same number
++ of paramter types as arguments supplied to the form. A special
++ case is made for a modemap whose sole parameter type is a Tuple.
++ In that case, it matches any number of supplied arguments.
-getFormModemaps: (%Form,%Env) -> %List
getFormModemaps(form is [op,:argl],e) ==
op is ["elt",domain,op1] =>
[x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]]
@@ -555,7 +682,6 @@ getFormModemaps(form is [op,:argl],e) ==
++ the same arity and must take flag argument in the same position.
++ Returns a vector of length `nargs' with positive entries indicating
++ flag arguments, and negative entries for normal argument passing.
-checkCallingConvention: (%List,%Short) -> %SimpleArray %Short
checkCallingConvention(sigs,nargs) ==
v := makeFilledSimpleArray("%Short",nargs,0)
for sig in sigs repeat
@@ -585,6 +711,52 @@ seteltModemapFilter(name,mmList,e) ==
nil
mmList
+
+compApply(sig,varl,body,argl,m,e) ==
+ argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl]
+ contour:=
+ [Pair(x,[["mode",m'],["value",removeEnv comp(a,m',e)]])
+ for x in varl for m' in sig.source for a in argl]
+ code:= [["LAMBDA",varl,body'],:[T.expr for T in argTl]]
+ m':= resolve(m,sig.target)
+ body':= (comp(body,m',addContour(contour,e))).expr
+ [code,m',e]
+
+compToApply(op,argl,m,e) ==
+ T:= compNoStacking(op,$EmptyMode,e) or return nil
+ m1:= T.mode
+ T.expr is ["QUOTE", =m1] => nil
+ compApplication(op,argl,m,T.env,T)
+
+compApplication(op,argl,m,e,T) ==
+ T.mode is ['Mapping, retm, :argml] =>
+ #argl ^= #argml => nil
+ retm := resolve(m, retm)
+ retm = $Category or isCategoryForm(retm,e) => nil -- not handled
+ argTl := [[.,.,e] := comp(x,m,e) or return "failed"
+ for x in argl for m in argml]
+ argTl = "failed" => nil
+ form:=
+ not (member(op,$formalArgList) or member(T.expr,$formalArgList)) and ATOM T.expr =>
+ nprefix := $prefix or
+ -- following needed for referencing local funs at capsule level
+ getAbbreviation($op,#rest $form)
+ [op',:[a.expr for a in argTl],"$"] where
+ op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem T.expr)
+ ['call, ['applyFun, T.expr], :[a.expr for a in argTl]]
+ coerce([form, retm, e],resolve(retm,m))
+ op = 'elt => nil
+ eltForm := ['elt, op, :argl]
+ comp(eltForm, m, e)
+
+++ `form' is a call to a operation described by the signature `sig'.
+++ Massage the call so that homogeneous variable length argument lists
+++ are properly tuplified.
+reshapeArgumentList(form,sig) ==
+ [op,:args] := form
+ wantArgumentsAsTuple(args,sig) => [op,["%Comma",:args]]
+ form
+
substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) ==
#dc^=#sig =>
keyedSystemError("S2GE0016",['"substituteIntoFunctorModemap",
@@ -602,7 +774,6 @@ substituteIntoFunctorModemap(argl,modemap is [[dc,:sig],:.],e) ==
compConstructorCategory(x,m,e) == [x,resolve($Category,m),e]
-compString: (%Form,%Mode,%Env) -> %Maybe %Triple
compString(x,m,e) == [x,resolve($StringCategory,m),e]
--% SUBSET CATEGORY
@@ -1258,7 +1429,6 @@ compIs(["is",a,b],m,e) ==
-- One should always call the correct function, since the represent-
-- ation of basic objects may not be the same.
-coerce: (%Triple,%Mode) -> %Maybe %Triple
coerce(T,m) ==
$InteractiveMode =>
keyedSystemError("S2GE0016",['"coerce",
@@ -1645,7 +1815,76 @@ compCat(form is [functorName,:argl],m,e) ==
--sure if it uses any of the other signatures(see extendsCategoryForm)
[form,catForm,e]
-
+--% APPLY MODEMAPS
+
+compApplyModemap(form,modemap,$e,sl) ==
+ [op,:argl] := form --form to be compiled
+ [[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]
+ 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
+
+ -- 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 member(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)
+ stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
+
+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 ["has",name,cat] => (knownInfo cexpr => true; false)
+ --for the time being we'll stop here - shouldn't happen so far
+ --$disregardConditionIfTrue => true
+ --stackSemanticError(("not known that",'%b,name,
+ -- '%d,"has",'%b,cat,'%d),nil)
+ --now it must be an attribute
+ member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true
+ --for the time being we'll stop here - shouldn't happen so far
+ stackMessage('"not known that %1pb has %2pb",[dc,cexpr])
+ false
+
+compMapCondFun(fnexpr,op,dc,bindings) ==
+ [fnexpr,bindings]
--% Interface to the backend