ptrans.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. <----------
-- ptrans.sa: pSather Transformation of code from AS to AM form.
class PTRANS
class PTRANS is
-- The context for a code transformation from AS form to AM form.
include STRANS
-- The following routines have already dummies in STRANS
-- which are redefined in class PTRANS.
is_in_par_or_fork ->,
is_in_lock ->,
transform_stmt_list ->,
transform_if_stmt ->,
transform_case_stmt ->,
transform_pSather_stmt ->,
transform_pSather_rout_elt_stuff ->,
transform_pSather_assign_stmt_err ->,
-- transform_pSather_protect_when_stuff ->,
-- transform_pSather_protect_else_stuff ->,
transform_pSather_expr ->,
check_pSather_stmt_for_return ->,
sys_closure_self ->,
sys_closure_nest ->,
transform_pSather_local_assign ->,
iter_call_out_of_loop_err ->;
attr cur_param_ob:AM_LOCAL_EXPR; -- If the current routine implements
-- a fork or a par then cur_param_ob
-- is the helper object
attr cur_par_ob:AM_LOCAL_EXPR; -- only par helper object
attr cur_cohort:AM_LOCAL_EXPR;
attr cur_lock:$AM_STMT; -- lock branch.
const import_code := 1;
const export_code := 2;
const frk_code := 11;
const par_code := 12;
const att_code := 13;
const do_helper_import : BOOL := true; -- should be true except for debug
const do_helper_export : BOOL := false; -- should be false except for debug
const do_direct_export : BOOL := true; -- should be true except for debug
is_in_lock:BOOL
-- is called in non-pSather programs as well
is
if ~prog.psather then return false-- TRANS::prog PROG::psather BOOL::not
else
-- True if we are working on a lock
return ~void(cur_lock)-- TRANS::cur_lock
end;-- BOOL::not
end;
is_in_par_or_fork:BOOL
-- is called in non-pSather programs as well
is
if ~prog.psather then return false-- TRANS::prog PROG::psather BOOL::not
else
-- True if we are working on a par, parloop, or fork
return (cur_rout.is_fork_routine or cur_rout.is_par_routine)-- TRANS::cur_rout AM_ROUT_DEF::is_fork_routine TRANS::cur_rout AM_ROUT_DEF::is_par_routine
end;
end;
active_locals_and_params!:AM_LOCAL_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if void(cur_rout) then quit; end;-- TRANS::cur_rout
-- return parameters (without self) first
if cur_rout.asize > 1 then-- TRANS::cur_rout AM_ROUT_DEF::asize INT::is_lt
loop
yield cur_rout.elt!(1).expr;-- TRANS::cur_rout AM_ROUT_DEF::elt! AM_FORMAL_ARG::expr
end;
end;
-- return locals which are not "nonames" and have a type
if active_locals.size > 0 then-- TRANS::active_locals FLIST{1}::size INT::is_lt
loop
loc ::= active_locals.elt!;-- TRANS::active_locals FLIST{1}::elt!
if ~void(loc.name) and ~void(loc.tp_at) then yield loc; end;-- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::tp_at BOOL::not
end;
end;
end;
last_declared_helper:AM_LOCAL_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
idx ::= active_locals.size;-- TRANS::active_locals FLIST{1}::size
loop while!(idx > 0);-- INT::is_lt
idx := idx - 1;-- INT::minus
loc ::= active_locals[idx];-- TRANS::active_locals FLIST{1}::aget
if ~void(loc.name) and ~void(loc.tp_at) -- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::tp_at
and (loc.name.str.size >= 7)-- BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::size INT::is_lt
and ( loc.name.str.head(7) = "_pS_par" -- par or fork-- AM_LOCAL_EXPR::name IDENT::str STR::head STR::is_eq
or loc.name.str.head(7) = "_pS_att") -- AM_LOCAL_EXPR::name IDENT::str STR::head STR::is_eq
then return loc end;
end;
idx := cur_rout.size;-- TRANS::cur_rout AM_ROUT_DEF::size
loop while!(idx > 0);-- INT::is_lt
idx := idx - 1;-- INT::minus
loc ::= cur_rout[idx].expr;-- TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
if ~void(loc.name) and ~void(loc.tp_at) -- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::tp_at
and (loc.name.str.size >= 7)-- BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::size INT::is_lt
and ( loc.name.str.head(7) = "_pS_par" -- par or fork-- AM_LOCAL_EXPR::name IDENT::str STR::head STR::is_eq
or loc.name.str.head(7) = "_pS_att") -- AM_LOCAL_EXPR::name IDENT::str STR::head STR::is_eq
then return loc end;
end;
return void;
end;
main is a::=last_declared_helper; end;
-----
last_declared_par_helper:AM_LOCAL_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
idx ::= active_locals.size;-- TRANS::active_locals FLIST{1}::size
loop while!(idx > 0);-- INT::is_lt
idx := idx - 1;-- INT::minus
loc ::= active_locals[idx];-- TRANS::active_locals FLIST{1}::aget
if ~void(loc.name) and ~void(loc.tp_at) -- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::tp_at
and loc.name.str.size >= 10-- BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::size INT::is_lt
and loc.name.str.head(10) = "_pS_par_ob"-- BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::head
then return loc end;-- STR::is_eq
end;
idx := cur_rout.size;-- TRANS::cur_rout AM_ROUT_DEF::size
loop while!(idx > 0);-- INT::is_lt
idx := idx - 1;-- INT::minus
loc ::= cur_rout[idx].expr;-- TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
if ~void(loc.name) and ~void(loc.tp_at) -- AM_LOCAL_EXPR::name BOOL::not AM_LOCAL_EXPR::tp_at
and loc.name.str.size >= 10-- BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::size INT::is_lt
and loc.name.str.head(10) = "_pS_par_ob"-- BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::head
then return loc end;-- STR::is_eq
end;
return void;
end;
previous(s:$AS_STMT):$AS_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
-- returns the preceeding statement in the list of statements of `s'.
-- returns void is this list is void or if `s' is the first element.
body ::= s.surr_stmt_list;
curr : $AS_STMT := body.stmts;-- AS_STMT_LIST::stmts
prev : $AS_STMT;
loop
if void(curr) then break! end;
if SYS::ob_eq(curr,s) then return prev end;-- SYS::ob_eq
prev := curr; curr := curr.next;
end;
return void;
end;
iter_call_out_of_loop_err
-- this is called in non-pSather programs as well
is
if ~prog.psather then-- TRANS::prog PROG::psather BOOL::not
err("Iters may only be called within loop statements."); -- TRANS::err
else
if void(cur_param_ob) then-- TRANS::cur_param_ob
err("Iters may only be called within loop statements.")-- TRANS::err
elsif cur_rout.is_attach_routine then-- TRANS::cur_rout AM_ROUT_DEF::is_attach_routine
err("Iters may not be called on the rhs of an attach statement.")-- TRANS::err
else
err("Iters need a surrounding loop inside `fork',"+-- TRANS::err
"`par', and `parloop'.");-- STR::plus
end;
end;
end;
transform_pSather_rout_elt_stuff(as:AS_ROUT_DEF)
pre prog.psather-- TRANS::prog PROG::psather
is
cur_rout.is_par_routine := as.is_par_routine;-- TRANS::cur_rout AM_ROUT_DEF::is_par_routine AS_ROUT_DEF::is_par_routine
cur_rout.is_fork_routine := as.is_fork_routine;-- TRANS::cur_rout AM_ROUT_DEF::is_fork_routine AS_ROUT_DEF::is_fork_routine
cur_rout.is_attach_routine := as.is_attach_routine;-- TRANS::cur_rout AM_ROUT_DEF::is_attach_routine AS_ROUT_DEF::is_attach_routine
cur_rout.sig.is_forked:=-- TRANS::cur_rout AM_ROUT_DEF::sig SIG::is_forked
cur_rout.is_par_routine-- TRANS::cur_rout AM_ROUT_DEF::is_par_routine
or cur_rout.is_fork_routine-- TRANS::cur_rout AM_ROUT_DEF::is_fork_routine
or cur_rout.is_attach_routine;-- TRANS::cur_rout AM_ROUT_DEF::is_attach_routine
if cur_rout.sig.is_forked then-- TRANS::cur_rout AM_ROUT_DEF::sig SIG::is_forked
cur_param_ob:=cur_rout[1].expr;-- TRANS::cur_param_ob TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
if cur_rout.is_par_routine then cur_par_ob := cur_rout[1].expr end;-- TRANS::cur_rout AM_ROUT_DEF::is_par_routine TRANS::cur_par_ob TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
if ~cur_rout.is_attach_routine then cur_cohort:=cur_rout[2].expr end;-- TRANS::cur_rout AM_ROUT_DEF::is_attach_routine BOOL::not TRANS::cur_cohort TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::expr
end;
end;
transform_stmt_list(l:AS_STMT_LIST):$AM_STMT
-- this is called in non-pSather programs as well!
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;-- AS_STMT_LIST::stmts
if void(s) then return void end;
osize:INT;
if ~void(active_locals) then osize:=active_locals.size end;-- TRANS::active_locals BOOL::not TRANS::active_locals FLIST{1}::size
r:$AM_STMT;
last : $AS_STMT;
loop while!(~void(s));-- BOOL::not
-- #OUT+"work on the statement list:\n";AS_OUT::AS_STMT_LIST_out(l);
-- #OUT+"work on the following statement:\n";AS_OUT::AS_STMT_out(s);
t ::= transform_stmt(s);-- TRANS::transform_stmt
if prog.psather then-- TRANS::prog PROG::psather
-- add export before current statement?
-- #OUT+"add export before current statement\n";
export : $AS_STMT := void;
if ~s.transformed then-- BOOL::not
if cur_rout.export_locals_pending then-- TRANS::cur_rout AM_ROUT_DEF::export_locals_pending
-- #OUT+"insert export:\n"; AS_OUT::AS_STMT_out(s);
if do_helper_export then-- TRANS::do_helper_export
export := as_for_import_export(export_code,l,s.source);-- TRANS::export_code
end;
-- #OUT+"new export statements\n";
-- AS_OUT::AS_STMT_out(export);
-- #OUT+"stmt list after exp loc:\n";
-- AS_OUT::AS_STMT_LIST_out(l);
end;
if cur_rout.export_call_pending then-- TRANS::cur_rout AM_ROUT_DEF::export_call_pending
-- A call of SYS::export is added (if there are locals to be
-- exported) then the call os SYS::export is after those
-- Both locals and SYS::export preceed the current statement
sys_exp ::= as_for_sys_import_export(export_code,l,s.source);-- TRANS::export_code
sys_exp.transformed := true;
if void(export) then export := sys_exp
else export.append(sys_exp) end;
-- #OUT+"stmt list after exp call:\n";
-- AS_OUT::AS_STMT_LIST_out(l);
end;
end;
cur_rout.export_done;-- TRANS::cur_rout AM_ROUT_DEF::export_done
if ~void(export) then-- BOOL::not
-- keep import.pending states:
imp_local_pending ::= cur_rout.import_locals_pending;-- TRANS::cur_rout AM_ROUT_DEF::import_locals_pending
imp_call_pending ::= cur_rout.import_call_pending;-- TRANS::cur_rout AM_ROUT_DEF::import_call_pending
-- make new statement list and transform this list into AM form
exp_stmt_list ::= #AS_STMT_LIST;-- AS_STMT_LIST::create
exp_stmt_list.stmts := export;-- AS_STMT_LIST::stmts
-- #OUT+"new export statements in list\n";
-- AS_OUT::AS_STMT_LIST_out(exp_stmt_list);
exp ::= transform_stmt_list(exp_stmt_list);-- TRANS::transform_stmt_list
-- #OUT+"exp erzeugt\n";
-- #OUT+"export - appending\n";
export.append(s);
if void(last) then l.stmts := export;-- AS_STMT_LIST::stmts
else last.next := export; end;
-- #OUT+"done\n";
if ~void(exp) then-- BOOL::not
-- #OUT+"exp appending\n";
exp.append(t); t:=exp;
-- #OUT+"done\n";
end;
-- restore import.pending states:
if imp_local_pending then cur_rout.needs_import_locals end;-- TRANS::cur_rout AM_ROUT_DEF::needs_import_locals
if imp_call_pending then cur_rout.needs_import_call end;-- TRANS::cur_rout AM_ROUT_DEF::needs_import_call
end;
end; -- pSather only
if void(r) then r:=t; else r.append(t) end;
if prog.psather then-- TRANS::prog PROG::psather
-- add import after current statement
-- #OUT+"add import after current statement\n";
if ~s.transformed then-- BOOL::not
if cur_rout.import_locals_pending then -- TRANS::cur_rout AM_ROUT_DEF::import_locals_pending
insert_import_after(s) ;-- TRANS::insert_import_after
-- #OUT+"stmt list after imp loc:\n";
-- AS_OUT::AS_STMT_LIST_out(l);
end;
if cur_rout.import_call_pending then-- TRANS::cur_rout AM_ROUT_DEF::import_call_pending
-- A call of SYS::import is added after the current statement
-- unless the current statement is of one of types in the
-- typecase. Note that the call of SYS::import preceeds all
-- imports of local variables which are added in the previous
-- if (import_locals_pending). Hence the total order is
-- (a) current statement (b) import of locals (c) SYS::import.
typecase t
when AS_RETURN_STMT then
when AS_RAISE_STMT then
when AS_QUIT_STMT then
else
sys_imp::=as_for_sys_import_export(import_code,l,s.source);-- TRANS::import_code
sys_imp.transformed := true;
sys_imp.append(s.next);
s.next := sys_imp;
end;
-- #OUT+"stmt list after imp call:\n";
-- AS_OUT::AS_STMT_LIST_out(l);
end;
end;
cur_rout.import_done;-- TRANS::cur_rout AM_ROUT_DEF::import_done
end; -- pSather only
s.transformed := true;
last:=s; s:=s.next;
end;
-- Close off the scope:
if ~void(active_locals) then-- TRANS::active_locals BOOL::not
loop while!(active_locals.size>osize); -- TRANS::active_locals FLIST{1}::size INT::is_lt
ignore::=active_locals.pop end;-- TRANS::active_locals FLIST{1}::pop
end;
return r;
end;
transform_if_stmt(s:AS_IF_STMT):$AM_STMT
-- this is called in non-pSather programs as well
is
-- A list of AM_STMT's which implements the source statement `s'.
r::=#AM_IF_STMT(s.source); -- AM_IF_STMT::create AS_IF_STMT::source
r.test:=transform_expr(s.test, TP_BUILTIN::bool);-- AM_IF_STMT::test TRANS::transform_expr AS_IF_STMT::test TP_BUILTIN::bool
if void(r.test) then return void end; -- Not a boolean.-- AM_IF_STMT::test
-- pSather add leading export
if prog.psather then-- TRANS::prog PROG::psather
if ~s.transformed then-- AS_IF_STMT::transformed BOOL::not
if cur_rout.import_locals_pending then-- TRANS::cur_rout AM_ROUT_DEF::import_locals_pending
if ~void(s.then_part) then -- AS_IF_STMT::then_part BOOL::not
insert_import(s.then_part,s.source) end;-- TRANS::insert_import AS_IF_STMT::then_part AS_IF_STMT::source
if ~void(s.else_part) then -- AS_IF_STMT::else_part BOOL::not
insert_import(s.else_part,s.source) end;-- TRANS::insert_import AS_IF_STMT::else_part AS_IF_STMT::source
end;
if cur_rout.import_call_pending then-- TRANS::cur_rout AM_ROUT_DEF::import_call_pending
if ~void(s.then_part) then-- AS_IF_STMT::then_part BOOL::not
sys_imp ::= as_for_sys_import_export(import_code,s.then_part,s.source);-- TRANS::import_code AS_IF_STMT::then_part AS_IF_STMT::source
sys_imp.transformed := true;
sys_imp.append(s.then_part.stmts);-- AS_IF_STMT::then_part AS_STMT_LIST::stmts
s.then_part.stmts := sys_imp;-- AS_IF_STMT::then_part AS_STMT_LIST::stmts
end;
if ~void(s.else_part) then-- AS_IF_STMT::else_part BOOL::not
sys_imp ::= as_for_sys_import_export(import_code,s.else_part,s.source);-- TRANS::import_code AS_IF_STMT::else_part AS_IF_STMT::source
sys_imp.transformed := true;
sys_imp.append(s.else_part.stmts);-- AS_IF_STMT::else_part AS_STMT_LIST::stmts
s.else_part.stmts := sys_imp;-- AS_IF_STMT::else_part AS_STMT_LIST::stmts
end;
end;
end;
cur_rout.import_done; -- TRANS::cur_rout AM_ROUT_DEF::import_done
end; -- pSather only
r.if_true:=transform_stmt_list(s.then_part);-- AM_IF_STMT::if_true TRANS::transform_stmt_list AS_IF_STMT::then_part
r.if_false:=transform_stmt_list(s.else_part); -- AM_IF_STMT::if_false TRANS::transform_stmt_list AS_IF_STMT::else_part
return r;
end;
transform_case_stmt(s:AS_CASE_STMT):$AM_STMT
-- this is called in non-pSather programs as well
is
-- A list of AM_STMT's which implements the source statement `s'.
if void(s) then return void end;
r::=#AM_ASSIGN_STMT(s.source);-- AM_ASSIGN_STMT::create AS_CASE_STMT::source
-- Assign test to a local variable.
r.src:=transform_expr(s.test,void);-- AM_ASSIGN_STMT::src TRANS::transform_expr AS_CASE_STMT::test
if void(r.src) then return void end; -- AM_ASSIGN_STMT::src
l::=#AM_LOCAL_EXPR(s.source,void,r.src.tp); -- AM_LOCAL_EXPR::create AS_CASE_STMT::source AM_ASSIGN_STMT::src
add_local(l); r.dest:=l;-- TRANS::add_local AM_ASSIGN_STMT::dest
if prog.psather then-- TRANS::prog PROG::psather
-- pSather add leading export
if ~s.transformed then-- AS_CASE_STMT::transformed BOOL::not
if cur_rout.import_locals_pending then-- TRANS::cur_rout AM_ROUT_DEF::import_locals_pending
wp ::= s.when_part;-- AS_CASE_STMT::when_part
loop
if void(wp) then break!; end;
insert_import(wp.then_part,s.source);-- TRANS::insert_import AS_CASE_WHEN::then_part AS_CASE_STMT::source
wp := wp.next;-- AS_CASE_WHEN::next
end;
if ~void(s.else_part) then-- AS_CASE_STMT::else_part BOOL::not
insert_import(s.else_part,s.source);-- TRANS::insert_import AS_CASE_STMT::else_part AS_CASE_STMT::source
end;
end;
if cur_rout.import_call_pending then-- TRANS::cur_rout AM_ROUT_DEF::import_call_pending
wp ::= s.when_part;-- AS_CASE_STMT::when_part
loop
if void(wp) then break!; end;
sys_imp ::= as_for_sys_import_export(import_code,wp.then_part,s.source);-- TRANS::import_code AS_CASE_WHEN::then_part AS_CASE_STMT::source
sys_imp.transformed := true;
sys_imp.append(wp.then_part.stmts);-- AS_CASE_WHEN::then_part AS_STMT_LIST::stmts
wp.then_part.stmts := sys_imp;-- AS_CASE_WHEN::then_part AS_STMT_LIST::stmts
wp := wp.next;-- AS_CASE_WHEN::next
end;
if ~void(s.else_part) then-- AS_CASE_STMT::else_part BOOL::not
sys_imp ::= as_for_sys_import_export(import_code,s.else_part,s.source);-- TRANS::import_code AS_CASE_STMT::else_part AS_CASE_STMT::source
sys_imp.transformed := true;
sys_imp.append(s.else_part.stmts);-- AS_CASE_STMT::else_part AS_STMT_LIST::stmts
s.else_part.stmts := sys_imp;-- AS_CASE_STMT::else_part AS_STMT_LIST::stmts
end;
end;
end;
cur_rout.import_done; -- TRANS::cur_rout AM_ROUT_DEF::import_done
end; -- pSather only
r.next:=transform_case_when(s,s.when_part,l);-- AM_ASSIGN_STMT::next TRANS::transform_case_when AS_CASE_STMT::when_part
return r;
end;
insert_import_after(t:$AS_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
-- #OUT+"insert_import_after:\n"; AS_OUT::AS_STMT_out(t);
typecase t
when AS_RETURN_STMT then return -- no import necessary
when AS_RAISE_STMT then return -- no import necessary
when AS_QUIT_STMT then return -- no import necessary
else
end;
import : $AS_STMT;
if do_helper_import then -- TRANS::do_helper_import
import := as_for_import_export(import_code,t.surr_stmt_list,t.source) -- TRANS::import_code
end;
-- #OUT+"import:\n"; AS_OUT::AS_STMT_out(import);
if ~void(import) then-- BOOL::not
import.append(t.next);
t.next := import;
-- #OUT+"remaining stmts:\n"; AS_OUT::AS_STMT_out(import);
end;
end;
insert_import(l:AS_STMT_LIST,source:SFILE_ID)
pre prog.psather-- TRANS::prog PROG::psather
is
-- #OUT+"insert_import:\n"; AS_OUT::AS_STMT_LIST_out(l);
import : $AS_STMT;
if do_helper_import then -- TRANS::do_helper_import
import := as_for_import_export(import_code,l,source) -- TRANS::import_code
end;
-- #OUT+"import:\n"; AS_OUT::AS_STMT_out(import);
if ~void(import) then-- BOOL::not
if ~void(l) then import.append(l.stmts) end;-- BOOL::not AS_STMT_LIST::stmts
l.stmts := import;-- AS_STMT_LIST::stmts
-- #OUT+"remaining stmts:\n"; AS_OUT::AS_STMT_out(import);
end;
end;
transform_pSather_stmt(s:$AS_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
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_PAR_STMT then r:= transform_par_stmt(s)-- TRANS::transform_par_stmt
when AS_INTERF_ATTACH_STMT then r:= transform_interf_attach_stmt(s)-- TRANS::transform_interf_attach_stmt
when AS_LOCK_STMT then r:= transform_lock_stmt(s)-- TRANS::transform_lock_stmt
when AS_UNLOCK_STMT then r:= transform_unlock_stmt(s)-- TRANS::transform_unlock_stmt
when AS_WITH_NEAR_STMT then r:= transform_with_near_stmt(s)-- TRANS::transform_with_near_stmt
when AS_ATTACH_STMT then r:= transform_attach_stmt(s)-- TRANS::transform_attach_stmt
when AS_FORK_STMT then r:= transform_fork_stmt(s)-- TRANS::transform_fork_stmt
when AS_SYNC_STMT then r:= transform_sync_stmt(s)-- TRANS::transform_sync_stmt
end;
return r;
end;
transform_pSather_assign_stmt_err(s:AS_ASSIGN_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
-- A list of AM_STMT's which implements the source statement `s'.
lhs:$AS_EXPR:=s.lhs_expr; err_loc(lhs); -- AS_ASSIGN_STMT::lhs_expr TRANS::err_loc
typecase lhs
when AS_HERE_EXPR then
err("It is illegal to assign to a `here' expression.");-- TRANS::err
when AS_ANY_EXPR then
err("It is illegal to assign to an `any' expression.");-- TRANS::err
when AS_COHORT_EXPR then
err("It is illegal to assign to a `cohort' expression.");-- TRANS::err
when AS_WHERE_EXPR then
err("It is illegal to assign to a where' expression.");-- TRANS::err
when AS_NEAR_EXPR then
err("It is illegal to assign to a `near' expression.");-- TRANS::err
when AS_FAR_EXPR then
err("It is illegal to assign to a `far' expression.");-- TRANS::err
when AS_AT_EXPR then
err("It is illegal to assign to an `at' expression.");-- TRANS::err
end;
end;
-- transform_pSather_protect_when_stuff(tp:$TP,wp:AS_PROTECT_WHEN,
-- s:AS_PROTECT_STMT)
-- pre prog.psather
-- is
-- -- #OUT+"enter transform_pSather_protect_when_stuff\n";
-- if void(wp.then_part) then wp.then_part := #AS_STMT_LIST;
-- wp.then_part.source := wp.source; end;
-- -- Import statements if CLEARED_EX
-- if is_in_par_or_fork and tp.str = "CLEARED_EX" and ~s.transformed then
-- -- #OUT+"import code in protect - when:\n";
-- import ::= as_for_sys_import_export(import_code,wp.then_part,wp.source);
-- if void(wp.then_part.stmts) then wp.then_part.stmts := import
-- else import.next:=wp.then_part.stmts; wp.then_part.stmts:=import end;
-- -- AS_OUT::AS_STMT_out(wp.then_part.stmts);
-- end;
-- -- Export statement
-- if ~s.transformed then
-- append_export_in_list(wp.then_part,false); -- at least one export
-- end;
-- -- AS_OUT::AS_STMT_out(wp.then_part.stmts);
-- -- #OUT+"return from transform_pSather_protect_when_stuff\n";
-- end;
-- transform_pSather_protect_else_stuff(s:AS_PROTECT_STMT)
-- pre prog.psather
-- is
-- -- #OUT+"enter transform_pSather_protect_else_stuff\n";
-- if void(s.else_part) then s.else_part := #AS_STMT_LIST;
-- s.else_part.source := s.source; end;
-- if is_in_par_or_fork and ~s.transformed then
-- -- #OUT+"import code in protect-else:\n";
-- if void(s.else_part) then s.else_part := #AS_STMT_LIST end;
-- import ::= as_for_sys_import_export(import_code,s.else_part,s.source);
-- if void(s.else_part.stmts) then s.else_part.stmts := import
-- else import.next := s.else_part.stmts; s.else_part.stmts := import end;
-- -- AS_OUT::AS_STMT_out(s.else_part.stmts);
-- end;
-- -- Export statement
-- if ~s.transformed then
-- append_export_in_list(s.else_part,false); -- at least one export
-- end;
-- -- AS_OUT::AS_STMT_out(s.else_part.stmts);
-- -- #OUT+"return from transform_pSather_protect_else_stuff\n";
-- end;
transform_pSather_local_assign(loc:AM_LOCAL_EXPR,s:AS_ASSIGN_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
-- used to export local variable immediately after write.
-- #OUT+"transform_pSather_local_assign:\n";
-- AS_OUT::AS_ASSIGN_STMT_out(s);
if loc.name.str.size >= 10 and loc.name.str.head(10)="_pS_cohort" then-- AM_LOCAL_EXPR::name IDENT::str STR::size INT::is_lt BOOL::not AM_LOCAL_EXPR::name IDENT::str STR::head STR::is_eq
if void(cur_cohort) then-- TRANS::cur_cohort
cur_cohort := loc;-- TRANS::cur_cohort
end;
end;
if ~s.transformed then-- AS_ASSIGN_STMT::transformed BOOL::not
s.transformed := true;-- AS_ASSIGN_STMT::transformed
if ~do_direct_export then return end;-- TRANS::do_direct_export BOOL::not
-- 1) Find out the appropriate helper object for export
as : AS_ASSIGN_STMT := void;
last_helper ::= last_declared_helper;-- TRANS::last_declared_helper
if void(last_helper) then return end;
rel_helper : AM_LOCAL_EXPR;
if void(cur_param_ob) then-- TRANS::cur_param_ob
-- not inside of par or fork routine
rel_helper := last_helper;
else
-- inside of par or fork routine
rel_helper := last_declared_par_helper;-- TRANS::last_declared_par_helper
if void(rel_helper) then
-- can only happen in fork routine
rel_helper := last_helper;
end;
end;
-- if there is no known helper object this call is ignored
-- if void(last_helper) then return end;
-- 2) Copy into helper object if applicable
-- if void(cur_param_ob) or local_is_in_par_helpers(loc.name,rel_helper)
if local_is_in_par_helpers(loc.name,rel_helper) -- TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name
then
as := #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
as.source := s.source;-- AS_ASSIGN_STMT::source AS_ASSIGN_STMT::source
as.surr_stmt_list := s.surr_stmt_list;-- AS_ASSIGN_STMT::surr_stmt_list AS_ASSIGN_STMT::surr_stmt_list
locvar ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
locvar.source := s.source;-- AS_CALL_EXPR::source AS_ASSIGN_STMT::source
locvar.name := loc.name;-- AS_CALL_EXPR::name AM_LOCAL_EXPR::name
helploc ::= as_of_local_in_helpers(loc.name,rel_helper,s.source);-- TRANS::as_of_local_in_helpers AM_LOCAL_EXPR::name AS_ASSIGN_STMT::source
as.lhs_expr := helploc;-- AS_ASSIGN_STMT::lhs_expr
as.rhs := locvar;-- AS_ASSIGN_STMT::rhs
-- #OUT+"immediate export statement:\n";
-- AS_OUT::AS_ASSIGN_STMT_out(as);
as.next := s.next; s.next := as;-- AS_ASSIGN_STMT::next AS_ASSIGN_STMT::next AS_ASSIGN_STMT::next
-- #OUT+"in context:\n";
-- AS_OUT::AS_STMT_out(s);
return;
end;
end;
end;
private add_helper_to_tbls(helper:IDENT,orig_cl_params:ARRAY{$TP}):TP_CLASS
pre prog.psather-- TRANS::prog PROG::psather
is
-- Create Type for new class
tp :TP_CLASS := prog.tp_tbl.tp_class_for(helper,orig_cl_params);-- TRANS::prog PROG::tp_tbl TP_TBL::tp_class_for
if void(tp) then err("Compiler Err:PTRANS::add_helper_to_tbls") end;-- TRANS::err
if ~prog.tp_done.test(tp) then -- TRANS::prog PROG::tp_done FSET{1}::test BOOL::not
-- #OUT+"Add Helper to tp_done:"+tp.str+"\n";
prog.tp_done := prog.tp_done.insert(tp); -- TRANS::prog PROG::tp_done TRANS::prog PROG::tp_done FSET{1}::insert
end;
return tp;
end;
----
private update_routine_in_tbls(cur_class_tp:TP_CLASS,newrout:AS_ROUT_DEF)
pre prog.psather-- TRANS::prog PROG::psather
is
-- Update Routine Definition in Interfaces for current type
sig ::= SIG::rout_sig(newrout,newrout.name,tp_con.ptypes,tp_con);-- SIG::rout_sig AS_ROUT_DEF::name TRANS::tp_con TP_CONTEXT::ptypes TRANS::tp_con
if void(sig) then err("Compiler Err:PTRANS::update_rout_in_tbls - 1") end;-- TRANS::err
elt ::= #ELT(sig,sig,newrout,tp_con,newrout.is_private);-- ELT::create TRANS::tp_con AS_ROUT_DEF::is_private
if void(elt) then err("Compiler Err:PTRANS::update_rout_in_tbls - 2") end;-- TRANS::err
impl ::= cur_class_tp.impl;-- TP_CLASS::impl
if void(impl) then err("Compiler Err:PTRANS::update_rout_in_tbls - 3") end;-- TRANS::err
f:ELT:=impl.elts.elt_same_name_as(elt);-- IMPL::elts ELT_TBL::elt_same_name_as
if void(f) then impl.elts := impl.elts.insert(elt) end;-- IMPL::elts IMPL::elts ELT_TBL::insert
-- Debug
-- dummy ::= cur_class_tp.impl;
-- #OUT+"Impl of new routine:\n";
-- #OUT+"id = "+SYS::id(dummy)+"\n";
-- #OUT+"tp = "+dummy.tp.str+"\n";
-- #OUT+"ifc:\n";
-- dummy.ifc.show;
-- #OUT+"elts:\n";
-- elttbl ::= dummy.elts;
-- loop el ::= elttbl.elt!;
-- #OUT+" "+el.sig.str+"(Id = "+SYS::id(el.sig)+")\n";
-- end;
end;
----
private create_helper_object(s:$AS_STMT,newid_ob:IDENT,newid_cl:IDENT,
orig_class_as:AS_CLASS_DEF,orig_cl_params:ARRAY{$TP}):AM_LOCAL_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
-- #OUT+"enter create helper object\n";
-- Create AS for new class
as ::= #AS_CLASS_DEF;-- AS_CLASS_DEF::create
as.source := s.source;-- AS_CLASS_DEF::source
as.kind := AS_CLASS_DEF::ref;-- AS_CLASS_DEF::kind AS_CLASS_DEF::ref
as.name := newid_cl;-- AS_CLASS_DEF::name
class_param ::= orig_class_as.params;-- AS_CLASS_DEF::params
loop
if void(class_param) then break! end;
pardec ::= #AS_PARAM_DEC;-- AS_PARAM_DEC::create
pardec.source := s.source;-- AS_PARAM_DEC::source
pardec.name := class_param.name;-- AS_PARAM_DEC::name AS_PARAM_DEC::name
if void(as.params) then as.params := pardec -- AS_CLASS_DEF::params AS_CLASS_DEF::params
else as.params.append(pardec) end;-- AS_CLASS_DEF::params AS_PARAM_DEC::append
class_param := class_param.next;-- AS_PARAM_DEC::next
end;
prog.as_tbl := prog.as_tbl.insert(as);-- TRANS::prog PROG::as_tbl TRANS::prog PROG::as_tbl PROG_AS_TBL::insert
tp ::= add_helper_to_tbls(newid_cl,orig_cl_params);-- TRANS::add_helper_to_tbls
-- Create Attribute Declarations
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if loc.name.str.head(1) /= "_"-- AM_LOCAL_EXPR::name IDENT::str STR::head
and ( void(cur_param_ob)-- STR::is_eq BOOL::not TRANS::cur_param_ob
or ~local_is_in_par_helpers(loc.name,cur_param_ob))-- TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name TRANS::cur_param_ob BOOL::not
then
var ::= #AS_ATTR_DEF;-- AS_ATTR_DEF::create
var.source := s.source;-- AS_ATTR_DEF::source
var.name := loc.name;-- AS_ATTR_DEF::name AM_LOCAL_EXPR::name
-- #OUT+"Name = "+loc.name.str;
tps : AS_TYPE_SPEC;
if ~void(loc.as_type) then-- AM_LOCAL_EXPR::as_type BOOL::not
if loc.as_type.kind /= AS_TYPE_SPEC::same then-- AM_LOCAL_EXPR::as_type AS_TYPE_SPEC::kind INT::is_eq AS_TYPE_SPEC::same BOOL::not
tps := loc.as_type;-- AM_LOCAL_EXPR::as_type
-- #OUT+" (1) ";
else
-- SAME
tps := loc.tp.as;-- AM_LOCAL_EXPR::tp
-- #OUT+" (2) ";
end;
else
tps := loc.tp.as;-- AM_LOCAL_EXPR::tp
-- #OUT+" (3) ";
end;
-- AS_OUT::AS_TYPE_SPEC_out(tps);
var.tp := tps;-- AS_ATTR_DEF::tp
if void(as.body) then as.body:=var else as.body.append(var); end;-- AS_CLASS_DEF::body AS_CLASS_DEF::body AS_CLASS_DEF::body
end;
end;
if is_in_par_or_fork and newid_cl.str.head(7) = "_pS_att" then-- TRANS::is_in_par_or_fork IDENT::str STR::head STR::is_eq
-- put current cohort into helper object
if void(cur_cohort) then err("Compiler Err: PTRANS create helper") end;-- TRANS::cur_cohort TRANS::err
var ::= #AS_ATTR_DEF;-- AS_ATTR_DEF::create
var.source := s.source;-- AS_ATTR_DEF::source
var.name := cur_cohort.name;-- AS_ATTR_DEF::name TRANS::cur_cohort AM_LOCAL_EXPR::name
tps ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
tps.source := s.source;-- AS_TYPE_SPEC::source
tps.name := #IDENT("PAR_ATTACH");-- AS_TYPE_SPEC::name IDENT::create
var.tp := tps;-- AS_ATTR_DEF::tp
if void(as.body) then as.body:=var else as.body.append(var); end;-- AS_CLASS_DEF::body AS_CLASS_DEF::body AS_CLASS_DEF::body
end;
-- If there is a surrounding par object add this to next helper:
if ~void(cur_par_ob) then-- TRANS::cur_par_ob BOOL::not
-- this happens inside of a par routine, therefore the current par
-- becomes part of the new helper object
var ::= #AS_ATTR_DEF;-- AS_ATTR_DEF::create
var.source := s.source;-- AS_ATTR_DEF::source
var.name := cur_par_ob.name;-- AS_ATTR_DEF::name TRANS::cur_par_ob AM_LOCAL_EXPR::name
tps : AS_TYPE_SPEC;
if ~void(cur_par_ob.as_type) then tps := cur_par_ob.as_type-- TRANS::cur_par_ob AM_LOCAL_EXPR::as_type BOOL::not TRANS::cur_par_ob AM_LOCAL_EXPR::as_type
else tps := cur_par_ob.tp.as end;-- TRANS::cur_par_ob AM_LOCAL_EXPR::tp
var.tp := tps;-- AS_ATTR_DEF::tp
if void(as.body) then as.body:=var else as.body.append(var); end;-- AS_CLASS_DEF::body AS_CLASS_DEF::body AS_CLASS_DEF::body
elsif ~void(cur_param_ob) then-- TRANS::cur_param_ob BOOL::not
-- this happens inside of a fork. We have to find the helper object
-- of the surrounding par in the current helper object.
elts : ELT_TBL := cur_param_ob.tp.impl.elts;-- TRANS::cur_param_ob AM_LOCAL_EXPR::tp IMPL::elts
loop
elt ::= elts.elt!;-- ELT_TBL::elt!
if elt.name.str.head(1) = "_" then-- ELT::name IDENT::str STR::head STR::is_eq
if ~void(elt.ret) then -- skip writer routine-- ELT::ret BOOL::not
if elt.name.str.size >= 8 -- ELT::name IDENT::str STR::size INT::is_lt
and elt.name.str.head(8) = "_pS_par_"-- BOOL::not ELT::name IDENT::str STR::head
then-- STR::is_eq
var ::= #AS_ATTR_DEF;-- AS_ATTR_DEF::create
var.source := s.source;-- AS_ATTR_DEF::source
var.name := elt.name;-- AS_ATTR_DEF::name ELT::name
tps : AS_TYPE_SPEC;
if ~void(elt.as_tp) then tps := elt.as_tp-- ELT::as_tp BOOL::not ELT::as_tp
else tps := elt.ret.as end;-- ELT::ret
var.tp := tps;-- AS_ATTR_DEF::tp
if void(as.body) then as.body:=var -- AS_CLASS_DEF::body AS_CLASS_DEF::body
else as.body.append(var); end;-- AS_CLASS_DEF::body
break!;
end;
end;
end;
end;
end;
-- Create Create Routine
crt ::= #AS_ROUT_DEF;-- AS_ROUT_DEF::create
crt.source := s.source;-- AS_ROUT_DEF::source
crt.name := #IDENT("create");-- AS_ROUT_DEF::name IDENT::create
ret_dec ::= #AS_TYPE_SPEC; -- AS_TYPE_SPEC::create
ret_dec.source := s.source;-- AS_TYPE_SPEC::source
ret_dec.kind := AS_TYPE_SPEC::same;-- AS_TYPE_SPEC::kind AS_TYPE_SPEC::same
crt.ret_dec := ret_dec;-- AS_ROUT_DEF::ret_dec
crtbdy ::= #AS_RETURN_STMT;-- AS_RETURN_STMT::create
crtbdy.source := s.source;-- AS_RETURN_STMT::source
crtnew ::= #AS_NEW_EXPR;-- AS_NEW_EXPR::create
crtnew.source := s.source;-- AS_NEW_EXPR::source
crtbdy.val := crtnew;-- AS_RETURN_STMT::val
crt.body := #AS_STMT_LIST;-- AS_ROUT_DEF::body AS_STMT_LIST::create
crt.body.source := s.source;-- AS_ROUT_DEF::body AS_STMT_LIST::source
crtbdy.surr_stmt_list := crt.body;-- AS_RETURN_STMT::surr_stmt_list AS_ROUT_DEF::body
crtbdy.surr_stmt_list := crt.body;-- AS_RETURN_STMT::surr_stmt_list AS_ROUT_DEF::body
crt.body.stmts := crtbdy;-- AS_ROUT_DEF::body AS_STMT_LIST::stmts
if void(as.body) then as.body:=crt else as.body.append(crt); end;-- AS_CLASS_DEF::body AS_CLASS_DEF::body AS_CLASS_DEF::body
-- Create Impl Entry
impl :IMPL:= tp.impl;-- TP_CLASS::impl
-- Modify Type Graph
-- Put Helper Class unter $OB
dob:TP_CLASS:=TP_BUILTIN::dollar_ob;-- TP_BUILTIN::dollar_ob
prog.tp_graph_abs_des.add(dob,tp);-- TRANS::prog PROG::tp_graph_abs_des TP_GRAPH_ABS_DES::add
-- Ancestors and Descendants of Helper Class
ip1 ::= prog.tp_graph.get_anc(tp);-- TRANS::prog PROG::tp_graph TP_GRAPH::get_anc
ip2 ::= prog.tp_graph.get_des(tp);-- TRANS::prog PROG::tp_graph TP_GRAPH::get_des
-- #OUT+"after create of helper object:\n"; AS_OUT::AS_CLASS_DEF_out(as);
return #AM_LOCAL_EXPR(s.source,newid_ob,tp);-- AM_LOCAL_EXPR::create
end;
----
private create_helper_object_stmt(newid_ob:IDENT,newid_cl:IDENT,
orig_class_as:AS_CLASS_DEF,body:AS_STMT_LIST,source:SFILE_ID)
:AS_ASSIGN_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
-- returns AS_node for the following assignment statement:
-- helper_object ::= #helper_object_class {type_params if any}
as3 ::= #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
as3.source := source;-- AS_ASSIGN_STMT::source
as3.name := newid_ob;-- AS_ASSIGN_STMT::name
as3.surr_stmt_list := body;-- AS_ASSIGN_STMT::surr_stmt_list
tp3 ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
tp3.source := source;-- AS_TYPE_SPEC::source
tp3.name := newid_cl;-- AS_TYPE_SPEC::name
class_param ::= orig_class_as.params;-- AS_CLASS_DEF::params
loop
if void(class_param) then break! end;
pardec ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
pardec.source := source;-- AS_TYPE_SPEC::source
pardec.name := class_param.name;-- AS_TYPE_SPEC::name AS_PARAM_DEC::name
if void(tp3.params) then tp3.params := pardec -- AS_TYPE_SPEC::params AS_TYPE_SPEC::params
else tp3.params.append(pardec) end;-- AS_TYPE_SPEC::params AS_TYPE_SPEC::append
class_param := class_param.next;-- AS_PARAM_DEC::next
end;
rhs3 ::= #AS_CREATE_EXPR;-- AS_CREATE_EXPR::create
rhs3.source := source;-- AS_CREATE_EXPR::source
rhs3.tp := tp3;-- AS_CREATE_EXPR::tp
as3.rhs := rhs3;-- AS_ASSIGN_STMT::rhs
return as3;
end;
private turn_into_routine(routname:IDENT,helper_ob:IDENT,helper_cl:IDENT,
helper:AM_LOCAL_EXPR,orig_class_as:AS_CLASS_DEF,
current_class_tp:TP_CLASS,gate:IDENT,orig_gate_tp:AS_TYPE_SPEC,
body:AS_STMT_LIST,code:INT,source:SFILE_ID):AS_ROUT_DEF
pre prog.psather-- TRANS::prog PROG::psather
is
gate_tp::=orig_gate_tp;
-- if gate_tp is void, then we assume "PAR_ATTACH".
-- #OUT+"turn_into_routine entered\n";
-- a) Create Routine Definition
newrout ::= #AS_ROUT_DEF;-- AS_ROUT_DEF::create
newrout.source := source;-- AS_ROUT_DEF::source
newrout.name := routname;-- AS_ROUT_DEF::name
case code
when par_code then newrout.is_par_routine := true;-- TRANS::par_code AS_ROUT_DEF::is_par_routine
when frk_code then newrout.is_fork_routine := true;-- TRANS::frk_code AS_ROUT_DEF::is_fork_routine
when att_code then newrout.is_attach_routine := true;-- TRANS::att_code AS_ROUT_DEF::is_attach_routine
end;
argdec0 ::= #AS_ARG_DEC;-- AS_ARG_DEC::create
argdec0.source := source;-- AS_ARG_DEC::source
argdec0.name := helper_ob;-- AS_ARG_DEC::name
argdec0.mode :=#(AS_ARG_MODE::in_mode);-- AS_ARG_DEC::mode AS_ARG_MODE::create AS_ARG_MODE::in_mode
argdec0tp ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
argdec0tp.source := source;-- AS_TYPE_SPEC::source
argdec0tp.name := helper_cl;-- AS_TYPE_SPEC::name
class_param ::= orig_class_as.params;-- AS_CLASS_DEF::params
loop
if void(class_param) then break! end;
pardec ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
pardec.source := source;-- AS_TYPE_SPEC::source
pardec.name := class_param.name;-- AS_TYPE_SPEC::name AS_PARAM_DEC::name
if void(argdec0tp.params) then argdec0tp.params := pardec -- AS_TYPE_SPEC::params AS_TYPE_SPEC::params
else argdec0tp.params.append(pardec) end;-- AS_TYPE_SPEC::params AS_TYPE_SPEC::append
class_param := class_param.next;-- AS_PARAM_DEC::next
end;
argdec0.tp := argdec0tp;-- AS_ARG_DEC::tp
argdec1 ::= #AS_ARG_DEC;-- AS_ARG_DEC::create
argdec1.source := source;-- AS_ARG_DEC::source
argdec1.name := gate;-- AS_ARG_DEC::name
argdec1.mode :=#(AS_ARG_MODE::in_mode);-- AS_ARG_DEC::mode AS_ARG_MODE::create AS_ARG_MODE::in_mode
if void(gate_tp) then
gate_tp := #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
gate_tp.source := source;-- AS_TYPE_SPEC::source
gate_tp.name := #IDENT("PAR_ATTACH");-- AS_TYPE_SPEC::name IDENT::create
end;
argdec1.tp := gate_tp;-- AS_ARG_DEC::tp
argdec2 ::= #AS_ARG_DEC;-- AS_ARG_DEC::create
argdec2.mode :=#(AS_ARG_MODE::in_mode);-- AS_ARG_DEC::mode AS_ARG_MODE::create AS_ARG_MODE::in_mode
argdec2.source := source;-- AS_ARG_DEC::source
argdec2.name := #IDENT("_pS_at");-- AS_ARG_DEC::name IDENT::create
argdec2tp ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
argdec2tp.source := source;-- AS_TYPE_SPEC::source
argdec2tp.name := #IDENT("INT");;-- AS_TYPE_SPEC::name IDENT::create
argdec2.tp := argdec2tp;-- AS_ARG_DEC::tp
argdec0.append(argdec1);-- AS_ARG_DEC::append
argdec0.append(argdec2);-- AS_ARG_DEC::append
newrout.args_dec := argdec0;-- AS_ROUT_DEF::args_dec
newrout.is_private := true;-- AS_ROUT_DEF::is_private
newrout.body := #AS_STMT_LIST;-- AS_ROUT_DEF::body AS_STMT_LIST::create
newrout.body.source := source;-- AS_ROUT_DEF::body AS_STMT_LIST::source
-- b) Include Routine Definition in Interfaces
orig_class_as.body.append(newrout);-- AS_CLASS_DEF::body
update_routine_in_tbls(current_class_tp,newrout);-- TRANS::update_routine_in_tbls
-- c) Add Initial Var Declaration and Helper Unpack Statements
decl_stmts : $AS_STMT;
asdec : AS_DEC_STMT;
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if loc.name.str.head(1) /= "_" -- AM_LOCAL_EXPR::name IDENT::str STR::head
or ( newrout.is_attach_routine -- STR::is_eq BOOL::not AS_ROUT_DEF::is_attach_routine
and ~void(cur_cohort)-- TRANS::cur_cohort
and loc.name = cur_cohort.name)-- BOOL::not AM_LOCAL_EXPR::name TRANS::cur_cohort AM_LOCAL_EXPR::name
then
-- loc : TYPE;
asdec := #AS_DEC_STMT;-- AS_DEC_STMT::create
asdec.source := source;-- AS_DEC_STMT::source
asdec.name := loc.name;-- AS_DEC_STMT::name AM_LOCAL_EXPR::name
asdec.surr_stmt_list := newrout.body;-- AS_DEC_STMT::surr_stmt_list AS_ROUT_DEF::body
if ~void(loc.as_type) then asdec.tp := loc.as_type-- AM_LOCAL_EXPR::as_type BOOL::not AS_DEC_STMT::tp AM_LOCAL_EXPR::as_type
else asdec.tp := loc.tp.as end;-- AS_DEC_STMT::tp AM_LOCAL_EXPR::tp
if void(decl_stmts) then decl_stmts := asdec
else decl_stmts.append(asdec) end;
end;
end;
--# -- attach.birth
--# call ::= #AS_EXPR_STMT;
--# call.source := source;
--# call.surr_stmt_list := body;
--# callexpr ::= #AS_CALL_EXPR;
--# callexpr.source := source;
--# callexpr.name := #IDENT("birth");
--# callexprob ::= #AS_CALL_EXPR;
--# callexprob.source := source;
--# callexprob.name := gate;
--# callexpr.ob := callexprob;
--# call.e := callexpr;
--# copy_in_stmts::=call;
copy_in_stmts::=as_for_sys_import_export(import_code,newrout.body,source);-- TRANS::import_code AS_ROUT_DEF::body
-- The regular import code only affects local variables which are
-- declared in the surrounding par. However, initially all variables
-- must be included.
asin : AS_ASSIGN_STMT;
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if (loc.name.str.head(1) /= "_" -- AM_LOCAL_EXPR::name IDENT::str STR::head
or ( newrout.is_attach_routine-- STR::is_eq BOOL::not AS_ROUT_DEF::is_attach_routine
and ~void(cur_cohort)-- TRANS::cur_cohort
and loc.name = cur_cohort.name))-- BOOL::not AM_LOCAL_EXPR::name TRANS::cur_cohort AM_LOCAL_EXPR::name
and ~local_is_in_par_helpers(loc.name,helper) -- TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name
then-- BOOL::not
-- loc := _pS_params_ob.loc;
asin := #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
asin.source := source;-- AS_ASSIGN_STMT::source
asin.transformed := true;-- AS_ASSIGN_STMT::transformed
asinlhs ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
asinlhs.source := source;-- AS_CALL_EXPR::source
asinlhs.name := loc.name;-- AS_CALL_EXPR::name AM_LOCAL_EXPR::name
asin.lhs_expr := asinlhs;-- AS_ASSIGN_STMT::lhs_expr
asin.rhs := as_of_local_in_helpers(loc.name,helper,source);-- AS_ASSIGN_STMT::rhs TRANS::as_of_local_in_helpers AM_LOCAL_EXPR::name
asin.surr_stmt_list := newrout.body;-- AS_ASSIGN_STMT::surr_stmt_list AS_ROUT_DEF::body
copy_in_stmts.append(asin);
end;
end;
-- d) Add trailing Export statements
-- the call to ATTACH::death is the only one inserted by the compiler.
-- We have to do it here as we may have to pass a value.
copy_out_stmts: $AS_STMT;
if void(orig_gate_tp) then
call ::= #AS_EXPR_STMT;-- AS_EXPR_STMT::create
call.source := source;-- AS_EXPR_STMT::source
call.surr_stmt_list := body;-- AS_EXPR_STMT::surr_stmt_list
callexpr ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexpr.source := source;-- AS_CALL_EXPR::source
callexpr.name := #IDENT("death");-- AS_CALL_EXPR::name IDENT::create
callexprob ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexprob.source := source;-- AS_CALL_EXPR::source
callexprob.name := gate;-- AS_CALL_EXPR::name
callexpr.ob := callexprob;-- AS_CALL_EXPR::ob
callexpr.args := void; -- without at expressions;-- AS_CALL_EXPR::args
callexpr.modes:=#(AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes AS_ARG_MODE::create AS_ARG_MODE::in_mode
call.e := callexpr;-- AS_EXPR_STMT::e
call.transformed := true; -- will prevent surrounding import/export-- AS_EXPR_STMT::transformed
copy_out_stmts:=call;
else
copy_out_stmts:=void;
end;
if void(copy_out_stmts) then
copy_out_stmts:=as_for_sys_import_export(export_code,newrout.body,source);-- TRANS::export_code AS_ROUT_DEF::body
else
copy_out_stmts.append(as_for_sys_import_export(export_code,newrout.body,source));-- TRANS::export_code AS_ROUT_DEF::body
end;
-- e) Add enclosing protect
-- prtct ::= #AS_PROTECT_STMT;
-- prtct.source := source;
-- prtct.surr_stmt_list := newrout.body;
-- prtct.body := body;
if ~void(body.stmts) then -- AS_STMT_LIST::stmts BOOL::not
if ~void(copy_in_stmts) then -- BOOL::not
copy_in_stmts.append(body.stmts);-- AS_STMT_LIST::stmts
body.stmts := copy_in_stmts;-- AS_STMT_LIST::stmts
end;
-- prtct.body.stmts.append(copy_out_stmts)
body.stmts.append(copy_out_stmts) -- AS_STMT_LIST::stmts
end;
newrout.body.stmts := decl_stmts;-- AS_ROUT_DEF::body AS_STMT_LIST::stmts
-- if void(decl_stmts) then newrout.body.stmts := prtct;
-- else newrout.body.stmts.append(prtct); end;
if void(decl_stmts) then newrout.body.stmts := body.stmts;-- AS_ROUT_DEF::body AS_STMT_LIST::stmts AS_STMT_LIST::stmts
else newrout.body.stmts.append(body.stmts); end;-- AS_ROUT_DEF::body AS_STMT_LIST::stmts AS_STMT_LIST::stmts
return newrout;
end;
link_helper_stmt(newid_ob:IDENT,body:AS_STMT_LIST,
source:SFILE_ID):AS_ASSIGN_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
exp : AS_ASSIGN_STMT;
if ~void(cur_par_ob) then-- TRANS::cur_par_ob BOOL::not
exp := #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
exp.source := source;-- AS_ASSIGN_STMT::source
exp.surr_stmt_list := body;-- AS_ASSIGN_STMT::surr_stmt_list
lhs ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
lhs.source := source;-- AS_CALL_EXPR::source
lhsob ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
lhsob.source := source;-- AS_CALL_EXPR::source
lhsob.name := newid_ob;-- AS_CALL_EXPR::name
lhs.ob := lhsob;-- AS_CALL_EXPR::ob
lhs.name := cur_par_ob.name;-- AS_CALL_EXPR::name TRANS::cur_par_ob AM_LOCAL_EXPR::name
exp.lhs_expr := lhs;-- AS_ASSIGN_STMT::lhs_expr
rhs ::= #AS_CALL_EXPR; -- AS_CALL_EXPR::create
rhs.source := source;-- AS_CALL_EXPR::source
rhs.name := cur_par_ob.name;-- AS_CALL_EXPR::name TRANS::cur_par_ob AM_LOCAL_EXPR::name
exp.rhs := rhs;-- AS_ASSIGN_STMT::rhs
elsif ~void(cur_param_ob) then -- in fork routine-- TRANS::cur_param_ob BOOL::not
exp := #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
exp.source := source;-- AS_ASSIGN_STMT::source
exp.surr_stmt_list := body;-- AS_ASSIGN_STMT::surr_stmt_list
elts : ELT_TBL := cur_param_ob.tp.impl.elts;-- TRANS::cur_param_ob AM_LOCAL_EXPR::tp IMPL::elts
par_ob : IDENT;
loop
elt ::= elts.elt!;-- ELT_TBL::elt!
if elt.name.str.head(1) = "_" then-- ELT::name IDENT::str STR::head STR::is_eq
if ~void(elt.ret) then -- skip writer routine-- ELT::ret BOOL::not
if elt.name.str.size >= 8 -- ELT::name IDENT::str STR::size INT::is_lt
and elt.name.str.head(8) = "_pS_par_"-- BOOL::not ELT::name IDENT::str STR::head
then-- STR::is_eq
par_ob := elt.name;-- ELT::name
break!;
end;
end;
end;
end;
if void(par_ob) then err("Compiler Error: PTRANS:link_helper") end;-- TRANS::err
rhs ::= as_of_local_in_helpers(par_ob,cur_param_ob,source);-- TRANS::as_of_local_in_helpers TRANS::cur_param_ob
lhs ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
lhs.source := source;-- AS_CALL_EXPR::source
lhsob ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
lhsob.source := source;-- AS_CALL_EXPR::source
lhsob.name := newid_ob;-- AS_CALL_EXPR::name
lhs.ob := lhsob;-- AS_CALL_EXPR::ob
lhs.name := par_ob;-- AS_CALL_EXPR::name
exp.lhs_expr := lhs;-- AS_ASSIGN_STMT::lhs_expr
exp.rhs := rhs;-- AS_ASSIGN_STMT::rhs
end;
return exp;
end;
transform_par_stmt(s:AS_PAR_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
ret_as : $AS_STMT;
-- 0) Preparation
-- #OUT+"Context:\n";
-- #OUT+"same = "+tp_con.same.str+"\n";
-- #OUT+"pnames = <";
-- loop pn ::= tp_con.pnames.elt!; #OUT+pn.str+" " end;
-- #OUT+">\n";
-- #OUT+"ptypes = <";
-- loop pt ::= tp_con.ptypes.elt!; #OUT+pt.str+" " end;
-- #OUT+">\n";
-- srcsig::=cur_rout.srcsig;
-- #OUT+"Elt-srcsig-TP= "+srcsig.tp.str+"\n";
orig_cl_tp : $TP := cur_rout.srcsig.tp;-- TRANS::cur_rout AM_ROUT_DEF::srcsig SIG::tp
orig_class_tp : TP_CLASS;
orig_class_as : AS_CLASS_DEF;
orig_cl_params : ARRAY{$TP};
typecase orig_cl_tp
when TP_CLASS then
orig_class_tp := orig_cl_tp;
orig_cl_params := orig_class_tp.params;-- TP_CLASS::params
num : INT := 0;
if ~void(orig_cl_params) then-- BOOL::not
num := orig_cl_params.size;-- ARRAY{1}::size
end;
orig_class_as:= prog.parse.tree_for(orig_class_tp.name,num);-- TRANS::prog PROG::parse TP_CLASS::name
else err("Compiler Error: PTRANS: transform_par: 0");-- TRANS::err
end;
-- #OUT+"orig_cl_tp = "+orig_cl_tp.str +"\n";
-- #OUT+"orig_class_tp = "+orig_class_tp.str+"\n";
-- #OUT+"orig_class_as = "+orig_class_as.name.str+"\n";
-- #OUT+"orig_cl_params = <";
-- loop pr ::= orig_cl_params.elt!; #OUT+pr.str+" " end;
-- #OUT+">\n";
current_tp : $TP := cur_rout[0].tp;-- TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::tp
current_class_tp : TP_CLASS;
typecase current_tp
when TP_CLASS then
current_class_tp := current_tp;
else err("Compiler Error: PTRANS: transform_par: 0");-- TRANS::err
end;
-- #OUT + "current_class_tp = " + current_class_tp.str + "\n";
if s.transformed then-- AS_PAR_STMT::transformed
-- #OUT + "Adding to tables\n";
dummy ::= add_helper_to_tbls(s.helper_class,orig_cl_params);-- TRANS::add_helper_to_tbls AS_PAR_STMT::helper_class
update_routine_in_tbls(current_class_tp,s.rout);-- TRANS::update_routine_in_tbls AS_PAR_STMT::rout
return void;
end;
-- 1) Create new identifiers
newidpar ::= #IDENT(IDENT::next_tmp("par"));-- IDENT::create IDENT::next_tmp
newidpar_cl ::= #IDENT(IDENT::next_tmp("par_cl"));-- IDENT::create IDENT::next_tmp
newidpar_ob ::= #IDENT(IDENT::next_tmp("par_ob"));-- IDENT::create IDENT::next_tmp
newidcohort ::= #IDENT(IDENT::next_tmp("cohort"));-- IDENT::create IDENT::next_tmp
s.helper_class := newidpar_cl;-- AS_PAR_STMT::helper_class
-- 2) Create class definition (Helper Object)
helper ::= create_helper_object(s,newidpar_ob,newidpar_cl,-- TRANS::create_helper_object
orig_class_as,orig_cl_params);
-- 3) insert
-- _pS_cohort ::= #ATTACH;
-- _pS_par_ob ::= #_pS_par_cl; in stmts for future processing
asc ::= #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
asc.source := s.source;-- AS_ASSIGN_STMT::source AS_PAR_STMT::source
asc.name := newidcohort;-- AS_ASSIGN_STMT::name
asc.surr_stmt_list := s.surr_stmt_list;-- AS_ASSIGN_STMT::surr_stmt_list AS_PAR_STMT::surr_stmt_list
tpc ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
tpc.source := s.source;-- AS_TYPE_SPEC::source AS_PAR_STMT::source
tpc.name := #IDENT("PAR_ATTACH");-- AS_TYPE_SPEC::name IDENT::create
rhsc ::= #AS_CREATE_EXPR;-- AS_CREATE_EXPR::create
rhsc.source := s.source;-- AS_CREATE_EXPR::source AS_PAR_STMT::source
rhsc.tp := tpc;-- AS_CREATE_EXPR::tp
asc.rhs := rhsc;-- AS_ASSIGN_STMT::rhs
ret_as := asc;
ret_as.append(create_helper_object_stmt(newidpar_ob,newidpar_cl,-- TRANS::create_helper_object_stmt
orig_class_as,s.surr_stmt_list,s.source));-- AS_PAR_STMT::surr_stmt_list AS_PAR_STMT::source
-- 4) Statements to Fill Helper Object
-- 4a) helper.cur_param_ob := cur_param_ob, optional
-- 4b) helper.local := locsl, for those which are not inherited from par
-- 4c) export;
ret_as.append(link_helper_stmt(newidpar_ob,s.surr_stmt_list,s.source));-- TRANS::link_helper_stmt AS_PAR_STMT::surr_stmt_list AS_PAR_STMT::source
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if loc.name.str.head(1) /= "_" -- AM_LOCAL_EXPR::name IDENT::str STR::head
and ( void(cur_param_ob) -- STR::is_eq BOOL::not TRANS::cur_param_ob
or ~local_is_in_par_helpers(loc.name,cur_param_ob))-- TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name TRANS::cur_param_ob BOOL::not
then
exp ::= #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
exp.source := s.source;-- AS_ASSIGN_STMT::source AS_PAR_STMT::source
exp.surr_stmt_list := s.surr_stmt_list;-- AS_ASSIGN_STMT::surr_stmt_list AS_PAR_STMT::surr_stmt_list
exp.lhs_expr:=as_of_local_in_helpers(loc.name,helper,s.source);-- AS_ASSIGN_STMT::lhs_expr TRANS::as_of_local_in_helpers AM_LOCAL_EXPR::name AS_PAR_STMT::source
rhs ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
rhs.source := s.source;-- AS_CALL_EXPR::source AS_PAR_STMT::source
rhs.name := loc.name;-- AS_CALL_EXPR::name AM_LOCAL_EXPR::name
exp.rhs := rhs;-- AS_ASSIGN_STMT::rhs
ret_as.append(exp);
end;
end;
ret_as.append(as_for_sys_import_export(export_code,s.surr_stmt_list,s.source));-- TRANS::export_code AS_PAR_STMT::surr_stmt_list AS_PAR_STMT::source
-- 5) Turn Par Body Into Routine
s.rout := turn_into_routine(newidpar,newidpar_ob,newidpar_cl,helper,-- AS_PAR_STMT::rout TRANS::turn_into_routine
orig_class_as,current_class_tp,newidcohort,void,s.body,par_code,-- AS_PAR_STMT::body TRANS::par_code
s.source);-- AS_PAR_STMT::source
s.body := void;-- AS_PAR_STMT::body
-- 6) _pS_par(_pS_par_ob,_pS_cohort);
att8 ::= #AS_INTERF_ATTACH_STMT;-- AS_INTERF_ATTACH_STMT::create
att8.source := s.source;-- AS_INTERF_ATTACH_STMT::source AS_PAR_STMT::source
att8.surr_stmt_list := s.surr_stmt_list;-- AS_INTERF_ATTACH_STMT::surr_stmt_list AS_PAR_STMT::surr_stmt_list
att8.routname := newidpar;-- AS_INTERF_ATTACH_STMT::routname
att8.helpername := newidpar_ob;-- AS_INTERF_ATTACH_STMT::helpername
att8.gatename := newidcohort;-- AS_INTERF_ATTACH_STMT::gatename
att8.at := void;-- AS_INTERF_ATTACH_STMT::at
ret_as.append(att8);
-- 7) Append: lock cohort.no_threads then end;
-- Then SYS::import;
aslck ::= #AS_LOCK_STMT;-- AS_LOCK_STMT::create
aslck.source := s.source;-- AS_LOCK_STMT::source AS_PAR_STMT::source
aslck.surr_stmt_list := s.surr_stmt_list;-- AS_LOCK_STMT::surr_stmt_list AS_PAR_STMT::surr_stmt_list
nthr ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
nthr.source := s.source;-- AS_CALL_EXPR::source AS_PAR_STMT::source
nthrob ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
nthrob.source := s.source;-- AS_CALL_EXPR::source AS_PAR_STMT::source
nthrob.name := newidcohort;-- AS_CALL_EXPR::name
nthr.ob := nthrob;-- AS_CALL_EXPR::ob
nthr.name := #IDENT("no_threads");-- AS_CALL_EXPR::name IDENT::create
tru ::= #AS_BOOL_LIT_EXPR; -- AS_BOOL_LIT_EXPR::create
tru.val := true;-- AS_BOOL_LIT_EXPR::val
aslck.if_when_part := #AS_LOCK_IF_WHEN;-- AS_LOCK_STMT::if_when_part AS_LOCK_IF_WHEN::create
aslck.if_when_part.val := tru;-- AS_LOCK_STMT::if_when_part AS_LOCK_IF_WHEN::val
aslck.if_when_part.e_list := nthr;-- AS_LOCK_STMT::if_when_part AS_LOCK_IF_WHEN::e_list
aslck.else_part := void;-- AS_LOCK_STMT::else_part
aslck.no_else := true;-- AS_LOCK_STMT::no_else
aslck.transformed := true;-- AS_LOCK_STMT::transformed
ret_as.append(aslck);
ret_as.append(as_for_sys_import_export(import_code,s.surr_stmt_list,s.source));-- TRANS::import_code AS_PAR_STMT::surr_stmt_list AS_PAR_STMT::source
-- 8) Push replacement statements into statement list
ret_as.append(s.next);-- AS_PAR_STMT::next
s.next := ret_as;-- AS_PAR_STMT::next
-- #OUT+"statements replacing par: (and more)\n";
-- AS_OUT::AS_STMT_out(s.next);
return void;
end;
as_for_p_sys(n:IDENT,body:AS_STMT_LIST, source:SFILE_ID):$AS_STMT
pre prog.psather
is
impexp ::= #AS_EXPR_STMT;
impexp.source := source;
impexp.surr_stmt_list := body;
impexpe ::= #AS_CALL_EXPR;
impexpe.source := source;
impexpetp ::= #AS_TYPE_SPEC;
impexpetp.source := source;
impexpetp.name := #IDENT("P_SYS");
impexpe.tp := impexpetp;
impexpe.name := #IDENT("import");
impexp.e := impexpe;
return impexp;
end;
as_for_sys_import_export(imporexp:INT,body:AS_STMT_LIST,
source:SFILE_ID):$AS_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
impexp ::= #AS_EXPR_STMT;-- AS_EXPR_STMT::create
impexp.source := source;-- AS_EXPR_STMT::source
impexp.surr_stmt_list := body;-- AS_EXPR_STMT::surr_stmt_list
impexpe ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
impexpe.source := source;-- AS_CALL_EXPR::source
impexpetp ::= #AS_TYPE_SPEC;-- AS_TYPE_SPEC::create
impexpetp.source := source;-- AS_TYPE_SPEC::source
impexpetp.name := #IDENT("SYS");-- AS_TYPE_SPEC::name IDENT::create
impexpe.tp := impexpetp;-- AS_CALL_EXPR::tp
case imporexp
when import_code then impexpe.name := #IDENT("import");-- TRANS::import_code AS_CALL_EXPR::name IDENT::create
when export_code then impexpe.name := #IDENT("export");-- TRANS::export_code AS_CALL_EXPR::name IDENT::create
end;
impexp.e := impexpe;-- AS_EXPR_STMT::e
return impexp;
end;
as_for_import_export(imporexp:INT,body:AS_STMT_LIST,
source:SFILE_ID):$AS_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
as : AS_ASSIGN_STMT;
code : $AS_STMT := void;
last_helper ::= last_declared_helper;-- TRANS::last_declared_helper
-- if there is no known helper object this call is ignored
if void(last_helper) then return code end;
rel_helper : AM_LOCAL_EXPR;
if void(cur_param_ob) then -- TRANS::cur_param_ob
-- not inside of par or fork routine
rel_helper := last_helper;
else
-- inside of par or fork routine
rel_helper := last_declared_par_helper;-- TRANS::last_declared_par_helper
if void(rel_helper) then
-- can only happen in fork routine
rel_helper := last_helper;
end;
end;
-- if there is no known helper object this call is ignored
if void(rel_helper) then return code end;
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if loc.name.str.head(1) /= "_" and-- AM_LOCAL_EXPR::name IDENT::str STR::head STR::is_eq BOOL::not
-- ( void(cur_param_ob)
-- or local_is_in_par_helpers(loc.name,rel_helper))
local_is_in_par_helpers(loc.name,rel_helper)-- TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name
then
-- export: <helpers>.loc := loc;
-- import: loc := <helpers>.loc;
as := #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
as.source := source;-- AS_ASSIGN_STMT::source
as.surr_stmt_list := body;-- AS_ASSIGN_STMT::surr_stmt_list
as.transformed := true;-- AS_ASSIGN_STMT::transformed
locvar ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
locvar.source := source;-- AS_CALL_EXPR::source
locvar.name := loc.name;-- AS_CALL_EXPR::name AM_LOCAL_EXPR::name
helploc ::= as_of_local_in_helpers(loc.name,rel_helper,source);-- TRANS::as_of_local_in_helpers AM_LOCAL_EXPR::name
case imporexp
when import_code then-- TRANS::import_code
as.lhs_expr := locvar;-- AS_ASSIGN_STMT::lhs_expr
as.rhs := helploc;-- AS_ASSIGN_STMT::rhs
when export_code then-- TRANS::export_code
as.lhs_expr := helploc;-- AS_ASSIGN_STMT::lhs_expr
as.rhs := locvar;-- AS_ASSIGN_STMT::rhs
end;
if void(code) then code := as else code.append(as); end;
end;
end;
return code;
end;
is_sys_import(s:SIG):BOOL is
tp::=s.tp;-- SIG::tp
typecase tp
when TP_CLASS then
return tp.name = #IDENT("SYS") and s.name = #IDENT("import");-- TP_CLASS::name IDENT::is_eq IDENT::create SIG::name IDENT::is_eq IDENT::create
else
return false;
end;
end;
is_sys_export(s:SIG):BOOL is
tp::=s.tp;-- SIG::tp
typecase tp
when TP_CLASS then
return tp.name = #IDENT("SYS") and s.name = #IDENT("export");-- TP_CLASS::name IDENT::is_eq IDENT::create SIG::name IDENT::is_eq IDENT::create
else
return false;
end;
end;
has_import(s:SIG):BOOL is
return s.is_builtin and s.builtin_info.does_import;-- SIG::is_builtin SIG::builtin_info CONFIG_ROUT::does_import
end;
has_export(s:SIG):BOOL is
return s.is_builtin and s.builtin_info.does_export;-- SIG::is_builtin SIG::builtin_info CONFIG_ROUT::does_export
end;
sys_closure_self(sig:SIG)
pre prog.psather-- TRANS::prog PROG::psather
is
-- transitive closure for SYS::import/export
-- #OUT+"["+sig.name.str;
if ~void(cur_rout) and ~void(sig) and ~void(sig.tp) then-- TRANS::cur_rout BOOL::not BOOL::not SIG::tp BOOL::not
if has_import(sig) then -- TRANS::has_import
cur_rout.needs_import_locals;-- TRANS::cur_rout AM_ROUT_DEF::needs_import_locals
-- #OUT+" needs import locals";
if ~is_sys_import(sig) then-- TRANS::is_sys_import BOOL::not
cur_rout.needs_import_call;-- TRANS::cur_rout AM_ROUT_DEF::needs_import_call
-- #OUT+" and call";
end;
end;
if has_export(sig) then -- TRANS::has_export
cur_rout.needs_export_locals;-- TRANS::cur_rout AM_ROUT_DEF::needs_export_locals
-- #OUT+" needs export locals";
if ~is_sys_export(sig) then-- TRANS::is_sys_export BOOL::not
cur_rout.needs_export_call; -- TRANS::cur_rout AM_ROUT_DEF::needs_export_call
-- #OUT+" and call";
end;
end;
end;
-- #OUT+"]\n";
end;
sys_closure_nest(ncs:$AM_EXPR)
pre prog.psather-- TRANS::prog PROG::psather
is
-- transitive closure for SYS::import/export
-- #OUT+"{";
if ~void(cur_rout) and ~void(ncs) then-- TRANS::cur_rout BOOL::not BOOL::not
typecase ncs
when AM_ROUT_CALL_EXPR then
if ncs.needs_import then -- AM_ROUT_CALL_EXPR::needs_import
-- #OUT+ncs.fun.name.str+" needs import";
cur_rout.needs_import_locals; -- TRANS::cur_rout AM_ROUT_DEF::needs_import_locals
end;
if ncs.needs_export then -- AM_ROUT_CALL_EXPR::needs_export
-- #OUT+ncs.fun.name.str+" needs export";
cur_rout.needs_export_locals; -- TRANS::cur_rout AM_ROUT_DEF::needs_export_locals
end;
else
end;
end;
-- #OUT+"}\n";
end;
-- Only for debugging purposes:
show_elements_of_tp(tp:$TP)
pre prog.psather
is
#OUT+"Elements of Type:\n";
elts : ELT_TBL := tp.impl.elts;
loop
elt ::= elts.elt!;
#OUT+elt.name.str+":";
if void(elt.ret) then
#OUT+"\n";
else
#OUT+elt.ret.str+"\n";
end;
end;
end; -- of show_elements_of_tp
name_of_local_in_helpers(local:IDENT,helper:AM_LOCAL_EXPR):FLIST{IDENT}
pre prog.psather-- TRANS::prog PROG::psather
is
-- #OUT+"Name_of_Local_in_Helper ("+local.str+") ";
-- #OUT+"in helper ("+helper.name.str+"/"+helper.tp.str+") ";
names ::= #FLIST{IDENT};-- FLIST{1}::create
tp ::= helper.tp;-- AM_LOCAL_EXPR::tp
names := names.push(helper.name);-- FLIST{1}::push AM_LOCAL_EXPR::name
if helper.name = local then-- AM_LOCAL_EXPR::name IDENT::is_eq
return names;
end;
loop
elts : ELT_TBL := tp.impl.elts;-- IMPL::elts
found ::= false;
loop
elt ::= elts.get_query!(local);-- ELT_TBL::get_query!
-- if we reach this point then there is an element called name in
-- this class
found := true;
names := names.push(local);-- FLIST{1}::push
break!;
end;
if found then break! end;
found := false;
loop
elt ::= elts.elt!;-- ELT_TBL::elt!
-- #OUT+"("+elt.name.str+"?)";
if elt.name.str.size>=7 and elt.name.str.head(7) = "_pS_par" then-- ELT::name IDENT::str STR::size INT::is_lt BOOL::not ELT::name IDENT::str STR::head STR::is_eq
if ~void(elt.ret) then -- skip writer routine-- ELT::ret BOOL::not
-- #OUT+"in helper ("+elt.name.str+"/"+elt.ret.str+") ";
found := true;
tp := elt.ret;-- ELT::ret
names := names.push(elt.name);-- FLIST{1}::push ELT::name
break!;
end;
end;
end;
if ~found then-- BOOL::not
-- if we reach thins point then there is something wrong.
-- #OUT+" - not found\n";
return void;
end;
end;
-- Debug Output
-- #OUT+"= ";
-- loop locname ::= names.elt!;
-- #OUT+locname.str+".";
-- end;
-- #OUT+"\n";
return names;
end; -- of name_of_local_in_helpers
local_is_in_par_helpers(local:IDENT,helper:AM_LOCAL_EXPR):BOOL
pre prog.psather-- TRANS::prog PROG::psather
is
-- similar to 'local_is_in_helpers'. However, we return true only
-- if in 'names' the innermost helper object has a par statement
-- as its origin. (Reason: locals that are passed in helpers and
-- are declared in surrounding fork statements are not to be
-- imported or exported.)
-- #OUT+"Local_Is_In_Par_Helper\n";
names : FLIST{IDENT} := name_of_local_in_helpers(local,helper);-- TRANS::name_of_local_in_helpers
if void(names) or names.size < 2 then return false end;-- FLIST{1}::size INT::is_lt
return ( names[names.size-2].str.size >= 10 -- FLIST{1}::aget FLIST{1}::size INT::minus IDENT::str STR::size INT::is_lt
and names[names.size-2].str.head(10) = "_pS_par_ob");-- BOOL::not FLIST{1}::aget FLIST{1}::size INT::minus IDENT::str STR::head STR::is_eq
end; -- of local_is_in_par_helpers
local_is_in_helpers(local:IDENT,helper:AM_LOCAL_EXPR):BOOL
pre prog.psather
is
-- returns true if local is declared in the helper object or
-- in one of the helper objects that can be reached transitively
-- from it.
-- #OUT+"Local_Is_In_Helper ("+local.str+") ";
-- #OUT+"in helper ("+helper.name.str+"/"+helper.tp.str+") ";
tp ::= helper.tp;
if helper.name = local then
-- a helper object is not defined in it self. Therefore:
return false;
end;
loop
elts : ELT_TBL := tp.impl.elts;
found ::= false;
loop
elt ::= elts.get_query!(local);
-- if we reach this point then there is an element called name in
-- this class
found := true;
break!;
end;
if found then break!; end;
found := false;
loop
elt ::= elts.elt!;
if elt.name.str.head(1) = "_" then
if ~void(elt.ret) then -- skip writer routine
-- #OUT+"in helper ("+elt.name.str+"/"+elt.ret.str+") ";
found := true;
tp := elt.ret;
break!;
end;
end;
end;
if ~found then
-- if we reach thins point then there is something wrong.
return false;
end;
end;
return true;
end; -- of loacl_is_in_helpers
as_of_local_in_helpers(local:IDENT,helper:AM_LOCAL_EXPR,
source:SFILE_ID):AS_CALL_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
-- if ~local_is_in_helpers(local,helper) then return void.
-- otherwise returns a tree of AS nodes that can be used to access local.
-- #OUT+"as_of_Local_in_Helper ("+local.str+") ";
-- #OUT+"in helper ("+helper.name.str+"/"+helper.tp.str+") ";
names : FLIST{IDENT} := name_of_local_in_helpers(local,helper);-- TRANS::name_of_local_in_helpers
-- Turn list of names into AS tree:
as:AS_CALL_EXPR;
loop name ::= names.elt!;-- FLIST{1}::elt!
if void(as) then as := #AS_CALL_EXPR; as.source := source -- AS_CALL_EXPR::create AS_CALL_EXPR::source
else as_new ::= #AS_CALL_EXPR; as_new.source := source;-- AS_CALL_EXPR::create AS_CALL_EXPR::source
as_new.ob := as; as := as_new;-- AS_CALL_EXPR::ob
end;
as.name := name;-- AS_CALL_EXPR::name
end;
return as;
end; -- of as_of_loacl_is_in_helpers
transform_interf_attach_stmt(s:AS_INTERF_ATTACH_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
r::= #AM_ATTACH_STMT(s.source);-- AM_ATTACH_STMT::create AS_INTERF_ATTACH_STMT::source
r.helper := local_with_name(s.helpername);-- AM_ATTACH_STMT::helper TRANS::local_with_name AS_INTERF_ATTACH_STMT::helpername
r.gate := local_with_name(s.gatename);-- AM_ATTACH_STMT::gate TRANS::local_with_name AS_INTERF_ATTACH_STMT::gatename
if ~void(s.at) then r.at := transform_expr(s.at,TP_BUILTIN::int) end;-- AS_INTERF_ATTACH_STMT::at BOOL::not AM_ATTACH_STMT::at TRANS::transform_expr AS_INTERF_ATTACH_STMT::at TP_BUILTIN::int
-- Similar to transform_call_expr. This must be done to make the
-- compiler actually translating the routine
callexpr ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexpr.source := s.source;-- AS_CALL_EXPR::source AS_INTERF_ATTACH_STMT::source
callexpr.name := s.routname;-- AS_CALL_EXPR::name AS_INTERF_ATTACH_STMT::routname
mod1::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);-- AS_ARG_MODE::create AS_ARG_MODE::in_mode
arg1 ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
arg1.source := s.source;-- AS_CALL_EXPR::source AS_INTERF_ATTACH_STMT::source
arg1.name := s.helpername;-- AS_CALL_EXPR::name AS_INTERF_ATTACH_STMT::helpername
mod2::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);-- AS_ARG_MODE::create AS_ARG_MODE::in_mode
arg2 ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
arg2.source := s.source;-- AS_CALL_EXPR::source AS_INTERF_ATTACH_STMT::source
arg2.name := s.gatename;-- AS_CALL_EXPR::name AS_INTERF_ATTACH_STMT::gatename
mod3::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);-- AS_ARG_MODE::create AS_ARG_MODE::in_mode
arg3 ::= #AS_INT_LIT_EXPR; -- since we only need type, choose arbitrary-- AS_INT_LIT_EXPR::create
arg3.source := s.source;-- AS_INT_LIT_EXPR::source AS_INTERF_ATTACH_STMT::source
arg3.val := #INTI(0);-- AS_INT_LIT_EXPR::val INTI::create
arg1.next := arg2;-- AS_CALL_EXPR::next
mod1.next := mod2;-- AS_ARG_MODE::next
arg2.next := arg3;-- AS_CALL_EXPR::next
mod2.next := mod3;-- AS_ARG_MODE::next
callexpr.args := arg1;-- AS_CALL_EXPR::args
callexpr.modes := mod1;-- AS_CALL_EXPR::modes
-- AS_OUT::AS_CALL_EXPR_out(callexpr);
-- #OUT+"Type:"+cur_rout[0].tp.str+"\n";
callam ::= transform_call_expr(callexpr,cur_rout[0].tp,false);-- TRANS::transform_call_expr TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::tp
if void(callam) then
err("Compiler Error: PTRANS: transf_interf_attach: Cannot locate par/fork/attach routine");-- TRANS::err
else
typecase callam
when AM_ROUT_CALL_EXPR then
r.rout := callam.fun;-- AM_ATTACH_STMT::rout AM_ROUT_CALL_EXPR::fun
else
err("Compiler Error: PTRANS: transf_interf_attach: Cannot locate par/fork/attach Routine");-- TRANS::err
end;
cur_rout.calls := cur_rout.calls.push(callam);-- TRANS::cur_rout AM_ROUT_DEF::calls TRANS::cur_rout AM_ROUT_DEF::calls FLIST{1}::push
end;
return r;
end; -- of transform_interf_attach_stmt
transform_lock_stmt(s:AS_LOCK_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
-- pSather add leading export
if ~s.transformed then-- AS_LOCK_STMT::transformed BOOL::not
iwp ::= s.if_when_part;-- AS_LOCK_STMT::if_when_part
loop
if void(iwp) then break!; end;
if void(iwp.then_part) then iwp.then_part := #AS_STMT_LIST; -- AS_LOCK_IF_WHEN::then_part AS_LOCK_IF_WHEN::then_part AS_STMT_LIST::create
iwp.then_part.source := s.source; end;-- AS_LOCK_IF_WHEN::then_part AS_STMT_LIST::source AS_LOCK_STMT::source
-- Insert Import Code before
import ::= as_for_sys_import_export(import_code,iwp.then_part,-- TRANS::import_code AS_LOCK_IF_WHEN::then_part
s.source);-- AS_LOCK_STMT::source
if void(iwp.then_part.stmts) then -- AS_LOCK_IF_WHEN::then_part AS_STMT_LIST::stmts
iwp.then_part.stmts := import-- AS_LOCK_IF_WHEN::then_part AS_STMT_LIST::stmts
else
import.next := iwp.then_part.stmts; -- AS_LOCK_IF_WHEN::then_part AS_STMT_LIST::stmts
iwp.then_part.stmts := import -- AS_LOCK_IF_WHEN::then_part AS_STMT_LIST::stmts
end;
--Append Export Code
append_export_in_list(iwp.then_part,false); -- at least one export-- TRANS::append_export_in_list AS_LOCK_IF_WHEN::then_part
iwp := iwp.next;-- AS_LOCK_IF_WHEN::next
end;
if ~void(s.else_part) then-- AS_LOCK_STMT::else_part BOOL::not
-- Insert Import Code before
import::=as_for_sys_import_export(import_code,s.else_part,s.source);-- TRANS::import_code AS_LOCK_STMT::else_part AS_LOCK_STMT::source
if void(s.else_part.stmts) then s.else_part.stmts := import-- AS_LOCK_STMT::else_part AS_STMT_LIST::stmts AS_LOCK_STMT::else_part AS_STMT_LIST::stmts
else import.next:=s.else_part.stmts;s.else_part.stmts:=import end;-- AS_LOCK_STMT::else_part AS_STMT_LIST::stmts AS_LOCK_STMT::else_part AS_STMT_LIST::stmts
--Append Export Code
append_export_in_list(s.else_part,false); -- at least one export-- TRANS::append_export_in_list AS_LOCK_STMT::else_part
end;
end;
-- semantics checked.
if void(s) then return void end;
r::=#AM_LOCK_STMT(s.source);-- AM_LOCK_STMT::create AS_LOCK_STMT::source
old_cur_lock::=cur_lock;-- TRANS::cur_lock
cur_lock := r;-- TRANS::cur_lock
iwp ::= s.if_when_part;-- AS_LOCK_STMT::if_when_part
loop while!(~void(iwp));-- BOOL::not
guardt ::= transform_expr(iwp.val,TP_BUILTIN::bool);-- TRANS::transform_expr AS_LOCK_IF_WHEN::val TP_BUILTIN::bool
locks ::= #ARRAY{$AM_EXPR}(iwp.elts_size);-- ARRAY{1}::create AS_LOCK_IF_WHEN::elts_size
lck ::= iwp.e_list;-- AS_LOCK_IF_WHEN::e_list
loop
while!(~void(lck));-- BOOL::not
idx ::= 0.up!;-- INT::up!
locks[idx] := transform_expr(lck,TP_BUILTIN::dollar_lock);-- ARRAY{1}::aset TRANS::transform_expr TP_BUILTIN::dollar_lock
lck := lck.next;
end;
body ::= transform_stmt_list(iwp.then_part);-- TRANS::transform_stmt_list AS_LOCK_IF_WHEN::then_part
r.guards := r.guards.push(guardt);-- AM_LOCK_STMT::guards AM_LOCK_STMT::guards FLIST{1}::push
r.locks := r.locks.push(locks);-- AM_LOCK_STMT::locks AM_LOCK_STMT::locks FLIST{1}::push
r.stmts := r.stmts.push(body);-- AM_LOCK_STMT::stmts AM_LOCK_STMT::stmts FLIST{1}::push
iwp := iwp.next; -- AS_LOCK_IF_WHEN::next
end;
if ~s.no_else then-- AS_LOCK_STMT::no_else BOOL::not
r.else_stmts := transform_stmt_list(s.else_part);-- AM_LOCK_STMT::else_stmts TRANS::transform_stmt_list AS_LOCK_STMT::else_part
end;
cur_lock := old_cur_lock;-- TRANS::cur_lock
return r;
end;
transform_unlock_stmt(s:AS_UNLOCK_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
if ~is_in_lock then-- TRANS::is_in_lock BOOL::not
if is_in_par_or_fork then-- TRANS::is_in_par_or_fork
unlock_in_par_fork_err(s);-- TRANS::unlock_in_par_fork_err
else
unlock_outside_lock_err(s); -- TRANS::unlock_outside_lock_err
end;
return void;
end;
ret : $AM_STMT;
if ~s.transformed then-- AS_UNLOCK_STMT::transformed BOOL::not
-- Insert Export before Unlock Statement
prev ::= previous(s);-- TRANS::previous
export::= as_for_sys_import_export(export_code,s.surr_stmt_list,s.source);-- TRANS::export_code AS_UNLOCK_STMT::surr_stmt_list AS_UNLOCK_STMT::source
export.next := s;
if void(prev) then s.surr_stmt_list.stmts := export -- AS_UNLOCK_STMT::surr_stmt_list AS_STMT_LIST::stmts
else prev.next := export end;
ret := transform_stmt(export);-- TRANS::transform_stmt
end;
r::=#AM_UNLOCK_STMT(s.source);-- AM_UNLOCK_STMT::create AS_UNLOCK_STMT::source
if void(ret) then ret := r else ret.append(r) end;
r.lock_ob := transform_expr(s.e,TP_BUILTIN::dollar_lock);-- AM_UNLOCK_STMT::lock_ob TRANS::transform_expr AS_UNLOCK_STMT::e TP_BUILTIN::dollar_lock
return ret;
end;
unlock_outside_lock_err(s:AS_UNLOCK_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(s);-- TRANS::err_loc
err("'unlock' statement must appear inside of `lock'.");-- TRANS::err
end;
unlock_in_par_fork_err(s:AS_UNLOCK_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(s);-- TRANS::err_loc
err("'unlock' statement may not not appear inside of `par', `parloop', or `fork'.");-- TRANS::err
end;
transform_with_near_stmt(s:AS_WITH_NEAR_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
r::=#AM_WITH_NEAR_STMT(s.source);-- AM_WITH_NEAR_STMT::create AS_WITH_NEAR_STMT::source
r.objects :=#ARRAY{$AM_EXPR}(s.elts_size);-- AM_WITH_NEAR_STMT::objects ARRAY{1}::create AS_WITH_NEAR_STMT::elts_size
obj ::= s.idents;-- AS_WITH_NEAR_STMT::idents
if void(cur_rout) then -- TRANS::cur_rout
err("Compiler Error: PTRANS: transf_with_near_stmt: cur_rout void");-- TRANS::err
end;
loop
while!(~void(obj));-- BOOL::not
-- obj is of type IDENT
l:AM_LOCAL_EXPR:=local_with_name(obj.name);-- TRANS::local_with_name AS_IDENT_LIST::name
if void(l) then
with_near_locals_only_err(obj);-- TRANS::with_near_locals_only_err
return void;
end;
k:INT:=l.tp.kind;-- AM_LOCAL_EXPR::tp
if (k/=TP_KIND::ref_tp and k/=TP_KIND::spr_tp) then -- INT::is_eq TP_KIND::ref_tp BOOL::not INT::is_eq TP_KIND::spr_tp BOOL::not
with_near_non_ref_err(obj); -- TRANS::with_near_non_ref_err
return void;
end;
r.objects.set!(l);-- AM_WITH_NEAR_STMT::objects ARRAY{1}::set!
obj := obj.next;-- AS_IDENT_LIST::next
end;
if s.self_occurred then-- AS_WITH_NEAR_STMT::self_occurred
r.objects[s.elts_size - 1] := cur_rout.self_local;-- AM_WITH_NEAR_STMT::objects ARRAY{1}::aset AS_WITH_NEAR_STMT::elts_size INT::minus TRANS::cur_rout AM_ROUT_DEF::self_local
end;
r.near_part := transform_stmt_list(s.near_part);-- AM_WITH_NEAR_STMT::near_part TRANS::transform_stmt_list AS_WITH_NEAR_STMT::near_part
r.else_part := transform_stmt_list(s.else_part);-- AM_WITH_NEAR_STMT::else_part TRANS::transform_stmt_list AS_WITH_NEAR_STMT::else_part
return r;
end;
with_near_non_ref_err(i:AS_IDENT_LIST)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(i);-- TRANS::err_loc
err("'with near' can't use "+i.name.str+-- TRANS::err STR::plus AS_IDENT_LIST::name IDENT::str
". (Reference objects only.)");-- STR::plus
end;
with_near_locals_only_err(i:AS_IDENT_LIST)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(i);-- TRANS::err_loc
err("`with near' can't use "+i.name.str+-- TRANS::err STR::plus AS_IDENT_LIST::name IDENT::str
". (Locals, arguments and 'self' only.)");-- STR::plus
end;
private is_of_type_attach(tp:$TP):BOOL is
typecase tp when TP_CLASS then
return tp.is_subtype(-- TP_CLASS::is_subtype
prog.tp_tbl.class_tbl.get_query(#(#IDENT("$ATTACH"),tp.params)));-- TRANS::prog PROG::tp_tbl TP_TBL::class_tbl TP_CLASS_TBL::get_query TUP{2}::create IDENT::create TP_CLASS::params
end;
end;
transform_attach_stmt(s:AS_ATTACH_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
-- #OUT+"entering transform of attach stmt\n";
if void(s.lhs) then attach_without_attach_err(s); return void end;-- AS_ATTACH_STMT::lhs TRANS::attach_without_attach_err
lhs_am ::= transform_expr(s.lhs,void);-- TRANS::transform_expr AS_ATTACH_STMT::lhs
if void(lhs_am) then -- there must be an error in transform_expr(s.lhs)
return void;
end;
lhs_tp ::= lhs_am.tp;
rhs_tp :$TP:= void;
-- #OUT+"Attach lhs type: "+lhs_tp.str+"\n";
if ~is_of_type_attach(lhs_am.tp) then-- TRANS::is_of_type_attach BOOL::not
attach_without_attach_err(s);-- TRANS::attach_without_attach_err
end;
lhs_as ::= lhs_am.tp.as;
typecase lhs_am
when AM_LOCAL_EXPR then
if ~void(lhs_am.as_type) then lhs_as := lhs_am.as_type end-- AM_LOCAL_EXPR::as_type BOOL::not AM_LOCAL_EXPR::as_type
else end;
if ~void(lhs_as.params) then-- AS_TYPE_SPEC::params BOOL::not
-- lhs has the form $ATTACH{...}
if ~void(lhs_as.params.next) then-- AS_TYPE_SPEC::params AS_TYPE_SPEC::next BOOL::not
attach_without_attach_err(s);-- TRANS::attach_without_attach_err
return void;
end;
rhs_tp := tp_of(lhs_as.params);-- TRANS::tp_of AS_TYPE_SPEC::params
end;
-- at this point rhs_tp has the correct result type of the rhs expr
-- strip any at-Expressions:
rhs ::= s.rhs;-- AS_ATTACH_STMT::rhs
at : $AS_EXPR;
atexpr : AS_AT_EXPR;
rhsexpr ::= s.rhs;-- AS_ATTACH_STMT::rhs
loop
typecase rhsexpr
when AS_AT_EXPR then
-- #OUT+"stripping off one AT-Expr\n";
atexpr := rhsexpr;
-- ignore ::= transform_expr(atexpr.at,TP_BUILTIN::int);
if void(at) then at := atexpr.at; end;-- AS_AT_EXPR::at
else
break!
end;
-- atexpr is AS_AT_EXPR here
rhsexpr := atexpr.e;-- AS_AT_EXPR::e
end;
rhs := rhsexpr;
rhs_am : $AM_EXPR;
typecase rhs
when AS_CALL_EXPR then
-- Special deal for AS_CALL_EXPR: If we would call transform_expr
-- in AS_CALL_EXPR, then the implementation would enforce the
-- the called routine to return a value. For attaching to cohort
-- however, no value is allowed. Hence, we call transform_call_expr
-- directly and use 'false' as third argument.
rhs_am := transform_call_expr(rhs,rhs_tp,~void(rhs_tp));-- TRANS::transform_call_expr BOOL::not
else
rhs_am := transform_expr(rhs,rhs_tp);-- TRANS::transform_expr
end;
if void(rhs_am) then
return void;
end;
ret_as : $AS_STMT;
-- 0) Preparation
-- #OUT+"Context:\n";
-- #OUT+"same = "+tp_con.same.str+"\n";
-- #OUT+"pnames = <";
-- loop pn ::= tp_con.pnames.elt!; #OUT+pn.str+" " end;
-- #OUT+">\n";
-- #OUT+"ptypes = <";
-- loop pt ::= tp_con.ptypes.elt!; #OUT+pt.str+" " end;
-- #OUT+">\n";
-- srcsig::=cur_rout.srcsig;
-- #OUT+"Elt-srcsig-TP= "+srcsig.tp.str+"\n";
-- original
-- current_tp : $TP := cur_rout[0].tp;
-- current_class_tp : TP_CLASS;
-- current_class_as : AS_CLASS_DEF;
-- current_params : ARRAY{$TP};
--
-- typecase current_tp
-- when TP_CLASS then
-- current_class_tp := current_tp;
-- current_params := current_class_tp.params;
-- num : INT := 0;
-- if ~void(current_params) then
-- num := current_params.size;
-- end;
-- current_class_as:= prog.parse.tree_for(current_class_tp.name,num);
-- else err("Compiler Error: PTRANS: transform_attach: 0");
-- end;
orig_cl_tp : $TP := cur_rout.srcsig.tp;-- TRANS::cur_rout AM_ROUT_DEF::srcsig SIG::tp
orig_class_tp : TP_CLASS;
orig_class_as : AS_CLASS_DEF;
orig_cl_params : ARRAY{$TP};
typecase orig_cl_tp
when TP_CLASS then
orig_class_tp := orig_cl_tp;
orig_cl_params := orig_class_tp.params;-- TP_CLASS::params
num : INT := 0;
if ~void(orig_cl_params) then-- BOOL::not
num := orig_cl_params.size;-- ARRAY{1}::size
end;
orig_class_as:= prog.parse.tree_for(orig_class_tp.name,num);-- TRANS::prog PROG::parse TP_CLASS::name
else err("Compiler Error: PTRANS: transform_attach: 0");-- TRANS::err
end;
-- #OUT+"orig_cl_tp = "+orig_cl_tp.str +"\n";
-- #OUT+"orig_class_tp = "+orig_class_tp.str+"\n";
-- #OUT+"orig_class_as = "+orig_class_as.name.str+"\n";
-- #OUT+"orig_cl_params = <";
-- loop pr ::= orig_cl_params.elt!; #OUT+pr.str+" " end;
-- #OUT+">\n";
current_tp : $TP := cur_rout[0].tp;-- TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::tp
current_class_tp : TP_CLASS;
typecase current_tp
when TP_CLASS then
current_class_tp := current_tp;
else err("Compiler Error: PTRANS: transform_par: 0");-- TRANS::err
end;
if s.transformed then-- AS_ATTACH_STMT::transformed
dummy ::= add_helper_to_tbls(s.helper_class,orig_cl_params);-- TRANS::add_helper_to_tbls AS_ATTACH_STMT::helper_class
update_routine_in_tbls(current_class_tp,s.rout);-- TRANS::update_routine_in_tbls AS_ATTACH_STMT::rout
return void;
end;
-- 1) Create new identifiers
newidattach ::= #IDENT(IDENT::next_tmp("attach"));-- IDENT::create IDENT::next_tmp
newidattach_cl ::= #IDENT(IDENT::next_tmp("attach_cl"));-- IDENT::create IDENT::next_tmp
newidattach_ob ::= #IDENT(IDENT::next_tmp("attach_ob"));-- IDENT::create IDENT::next_tmp
newidgate ::= #IDENT(IDENT::next_tmp("gate"));-- IDENT::create IDENT::next_tmp
s.helper_class := newidattach_cl;-- AS_ATTACH_STMT::helper_class
-- 2) Create class definition (Helper Object)
helper ::= create_helper_object(s,newidattach_ob,newidattach_cl,-- TRANS::create_helper_object
orig_class_as,orig_cl_params);
-- 3) insert
-- newgate ::= lhsexpr
-- _pS_attach_ob ::= #_pS_attach_cl;
as1 ::= #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
as1.source := s.source;-- AS_ASSIGN_STMT::source AS_ATTACH_STMT::source
as1.surr_stmt_list := s.surr_stmt_list;-- AS_ASSIGN_STMT::surr_stmt_list AS_ATTACH_STMT::surr_stmt_list
as1.name := newidgate;-- AS_ASSIGN_STMT::name
as1.rhs := s.lhs;-- AS_ASSIGN_STMT::rhs AS_ATTACH_STMT::lhs
if void(ret_as) then ret_as := as1 else ret_as.append(as1) end;
ret_as.append(create_helper_object_stmt(newidattach_ob,newidattach_cl,-- TRANS::create_helper_object_stmt
orig_class_as,s.surr_stmt_list,s.source));-- AS_ATTACH_STMT::surr_stmt_list AS_ATTACH_STMT::source
-- 4) Statements to Fill Helper Object
ret_as.append(link_helper_stmt(newidattach_ob,s.surr_stmt_list,s.source));-- TRANS::link_helper_stmt AS_ATTACH_STMT::surr_stmt_list AS_ATTACH_STMT::source
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if ( loc.name.str.head(1) /= "_" -- AM_LOCAL_EXPR::name IDENT::str STR::head
or ( ~void(cur_cohort)-- STR::is_eq BOOL::not TRANS::cur_cohort
and loc.name = cur_cohort.name))-- BOOL::not AM_LOCAL_EXPR::name TRANS::cur_cohort AM_LOCAL_EXPR::name
and ( void(cur_param_ob)-- TRANS::cur_param_ob
or ~local_is_in_par_helpers(loc.name,cur_param_ob))-- TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name TRANS::cur_param_ob BOOL::not
then
exp ::= #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
exp.source := s.source;-- AS_ASSIGN_STMT::source AS_ATTACH_STMT::source
exp.surr_stmt_list := s.surr_stmt_list;-- AS_ASSIGN_STMT::surr_stmt_list AS_ATTACH_STMT::surr_stmt_list
exp.lhs_expr := as_of_local_in_helpers(loc.name,helper,s.source);-- AS_ASSIGN_STMT::lhs_expr TRANS::as_of_local_in_helpers AM_LOCAL_EXPR::name AS_ATTACH_STMT::source
rhsx ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
rhsx.source := s.source;-- AS_CALL_EXPR::source AS_ATTACH_STMT::source
rhsx.name := loc.name;-- AS_CALL_EXPR::name AM_LOCAL_EXPR::name
exp.rhs := rhsx;-- AS_ASSIGN_STMT::rhs
ret_as.append(exp);
end;
end;
ret_as.append(as_for_sys_import_export(export_code,s.surr_stmt_list,s.source));-- TRANS::export_code AS_ATTACH_STMT::surr_stmt_list AS_ATTACH_STMT::source
-- 5) Turn Attached Expression Into Routine
-- either newgate.enqueue(rhsexpr);
-- or rhsexpr; newgate.enqueue;
attachbody ::= #AS_STMT_LIST;-- AS_STMT_LIST::create
attachbody.source := s.source;-- AS_STMT_LIST::source AS_ATTACH_STMT::source
if ~void(rhs_tp) then-- BOOL::not
call ::= #AS_EXPR_STMT;-- AS_EXPR_STMT::create
call.source := s.source;-- AS_EXPR_STMT::source AS_ATTACH_STMT::source
call.surr_stmt_list := attachbody;-- AS_EXPR_STMT::surr_stmt_list
callexpr ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexpr.source := s.source;-- AS_CALL_EXPR::source AS_ATTACH_STMT::source
callexpr.name := #IDENT("death");-- AS_CALL_EXPR::name IDENT::create
callexprob ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexprob.source := s.source;-- AS_CALL_EXPR::source AS_ATTACH_STMT::source
callexprob.name := newidgate;-- AS_CALL_EXPR::name
callexpr.ob := callexprob;-- AS_CALL_EXPR::ob
callexpr.args := rhs; -- without at expressions;-- AS_CALL_EXPR::args
callexpr.modes:=#(AS_ARG_MODE::in_mode);-- AS_CALL_EXPR::modes AS_ARG_MODE::create AS_ARG_MODE::in_mode
call.e := callexpr;-- AS_EXPR_STMT::e
call.transformed := true; -- will prevent surrounding import/export-- AS_EXPR_STMT::transformed
attachbody.stmts := call;-- AS_STMT_LIST::stmts
else
exprstmt ::= #AS_EXPR_STMT;-- AS_EXPR_STMT::create
exprstmt.source := s.source;-- AS_EXPR_STMT::source AS_ATTACH_STMT::source
exprstmt.surr_stmt_list := attachbody;-- AS_EXPR_STMT::surr_stmt_list
exprstmt.e := rhs; -- without at expressions;-- AS_EXPR_STMT::e
attachbody.stmts := exprstmt;-- AS_STMT_LIST::stmts
call ::= #AS_EXPR_STMT;-- AS_EXPR_STMT::create
call.source := s.source;-- AS_EXPR_STMT::source AS_ATTACH_STMT::source
call.surr_stmt_list := attachbody;-- AS_EXPR_STMT::surr_stmt_list
callexpr ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexpr.source := s.source;-- AS_CALL_EXPR::source AS_ATTACH_STMT::source
callexpr.name := #IDENT("death");-- AS_CALL_EXPR::name IDENT::create
callexprob ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
callexprob.source := s.source;-- AS_CALL_EXPR::source AS_ATTACH_STMT::source
callexprob.name := newidgate;-- AS_CALL_EXPR::name
callexpr.ob := callexprob;-- AS_CALL_EXPR::ob
call.e := callexpr;-- AS_EXPR_STMT::e
call.transformed := true; -- will prevent surrounding import/export-- AS_EXPR_STMT::transformed
attachbody.stmts.append(call);-- AS_STMT_LIST::stmts
end;
s.rout:=turn_into_routine(newidattach,newidattach_ob,newidattach_cl,helper,-- AS_ATTACH_STMT::rout TRANS::turn_into_routine
orig_class_as,current_class_tp,newidgate,lhs_as,attachbody,att_code,-- TRANS::att_code
s.source);-- AS_ATTACH_STMT::source
-- 6) _pS_attach(_pS_attach_ob,_pS_gate);
att8 ::= #AS_INTERF_ATTACH_STMT;-- AS_INTERF_ATTACH_STMT::create
att8.source := s.source;-- AS_INTERF_ATTACH_STMT::source AS_ATTACH_STMT::source
att8.surr_stmt_list := s.surr_stmt_list;-- AS_INTERF_ATTACH_STMT::surr_stmt_list AS_ATTACH_STMT::surr_stmt_list
att8.routname := newidattach;-- AS_INTERF_ATTACH_STMT::routname
att8.helpername := newidattach_ob;-- AS_INTERF_ATTACH_STMT::helpername
att8.gatename := newidgate;-- AS_INTERF_ATTACH_STMT::gatename
att8.at := at;-- AS_INTERF_ATTACH_STMT::at
ret_as.append(att8);
-- 8) Push replacement statements into statement list
ret_as.append(s.next);-- AS_ATTACH_STMT::next
s.next := ret_as;-- AS_ATTACH_STMT::next
s.dont_print := true; -- flag for AS_out that atach must not be printed-- AS_ATTACH_STMT::dont_print
-- #OUT+"statements replacing attach (and more):\n";
-- AS_OUT::AS_STMT_out(s.next);
return void;
end;
attach_without_attach_err(s:AS_ATTACH_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(s);-- TRANS::err_loc
err("':-' statement must have $ATTACH or $ATTACH{T} expr as lhs");-- TRANS::err
end;
transform_fork_stmt(s:AS_FORK_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
if ~is_in_par_or_fork then fork_outside_par_err(s); return void end;-- TRANS::is_in_par_or_fork BOOL::not TRANS::fork_outside_par_err
ret_as : $AS_STMT;
-- 0) Preparation
-- #OUT+"Context:\n";
-- #OUT+"same = "+tp_con.same.str+"\n";
-- #OUT+"pnames = <";
-- loop pn ::= tp_con.pnames.elt!; #OUT+pn.str+" " end;
-- #OUT+">\n";
-- #OUT+"ptypes = <";
-- loop pt ::= tp_con.ptypes.elt!; #OUT+pt.str+" " end;
-- #OUT+">\n";
-- srcsig::=cur_rout.srcsig;
-- #OUT+"Elt-srcsig-TP= "+srcsig.tp.str+"\n";
-- Original
-- current_tp : $TP := cur_rout[0].tp;
-- current_class_tp : TP_CLASS;
-- current_class_as : AS_CLASS_DEF;
-- current_params : ARRAY{$TP};
--
-- typecase current_tp
-- when TP_CLASS then
-- current_class_tp := current_tp;
-- current_params := current_class_tp.params;
-- num : INT := 0;
-- if ~void(current_params) then
-- num := current_params.size;
-- end;
-- current_class_as:= prog.parse.tree_for(current_class_tp.name,num);
-- else err("Compiler Error: PTRANS: transform_fork: 0");
-- end;
orig_cl_tp : $TP := cur_rout.srcsig.tp;-- TRANS::cur_rout AM_ROUT_DEF::srcsig SIG::tp
orig_class_tp : TP_CLASS;
orig_class_as : AS_CLASS_DEF;
orig_cl_params : ARRAY{$TP};
typecase orig_cl_tp
when TP_CLASS then
orig_class_tp := orig_cl_tp;
orig_cl_params := orig_class_tp.params;-- TP_CLASS::params
num : INT := 0;
if ~void(orig_cl_params) then-- BOOL::not
num := orig_cl_params.size;-- ARRAY{1}::size
end;
orig_class_as:= prog.parse.tree_for(orig_class_tp.name,num);-- TRANS::prog PROG::parse TP_CLASS::name
else err("Compiler Error: PTRANS: transform_fork: 0");-- TRANS::err
end;
-- #OUT+"orig_cl_tp = "+orig_cl_tp.str +"\n";
-- #OUT+"orig_class_tp = "+orig_class_tp.str+"\n";
-- #OUT+"orig_class_as = "+orig_class_as.name.str+"\n";
-- #OUT+"orig_cl_params = <";
-- loop pr ::= orig_cl_params.elt!; #OUT+pr.str+" " end;
-- #OUT+">\n";
current_tp : $TP := cur_rout[0].tp;-- TRANS::cur_rout AM_ROUT_DEF::aget AM_FORMAL_ARG::tp
current_class_tp : TP_CLASS;
typecase current_tp
when TP_CLASS then
current_class_tp := current_tp;
else err("Compiler Error: PTRANS: transform_par: 0");-- TRANS::err
end;
if s.transformed then-- AS_FORK_STMT::transformed
dummy ::= add_helper_to_tbls(s.helper_class,orig_cl_params);-- TRANS::add_helper_to_tbls AS_FORK_STMT::helper_class
update_routine_in_tbls(current_class_tp,s.rout);-- TRANS::update_routine_in_tbls AS_FORK_STMT::rout
return void;
end;
-- 1) Create new identifiers
newidfork ::= #IDENT(IDENT::next_tmp("fork"));-- IDENT::create IDENT::next_tmp
newidparams_cl ::= #IDENT(IDENT::next_tmp("params_cl"));-- IDENT::create IDENT::next_tmp
newidparams_ob ::= #IDENT(IDENT::next_tmp("params_ob"));-- IDENT::create IDENT::next_tmp
s.helper_class := newidparams_cl;-- AS_FORK_STMT::helper_class
-- 2) Create class definition (Helper Object)
helper ::= create_helper_object(s,newidparams_ob,newidparams_cl,-- TRANS::create_helper_object
orig_class_as,orig_cl_params);
-- 3) _pS_params_ob ::= #_pS_params_cl;
chos ::= create_helper_object_stmt(newidparams_ob,newidparams_cl,-- TRANS::create_helper_object_stmt
orig_class_as,s.surr_stmt_list,s.source); -- AS_FORK_STMT::surr_stmt_list AS_FORK_STMT::source
if void(ret_as) then ret_as := chos else ret_as.append(chos) end;
-- 4) Statements to Fill Helper Object
-- 4a) helper.cur_param_ob := cur_param_ob
-- 4b) helper.local := local, for those which are not inherited from par
-- 4c) export;
ret_as.append(link_helper_stmt(newidparams_ob,s.surr_stmt_list,s.source));-- TRANS::link_helper_stmt AS_FORK_STMT::surr_stmt_list AS_FORK_STMT::source
loop loc::=active_locals_and_params!;-- TRANS::active_locals_and_params!
if loc.name.str.head(1) /= "_" -- AM_LOCAL_EXPR::name IDENT::str STR::head
and ~local_is_in_par_helpers(loc.name,cur_param_ob)-- STR::is_eq BOOL::not TRANS::local_is_in_par_helpers AM_LOCAL_EXPR::name TRANS::cur_param_ob
then-- BOOL::not
exp ::= #AS_ASSIGN_STMT;-- AS_ASSIGN_STMT::create
exp.source := s.source;-- AS_ASSIGN_STMT::source AS_FORK_STMT::source
exp.surr_stmt_list := s.surr_stmt_list;-- AS_ASSIGN_STMT::surr_stmt_list AS_FORK_STMT::surr_stmt_list
exp.lhs_expr:=as_of_local_in_helpers(loc.name,helper,s.source);-- AS_ASSIGN_STMT::lhs_expr TRANS::as_of_local_in_helpers AM_LOCAL_EXPR::name AS_FORK_STMT::source
rhs ::= #AS_CALL_EXPR;-- AS_CALL_EXPR::create
rhs.source := s.source;-- AS_CALL_EXPR::source AS_FORK_STMT::source
rhs.name := loc.name;-- AS_CALL_EXPR::name AM_LOCAL_EXPR::name
exp.rhs := rhs;-- AS_ASSIGN_STMT::rhs
ret_as.append(exp);
end;
end;
ret_as.append(as_for_sys_import_export(export_code,s.surr_stmt_list,s.source));-- TRANS::export_code AS_FORK_STMT::surr_stmt_list AS_FORK_STMT::source
-- 5) Turn Fork Body Into Routine
s.rout := turn_into_routine(newidfork,newidparams_ob,newidparams_cl,helper,-- AS_FORK_STMT::rout TRANS::turn_into_routine
orig_class_as,current_class_tp,cur_cohort.name,void,s.body,frk_code,-- TRANS::cur_cohort AM_LOCAL_EXPR::name AS_FORK_STMT::body TRANS::frk_code
s.source);-- AS_FORK_STMT::source
s.body := void;-- AS_FORK_STMT::body
-- 6) _pS_fork(_pS_params_ob,_pS_cohort);
att8 ::= #AS_INTERF_ATTACH_STMT;-- AS_INTERF_ATTACH_STMT::create
att8.source := s.source;-- AS_INTERF_ATTACH_STMT::source AS_FORK_STMT::source
att8.surr_stmt_list := s.surr_stmt_list;-- AS_INTERF_ATTACH_STMT::surr_stmt_list AS_FORK_STMT::surr_stmt_list
att8.routname := newidfork;-- AS_INTERF_ATTACH_STMT::routname
att8.helpername := newidparams_ob;-- AS_INTERF_ATTACH_STMT::helpername
att8.gatename := cur_cohort.name;-- AS_INTERF_ATTACH_STMT::gatename TRANS::cur_cohort AM_LOCAL_EXPR::name
att8.at := s.at;-- AS_INTERF_ATTACH_STMT::at AS_FORK_STMT::at
ret_as.append(att8);
-- 7)
-- 8) Push replacement statements into statement list
ret_as.append(s.next);-- AS_FORK_STMT::next
s.next := ret_as;-- AS_FORK_STMT::next
-- #OUT+"statements replacing fork (and more):\n";
-- AS_OUT::AS_STMT_out(s.next);
return void;
end;
fork_outside_par_err(s:AS_FORK_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(s);-- TRANS::err_loc
err("`fork' statement must appear inside of `par' or `parloop'");-- TRANS::err
end;
transform_sync_stmt(s:AS_SYNC_STMT):$AM_STMT
pre prog.psather-- TRANS::prog PROG::psather
is
ret : $AM_STMT;
if ~s.transformed then-- AS_SYNC_STMT::transformed BOOL::not
-- Insert Export before Sync Statement
prev ::= previous(s);-- TRANS::previous
export::=as_for_sys_import_export(export_code,s.surr_stmt_list,s.source);-- TRANS::export_code AS_SYNC_STMT::surr_stmt_list AS_SYNC_STMT::source
export.next := s;
if void(prev) then s.surr_stmt_list.stmts := export -- AS_SYNC_STMT::surr_stmt_list AS_STMT_LIST::stmts
else prev.next := export end;
ret := transform_stmt(export);-- TRANS::transform_stmt
end;
r::=#AM_SYNC_STMT(s.source);-- AM_SYNC_STMT::create AS_SYNC_STMT::source
if void(ret) then ret := r else ret.append(r) end;
-- Append Import statement after Sync Statement.
import::=as_for_sys_import_export(import_code,s.surr_stmt_list,s.source);-- TRANS::import_code AS_SYNC_STMT::surr_stmt_list AS_SYNC_STMT::source
import.next := s.next; s.next := import;-- AS_SYNC_STMT::next AS_SYNC_STMT::next
return ret;
end;
transform_pSather_expr(e:$AS_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
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_HERE_EXPR then r:= transform_here_expr(e,tp)-- TRANS::transform_here_expr
when AS_ANY_EXPR then r:= transform_any_expr(e,tp)-- TRANS::transform_any_expr
when AS_COHORT_EXPR then r:= transform_cohort_expr(e,tp)-- TRANS::transform_cohort_expr
when AS_WHERE_EXPR then r:= transform_where_expr(e,tp)-- TRANS::transform_where_expr
when AS_NEAR_EXPR then r:= transform_near_expr(e,tp)-- TRANS::transform_near_expr
when AS_FAR_EXPR then r:= transform_far_expr(e,tp)-- TRANS::transform_far_expr
when AS_AT_EXPR then r:= transform_at_expr(e,tp)-- TRANS::transform_at_expr
end;
return r;
end;
transform_here_expr(e:AS_HERE_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::int.is_subtype(tp) then-- TP_BUILTIN::int TP_CLASS::is_subtype BOOL::not
here_context_err(e,tp); return void; -- TRANS::here_context_err
end;
end;
r::=#AM_HERE_EXPR(e.source);-- AM_HERE_EXPR::create AS_HERE_EXPR::source
return r;
end;
here_context_err(e:AS_HERE_EXPR, tp:$TP)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(e);-- TRANS::err_loc
err("'here' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_any_expr(e:AS_ANY_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::int.is_subtype(tp) then-- TP_BUILTIN::int TP_CLASS::is_subtype BOOL::not
any_context_err(e,tp); return void; -- TRANS::any_context_err
end;
end;
r::=#AM_ANY_EXPR(e.source);-- AM_ANY_EXPR::create AS_ANY_EXPR::source
return r;
end;
any_context_err(e:AS_ANY_EXPR, tp:$TP)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(e);-- TRANS::err_loc
err("'any' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_where_expr(e:AS_WHERE_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::int.is_subtype(tp) then-- TP_BUILTIN::int TP_CLASS::is_subtype BOOL::not
where_context_err(e,tp); return void; -- TRANS::where_context_err
end;
end;
r::=#AM_WHERE_EXPR(e.source);-- AM_WHERE_EXPR::create AS_WHERE_EXPR::source
-- Check parameter
r.arg := transform_expr(e.e, TP_BUILTIN::dollar_ob);-- AM_WHERE_EXPR::arg TRANS::transform_expr AS_WHERE_EXPR::e TP_BUILTIN::dollar_ob
if void(r.arg) then return void end; -- Type Error.-- AM_WHERE_EXPR::arg
return r;
end;
where_context_err(e:AS_WHERE_EXPR, tp:$TP)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(e);-- TRANS::err_loc
err("'where' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_near_expr(e:AS_NEAR_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::bool.is_subtype(tp) then-- TP_BUILTIN::bool TP_CLASS::is_subtype BOOL::not
near_context_err(e,tp); return void; -- TRANS::near_context_err
end;
end;
r::=#AM_NEAR_EXPR(e.source);-- AM_NEAR_EXPR::create AS_NEAR_EXPR::source
-- Check parameter
r.arg := transform_expr(e.e, TP_BUILTIN::dollar_ob);-- AM_NEAR_EXPR::arg TRANS::transform_expr AS_NEAR_EXPR::e TP_BUILTIN::dollar_ob
if void(r.arg) then return void end; -- Type Error.-- AM_NEAR_EXPR::arg
return r;
end;
near_context_err(e:AS_NEAR_EXPR, tp:$TP)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(e);-- TRANS::err_loc
err("'near' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_far_expr(e:AS_FAR_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::bool.is_subtype(tp) then-- TP_BUILTIN::bool TP_CLASS::is_subtype BOOL::not
far_context_err(e,tp); return void; -- TRANS::far_context_err
end;
end;
r::=#AM_FAR_EXPR(e.source);-- AM_FAR_EXPR::create AS_FAR_EXPR::source
-- Check parameter
r.arg := transform_expr(e.e, TP_BUILTIN::dollar_ob);-- AM_FAR_EXPR::arg TRANS::transform_expr AS_FAR_EXPR::e TP_BUILTIN::dollar_ob
if void(r.arg) then return void end; -- Type Error.-- AM_FAR_EXPR::arg
return r;
end;
far_context_err(e:AS_FAR_EXPR, tp:$TP)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(e);-- TRANS::err_loc
err("'far' (INT) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
transform_at_expr(e:AS_AT_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
r::=#AM_AT_EXPR(e.source);-- AM_AT_EXPR::create AS_AT_EXPR::source
r.e := transform_expr(e.e,tp);-- AM_AT_EXPR::e TRANS::transform_expr AS_AT_EXPR::e
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
return r;
end;
transform_cohort_expr(e:AS_COHORT_EXPR, tp:$TP):$AM_EXPR
pre prog.psather-- TRANS::prog PROG::psather
is
if ~is_in_par_or_fork and void(cur_cohort) then -- TRANS::is_in_par_or_fork BOOL::not TRANS::cur_cohort
cohort_outside_par_fork_err(e); -- TRANS::cohort_outside_par_fork_err
return void;
end;
if ~void(tp) then-- BOOL::not
if ~TP_BUILTIN::attach.is_subtype(tp) then-- TP_BUILTIN::attach TP_CLASS::is_subtype BOOL::not
cohort_context_err(e,tp); return void; -- TRANS::cohort_context_err
end;
end;
r:AM_LOCAL_EXPR:=local_with_name(cur_cohort.name);-- TRANS::cur_cohort AM_LOCAL_EXPR::name
if void(r) then err("Comp. Err:PTRANS::transf_cohort_xpr");return void end;-- TRANS::err
r.source := e.source;-- AM_LOCAL_EXPR::source AS_COHORT_EXPR::source
e.name_after_pSather_trafo := cur_cohort.name;-- AS_COHORT_EXPR::name_after_pSather_trafo TRANS::cur_cohort AM_LOCAL_EXPR::name
return r;
end;
cohort_outside_par_fork_err(s:AS_COHORT_EXPR)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(s);-- TRANS::err_loc
err("'cohort' must not appear outside of `par', `parloop', or `fork'.");-- TRANS::err
end;
cohort_context_err(e:AS_COHORT_EXPR, tp:$TP)
pre prog.psather-- TRANS::prog PROG::psather
is
err_loc(e);-- TRANS::err_loc
err("'cohort' (ATTACH) is not a subtype of " + tp.str + ".");-- TRANS::err STR::plus STR::plus
end;
check_pSather_stmt_for_return(t:$AS_STMT)
pre prog.psather-- TRANS::prog PROG::psather
is
s:$AS_STMT:=t;
err_loc(s);-- TRANS::err_loc
typecase s
when AS_PAR_STMT then check_stmt_list_for_return(s.body);-- TRANS::check_stmt_list_for_return AS_PAR_STMT::body
when AS_LOCK_STMT then
if ~s.no_else then check_stmt_list_for_return(s.else_part) end;-- AS_LOCK_STMT::no_else BOOL::not TRANS::check_stmt_list_for_return AS_LOCK_STMT::else_part
iwp : AS_LOCK_IF_WHEN := s.if_when_part;-- AS_LOCK_STMT::if_when_part
loop while!(~void(iwp));-- BOOL::not
check_stmt_list_for_return(iwp.then_part);-- TRANS::check_stmt_list_for_return AS_LOCK_IF_WHEN::then_part
iwp := iwp.next; end;-- AS_LOCK_IF_WHEN::next
when AS_UNLOCK_STMT then return_err;-- TRANS::return_err
when AS_WITH_NEAR_STMT then check_stmt_list_for_return(s.near_part);-- TRANS::check_stmt_list_for_return AS_WITH_NEAR_STMT::near_part
check_stmt_list_for_return(s.else_part);-- TRANS::check_stmt_list_for_return AS_WITH_NEAR_STMT::else_part
when AS_ATTACH_STMT then return_err;-- TRANS::return_err
when AS_FORK_STMT then check_stmt_list_for_return(s.body);-- TRANS::check_stmt_list_for_return AS_FORK_STMT::body
end;
end;
private prev_export(p:$AS_STMT,s:$AS_STMT,l:AS_STMT_LIST)
pre prog.psather-- TRANS::prog PROG::psather
is
export ::= as_for_sys_import_export(export_code,l,s.source);-- TRANS::export_code
export.next := s;
if void(p) then l.stmts := export;-- AS_STMT_LIST::stmts
else p.next := export end;
end;
private is_in_loop_and_calls_iter(e:$AS_EXPR):BOOL
pre prog.psather-- TRANS::prog PROG::psather
is
return (~void(cur_loop) and contains_iter_call(transform_expr(e,void)));-- TRANS::cur_loop BOOL::not TRANS::contains_iter_call TRANS::transform_expr
end;
append_export_in_list(l:AS_STMT_LIST,on_exit_only:BOOL)
pre prog.psather-- TRANS::prog PROG::psather
is
if void(l) then return end;
-- #OUT+"append-export-in-list starting:\n";
-- AS_OUT::AS_STMT_LIST_out(l);
-- #OUT+"is changed to:\n";
s:$AS_STMT:=l.stmts; -- AS_STMT_LIST::stmts
if void(s) then
export ::= as_for_sys_import_export(export_code,l,l.source);-- TRANS::export_code AS_STMT_LIST::source
l.stmts:=export; -- AS_STMT_LIST::stmts
-- AS_OUT::AS_STMT_LIST_out(l);
return;
end;
p:$AS_STMT:=void;
loop
if is_in_lock then-- TRANS::is_in_lock
typecase s
when AS_ASSIGN_STMT then
if is_in_loop_and_calls_iter(s.rhs) then prev_export(p,s,l) end;-- TRANS::is_in_loop_and_calls_iter AS_ASSIGN_STMT::rhs TRANS::prev_export
when AS_ASSERT_STMT then
if is_in_loop_and_calls_iter(s.test) then prev_export(p,s,l) end;-- TRANS::is_in_loop_and_calls_iter AS_ASSERT_STMT::test TRANS::prev_export
when AS_EXPR_STMT then
e:$AS_EXPR:=s.e;-- AS_EXPR_STMT::e
typecase e
when AS_BREAK_EXPR then prev_export(p,s,l)-- TRANS::prev_export
when AS_CALL_EXPR then
if ~void(cur_loop) -- TRANS::cur_loop
and contains_iter_call(transform_call_expr(e,void,false)) -- BOOL::not TRANS::contains_iter_call TRANS::transform_call_expr
then prev_export(p,s,l) end;-- TRANS::prev_export
when AS_AT_EXPR then
if is_in_loop_and_calls_iter(e.e)-- TRANS::is_in_loop_and_calls_iter AS_AT_EXPR::e
or is_in_loop_and_calls_iter(e.at) -- TRANS::is_in_loop_and_calls_iter AS_AT_EXPR::at
then prev_export(p,s,l) end;-- TRANS::prev_export
else
end;
when AS_IF_STMT then
if is_in_loop_and_calls_iter(s.test) then prev_export(p,s,l) end;-- TRANS::is_in_loop_and_calls_iter AS_IF_STMT::test TRANS::prev_export
append_export_in_list(s.then_part,true); -- on exit only-- TRANS::append_export_in_list AS_IF_STMT::then_part
append_export_in_list(s.else_part,true); -- on exit only-- TRANS::append_export_in_list AS_IF_STMT::else_part
when AS_LOOP_STMT then
append_export_in_list(s.body,true); -- on exit only-- TRANS::append_export_in_list AS_LOOP_STMT::body
when AS_CASE_STMT then
if is_in_loop_and_calls_iter(s.test) then prev_export(p,s,l) end;-- TRANS::is_in_loop_and_calls_iter AS_CASE_STMT::test TRANS::prev_export
if ~s.no_else then append_export_in_list(s.else_part,true) end; -- AS_CASE_STMT::no_else BOOL::not TRANS::append_export_in_list AS_CASE_STMT::else_part
wp:AS_CASE_WHEN:=s.when_part;-- AS_CASE_STMT::when_part
loop while!(~void(wp));-- BOOL::not
append_export_in_list(wp.then_part,true); -- on exit only-- TRANS::append_export_in_list AS_CASE_WHEN::then_part
wp:=wp.next end;-- AS_CASE_WHEN::next
when AS_TYPECASE_STMT then
if ~s.no_else then append_export_in_list(s.else_part,true) end; -- AS_TYPECASE_STMT::no_else BOOL::not TRANS::append_export_in_list AS_TYPECASE_STMT::else_part
wp:AS_TYPECASE_WHEN:=s.when_part;-- AS_TYPECASE_STMT::when_part
loop while!(~void(wp));-- BOOL::not
append_export_in_list(wp.then_part,true); -- on exit only-- TRANS::append_export_in_list AS_TYPECASE_WHEN::then_part
wp:=wp.next end;-- AS_TYPECASE_WHEN::next
when AS_WITH_NEAR_STMT then
append_export_in_list(s.near_part,true); -- on exit only-- TRANS::append_export_in_list AS_WITH_NEAR_STMT::near_part
append_export_in_list(s.else_part,true); -- on exit only-- TRANS::append_export_in_list AS_WITH_NEAR_STMT::else_part
when AS_LOCK_STMT then
iwp ::= s.if_when_part;-- AS_LOCK_STMT::if_when_part
loop
if void(iwp) then break! end;
lck : $AS_EXPR := iwp.e_list; -- AS_LOCK_IF_WHEN::e_list
loop while!(~void(lck)); -- BOOL::not
if is_in_loop_and_calls_iter(lck) -- TRANS::is_in_loop_and_calls_iter
then prev_export(p,s,l) end;-- TRANS::prev_export
lck := lck.next;
end;
iwp := iwp.next;-- AS_LOCK_IF_WHEN::next
end;
else
end;
end;
until!(void(s.next)); p:=s; s:=s.next;
end;
-- work on last statement in this list:
if ~on_exit_only then -- BOOL::not
typecase s
when AS_RETURN_STMT then
-- #OUT+"(return at end)\n"; AS_OUT::AS_STMT_LIST_out(l);
return
when AS_YIELD_STMT then
-- #OUT+"(yield at end)\n"; AS_OUT::AS_STMT_LIST_out(l);
return
when AS_QUIT_STMT then
-- #OUT+"(quit at end)\n"; AS_OUT::AS_STMT_LIST_out(l);
return
when AS_RAISE_STMT then
-- #OUT+"(raise at end)\n"; AS_OUT::AS_STMT_LIST_out(l);
return
else
export ::= as_for_sys_import_export(export_code,l,s.source);-- TRANS::export_code
s.append(export);
end;
end;
-- AS_OUT::AS_STMT_LIST_out(l);
end;
end; -- class PTRANS
-- vim:sw=3:nosmartindent