trans.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- Copyright (C) International Computer Science Institute, 1995. COPYRIGHT --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in --
-- the file "Doc/License" of the Sather distribution. The license is also --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA. --
--------> Please email comments to sather-bugs@icsi.berkeley.edu. <----------
-- trans.sa: Transformation of code from AS to AM form.
-- Code transformation is partitioned into two pieces, one for
-- serial translation and one for pSather. To simplify things
-- STRANS uses some calls from PTRANS.
-- The other stages of the compiler use TRANS. Here it points
-- to PTRANS, but it could also be compiled to leave the pSather
-- stuff out by pointing to STRANS alone.
class TRANS
class TRANS is
include PTRANS;
end;
class STRANS
class STRANS is
-- The context for a code transformation from AS form to AM form.
include CS_COMPONENT;
-- we redefine err, such that it gives a little bit more information
err(s:STR) is
if void(self) or void(self.cur_rout) or void(self.cur_rout.sig) then prog.err(s);-- TRANS::cur_rout TRANS::cur_rout AM_ROUT_DEF::sig TRANS::prog PROG::err
else s:=self.cur_rout.sig.str+":"+s;-- TRANS::cur_rout AM_ROUT_DEF::sig SIG::str STR::plus STR::plus
prog.err(s);-- TRANS::prog PROG::err
end;
end;
attr impl:IMPL; -- The implementation structure for the
-- type within which this transformation appears.
attr tp_con:TP_CONTEXT; -- The type context for interpreting
-- type specifiers.
attr cur_rout:AM_ROUT_DEF; -- The current routine or iter.
attr cur_loop:AM_LOOP_STMT; -- Current loop if any.
attr cur_yield_ind:INT; -- Index of the current yield.
attr active_locals:FLIST{AM_LOCAL_EXPR}; -- Locals in scope.
attr in_pre:BOOL; -- True if inside a `pre' clause.
attr in_post:BOOL; -- True if this code is inside
-- a "post" clause (and so can have initial expressions).
attr in_protect_body:BOOL; -- True if inside a `protect' body.
attr in_protect_then:BOOL; -- True if inside a `protect' `then' or
-- `else' clause.
attr in_protect_but_not_loop:BOOL;
-- True if inside a `protect', but not inside a `loop'.
attr ex_tp:$TP; -- Type of exception expr.
attr in_invariant:BOOL; -- True if inside an invariant body.
attr in_initial:BOOL; -- True if inside an `initial' expr.
attr init_stmts:$AM_STMT; -- The initial statments if any.
attr in_external:BOOL; -- True if inside an external class.
attr in_constant:BOOL; -- True if inside a constant or shared
-- initialization expression.
attr cur_se:SE_CONTEXT; -- set of side_effects for this translation
-- invariants or postconditions to be emitted before a return,
-- if any.
attr inv_stmt:AM_INVARIANT_STMT;
attr post_stmt:AM_POST_STMT;
-- The following dummy routines are necessary to allow STRANS to be used
-- without additional pSather stuff. These routines are redefined in PTRANS
is_in_par_or_fork:BOOL is return false end;
is_in_lock:BOOL is return false end;
transform_pSather_stmt(as:$AS_STMT):$AM_STMT is return void; end;
transform_pSather_rout_elt_stuff(as:AS_ROUT_DEF) is end;
transform_pSather_assign_stmt_err(as:AS_ASSIGN_STMT) is end;
-- transform_pSather_protect_when_stuff(tp:$TP,wp:AS_PROTECT_WHEN,
-- as:AS_PROTECT_STMT) is end;
-- transform_pSather_protect_else_stuff(as:AS_PROTECT_STMT) is end;
transform_pSather_expr(e:$AS_EXPR, tp:$TP):$AM_EXPR is return void; end;
check_pSather_stmt_for_return(as:$AS_STMT) is end;
sys_closure_self(sig:SIG) is end;
sys_closure_nest(ncs:$AM_EXPR) is end;
transform_pSather_local_assign(loc:AM_LOCAL_EXPR,s:AS_ASSIGN_STMT) is end;
create(e:ELT):SAME
-- Create a new transformation context for the element e.
pre ~void(e) is-- BOOL::not
r::=new;
r.prog:=e.prog; -- TRANS::prog ELT::prog
r.impl:=e.impl;-- TRANS::impl ELT::impl
r.tp_con:=e.con; -- TRANS::tp_con ELT::con
r.cur_se:=#(r.prog,e.sig);-- TRANS::cur_se SE_CONTEXT::create TRANS::prog ELT::sig
--r.iter_sig_am_rout_def := #;
if void(r.impl) or void(r.tp_con) then return void end;-- TRANS::impl TRANS::tp_con
return r;
end;
is_iter:BOOL is
-- True if we are working on an iter.
if void(cur_rout) then return false end;-- TRANS::cur_rout
return cur_rout.is_iter; -- TRANS::cur_rout AM_ROUT_DEF::is_iter
end;
local_with_name(n:IDENT):AM_LOCAL_EXPR
-- The local with the name `n', if any. Void otherwise.
pre ~void(cur_rout) is-- TRANS::cur_rout BOOL::not
loop r::=cur_rout.elt!;-- TRANS::cur_rout AM_ROUT_DEF::elt!
if void(r) then
#OUT + "Compiler error, TRANS::local_with_name, void local.";-- OUT::create OUT::plus
return void end;
if r.expr.name=n then return r.expr end end;-- AM_FORMAL_ARG::expr AM_LOCAL_EXPR::name IDENT::is_eq AM_FORMAL_ARG::expr
loop r::=active_locals.elt!;-- TRANS::active_locals FLIST{1}::elt!
if void(r) then
#OUT + "Compiler error, TRANS::local_with_name, void local.";-- OUT::create OUT::plus
return void end;
if r.name=n -- AM_LOCAL_EXPR::name IDENT::is_eq
then return r
end
end;
return void;
end;
add_local(l:AM_LOCAL_EXPR) is
-- Add the local variable `l'.
if void(cur_rout) then -- TRANS::cur_rout
#OUT + "Compiler error, TRANS::add_local, cur_rout=void.";-- OUT::create OUT::plus
return end;
cur_rout.locals:=cur_rout.locals.push(l);-- TRANS::cur_rout AM_ROUT_DEF::locals TRANS::cur_rout AM_ROUT_DEF::locals FLIST{1}::push
if ~void(l.name) then active_locals:=active_locals.push(l) end;-- AM_LOCAL_EXPR::name BOOL::not TRANS::active_locals TRANS::active_locals FLIST{1}::push
end;
tp_of(t:AS_TYPE_SPEC):$TP
-- The type object corresponding to the type specifier `t' in
-- this context.
pre ~void(t) is-- BOOL::not
return tp_con.tp_of(t); -- TRANS::tp_con TP_CONTEXT::tp_of
end;
special_inline(call:AM_ROUT_CALL_EXPR):$AM_EXPR is
-- Here we deal only with special purpose inlining
-- general purpose inlining is done during the optimization phase
-- If `call' can be inlined, return the inlining expression,
-- otherwise just return it.
if ~prog.all_reached then-- TRANS::prog PROG::all_reached BOOL::not
-- Make sure it's been generated.
prog.generate_am.output_sig(call.fun); -- TRANS::prog PROG::generate_am AM_ROUT_CALL_EXPR::fun
end;
-- Don't inline constant initializations
-- It happens only once, so overhead is little
-- It makes main more readable, and lowers the
-- complexity of inlining considerably
-- Actually, this was only a problem when the general
-- inlining was done here too. As now the general
-- inlining has been moved to the optimizer,
-- it should work OK again. If not, remove the comments
-- (and don't compile with -O2, gcc is broken)
-- if in_constant then
-- return call;
-- end;
am::=prog.inliner.special_inline(call);-- TRANS::prog PROG::inliner
-- Ivin - The statements may use local variables and call other routines.
typecase am
when AM_STMT_EXPR then
-- Do not change active_locals to avoid name clashes.
cur_rout.calls:=cur_rout.calls.concat(am.calls);-- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::concat AM_STMT_EXPR::calls
cur_rout.locals:=cur_rout.locals.concat(am.locals);-- TRANS::cur_rout AM_ROUT_DEF::locals TRANS::cur_rout AM_ROUT_DEF::locals FLIST{1}::concat AM_STMT_EXPR::locals
else end;
return am
end;
-- Ivin - same for iterators.
special_inline(call:AM_ITER_CALL_EXPR):$AM_EXPR is
-- Here we deal only with special purpose inlining
-- general purpose inlining is done during the optimization phase
-- If `call' can be inlined, return the inlining expression,
-- otherwise just return it.
if ~prog.all_reached then-- TRANS::prog PROG::all_reached BOOL::not
-- Make sure it's been generated.
prog.generate_am.output_sig(call.fun); -- TRANS::prog PROG::generate_am AM_ITER_CALL_EXPR::fun
end;
am::=prog.inliner.special_inline(call);-- TRANS::prog PROG::inliner
typecase am
when AM_STMT_EXPR then
-- Do not change active_locals to avoid name clashes.
cur_rout.calls:=cur_rout.calls.concat(am.calls);-- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::concat AM_STMT_EXPR::calls
cur_rout.locals:=cur_rout.locals.concat(am.locals);-- TRANS::cur_rout AM_ROUT_DEF::locals TRANS::cur_rout AM_ROUT_DEF::locals FLIST{1}::concat AM_STMT_EXPR::locals
cur_loop.its:=cur_loop.its.concat(am.its);-- TRANS::cur_loop AM_LOOP_STMT::its TRANS::cur_loop AM_LOOP_STMT::its FLIST{1}::concat AM_STMT_EXPR::its
cur_loop.bits:=cur_loop.bits.concat(am.bits);-- TRANS::cur_loop AM_LOOP_STMT::bits TRANS::cur_loop AM_LOOP_STMT::bits FLIST{1}::concat AM_STMT_EXPR::bits
cur_loop.firsts:=cur_loop.firsts.concat(am.firsts);-- TRANS::cur_loop AM_LOOP_STMT::firsts TRANS::cur_loop AM_LOOP_STMT::firsts FLIST{1}::concat AM_STMT_EXPR::firsts
else end;
return am
end;
gen:GENERATE_AM is
-- The GENERATE_AM object controlling translation.
gen::=prog.generate_am;-- TRANS::prog PROG::generate_am
typecase gen when GENERATE_AM then return gen; end;
end;
transform_elt(e:ELT):AM_ROUT_DEF
-- Transform the element `e' into AM form. Ignores self.
-- Should not be applied to void.
-- If there is a problem, returns void.
pre ~void(e) is-- BOOL::not
t:SAME:=#(e); if void(t) then return void end;-- TRANS::create
as::=e.as;-- ELT::as
r:AM_ROUT_DEF;
typecase as
when AS_CONST_DEF then r:=t.transform_const_elt(e,as)-- TRANS::transform_const_elt
when AS_SHARED_DEF then r:=t.transform_shared_elt(e,as)-- TRANS::transform_shared_elt
when AS_ATTR_DEF then r:=t.transform_attr_elt(e,as)-- TRANS::transform_attr_elt
when AS_ROUT_DEF then
r:=t.transform_rout_elt(e,as);-- TRANS::transform_rout_elt
if t.prog.psather and ~void(t.cur_se) then-- TRANS::prog PROG::psather TRANS::cur_se BOOL::not
t.cur_se.has_import:=t.cur_se.has_import or (r.sig.is_builtin and r.sig.builtin_info.does_import);-- TRANS::cur_se SE_CONTEXT::has_import TRANS::cur_se SE_CONTEXT::has_import AM_ROUT_DEF::sig SIG::is_builtin AM_ROUT_DEF::sig SIG::builtin_info CONFIG_ROUT::does_import
t.cur_se.has_export:=t.cur_se.has_export or (r.sig.is_builtin and r.sig.builtin_info.does_export);-- TRANS::cur_se SE_CONTEXT::has_export TRANS::cur_se SE_CONTEXT::has_export AM_ROUT_DEF::sig SIG::is_builtin AM_ROUT_DEF::sig SIG::builtin_info CONFIG_ROUT::does_export
end;
end;
-- register this se_context with the
t.cur_se.register;-- TRANS::cur_se SE_CONTEXT::register
SYS::destroy(t);-- SYS::destroy
return r;
end;
transform_const_elt(e:ELT,as:AS_CONST_DEF):AM_ROUT_DEF is
-- Transform the element `e' into AM form.
r:AM_ROUT_DEF:=#AM_ROUT_DEF(1,as.source); cur_rout:=r;-- AM_ROUT_DEF::create AS_CONST_DEF::source TRANS::cur_rout
r.srcsig:=e.srcsig;-- AM_ROUT_DEF::srcsig ELT::srcsig
r.sig:=e.sig;-- AM_ROUT_DEF::sig ELT::sig
r.sig.srcsig:=e.srcsig;-- AM_ROUT_DEF::sig SIG::srcsig ELT::srcsig
sl::=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::self_ident,e.tp,e.as_tp);-- AM_LOCAL_EXPR::create AS_CONST_DEF::source IDENT_BUILTIN::self_ident ELT::tp ELT::as_tp
r[0] := #AM_FORMAL_ARG(sl);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
g:AM_GLOBAL_EXPR:=gen.global_tbl.get(e.name,impl.tp);-- TRANS::gen GENERATE_AM::global_tbl GLOBAL_TBL::get ELT::name TRANS::impl IMPL::tp
if void(g) then
g:=#AM_GLOBAL_EXPR(as.source); g.name:=e.name;-- AM_GLOBAL_EXPR::create AS_CONST_DEF::source AM_GLOBAL_EXPR::name ELT::name
g.as_type := e.as_tp;-- AM_GLOBAL_EXPR::as_type ELT::as_tp
g.tp_at:=e.ret; g.class_tp:=impl.tp; g.is_const:=true;-- AM_GLOBAL_EXPR::tp_at ELT::ret AM_GLOBAL_EXPR::class_tp TRANS::impl IMPL::tp AM_GLOBAL_EXPR::is_const
in_constant:=true;-- TRANS::in_constant
g.init:=transform_expr(as.init,g.tp_at); -- AM_GLOBAL_EXPR::init TRANS::transform_expr AS_CONST_DEF::init AM_GLOBAL_EXPR::tp_at
in_constant:=false;-- TRANS::in_constant
gen.global_tbl.insert(g) end;-- TRANS::gen GENERATE_AM::global_tbl GLOBAL_TBL::insert
ar::=#AM_RETURN_STMT(as.source); ar.val:=g;-- AM_RETURN_STMT::create AS_CONST_DEF::source AM_RETURN_STMT::val
r.code:=ar; r.is_clean:=true; -- AM_ROUT_DEF::code AM_ROUT_DEF::is_clean
return r;
end;
transform_shared_elt(e:ELT,as:AS_SHARED_DEF):AM_ROUT_DEF is
-- Transform the element `e' into AM form.
sl, l1: AM_LOCAL_EXPR;
if e.is_shared_reader then -- Shared reader.-- ELT::is_shared_reader
r::=#AM_ROUT_DEF(1,as.source); cur_rout:=r;-- AM_ROUT_DEF::create AS_SHARED_DEF::source TRANS::cur_rout
r.srcsig:=e.srcsig;-- AM_ROUT_DEF::srcsig ELT::srcsig
sl:=#AM_LOCAL_EXPR(as.source, -- Local for self.-- AM_LOCAL_EXPR::create AS_SHARED_DEF::source
IDENT_BUILTIN::self_ident, e.tp, e.as_tp);-- IDENT_BUILTIN::self_ident ELT::tp ELT::as_tp
r[0] := #AM_FORMAL_ARG(sl);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
r.sig:=e.sig;-- AM_ROUT_DEF::sig ELT::sig
r.sig.srcsig:=e.srcsig;-- AM_ROUT_DEF::sig SIG::srcsig ELT::srcsig
g:AM_GLOBAL_EXPR:=gen.global_tbl.get(e.name,impl.tp);-- TRANS::gen GENERATE_AM::global_tbl GLOBAL_TBL::get ELT::name TRANS::impl IMPL::tp
if void(g) then
g:=#AM_GLOBAL_EXPR(as.source); g.name:=e.name;-- AM_GLOBAL_EXPR::create AS_SHARED_DEF::source AM_GLOBAL_EXPR::name ELT::name
g.as_type := e.as_tp;-- AM_GLOBAL_EXPR::as_type ELT::as_tp
g.tp_at:=e.ret; g.class_tp:=impl.tp; -- AM_GLOBAL_EXPR::tp_at ELT::ret AM_GLOBAL_EXPR::class_tp TRANS::impl IMPL::tp
in_constant:=true;-- TRANS::in_constant
g.init:=transform_expr(as.init,g.tp); -- AM_GLOBAL_EXPR::init TRANS::transform_expr AS_SHARED_DEF::init AM_GLOBAL_EXPR::tp
in_constant:=false;-- TRANS::in_constant
gen.global_tbl.insert(g) end;-- TRANS::gen GENERATE_AM::global_tbl GLOBAL_TBL::insert
g.tp_at:=e.sig.ret;-- AM_GLOBAL_EXPR::tp_at ELT::sig SIG::ret
cur_se.mark_se(g,false);-- TRANS::cur_se SE_CONTEXT::mark_se
ar::=#AM_RETURN_STMT(as.source); ar.val:=g;-- AM_RETURN_STMT::create AS_SHARED_DEF::source AM_RETURN_STMT::val
r.code:=ar; r.is_clean:=true; -- AM_ROUT_DEF::code AM_ROUT_DEF::is_clean
return r
else -- Shared writer.
r::=#AM_ROUT_DEF(2,as.source); cur_rout:=r;-- AM_ROUT_DEF::create AS_SHARED_DEF::source TRANS::cur_rout
r.srcsig:=e.srcsig; -- AM_ROUT_DEF::srcsig ELT::srcsig
sl:=#AM_LOCAL_EXPR(as.source, -- Local for self.-- AM_LOCAL_EXPR::create AS_SHARED_DEF::source
IDENT_BUILTIN::self_ident, e.tp, e.as_tp);-- IDENT_BUILTIN::self_ident ELT::tp ELT::as_tp
r[0] := #AM_FORMAL_ARG(sl);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
if void(e.sig.args) then-- ELT::sig SIG::args
err("Compiler error, TRANS::transform_shared_elt, "
"e.sig.args=void."); return void end; -- TRANS::err
l1:=#AM_LOCAL_EXPR(as.source, e.name, e.sig.args[0].tp);-- AM_LOCAL_EXPR::create AS_SHARED_DEF::source ELT::name ELT::sig SIG::args ARRAY{1}::aget ARG::tp
r[1] := #AM_FORMAL_ARG(l1);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
r.sig:=e.sig;-- AM_ROUT_DEF::sig ELT::sig
r.sig.srcsig:=e.srcsig;-- AM_ROUT_DEF::sig SIG::srcsig ELT::srcsig
g:AM_GLOBAL_EXPR:=gen.global_tbl.get(e.name,impl.tp);-- TRANS::gen GENERATE_AM::global_tbl GLOBAL_TBL::get ELT::name TRANS::impl IMPL::tp
if void(g) then
g:=#AM_GLOBAL_EXPR(as.source); g.name:=e.name;-- AM_GLOBAL_EXPR::create AS_SHARED_DEF::source AM_GLOBAL_EXPR::name ELT::name
g.as_type := e.as_tp;-- AM_GLOBAL_EXPR::as_type ELT::as_tp
g.class_tp:=impl.tp;-- AM_GLOBAL_EXPR::class_tp TRANS::impl IMPL::tp
in_constant:=true;-- TRANS::in_constant
g.init:=transform_expr(as.init,g.tp); -- AM_GLOBAL_EXPR::init TRANS::transform_expr AS_SHARED_DEF::init AM_GLOBAL_EXPR::tp
in_constant:=false;-- TRANS::in_constant
gen.global_tbl.insert(g) end;-- TRANS::gen GENERATE_AM::global_tbl GLOBAL_TBL::insert
g.tp_at:=e.sig.args[0].tp;-- AM_GLOBAL_EXPR::tp_at ELT::sig SIG::args ARRAY{1}::aget ARG::tp
cur_se.mark_se(g,true);-- TRANS::cur_se SE_CONTEXT::mark_se
ar::=#AM_ASSIGN_STMT(as.source); -- AM_ASSIGN_STMT::create AS_SHARED_DEF::source
ar.dest:=g; ar.src:=r[1].expr;-- AM_ASSIGN_STMT::dest AM_ASSIGN_STMT::src AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
inv:AM_INVARIANT_STMT;
if ~e.is_private and ~in_invariant then-- ELT::is_private BOOL::not TRANS::in_invariant BOOL::not
isig:SIG:=impl.invariant_sig;-- TRANS::impl IMPL::invariant_sig
if ~void(isig) then-- BOOL::not
inv:=#AM_INVARIANT_STMT(as.source); -- AM_INVARIANT_STMT::create AS_SHARED_DEF::source
inv.sig:=isig;-- AM_INVARIANT_STMT::sig
icall::=#AM_ROUT_CALL_EXPR(1,as.source);-- AM_ROUT_CALL_EXPR::create AS_SHARED_DEF::source
icall.fun:=isig;-- AM_ROUT_CALL_EXPR::fun
cur_se.mark_context(icall);-- TRANS::cur_se SE_CONTEXT::mark_context
r.calls:=r.calls.push(icall) end end;-- AM_ROUT_DEF::calls AM_ROUT_DEF::calls FLIST{1}::push
r.code:=ar; -- AM_ROUT_DEF::code
if void(r.code) then r.code:=inv-- AM_ROUT_DEF::code AM_ROUT_DEF::code
else r.code.append(inv) end;-- AM_ROUT_DEF::code
r.is_clean:=false; -- AM_ROUT_DEF::is_clean
return r;
end;
end;
transform_attr_elt(e:ELT,as:AS_ATTR_DEF):AM_ROUT_DEF is
-- Transform the element `e' into AM form.
sl, l1, l2:AM_LOCAL_EXPR;
r:AM_ROUT_DEF;
if e.is_attr_reader then -- Attribute reader.-- ELT::is_attr_reader
r:=#AM_ROUT_DEF(1,as.source); -- AM_ROUT_DEF::create AS_ATTR_DEF::source
r.srcsig:=e.srcsig;-- AM_ROUT_DEF::srcsig ELT::srcsig
sl:=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::self_ident, -- AM_LOCAL_EXPR::create AS_ATTR_DEF::source IDENT_BUILTIN::self_ident
e.tp, e.as_tp);-- ELT::tp ELT::as_tp
r[0] := #AM_FORMAL_ARG(sl);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
r.sig:=e.sig;-- AM_ROUT_DEF::sig ELT::sig
r.sig.srcsig:=e.srcsig;-- AM_ROUT_DEF::sig SIG::srcsig ELT::srcsig
ae::=#AM_ATTR_EXPR(as.source); -- AM_ATTR_EXPR::create AS_ATTR_DEF::source
ae.as_type := e.as_tp;-- AM_ATTR_EXPR::as_type ELT::as_tp
ae.ob:=r[0].expr; ae.self_tp:=ae.ob.tp;-- AM_ATTR_EXPR::ob AM_ROUT_DEF::aget AM_FORMAL_ARG::expr AM_ATTR_EXPR::self_tp AM_ATTR_EXPR::ob
ae.at:=e.name; ae.tp_at:=tp_of(as.tp);-- AM_ATTR_EXPR::at ELT::name AM_ATTR_EXPR::tp_at TRANS::tp_of AS_ATTR_DEF::tp
if void(ae.tp_at) then -- AM_ATTR_EXPR::tp_at
err_loc(as.tp); err("Cannot translate type.");-- TRANS::err_loc AS_ATTR_DEF::tp TRANS::err
return void end;
cur_se.mark_se(ae,false);-- TRANS::cur_se SE_CONTEXT::mark_se
if ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
ar::=#AM_RETURN_STMT(as.source); -- AM_RETURN_STMT::create AS_ATTR_DEF::source
ar.val:=ae; r.code:=ar; r.is_clean:=true; -- AM_RETURN_STMT::val AM_ROUT_DEF::code AM_ROUT_DEF::is_clean
else -- Attribute writer.
r:=#AM_ROUT_DEF(2,as.source); -- AM_ROUT_DEF::create AS_ATTR_DEF::source
r.srcsig:=e.srcsig;-- AM_ROUT_DEF::srcsig ELT::srcsig
sl:=#AM_LOCAL_EXPR(as.source, IDENT_BUILTIN::self_ident, -- AM_LOCAL_EXPR::create AS_ATTR_DEF::source IDENT_BUILTIN::self_ident
e.tp, e.as_tp);-- ELT::tp ELT::as_tp
r[0] := #AM_FORMAL_ARG(sl);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
if void(e.sig.args) then-- ELT::sig SIG::args
err("Compiler error, TRANS::transform_attr_elt, "
"e.sig.args=void."); return void end; -- TRANS::err
l1:=#AM_LOCAL_EXPR(as.source,e.name,e.sig.args[0].tp);-- AM_LOCAL_EXPR::create AS_ATTR_DEF::source ELT::name ELT::sig SIG::args ARRAY{1}::aget ARG::tp
r[1] := #AM_FORMAL_ARG(l1);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
r.sig:=e.sig;-- AM_ROUT_DEF::sig ELT::sig
r.sig.srcsig:=e.srcsig;-- AM_ROUT_DEF::sig SIG::srcsig ELT::srcsig
if tp_con.same.kind=TP_KIND::val_tp then -- Value type.-- TRANS::tp_con TP_CONTEXT::same TP_CLASS::kind INT::is_eq TP_KIND::val_tp
av::=#AM_VATTR_ASSIGN_EXPR(as.source);-- AM_VATTR_ASSIGN_EXPR::create AS_ATTR_DEF::source
av.ob:=r[0].expr; av.at:=e.name; av.val:=r[1].expr;-- AM_VATTR_ASSIGN_EXPR::ob AM_ROUT_DEF::aget AM_FORMAL_ARG::expr AM_VATTR_ASSIGN_EXPR::at ELT::name AM_VATTR_ASSIGN_EXPR::val AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
av.real_tp:=tp_of(as.tp);-- AM_VATTR_ASSIGN_EXPR::real_tp TRANS::tp_of AS_ATTR_DEF::tp
cur_se.mark_se(av,true);-- TRANS::cur_se SE_CONTEXT::mark_se
if ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
ar::=#AM_RETURN_STMT(as.source);-- AM_RETURN_STMT::create AS_ATTR_DEF::source
ar.val:=av; r.code:=ar;-- AM_RETURN_STMT::val AM_ROUT_DEF::code
else -- Reference type.
ae::=#AM_ATTR_EXPR(as.source); -- AM_ATTR_EXPR::create AS_ATTR_DEF::source
ae.as_type := e.as_tp;-- AM_ATTR_EXPR::as_type ELT::as_tp
ae.ob:=r[0].expr; ae.self_tp:=ae.ob.tp;-- AM_ATTR_EXPR::ob AM_ROUT_DEF::aget AM_FORMAL_ARG::expr AM_ATTR_EXPR::self_tp AM_ATTR_EXPR::ob
ae.at:=e.name; ae.tp_at:=tp_of(as.tp);-- AM_ATTR_EXPR::at ELT::name AM_ATTR_EXPR::tp_at TRANS::tp_of AS_ATTR_DEF::tp
if void(ae.tp_at) then -- AM_ATTR_EXPR::tp_at
err_loc(as.tp); err("Cannot translate type.");-- TRANS::err_loc AS_ATTR_DEF::tp TRANS::err
return void end;
cur_se.mark_se(ae,true);-- TRANS::cur_se SE_CONTEXT::mark_se
if ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
ar::=#AM_ASSIGN_STMT(as.source); -- AM_ASSIGN_STMT::create AS_ATTR_DEF::source
ar.dest:=ae; ar.src:=r[1].expr; r.code:=ar; -- AM_ASSIGN_STMT::dest AM_ASSIGN_STMT::src AM_ROUT_DEF::aget AM_FORMAL_ARG::expr AM_ROUT_DEF::code
end;
inv:AM_INVARIANT_STMT;
if ~e.is_private and ~in_invariant then-- ELT::is_private BOOL::not TRANS::in_invariant BOOL::not
isig:SIG:=impl.invariant_sig;-- TRANS::impl IMPL::invariant_sig
if ~void(isig) then-- BOOL::not
inv:=#AM_INVARIANT_STMT(as.source); -- AM_INVARIANT_STMT::create AS_ATTR_DEF::source
inv.sig:=isig;-- AM_INVARIANT_STMT::sig
icall::=#AM_ROUT_CALL_EXPR(1,as.source);-- AM_ROUT_CALL_EXPR::create AS_ATTR_DEF::source
icall.fun:=isig;-- AM_ROUT_CALL_EXPR::fun
cur_se.mark_context(icall);-- TRANS::cur_se SE_CONTEXT::mark_context
r.calls:=r.calls.push(icall) end end;-- AM_ROUT_DEF::calls AM_ROUT_DEF::calls FLIST{1}::push
if void(r.code) then r.code:=inv -- AM_ROUT_DEF::code AM_ROUT_DEF::code
else r.code.append(inv) end;-- AM_ROUT_DEF::code
r.is_clean:=false; end;-- AM_ROUT_DEF::is_clean
return r;
end;
transform_rout_elt(e:ELT,as:AS_ROUT_DEF):AM_ROUT_DEF is
-- Transform the element `e' into AM form.
if e.is_invariant then in_invariant:=true else-- ELT::is_invariant TRANS::in_invariant
in_invariant:=false end;-- TRANS::in_invariant
if as.is_abstract then -- AS_ROUT_DEF::is_abstract
if e.is_external or e.tp.is_partial then return void -- ELT::is_external ELT::tp
-- Don't do anything special for
-- abstract sigs in external and partial classes
else
err_loc(as); -- TRANS::err_loc
err("Compiler error, TRANS::tranform_rout_elt given "
"abstract"); return void -- TRANS::err
end
end;
check_return(as);-- TRANS::check_return
r::=#AM_ROUT_DEF(1+e.sig.args.size,as.source); -- AM_ROUT_DEF::create INT::plus ELT::sig SIG::args ARRAY{1}::size AS_ROUT_DEF::source
r.srcsig:=e.srcsig; r.sig:=e.sig;-- AM_ROUT_DEF::srcsig ELT::srcsig AM_ROUT_DEF::sig ELT::sig
r.sig.srcsig:=e.srcsig;-- AM_ROUT_DEF::sig SIG::srcsig ELT::srcsig
if e.is_external then r.is_external:=true end;-- ELT::is_external AM_ROUT_DEF::is_external
sl::=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::self_ident, e.tp, e.as_tp);-- AM_LOCAL_EXPR::create AS_ROUT_DEF::source IDENT_BUILTIN::self_ident ELT::tp ELT::as_tp
r[0] := #AM_FORMAL_ARG(sl);-- AM_ROUT_DEF::aset AM_FORMAL_ARG::create
if e.sig.has_ret then -- ELT::sig SIG::has_ret
r.rres:=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::ret_ident,e.ret); -- For return.-- AM_ROUT_DEF::rres AM_LOCAL_EXPR::create AS_ROUT_DEF::source IDENT_BUILTIN::ret_ident ELT::ret
r.locals:=r.locals.push(r.rres); -- AM_ROUT_DEF::locals AM_ROUT_DEF::locals FLIST{1}::push AM_ROUT_DEF::rres
end;
i:INT:=0; na:AS_ARG_DEC:=as.args_dec;-- AS_ROUT_DEF::args_dec
if na.size/=e.sig.args.size then-- AS_ARG_DEC::size INT::is_eq ELT::sig SIG::args ARRAY{1}::size BOOL::not
err_loc(as); -- TRANS::err_loc
err("Compiler error, TRANS::transform_rout_elt size bug.");-- TRANS::err
return void end;
loop while!(i<e.sig.args.size);-- INT::is_lt ELT::sig SIG::args ARRAY{1}::size
l::=#AM_LOCAL_EXPR(as.source, na.name, e.sig.args[i].tp, na.tp);-- AM_LOCAL_EXPR::create AS_ROUT_DEF::source AS_ARG_DEC::name ELT::sig SIG::args ARRAY{1}::aget ARG::tp AS_ARG_DEC::tp
r[i+1]:=#AM_FORMAL_ARG(l, MODE::create_from_as(na.mode));-- AM_ROUT_DEF::aset INT::plus AM_FORMAL_ARG::create MODE::create_from_as AS_ARG_DEC::mode
i:=i+1; na:=na.next end; -- INT::plus AS_ARG_DEC::next
cur_rout:=r;-- TRANS::cur_rout
if prog.psather then transform_pSather_rout_elt_stuff(as) end;-- TRANS::prog PROG::psather TRANS::transform_pSather_rout_elt_stuff
pres:AM_PRE_STMT;
if ~void(as.pre_e) then-- AS_ROUT_DEF::pre_e BOOL::not
if prog.pre_checks and ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::prog PROG::pre_checks TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
in_pre:=true;-- TRANS::in_pre
pres:=#AM_PRE_STMT(as.source);-- AM_PRE_STMT::create AS_ROUT_DEF::source
pres.tp:=impl.tp;-- AM_PRE_STMT::tp TRANS::impl IMPL::tp
pres.test:=transform_expr(as.pre_e,TP_BUILTIN::bool);-- AM_PRE_STMT::test TRANS::transform_expr AS_ROUT_DEF::pre_e TP_BUILTIN::bool
if void(pres.test) then pres:=void end;-- AM_PRE_STMT::test
in_pre:=false end;-- TRANS::in_pre
--posts:AM_POST_STMT;
post_stmt:=void;-- TRANS::post_stmt
if ~void(as.post_e) then-- AS_ROUT_DEF::post_e BOOL::not
in_post:=true;-- TRANS::in_post
if prog.post_checks and ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::prog PROG::post_checks TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
post_stmt:=#AM_POST_STMT(as.source);-- TRANS::post_stmt AM_POST_STMT::create AS_ROUT_DEF::source
post_stmt.tp:=impl.tp;-- TRANS::post_stmt AM_POST_STMT::tp TRANS::impl IMPL::tp
post_stmt.test:=transform_expr(as.post_e,TP_BUILTIN::bool);-- TRANS::post_stmt AM_POST_STMT::test TRANS::transform_expr AS_ROUT_DEF::post_e TP_BUILTIN::bool
if void(post_stmt.test) then post_stmt:=void end; -- TRANS::post_stmt AM_POST_STMT::test TRANS::post_stmt
in_post:=false end;-- TRANS::in_post
--inv:AM_INVARIANT_STMT;
inv_stmt:=void;-- TRANS::inv_stmt
if ~e.is_private and ~in_invariant then-- ELT::is_private BOOL::not TRANS::in_invariant BOOL::not
isig:SIG:=impl.invariant_sig;-- TRANS::impl IMPL::invariant_sig
if ~void(isig) then-- BOOL::not
inv_stmt:=#AM_INVARIANT_STMT(as.source); -- TRANS::inv_stmt AM_INVARIANT_STMT::create AS_ROUT_DEF::source
inv_stmt.sig:=isig;-- TRANS::inv_stmt AM_INVARIANT_STMT::sig
icall::=#AM_ROUT_CALL_EXPR(1,as.source);-- AM_ROUT_CALL_EXPR::create AS_ROUT_DEF::source
icall.fun:=isig;-- AM_ROUT_CALL_EXPR::fun
cur_se.mark_context(icall);-- TRANS::cur_se SE_CONTEXT::mark_context
r.calls:=r.calls.push(icall) end end;-- AM_ROUT_DEF::calls AM_ROUT_DEF::calls FLIST{1}::push
code:$AM_STMT;
-- if is_array_sig(e.srcsig) then
-- code:=transform_array_body(e);
-- else
code:=transform_stmt_list(as.body);-- TRANS::transform_stmt_list AS_ROUT_DEF::body
-- end;
r.code:=init_stmts; -- First do the initial statments.-- AM_ROUT_DEF::code TRANS::init_stmts
if void(r.code) then -- AM_ROUT_DEF::code
r.code:=pres -- Then the pre statement.-- AM_ROUT_DEF::code
else r.code.append(pres) end;-- AM_ROUT_DEF::code
if void(r.code) then -- AM_ROUT_DEF::code
r.code:=code -- Then the body statement.-- AM_ROUT_DEF::code
else r.code.append(code) end; -- AM_ROUT_DEF::code
if void(as.ret_dec) then-- AS_ROUT_DEF::ret_dec
-- if there's no return value, emit the post and invariant
-- checks at the end; otherwise, they will be emitted with
-- before the return.
if void(r.code) then-- AM_ROUT_DEF::code
r.code:=post_stmt -- Then the post statement. -- AM_ROUT_DEF::code TRANS::post_stmt
else r.code.append(post_stmt) end;-- AM_ROUT_DEF::code TRANS::post_stmt
if void(r.code) then-- AM_ROUT_DEF::code
r.code:=inv_stmt -- Then the invariant statement. -- AM_ROUT_DEF::code TRANS::inv_stmt
else r.code.append(inv_stmt) end;-- AM_ROUT_DEF::code TRANS::inv_stmt
end;
return r;
end;
private is_some_array_sig(s:SIG):BOOL is
-- True if `s' is a function/iter in AVAL or AREF.
if void(s) then return false end;
stp::=s.tp;
typecase stp
when TP_CLASS then
if stp.name/=IDENT_BUILTIN::AREF_ident and
stp.name/=IDENT_BUILTIN::AVAL_ident then return false end;
if void(stp.params) then return false end;
if stp.params.size/=1 then return false end;
return true
else return false;
end;
end;
private is_array_sig(s:SIG):BOOL is
-- True if `s' is `aset' or `aget' in AVAL or AREF.
if void(s) then return false end;
stp::=s.tp;
typecase stp
when TP_CLASS then
if stp.name/=IDENT_BUILTIN::AREF_ident and
stp.name/=IDENT_BUILTIN::AVAL_ident then return false end;
if void(stp.params) then return false end;
if stp.params.size/=1 then return false end;
if s.name/=IDENT_BUILTIN::aget_ident and
s.name/=IDENT_BUILTIN::aset_ident then return false end;
return true
else return false;
end;
end;
is_aget_sig(s:SIG):BOOL is
-- True if `s' is`aget'
if void(s) then return false end;
stp::=s.tp;-- SIG::tp
typecase stp
when TP_CLASS then
-- note that external array classes may have no parameters,
-- but internal ones must have a single parameter
-- This may need to be changed later when the multidimensional
-- array story for external classes is clear (and it is decided
-- whether external classes should be built in or not)
-- Another solution is to have, say, AREF{F_INTEGER} instead of
-- F_INTEGER_ARR - then external arrays will behave similar to intern.
if ~void(stp.params) then -- TP_CLASS::params BOOL::not
if stp.params.size/=1 then return false end;-- TP_CLASS::params ARRAY{1}::size INT::is_eq BOOL::not
end;
if s.name/=IDENT_BUILTIN::aget_ident then return false end;-- SIG::name IDENT::is_eq IDENT_BUILTIN::aget_ident BOOL::not
return true;
else
return false;
end;
end;
transform_stmt_list(l:AS_STMT_LIST):$AM_STMT is
-- A list of AM_STMT's which implements all the statements in
-- the source list `l'.
if void(l) then return void end;
s : $AS_STMT := l.stmts;
if void(s) then return void end;
osize:INT;
if ~void(active_locals) then osize:=active_locals.size end;
r:$AM_STMT;
loop while!(~void(s));
if void(r) then r:=transform_stmt(s)
else r.append(transform_stmt(s)) end;
s:=s.next
end;
-- Close off the scope:
if ~void(active_locals) then
loop while!(active_locals.size>osize);
ignore::=active_locals.pop end;
end;
return r;
end;
transform_stmt(s:$AS_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
if void(s) then return void end;
r:$AM_STMT;
typecase s
when AS_DEC_STMT then r:= transform_dec_stmt(s)-- TRANS::transform_dec_stmt
when AS_ASSIGN_STMT then r:= transform_assign_stmt(s)-- TRANS::transform_assign_stmt
when AS_IF_STMT then r:= transform_if_stmt(s)-- TRANS::transform_if_stmt
when AS_LOOP_STMT then r:= transform_loop_stmt(s)-- TRANS::transform_loop_stmt
when AS_RETURN_STMT then r:= transform_return_stmt(s)-- TRANS::transform_return_stmt
when AS_YIELD_STMT then r:= transform_yield_stmt(s)-- TRANS::transform_yield_stmt
when AS_QUIT_STMT then r:= transform_quit_stmt(s)-- TRANS::transform_quit_stmt
when AS_CASE_STMT then r:= transform_case_stmt(s)-- TRANS::transform_case_stmt
when AS_TYPECASE_STMT then r:= transform_typecase_stmt(s)-- TRANS::transform_typecase_stmt
when AS_ASSERT_STMT then r:= transform_assert_stmt(s)-- TRANS::transform_assert_stmt
when AS_PROTECT_STMT then r:= transform_protect_stmt(s)-- TRANS::transform_protect_stmt
when AS_RAISE_STMT then r:= transform_raise_stmt(s)-- TRANS::transform_raise_stmt
when AS_EXPR_STMT then r:= transform_expr_stmt(s)-- TRANS::transform_expr_stmt
else if prog.psather then r := transform_pSather_stmt(s) end;-- TRANS::prog PROG::psather TRANS::transform_pSather_stmt
end;
return r;
end;
transform_dec_stmt(s:AS_DEC_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
l:AM_LOCAL_EXPR:=local_with_name(s.name);-- TRANS::local_with_name AS_DEC_STMT::name
err_loc(s);-- TRANS::err_loc
if ~void(l) then -- BOOL::not
err("This local variable declaration is in the scope of " +-- TRANS::err
l.name.str + ":" + l.tp_at.str +-- STR::plus AM_LOCAL_EXPR::name IDENT::str STR::plus STR::plus AM_LOCAL_EXPR::tp_at
" which has the same name."); return void end;-- STR::plus
the_tp:$TP := tp_of(s.tp);-- TRANS::tp_of AS_DEC_STMT::tp
if the_tp.is_partial and (s.tp.kind /= AS_TYPE_SPEC::same) then-- AS_DEC_STMT::tp AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::same BOOL::not
err("Partial classes cannot be instantiated.");-- TRANS::err
end;
l:=#AM_LOCAL_EXPR(s.source, s.name, the_tp, s.tp); -- AM_LOCAL_EXPR::create AS_DEC_STMT::source AS_DEC_STMT::name AS_DEC_STMT::tp
l.needs_init:=true; -- AM_LOCAL_EXPR::needs_init
add_local(l);-- TRANS::add_local
return void;
end;
transform_assign_stmt(s:AS_ASSIGN_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
if void(s.lhs_expr) then -- AS_ASSIGN_STMT::lhs_expr
r::=transform_assign_dec_stmt(s);-- TRANS::transform_assign_dec_stmt
return r;
end;
lhs:$AS_EXPR:=s.lhs_expr; err_loc(lhs); -- AS_ASSIGN_STMT::lhs_expr TRANS::err_loc
typecase lhs
when AS_CALL_EXPR then
if lhs.is_array then -- AS_CALL_EXPR::is_array
r::=transform_array_assign_stmt(lhs,s);-- TRANS::transform_array_assign_stmt
return r;
else
r::= transform_call_assign_stmt(lhs,s);-- TRANS::transform_call_assign_stmt
return r;
end;
when AS_SELF_EXPR then
err("It is illegal to assign to `self'.");-- TRANS::err
when AS_VOID_EXPR then
err("It is illegal to assign to `void'.");-- TRANS::err
when AS_IS_VOID_EXPR then
err("It is illegal to assign to a `void' test expression.");-- TRANS::err
when AS_ARRAY_EXPR then
err("It is illegal to assign to an array expression.");-- TRANS::err
when AS_CREATE_EXPR then
err("It is illegal to assign to a creation expression.");-- TRANS::err
when AS_BOUND_CREATE_EXPR then
err("It is illegal to assign to a bound create expression.");-- TRANS::err
when AS_AND_EXPR then
err("It is illegal to assign to an `and' expression.");-- TRANS::err
when AS_OR_EXPR then
err("It is illegal to assign to an `or' expression."); -- TRANS::err
when AS_EXCEPT_EXPR then
err("It is illegal to assign to an `exception' expression.");-- TRANS::err
when AS_NEW_EXPR then
err("It is illegal to assign to a `new' expression.");-- TRANS::err
when AS_INITIAL_EXPR then
err("It is illegal to assign to an `initial' expression.");-- TRANS::err
when AS_BREAK_EXPR then
err("It is illegal to assign to a `break!' expression."); -- TRANS::err
when AS_RESULT_EXPR then
err("It is illegal to assign to a `result' expression."); -- TRANS::err
when AS_BOOL_LIT_EXPR then
err("It is illegal to assign to a boolean literal."); -- TRANS::err
when AS_CHAR_LIT_EXPR then
err("It is illegal to assign to a character literal."); -- TRANS::err
when AS_STR_LIT_EXPR then
err("It is illegal to assign to a string literal."); -- TRANS::err
when AS_INT_LIT_EXPR then
err("It is illegal to assign to an integer literal."); -- TRANS::err
when AS_FLT_LIT_EXPR then
err("It is illegal to assign to a floating point literal.");-- TRANS::err
when AS_CLUSTER_EXPR then
err("It is illegal to assign to an `cluster' expression.");-- TRANS::err
when AS_CLUSTER_SIZE_EXPR then
err("It is illegal to assign to an `cluster_size' expression."); -- TRANS::err
else if prog.psather then transform_pSather_assign_stmt_err(s) end;-- TRANS::prog PROG::psather TRANS::transform_pSather_assign_stmt_err
end;
return void;
end;
transform_assign_dec_stmt(s:AS_ASSIGN_STMT):$AM_STMT
-- A list of AM_STMT's which implements the source statement `s'.
-- This is an assignment which declares a local variable and
-- assigns to it.
pre void(s) or void(s.lhs_expr) is-- AS_ASSIGN_STMT::lhs_expr
if void(s) then return void end;
l:AM_LOCAL_EXPR:=local_with_name(s.name);-- TRANS::local_with_name AS_ASSIGN_STMT::name
err_loc(s);-- TRANS::err_loc
if ~void(l) then -- BOOL::not
err("This local variable declaration is in the scope of " +-- TRANS::err
l.name.str + ":" + l.tp_at.str +-- STR::plus AM_LOCAL_EXPR::name IDENT::str STR::plus STR::plus AM_LOCAL_EXPR::tp_at
" which has the same name."); return void end;-- STR::plus
l:=#AM_LOCAL_EXPR(s.source,s.name,void); -- AM_LOCAL_EXPR::create AS_ASSIGN_STMT::source AS_ASSIGN_STMT::name
if in_protect_body then l.is_volatile:=true end;-- TRANS::in_protect_body AM_LOCAL_EXPR::is_volatile
r:AM_ASSIGN_STMT;
if ~void(s.tp) then -- Explicitly specified type ":FOO:="-- AS_ASSIGN_STMT::tp BOOL::not
l.tp_at:=tp_of(s.tp);-- AM_LOCAL_EXPR::tp_at TRANS::tp_of AS_ASSIGN_STMT::tp
if l.tp_at.is_partial and (s.tp.kind /= AS_TYPE_SPEC::same) then-- AM_LOCAL_EXPR::tp_at AS_ASSIGN_STMT::tp AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::same BOOL::not
err("Partial classes cannot be instantiated.");-- TRANS::err
end;
l.as_type := s.tp;-- AM_LOCAL_EXPR::as_type AS_ASSIGN_STMT::tp
if void(l.tp_at) then -- AM_LOCAL_EXPR::tp_at
err_loc(s);-- TRANS::err_loc
err("Compiler error, TRANS::transform_assign_dec_stmt, "
"bad type."); -- TRANS::err
return void end;
add_local(l); -- Add it here since type is known.-- TRANS::add_local
r:=#AM_ASSIGN_STMT(s.source); r.dest:=l; -- AM_ASSIGN_STMT::create AS_ASSIGN_STMT::source AM_ASSIGN_STMT::dest
r.src:=transform_expr(s.rhs,l.tp);-- AM_ASSIGN_STMT::src TRANS::transform_expr AS_ASSIGN_STMT::rhs AM_LOCAL_EXPR::tp
if void(r.src) then return void end;-- AM_ASSIGN_STMT::src
return r
end;
-- If you get here, then the declared type is inferred.
rhs:$AS_EXPR:=s.rhs; err_loc(s.rhs);-- AS_ASSIGN_STMT::rhs TRANS::err_loc AS_ASSIGN_STMT::rhs
typecase rhs
when AS_VOID_EXPR then
err("The right hand side of `::=' may not be `void'.");-- TRANS::err
return void;
when AS_CREATE_EXPR then
if void(rhs.tp) then-- AS_CREATE_EXPR::tp
err("Creation expressions on the right hand side "
"of `::=' must explicitly specify a type."); return void end;-- TRANS::err
if tp_of(rhs.tp).is_partial and -- TRANS::tp_of AS_CREATE_EXPR::tp
(rhs.tp.kind /= AS_TYPE_SPEC::same) then-- AS_CREATE_EXPR::tp AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::same BOOL::not
err("Partial classes cannot be instantiated."); -- TRANS::err
end;
when AS_ARRAY_EXPR then
err("The right hand side of `::=' may not be an array "
"creation expression."); return void-- TRANS::err
else end;
r:=#AM_ASSIGN_STMT(s.source); r.dest:=l; -- AM_ASSIGN_STMT::create AS_ASSIGN_STMT::source AM_ASSIGN_STMT::dest
r.src:=transform_expr(s.rhs,void);-- AM_ASSIGN_STMT::src TRANS::transform_expr AS_ASSIGN_STMT::rhs
if void(r.src) then -- AM_ASSIGN_STMT::src
l.tp_at:=TP_BUILTIN::dollar_ob; add_local(l); return void end;-- AM_LOCAL_EXPR::tp_at TP_BUILTIN::dollar_ob TRANS::add_local
l.tp_at:=r.src.tp; -- AM_LOCAL_EXPR::tp_at AM_ASSIGN_STMT::src
add_local(l); -- TRANS::add_local
if prog.psather then-- TRANS::prog PROG::psather
rhsam ::= r.src;-- AM_ASSIGN_STMT::src
typecase rhsam
when AM_LOCAL_EXPR then l.as_type := rhsam.as_type-- AM_LOCAL_EXPR::as_type AM_LOCAL_EXPR::as_type
when AM_ROUT_CALL_EXPR then l.as_type := rhsam.as_type-- AM_LOCAL_EXPR::as_type AM_ROUT_CALL_EXPR::as_type
when AM_GLOBAL_EXPR then l.as_type := rhsam.as_type-- AM_LOCAL_EXPR::as_type AM_GLOBAL_EXPR::as_type
when AM_ATTR_EXPR then l.as_type := rhsam.as_type-- AM_LOCAL_EXPR::as_type AM_ATTR_EXPR::as_type
else
end;
end;
return r;
end;
transform_array_assign_stmt(l:AS_CALL_EXPR,s:AS_ASSIGN_STMT):$AM_STMT
-- A list of AM_STMT's which implements the source statement `s'.
-- This is an assignment to the call expression `l' which has
-- `is_array' equal to true. So we know it is one of the forms:
-- "[a,b,c]:=d" or "e[a,b,c]:=d" and should become "aset(a,b,c,d)"
-- or "e.aset(a,b,c,d)".
pre l.is_array=true is-- AS_CALL_EXPR::is_array BOOL::is_eq
-- We change the call object by giving it the name "aset" adding
-- on the righthand side as an extra argument, transform it and
-- then change it back.
r::=#AM_EXPR_STMT(l.source);-- AM_EXPR_STMT::create AS_CALL_EXPR::source
l.name:=IDENT_BUILTIN::aset_ident; l.is_array:=false; -- AS_CALL_EXPR::name IDENT_BUILTIN::aset_ident AS_CALL_EXPR::is_array
if void(l.args) then -- AS_CALL_EXPR::args
l.args:=s.rhs; -- AS_CALL_EXPR::args AS_ASSIGN_STMT::rhs
-- Set the modes of newly create args
a ::= l.args;-- AS_CALL_EXPR::args
loop while!(~void(a));-- BOOL::not
mode::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);-- AS_ARG_MODE::create AS_ARG_MODE::in_mode
if void(l.modes) then-- AS_CALL_EXPR::modes
l.modes := mode;-- AS_CALL_EXPR::modes
else
l.modes.append(mode);-- AS_CALL_EXPR::modes AS_ARG_MODE::append
end;
a:=a.next;
end;
r.expr:=transform_call_expr(l,void,false); -- AM_EXPR_STMT::expr TRANS::transform_call_expr
l.args:=void; l.modes:=void;-- AS_CALL_EXPR::args AS_CALL_EXPR::modes
else
lst::=l.args;-- AS_CALL_EXPR::args
modes::=l.modes;-- AS_CALL_EXPR::modes
loop until!(void(lst.next));
lst:=lst.next;
modes:=modes.next;-- AS_ARG_MODE::next
end;
added_args::=s.rhs;-- AS_ASSIGN_STMT::rhs
added_modes:AS_ARG_MODE;
--set modes for newly added args
loop while!(~void(added_args));-- BOOL::not
mode::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);-- AS_ARG_MODE::create AS_ARG_MODE::in_mode
if void(added_modes) then
added_modes:=mode;
else
added_modes.append(mode);-- AS_ARG_MODE::append
end;
added_args:=added_args.next;
end;
lst.next:=s.rhs;-- AS_ASSIGN_STMT::rhs
modes.next:=added_modes;-- AS_ARG_MODE::next
r.expr:=transform_call_expr(l,void,false); -- AM_EXPR_STMT::expr TRANS::transform_call_expr
lst.next:=void;
end;
l.name:=void; l.is_array:=true;-- AS_CALL_EXPR::name AS_CALL_EXPR::is_array
if ~void(r.expr) then return r else return void end; -- Ivin. -- AM_EXPR_STMT::expr BOOL::not
end;
transform_call_assign_stmt(l:AS_CALL_EXPR,s:AS_ASSIGN_STMT):$AM_STMT
-- A list of AM_STMT's which implements the source statement `s'.
-- This is an assignment to the call expression `l' which has
-- `is_array' equal to false.
pre l.is_array=false is -- AS_CALL_EXPR::is_array BOOL::is_eq
if ~void(l.args) then -- One of the forms: -- AS_CALL_EXPR::args BOOL::not
-- "a(5):=foo", "x.a(5):=foo", or "A::a(5):=foo"
err_loc(l);-- TRANS::err_loc
err("It is illegal to assign to a call with arguments."); -- TRANS::err
return void end;
if void(l.ob) and void(l.tp) then-- AS_CALL_EXPR::ob AS_CALL_EXPR::tp
-- "a:=foo", This is the case that might be a local variable.
loc:AM_LOCAL_EXPR:=local_with_name(l.name);-- TRANS::local_with_name AS_CALL_EXPR::name
if ~void(loc) then r::=transform_local_assign_stmt(loc,s);-- BOOL::not TRANS::transform_local_assign_stmt
return r;
end end;
-- At this point we are either of the form "a:=foo" and not a
-- local, "x.a:=foo" or "A::x:=foo".
-- We change the call object by adding on the righthand side as an
-- argument, transform it and then put it back to void:
l.args:=s.rhs;-- AS_CALL_EXPR::args AS_ASSIGN_STMT::rhs
-- It is important to set modes of newly created args
a ::= l.args;-- AS_CALL_EXPR::args
loop while!(~void(a));-- BOOL::not
mode::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);-- AS_ARG_MODE::create AS_ARG_MODE::in_mode
if void(l.modes) then-- AS_CALL_EXPR::modes
l.modes := mode;-- AS_CALL_EXPR::modes
else
l.modes.append(mode);-- AS_CALL_EXPR::modes AS_ARG_MODE::append
end;
a:=a.next;
end;
r::=#AM_EXPR_STMT(l.source);-- AM_EXPR_STMT::create AS_CALL_EXPR::source
r.expr:=transform_call_expr(l,void,false);-- AM_EXPR_STMT::expr TRANS::transform_call_expr
l.args:=void; -- AS_CALL_EXPR::args
if ~void(r.expr) then return r else return void end; -- Ivin.-- AM_EXPR_STMT::expr BOOL::not
end;
transform_local_assign_stmt(loc:AM_LOCAL_EXPR, s:AS_ASSIGN_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source assignment
-- `s'. At this point we know it is an assignment to the local
-- variable `loc'.
if loc.no_assign then-- AM_LOCAL_EXPR::no_assign
err_loc(s); -- TRANS::err_loc
err("It is illegal to assign to the typecase variable.");-- TRANS::err
return void;
end;
r::=#AM_ASSIGN_STMT(s.source);-- AM_ASSIGN_STMT::create AS_ASSIGN_STMT::source
-- Does the assignment to the local.
r.dest:=loc; -- Make the local be the destination.-- AM_ASSIGN_STMT::dest
if in_protect_body then loc.is_volatile:=true end;-- TRANS::in_protect_body AM_LOCAL_EXPR::is_volatile
r.src:=transform_expr(s.rhs,loc.tp);-- AM_ASSIGN_STMT::src TRANS::transform_expr AS_ASSIGN_STMT::rhs AM_LOCAL_EXPR::tp
if void(r.src) then return void end; -- Type error.-- AM_ASSIGN_STMT::src
if prog.psather then transform_pSather_local_assign(loc,s) end;-- TRANS::prog PROG::psather TRANS::transform_pSather_local_assign
return r;
end;
transform_if_stmt(s:AS_IF_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
r::=#AM_IF_STMT(s.source);
r.test:=transform_expr(s.test, TP_BUILTIN::bool);
if void(r.test) then return void end; -- Not a boolean.
r.if_true:=transform_stmt_list(s.then_part);
r.if_false:=transform_stmt_list(s.else_part);
return r;
end;
-----------
transform_loop_stmt(s:AS_LOOP_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
ol:AM_LOOP_STMT:=cur_loop; -- Save the old loop object, if any.-- TRANS::cur_loop
r::=#AM_LOOP_STMT(s.source); -- AM_LOOP_STMT::create AS_LOOP_STMT::source
cur_loop:=r; -- Any enclosed iters will add themselves.-- TRANS::cur_loop
old_in_protect_but_not_loop:BOOL:=in_protect_but_not_loop;-- TRANS::in_protect_but_not_loop
in_protect_but_not_loop:=false;-- TRANS::in_protect_but_not_loop
r.body:=transform_stmt_list(s.body);-- AM_LOOP_STMT::body TRANS::transform_stmt_list AS_LOOP_STMT::body
in_protect_but_not_loop:=old_in_protect_but_not_loop;-- TRANS::in_protect_but_not_loop
if ~void(ol) and ~void(r) then-- BOOL::not BOOL::not
ol.has_yield:=ol.has_yield or r.has_yield; -- Prop "has_yield".-- AM_LOOP_STMT::has_yield AM_LOOP_STMT::has_yield AM_LOOP_STMT::has_yield
end;
cur_loop:=ol; -- Restore the old loop object, if any.-- TRANS::cur_loop
if prog.prolix and ~prog.loops_seen.test(s.source) then-- TRANS::prog PROG::prolix TRANS::prog PROG::loops_seen FSET{1}::test AS_LOOP_STMT::source BOOL::not
-- Number of iters, not including break!, while! or until!.
num::=r.its.size;-- AM_LOOP_STMT::its FLIST{1}::size
-- Number with hot arguments
hots::=0;
loop
sig::=r.its.elt!.fun;-- AM_LOOP_STMT::its FLIST{1}::elt! AM_ITER_CALL_EXPR::fun
if ~void(sig.hot) then-- SIG::hot BOOL::not
loop
if sig.hot.elt! then-- SIG::hot ARRAY{1}::elt!
hots:=hots+1;-- INT::plus
break!;
end
end
end
end;
-- Make sure there's a place for the statistics
if void(prog.itercounts) then prog.itercounts:=#(10) end;-- TRANS::prog PROG::itercounts TRANS::prog PROG::itercounts ARRAY{1}::create
if void(prog.hotcounts) then prog.hotcounts:=#(10) end;-- TRANS::prog PROG::hotcounts TRANS::prog PROG::hotcounts ARRAY{1}::create
-- Update the histograms
prog.itercounts[num]:=prog.itercounts[num]+1;-- TRANS::prog PROG::itercounts ARRAY{1}::aset TRANS::prog PROG::itercounts ARRAY{1}::aget INT::plus
prog.hotcounts[hots]:=prog.hotcounts[hots]+1;-- TRANS::prog PROG::hotcounts ARRAY{1}::aset TRANS::prog PROG::hotcounts ARRAY{1}::aget INT::plus
-- Make sure never update stats for this one again
prog.loops_seen:=prog.loops_seen.insert(s.source);-- TRANS::prog PROG::loops_seen TRANS::prog PROG::loops_seen FSET{1}::insert AS_LOOP_STMT::source
end;
if ~void(cur_se) and INT::maxint-cur_se.weight>10 then cur_se.weight:=cur_se.weight+10; end;-- TRANS::cur_se BOOL::not INT::maxint TRANS::cur_se SE_CONTEXT::weight INT::is_lt TRANS::cur_se SE_CONTEXT::weight TRANS::cur_se SE_CONTEXT::weight INT::plus
return r;
end;
transform_return_stmt(s:AS_RETURN_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
if is_iter then return_in_iter_err(s); return void end;-- TRANS::is_iter TRANS::return_in_iter_err
--pSather
if is_in_par_or_fork then return_in_par_fork_err(s); return void; end;-- TRANS::is_in_par_or_fork TRANS::return_in_par_fork_err
if ~void(s.next) then stmts_after_return_err(s) end;-- AS_RETURN_STMT::next BOOL::not TRANS::stmts_after_return_err
rtp:$TP:=cur_rout.sig.ret; -- The return type if any. -- TRANS::cur_rout AM_ROUT_DEF::sig SIG::ret
res:$AM_STMT;
if void(s.val) then -- No return value specified.-- AS_RETURN_STMT::val
if ~void(rtp) then -- BOOL::not
missing_return_value_err(s,rtp); return void end;-- TRANS::missing_return_value_err
res:=#AM_RETURN_STMT(s.source);-- AM_RETURN_STMT::create AS_RETURN_STMT::source
else -- with return value.
a::=#AM_ASSIGN_STMT(s.source);-- AM_ASSIGN_STMT::create AS_RETURN_STMT::source
a.dest:=cur_rout.rres;-- AM_ASSIGN_STMT::dest TRANS::cur_rout AM_ROUT_DEF::rres
if void(rtp) then
extra_return_value_err(s, cur_rout.sig); return void end;-- TRANS::extra_return_value_err TRANS::cur_rout AM_ROUT_DEF::sig
r::=#AM_RETURN_STMT(s.source); -- AM_RETURN_STMT::create AS_RETURN_STMT::source
a.next:=r;-- AM_ASSIGN_STMT::next
r.val:=cur_rout.rres;-- AM_RETURN_STMT::val TRANS::cur_rout AM_ROUT_DEF::rres
a.src:=transform_expr(s.val,rtp);-- AM_ASSIGN_STMT::src TRANS::transform_expr AS_RETURN_STMT::val
if void(a.src) then return void end; -- wrong type.-- AM_ASSIGN_STMT::src
res:=a;
end;
if ~void(inv_stmt) then-- TRANS::inv_stmt BOOL::not
stmt::=inv_stmt.copy;-- TRANS::inv_stmt AM_INVARIANT_STMT::copy
stmt.next:=res.next;
res.next:=stmt;
end;
if ~void(post_stmt) then-- TRANS::post_stmt BOOL::not
stmt::=post_stmt.copy;-- TRANS::post_stmt AM_POST_STMT::copy
stmt.next:=res.next;
res.next:=stmt;
end;
return res;
end;
return_in_iter_err(s:AS_RETURN_STMT) is
err_loc(s);-- TRANS::err_loc
err("`return' statements may not appear in iters."); -- TRANS::err
end;
stmts_after_return_err(s:AS_RETURN_STMT) is
err_loc(s);-- TRANS::err_loc
err("No statements may follow `return' in a statment list.");-- TRANS::err
end;
missing_return_value_err(s:AS_RETURN_STMT, tp:$TP) is
err_loc(s);-- TRANS::err_loc
err("A return value of type: " + tp.str +-- TRANS::err STR::plus
" must be specified."); -- STR::plus
end;
extra_return_value_err(s:AS_RETURN_STMT, sig:SIG) is
err_loc(s);-- TRANS::err_loc
err("No return value should be provided for the signature: " + -- TRANS::err
sig.str + "."); -- STR::plus SIG::str STR::plus
end;
return_in_par_fork_err(s:AS_RETURN_STMT) is
err_loc(s);-- TRANS::err_loc
err("`return' statements may not appear in `par', `parloop', or `fork'.") -- TRANS::err
end;
transform_yield_stmt(s:AS_YIELD_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
if ~is_iter then yield_in_rout_err(s); return void end;-- TRANS::is_iter BOOL::not TRANS::yield_in_rout_err
if in_protect_body then yield_in_protect_err(s); return void end;-- TRANS::in_protect_body TRANS::yield_in_protect_err
if in_protect_then then yield_in_protect_err(s); return void end;-- TRANS::in_protect_then TRANS::yield_in_protect_err
--pSather
if is_in_par_or_fork then yield_in_par_fork_err(s); return void end;-- TRANS::is_in_par_or_fork TRANS::yield_in_par_fork_err
if is_in_lock and ~void(cur_se) then cur_se.has_yield_in_lock:=true; end;-- TRANS::is_in_lock TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_yield_in_lock
rtp:$TP:=cur_rout.sig.ret; -- The return type if any. -- TRANS::cur_rout AM_ROUT_DEF::sig SIG::ret
if void(s.val) then -- No return value specified.-- AS_YIELD_STMT::val
if ~void(rtp) then -- BOOL::not
missing_yield_value_err(s,rtp); return void end;-- TRANS::missing_yield_value_err
y::=#AM_YIELD_STMT(s.source); -- AM_YIELD_STMT::create AS_YIELD_STMT::source
cur_yield_ind:=cur_yield_ind+1; y.ret:=cur_yield_ind; -- TRANS::cur_yield_ind TRANS::cur_yield_ind INT::plus AM_YIELD_STMT::ret TRANS::cur_yield_ind
cur_rout.num_yields:=cur_rout.num_yields+1;-- TRANS::cur_rout AM_ROUT_DEF::num_yields TRANS::cur_rout AM_ROUT_DEF::num_yields INT::plus
if ~void(cur_loop) then cur_loop.has_yield:=true end;-- TRANS::cur_loop BOOL::not TRANS::cur_loop AM_LOOP_STMT::has_yield
return y
else -- with return value.
if void(rtp) then
extra_yield_value_err(s, cur_rout.sig); return void end;-- TRANS::extra_yield_value_err TRANS::cur_rout AM_ROUT_DEF::sig
r::=#AM_YIELD_STMT(s.source);-- AM_YIELD_STMT::create AS_YIELD_STMT::source
r.val:=transform_expr(s.val,rtp);-- AM_YIELD_STMT::val TRANS::transform_expr AS_YIELD_STMT::val
if void(r.val) then return void end; -- wrong type. -- AM_YIELD_STMT::val
cur_yield_ind:=cur_yield_ind+1; r.ret:=cur_yield_ind; -- TRANS::cur_yield_ind TRANS::cur_yield_ind INT::plus AM_YIELD_STMT::ret TRANS::cur_yield_ind
cur_rout.num_yields:=cur_rout.num_yields+1; -- TRANS::cur_rout AM_ROUT_DEF::num_yields TRANS::cur_rout AM_ROUT_DEF::num_yields INT::plus
if ~void(cur_loop) then cur_loop.has_yield:=true end; -- TRANS::cur_loop BOOL::not TRANS::cur_loop AM_LOOP_STMT::has_yield
return r;
end;
end;
yield_in_rout_err(s:AS_YIELD_STMT) is
err_loc(s);-- TRANS::err_loc
err("`yield' statements may not appear in routines."); -- TRANS::err
end;
yield_in_par_fork_err(s:AS_YIELD_STMT) is
err_loc(s);-- TRANS::err_loc
err("`yield' statements may not appear in `par', `parloop', or `fork'."); -- TRANS::err
end;
yield_in_protect_err(s:AS_YIELD_STMT) is
err_loc(s);-- TRANS::err_loc
err("`yield' statements may not appear in `protect'."); -- TRANS::err
end;
missing_yield_value_err(s:AS_YIELD_STMT, tp:$TP) is
err_loc(s);-- TRANS::err_loc
err("A yield value of type: " + tp.str + " must be specified."); -- TRANS::err STR::plus STR::plus
end;
extra_yield_value_err(s:AS_YIELD_STMT, sig:SIG) is
err_loc(s);-- TRANS::err_loc
err("No yield value should be provided for the signature: "+sig.str+"."); -- TRANS::err STR::plus SIG::str STR::plus
end;
transform_quit_stmt(s:AS_QUIT_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
--pSather
if is_in_par_or_fork then quit_in_par_fork_err(s); return void; end;-- TRANS::is_in_par_or_fork TRANS::quit_in_par_fork_err
if ~is_iter then quit_in_rout_err(s); return void end;-- TRANS::is_iter BOOL::not TRANS::quit_in_rout_err
if ~void(s.next) then stmts_after_quit_err(s) end;-- AS_QUIT_STMT::next BOOL::not TRANS::stmts_after_quit_err
r::=#AM_RETURN_STMT(s.source);-- AM_RETURN_STMT::create AS_QUIT_STMT::source
return r;
end;
quit_in_par_fork_err(s:AS_QUIT_STMT) is
err_loc(s);-- TRANS::err_loc
err("`quit' statements may not appear in `par', `parloop', or `fork'.") -- TRANS::err
end;
quit_in_rout_err(s:AS_QUIT_STMT) is
err_loc(s);-- TRANS::err_loc
err("`quit' statements may not appear in routines."); -- TRANS::err
end;
stmts_after_quit_err(s:AS_QUIT_STMT) is
err_loc(s);-- TRANS::err_loc
err("No statements may follow `quit' in a statment list."); -- TRANS::err
end;
transform_case_stmt(s:AS_CASE_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
if void(s) then return void end;
if ~void(cur_se) then cur_se.has_fatal_error:=true; end;
r::=#AM_ASSIGN_STMT(s.source);
-- Assign test to a local variable.
r.src:=transform_expr(s.test,void);
if void(r.src) then return void end;
l::=#AM_LOCAL_EXPR(s.source,void,r.src.tp);
add_local(l); r.dest:=l;
r.next:=transform_case_when(s,s.when_part,l);
return r;
end;
private const_to_switch(e:$AM_EXPR):$AM_CONST is
-- returns a constant expression that can be used in a
-- when clause of an AM_CASE_STMT, or void if it cannot
-- be used.
if void(e) then return void; end;
typecase e
when AM_CHAR_CONST then return e;
when AM_INT_CONST then return e;
when AM_GLOBAL_EXPR then return const_to_switch(e.init);-- TRANS::const_to_switch AM_GLOBAL_EXPR::init
else return void;
end;
end;
transform_case_when(s:AS_CASE_STMT, cw:AS_CASE_WHEN,
l:AM_LOCAL_EXPR):$AM_STMT is
-- A list of AM_STMT's which implements the list of "when" clauses
-- and else clause in `s' starting at `cw'. `l' is the local variable
-- with the value to test against. This will generate
-- AM_CASE_STMT's for constants and AM_IF_STMT's otherwise.
if void(cw) then -- Just do the else clause.
if s.no_else then-- AS_CASE_STMT::no_else
r::=#AM_CASE_STMT(s.source);-- AM_CASE_STMT::create AS_CASE_STMT::source
r.test:=l; r.no_else:=true; -- AM_CASE_STMT::test AM_CASE_STMT::no_else
return r;
else
r::= transform_stmt_list(s.else_part);-- TRANS::transform_stmt_list AS_CASE_STMT::else_part
return r;
end;
end;
err_loc(cw); -- In case of error.-- TRANS::err_loc
ct:$CALL_TP:=call_tp_of_expr(cw.val); -- Call type of test expr.-- TRANS::call_tp_of_expr AS_CASE_WHEN::val
v:$AM_EXPR; -- The value of test expr.
if void(ct) then v:=transform_expr(cw.val,void); -- TRANS::transform_expr AS_CASE_WHEN::val
if void(v) then return void end; -- Error!
cv:$AM_CONST:=const_to_switch(v);-- TRANS::const_to_switch
if ~void(cv) then-- BOOL::not
r::=#AM_CASE_STMT(cw.source);-- AM_CASE_STMT::create AS_CASE_WHEN::source
r.test:=l;-- AM_CASE_STMT::test
last_then:$AS_STMT:=cw.then_part.stmts;-- AS_CASE_WHEN::then_part AS_STMT_LIST::stmts
ls:FLIST{$AM_CONST}; ls:=ls.push(cv);-- FLIST{1}::push
r.tgts:=r.tgts.push(ls);-- AM_CASE_STMT::tgts AM_CASE_STMT::tgts FLIST{1}::push
r.stmts:=r.stmts.push(transform_stmt_list(cw.then_part));-- AM_CASE_STMT::stmts AM_CASE_STMT::stmts FLIST{1}::push TRANS::transform_stmt_list AS_CASE_WHEN::then_part
loop cw:=cw.next;-- AS_CASE_WHEN::next
if void(cw) then
if s.no_else then r.no_else:=true -- AS_CASE_STMT::no_else AM_CASE_STMT::no_else
else r.else_stmts:=transform_stmt_list(s.else_part) end;-- AM_CASE_STMT::else_stmts TRANS::transform_stmt_list AS_CASE_STMT::else_part
return r end;
if ~void(call_tp_of_expr(cw.val)) then -- Do an if in else.-- TRANS::call_tp_of_expr AS_CASE_WHEN::val BOOL::not
r.else_stmts:=transform_case_when(s,cw,l); -- AM_CASE_STMT::else_stmts TRANS::transform_case_when
return r end;
v:=transform_expr(cw.val,void);-- TRANS::transform_expr AS_CASE_WHEN::val
if void(v) then return void end; -- Error!
cv:=const_to_switch(v);-- TRANS::const_to_switch
if ~void(cv) then-- BOOL::not
if SYS::ob_eq(last_then,cw.then_part) then -- SYS::ob_eq AS_CASE_WHEN::then_part
-- add to same stmt
ls:=r.tgts.pop; ls:=ls.push(cv); -- AM_CASE_STMT::tgts FLIST{1}::pop FLIST{1}::push
r.tgts:=r.tgts.push(ls);-- AM_CASE_STMT::tgts AM_CASE_STMT::tgts FLIST{1}::push
else -- Start a new "when" list
ls:=void; ls:=ls.push(cv); r.tgts:=r.tgts.push(ls);-- FLIST{1}::push AM_CASE_STMT::tgts AM_CASE_STMT::tgts FLIST{1}::push
r.stmts:=r.stmts.push(transform_stmt_list(cw.then_part));-- AM_CASE_STMT::stmts AM_CASE_STMT::stmts FLIST{1}::push TRANS::transform_stmt_list AS_CASE_WHEN::then_part
end;
else -- Do an if and put it in else.
r.else_stmts:=transform_case_when(s,cw,l); -- AM_CASE_STMT::else_stmts TRANS::transform_case_when
return r
end; -- if
end; -- loop
end; -- if
end; -- if
-- At this point we need to generate an `if'. One of `ct' and
-- `v' is void, the other non-void.
cs::=#CALL_SIG;-- CALL_SIG::create
cs.tp:=l.tp_at; cs.name:=IDENT_BUILTIN::is_eq_ident;-- CALL_SIG::tp AM_LOCAL_EXPR::tp_at CALL_SIG::name IDENT_BUILTIN::is_eq_ident
cs.has_ret:=true; -- CALL_SIG::has_ret
cs.args:=#ARRAY{CALL_ARG}(1); -- CALL_SIG::args ARRAY{1}::create
if ~void(ct) then cs.args[0]:=#(ct) else cs.args[0]:=#(v.tp) end;-- BOOL::not CALL_SIG::args ARRAY{1}::aset CALL_ARG::create CALL_SIG::args ARRAY{1}::aset CALL_ARG::create
sig:SIG:=cs.lookup(tp_con.same=cs.tp); -- Arg true if in this class.-- CALL_SIG::lookup TRANS::tp_con TP_CONTEXT::same TP_CLASS::is_eq CALL_SIG::tp
if void(sig) then return void end; -- Error!
if sig.ret/=TP_BUILTIN::bool then-- SIG::ret TP_BUILTIN::bool BOOL::not
err("The `is_eq' routine corresponding to a `case' branch "
"must return a boolean."); return void end;-- TRANS::err
if void(v) then v:=transform_expr(cw.val,sig.args[0].tp) end;-- TRANS::transform_expr AS_CASE_WHEN::val SIG::args ARRAY{1}::aget ARG::tp
if void(v) then return void end; -- Error!
-- Create the call on the routine `is_eq'.
arc::=#AM_ROUT_CALL_EXPR(2,cw.source);-- AM_ROUT_CALL_EXPR::create AS_CASE_WHEN::source
arc.fun:=sig; arc[0]:=#(l); arc[1]:=#(v);-- AM_ROUT_CALL_EXPR::fun AM_ROUT_CALL_EXPR::aset AM_CALL_ARG::create AM_ROUT_CALL_EXPR::aset AM_CALL_ARG::create
r::=#AM_IF_STMT(cw.source); -- AM_IF_STMT::create AS_CASE_WHEN::source
cur_se.mark_context(arc);-- TRANS::cur_se SE_CONTEXT::mark_context
r.test:=special_inline(arc); -- AM_IF_STMT::test TRANS::special_inline
r.if_true:=transform_stmt_list(cw.then_part);-- AM_IF_STMT::if_true TRANS::transform_stmt_list AS_CASE_WHEN::then_part
r.if_false:=transform_case_when(s,cw.next,l); -- AM_IF_STMT::if_false TRANS::transform_case_when AS_CASE_WHEN::next
return r;
end;
transform_typecase_stmt(s: AS_TYPECASE_STMT): $AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
l ::= local_with_name(s.name); -- TRANS::local_with_name AS_TYPECASE_STMT::name
if void(l) then typecase_local_err(s); return void end;-- TRANS::typecase_local_err
if cur_rout.local_is_hot(l) then -- TRANS::cur_rout AM_ROUT_DEF::local_is_hot
typecase_hot_local_err(s);-- TRANS::typecase_hot_local_err
return void
end;
old_no_assign ::= l.no_assign; -- Old value (if currently in typecase).-- AM_LOCAL_EXPR::no_assign
l.no_assign:=true; -- Freeze it for the current typecase.-- AM_LOCAL_EXPR::no_assign
ltp:$TP:=l.tp; -- The declared type of the local.-- AM_LOCAL_EXPR::tp
las_type:AS_TYPE_SPEC:=l.as_type; -- The declared tye of the local.-- AM_LOCAL_EXPR::as_type
r ::= #AM_TYPECASE_STMT(s.source); -- the likely result-- AM_TYPECASE_STMT::create AS_TYPECASE_STMT::source
r.test:=l;-- AM_TYPECASE_STMT::test
r.no_else := true;-- AM_TYPECASE_STMT::no_else
r.has_void_stmts := false;-- AM_TYPECASE_STMT::has_void_stmts
wp ::= s.when_part;-- AS_TYPECASE_STMT::when_part
if ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
loop while!(~void(wp));-- BOOL::not
tp:$TP:=tp_of(wp.tp); -- Type to compare against. -- TRANS::tp_of AS_TYPECASE_WHEN::tp
if ltp.is_subtype(tp) then -- this will definitely match
r.no_else := false;-- AM_TYPECASE_STMT::no_else
r.else_stmts := transform_stmt_list(wp.then_part);-- AM_TYPECASE_STMT::else_stmts TRANS::transform_stmt_list AS_TYPECASE_WHEN::then_part
r.has_void_stmts := true;-- AM_TYPECASE_STMT::has_void_stmts
-- at this point, else_stmts contain void statements to
-- be called even if the object is void (no tag)
-- possibly issue a warning about never-reached when-parts
break!
elsif ltp.is_abstract then -- local is abstract, this requires a typetest
l.tp_at:=tp;-- AM_LOCAL_EXPR::tp_at
l.as_type := wp.tp; -- AM_LOCAL_EXPR::as_type AS_TYPECASE_WHEN::tp
r.tgts:=r.tgts.push(tp);-- AM_TYPECASE_STMT::tgts AM_TYPECASE_STMT::tgts FLIST{1}::push
r.stmts:=r.stmts.push(transform_stmt_list(wp.then_part));-- AM_TYPECASE_STMT::stmts AM_TYPECASE_STMT::stmts FLIST{1}::push TRANS::transform_stmt_list AS_TYPECASE_WHEN::then_part
l.tp_at:=ltp; -- Change the declared type back.-- AM_LOCAL_EXPR::tp_at
l.as_type := las_type; -- Change the declared type back.-- AM_LOCAL_EXPR::as_type
else
-- typecase that can never ever match -> warning ?
end;
wp:=wp.next-- AS_TYPECASE_WHEN::next
end;
l.no_assign := old_no_assign;-- AM_LOCAL_EXPR::no_assign
if r.no_else and ~s.no_else then -- no matching branch found-- AM_TYPECASE_STMT::no_else AS_TYPECASE_STMT::no_else BOOL::not
r.no_else := false;-- AM_TYPECASE_STMT::no_else
r.else_stmts := transform_stmt_list(s.else_part);-- AM_TYPECASE_STMT::else_stmts TRANS::transform_stmt_list AS_TYPECASE_STMT::else_part
r.has_void_stmts := true;-- AM_TYPECASE_STMT::has_void_stmts
-- else_stmts at this point also contain statements to
-- be executed for void (i.e. untagged) argument
end;
if void(r.stmts) then -- no typetest to be made-- AM_TYPECASE_STMT::stmts
if r.no_else then -- no match at all-- AM_TYPECASE_STMT::no_else
typecase_no_branch_err(s);-- TRANS::typecase_no_branch_err
return r; -- return void ?
else
return r.else_stmts-- AM_TYPECASE_STMT::else_stmts
end;
end;
return r;
end;
typecase_local_err(s:AS_TYPECASE_STMT) is
err_loc(s);-- TRANS::err_loc
err("The name `" + s.name.str + "' isn't a local variable."); -- TRANS::err STR::plus AS_TYPECASE_STMT::name IDENT::str STR::plus
end;
typecase_hot_local_err(s:AS_TYPECASE_STMT) is
err_loc(s);-- TRANS::err_loc
err("The typecase test local `" + s.name.str +-- TRANS::err STR::plus AS_TYPECASE_STMT::name IDENT::str
"' must not be a `!' argument to an iter."); -- STR::plus
end;
typecase_no_branch_err(s:AS_TYPECASE_STMT) is
err_loc(s);-- TRANS::err_loc
err("There are no matching branches in this typecase."); -- TRANS::err
end;
transform_assert_stmt(s:AS_ASSERT_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
r::=#AM_ASSERT_STMT(s.source);-- AM_ASSERT_STMT::create AS_ASSERT_STMT::source
r.test:=transform_expr(s.test, TP_BUILTIN::bool);-- AM_ASSERT_STMT::test TRANS::transform_expr AS_ASSERT_STMT::test TP_BUILTIN::bool
if void(r.test) then return void end; -- Not a boolean.-- AM_ASSERT_STMT::test
if prog.assert_checks and ~void(cur_se) then cur_se.has_fatal_error:=true; end;-- TRANS::prog PROG::assert_checks TRANS::cur_se BOOL::not TRANS::cur_se SE_CONTEXT::has_fatal_error
return r;
end;
transform_protect_stmt(s:AS_PROTECT_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
-- Since registers are restored after a longjump, we have to make
-- sure that no local variables which could have been changed in
-- the protect and are used later are held in registers. We are
-- a bit conservative here and make any locals which are assigned
-- to in the protect body be volatile.
r::=#AM_PROTECT_STMT(s.source);-- AM_PROTECT_STMT::create AS_PROTECT_STMT::source
old_in_protect_body:BOOL:=in_protect_body; -- TRANS::in_protect_body
in_protect_body:=true;-- TRANS::in_protect_body
old_in_protect_but_not_loop:BOOL:=in_protect_but_not_loop;-- TRANS::in_protect_but_not_loop
in_protect_but_not_loop:=true;-- TRANS::in_protect_but_not_loop
r.body:=transform_stmt_list(s.body);-- AM_PROTECT_STMT::body TRANS::transform_stmt_list AS_PROTECT_STMT::body
in_protect_body:=old_in_protect_body;-- TRANS::in_protect_body
wp:AS_PROTECT_WHEN:=s.when_part;-- AS_PROTECT_STMT::when_part
loop while!(~void(wp));-- BOOL::not
tp:$TP:=tp_of(wp.tp); -- Type to compare against.-- TRANS::tp_of AS_PROTECT_WHEN::tp
oex_tp:$TP:=ex_tp; ex_tp:=tp; -- TRANS::ex_tp TRANS::ex_tp
old_in_protect_then:BOOL:=in_protect_then; in_protect_then:=true;-- TRANS::in_protect_then TRANS::in_protect_then
r.tgts:=r.tgts.push(tp);-- AM_PROTECT_STMT::tgts AM_PROTECT_STMT::tgts FLIST{1}::push
-- if prog.psather then transform_pSather_protect_when_stuff(tp,wp,s) end;
r.stmts:=r.stmts.push(transform_stmt_list(wp.then_part));-- AM_PROTECT_STMT::stmts AM_PROTECT_STMT::stmts FLIST{1}::push TRANS::transform_stmt_list AS_PROTECT_WHEN::then_part
in_protect_then:=old_in_protect_then;-- TRANS::in_protect_then
ex_tp:=oex_tp; -- Change exception type back.-- TRANS::ex_tp
wp:=wp.next end;-- AS_PROTECT_WHEN::next
if s.no_else then -- Raise the same exception.-- AS_PROTECT_STMT::no_else
r.no_else:=true;-- AM_PROTECT_STMT::no_else
else -- Do the else statements.
oex_tp:$TP:=ex_tp; ex_tp:=TP_BUILTIN::dollar_ob;-- TRANS::ex_tp TRANS::ex_tp TP_BUILTIN::dollar_ob
old_in_protect_then:BOOL:=in_protect_then; in_protect_then:=true;-- TRANS::in_protect_then TRANS::in_protect_then
-- if prog.psather then transform_pSather_protect_else_stuff(s) end;
r.else_stmts:=transform_stmt_list(s.else_part);-- AM_PROTECT_STMT::else_stmts TRANS::transform_stmt_list AS_PROTECT_STMT::else_part
in_protect_then:=old_in_protect_then;-- TRANS::in_protect_then
ex_tp:=oex_tp; end;-- TRANS::ex_tp
in_protect_but_not_loop:=old_in_protect_but_not_loop;-- TRANS::in_protect_but_not_loop
return r;
end;
transform_raise_stmt(s:AS_RAISE_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
if ~void(s.next) then stmts_after_raise_err(s) end;-- AS_RAISE_STMT::next BOOL::not TRANS::stmts_after_raise_err
--pSather
if is_in_par_or_fork and ~in_protect_body then-- TRANS::is_in_par_or_fork TRANS::in_protect_body BOOL::not
unprotected_raise_in_par_fork_warning(s);-- TRANS::unprotected_raise_in_par_fork_warning
end;
r::=#AM_RAISE_STMT(s.source);-- AM_RAISE_STMT::create AS_RAISE_STMT::source
if ~void(cur_se) then-- TRANS::cur_se BOOL::not
cur_se.has_raise:=true;-- TRANS::cur_se SE_CONTEXT::has_raise
end;
r.val:=transform_expr(s.val,void);-- AM_RAISE_STMT::val TRANS::transform_expr AS_RAISE_STMT::val
if void(r.val) then return void end; -- AM_RAISE_STMT::val
return r;
end;
stmts_after_raise_err(s:AS_RAISE_STMT) is
err_loc(s);-- TRANS::err_loc
err("No statements may follow `raise' in a statment list."); -- TRANS::err
end;
unprotected_raise_in_par_fork_warning(s:AS_RAISE_STMT) is
err_loc(s);-- TRANS::err_loc
warning("Inside of `par', `parloop', or `fork' this `raise' "+-- TRANS::warning
"should be inside of a `protect'."); -- STR::plus
end;
transform_expr_stmt(s:AS_EXPR_STMT):$AM_STMT is
-- A list of AM_STMT's which implements the source statement `s'.
e:$AS_EXPR:=s.e; -- The expression.-- AS_EXPR_STMT::e
typecase e
when AS_BREAK_EXPR then
if void(cur_loop) then break_not_in_loop_err(s); return void end;-- TRANS::cur_loop TRANS::break_not_in_loop_err
r::= #AM_BREAK_STMT(s.source);-- AM_BREAK_STMT::create AS_EXPR_STMT::source
return r;
when AS_CALL_EXPR then
r::=#AM_EXPR_STMT(s.source); -- AM_EXPR_STMT::create AS_EXPR_STMT::source
r.expr:=transform_call_expr(e,void,false);-- AM_EXPR_STMT::expr TRANS::transform_call_expr
if ~void(s.at) then r.at:=transform_expr(s.at, TP_BUILTIN::int); end;-- AS_EXPR_STMT::at BOOL::not AM_EXPR_STMT::at TRANS::transform_expr AS_EXPR_STMT::at TP_BUILTIN::int
if ~void(r.expr) then return r else return void end; -- Ivin.-- AM_EXPR_STMT::expr BOOL::not
when AS_AT_EXPR then
r::=#AM_AT_EXPR(e.source);-- AM_AT_EXPR::create AS_AT_EXPR::source
ce::=e.e;-- AS_AT_EXPR::e
typecase ce when AS_CALL_EXPR then
r.e := transform_call_expr(ce,void,false);-- AM_AT_EXPR::e TRANS::transform_call_expr
end;
if void(r.e) then return void end; -- Type Error.-- AM_AT_EXPR::e
r.at := transform_expr(e.at, TP_BUILTIN::int);-- AM_AT_EXPR::at TRANS::transform_expr AS_AT_EXPR::at TP_BUILTIN::int
if void(r.at) then return void end; -- Type Error-- AM_AT_EXPR::at
r2::=#AM_EXPR_STMT(s.source); -- AM_EXPR_STMT::create AS_EXPR_STMT::source
r2.expr:=r;-- AM_EXPR_STMT::expr
return r2;
else
expr_stmt_err(s); -- TRANS::expr_stmt_err
return void;
end;
end;
break_not_in_loop_err(s:AS_EXPR_STMT) is
err_loc(s);-- TRANS::err_loc
err("`break!', `while!' and `until!' calls must appear "
"inside loops."); -- TRANS::err
end;
expr_stmt_err(s:AS_EXPR_STMT) is
err_loc(s);-- TRANS::err_loc
err("Expressions used as statements may not have return "
"values."); -- TRANS::err
end;
call_tp_of_expr(e:$AS_EXPR):$CALL_TP is
-- Returns the call type of an expression, if it is one of the
-- special cases. Otherwise it returns void. (To get the
-- actual type, you have to do `transform_expr'.
if void(e) then
#OUT + "Compiler error, TRANS::call_tp_of_expr(void).";-- OUT::create OUT::plus
return void end;
typecase e
when AS_VOID_EXPR then return #CALL_TP_VOID-- CALL_TP_VOID::create
when AS_CREATE_EXPR then
if void(e.tp) then return #CALL_TP_CREATE -- AS_CREATE_EXPR::tp CALL_TP_CREATE::create
else return void end
when AS_BOUND_CREATE_EXPR then
-- what do we do if partial specification is allowed? (Boris)
return #CALL_TP_BOUND_CREATE; -- CALL_TP_BOUND_CREATE::create
when AS_ARRAY_EXPR then return #CALL_TP_ARRAY-- CALL_TP_ARRAY::create
when AS_UNDERSCORE_ARG then
tua::=#CALL_TP_UNDERSCORE; -- CALL_TP_UNDERSCORE::create
-- typed "underscore" case
if ~void(e.tp) then tua.tp:=tp_of(e.tp) end; -- AS_UNDERSCORE_ARG::tp BOOL::not CALL_TP_UNDERSCORE::tp TRANS::tp_of AS_UNDERSCORE_ARG::tp
return tua
else
return void;
end;
end;
transform_expr(e:$AS_EXPR, tp:$TP):$AM_EXPR is
-- Return an expression which evaluates `e'. If `tp' is not void
-- then use it as the inferred type. Print an error message if
-- if is not a supertype of the expression type. In this case
-- return void. If `tp' is void then the expression must determine
-- its own type.
if void(e) then return void end;
r:$AM_EXPR;
typecase e
when AS_SELF_EXPR then r:= transform_self_expr(e,tp)-- TRANS::transform_self_expr
when AS_CALL_EXPR then r:= transform_call_expr(e,tp,true)-- TRANS::transform_call_expr
-- This is special since we need to know whether a return
-- value is used to resolve overloading. The only way the
-- return value won't be used is in an expression statement.
-- If we get to it from here, the value must be used.
when AS_VOID_EXPR then r:= transform_void_expr(e,tp)-- TRANS::transform_void_expr
when AS_IS_VOID_EXPR then r:= transform_is_void_expr(e,tp) -- TRANS::transform_is_void_expr
when AS_ARRAY_EXPR then r:= transform_array_expr(e,tp)-- TRANS::transform_array_expr
when AS_CREATE_EXPR then r:= transform_create_expr(e,tp)-- TRANS::transform_create_expr
when AS_BOUND_CREATE_EXPR then r:= transform_bound_create_expr(e,tp)-- TRANS::transform_bound_create_expr
when AS_AND_EXPR then r:= transform_and_expr(e,tp)-- TRANS::transform_and_expr
when AS_OR_EXPR then r:= transform_or_expr(e,tp)-- TRANS::transform_or_expr
when AS_EXCEPT_EXPR then r:= transform_except_expr(e,tp)-- TRANS::transform_except_expr
when AS_NEW_EXPR then r:= transform_new_expr(e,tp)-- TRANS::transform_new_expr
when AS_INITIAL_EXPR then r:= transform_initial_expr(e,tp)-- TRANS::transform_initial_expr
when AS_BREAK_EXPR then r:= transform_break_expr(e,tp)-- TRANS::transform_break_expr
when AS_RESULT_EXPR then r:= transform_result_expr(e,tp)-- TRANS::transform_result_expr
when AS_BOOL_LIT_EXPR then r:= transform_bool_lit_expr(e,tp)-- TRANS::transform_bool_lit_expr
when AS_CHAR_LIT_EXPR then r:= transform_char_lit_expr(e,tp)-- TRANS::transform_char_lit_expr
when AS_STR_LIT_EXPR then r:= transform_str_lit_expr(e,tp)-- TRANS::transform_str_lit_expr
when AS_INT_LIT_EXPR then r:= transform_int_lit_expr(e,tp)-- TRANS::transform_int_lit_expr
when AS_FLT_LIT_EXPR then r:= transform_flt_lit_expr(e,tp) -- TRANS::transform_flt_lit_expr
when AS_CLUSTER_EXPR then r:= transform_cluster_expr(e,tp)-- TRANS::transform_cluster_expr
when AS_CLUSTER_SIZE_EXPR then r:= transform_cluster_size_expr(e,tp) -- TRANS::transform_cluster_size_expr
else if prog.psather then r := transform_pSather_expr(e,tp) end;-- TRANS::prog PROG::psather TRANS::transform_pSather_expr
end;
return r;
end;
transform_self_expr(e:AS_SELF_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if in_constant then self_const_err(e); return void end;-- TRANS::in_constant TRANS::self_const_err
sl:AM_LOCAL_EXPR:=cur_rout.self_local;-- TRANS::cur_rout AM_ROUT_DEF::self_local
if ~void(tp) then-- BOOL::not
if ~sl.tp.is_subtype(tp) then-- AM_LOCAL_EXPR::tp BOOL::not
self_context_err(e,sl.tp,tp); return void end end;-- TRANS::self_context_err AM_LOCAL_EXPR::tp
return sl;
end;
self_const_err(e:AS_SELF_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`self' may not appear in a shared or constant "
"initialization expression."); -- TRANS::err
end;
self_context_err(e:AS_SELF_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of self: " + stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
transform_call_expr(e:AS_CALL_EXPR, tp:$TP, has_ret:BOOL):$AM_EXPR is
-- Expression implementing `e' in type context `tp'. `has_ret' says
-- whether the return value is used.
if void(cur_rout) and ~in_constant then-- TRANS::cur_rout TRANS::in_constant BOOL::not
#OUT + "Compiler error, TRANS::transform_call_expr, "-- OUT::create
"cur_rout=void."; return void end;-- OUT::plus
if void(e) then return void end;
r:$AM_EXPR; err_loc(e);-- TRANS::err_loc
if ~void(e.tp) then-- AS_CALL_EXPR::tp BOOL::not
if void(e.ob) and tp_of(e.tp).is_partial then-- AS_CALL_EXPR::ob TRANS::tp_of AS_CALL_EXPR::tp
err("No calls into partial classes allowed.");-- TRANS::err
end;
end;
r:=call_expr_check_local(e,tp); -- TRANS::call_expr_check_local
if ~void(r) then -- BOOL::not
return r
end;
stup:TUP{$AM_EXPR,$TP}:=call_self(e); -- TRANS::call_self
if void(stup) then return void end; -- Fail
self_val:$AM_EXPR:=stup.t1; self_tp:$TP:=stup.t2;-- TUP{2}::t1 TUP{2}::t2
if void(self_tp) then return void end; -- Failure.
in_class:BOOL; if self_tp=tp_con.same then in_class:=true end;-- TRANS::tp_con TP_CONTEXT::same
call_sig::=#CALL_SIG; call_sig.has_ret:=has_ret;-- CALL_SIG::create CALL_SIG::has_ret
call_sig.name:=call_expr_rout_name(e); call_sig.tp:=self_tp;-- CALL_SIG::name TRANS::call_expr_rout_name CALL_SIG::tp
args:ARRAY{AM_CALL_ARG}; nargs:INT:=e.args_size;-- AS_CALL_EXPR::args_size
if ~void(e.args) then args:=#ARRAY{AM_CALL_ARG}(nargs);-- AS_CALL_EXPR::args BOOL::not ARRAY{1}::create
call_sig.args:=#ARRAY{CALL_ARG}(nargs) end; -- CALL_SIG::args ARRAY{1}::create
sig:SIG:=call_expr_get_sig(e,call_sig,args,in_class);-- TRANS::call_expr_get_sig
if prog.psather then sys_closure_self(sig) end;-- TRANS::prog PROG::psather TRANS::sys_closure_self
if void(sig) then return void end;
cr:$AM_CALL_EXPR;
er:AM_EXT_CALL_EXPR; ir:AM_ITER_CALL_EXPR; rr:AM_ROUT_CALL_EXPR;
brr:AM_BND_ROUT_CALL_EXPR;
bir:AM_BND_ITER_CALL_EXPR; --AJ-
call_check_out_args(e);-- TRANS::call_check_out_args
typecase self_tp
when TP_CLASS then
if self_tp.is_external then-- TP_CLASS::is_external
if in_constant then ext_call_const_err(e); return void end;-- TRANS::in_constant TRANS::ext_call_const_err
im:IMPL:=self_tp.impl;-- TP_CLASS::impl
if void(im) then
#OUT + "Compiler err, TRANS::transform_call_expr, "-- OUT::create
"im=void."; return void end;-- OUT::plus
el:ELT:=im.elt_with_sig(sig);-- IMPL::elt_with_sig
if void(el) then
#OUT + "Compiler err, TRANS::transform_call_expr, "-- OUT::create
"el=void.";-- OUT::plus
return void end;
er:=#AM_EXT_CALL_EXPR(nargs+1,e.source,name_for_ext(el)); -- AM_EXT_CALL_EXPR::create INT::plus AS_CALL_EXPR::source TRANS::name_for_ext
er[0]:=#(self_val); er.fun:=sig;-- AM_EXT_CALL_EXPR::aset AM_CALL_ARG::create AM_EXT_CALL_EXPR::fun
if ~void(args) then-- BOOL::not
i:INT:=0;
loop while!(i<nargs); er[i+1]:=args[i]; i:=i+1 end;-- INT::is_lt AM_EXT_CALL_EXPR::aset INT::plus ARRAY{1}::aget INT::plus
end;
cr:=er;
elsif e.name.is_iter then -- AS_CALL_EXPR::name IDENT::is_iter
if in_protect_but_not_loop then -- TRANS::in_protect_but_not_loop
iter_in_protect_err(e); return void;-- TRANS::iter_in_protect_err
end;
ir:=#AM_ITER_CALL_EXPR(nargs+1,e.source); -- AM_ITER_CALL_EXPR::create INT::plus AS_CALL_EXPR::source
ir[0]:=#(self_val); ir.fun:=sig;-- AM_ITER_CALL_EXPR::aset AM_CALL_ARG::create AM_ITER_CALL_EXPR::fun
if ~void(args) then-- BOOL::not
i:INT:=0;
loop while!(i<nargs); ir[i+1]:=args[i]; i:=i+1 end;-- INT::is_lt AM_ITER_CALL_EXPR::aset INT::plus ARRAY{1}::aget INT::plus
end;
cr:=call_fix_iter(ir);-- TRANS::call_fix_iter
else rr:=#AM_ROUT_CALL_EXPR(nargs+1,e.source); -- AM_ROUT_CALL_EXPR::create INT::plus AS_CALL_EXPR::source
rr[0]:=#(self_val); rr.fun:=sig;-- AM_ROUT_CALL_EXPR::aset AM_CALL_ARG::create AM_ROUT_CALL_EXPR::fun
if ~void(args) then-- BOOL::not
i:INT:=0;
loop while!(i<nargs); rr[i+1]:=args[i]; i:=i+1 end;-- INT::is_lt AM_ROUT_CALL_EXPR::aset INT::plus ARRAY{1}::aget INT::plus
-- If it came from a ">" or "<=" sugar, need to flip
-- self and the first argument evaluations. DPS
if e.flip then t::=rr[0]; rr[0]:=rr[1]; rr[1]:=t; end;-- AS_CALL_EXPR::flip AM_ROUT_CALL_EXPR::aget AM_ROUT_CALL_EXPR::aset AM_ROUT_CALL_EXPR::aget AM_ROUT_CALL_EXPR::aset
end;
cr:=rr;
if prog.psather and in_class then-- TRANS::prog PROG::psather
-- Find AS-form of return type. Type is needed for attributes.
im:IMPL:=self_tp.impl;-- TP_CLASS::impl
if void(im) then
#OUT + "Compiler err, TRANS::transform_call_expr, "-- OUT::create
"im=void."; return void end;-- OUT::plus
el:ELT:=im.elt_with_sig(sig);-- IMPL::elt_with_sig
if void(el) then
#OUT + "Compiler err, TRANS::transform_call_expr, "-- OUT::create
"el=void.";-- OUT::plus
return void end;
-- #OUT+"Call of elt:"+el.sig.str+"\n";
-- #OUT+"Type: "; AS_OUT::AS_TYPE_SPEC_out(el.as_tp); #OUT+"\n";
rr.as_type := el.as_tp;-- AM_ROUT_CALL_EXPR::as_type ELT::as_tp
end;
end;
when TP_ROUT then
if in_constant then bnd_rout_call_const_err; return void end;-- TRANS::in_constant TRANS::bnd_rout_call_const_err
brr:=#AM_BND_ROUT_CALL_EXPR(nargs,e.source); -- AM_BND_ROUT_CALL_EXPR::create AS_CALL_EXPR::source
brr.br:=self_val; -- AM_BND_ROUT_CALL_EXPR::br
brr.br_tp:=self_tp; -- Have to do this in case it's in a typecase-- AM_BND_ROUT_CALL_EXPR::br_tp
if ~void(args) then-- BOOL::not
loop
i::=args.ind!;-- ARRAY{1}::ind!
brr[i]:=args[i];-- AM_BND_ROUT_CALL_EXPR::aset ARRAY{1}::aget
end;
end;
cr:=brr;
when TP_ITER then
if in_protect_but_not_loop then-- TRANS::in_protect_but_not_loop
iter_in_protect_err(e); return void;-- TRANS::iter_in_protect_err
end;
bir:=#AM_BND_ITER_CALL_EXPR(nargs,e.source); -- AM_BND_ITER_CALL_EXPR::create AS_CALL_EXPR::source
bir.bi:=self_val;-- AM_BND_ITER_CALL_EXPR::bi
bir.bi_tp:=self_tp; -- Have to do this in case it's in a typecase-- AM_BND_ITER_CALL_EXPR::bi_tp
if ~void(args) then-- BOOL::not
i:INT:=0;
loop while!(i<nargs); -- INT::is_lt
bir[i]:=args[i]; i:=i+1;-- AM_BND_ITER_CALL_EXPR::aset ARRAY{1}::aget INT::plus
end;
end;
cr:=call_fix_bnd_iter(bir,sig) -- move once args-- TRANS::call_fix_bnd_iter
end;
if void(cr) then return void end;
if ~void(tp) and ~void(cr.tp) then-- BOOL::not BOOL::not
if ~cr.tp.is_subtype(tp) then-- BOOL::not
call_context_err(e,cr.tp,tp);-- TRANS::call_context_err
return void
end
end;
-- may need to do some fixups for attributes and array elements
-- passed as out/inout parameters
ncr:$AM_EXPR:=cr;
if call_need_fix_out_args(cr) then-- TRANS::call_need_fix_out_args
ncr := call_fix_out_args(cr);-- TRANS::call_fix_out_args
else
cur_se.mark_context(cr);-- TRANS::cur_se SE_CONTEXT::mark_context
-- Try inlining.
typecase cr
when AM_ROUT_CALL_EXPR then
ncr:=special_inline(cr);-- TRANS::special_inline
when AM_ITER_CALL_EXPR then
ncr:=special_inline(cr);-- TRANS::special_inline
typecase ncr
when AM_ITER_CALL_EXPR then
cur_loop.its:=cur_loop.its.push(ncr);-- TRANS::cur_loop AM_LOOP_STMT::its TRANS::cur_loop AM_LOOP_STMT::its FLIST{1}::push
else end;
else
end;
end;
if prog.psather then sys_closure_nest(cr) end;-- TRANS::prog PROG::psather TRANS::sys_closure_nest
-- see if still an $AM_CALL_EXPR and add to list if so
if ~void(cur_rout) then -- TRANS::cur_rout BOOL::not
typecase ncr
when $AM_CALL_EXPR then cur_rout.calls:=cur_rout.calls.push(ncr);-- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::push
-- inform the optimizer about out/inout args, if any
loop
i::=0.upto!(ncr.asize-1);-- INT::upto! INT::minus
if ncr[i].mode = MODES::out_mode or ncr[i].mode = MODES::inout_mode-- AM_CALL_ARG::mode MODES::out_mode AM_CALL_ARG::mode MODES::inout_mode
then
cur_se.mark_se(ncr[i].expr,true);-- TRANS::cur_se SE_CONTEXT::mark_se AM_CALL_ARG::expr
end;
end;
else
end;
end;
return ncr;
end;
iter_in_protect_err(e:AS_CALL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("An iter call may not occur in a protect statement without an enclosing loop.")-- TRANS::err
end;
call_need_fix_out_args(cr:$AM_CALL_EXPR): BOOL is
-- attributes and array elements passed as out and inout parameters
-- need very special treatment. The same goes for attributes.
-- Return true is these are present
loop
i::=0.upto!(cr.asize-1);-- INT::upto! INT::minus
a::=cr[i];
ae ::=a.expr;-- AM_CALL_ARG::expr
typecase ae
when AM_ROUT_CALL_EXPR then
if SYS::ob_eq(a.mode, MODES::out_mode) or-- SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
SYS::ob_eq(a.mode, MODES::inout_mode) then-- SYS::ob_eq AM_CALL_ARG::mode MODES::inout_mode
if is_aget_sig(ae.fun) then-- TRANS::is_aget_sig AM_ROUT_CALL_EXPR::fun
-- array element as out/inout arg argument
return true
elsif ae.fun.is_reader_sig then -- AM_ROUT_CALL_EXPR::fun SIG::is_reader_sig
-- handles a case when attribute accesses could
-- not be inlined due to, say, dispatching
-- attribute as out/inout argument
return true;
end;
end;
when AM_ATTR_EXPR then
-- simple (not dispatched) attribute accesses might
-- have already been inlined
if SYS::ob_eq(a.mode, MODES::out_mode) or-- SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
SYS::ob_eq(a.mode, MODES::inout_mode) then-- SYS::ob_eq AM_CALL_ARG::mode MODES::inout_mode
return true;
end;
else
end;
end;
return false;
end;
-- fix bound iter part
call_fix_out_args(cr:$AM_CALL_EXPR): $AM_EXPR is
-- attributes and array elements passed as out and inout parameters
-- need very special treatment. First, they must be evaluated into
-- a temporary (reader, aget), a temporary is passed as out/inout,
-- then they are set (writer, aset)
-- For now make things simple: evaluate every argument into a
-- temporary! Will fix when have time
res:AM_STMT_EXPR;
args:ARRAY{AM_CALL_ARG};
res := #AM_STMT_EXPR(cr.source);-- AM_STMT_EXPR::create
args := #(cr.asize);-- ARRAY{1}::create
start:INT:=0;
typecase cr
when AM_ROUT_CALL_EXPR then
start := 1;
args[0] := cr[0].copy;-- ARRAY{1}::aset AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::copy
when AM_ITER_CALL_EXPR then
start := 1;
args[0] := cr[0].copy;-- ARRAY{1}::aset AM_ITER_CALL_EXPR::aget AM_CALL_ARG::copy
else
end;
loop
i::=start.upto!(cr.asize-1);-- INT::upto! INT::minus
a::=cr[i].copy;-- AM_CALL_ARG::copy
ae ::=a.expr;-- AM_CALL_ARG::expr
typecase ae
when $AM_CONST then
args[i] := a;-- ARRAY{1}::aset
else -- do the copying
l:AM_LOCAL_EXPR := #AM_LOCAL_EXPR(cr.source, void, ae.tp);-- AM_LOCAL_EXPR::create
stmt ::= #AM_ASSIGN_STMT(cr.source);-- AM_ASSIGN_STMT::create
stmt.src := ae;-- AM_ASSIGN_STMT::src
add_local(l);-- TRANS::add_local
stmt.dest := l;-- AM_ASSIGN_STMT::dest
if void(res.stmts) then-- AM_STMT_EXPR::stmts
res.stmts := stmt;-- AM_STMT_EXPR::stmts
else
res.stmts.append(stmt);-- AM_STMT_EXPR::stmts
end;
args[i] := #AM_CALL_ARG(l, a.mode); -- ARRAY{1}::aset AM_CALL_ARG::create AM_CALL_ARG::mode
end;
end;
-- now, generate a call that has only newly created locals as
-- arguments
new_call_stmt:$AM_STMT;
new_res:AM_LOCAL_EXPR;
ret_tp:$TP; -- return type of the call
ncr:$AM_EXPR;
typecase cr
when AM_ROUT_CALL_EXPR then
nr ::= #AM_ROUT_CALL_EXPR(cr.asize);-- AM_ROUT_CALL_EXPR::create AM_ROUT_CALL_EXPR::asize
nr.fun := cr.fun;-- AM_ROUT_CALL_EXPR::fun AM_ROUT_CALL_EXPR::fun
loop
i::=0.upto!(cr.asize-1);-- INT::upto! AM_ROUT_CALL_EXPR::asize INT::minus
nr[i] := args[i];-- AM_ROUT_CALL_EXPR::aset ARRAY{1}::aget
end;
ret_tp := nr.fun.ret;-- AM_ROUT_CALL_EXPR::fun SIG::ret
-- try inlinining
cur_se.mark_context(nr); -- TRANS::cur_se SE_CONTEXT::mark_context
ncr := special_inline(nr);-- TRANS::special_inline
when AM_ITER_CALL_EXPR then
ni ::= #AM_ITER_CALL_EXPR(cr.asize);-- AM_ITER_CALL_EXPR::create AM_ITER_CALL_EXPR::asize
ni.fun := cr.fun;-- AM_ITER_CALL_EXPR::fun AM_ITER_CALL_EXPR::fun
ni.init := cr.init;-- AM_ITER_CALL_EXPR::init AM_ITER_CALL_EXPR::init
ni.lp := cr.lp;-- AM_ITER_CALL_EXPR::lp AM_ITER_CALL_EXPR::lp
ni.init_before_loop := cr.init_before_loop;-- AM_ITER_CALL_EXPR::init_before_loop AM_ITER_CALL_EXPR::init_before_loop
loop
i::=0.upto!(cr.asize-1);-- INT::upto! AM_ITER_CALL_EXPR::asize INT::minus
ni[i] := args[i];-- AM_ITER_CALL_EXPR::aset ARRAY{1}::aget
end;
ret_tp := ni.fun.ret;-- AM_ITER_CALL_EXPR::fun SIG::ret
--try inlining
cur_se.mark_context(ni); -- TRANS::cur_se SE_CONTEXT::mark_context
ncr := special_inline(ni);-- TRANS::special_inline
-- update enclosing loop if inlining did not work!
typecase ncr
when AM_ITER_CALL_EXPR then
cur_loop.its := cur_loop.its.push(ncr);-- TRANS::cur_loop AM_LOOP_STMT::its TRANS::cur_loop AM_LOOP_STMT::its FLIST{1}::push
else
end;
when AM_BND_ROUT_CALL_EXPR then
nb ::= #AM_BND_ROUT_CALL_EXPR(cr.asize);-- AM_BND_ROUT_CALL_EXPR::create AM_BND_ROUT_CALL_EXPR::asize
nb.br := cr.br;-- AM_BND_ROUT_CALL_EXPR::br AM_BND_ROUT_CALL_EXPR::br
nb.br_tp := cr.br_tp;-- AM_BND_ROUT_CALL_EXPR::br_tp AM_BND_ROUT_CALL_EXPR::br_tp
loop
i::=0.upto!(cr.asize-1);-- INT::upto! AM_BND_ROUT_CALL_EXPR::asize INT::minus
nb[i] := args[i];-- AM_BND_ROUT_CALL_EXPR::aset ARRAY{1}::aget
end;
ncr:=nb;
ret_tp := nb.tp;-- AM_BND_ROUT_CALL_EXPR::tp
when AM_BND_ITER_CALL_EXPR then
-- bound iters are not implemented yet
-- nbi ::= cr.copy; -- no inout stuff yet for iters
when AM_EXT_CALL_EXPR then
ne ::= #AM_EXT_CALL_EXPR(cr.asize);-- AM_EXT_CALL_EXPR::create AM_EXT_CALL_EXPR::asize
ne.fun := cr.fun;-- AM_EXT_CALL_EXPR::fun AM_EXT_CALL_EXPR::fun
ne.nm := cr.nm;-- AM_EXT_CALL_EXPR::nm AM_EXT_CALL_EXPR::nm
loop
i::=0.upto!(cr.asize-1);-- INT::upto! AM_EXT_CALL_EXPR::asize INT::minus
ne[i] := args[i];-- AM_EXT_CALL_EXPR::aset ARRAY{1}::aget
end;
ncr := ne;
ret_tp := ne.fun.ret;-- AM_EXT_CALL_EXPR::fun SIG::ret
end;
if void(ret_tp) then
expr_stmt ::= #AM_EXPR_STMT(cr.source);-- AM_EXPR_STMT::create
expr_stmt.expr := ncr;-- AM_EXPR_STMT::expr
new_call_stmt := expr_stmt;
else
ass_stmt ::= #AM_ASSIGN_STMT(cr.source);-- AM_ASSIGN_STMT::create
new_res := #AM_LOCAL_EXPR(cr.source, void, ret_tp);-- AM_LOCAL_EXPR::create
add_local(new_res);-- TRANS::add_local
ass_stmt.src := ncr;-- AM_ASSIGN_STMT::src
ass_stmt.dest := new_res;-- AM_ASSIGN_STMT::dest
res.expr := new_res;-- AM_STMT_EXPR::expr
new_call_stmt := ass_stmt;
end;
-- append the call statement
res.stmts.append(new_call_stmt);-- AM_STMT_EXPR::stmts
-- all we need to do is to copy back all inout/out args
-- note the way attributes and array elements are handled!
loop
i ::= start.upto!(cr.asize-1);-- INT::upto! INT::minus
a::=cr[i].copy;-- AM_CALL_ARG::copy
ae::=a.expr;-- AM_CALL_ARG::expr
if SYS::ob_eq(a.mode, MODES::out_mode) or-- SYS::ob_eq AM_CALL_ARG::mode MODES::out_mode
SYS::ob_eq(a.mode, MODES::inout_mode) then-- SYS::ob_eq AM_CALL_ARG::mode MODES::inout_mode
typecase ae
when AM_ROUT_CALL_EXPR then
if is_aget_sig(ae.fun) then-- TRANS::is_aget_sig AM_ROUT_CALL_EXPR::fun
if ae[0].expr.tp.is_immutable then-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
err("It is illegal to pass elements of immutable arrays as out/inout arguments.");-- TRANS::err
end;
aset_call ::= #AM_ROUT_CALL_EXPR(ae.size+1);-- AM_ROUT_CALL_EXPR::create AM_ROUT_CALL_EXPR::size INT::plus
aset_call_sig ::= #CALL_SIG;-- CALL_SIG::create
aset_call_sig.args:=#ARRAY{CALL_ARG}(ae.size);-- CALL_SIG::args ARRAY{1}::create AM_ROUT_CALL_EXPR::size
aset_call_sig.tp := ae.fun.tp; -- type on which the call is made-- CALL_SIG::tp AM_ROUT_CALL_EXPR::fun SIG::tp
aset_call_sig.name := IDENT_BUILTIN::aset_ident;-- CALL_SIG::name IDENT_BUILTIN::aset_ident
aset_call_sig.has_ret:=false; -- aset has no return-- CALL_SIG::has_ret
loop
aset_call_sig.args.set!(#CALL_ARG(ae.fun.args.elt!.tp));-- CALL_SIG::args ARRAY{1}::set! CALL_ARG::create AM_ROUT_CALL_EXPR::fun SIG::args ARRAY{1}::elt! ARG::tp
-- type of index
end;
aset_call_sig.args[ae.size-1] := #(ae.fun.ret);-- CALL_SIG::args ARRAY{1}::aset AM_ROUT_CALL_EXPR::size INT::minus CALL_ARG::create AM_ROUT_CALL_EXPR::fun SIG::ret
-- type of held element
aset_call.fun := ae.fun.tp.ifc.sig_for_call(aset_call_sig);-- AM_ROUT_CALL_EXPR::fun AM_ROUT_CALL_EXPR::fun SIG::tp IFC::sig_for_call
if void(aset_call.fun) then-- AM_ROUT_CALL_EXPR::fun
err("Passing array element as out/inout argument: aset not found.");-- TRANS::err
else
loop
aset_call.set!(ae.elt!);-- AM_ROUT_CALL_EXPR::set! AM_ROUT_CALL_EXPR::elt!
end;
aset_call[aset_call.size-1] := #(args[i].expr);-- AM_ROUT_CALL_EXPR::aset AM_ROUT_CALL_EXPR::size INT::minus AM_CALL_ARG::create ARRAY{1}::aget AM_CALL_ARG::expr
cur_rout.calls:=cur_rout.calls.push(aset_call); -- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::push
expr_stmt ::= #AM_EXPR_STMT(cr.source);-- AM_EXPR_STMT::create
expr_stmt.expr := aset_call;-- AM_EXPR_STMT::expr
res.stmts.append(expr_stmt);-- AM_STMT_EXPR::stmts
end;
elsif ae.fun.is_reader_sig then-- AM_ROUT_CALL_EXPR::fun SIG::is_reader_sig
if ae[0].expr.tp.is_immutable then-- AM_ROUT_CALL_EXPR::aget AM_CALL_ARG::expr
err("It is illegal to pass attributes of immutable objects as out/inout parameters.");-- TRANS::err
end;
writer_call ::= #AM_ROUT_CALL_EXPR(2);-- AM_ROUT_CALL_EXPR::create
writer_call_sig ::= #CALL_SIG;-- CALL_SIG::create
writer_call_sig.args := #ARRAY{CALL_ARG}(1);-- CALL_SIG::args ARRAY{1}::create
writer_call_sig.tp := ae.fun.tp;-- CALL_SIG::tp AM_ROUT_CALL_EXPR::fun SIG::tp
writer_call_sig.name := ae.fun.name;-- CALL_SIG::name AM_ROUT_CALL_EXPR::fun SIG::name
writer_call_sig.has_ret := false; -- ref attr writer-- CALL_SIG::has_ret
writer_call_sig.args[0] := #(ae.fun.ret);-- CALL_SIG::args ARRAY{1}::aset CALL_ARG::create AM_ROUT_CALL_EXPR::fun SIG::ret
writer_call.fun := ae.fun.tp.ifc.sig_for_call(writer_call_sig);-- AM_ROUT_CALL_EXPR::fun AM_ROUT_CALL_EXPR::fun SIG::tp IFC::sig_for_call
if void(writer_call.fun) then-- AM_ROUT_CALL_EXPR::fun
err("Passing an attribute as out/inout argument: writer not found");-- TRANS::err
else
writer_call[0] := ae[0];-- AM_ROUT_CALL_EXPR::aset AM_ROUT_CALL_EXPR::aget
writer_call[1] := #(args[i].expr.copy);-- AM_ROUT_CALL_EXPR::aset AM_CALL_ARG::create ARRAY{1}::aget AM_CALL_ARG::expr
cur_rout.calls:=cur_rout.calls.push(writer_call); -- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::push
expr_stmt ::= #AM_EXPR_STMT(cr.source);-- AM_EXPR_STMT::create
expr_stmt.expr := writer_call;-- AM_EXPR_STMT::expr
res.stmts.append(expr_stmt);-- AM_STMT_EXPR::stmts
end;
end;
else
-- simple copy
stmt:AM_ASSIGN_STMT;
stmt:=#AM_ASSIGN_STMT(cr.source);-- AM_ASSIGN_STMT::create
stmt.src := args[i].expr.copy; -- AM_ASSIGN_STMT::src ARRAY{1}::aget AM_CALL_ARG::expr
stmt.dest := cr[i].expr.copy;-- AM_ASSIGN_STMT::dest AM_CALL_ARG::expr
res.stmts.append(stmt); -- AM_STMT_EXPR::stmts
end;
end;
end;
return res;
end;
call_check_out_args(as_call:AS_CALL_EXPR) is
e:$AS_EXPR;
m:AS_ARG_MODE;
e:=as_call.args;-- AS_CALL_EXPR::args
m:=as_call.modes;-- AS_CALL_EXPR::modes
loop
while!(~void(e));-- BOOL::not
if (m.mod = AS_ARG_MODE::out_mode) or -- AS_ARG_MODE::mod INT::is_eq AS_ARG_MODE::out_mode
(m.mod = AS_ARG_MODE::inout_mode) then-- AS_ARG_MODE::mod INT::is_eq AS_ARG_MODE::inout_mode
typecase e
when AS_SELF_EXPR then
err("It is illegal to pass `self' as out/inout argument.");-- TRANS::err
when AS_VOID_EXPR then
err("It is illegal to pass `void' as out/inout argument.");-- TRANS::err
when AS_IS_VOID_EXPR then
err("It is illegal to pass `void' test expression as out/inout argument.");-- TRANS::err
when AS_ARRAY_EXPR then
err("It is illegal to pass array expression as out/inout argument.");-- TRANS::err
when AS_CREATE_EXPR then
err("It is illegal to pass a creation expression as out/inout argument.");-- TRANS::err
when AS_BOUND_CREATE_EXPR then
err("It is illegal pass a bound create expression as out/inout argument.");-- TRANS::err
when AS_AND_EXPR then
err("It is illegal to pass an `and' expression as out/inout argument.");-- TRANS::err
when AS_OR_EXPR then
err("It is illegal to pass `or' expression as out/inout argument."); -- TRANS::err
when AS_EXCEPT_EXPR then
err("It is illegal to pass a `exception' expression as out/inout argument.");-- TRANS::err
when AS_NEW_EXPR then
err("It is illegal to pass a `new' expression as out/inout argument.");-- TRANS::err
when AS_INITIAL_EXPR then
err("It is illegal to pass an `initial' expression as out/inout argument.");-- TRANS::err
when AS_BREAK_EXPR then
err("It is illegal to pass a `break!' expression as out/inout argument."); -- TRANS::err
when AS_RESULT_EXPR then
err("It is illegal to pass a result' expression as out/inout argument."); -- TRANS::err
when AS_BOOL_LIT_EXPR then
err("It is illegal to pass a boolean literal as out/inout argument."); -- TRANS::err
when AS_CHAR_LIT_EXPR then
err("It is illegal to pass a character literal as out/inout argument."); -- TRANS::err
when AS_STR_LIT_EXPR then
err("It is illegal to pass a string literal as out/inout argument."); -- TRANS::err
when AS_INT_LIT_EXPR then
err("It is illegal to pass an integer literal as out/inout argument."); -- TRANS::err
when AS_FLT_LIT_EXPR then
err("It is illegal to pass a floating point literal as out/inout argument.");-- TRANS::err
when AS_CLUSTER_EXPR then
err("It is illegal to pass a `cluster' expression as out/inout argument.");-- TRANS::err
when AS_CLUSTER_SIZE_EXPR then
err("It is illegal to pass a `cluster_size' expression as out/inout argument."); -- TRANS::err
when AS_CALL_EXPR then
if e.is_array=false and ~void(e.args) then-- AS_CALL_EXPR::is_array BOOL::is_eq AS_CALL_EXPR::args BOOL::not
err("It is illegal to pass a call with arguments as out/inout parameter.");-- TRANS::err
end;
else end;
end;
e := e.next;
m := m.next;-- AS_ARG_MODE::next
end;
end;
call_local_context_err(e:AS_CALL_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of this local variable: " + stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
call_const_err(e:AS_CALL_EXPR) is
err_loc(e);
err("Illegal call for a shared or constant initialization "
"expression.");
end;
call_expr_check_local(e:AS_CALL_EXPR,tp:$TP):AM_LOCAL_EXPR is
-- Check if the call `e' is a local variable reference.
-- If it is return the local.
if in_constant then return void end; -- No locals in initializers.-- TRANS::in_constant
if void(e) then
err("Compiler error, TRANS::call_expr_check_local on void.");-- TRANS::err
return void end;
self_as:$AS_EXPR:=e.ob; -- AS_CALL_EXPR::ob
r:AM_LOCAL_EXPR;
if void(self_as) and void(e.tp) and void(e.args) and -- AS_CALL_EXPR::tp AS_CALL_EXPR::args
e.is_array=false -- AS_CALL_EXPR::is_array BOOL::is_eq
then -- check for local.
r:=local_with_name(e.name);-- TRANS::local_with_name AS_CALL_EXPR::name
if ~void(r) then-- BOOL::not
if ~void(tp) then-- BOOL::not
if ~r.tp.is_subtype(tp) then-- AM_LOCAL_EXPR::tp BOOL::not
call_local_context_err(e,r.tp,tp); return void-- TRANS::call_local_context_err AM_LOCAL_EXPR::tp
end
end;
end;
end;
return r;
end;
call_self(e:AS_CALL_EXPR):TUP{$AM_EXPR,$TP}
-- Return an expression for self and the type of self for the
-- call `e'.
pre ~void(e) is-- BOOL::not
self_as:$AS_EXPR:=e.ob;-- AS_CALL_EXPR::ob
if ~void(self_as) then -- Call made on an expr.-- BOOL::not
typecase self_as
when AS_VOID_EXPR then call_self_void_err(e); return void-- TRANS::call_self_void_err
when AS_CREATE_EXPR then
if void(self_as.tp) then -- AS_CREATE_EXPR::tp
call_self_create_err(e); return void-- TRANS::call_self_create_err
else self_val:$AM_EXPR:=transform_expr(self_as,void); -- TRANS::transform_expr
if void(self_val) then return void end;
return #TUP{$AM_EXPR,$TP}(self_val,self_val.tp) end;-- TUP{2}::create
when AS_ARRAY_EXPR then call_self_array_err(e); return void-- TRANS::call_self_array_err
when AS_UNDERSCORE_ARG then
call_self_underscore_err(e); return void-- TRANS::call_self_underscore_err
else self_val:$AM_EXPR:=transform_expr(self_as,void);-- TRANS::transform_expr
if void(self_val) then return void end;
return #TUP{$AM_EXPR,$TP}(self_val,self_val.tp); -- TUP{2}::create
end;
elsif ~void(e.tp) then -- Double colon call.-- AS_CALL_EXPR::tp BOOL::not
av::=#AM_VOID_CONST(e.source);-- AM_VOID_CONST::create AS_CALL_EXPR::source
av.tp_at:=tp_of(e.tp);-- AM_VOID_CONST::tp_at TRANS::tp_of AS_CALL_EXPR::tp
return #TUP{$AM_EXPR,$TP}(av,av.tp_at)-- TUP{2}::create AM_VOID_CONST::tp_at
else -- Call on self.
self_val:$AM_EXPR;
if in_constant then -- Self is void in initializers.-- TRANS::in_constant
av::=#AM_VOID_CONST(e.source);-- AM_VOID_CONST::create AS_CALL_EXPR::source
av.tp_at:=tp_con.same; self_val:=av;-- AM_VOID_CONST::tp_at TRANS::tp_con TP_CONTEXT::same
else
self_val:=cur_rout.self_local end;-- TRANS::cur_rout AM_ROUT_DEF::self_local
if void(self_val) then
#OUT + "Compiler error, TRANS::call_self, self_val=void.";-- OUT::create OUT::plus
return void end;
return #TUP{$AM_EXPR,$TP}(self_val,self_val.tp) end end;-- TUP{2}::create
call_self_void_err(e:AS_CALL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Calls may not be made directly on `void'."); -- TRANS::err
end;
call_self_create_err(e:AS_CALL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Calls may not be made on create expressions which "
"don't specify the type of object being created."); -- TRANS::err
end;
call_self_array_err(e:AS_CALL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Calls may not be made on array expressions."); -- TRANS::err
end;
call_self_underscore_err(e:AS_CALL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Underscore arguments may not appear in this position.") -- TRANS::err
end;
call_context_err(e:AS_CALL_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of the call: " + stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
ext_call_const_err(e:AS_CALL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("External calls may not appear in shared or constant "
"initialization expressions."); -- TRANS::err
end;
call_expr_get_sig(e:AS_CALL_EXPR, call_sig:CALL_SIG,
args:ARRAY{AM_CALL_ARG},in_class:BOOL):SIG is
-- Get the signature of the call with `call_sig' and if there
-- are arguments, put their expressions in `args'. If anything fails,
-- return void. If `in_class' is true then look at private routines
-- as well as public ones.
if void(args) then
if ~void(e.args) then -- AS_CALL_EXPR::args BOOL::not
err("Compiler error, TRANS::call_expr_get_sig, args size.");-- TRANS::err
return void end;
elsif args.size/=e.args_size or -- ARRAY{1}::size INT::is_eq AS_CALL_EXPR::args_size BOOL::not
call_sig.args.size/=e.args_size then-- CALL_SIG::args ARRAY{1}::size INT::is_eq AS_CALL_EXPR::args_size BOOL::not
err("Compiler error, TRANS::call_expr_get_sig, args size.");-- TRANS::err
return void end;
a:$AS_EXPR:=e.args; m:AS_ARG_MODE:=e.modes; i:INT:=0;-- AS_CALL_EXPR::args AS_CALL_EXPR::modes
ce:$AM_EXPR; md:$MODE;
loop while!(~void(a));-- BOOL::not
ct:$CALL_TP:=call_tp_of_expr(a);-- TRANS::call_tp_of_expr
if void(ct) then ce:=transform_expr(a,void); -- TRANS::transform_expr
if void(ce) then return void
else ct:=ce.tp end;
else ce:=void end;
md := MODE::create_from_as(m);-- MODE::create_from_as
call_sig.args[i]:=#(ct,md); args[i]:=#(ce,md); -- CALL_SIG::args ARRAY{1}::aset CALL_ARG::create ARRAY{1}::aset AM_CALL_ARG::create
a:=a.next; m:=m.next; i:=i+1 end;-- AS_ARG_MODE::next INT::plus
err_loc(e); r::=call_sig.lookup(in_class);-- TRANS::err_loc CALL_SIG::lookup
if void(r) then return void end; -- Failure.
if r.args.size/=e.args_size then-- SIG::args ARRAY{1}::size INT::is_eq AS_CALL_EXPR::args_size BOOL::not
err("Compiler error, TRANS::call_expr_get_sig, res size.");-- TRANS::err
return void end;
a:=e.args; m:=e.modes; i:=0;-- AS_CALL_EXPR::args AS_CALL_EXPR::modes
loop while!(~void(a));-- BOOL::not
ce:=args[i].expr; at:$TP:=r.args[i].tp;-- ARRAY{1}::aget AM_CALL_ARG::expr SIG::args ARRAY{1}::aget ARG::tp
if void(ce) then ce:=transform_expr(a,at) end;-- TRANS::transform_expr
if void(ce) then return void end;
args[i]:=#(ce,MODE::create_from_as(m)); -- ARRAY{1}::aset AM_CALL_ARG::create MODE::create_from_as
a:=a.next; m:=m.next; i:=i+1 end;-- AS_ARG_MODE::next INT::plus
return r;
end;
call_expr_rout_name(e:AS_CALL_EXPR):IDENT
-- The name of the routine being called.
pre ~void(e) is-- BOOL::not
if e.is_array then return IDENT_BUILTIN::aget_ident-- AS_CALL_EXPR::is_array IDENT_BUILTIN::aget_ident
else return e.name end; -- AS_CALL_EXPR::name
end;
call_fix_iter(ir:AM_ITER_CALL_EXPR):AM_ITER_CALL_EXPR
-- Move the once args out in the iter call `ir'.
pre ~void(ir) is-- BOOL::not
if in_constant then iter_call_const_err; return void end; -- TRANS::in_constant TRANS::iter_call_const_err
if void(cur_loop) then iter_call_out_of_loop_err; return void end;-- TRANS::cur_loop TRANS::iter_call_out_of_loop_err
ir.lp:=cur_loop;-- AM_ITER_CALL_EXPR::lp TRANS::cur_loop
if void(ir[0].expr) then -- AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
#OUT + "Compiler error, TRANS::call_fix_iter, ir[0]=void."; -- OUT::create OUT::plus
return void end;
if void(ir.fun) then -- AM_ITER_CALL_EXPR::fun
#OUT + "Compiler error, TRANS::call_fix_iter, ir.fun=void."; -- OUT::create OUT::plus
return void end;
if contains_iter_call(ir[0].expr) then -- iter in self expression.-- TRANS::contains_iter_call AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
iter_call_in_once_arg_err(0); return void end; -- TRANS::iter_call_in_once_arg_err
nl::=#AM_LOCAL_EXPR(ir.source, void, ir[0].expr.tp); -- AM_LOCAL_EXPR::create AM_ITER_CALL_EXPR::source AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
add_local(nl); -- TRANS::add_local
ass::=#AM_ASSIGN_STMT(ir.source); -- AM_ASSIGN_STMT::create AM_ITER_CALL_EXPR::source
ass.dest:=nl;-- AM_ASSIGN_STMT::dest
ass.src:=ir[0].expr; ir[0].expr:=nl; ir.init:=ass;-- AM_ASSIGN_STMT::src AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr AM_ITER_CALL_EXPR::aget AM_CALL_ARG::expr AM_ITER_CALL_EXPR::init
i:INT:=0;
loop while!(i<ir.size-1);-- INT::is_lt AM_ITER_CALL_EXPR::size INT::minus
if void(ir[i+1].expr) then-- AM_ITER_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
#OUT + "Compiler error, TRANS::call_fix_iter, ir[" + (i+1) +-- OUT::create OUT::plus OUT::plus INT::plus
"].expr=void."; return void end; -- OUT::plus
aonce:BOOL:=false;
if void(ir.fun.hot) then aonce:=true -- AM_ITER_CALL_EXPR::fun SIG::hot
elsif ~ir.fun.hot[i] then aonce:=true end;-- AM_ITER_CALL_EXPR::fun SIG::hot ARRAY{1}::aget BOOL::not
if aonce then
if contains_iter_call(ir[i+1].expr) then-- TRANS::contains_iter_call AM_ITER_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
iter_call_in_once_arg_err(i+1); return void end;-- TRANS::iter_call_in_once_arg_err INT::plus
nl:=#AM_LOCAL_EXPR(ir.source,void, ir[i+1].expr.tp);-- AM_LOCAL_EXPR::create AM_ITER_CALL_EXPR::source AM_ITER_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
add_local(nl); -- TRANS::add_local
ass:=#AM_ASSIGN_STMT(ir.source); ass.dest:=nl;-- AM_ASSIGN_STMT::create AM_ITER_CALL_EXPR::source AM_ASSIGN_STMT::dest
ass.src:=ir[i+1].expr; ir[i+1].expr:=nl; -- AM_ASSIGN_STMT::src AM_ITER_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr AM_ITER_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
if void(ir.init) then ir.init:=ass-- AM_ITER_CALL_EXPR::init AM_ITER_CALL_EXPR::init
else ir.init.append(ass) end end; -- AM_ITER_CALL_EXPR::init
i:=i+1 end;-- INT::plus
-- Moved(ivin) cur_loop.its:=cur_loop.its.push(ir);
return ir;
end;
iter_call_const_err is
err("Iter calls may not appear in shared or constant "
"initialization expressions."); -- TRANS::err
end;
iter_call_out_of_loop_err is
err("Iters may only be called within loop statements.");
end;
contains_iter_call(e:$AM_EXPR):BOOL is
-- True if `e' contains an iter call. This is used to check for
-- iter calls in the expressions for once iter arguments.
if void(e) then return void end;
typecase e
when AM_ROUT_CALL_EXPR then
loop if contains_iter_call(e.elt!.expr) then return true end end;-- TRANS::contains_iter_call AM_ROUT_CALL_EXPR::elt! AM_CALL_ARG::expr
when AM_ITER_CALL_EXPR then return true
when AM_ARRAY_EXPR then
loop if contains_iter_call(e.elt!) then return true end end;-- TRANS::contains_iter_call AM_ARRAY_EXPR::elt!
when AM_BND_CREATE_EXPR then
loop if contains_iter_call(e.elt!.expr) then return true end end; -- TRANS::contains_iter_call AM_BND_CREATE_EXPR::elt! AM_CALL_ARG::expr
when AM_BND_ROUT_CALL_EXPR then
loop if contains_iter_call(e.elt!.expr) then return true end end;-- TRANS::contains_iter_call AM_BND_ROUT_CALL_EXPR::elt! AM_CALL_ARG::expr
when AM_BND_ITER_CALL_EXPR then return true
when AM_IF_EXPR then
if contains_iter_call(e.test) or -- TRANS::contains_iter_call AM_IF_EXPR::test
contains_iter_call(e.if_true) or-- TRANS::contains_iter_call AM_IF_EXPR::if_true
contains_iter_call(e.if_false) then return true end -- TRANS::contains_iter_call AM_IF_EXPR::if_false
when AM_IS_VOID_EXPR then
if contains_iter_call(e.arg) then return true end -- TRANS::contains_iter_call AM_IS_VOID_EXPR::arg
when AM_NEW_EXPR then
if contains_iter_call(e.asz) then return true end -- TRANS::contains_iter_call AM_NEW_EXPR::asz
when AM_ATTR_EXPR then
if contains_iter_call(e.ob) then return true end -- TRANS::contains_iter_call AM_ATTR_EXPR::ob
when AM_EXT_CALL_EXPR then
loop if contains_iter_call(e.elt!.expr) then return true end end; -- TRANS::contains_iter_call AM_EXT_CALL_EXPR::elt! AM_CALL_ARG::expr
else end;
return false;
end;
iter_call_in_once_arg_err(i:INT) is
if i=0 then-- INT::is_eq
err("The expression specifying `self' in this iter call, "
"itself contains an iter call.")-- TRANS::err
else err("The expression for argument number " + i +-- TRANS::err STR::plus
" in this iter call, itself contains an iter call."); -- STR::plus
end;
end;
bnd_rout_call_const_err is
err("Bound routine calls may not appear in shared or "
"constant initialization expressions."); -- TRANS::err
end;
call_fix_bnd_iter(bir:AM_BND_ITER_CALL_EXPR,
sig:SIG):AM_BND_ITER_CALL_EXPR is
-- Move the once args out in the bound iter call `bir' with
-- signature `sig'.
if void(bir) or void(sig) then return void end;
if in_constant then bnd_iter_call_const_err; return void end; -- TRANS::in_constant TRANS::bnd_iter_call_const_err
if void(cur_loop) then -- TRANS::cur_loop
bnd_iter_call_out_of_loop_err; return void end;-- TRANS::bnd_iter_call_out_of_loop_err
bir.lp:=cur_loop;-- AM_BND_ITER_CALL_EXPR::lp TRANS::cur_loop
i:INT:=0;
loop while!(i<bir.size);-- INT::is_lt AM_BND_ITER_CALL_EXPR::size
if void(bir[i].expr) then err_loc(bir);-- AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr TRANS::err_loc
err("Compiler error, TRANS::call_fix_bnd_iter, bir[" +-- TRANS::err
i + "].expr=void."); return void end;-- STR::plus STR::plus
aonce:BOOL:=false;
if void(sig.hot) then aonce:=true-- SIG::hot
elsif ~sig.hot[i] then aonce:=true end;-- SIG::hot ARRAY{1}::aget BOOL::not
if aonce then
if contains_iter_call(bir[i].expr) then-- TRANS::contains_iter_call AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
bnd_iter_call_in_once_err(i); return void end;-- TRANS::bnd_iter_call_in_once_err
nl::=#AM_LOCAL_EXPR(bir.source,void,bir[i].expr.tp);-- AM_LOCAL_EXPR::create AM_BND_ITER_CALL_EXPR::source AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
add_local(nl); -- TRANS::add_local
ass::=#AM_ASSIGN_STMT(bir.source); -- AM_ASSIGN_STMT::create AM_BND_ITER_CALL_EXPR::source
ass.dest:=nl;-- AM_ASSIGN_STMT::dest
ass.src:=bir[i].expr; bir[i].expr:=nl; -- AM_ASSIGN_STMT::src AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr AM_BND_ITER_CALL_EXPR::aget AM_CALL_ARG::expr
if void(bir.init) then bir.init:=ass-- AM_BND_ITER_CALL_EXPR::init AM_BND_ITER_CALL_EXPR::init
else bir.init.append(ass) end end;-- AM_BND_ITER_CALL_EXPR::init
i:=i+1 end;-- INT::plus
cur_loop.bits:=cur_loop.bits.push(bir); -- TRANS::cur_loop AM_LOOP_STMT::bits TRANS::cur_loop AM_LOOP_STMT::bits FLIST{1}::push
return bir;
end;
bnd_iter_call_const_err is
err("Bound iter calls may not appear in shared or constant "
"initialization expressions."); -- TRANS::err
end;
bnd_iter_call_out_of_loop_err is
err("Bound iters may only be called inside loop statements.");-- TRANS::err
end;
bnd_iter_call_in_once_err(i:INT) is
err("Argument " + i + " of this bound iter call is " +-- TRANS::err STR::plus STR::plus
"a once argument, but an iter call appears in its expression."); -- STR::plus
end;
transform_void_expr(e:AS_VOID_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
r::=#AM_VOID_CONST(e.source); -- AM_VOID_CONST::create AS_VOID_EXPR::source
if void(tp) then
err_loc(e);-- TRANS::err_loc
err("Compiler error, no type for void."); return void end;-- TRANS::err
r.tp_at:=tp; -- AM_VOID_CONST::tp_at
return r;
end;
transform_is_void_expr(e:AS_IS_VOID_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::bool.is_subtype(tp) then-- TP_BUILTIN::bool TP_CLASS::is_subtype BOOL::not
err_loc(e); -- TRANS::err_loc
err("Void test expressions return BOOL objects which "
"are not subtypes of " + tp.str + "."); return void end end;-- TRANS::err STR::plus STR::plus
r::=#AM_IS_VOID_EXPR(e.source); -- AM_IS_VOID_EXPR::create AS_IS_VOID_EXPR::source
r.tp_at:=TP_BUILTIN::bool; err_loc(e.arg);-- AM_IS_VOID_EXPR::tp_at TP_BUILTIN::bool TRANS::err_loc AS_IS_VOID_EXPR::arg
earg::=e.arg;-- AS_IS_VOID_EXPR::arg
typecase earg
when AS_VOID_EXPR then
err("void(void) is not allowed."); return void-- TRANS::err
when AS_CREATE_EXPR then
if void(earg.tp) then -- AS_CREATE_EXPR::tp
err("void() on create expression without type."); -- TRANS::err
return void end;
when AS_ARRAY_EXPR then
err("void() on array creation expression."); return void-- TRANS::err
when AS_UNDERSCORE_ARG then
err("void(_) is illegal."); return void-- TRANS::err
else end;
r.arg:=transform_expr(e.arg,void); -- AM_IS_VOID_EXPR::arg TRANS::transform_expr AS_IS_VOID_EXPR::arg
if void(r.arg) then return void end;-- AM_IS_VOID_EXPR::arg
return r;
end;
transform_array_expr(e:AS_ARRAY_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if void(tp) then array_tp_void_err(e); return void end;-- TRANS::array_tp_void_err
pt:$TP;
typecase tp
when TP_CLASS then
if tp.name/=IDENT_BUILTIN::ARRAY_ident -- TP_CLASS::name IDENT::is_eq IDENT_BUILTIN::ARRAY_ident
or tp.params.size/=1 then-- BOOL::not TP_CLASS::params ARRAY{1}::size INT::is_eq BOOL::not
array_wrong_tp_err(e,tp); return void end;-- TRANS::array_wrong_tp_err
pt:=tp.params[0]; -- The parameter type.-- TP_CLASS::params ARRAY{1}::aget
else array_wrong_tp_err(e,tp); return void end;-- TRANS::array_wrong_tp_err
r::=#AM_ARRAY_EXPR(e.elts_size, e.source); -- AM_ARRAY_EXPR::create AS_ARRAY_EXPR::elts_size AS_ARRAY_EXPR::source
r.tp_at:=tp;-- AM_ARRAY_EXPR::tp_at
ae:$AS_EXPR:=e.elts; i:INT:=0;-- AS_ARRAY_EXPR::elts
loop while!(~void(ae));-- BOOL::not
tae:$AM_EXPR:=transform_expr(ae,pt);-- TRANS::transform_expr
if void(tae) then return void end;
r[i]:=tae;-- AM_ARRAY_EXPR::aset
ae:=ae.next; i:=i+1 end;-- INT::plus
return r;
end;
array_tp_void_err(e:AS_ARRAY_EXPR) is
err_loc(e);-- TRANS::err_loc
err("The type of this array creation expression cannot be "
"inferred from context."); -- TRANS::err
end;
array_wrong_tp_err(e:AS_ARRAY_EXPR, tp:$TP) is
err_loc(e);-- TRANS::err_loc
err("The inferred type: " + tp.str + " for this array " +-- TRANS::err STR::plus STR::plus
"creation expression is not of the form `ARRAY{T}'."); -- STR::plus
end;
transform_create_expr(e:AS_CREATE_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
at:$TP;
if in_constant then create_const_err(e); return void end; -- TRANS::in_constant TRANS::create_const_err
if ~void(e.tp) then-- AS_CREATE_EXPR::tp BOOL::not
at:=tp_of(e.tp);-- TRANS::tp_of AS_CREATE_EXPR::tp
if ~void(tp) then-- BOOL::not
if ~at.is_subtype(tp) then -- BOOL::not
create_context_err(e,at,tp); return void end end;-- TRANS::create_context_err
elsif void(tp) then
create_tp_spec_err(e); return void-- TRANS::create_tp_spec_err
else at:=tp end;
-- Now `at' has the type we are creating.
if at.is_abstract then err_loc(e);-- TRANS::err_loc
err("Creation expressions may not specify abstract types.");-- TRANS::err
return void end;
na:INT:=e.elts_size; -- Number of arguments.-- AS_CREATE_EXPR::elts_size
r::=#AM_ROUT_CALL_EXPR(na+1,e.source); -- AM_ROUT_CALL_EXPR::create INT::plus AS_CREATE_EXPR::source
r.as_type := e.tp;-- AM_ROUT_CALL_EXPR::as_type AS_CREATE_EXPR::tp
av::=#AM_VOID_CONST(e.source); av.tp_at:=at;-- AM_VOID_CONST::create AS_CREATE_EXPR::source AM_VOID_CONST::tp_at
r[0]:=#(av); -- AM_ROUT_CALL_EXPR::aset AM_CALL_ARG::create
cs::=#CALL_SIG; -- CALL_SIG::create
if na>0 then cs.args:=#ARRAY{CALL_ARG}(na) end;-- INT::is_lt CALL_SIG::args ARRAY{1}::create
cs.tp:=at; cs.name:=IDENT_BUILTIN::create_ident;-- CALL_SIG::tp CALL_SIG::name IDENT_BUILTIN::create_ident
cs.has_ret:=true; -- Creation expressions always return vals.-- CALL_SIG::has_ret
ce:$AS_EXPR:=e.elts; i:INT:=0;-- AS_CREATE_EXPR::elts
m:AS_ARG_MODE:=e.modes;-- AS_CREATE_EXPR::modes
loop while!(~void(ce));-- BOOL::not
cs.args[i]:=#(call_tp_of_expr(ce), MODE::create_from_as(m));-- CALL_SIG::args ARRAY{1}::aset CALL_ARG::create TRANS::call_tp_of_expr MODE::create_from_as
if void(cs.args[i].tp) then -- Not a type inference case.-- CALL_SIG::args ARRAY{1}::aget CALL_ARG::tp
-- Compute arg expr.
r[i+1]:=#(transform_expr(ce,void),MODE::create_from_as(m));-- AM_ROUT_CALL_EXPR::aset INT::plus AM_CALL_ARG::create TRANS::transform_expr MODE::create_from_as
if void(r[i+1].expr) then return void end;-- AM_ROUT_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
cs.args[i].tp:=r[i+1].expr.tp; -- CALL_SIG::args ARRAY{1}::aget CALL_ARG::tp AM_ROUT_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
cs.args[i].mode := r[i+1].mode;-- CALL_SIG::args ARRAY{1}::aget CALL_ARG::mode AM_ROUT_CALL_EXPR::aget INT::plus AM_CALL_ARG::mode
end; -- Get type from expr.
ce:=ce.next; m:=m.next; i:=i+1 -- AS_ARG_MODE::next INT::plus
end;
err_loc(e);-- TRANS::err_loc
-- DPS: was: r.fun:=at.ifc.sig_for_call(cs);
if at=tp_con.same then-- TRANS::tp_con TP_CONTEXT::same
r.fun:=at.impl.sig_for_internal_call(cs);-- AM_ROUT_CALL_EXPR::fun IMPL::sig_for_internal_call
else
r.fun:=at.ifc.sig_for_call(cs);-- AM_ROUT_CALL_EXPR::fun IFC::sig_for_call
end;
-- DPS end of change
if void(r.fun) then return void end;-- AM_ROUT_CALL_EXPR::fun
ce:=e.elts; i:=0;-- AS_CREATE_EXPR::elts
loop while!(~void(ce));-- BOOL::not
if void(r[i+1]) then -- Need to compute by inference.-- AM_ROUT_CALL_EXPR::aget INT::plus
r[i+1]:=#(transform_expr(ce,r.fun.args[i].tp),r.fun.args[i].mode); -- AM_ROUT_CALL_EXPR::aset INT::plus AM_CALL_ARG::create TRANS::transform_expr AM_ROUT_CALL_EXPR::fun SIG::args ARRAY{1}::aget ARG::tp AM_ROUT_CALL_EXPR::fun SIG::args ARRAY{1}::aget ARG::mode
-- Here is where the type inference gets done. We tell
-- it to use the found signature type an mode to evaluate ce.
if void(r[i+1].expr) then return void end end; -- AM_ROUT_CALL_EXPR::aget INT::plus AM_CALL_ARG::expr
ce:=ce.next; i:=i+1 -- INT::plus
end;
if r.fun.ret/=at then-- AM_ROUT_CALL_EXPR::fun SIG::ret BOOL::not
create_bad_return_type_err(e,r.fun.ret,at); return void end;-- TRANS::create_bad_return_type_err AM_ROUT_CALL_EXPR::fun SIG::ret
cur_rout.calls:=cur_rout.calls.push(r); -- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::push
cur_se.mark_context(r);-- TRANS::cur_se SE_CONTEXT::mark_context
r2 ::= special_inline(r);-- TRANS::special_inline
return r2;
end;
create_const_err(e:AS_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Creation expressions may not appear in shared or "
"constant initialization expressions."); -- TRANS::err
end;
create_context_err(e:AS_CREATE_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of the creation expression: " + stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
create_tp_spec_err(e:AS_CREATE_EXPR) is
err_loc(e); -- TRANS::err_loc
err("This creation expression does not specify its type "
"and it cannot be inferred from context."); -- TRANS::err
end;
create_bad_return_type_err(e:AS_CREATE_EXPR, rt,at:$TP) is
err_loc(e);-- TRANS::err_loc
err("This creation expression returns the type: " + rt.str +-- TRANS::err STR::plus
" rather than " + at.str + " as it must."); -- STR::plus STR::plus STR::plus
end;
transform_bound_create_expr(e:AS_BOUND_CREATE_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if in_constant then bound_create_in_const_err(e); return void end; -- TRANS::in_constant TRANS::bound_create_in_const_err
st::=bound_create_self(e); self_val::=st.t1; self_tp::=st.t2;-- TRANS::bound_create_self TUP{2}::t1 TUP{2}::t2
nbnd::=bound_create_num_bnd(self_val,e);-- TRANS::bound_create_num_bnd
r::=#AM_BND_CREATE_EXPR(nbnd);-- AM_BND_CREATE_EXPR::create
r.fun:=bound_create_sig(e,self_tp, tp);-- AM_BND_CREATE_EXPR::fun TRANS::bound_create_sig
if void(r.fun) then return void end; -- Failure.-- AM_BND_CREATE_EXPR::fun
if e.is_iter and r.fun.is_iter.not then-- AS_BOUND_CREATE_EXPR::is_iter AM_BND_CREATE_EXPR::fun SIG::is_iter BOOL::not
bound_create_not_iter_err(e); return void-- TRANS::bound_create_not_iter_err
elsif ~e.is_iter and r.fun.is_iter then-- AS_BOUND_CREATE_EXPR::is_iter BOOL::not AM_BND_CREATE_EXPR::fun SIG::is_iter
bound_create_iter_err(e); return void end;-- TRANS::bound_create_iter_err
r.bnd_args:=bound_create_bnd_args(nbnd,e);-- AM_BND_CREATE_EXPR::bnd_args TRANS::bound_create_bnd_args
r.unbnd_args:=bound_create_unbnd_args(nbnd,e);-- AM_BND_CREATE_EXPR::unbnd_args TRANS::bound_create_unbnd_args
b_ind::=0; -- Index into bound arguments.
if ~void(self_val) then-- BOOL::not
r[b_ind]:=#(self_val); b_ind:=b_ind+1;-- AM_BND_CREATE_EXPR::aset AM_CALL_ARG::create INT::plus
if e.is_iter and contains_iter_call(self_val) then-- AS_BOUND_CREATE_EXPR::is_iter TRANS::contains_iter_call
bound_create_self_has_iter_err(e); return void end;-- TRANS::bound_create_self_has_iter_err
-- This used to enclose entire following loop!
end;
hot:BOOL;
a::=e.call.args;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args
m::=e.call.modes;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::modes
loop while!(~void(a)); atp::=r.fun.args.elt!.tp;-- BOOL::not AM_BND_CREATE_EXPR::fun SIG::args ARRAY{1}::elt! ARG::tp
--
if ~void(r.fun.hot) then hot:=r.fun.hot.elt! end;-- AM_BND_CREATE_EXPR::fun SIG::hot BOOL::not AM_BND_CREATE_EXPR::fun SIG::hot ARRAY{1}::elt!
typecase a when AS_UNDERSCORE_ARG then else
r[b_ind]:=#(transform_expr(a,atp), MODE::create_from_as(m));-- AM_BND_CREATE_EXPR::aset AM_CALL_ARG::create TRANS::transform_expr MODE::create_from_as
if void(r[b_ind].expr) then return void end;-- AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
if e.is_iter and ~hot and contains_iter_call(r[b_ind].expr) then-- AS_BOUND_CREATE_EXPR::is_iter BOOL::not TRANS::contains_iter_call AM_BND_CREATE_EXPR::aget AM_CALL_ARG::expr
bound_create_iter_in_once_err(a); return void end;-- TRANS::bound_create_iter_in_once_err
b_ind:=b_ind+1 end;-- INT::plus
a:=a.next;
end;
bound_create_set_tp(r);-- TRANS::bound_create_set_tp
if ~void(tp) and ~r.tp.is_subtype(tp) then-- BOOL::not AM_BND_CREATE_EXPR::tp BOOL::not
bound_create_context_err(e,r.tp,tp); return void end;-- TRANS::bound_create_context_err AM_BND_CREATE_EXPR::tp
cur_rout.calls:=cur_rout.calls.push(r);-- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::push
return r;
end;
bound_create_in_const_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Bound creation expressions may not appear in shared or "
"constant initialization expressions."); -- TRANS::err
end;
bound_create_self(e:AS_BOUND_CREATE_EXPR):TUP{$AM_EXPR,$TP} is
-- Return an expression for self and the type of self for the
-- bound create expression `e'. If `t1' is void, then it is a
-- call on underscore, or an error!.
call::=e.call; self_as::=call.ob;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::ob
self_val:$AM_EXPR;
if ~void(self_as) then -- Call made on an expr.-- BOOL::not
typecase self_as
when AS_VOID_EXPR then bound_create_self_void_err(e); -- TRANS::bound_create_self_void_err
return #(void,void)-- TUP{2}::create
when AS_CREATE_EXPR then
if void(self_as.tp) then bound_create_self_create_err(e); -- AS_CREATE_EXPR::tp TRANS::bound_create_self_create_err
return #(void,void)-- TUP{2}::create
else self_val:=transform_expr(self_as,void); -- TRANS::transform_expr
return #(self_val,self_val.tp) end;-- TUP{2}::create
when AS_ARRAY_EXPR then bound_create_self_array_err(e); -- TRANS::bound_create_self_array_err
return #(void,void)-- TUP{2}::create
when AS_UNDERSCORE_ARG then
-- `self_val' is void if self is an underscore expression, or if it
-- does not exist for some erroneus reason.
if void(self_as.tp) then return #(void,void)-- AS_UNDERSCORE_ARG::tp TUP{2}::create
else
return #(void,tp_of(self_as.tp)) -- TUP{2}::create TRANS::tp_of AS_UNDERSCORE_ARG::tp
end;
else self_val:=transform_expr(self_as,void);-- TRANS::transform_expr
-- error: dispatch on void , if self_val is void.
--if void(self_val) then err("Dispatch on void, trans !, temporary!");
--else
return #(self_val,self_val.tp); --end;-- TUP{2}::create
end;
elsif ~void(call.tp) then -- Double colon call.-- AS_CALL_EXPR::tp BOOL::not
res::=#AM_VOID_CONST(call.source);-- AM_VOID_CONST::create AS_CALL_EXPR::source
res.tp_at:=tp_of(call.tp);-- AM_VOID_CONST::tp_at TRANS::tp_of AS_CALL_EXPR::tp
return #(res, res.tp_at);-- TUP{2}::create AM_VOID_CONST::tp_at
else -- Call on self.
if void(call.args) then -- Might be a local.-- AS_CALL_EXPR::args
l::=local_with_name(call.name);-- TRANS::local_with_name AS_CALL_EXPR::name
if ~void(l) then -- BOOL::not
bound_create_self_local_err(e); return #(void,void)-- TRANS::bound_create_self_local_err TUP{2}::create
else end end;
self_val:=cur_rout.self_local; -- TRANS::cur_rout AM_ROUT_DEF::self_local
return #(self_val, self_val.tp); -- TUP{2}::create
end;
end;
bound_create_self_void_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Bound creation calls may not be made directly on `void'.") -- TRANS::err
end;
bound_create_self_create_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Bound creation calls may not be made on create "
"expressions which don't specify the type of object being "
"created."); -- TRANS::err
end;
bound_create_self_array_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Bound creation calls may not be made on array "
"expressions."); -- TRANS::err
end;
bound_create_self_local_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e); -- TRANS::err_loc
err("Bound creation calls must be calls on routines or iters, "
"not references to local variables."); -- TRANS::err
end;
bound_create_sig(e:AS_BOUND_CREATE_EXPR, self_tp:$TP, ctp:$TP):SIG is
-- The signature of the call represented by `e' where the type of
-- self has been determined to be `self_tp'. If self_tp is void,
-- self is untyped '_' and we need to figure out the type from the
-- context. ctp is the type context.
-- Void if there is a problem.
con_args: ARRAY{ARG}; -- args from context
con_ret:$TP; -- return type from context
if ~void(ctp) then-- BOOL::not
typecase ctp
when TP_ROUT then
con_args := ctp.args;-- TP_ROUT::args
con_ret := ctp.ret;-- TP_ROUT::ret
when TP_ITER then
con_args := ctp.args;-- TP_ITER::args
con_ret := ctp.ret;-- TP_ITER::ret
end; -- nothing else is possible here
end;
if void(self_tp) then
-- need to take from context
if ~void(con_args) then-- BOOL::not
self_tp := con_args[0].tp; -- ARRAY{1}::aget ARG::tp
else
err("Failure to infer the type of the unbound self argument");-- TRANS::err
return void;
end;
end;
call_sig::=#CALL_SIG; call_sig.tp:=self_tp;-- CALL_SIG::create CALL_SIG::tp
call_sig.name:=e.call.name;-- CALL_SIG::name AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::name
call_sig.args:=#ARRAY{CALL_ARG}(e.call.args_size);-- CALL_SIG::args ARRAY{1}::create AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args_size
if ~void(con_ret) then call_sig.has_ret:=true end;-- BOOL::not CALL_SIG::has_ret
if void(ctp) and void(e.ret) then-- AS_BOUND_CREATE_EXPR::ret
call_sig.unknown_ret:=true -- CALL_SIG::unknown_ret
end;
ca::=e.call.args;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args
cm::=e.call.modes; -- tells u whether its once i.e. once_mod-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::modes
i:INT; -- arg poistion
-- figure out if self is unbound
ob ::= e.call.ob;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::ob
typecase ob
when AS_UNDERSCORE_ARG then
i := 1;
else
i := 0;
end;
loop while!(~void(ca)); -- BOOL::not
atp::=call_tp_of_expr(ca);-- TRANS::call_tp_of_expr
if void(atp) then
-- normal case
atp:=transform_expr(ca,void).tp -- TRANS::transform_expr
else
-- possible type inference case
if ~void(con_args) then-- BOOL::not
typecase atp
when CALL_TP_UNDERSCORE then
if void(atp.tp) then-- CALL_TP_UNDERSCORE::tp
-- need to use type inferencing
atp.tp := con_args[i].tp;-- CALL_TP_UNDERSCORE::tp ARRAY{1}::aget ARG::tp
end;
i := i + 1;-- INT::plus
else
end;
end;
end;
call_sig.args.set!(#CALL_ARG(atp, MODE::create_from_as(cm)));-- CALL_SIG::args ARRAY{1}::set! CALL_ARG::create MODE::create_from_as
ca:=ca.next; cm:=cm.next; -- AS_ARG_MODE::next
end;
-- At this point call_sig is complete, except for hots which were left out
err_loc(e); -- Just in case.-- TRANS::err_loc
-- setting of the hot in SIG must happen in the following call
s::=call_sig.lookup(self_tp=tp_con.same); -- CALL_SIG::lookup TRANS::tp_con TP_CONTEXT::same
return s;
end;
bound_create_not_iter_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Bound iters must be formed from iter calls."); -- TRANS::err
end;
bound_create_iter_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("Bound routines must be formed from routine calls."); -- TRANS::err
end;
bound_create_num_bnd(self_val:$AM_EXPR, e:AS_BOUND_CREATE_EXPR):INT is
-- The number of argument which are bound up (including self).
r:INT;
if void(self_val) then r:=0 else r:=1 end; -- Count self.
a::=e.call.args;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args
loop while!(~void(a));-- BOOL::not
typecase a when AS_UNDERSCORE_ARG then else r:=r+1 end;-- INT::plus
a:=a.next end;
return r;
end;
bound_create_bnd_args(nbnd:INT,e:AS_BOUND_CREATE_EXPR):ARRAY{INT} is
-- An array of the indices of arguments which are bound up in
-- order. 0 is self. `nbnd' is the number of bound args.
r::=#ARRAY{INT}(nbnd); -- ARRAY{1}::create
rind::=0; -- Index into r.
st::=e.call.ob;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::ob
typecase st when AS_UNDERSCORE_ARG then
else r[rind]:=0; rind:=rind+1 end;-- ARRAY{1}::aset INT::plus
aind::=0; -- Index into argument list.
a::=e.call.args;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args
loop while!(~void(a)); aind:=aind+1;-- BOOL::not INT::plus
typecase a when AS_UNDERSCORE_ARG then
else r[rind]:=aind; rind:=rind+1 end;-- ARRAY{1}::aset INT::plus
a:=a.next end;
return r;
end;
bound_create_unbnd_args(nbnd:INT,e:AS_BOUND_CREATE_EXPR):ARRAY{INT} is
-- An array of the indices of arguments which are not bound in
-- order. 0 is self. `nbnd' is the number of bound args.
r::=#ARRAY{INT}(1+e.call.args_size-nbnd); -- ARRAY{1}::create INT::plus AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args_size INT::minus
rind::=0; -- Index into r.
st::=e.call.ob;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::ob
typecase st when AS_UNDERSCORE_ARG then
r[rind]:=0; rind:=rind+1 else end;-- ARRAY{1}::aset INT::plus
aind::=0; -- Index into argument list.
a::=e.call.args;-- AS_BOUND_CREATE_EXPR::call AS_CALL_EXPR::args
loop while!(~void(a)); aind:=aind+1; -- BOOL::not INT::plus
typecase a when AS_UNDERSCORE_ARG then
r[rind]:=aind; rind:=rind+1 else end;-- ARRAY{1}::aset INT::plus
a:=a.next end;
return r;
end;
bound_create_self_has_iter_err(e:AS_BOUND_CREATE_EXPR) is
err_loc(e);-- TRANS::err_loc
err("The expression for self in an iter call may not "
"itself contain an iter call."); -- TRANS::err
end;
bound_create_iter_in_once_err(a:$AS_EXPR) is
err_loc(a);-- TRANS::err_loc
err("Once arguments of iter calls may not themselves "
"contain iter calls."); -- TRANS::err
end;
bound_create_set_tp(r:AM_BND_CREATE_EXPR) is
-- Set the type in `r', assuming everything else is there (incl. mode)
fun::=r.fun;-- AM_BND_CREATE_EXPR::fun
args::=#ARRAY{ARG}(r.unbnd_args.size); -- ARRAY{1}::create AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::size
t:$TP; m:$MODE; h:BOOL; hot : ARRAY{BOOL};
if fun.is_iter then -- A bound iter.-- SIG::is_iter
-- if in bnd type no arg is hot the hot needs to be void
one_is_hot ::= false;
if void(fun.hot) then -- SIG::hot
hot := void;
else
hot:=#ARRAY{BOOL}(r.unbnd_args.size);-- ARRAY{1}::create AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::size
end;
loop i::=r.unbnd_args.elt!;-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::elt!
if i=0 then -- INT::is_eq
t:=fun.tp;-- SIG::tp
if fun.is_iter then-- SIG::is_iter
-- If self is left unbound in the bound iter
-- it must have "once" mode
if r.unbnd_args[0] = 0 then-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::aget INT::is_eq
m := #ONCE_MODE;-- ONCE_MODE::create
end;
else
m:=#IN_MODE; --can't change self-- IN_MODE::create
end;
else
t:=fun.args[i-1].tp;-- SIG::args ARRAY{1}::aget INT::minus ARG::tp
m:=fun.args[i-1].mode;-- SIG::args ARRAY{1}::aget INT::minus ARG::mode
end;
args.set!(#ARG(t,m));-- ARRAY{1}::set! ARG::create
if ~void(fun.hot) then -- SIG::hot BOOL::not
if i=0 then h:=false else h:=fun.hot[i-1] end;-- INT::is_eq SIG::hot ARRAY{1}::aget INT::minus
hot.set!(h);-- ARRAY{1}::set!
one_is_hot := one_is_hot or h; -- set whenever there is a hot arg.
end; -- if there is nothing hot we DO want hot to be void!
end; -- ends loop
if ~one_is_hot then hot := void; end;-- BOOL::not
r.tp_at:=prog.tp_tbl.tp_iter_for(args,hot,fun.ret)-- AM_BND_CREATE_EXPR::tp_at TRANS::prog PROG::tp_tbl TP_TBL::tp_iter_for SIG::ret
else -- A bound routine.
loop i::=r.unbnd_args.elt!;-- AM_BND_CREATE_EXPR::unbnd_args ARRAY{1}::elt!
if i=0 then -- INT::is_eq
t:=fun.tp;-- SIG::tp
m:=#IN_MODE;-- IN_MODE::create
else
t:=fun.args[i-1].tp; -- SIG::args ARRAY{1}::aget INT::minus ARG::tp
m:=fun.args[i-1].mode;-- SIG::args ARRAY{1}::aget INT::minus ARG::mode
end;
args.set!(#ARG(t,m)) end;-- ARRAY{1}::set! ARG::create
r.tp_at:=prog.tp_tbl.tp_rout_for(args,fun.ret); -- AM_BND_CREATE_EXPR::tp_at TRANS::prog PROG::tp_tbl TP_TBL::tp_rout_for SIG::ret
end;
end;
bound_create_context_err(e:AS_BOUND_CREATE_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of the bound creation expression: " + stp.str + -- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
transform_and_expr(e:AS_AND_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::bool.is_subtype(tp) then-- TP_BUILTIN::bool TP_CLASS::is_subtype BOOL::not
and_context_err(e,tp); return void end end;-- TRANS::and_context_err
e1:$AM_EXPR:=transform_expr(e.e1, TP_BUILTIN::bool); -- TRANS::transform_expr AS_AND_EXPR::e1 TP_BUILTIN::bool
e2:$AM_EXPR:=transform_expr(e.e2, TP_BUILTIN::bool); -- TRANS::transform_expr AS_AND_EXPR::e2 TP_BUILTIN::bool
if void(e1) or void(e2) then return void end; -- Not booleans.
r::=#AM_IF_EXPR(e.source);-- AM_IF_EXPR::create AS_AND_EXPR::source
r.test:=e1; r.if_true:=e2;-- AM_IF_EXPR::test AM_IF_EXPR::if_true
abc::=#AM_BOOL_CONST(e.source); -- AM_BOOL_CONST::create AS_AND_EXPR::source
abc.val:=false;-- AM_BOOL_CONST::val
r.if_false:=abc;-- AM_IF_EXPR::if_false
r.tp_at:=TP_BUILTIN::bool; -- AM_IF_EXPR::tp_at TP_BUILTIN::bool
return r;
end;
and_context_err(e:AS_AND_EXPR, tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("And expressions return BOOL objects which are " +-- TRANS::err
"not subtypes of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
transform_or_expr(e:AS_OR_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::bool.is_subtype(tp) then-- TP_BUILTIN::bool TP_CLASS::is_subtype BOOL::not
or_context_err(e,tp); return void end end;-- TRANS::or_context_err
e1:$AM_EXPR:=transform_expr(e.e1, TP_BUILTIN::bool); -- TRANS::transform_expr AS_OR_EXPR::e1 TP_BUILTIN::bool
e2:$AM_EXPR:=transform_expr(e.e2, TP_BUILTIN::bool); -- TRANS::transform_expr AS_OR_EXPR::e2 TP_BUILTIN::bool
if void(e1) or void(e2) then return void end; -- Not booleans.
r::=#AM_IF_EXPR(e.source);-- AM_IF_EXPR::create AS_OR_EXPR::source
r.test:=e1; r.if_false:=e2;-- AM_IF_EXPR::test AM_IF_EXPR::if_false
abc::=#AM_BOOL_CONST(e.source); abc.val:=true;-- AM_BOOL_CONST::create AS_OR_EXPR::source AM_BOOL_CONST::val
r.if_true:=abc;-- AM_IF_EXPR::if_true
r.tp_at:=TP_BUILTIN::bool; -- AM_IF_EXPR::tp_at TP_BUILTIN::bool
return r;
end;
or_context_err(e:AS_OR_EXPR, tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("Or expressions return BOOL objects which are " +-- TRANS::err
"not subtypes of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
transform_except_expr(e:AS_EXCEPT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if in_constant then except_const_err(e); return void end; -- TRANS::in_constant TRANS::except_const_err
if in_protect_then=false then except_loc_err(e); return void end;-- TRANS::in_protect_then BOOL::is_eq TRANS::except_loc_err
r::=#AM_EXCEPT_EXPR(ex_tp);-- AM_EXCEPT_EXPR::create TRANS::ex_tp
if ~void(tp) then-- BOOL::not
if ~r.tp.is_subtype(tp) then-- AM_EXCEPT_EXPR::tp BOOL::not
except_context_err(e,r.tp,tp); return void end end;-- TRANS::except_context_err AM_EXCEPT_EXPR::tp
return r;
end;
except_const_err(e:AS_EXCEPT_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`exception' expressions may not appear in shared "
"or constant initialization expressions."); -- TRANS::err
end;
except_loc_err(e:AS_EXCEPT_EXPR) is
err_loc(e); -- TRANS::err_loc
err("`exception' expressions may only appear in `then'"
"and `else' clauses of `protect' statements."); -- TRANS::err
end;
except_context_err(e:AS_EXCEPT_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of the exception expression: "+ stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
transform_new_expr(e:AS_NEW_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if in_constant then new_const_err(e); return void end; -- TRANS::in_constant TRANS::new_const_err
t::=impl.tp; -- The type in which this appears.-- TRANS::impl IMPL::tp
k:INT:=t.kind;
if (k/=TP_KIND::ref_tp and k/=TP_KIND::spr_tp and k/=TP_KIND::part_tp) -- INT::is_eq TP_KIND::ref_tp BOOL::not INT::is_eq TP_KIND::spr_tp BOOL::not INT::is_eq TP_KIND::part_tp BOOL::not
then
new_in_non_ref_or_part_err(e); -- TRANS::new_in_non_ref_or_part_err
return void;
end;
r:AM_NEW_EXPR;
-- new expressions can not be optimized out because they
-- actually modify state
cur_se.mark_unsafe;-- TRANS::cur_se SE_CONTEXT::mark_unsafe
if ~void(tp) then-- BOOL::not
if ~t.is_subtype(tp) then-- BOOL::not
new_context_err(e,t,tp); return void end end;-- TRANS::new_context_err
if ~void(e.arg) then -- Specifies asize.-- AS_NEW_EXPR::arg BOOL::not
if void(impl.arr) then new_arg_no_array_err(e); return void end;-- TRANS::impl IMPL::arr TRANS::new_arg_no_array_err
r:=#AM_NEW_EXPR(e.source); r.tp_at:=t; -- AM_NEW_EXPR::create AS_NEW_EXPR::source AM_NEW_EXPR::tp_at
r.asz:=transform_expr(e.arg,TP_BUILTIN::int);-- AM_NEW_EXPR::asz TRANS::transform_expr AS_NEW_EXPR::arg TP_BUILTIN::int
if void(r.asz) then return void end;-- AM_NEW_EXPR::asz
else -- Not an array class.
if ~void(impl.arr) then new_no_arg_array_err(e); return void end;-- TRANS::impl IMPL::arr BOOL::not TRANS::new_no_arg_array_err
r:=#AM_NEW_EXPR(e.source); r.tp_at:=t end;-- AM_NEW_EXPR::create AS_NEW_EXPR::source AM_NEW_EXPR::tp_at
return r;
end;
new_const_err(e:AS_NEW_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`new' expressions may not appear in shared or constant "
"initialization expressions."); -- TRANS::err
end;
new_in_non_ref_or_part_err(e:AS_NEW_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`new' expressions may only appear in reference partial classes.") -- TRANS::err
end;
new_context_err(e:AS_NEW_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of the `new' expression: " + stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
new_arg_no_array_err(e:AS_NEW_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`new' expressions only take an argument in classes "
"which have an include path to AREF."); -- TRANS::err
end;
new_no_arg_array_err(e:AS_NEW_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`new' expressions must take an argument specifying "
"`asize' in classes which have an include path to AREF."); -- TRANS::err
end;
transform_initial_expr(e:AS_INITIAL_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
-- Append initialization code to `init_stmts'.
if ~in_post then initial_out_of_post_err(e); return void end;-- TRANS::in_post BOOL::not TRANS::initial_out_of_post_err
if in_initial then nested_initial_err(e); return void end;-- TRANS::in_initial TRANS::nested_initial_err
in_initial:=true; -- TRANS::in_initial
te:$AM_EXPR:=transform_expr(e.e,tp); -- TRANS::transform_expr AS_INITIAL_EXPR::e
in_initial:=false;-- TRANS::in_initial
if void(te) then return void end;
v::=#AM_LOCAL_EXPR(e.source, void,te.tp);-- AM_LOCAL_EXPR::create AS_INITIAL_EXPR::source
cur_rout.locals:=cur_rout.locals.push(v);-- TRANS::cur_rout AM_ROUT_DEF::locals TRANS::cur_rout AM_ROUT_DEF::locals FLIST{1}::push
as::=#AM_ASSIGN_STMT(e.source); -- AM_ASSIGN_STMT::create AS_INITIAL_EXPR::source
as.src:=te; as.dest:=v;-- AM_ASSIGN_STMT::src AM_ASSIGN_STMT::dest
inst::=#AM_INITIAL_STMT(e.source); -- AM_INITIAL_STMT::create AS_INITIAL_EXPR::source
inst.tp:=impl.tp; inst.stmts:=as;-- AM_INITIAL_STMT::tp TRANS::impl IMPL::tp AM_INITIAL_STMT::stmts
if void(init_stmts) then init_stmts:=inst-- TRANS::init_stmts TRANS::init_stmts
else init_stmts.append(inst) end;-- TRANS::init_stmts
return v;
end;
initial_out_of_post_err(e:AS_INITIAL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`initial' expressions can only occur in `post' clauses.") -- TRANS::err
end;
nested_initial_err(e:AS_INITIAL_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`initial' expressions may not be nested."); -- TRANS::err
end;
initial_context_err(e:AS_INITIAL_EXPR, stp,tp:$TP) is
err_loc(e);
err("The type of the `initial' expression: " + stp.str +
" is not a subtype of " + tp.str + ".");
end;
transform_break_expr(e:AS_BREAK_EXPR, tp:$TP):$AM_EXPR is
-- Break's must always be handled in expression statements. If
-- we get here, something's wrong.
err_loc(e);-- TRANS::err_loc
err("`break!' may not appear as a part of an expression.");-- TRANS::err
return void;
end;
transform_result_expr(e:AS_RESULT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if in_post=false then result_out_of_post_err(e); return void end;-- TRANS::in_post BOOL::is_eq TRANS::result_out_of_post_err
if in_initial=true then result_in_initial_err(e); return void end;-- TRANS::in_initial BOOL::is_eq TRANS::result_in_initial_err
if void(cur_rout.rres) then -- TRANS::cur_rout AM_ROUT_DEF::rres
if void(cur_rout.sig.ret) then -- TRANS::cur_rout AM_ROUT_DEF::sig SIG::ret
result_and_no_return_err(e); return void end;-- TRANS::result_and_no_return_err
cur_rout.rres:=#AM_LOCAL_EXPR(e.source,void,cur_rout.sig.ret) end;-- TRANS::cur_rout AM_ROUT_DEF::rres AM_LOCAL_EXPR::create AS_RESULT_EXPR::source TRANS::cur_rout AM_ROUT_DEF::sig SIG::ret
if ~void(tp) then-- BOOL::not
if ~cur_rout.rres.tp.is_subtype(tp) then-- TRANS::cur_rout AM_ROUT_DEF::rres AM_LOCAL_EXPR::tp BOOL::not
result_context_err(e,cur_rout.rres.tp,tp); return void end end;-- TRANS::result_context_err TRANS::cur_rout AM_ROUT_DEF::rres AM_LOCAL_EXPR::tp
r::=cur_rout.rres;-- TRANS::cur_rout AM_ROUT_DEF::rres
return r;
end;
result_out_of_post_err(e:AS_RESULT_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`result' expressions can only occur in `post' clauses.")-- TRANS::err
end;
result_in_initial_err(e:AS_RESULT_EXPR) is
err_loc(e);-- TRANS::err_loc
err("`result' expressions may not appear in `initial' expressions."); -- TRANS::err
end;
result_and_no_return_err(e:AS_RESULT_EXPR) is
err_loc(e); -- TRANS::err_loc
err("`result' expressions may not appear in routines or "
"iters without return values."); -- TRANS::err
end;
result_context_err(e:AS_RESULT_EXPR, stp,tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("The type of the `result' expression: " + stp.str +-- TRANS::err STR::plus
" is not a subtype of " + tp.str + "."); -- STR::plus STR::plus STR::plus
end;
transform_bool_lit_expr(e:AS_BOOL_LIT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::bool.is_subtype(tp) then-- TP_BUILTIN::bool TP_CLASS::is_subtype BOOL::not
bool_lit_context_err(e,tp); return void end end;-- TRANS::bool_lit_context_err
r::=#AM_BOOL_CONST(e.source); -- AM_BOOL_CONST::create AS_BOOL_LIT_EXPR::source
r.tp_at:=TP_BUILTIN::bool;-- AM_BOOL_CONST::tp_at TP_BUILTIN::bool
r.val:=e.val; -- AM_BOOL_CONST::val AS_BOOL_LIT_EXPR::val
return r;
end;
bool_lit_context_err(e:AS_BOOL_LIT_EXPR, tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("Boolean literals are not subtypes of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_char_lit_expr(e:AS_CHAR_LIT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::char.is_subtype(tp) then-- TP_BUILTIN::char TP_CLASS::is_subtype BOOL::not
char_lit_context_err(e,tp); return void end end;-- TRANS::char_lit_context_err
r::=#AM_CHAR_CONST(e); -- AM_CHAR_CONST::create
r.tp_at:=TP_BUILTIN::char;-- AM_CHAR_CONST::tp_at TP_BUILTIN::char
return r;
end;
char_lit_context_err(e:AS_CHAR_LIT_EXPR, tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("Character literals are not subtypes of " + tp.str + ".") -- TRANS::err STR::plus STR::plus
end;
transform_str_lit_expr(e:AS_STR_LIT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::str.is_subtype(tp) then-- TP_BUILTIN::str TP_CLASS::is_subtype BOOL::not
str_lit_context_err(e,tp); return void end end;-- TRANS::str_lit_context_err
r::=#AM_STR_CONST(e); r.tp_at:=TP_BUILTIN::str;-- AM_STR_CONST::create AM_STR_CONST::tp_at TP_BUILTIN::str
return r;
end;
str_lit_context_err(e:AS_STR_LIT_EXPR, tp:$TP) is
err_loc(e); -- TRANS::err_loc
err("String literals are not subtypes of " + tp.str + "."); -- TRANS::err STR::plus STR::plus
end;
transform_int_lit_expr(e:AS_INT_LIT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
if e.is_inti then-- AS_INT_LIT_EXPR::is_inti
ri::=#AM_INTI_CONST(e); -- AM_INTI_CONST::create
ri.tp_at:=TP_BUILTIN::inti; -- AM_INTI_CONST::tp_at TP_BUILTIN::inti
if void(tp) then
return ri
elsif ~ri.tp_at.is_subtype(tp) then-- AM_INTI_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of INTI."); return void-- STR::plus STR::plus
else
return ri
end;
else
r::=#AM_INT_CONST(e); -- AM_INT_CONST::create
r.tp_at:=TP_BUILTIN::int; -- AM_INT_CONST::tp_at TP_BUILTIN::int
if void(tp) then
return r
elsif ~r.tp_at.is_subtype(tp) then-- AM_INT_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of INT."); return void-- STR::plus STR::plus
else
return r
end;
end;
end;
transform_flt_lit_expr(e:AS_FLT_LIT_EXPR, tp:$TP):$AM_EXPR is
-- Expression implementing `e' in type context `tp'.
case e.tp-- AS_FLT_LIT_EXPR::tp
when AS_FLT_LIT_EXPR::flt then-- AS_FLT_LIT_EXPR::flt
rf::=#AM_FLT_CONST(e); -- AM_FLT_CONST::create
rf.tp_at:=TP_BUILTIN::flt; -- AM_FLT_CONST::tp_at TP_BUILTIN::flt
if void(tp) then
return rf
elsif ~rf.tp_at.is_subtype(tp) then-- AM_FLT_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of FLT."); return void-- STR::plus STR::plus
else
return rf
end;
when AS_FLT_LIT_EXPR::fltd then-- AS_FLT_LIT_EXPR::fltd
rfd::=#AM_FLTD_CONST(e); -- AM_FLTD_CONST::create
rfd.tp_at:=TP_BUILTIN::fltd; -- AM_FLTD_CONST::tp_at TP_BUILTIN::fltd
if void(tp) then
return rfd
elsif ~rfd.tp_at.is_subtype(tp) then-- AM_FLTD_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of FLTD."); return void-- STR::plus STR::plus
else
return rfd
end;
when AS_FLT_LIT_EXPR::fltx then-- AS_FLT_LIT_EXPR::fltx
rfx::=#AM_FLTX_CONST(e); -- AM_FLTX_CONST::create
rfx.tp_at:=TP_BUILTIN::fltx; -- AM_FLTX_CONST::tp_at TP_BUILTIN::fltx
if void(tp) then
return rfx
elsif ~rfx.tp_at.is_subtype(tp) then-- AM_FLTX_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of FLTX."); return void-- STR::plus STR::plus
else
return rfx
end;
when AS_FLT_LIT_EXPR::fltdx then-- AS_FLT_LIT_EXPR::fltdx
rfdx::=#AM_FLTDX_CONST(e); -- AM_FLTDX_CONST::create
rfdx.tp_at:=TP_BUILTIN::fltdx; -- AM_FLTDX_CONST::tp_at TP_BUILTIN::fltdx
if void(tp) then
return rfdx
elsif ~rfdx.tp_at.is_subtype(tp) then-- AM_FLTDX_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of FLTDX."); return void-- STR::plus STR::plus
else
return rfdx
end;
when AS_FLT_LIT_EXPR::flti then-- AS_FLT_LIT_EXPR::flti
rfi::=#AM_FLTI_CONST(e); -- AM_FLTI_CONST::create
rfi.tp_at:=TP_BUILTIN::flti; -- AM_FLTI_CONST::tp_at TP_BUILTIN::flti
if void(tp) then
return rfi
elsif ~rfi.tp_at.is_subtype(tp) then-- AM_FLTI_CONST::tp_at BOOL::not
err_loc(e); err("The type of the destination: " +-- TRANS::err_loc TRANS::err
tp.str + " is not a supertype of FLTI."); return void-- STR::plus STR::plus
else
return rfi
end;
end;
end;
transform_cluster_expr(e:AS_CLUSTER_EXPR, tp:$TP):$AM_EXPR is
-- Although clusters belongs to pSather it is translated in serial
-- Sather as well.
if ~prog.psather then-- TRANS::prog PROG::psather BOOL::not
-- we allow cluster to appear in SYS::builtin_clusters!
if cur_rout.sig.tp = TP_BUILTIN::sys -- TRANS::cur_rout AM_ROUT_DEF::sig SIG::tp TP_BUILTIN::sys
and cur_rout.sig.name = #IDENT("builtin_clusters!") -- TRANS::cur_rout AM_ROUT_DEF::sig SIG::name IDENT::is_eq IDENT::create
then
asint ::= #AS_INT_LIT_EXPR; -- AS_INT_LIT_EXPR::create
asint.val := #INTI(1);-- AS_INT_LIT_EXPR::val INTI::create
r ::= #AM_INT_CONST(asint);-- AM_INT_CONST::create
return r
else
err("`clusters' is a key word of pSather and may not be used in sequential Sather'");-- TRANS::err
return void;
end;
else
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::int.is_subtype(tp) then-- TP_BUILTIN::int TP_CLASS::is_subtype BOOL::not
cluster_context_err(e,tp); return void; -- TRANS::cluster_context_err
end;
end;
r::=#AM_CLUSTER_EXPR(e.source);-- AM_CLUSTER_EXPR::create AS_CLUSTER_EXPR::source
return r;
end;
end;
cluster_context_err(e:AS_CLUSTER_EXPR, tp:$TP) is
err_loc(e);-- TRANS::err_loc
err("'clusters' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_cluster_size_expr(e:AS_CLUSTER_SIZE_EXPR, tp:$TP):$AM_EXPR is
if ~prog.psather then-- TRANS::prog PROG::psather BOOL::not
err("`cluster_size' is a key word of pSather and may not be used in sequential Sather'");-- TRANS::err
return void;
else
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::int.is_subtype(tp) then-- TP_BUILTIN::int TP_CLASS::is_subtype BOOL::not
cluster_size_context_err(e,tp); return void; -- TRANS::cluster_size_context_err
end;
end;
r::=#AM_CLUSTER_SIZE_EXPR(e.source);-- AM_CLUSTER_SIZE_EXPR::create AS_CLUSTER_SIZE_EXPR::source
return r;
end;
end;
cluster_size_context_err(e:AS_CLUSTER_SIZE_EXPR, tp:$TP) is
err_loc(e);-- TRANS::err_loc
err("'clusters_procs' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
check_return(t:AS_ROUT_DEF) is
-- Check the routine `t' to make sure that if it has a return
-- value, then the last statement actually returns a value.
-- If not, then print an error.
if void(t) then return end;
if void(t.ret_dec) then return end; -- No return value.-- AS_ROUT_DEF::ret_dec
if t.name.is_iter then return end; -- No check for iters.-- AS_ROUT_DEF::name IDENT::is_iter
if t.is_builtin then return end; -- No check for builtins.-- AS_ROUT_DEF::is_builtin
err_loc(t);-- TRANS::err_loc
check_stmt_list_for_return(t.body) end;-- TRANS::check_stmt_list_for_return AS_ROUT_DEF::body
check_stmt_list_for_return(l:AS_STMT_LIST) is
-- `l' must either be a return statement, a raise statement
-- or terminate in one. If not, print an error.
t : $AS_STMT := l.stmts;-- AS_STMT_LIST::stmts
if void(t) then return_err; return end;-- TRANS::return_err
s:$AS_STMT:=t; loop until!(void(s.next)); s:=s.next end;
err_loc(s);-- TRANS::err_loc
typecase s
when AS_DEC_STMT then return_err-- TRANS::return_err
when AS_ASSIGN_STMT then return_err-- TRANS::return_err
when AS_IF_STMT then check_stmt_list_for_return(s.then_part);-- TRANS::check_stmt_list_for_return AS_IF_STMT::then_part
if ~void(s.else_part) then check_stmt_list_for_return(s.else_part) end;-- AS_IF_STMT::else_part BOOL::not TRANS::check_stmt_list_for_return AS_IF_STMT::else_part
when AS_LOOP_STMT then
-- Don't check anything if the last statement is a loop since
-- can't be sure. (Maybe later check whether there is a return
-- or raise somewhere in the loop.)
-- check_stmt_list_for_return(s.body);
when AS_RETURN_STMT then
when AS_YIELD_STMT then return_err-- TRANS::return_err
when AS_QUIT_STMT then return_err-- TRANS::return_err
when AS_CASE_STMT then
if ~s.no_else then-- AS_CASE_STMT::no_else BOOL::not
check_stmt_list_for_return(s.else_part) end;-- TRANS::check_stmt_list_for_return AS_CASE_STMT::else_part
wp:AS_CASE_WHEN:=s.when_part;-- AS_CASE_STMT::when_part
loop while!(~void(wp));-- BOOL::not
check_stmt_list_for_return(wp.then_part);-- TRANS::check_stmt_list_for_return AS_CASE_WHEN::then_part
wp:=wp.next end;-- AS_CASE_WHEN::next
when AS_TYPECASE_STMT then
if ~s.no_else then-- AS_TYPECASE_STMT::no_else BOOL::not
check_stmt_list_for_return(s.else_part) end; -- TRANS::check_stmt_list_for_return AS_TYPECASE_STMT::else_part
wp:AS_TYPECASE_WHEN:=s.when_part;-- AS_TYPECASE_STMT::when_part
loop while!(~void(wp));-- BOOL::not
check_stmt_list_for_return(wp.then_part);-- TRANS::check_stmt_list_for_return AS_TYPECASE_WHEN::then_part
wp:=wp.next end;-- AS_TYPECASE_WHEN::next
when AS_ASSERT_STMT then return_err-- TRANS::return_err
when AS_PROTECT_STMT then
if ~s.no_else then-- AS_PROTECT_STMT::no_else BOOL::not
check_stmt_list_for_return(s.else_part) end; -- TRANS::check_stmt_list_for_return AS_PROTECT_STMT::else_part
wp:AS_PROTECT_WHEN:=s.when_part;-- AS_PROTECT_STMT::when_part
loop while!(~void(wp));-- BOOL::not
check_stmt_list_for_return(wp.then_part);-- TRANS::check_stmt_list_for_return AS_PROTECT_WHEN::then_part
wp:=wp.next end;-- AS_PROTECT_WHEN::next
when AS_RAISE_STMT then
when AS_EXPR_STMT then return_err-- TRANS::return_err
else check_pSather_stmt_for_return(s);-- TRANS::check_pSather_stmt_for_return
end;
end;
return_err is
err("Routine must terminate with a `return' statement or a "
"`raise' statement."); -- TRANS::err
end;
name_for_ext(el:ELT):IDENT is
-- Name to use for an external class call.
if el.is_abstract then return el.sig.name;-- ELT::is_abstract ELT::sig SIG::name
else return #IDENT(el.tp.str+'_'+el.sig.name.str);-- IDENT::create ELT::tp STR::plus STR::plus ELT::sig SIG::name IDENT::str
end;
end;
end; -- class STRANS