------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather package. It is free software; you may --
-- redistribute  and/or modify it under the terms of the  GNU General Public --
-- License (GPL)  as  published  by the  Free  Software  Foundation;  either --
-- version 2 of the license, or (at your option) any later version.          --
-- This  program  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/GPL for more details.        --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- trans.sa: Transformation of code from AS to AM form.
-------------------------------------------------------------------

class TRANS is
   -- The context for a code transformation from AS form to AM form.
   include CS_COMPONENT;
   -- we redefine err, such that it gives a little bit more information
   err(s:STR) is
      if void(self) or void(self.cur_rout) or void(self.cur_rout.sig) then prog.err(s);
      else s:=self.cur_rout.sig.str+":"+s;
	   prog.err(s);
      end;
   end;

   attr impl:IMPL;		-- The implementation structure for the
      -- type within which this transformation appears.
   attr tp_con:TP_CONTEXT;	-- The type context for interpreting
      -- type specifiers.
   attr cur_rout:AM_ROUT_DEF;	-- The current routine or iter.

   attr cur_loop:AM_LOOP_STMT;	-- Current loop if any.
   attr cur_yield_ind:INT;	-- Index of the current yield.
   attr active_locals:FLIST{AM_LOCAL_EXPR}; -- Locals in scope.
   attr in_pre:BOOL;		-- True if inside a `pre' clause.   
   attr in_post:BOOL;		-- True if this code is inside
      -- a "post" clause (and so can have initial expressions).
   attr in_protect_body:BOOL;	-- True if inside a `protect' body.
   attr in_protect_then:BOOL;	-- True if inside a `protect' `then' or
      -- `else' clause.
   attr in_protect_but_not_loop:BOOL;
   -- True if inside a `protect', but not inside a `loop'.
   attr in_simple_par:BOOL;
   -- True if inside a "simple" par that can be implemented without gates
   attr cur_simple_par:AM_PAR_STMT;
   -- current simple par, if any
   attr ex_tp:$TP;		-- Type of exception expr.
   attr in_invariant:BOOL;	-- True if inside an invariant body.
   attr in_initial:BOOL;	-- True if inside an `initial' expr.
   attr init_stmts:$AM_STMT;	-- The initial statments if any.
   attr in_external:BOOL;	-- True if inside an external class.
   attr in_constant:BOOL;	-- True if inside a constant or shared
      -- initialization expression.

   attr cur_se:SE_CONTEXT;       -- set of side_effects for this translation

   -- invariants or postconditions to be emitted before a return,
   -- if any.
   attr inv_stmt:AM_INVARIANT_STMT;
   attr post_stmt:AM_POST_STMT;
   
   private attr chk_pre, chk_post, chk_invariant, chk_assert:BOOL;
   
-----------

   create(e:ELT):SAME 
      -- Create a new transformation context for the element e. 
      pre ~void(e) is
      r::=new; 
      r.prog:=e.prog; 
      r.impl:=e.impl;
      r.tp_con:=e.con; 
      r.cur_se:=#(r.prog,e.sig);
      --r.iter_sig_am_rout_def := #;
      if void(r.impl) or void(r.tp_con) then return void end;
      r.set_chks;
      return r; 
   end; 
      
-----------      
   
   private set_chks is
      -- set checking states for this class
      
      n::=impl.tp.str;
      options::=prog.get_options;
      typecase options
      when CS_OPTIONS then
	 chk_pre:=options.pre_chk(n);
	 chk_post:=options.post_chk(n);
	 chk_invariant:=options.invariant_chk(n);
	 chk_assert:=options.assert_chk(n);
	 
      end;
   end;

-----------   
   is_iter:BOOL is
      -- True if we are working on an iter.
      if void(cur_rout) then return false end;
      return cur_rout.is_iter; 
   end;

-----------      

   local_with_name(n:IDENT):AM_LOCAL_EXPR 
      -- The local with the name `n', if any. Void otherwise.
      pre ~void(cur_rout) is
      loop r::=cur_rout.elt!;
	 if void(r) then 
	    #OUT + "Compiler error, TRANS::local_with_name, void local.";
	    return void end;
	 if r.expr.name=n then return r.expr end end;
      loop r::=active_locals.elt!;
	 if void(r) then 
	    #OUT + "Compiler error, TRANS::local_with_name, void local.";
	    return void end;
	  if r.name=n 
	  then return r 
	  end 
      end;	    
      return void; 
   end;

-----------      

   add_local(l:AM_LOCAL_EXPR) is
      -- Add the local variable `l'.
      if void(cur_rout) then 
	 #OUT + "Compiler error, TRANS::add_local, cur_rout=void.";
	 return end;
      cur_rout.locals:=cur_rout.locals.push(l);
      if ~void(l.name) then active_locals:=active_locals.push(l) end;
   end;

-----------      

   tp_of(t:AS_TYPE_SPEC):$TP 
      -- The type object corresponding to the type specifier `t' in
      -- this context.
      pre ~void(t) is
      return tp_con.tp_of(t); 
   end;
   
-----------      
   
    special_inline(call:AM_ROUT_CALL_EXPR):$AM_EXPR is
      -- Here we deal only with special purpose inlining
      -- general purpose inlining is done during the optimization phase
      -- If `call' can be inlined, return the inlining expression, 
      -- otherwise just return it.
      if ~prog.all_reached then
	 -- Make sure it's been generated.
	 prog.generate_am.output_sig(call.fun); 
      end;

      -- Don't inline constant initializations
      -- It happens only once, so overhead is little
      -- It makes main more readable, and lowers the
      -- complexity of inlining considerably
      -- Actually, this was only a problem when the general
      -- inlining was done here too. As now the general
      -- inlining has been moved to the optimizer,
      -- it should work OK again. If not, remove the comments
      -- (and don't compile with -O2, gcc is broken)
      -- if in_constant then
          -- return call;
      -- end;

      am::=prog.inliner.special_inline(call);
      -- Ivin - The statements may use local variables and call other routines.
      typecase am
      when AM_STMT_EXPR then
	-- Do not change active_locals to avoid name clashes.
	cur_rout.calls:=cur_rout.calls.concat(am.calls);
	cur_rout.locals:=cur_rout.locals.concat(am.locals);
      else end;
      return am
   end;

-----------      

   -- Ivin - same for iterators.
    special_inline(call:AM_ITER_CALL_EXPR):$AM_EXPR is
      -- Here we deal only with special purpose inlining
      -- general purpose inlining is done during the optimization phase
      -- If `call' can be inlined, return the inlining expression, 
      -- otherwise just return it.
      if ~prog.all_reached then
	 -- Make sure it's been generated.
	 prog.generate_am.output_sig(call.fun); 
      end;
      am::=prog.inliner.special_inline(call);
      typecase am
      when AM_STMT_EXPR then
	-- Do not change active_locals to avoid name clashes.
	cur_rout.calls:=cur_rout.calls.concat(am.calls);
	cur_rout.locals:=cur_rout.locals.concat(am.locals);
	cur_loop.its:=cur_loop.its.concat(am.its);
	cur_loop.bits:=cur_loop.bits.concat(am.bits);
	cur_loop.firsts:=cur_loop.firsts.concat(am.firsts);
      else end;
      return am
   end;

-----------      

    gen:GENERATE_AM is
       -- The GENERATE_AM object controlling translation.
      gen::=prog.generate_am;
      typecase gen when GENERATE_AM then return gen; end;
   end;

-----------      
   
   transform_elt(e:ELT):AM_ROUT_DEF 
      -- Transform the element `e' into AM form. Ignores self.
      -- Should not be applied to void.
      -- If there is a problem, returns void.
      pre ~void(e) is
      t:SAME:=#(e); if void(t) then return void end;
      as::=e.as;
      r:AM_ROUT_DEF;
      typecase as
      when AS_CONST_DEF then r:=t.transform_const_elt(e,as)
      when AS_SHARED_DEF then r:=t.transform_shared_elt(e,as)
      when AS_ATTR_DEF then r:=t.transform_attr_elt(e,as)
      when AS_ROUT_DEF then 
         r:=t.transform_rout_elt(e,as);
	 if t.prog.psather and ~void(t.cur_se) then
 	    t.cur_se.has_import:=t.cur_se.has_import or (r.sig.is_builtin and r.sig.builtin_info.does_import);
 	    t.cur_se.has_export:=t.cur_se.has_export or (r.sig.is_builtin and r.sig.builtin_info.does_export);
	 end;
      end;

      -- register this se_context with the 
      t.cur_se.register;

      SYS::destroy(t);
      return r;
   end;
   
-----------      

   transform_const_elt(e:ELT,as:AS_CONST_DEF):AM_ROUT_DEF is
      -- Transform the element `e' into AM form. 

      check_params_for_partial(as.tp);

      r:AM_ROUT_DEF:=#AM_ROUT_DEF(1,as.source); cur_rout:=r;
      r.srcsig:=e.srcsig;
      r.sig:=e.sig;
      r.sig.srcsig:=e.srcsig;
      sl::=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::self_ident,e.tp,e.as_tp);
      r[0] := #AM_FORMAL_ARG(sl);
      g:AM_SHARED_EXPR:=gen.global_tbl.get(e.name,impl.tp);
      if void(g) then 
	 g:=#AM_SHARED_EXPR(as.source); g.name:=e.name;
	 g.as_type := e.as_tp;
	 g.tp_at:=e.ret; g.class_tp:=impl.tp; g.is_const:=true;
	 in_constant:=true;
	 g.init:=transform_expr(as.init,g.tp_at); 
	 in_constant:=false;
	 gen.global_tbl.insert(g) end;
      ar::=#AM_RETURN_STMT(as.source); ar.val:=g;
      r.code:=ar; r.is_clean:=true; 
      return r; 
   end;
   
-----------      

   transform_shared_elt(e:ELT,as:AS_SHARED_DEF):AM_ROUT_DEF is
	-- Transform the element `e' into AM form. 
      sl, l1: AM_LOCAL_EXPR;

      if tp_of(as.tp).is_partial and (as.tp.kind /= AS_TYPE_SPEC::same) and
	       ~prog.is_check_am 
	 -- this error is not reported during unreachable code stage
	 -- since whenever the code is complete SAME in partial classes
	 -- becomes a concrete class
      then
	 err("Partial classes cannot be instantiated.");
      end;
      
      check_params_for_partial(as.tp);

      if e.is_shared_reader then -- Shared reader.
	 r::=#AM_ROUT_DEF(1,as.source); cur_rout:=r;
	 r.srcsig:=e.srcsig;
	 sl:=#AM_LOCAL_EXPR(as.source, -- Local for self.
			    IDENT_BUILTIN::self_ident, e.tp, e.as_tp);
	 r[0] := #AM_FORMAL_ARG(sl);
	 r.sig:=e.sig;
	 r.sig.srcsig:=e.srcsig;
	 g:AM_SHARED_EXPR:=gen.global_tbl.get(e.name,impl.tp);
	 if void(g) then 
	    g:=#AM_SHARED_EXPR(as.source); g.name:=e.name;
	    g.as_type := e.as_tp;
	    g.tp_at:=e.ret; g.class_tp:=impl.tp; 
	    in_constant:=true;
	    g.init:=transform_expr(as.init,g.tp); 
	    in_constant:=false;
	    gen.global_tbl.insert(g) end;
	 g.tp_at:=e.sig.ret;
	 cur_se.mark_se(g,false);
	 ar::=#AM_RETURN_STMT(as.source); ar.val:=g;
	 r.code:=ar; r.is_clean:=true; 
         return r
      else			-- Shared writer.
	 r::=#AM_ROUT_DEF(2,as.source); cur_rout:=r;
	 r.srcsig:=e.srcsig;	 
	 sl:=#AM_LOCAL_EXPR(as.source, -- Local for self.
			    IDENT_BUILTIN::self_ident, e.tp, e.as_tp);
	 r[0] := #AM_FORMAL_ARG(sl);
	 if void(e.sig.args) then
	    err("Compiler error, TRANS::transform_shared_elt, "
		  "e.sig.args=void."); return void end;	 
	 l1:=#AM_LOCAL_EXPR(as.source, e.name, e.sig.args[0].tp);
	 r[1] := #AM_FORMAL_ARG(l1);
	 r.sig:=e.sig;
	 r.sig.srcsig:=e.srcsig;
	 g:AM_SHARED_EXPR:=gen.global_tbl.get(e.name,impl.tp);
	 if void(g) then 
	    g:=#AM_SHARED_EXPR(as.source); g.name:=e.name;
	    g.as_type := e.as_tp;
	    g.class_tp:=impl.tp;
	    in_constant:=true;
	    g.init:=transform_expr(as.init,g.tp); 
	    in_constant:=false;
	    gen.global_tbl.insert(g) end;
	 g.tp_at:=e.sig.args[0].tp;
	 cur_se.mark_se(g,true);
	 ar::=#AM_ASSIGN_STMT(as.source); 
	 ar.dest:=g; ar.src:=r[1].expr;
	 inv:AM_INVARIANT_STMT;
	 if ~e.is_private and ~in_invariant then
	    isig:SIG:=impl.invariant_sig;
	    if ~void(isig) then
	       inv:=#AM_INVARIANT_STMT(as.source); 
	       inv.sig:=isig;
	       icall::=#AM_ROUT_CALL_EXPR(1,as.source);
	       icall.fun:=isig;
	       cur_se.mark_context(icall);
	       r.calls:=r.calls.push(icall) end end;
	 r.code:=ar; 
	 if void(r.code) then r.code:=inv
	 else r.code.append(inv) end;
	 r.is_clean:=false; 
	 return r; 
      end;
   end;
   
-----------      

   transform_attr_elt(e:ELT,as:AS_ATTR_DEF):AM_ROUT_DEF is
	-- Transform the element `e' into AM form. 
      sl, l1, l2:AM_LOCAL_EXPR;
      r:AM_ROUT_DEF;

      if tp_of(as.tp).is_partial and (as.tp.kind /= AS_TYPE_SPEC::same) and
	       ~prog.is_check_am 
	 -- this error is not reported during unreachable code stage
	 -- since whenever the code is complete SAME in partial classes
	 -- becomes a concrete class
      then
	 err("Partial classes cannot be instantiated.");
      end;
      
      check_params_for_partial(as.tp);

      if e.is_attr_reader then	-- Attribute reader.
	 r:=#AM_ROUT_DEF(1,as.source);	
	 r.srcsig:=e.srcsig;
	 sl:=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::self_ident, 
			    e.tp, e.as_tp);
	 r[0] := #AM_FORMAL_ARG(sl);
	 r.sig:=e.sig;
	 r.sig.srcsig:=e.srcsig;
	 ae::=#AM_ATTR_EXPR(as.source); 
	 ae.as_type := e.as_tp;
	 ae.ob:=r[0].expr; ae.self_tp:=ae.ob.tp;
	 ae.at:=e.name; ae.tp_at:=tp_of(as.tp);
	 if void(ae.tp_at) then 
	    err_loc(as.tp); err("Cannot translate type.");
	    return void end;
	 cur_se.mark_se(ae,false);
	 if ~void(cur_se) then cur_se.has_fatal_error:=true; end;
	 ar::=#AM_RETURN_STMT(as.source); 
	 ar.val:=ae; r.code:=ar; r.is_clean:=true; 
      else			-- Attribute writer.
	 r:=#AM_ROUT_DEF(2,as.source); 
	 r.srcsig:=e.srcsig;
	 sl:=#AM_LOCAL_EXPR(as.source, IDENT_BUILTIN::self_ident, 
			    e.tp, e.as_tp);
	 r[0] := #AM_FORMAL_ARG(sl);
	 if void(e.sig.args) then
	    err("Compiler error, TRANS::transform_attr_elt, "
		  "e.sig.args=void."); return void end;	 
	 l1:=#AM_LOCAL_EXPR(as.source,e.name,e.sig.args[0].tp);
	 r[1] := #AM_FORMAL_ARG(l1);
	 r.sig:=e.sig;
	 r.sig.srcsig:=e.srcsig;
	 if tp_con.same.kind=TP_KIND::val_tp then -- Value type.
	    av::=#AM_VATTR_ASSIGN_EXPR(as.source);
	    av.ob:=r[0].expr; av.at:=e.name; av.val:=r[1].expr;
	    av.real_tp:=tp_of(as.tp);
	    cur_se.mark_se(av,true);
	    if ~void(cur_se) then cur_se.has_fatal_error:=true; end;
	    ar::=#AM_RETURN_STMT(as.source);
	    ar.val:=av; r.code:=ar;
	 else			-- Reference type.
	    ae::=#AM_ATTR_EXPR(as.source); 
	    ae.as_type := e.as_tp;
	    ae.ob:=r[0].expr; ae.self_tp:=ae.ob.tp;
	    ae.at:=e.name; ae.tp_at:=tp_of(as.tp);
	    if void(ae.tp_at) then 
	       err_loc(as.tp); err("Cannot translate type.");
	       return void end;	 
	    cur_se.mark_se(ae,true);
	    if ~void(cur_se) then cur_se.has_fatal_error:=true; end;
	    ar::=#AM_ASSIGN_STMT(as.source); 
	    ar.dest:=ae; ar.src:=r[1].expr; r.code:=ar; 
	 end;
	 inv:AM_INVARIANT_STMT;
	 if ~e.is_private and ~in_invariant then
	    isig:SIG:=impl.invariant_sig;
	    if ~void(isig) then
	       inv:=#AM_INVARIANT_STMT(as.source); 
	       inv.sig:=isig;
	       icall::=#AM_ROUT_CALL_EXPR(1,as.source);
	       icall.fun:=isig;
	       cur_se.mark_context(icall);
	       r.calls:=r.calls.push(icall) end end;
	 if void(r.code) then r.code:=inv 
	 else r.code.append(inv) end;
	 r.is_clean:=false; end;
      return r; 
   end;
   
-----------      
   
   transform_rout_elt(e:ELT,as:AS_ROUT_DEF):AM_ROUT_DEF is
      -- Transform the element `e' into AM form. 
 
      if e.is_invariant then in_invariant:=true else
	 in_invariant:=false end;
      if as.is_abstract then 
	 if e.is_external or e.tp.is_partial then return void 
	    -- Don't do anything special for
	    -- abstract sigs in external and partial classes
	 else
	    err_loc(as); 
	    err("Compiler error, TRANS::tranform_rout_elt given "
		"abstract"); return void 
	 end 
      end; 
      check_return(as);
      r::=#AM_ROUT_DEF(1+e.sig.args.size,as.source); 
      r.srcsig:=e.srcsig; r.sig:=e.sig;
      r.sig.srcsig:=e.srcsig;
      if e.is_external then r.is_external:=true end;
      sl::=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::self_ident, e.tp, e.as_tp);
      r[0] := #AM_FORMAL_ARG(sl);
      if e.sig.has_ret then 
	 r.rres:=#AM_LOCAL_EXPR(as.source,IDENT_BUILTIN::ret_ident,e.ret); -- For return.
	 r.locals:=r.locals.push(r.rres);      
      end;
      i:INT:=0; na:AS_ARG_DEC:=as.args_dec;
      if na.size/=e.sig.args.size then
	 err_loc(as); 
	 err("Compiler error, TRANS::transform_rout_elt size bug.");
	 return void end;
      loop while!(i<e.sig.args.size);
	 l::=#AM_LOCAL_EXPR(as.source, na.name, e.sig.args[i].tp, na.tp);
	 r[i+1]:=#AM_FORMAL_ARG(l, MODE::create_from_as(na.mode));
	 i:=i+1; na:=na.next end; 
      cur_rout:=r;
      if prog.psather then transform_pSather_rout_elt_stuff(as) end;
      pres:AM_PRE_STMT;
      if chk_pre then
	 if ~void(as.pre_e) then
	    if prog.pre_checks and ~void(cur_se) then cur_se.has_fatal_error:=true; end;
	    in_pre:=true;
	    pres:=#AM_PRE_STMT(as.source);
	    pres.tp:=impl.tp;
	    pres.test:=transform_expr(as.pre_e,TP_BUILTIN::bool);
	    if void(pres.test) then pres:=void end;
	    in_pre:=false end;
      end;

      --posts:AM_POST_STMT;      
      post_stmt:=void;
      if chk_post then
	 if ~void(as.post_e) then
	    in_post:=true;
	    if prog.post_checks and ~void(cur_se) then cur_se.has_fatal_error:=true; end;
	    post_stmt:=#AM_POST_STMT(as.source);
	    post_stmt.tp:=impl.tp;
	    post_stmt.test:=transform_expr(as.post_e,TP_BUILTIN::bool);
	    if void(post_stmt.test) then post_stmt:=void end;	 
	    in_post:=false end;
      end;
      
      --inv:AM_INVARIANT_STMT;
      inv_stmt:=void;
      if chk_invariant then
	 if ~e.is_private and ~in_invariant then
	    isig:SIG:=impl.invariant_sig;
	    if ~void(isig) then
	       inv_stmt:=#AM_INVARIANT_STMT(as.source); 
	       inv_stmt.sig:=isig;
	       icall::=#AM_ROUT_CALL_EXPR(1,as.source);
	       icall.fun:=isig;
	       cur_se.mark_context(icall);
	       r.calls:=r.calls.push(icall) end end;
      end;
      
      code:$AM_STMT;
      -- if is_array_sig(e.srcsig) then
	 -- code:=transform_array_body(e);
      -- else 
	 code:=transform_stmt_list(as.body);
      -- end;
      r.code:=init_stmts;	-- First do the initial statments.
      if void(r.code) then 
	 r.code:=pres		-- Then the pre statement.
      else r.code.append(pres) end;
      if void(r.code) then 
	 r.code:=code		-- Then the body statement.
      else r.code.append(code) end; 
      
      if void(as.ret_dec) then
	 -- if there's no return value, emit the post and invariant
	 -- checks at the end; otherwise, they will be emitted with
	 -- before the return.
	 if void(r.code) then
	    r.code:=post_stmt		-- Then the post statement.      
	 else r.code.append(post_stmt) end;
	 if void(r.code) then
	    r.code:=inv_stmt		-- Then the invariant statement.      
	 else r.code.append(inv_stmt) end;
      end;
      return r;
   end;

-----------      

   private is_some_array_sig(s:SIG):BOOL is
      -- True if `s' is a function/iter in AVAL or AREF.
      if void(s) then return false end;
      stp::=s.tp;
      typecase stp
      when TP_CLASS then
	 if stp.name/=IDENT_BUILTIN::AREF_ident and
	    stp.name/=IDENT_BUILTIN::AVAL_ident then return false end;
	 if void(stp.params) then return false end;
	 if stp.params.size/=1 then return false end;
	 return true
      else return false; 
      end; 
   end;
   
   private is_array_sig(s:SIG):BOOL is
      -- True if `s' is `aset' or `aget' in AVAL or AREF.
      if void(s) then return false end;
      stp::=s.tp;
      typecase stp
      when TP_CLASS then
	 if stp.name/=IDENT_BUILTIN::AREF_ident and
	    stp.name/=IDENT_BUILTIN::AVAL_ident then return false end;
	 if void(stp.params) then return false end;
	 if stp.params.size/=1 then return false end;
	 if s.name/=IDENT_BUILTIN::aget_ident and
	    s.name/=IDENT_BUILTIN::aset_ident then return false end;
	 return true
      else return false; 
      end; 
   end;

   is_aget_sig(s:SIG):BOOL is
      -- True if `s' is`aget' 
      if void(s) then return false end;
      stp::=s.tp;
      typecase stp
      when TP_CLASS then
	 -- note that external array classes may have no parameters,
	 -- but internal ones must have a single parameter
	 -- This may need to be changed later when the multidimensional
	 -- array story for external classes is clear (and it is decided
	 -- whether external classes should be built in or not)
	 -- Another solution is to have, say, AREF{F_INTEGER} instead of
	 -- F_INTEGER_ARR - then external arrays will behave similar to intern.
	 if ~void(stp.params) then 
	    if stp.params.size/=1 then return false end;
	 end;
	 if s.name/=IDENT_BUILTIN::aget_ident then return false end;
	 return true;
      else 
	 return false; 
      end; 
   end;

-----------      

   transform_stmt(s:$AS_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if void(s) then return void end;
      r:$AM_STMT;
      typecase s
      when AS_DEC_STMT then r:= transform_dec_stmt(s)
      when AS_ASSIGN_STMT then r:= transform_assign_stmt(s)
      when AS_IF_STMT then r:= transform_if_stmt(s)
      when AS_LOOP_STMT then r:= transform_loop_stmt(s)
      when AS_RETURN_STMT then r:= transform_return_stmt(s)
      when AS_YIELD_STMT then r:= transform_yield_stmt(s)
      when AS_QUIT_STMT then r:= transform_quit_stmt(s)
      when AS_CASE_STMT then r:= transform_case_stmt(s)
      when AS_TYPECASE_STMT then r:= transform_typecase_stmt(s)
      when AS_ASSERT_STMT then r:= transform_assert_stmt(s)
      when AS_PROTECT_STMT then r:= transform_protect_stmt(s)
      when AS_RAISE_STMT then r:= transform_raise_stmt(s)
      when AS_EXPR_STMT then r:= transform_expr_stmt(s)
      else r := transform_pSather_stmt(s)
      end;
      return r;
    end;

-----------     
 
   transform_dec_stmt(s:AS_DEC_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      l:AM_LOCAL_EXPR:=local_with_name(s.name);
      err_loc(s);
      if ~void(l) then 
	 err("This local variable declaration is in the scope of " +
	       l.name.str + ":" + l.tp_at.str +
	     " which has the same name."); return void end;
      the_tp:$TP := tp_of(s.tp);
      if the_tp.is_partial and (s.tp.kind /= AS_TYPE_SPEC::same) and
	       ~prog.is_check_am 
	 -- this error is not reported during unreachable code stage
	 -- since whenever the code is complete SAME in partial classes
	 -- becomes a concrete class
      then
	 err("Partial classes cannot be instantiated.");
      end;
      
      check_params_for_partial(s.tp);
      
      l:=#AM_LOCAL_EXPR(s.source, s.name, the_tp, s.tp); 
      l.needs_init:=true; 
      add_local(l);
      return void; 
   end;

   check_params_for_partial(t:AS_TYPE_SPEC) is
      -- make sure type parameters are not instantiated with
      -- partial classes
      if ~void(t) then
	 param ::= t.params;
	 loop
	    while!(~void(param));
	    if tp_of(param).is_partial and (param.kind /= AS_TYPE_SPEC::same)
	    and ~prog.is_check_am then
	       err_loc(t);
	       err("Partial classes cannot be used as type parameters.");
	    end;
	    param := param.next;
	 end;
      end;
   end;
-----------
      
   transform_assign_stmt(s:AS_ASSIGN_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if void(s.lhs_expr) then 
	 r::=transform_assign_dec_stmt(s);
	 return r;
      end;
      lhs:$AS_EXPR:=s.lhs_expr; err_loc(lhs); 
      typecase lhs
      when AS_CALL_EXPR then 
	 if lhs.is_array then 
	    r::=transform_array_assign_stmt(lhs,s);
            return r;
	 else 
	    r::= transform_call_assign_stmt(lhs,s);
	    return r;
         end;
      when AS_SELF_EXPR then 
	 err("It is illegal to assign to `self'.");
      when AS_VOID_EXPR then 
	 err("It is illegal to assign to `void'.");
      when AS_IS_VOID_EXPR then 
	 err("It is illegal to assign to a `void' test expression.");
      when AS_ARRAY_EXPR then 
	 err("It is illegal to assign to an array expression.");
      when AS_CREATE_EXPR then
	 err("It is illegal to assign to a creation expression.");
      when AS_BOUND_CREATE_EXPR then 
	 err("It is illegal to assign to a bound create expression.");
      when AS_AND_EXPR then 
	 err("It is illegal to assign to an `and' expression.");
      when AS_OR_EXPR then 
	 err("It is illegal to assign to an `or' expression.");	 
      when AS_EXCEPT_EXPR then
	 err("It is illegal to assign to an `exception' expression.");
      when AS_NEW_EXPR then 
	 err("It is illegal to assign to a `new' expression.");
      when AS_INITIAL_EXPR then
	 err("It is illegal to assign to an `initial' expression.");
      when AS_BREAK_EXPR then 
	 err("It is illegal to assign to a `break!' expression.");	
      when AS_RESULT_EXPR then 
	 err("It is illegal to assign to a `result' expression.");	
      when AS_BOOL_LIT_EXPR then
	 err("It is illegal to assign to a boolean literal.");	
      when AS_CHAR_LIT_EXPR then
	 err("It is illegal to assign to a character literal.");	
      when AS_STR_LIT_EXPR then 
	 err("It is illegal to assign to a string literal.");	
      when AS_INT_LIT_EXPR then 
	 err("It is illegal to assign to an integer literal.");	
      when AS_FLT_LIT_EXPR then 
	 err("It is illegal to assign to a floating point literal.");
      when AS_CLUSTER_EXPR then 
	 err("It is illegal to assign to an `cluster' expression.");
      when AS_CLUSTER_SIZE_EXPR then 
	 err("It is illegal to assign to an `cluster_size' expression.");
      when AS_GLOBAL_EXPR then 
	 err("It is illegal to assign to a `global' expression.");	 
      else if prog.psather then transform_pSather_assign_stmt_err(s) end;
      end;
      return void; 
   end;

-----------      

   transform_assign_dec_stmt(s:AS_ASSIGN_STMT):$AM_STMT
      -- A list of AM_STMT's which implements the source statement `s'.
      -- This is an assignment which declares a local variable and
      -- assigns to it.
      pre void(s) or void(s.lhs_expr) is
      if void(s) then return void end;
      l:AM_LOCAL_EXPR:=local_with_name(s.name);
      err_loc(s);
      if ~void(l) then 
	 err("This local variable declaration is in the scope of " +
	       l.name.str + ":" + l.tp_at.str +
	       " which has the same name."); return void end;
      l:=#AM_LOCAL_EXPR(s.source,s.name,void); 
      if in_protect_body then l.is_volatile:=true end;
      r:AM_ASSIGN_STMT;
      if ~void(s.tp) then	-- Explicitly specified type ":FOO:="
	 l.tp_at:=tp_of(s.tp);
	 if l.tp_at.is_partial and (s.tp.kind /= AS_TYPE_SPEC::same) 
		 and ~prog.is_check_am
	 then
	 -- this error is not reported during unreachable code stage
	 -- since whenever the code is complete SAME in partial classes
	 -- becomes a concrete class	    
	    err("Partial classes cannot be instantiated.");
	 end;
	 
	 check_params_for_partial(s.tp);	 
	 
	 l.as_type := s.tp;
	 if void(l.tp_at) then 
	    err_loc(s);
	    err("Compiler error, TRANS::transform_assign_dec_stmt, "
		  "bad type."); 
	    return void end;
	 add_local(l);		-- Add it here since type is known.
	 r:=#AM_ASSIGN_STMT(s.source); r.dest:=l; 
	 r.src:=transform_expr(s.rhs,l.tp);
	 if void(r.src) then return void end;
	 return r 
      end;
      -- If you get here, then the declared type is inferred.
      rhs:$AS_EXPR:=s.rhs; err_loc(s.rhs);
      typecase rhs
      when AS_VOID_EXPR then 
	 err("The right hand side of `::=' may not be `void'.");
	 return void;
      when AS_CREATE_EXPR then 
	 if void(rhs.tp) then
	    err("Creation expressions on the right hand side "
		"of `::=' must explicitly specify a type."); return void end;
	 if tp_of(rhs.tp).is_partial and 
		  (rhs.tp.kind /= AS_TYPE_SPEC::same) and ~prog.is_check_am
	 then
	 -- this error is not reported during unreachable code stage
	 -- since whenever the code is complete SAME in partial classes
	 -- becomes a concrete class	    
	    err("Partial classes cannot be instantiated.");	 
	 end;
	 
      when AS_ARRAY_EXPR then
	 err("The right hand side of `::=' may not be an array "
	       "creation expression."); return void
      else end;
      r:=#AM_ASSIGN_STMT(s.source); r.dest:=l; 	 
      r.src:=transform_expr(s.rhs,void);
      if void(r.src) then 
	 l.tp_at:=TP_BUILTIN::dollar_ob; add_local(l); return void end;
      l.tp_at:=r.src.tp; 
      add_local(l); 
      if prog.psather then
	 rhsam ::= r.src;
	 typecase rhsam
	 when AM_LOCAL_EXPR then l.as_type := rhsam.as_type
	 when AM_ROUT_CALL_EXPR then l.as_type := rhsam.as_type
	 when AM_SHARED_EXPR then l.as_type := rhsam.as_type
	 when AM_ATTR_EXPR then l.as_type := rhsam.as_type
	 else 
	 end;
      end;
      return r;
   end; 
   
-----------      

   transform_array_assign_stmt(l:AS_CALL_EXPR,s:AS_ASSIGN_STMT):$AM_STMT
      -- A list of AM_STMT's which implements the source statement `s'.
      -- This is an assignment to the call expression `l' which has 
      -- `is_array' equal to true. So we know it is one of the forms:
      -- "[a,b,c]:=d" or "e[a,b,c]:=d" and should become "aset(a,b,c,d)"
      -- or "e.aset(a,b,c,d)".
      pre l.is_array=true is
      -- We change the call object by giving it the name "aset" adding
      -- on the righthand side as an extra argument, transform it and
      -- then change it back.
      r::=#AM_EXPR_STMT(l.source);
      l.name:=IDENT_BUILTIN::aset_ident; l.is_array:=false;      

      if void(l.args) then 
	 l.args:=s.rhs; 
	 -- Set the modes of newly create args
	 a ::= l.args;
	 loop while!(~void(a));
	     mode::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);
	     if void(l.modes) then
		 l.modes := mode;
	     else
		 l.modes.append(mode);
	     end;
	     a:=a.next;
	 end;
	 r.expr:=transform_call_expr(l,void,false);	 
	 l.args:=void; l.modes:=void;
      else 
	  lst::=l.args;
	  modes::=l.modes;

	  loop until!(void(lst.next)); 
	      lst:=lst.next;
	      modes:=modes.next;
	  end;

	  added_args::=s.rhs;
	  added_modes:AS_ARG_MODE;

	  --set modes for newly added args
	  loop while!(~void(added_args));
	      mode::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);
	      if void(added_modes) then
		  added_modes:=mode;
	      else
		  added_modes.append(mode);
	      end;
	      added_args:=added_args.next;
	  end;

	  lst.next:=s.rhs;
	  modes.next:=added_modes;

	  r.expr:=transform_call_expr(l,void,false);	 
	  lst.next:=void;
      end;
      l.name:=void; l.is_array:=true;
      if ~void(r.expr) then return r else return void end;  -- Ivin. 
   end;
   
-----------      

   transform_call_assign_stmt(l:AS_CALL_EXPR,s:AS_ASSIGN_STMT):$AM_STMT 
      -- A list of AM_STMT's which implements the source statement `s'.
      -- This is an assignment to the call expression `l' which has
      -- `is_array' equal to false.
      pre l.is_array=false is      
      if ~void(l.args) then	-- One of the forms: 
	 -- "a(5):=foo", "x.a(5):=foo", or "A::a(5):=foo"
	 err_loc(l);
	 err("It is illegal to assign to a call with arguments."); 
	 return void end;
      if void(l.ob) and void(l.tp) then
	 -- "a:=foo", This is the case that might be a local variable. 
	 loc:AM_LOCAL_EXPR:=local_with_name(l.name);
	 if ~void(loc) then r::=transform_local_assign_stmt(loc,s);
	    return r;
	 end end;
      -- At this point we are either of the form "a:=foo" and not a 
      -- local, "x.a:=foo" or "A::x:=foo".
      -- We change the call object by adding on the righthand side as an 
      -- argument, transform it and then put it back to void:
	l.args:=s.rhs;
	-- It is important to set modes of newly created args
	a ::= l.args;
	loop while!(~void(a));
	    mode::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);
	    if void(l.modes) then
		l.modes := mode;
	    else
		l.modes.append(mode);
	    end;
	    a:=a.next;
	end;
      r::=#AM_EXPR_STMT(l.source);
      r.expr:=transform_call_expr(l,void,false);
      l.args:=void; 
      if ~void(r.expr) then return r else return void end;  -- Ivin.
   end;
      
-----------      

   transform_local_assign_stmt(loc:AM_LOCAL_EXPR, s:AS_ASSIGN_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source assignment
      -- `s'. At this point we know it is an assignment to the local
      -- variable `loc'.
      if loc.no_assign then
	 err_loc(s); 
	 err("It is illegal to assign to the typecase variable.");
	 return void; 
      end;
      r::=#AM_ASSIGN_STMT(s.source);
      -- Does the assignment to the local. 
      r.dest:=loc;		-- Make the local be the destination.
      if in_protect_body then loc.is_volatile:=true end;
      r.src:=transform_expr(s.rhs,loc.tp);
      if void(r.src) then return void end; -- Type error.
      if prog.psather then transform_pSather_local_assign(loc,s) end;
      return r;
   end;
   
-----------      

   transform_loop_stmt(s:AS_LOOP_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      ol:AM_LOOP_STMT:=cur_loop; -- Save the old loop object, if any.
      r::=#AM_LOOP_STMT(s.source); 
      cur_loop:=r;		-- Any enclosed iters will add themselves.
      old_in_protect_but_not_loop:BOOL:=in_protect_but_not_loop;
      in_protect_but_not_loop:=false;
      r.body:=transform_stmt_list(s.body);
      in_protect_but_not_loop:=old_in_protect_but_not_loop;
      if ~void(ol) and ~void(r) then
	 ol.has_yield:=ol.has_yield or r.has_yield; -- Prop "has_yield".
      end;
      cur_loop:=ol;		-- Restore the old loop object, if any.

      if prog.prolix and ~prog.loops_seen.test(s.source) then
       -- Number of iters, not including break!, while! or until!.
       num::=r.its.size;
       -- Number with hot arguments
       hots::=0;
       loop
          sig::=r.its.elt!.fun;
          if ~void(sig.hot) then
             loop
                if sig.hot.elt! then
                   hots:=hots+1;
                   break!;
                end
             end
          end
       end;
      
       -- Make sure there's a place for the statistics
       if void(prog.itercounts) then prog.itercounts:=#(10) end;
       if void(prog.hotcounts) then prog.hotcounts:=#(10) end;
      
       -- Update the histograms
       prog.itercounts[num]:=prog.itercounts[num]+1;
       prog.hotcounts[hots]:=prog.hotcounts[hots]+1;
      
       -- Make sure never update stats for this one again
       prog.loops_seen:=prog.loops_seen.insert(s.source);
      end;
      if ~void(cur_se) then cur_se.weight:=(cur_se.weight+10).min(1000000); end;
      

      return r;
   end;

-----------      

   transform_return_stmt(s:AS_RETURN_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if is_iter then return_in_iter_err(s); return void end;
      
      --pSather
      if is_in_par_or_fork then return_in_par_fork_err(s); return void; end;
      
      if ~void(s.next) then stmts_after_return_err(s) end;
      rtp:$TP:=cur_rout.sig.ret; -- The return type if any.      
      res:$AM_STMT;
      if void(s.val) then	-- No return value specified.
	 if ~void(rtp) then 
	    missing_return_value_err(s,rtp); return void end;
	 res:=#AM_RETURN_STMT(s.source);
      else			-- with return value.
	 a::=#AM_ASSIGN_STMT(s.source);
	 a.dest:=cur_rout.rres;
	 if void(rtp) then 
	    extra_return_value_err(s, cur_rout.sig); return void end;
	 r::=#AM_RETURN_STMT(s.source); 	 
	 a.next:=r;
	 r.val:=cur_rout.rres;
	 a.src:=transform_expr(s.val,rtp);
	 if void(a.src) then return void end; -- wrong type.
	 res:=a;
      end;
      if ~void(inv_stmt) then
	 stmt::=inv_stmt.copy;
	 stmt.next:=res.next;
	 res.next:=stmt;
      end;
      if ~void(post_stmt) then
	 stmt::=post_stmt.copy;
	 stmt.next:=res.next;
	 res.next:=stmt;
      end;
      return res;
   end;

   return_in_iter_err(s:AS_RETURN_STMT) is
      err_loc(s);
      err("`return' statements may not appear in iters."); 
   end;
   
   stmts_after_return_err(s:AS_RETURN_STMT) is
      err_loc(s);
      err("No statements may follow `return' in a statment list.");
   end;
      
   missing_return_value_err(s:AS_RETURN_STMT, tp:$TP) is
      err_loc(s);
      err("A return value of type: " + tp.str +
	    " must be specified."); 
   end;      

   extra_return_value_err(s:AS_RETURN_STMT, sig:SIG) is
      err_loc(s);
      err("No return value should be provided for the signature: " + 
	    sig.str + "."); 
   end;
   
   return_in_par_fork_err(s:AS_RETURN_STMT) is
      err_loc(s);
      err("`return' statements may not appear in `par', `parloop', or `fork'.") 
   end;
   
-----------
      
   transform_yield_stmt(s:AS_YIELD_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if ~is_iter then yield_in_rout_err(s); return void end;
      
      if in_protect_body then yield_in_protect_err(s); return void end;
      if in_protect_then then yield_in_protect_err(s); return void end;

      --pSather      
      if is_in_par_or_fork then yield_in_par_fork_err(s); return void end;
      if is_in_lock and ~void(cur_se) then cur_se.has_yield_in_lock:=true; end;
      
      rtp:$TP:=cur_rout.sig.ret; -- The return type if any.      
      if void(s.val) then	-- No return value specified.
	 if ~void(rtp) then 
	    missing_yield_value_err(s,rtp); return void end;
	 y::=#AM_YIELD_STMT(s.source); 
	 cur_yield_ind:=cur_yield_ind+1; y.ret:=cur_yield_ind; 
	 cur_rout.num_yields:=cur_rout.num_yields+1;
	 if ~void(cur_loop) then cur_loop.has_yield:=true end;
	 return y
      else			-- with return value.
	 if void(rtp) then 
	    extra_yield_value_err(s, cur_rout.sig); return void end;
	 r::=#AM_YIELD_STMT(s.source);
	 r.val:=transform_expr(s.val,rtp);
	 if void(r.val) then return void end; -- wrong type.	 
	 cur_yield_ind:=cur_yield_ind+1; r.ret:=cur_yield_ind; 
	 cur_rout.num_yields:=cur_rout.num_yields+1;	 
	 if ~void(cur_loop) then cur_loop.has_yield:=true end;	 
	 return r;
      end; 
   end;
   
   yield_in_rout_err(s:AS_YIELD_STMT) is
      err_loc(s);
      err("`yield' statements may not appear in routines."); 
   end;
   
   yield_in_par_fork_err(s:AS_YIELD_STMT) is
      err_loc(s);
      err("`yield' statements may not appear in `par', `parloop', or `fork'."); 
   end;
   
   yield_in_protect_err(s:AS_YIELD_STMT) is
      err_loc(s);
      err("`yield' statements may not appear in `protect'."); 
   end;
   
   missing_yield_value_err(s:AS_YIELD_STMT, tp:$TP) is
      err_loc(s);
      err("A yield value of type: " + tp.str + " must be specified."); 
   end;      
   
   extra_yield_value_err(s:AS_YIELD_STMT, sig:SIG) is
      err_loc(s);
      err("No yield value should be provided for the signature: "+sig.str+"."); 
   end;
   
-----------
   
   transform_quit_stmt(s:AS_QUIT_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      
      --pSather
      if is_in_par_or_fork then quit_in_par_fork_err(s); return void; end;
      
      if ~is_iter then quit_in_rout_err(s); return void end;
      if ~void(s.next) then stmts_after_quit_err(s) end;
      r::=#AM_RETURN_STMT(s.source);
      return r;
   end;
   
   quit_in_par_fork_err(s:AS_QUIT_STMT) is
      err_loc(s);
      err("`quit' statements may not appear in `par', `parloop', or `fork'.") 
   end;

   quit_in_rout_err(s:AS_QUIT_STMT) is
      err_loc(s);
      err("`quit' statements may not appear in routines."); 
   end;
   
   stmts_after_quit_err(s:AS_QUIT_STMT) is
      err_loc(s);
      err("No statements may follow `quit' in a statment list."); 
   end;

-----------
      
   private const_to_switch(e:$AM_EXPR):$AM_CONST is
      -- returns a constant expression that can be used in a
      -- when clause of an AM_CASE_STMT, or void if it cannot
      -- be used.
      if void(e) then return void; end;
      typecase e
      when AM_CHAR_CONST then return e;
      when AM_INT_CONST then return e;
      when AM_SHARED_EXPR then return const_to_switch(e.init);
      else return void;
      end;
   end;
      
   transform_case_when(s:AS_CASE_STMT, cw:AS_CASE_WHEN,
      l:AM_LOCAL_EXPR):$AM_STMT is
      -- A list of AM_STMT's which implements the list of "when" clauses
      -- and else clause in `s' starting at `cw'. `l' is the local variable
      -- with the value to test against. This will generate 
      -- AM_CASE_STMT's for constants and AM_IF_STMT's otherwise.
      if void(cw) then		-- Just do the else clause.
	 if s.no_else then
	    r::=#AM_CASE_STMT(s.source);
	    r.test:=l; r.no_else:=true; 
            return r;
	 else
	    r::= transform_stmt_list(s.else_part);
            return r;
	 end; 
      end;	    
      err_loc(cw);		-- In case of error.
      ct:$CALL_TP:=call_tp_of_expr(cw.val); -- Call type of test expr.
      v:$AM_EXPR;		-- The value of test expr.
      if void(ct) then v:=transform_expr(cw.val,void); 
	 if void(v) then return void end; -- Error!
	 cv:$AM_CONST:=const_to_switch(v);
	 if ~void(cv) then
	    r::=#AM_CASE_STMT(cw.source);
	    r.test:=l;
	    last_then:$AS_STMT:=cw.then_part.stmts;
	    ls:FLIST{$AM_CONST}; ls:=ls.push(cv);
	    r.tgts:=r.tgts.push(ls);
	    r.stmts:=r.stmts.push(transform_stmt_list(cw.then_part));
	    loop cw:=cw.next;
	       if void(cw) then 
		  if s.no_else then r.no_else:=true 
		  else r.else_stmts:=transform_stmt_list(s.else_part) end;
		  return r end;
	       if ~void(call_tp_of_expr(cw.val)) then -- Do an if in else.
		  r.else_stmts:=transform_case_when(s,cw,l); 
		  return r end;
	       v:=transform_expr(cw.val,void);
	       if void(v) then return void end; -- Error!	    
	       cv:=const_to_switch(v);
	       if ~void(cv) then
		  if SYS::ob_eq(last_then,cw.then_part) then 
		     -- add to same stmt
		     ls:=r.tgts.pop; ls:=ls.push(cv); 
		     r.tgts:=r.tgts.push(ls);
		  else		-- Start a new "when" list
		     ls:=void; ls:=ls.push(cv); r.tgts:=r.tgts.push(ls);
		     r.stmts:=r.stmts.push(transform_stmt_list(cw.then_part));
		  end;
	       else		-- Do an if and put it in else.
		  r.else_stmts:=transform_case_when(s,cw,l); 
		  return r
	       end; -- if
	    end; -- loop
	 end; -- if
      end; -- if
      -- At this point we need to generate an `if'. One of `ct' and
      -- `v' is void, the other non-void.
      cs::=#CALL_SIG;
      cs.tp:=l.tp_at; cs.name:=IDENT_BUILTIN::is_eq_ident;
      cs.has_ret:=true; 
      cs.args:=#ARRAY{CALL_ARG}(1); 
      if ~void(ct) then cs.args[0]:=#(ct) else cs.args[0]:=#(v.tp) end;
      sig:SIG:=cs.lookup(tp_con.same=cs.tp); -- Arg true if in this class.
      if void(sig) then return void end; -- Error!
      if sig.ret/=TP_BUILTIN::bool then
	 err("The `is_eq' routine corresponding to a `case' branch "
	       "must return a boolean."); return void end;
      if void(v) then v:=transform_expr(cw.val,sig.args[0].tp) end;
      if void(v) then return void end; -- Error!
      -- Create the call on the routine `is_eq'.
      arc::=#AM_ROUT_CALL_EXPR(2,cw.source);
      arc.fun:=sig; arc[0]:=#(l); arc[1]:=#(v);
      r::=#AM_IF_STMT(cw.source);      
      cur_se.mark_context(arc);
      r.test:=special_inline(arc); 
      r.if_true:=transform_stmt_list(cw.then_part);
      r.if_false:=transform_case_when(s,cw.next,l); 
      return r;
   end;
   
-----------      

    transform_typecase_stmt(s: AS_TYPECASE_STMT): $AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.

      l ::= local_with_name(s.name); 
      if void(l) then typecase_local_err(s); return void end;
      if cur_rout.local_is_hot(l) then 
	 typecase_hot_local_err(s);
	 return void
      end;

      old_no_assign ::= l.no_assign; -- Old value (if currently in typecase).
      l.no_assign:=true;	-- Freeze it for the current typecase.
      ltp:$TP:=l.tp;		-- The declared type of the local.
      las_type:AS_TYPE_SPEC:=l.as_type; -- The declared tye of the local.

      r ::= #AM_TYPECASE_STMT(s.source); -- the likely result
      r.test:=l;
      r.no_else := true;
      r.has_void_stmts := false;
      
      wp ::= s.when_part;

      if ~void(cur_se) then cur_se.has_fatal_error:=true; end;
      
      loop while!(~void(wp));
	 tp:$TP:=tp_of(wp.tp); -- Type to compare against.	 
	 if ltp.is_subtype(tp) then -- this will definitely match
	    r.no_else := false;
	    r.else_stmts := transform_stmt_list(wp.then_part);

	    r.has_void_stmts := true;
	    -- at this point, else_stmts contain void statements to
	    -- be called even if the object is void (no tag)
	    
	    -- possibly issue a warning about never-reached when-parts

	    break!
	 elsif ltp.is_abstract then -- local is abstract, this requires a typetest
	    l.tp_at:=tp;
	    l.as_type := wp.tp;  

	    r.tgts:=r.tgts.push(tp);
	    r.stmts:=r.stmts.push(transform_stmt_list(wp.then_part));

	    l.tp_at:=ltp;	-- Change the declared type back.
	    l.as_type := las_type; -- Change the declared type back.
	 else
	    -- typecase that can never ever match -> warning ?
	 end; 
	 
	 wp:=wp.next
      end;
      l.no_assign := old_no_assign;

      if r.no_else and ~s.no_else then -- no matching branch found
	 r.no_else := false;
	 r.else_stmts := transform_stmt_list(s.else_part);

	 r.has_void_stmts := true;
	 -- else_stmts at this point also contain statements to
	 -- be executed for void (i.e. untagged) argument
      end;

      if void(r.stmts) then	-- no typetest to be made
	 if r.no_else then	-- no match at all
	    typecase_no_branch_err(s);
	    return r;		-- return void ?
	 else
	    return r.else_stmts
	 end;
      end;
      
      return r;
   end;

   typecase_local_err(s:AS_TYPECASE_STMT) is
      err_loc(s);
      err("The name `" + s.name.str + "' isn't a local variable."); 
   end;

   typecase_hot_local_err(s:AS_TYPECASE_STMT) is
      err_loc(s);
      err("The typecase test local `" + s.name.str +
	 "' must not be a `!' argument to an iter."); 
   end;
      
   typecase_no_branch_err(s:AS_TYPECASE_STMT) is
      err_loc(s);
      err("There are no matching branches in this typecase."); 
   end;
      
-----------
         
   transform_assert_stmt(s:AS_ASSERT_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if ~chk_assert then return void; end;
      r::=#AM_ASSERT_STMT(s.source);
      r.test:=transform_expr(s.test, TP_BUILTIN::bool);
      if void(r.test) then return void end; -- Not a boolean.
      if prog.assert_checks and ~void(cur_se) then cur_se.has_fatal_error:=true; end;
      return r;
   end;

-----------
         
   transform_protect_stmt(s:AS_PROTECT_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      -- Since registers are restored after a longjump, we have to make
      -- sure that no local variables which could have been changed in
      -- the protect and are used later are held in registers. We are
      -- a bit conservative here and make any locals which are assigned
      -- to in the protect body be volatile.
      r::=#AM_PROTECT_STMT(s.source);
      old_in_protect_body:BOOL:=in_protect_body; 
      in_protect_body:=true;
      old_in_protect_but_not_loop:BOOL:=in_protect_but_not_loop;
      in_protect_but_not_loop:=true;
      r.body:=transform_stmt_list(s.body);
      in_protect_body:=old_in_protect_body;
      wp:AS_PROTECT_WHEN:=s.when_part;
      loop while!(~void(wp));
	 tp:$TP:=tp_of(wp.tp);	-- Type to compare against.
	 oex_tp:$TP:=ex_tp; ex_tp:=tp;	
	 old_in_protect_then:BOOL:=in_protect_then; in_protect_then:=true;
	 r.tgts:=r.tgts.push(tp);
--	 if prog.psather then transform_pSather_protect_when_stuff(tp,wp,s) end;
	 r.stmts:=r.stmts.push(transform_stmt_list(wp.then_part));
	 in_protect_then:=old_in_protect_then;
	 ex_tp:=oex_tp;		-- Change exception type back.
	 wp:=wp.next end;
      if s.no_else then		-- Raise the same exception.
	 r.no_else:=true;
      else			-- Do the else statements.
	 oex_tp:$TP:=ex_tp; ex_tp:=TP_BUILTIN::dollar_ob;
	 old_in_protect_then:BOOL:=in_protect_then; in_protect_then:=true;
--	 if prog.psather then transform_pSather_protect_else_stuff(s) end;
	 r.else_stmts:=transform_stmt_list(s.else_part);
	 in_protect_then:=old_in_protect_then;
	 ex_tp:=oex_tp; end;
      in_protect_but_not_loop:=old_in_protect_but_not_loop;
      return r;
   end;

-----------
         
   transform_raise_stmt(s:AS_RAISE_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if ~void(s.next) then stmts_after_raise_err(s) end;
      
      --pSather
      if is_in_par_or_fork and ~in_protect_body then
	 unprotected_raise_in_par_fork_warning(s);
      end;
      
      r::=#AM_RAISE_STMT(s.source);
      if ~void(cur_se) then
	 	cur_se.has_raise:=true;
      end;
      r.val:=transform_expr(s.val,void);
      if void(r.val) then return void end; 
      return r;
   end;
   
   stmts_after_raise_err(s:AS_RAISE_STMT) is
      err_loc(s);
      err("No statements may follow `raise' in a statment list."); 
   end;

   unprotected_raise_in_par_fork_warning(s:AS_RAISE_STMT) is
      err_loc(s);
      warning("Inside of `par', `parloop', or `fork' this `raise' "+
      "should be inside of a `protect'."); 
   end;

-----------
         
   transform_expr_stmt(s:AS_EXPR_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      e:$AS_EXPR:=s.e;			-- The expression.
      typecase e
      when AS_BREAK_EXPR then 
	 if void(cur_loop) then break_not_in_loop_err(s); return void end;
	 r::= #AM_BREAK_STMT(s.source);
         return r;
      when AS_CALL_EXPR then 
	 r::=#AM_EXPR_STMT(s.source); 
	 r.expr:=transform_call_expr(e,void,false);
         if ~void(s.at) then 
	    if prog.zones then
	       r.at:=transform_expr(s.at, TP_BUILTIN::zone); 
	    else
	       r.at:=transform_expr(s.at, TP_BUILTIN::int); 
	    end;
	 end;
	 if ~void(r.expr) then return r else return void end;  -- Ivin.
      when AS_AT_EXPR then
         r::=#AM_AT_EXPR(e.source);
	 ce::=e.e;
	 typecase ce
         when AS_CALL_EXPR then r.e := transform_call_expr(ce,void,false);
         else
            err_loc(s);
	    err("Lhs of '@' in an expr statement must be a call");
	 end;
         if void(r.e) then return void end;  -- Type Error.
	 if prog.zones then
	    r.at := transform_expr(e.at, TP_BUILTIN::zone);
	 else
	    r.at := transform_expr(e.at, TP_BUILTIN::int);
	 end;
         if void(r.at) then return void end; -- Type Error
	 r2::=#AM_EXPR_STMT(s.source); 
	 r2.expr:=r;
 	 return r2;
      else 
	 expr_stmt_err(s); 
	 return void; 
      end; 
   end;

   break_not_in_loop_err(s:AS_EXPR_STMT) is
      err_loc(s);
      err("`break!', `while!' and `until!' calls must appear "
	    "inside loops."); 
   end;

   expr_stmt_err(s:AS_EXPR_STMT) is
      err_loc(s);
      err("Expressions used as statements may not have return "
	    "values."); 
   end;

-----------         

   call_tp_of_expr(e:$AS_EXPR):$CALL_TP is
      -- Returns the call type of an expression, if it is one of the
      -- special cases. Otherwise it returns void. (To get the
      -- actual type, you have to do `transform_expr'.
      if void(e) then 
	 #OUT + "Compiler error, TRANS::call_tp_of_expr(void).";
	 return void end;
      typecase e
      when AS_VOID_EXPR then return #CALL_TP_VOID
      when AS_CREATE_EXPR then 
	 if void(e.tp) then return #CALL_TP_CREATE 
	 else return void end
      when AS_BOUND_CREATE_EXPR then 
	 -- what do we do if partial specification is allowed? (Boris)
	 return #CALL_TP_BOUND_CREATE; 
      when AS_ARRAY_EXPR then return #CALL_TP_ARRAY
      when AS_UNDERSCORE_ARG then 
	 tua::=#CALL_TP_UNDERSCORE; 
	 -- typed "underscore" case
	 if ~void(e.tp) then tua.tp:=tp_of(e.tp) end; 
	 return tua
      else 
	 return void; 
      end; 
   end;
	 
-----------         

   transform_expr(e:$AS_EXPR, tp:$TP):$AM_EXPR is
      -- Return an expression which evaluates `e'. If `tp' is not void
      -- then use it as the inferred type. Print an error message if
      -- if is not a supertype of the expression type. In this case 
      -- return void. If `tp' is void then the expression must determine
      -- its own type.
      if void(e) then return void end;
      r:$AM_EXPR;
      typecase e
      when AS_SELF_EXPR then r:= transform_self_expr(e,tp)
      when AS_CALL_EXPR then r:= transform_call_expr(e,tp,true)
	 -- This is special since we need to know whether a return
	 -- value is used to resolve overloading. The only way the 
	 -- return value won't be used is in an expression statement.
	 -- If we get to it from here, the value must be used.
      when AS_VOID_EXPR then r:= transform_void_expr(e,tp)
      when AS_IS_VOID_EXPR then r:= transform_is_void_expr(e,tp)	 
      when AS_ARRAY_EXPR then r:= transform_array_expr(e,tp)
      when AS_CREATE_EXPR then r:= transform_create_expr(e,tp)
      when AS_BOUND_CREATE_EXPR then r:= transform_bound_create_expr(e,tp)
      when AS_AND_EXPR then r:= transform_and_expr(e,tp)
      when AS_OR_EXPR then r:= transform_or_expr(e,tp)
      when AS_EXCEPT_EXPR then r:= transform_except_expr(e,tp)
      when AS_NEW_EXPR then r:= transform_new_expr(e,tp)
      when AS_INITIAL_EXPR then r:= transform_initial_expr(e,tp)
      when AS_BREAK_EXPR then r:= transform_break_expr(e,tp)
      when AS_RESULT_EXPR then r:= transform_result_expr(e,tp)
      when AS_BOOL_LIT_EXPR then r:= transform_bool_lit_expr(e,tp)
      when AS_CHAR_LIT_EXPR then r:= transform_char_lit_expr(e,tp)
      when AS_STR_LIT_EXPR then r:= transform_str_lit_expr(e,tp)
      when AS_INT_LIT_EXPR then r:= transform_int_lit_expr(e,tp)
      when AS_FLT_LIT_EXPR then r:= transform_flt_lit_expr(e,tp) 
      when AS_CLUSTER_EXPR then r:= transform_cluster_expr(e,tp)
      when AS_CLUSTER_SIZE_EXPR then r:= transform_cluster_size_expr(e,tp) 
      when AS_GLOBAL_EXPR then r:= transform_global_expr(e,tp)
      when AS_AT_EXPR then r:= transform_at_expr(e,tp)
      when AS_HERE_EXPR then r:= transform_here_expr(e,tp)
      when AS_WHERE_EXPR then r:= transform_where_expr(e,tp)
      when AS_ANY_EXPR then r:= transform_any_expr(e,tp)
      when AS_COHORT_EXPR then r:= transform_cohort_expr(e,tp)
      when AS_NEAR_EXPR then r:= transform_near_expr(e,tp)
      when AS_FAR_EXPR then r:= transform_far_expr(e,tp)
      end;
      return r;
    end;

-----------         

   transform_self_expr(e:AS_SELF_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if in_constant then self_const_err(e); return void end;
      sl:AM_LOCAL_EXPR:=cur_rout.self_local;
      if ~void(tp) then
	 if ~sl.tp.is_subtype(tp) then
	    self_context_err(e,sl.tp,tp); return void end end;
      return sl;
   end;
   
   self_const_err(e:AS_SELF_EXPR) is
      err_loc(e);
      err("`self' may not appear in a shared or constant "
	    "initialization expression."); 
   end;
   
   self_context_err(e:AS_SELF_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of self: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 
   
   transform_global_expr(e:AS_GLOBAL_EXPR, tp:$TP):$AM_EXPR
      pre prog.zones
   is
      if ~void(tp) then
	 if ~TP_BUILTIN::zone.is_subtype(tp) then
            global_context_err(e,tp);
            return void;
         end;
      end;
      return #AM_GLOBAL_EXPR(e.source);
   end;

   global_context_err(e:AS_GLOBAL_EXPR, tp:$TP)
      pre prog.zones
   is
      err_loc(e);
      err("'global' (ZONE) is not a subtype of " + tp.str + ".");
   end;

-----------         

   transform_call_expr(e:AS_CALL_EXPR, tp:$TP, has_ret:BOOL):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'. `has_ret' says
      -- whether the return value is used. 
      if void(cur_rout) and ~in_constant then
	 #OUT + "Compiler error, TRANS::transform_call_expr, "
	       "cur_rout=void."; return void end;
      if void(e) then return void end;
      r:$AM_EXPR; err_loc(e);

      stp:$TP;
      if ~void(e.tp) then
	 stp := tp_of(e.tp);
	 if void(e.ob) and stp.is_partial then
	    err("No calls into partial classes allowed.");
	 end;
      end;
      r:=call_expr_check_local(e,tp); 
      if ~void(r) then 
        return r 
      end;
      stup:TUP{$AM_EXPR,$TP}:=call_self(e); 
      if void(stup) then return void end; -- Fail
      self_val:$AM_EXPR:=stup.t1; self_tp:$TP:=stup.t2;
      if void(self_tp) then return void end; -- Failure.
      in_class:BOOL; if self_tp=tp_con.same then in_class:=true end;
      call_sig::=#CALL_SIG; call_sig.has_ret:=has_ret;
      call_sig.name:=call_expr_rout_name(e); call_sig.tp:=self_tp;
      args:ARRAY{AM_CALL_ARG}; nargs:INT:=e.args_size;
      if ~void(e.args) then args:=#ARRAY{AM_CALL_ARG}(nargs);
	 call_sig.args:=#ARRAY{CALL_ARG}(nargs) end; 
      sig:SIG:=call_expr_get_sig(e,call_sig,args,in_class);
      if prog.psather then sys_closure_self(sig) end;
      if void(sig) then return void end;
      cr:$AM_CALL_EXPR;
      er:AM_EXT_CALL_EXPR; ir:AM_ITER_CALL_EXPR; rr:AM_ROUT_CALL_EXPR;
      brr:AM_BND_ROUT_CALL_EXPR; 
      bir:AM_BND_ITER_CALL_EXPR;  --AJ- 
      call_check_out_args(e);
      typecase self_tp
      when TP_CLASS then
	 external_call:BOOL;
	 external_call := self_tp.is_external and 
	       ((self_tp.kind/=TP_KIND::ext_fortran_tp) or 
		(self_tp.kind=TP_KIND::ext_fortran_tp and 
		 sig.is_ext_fortran_sig) or 
		(self_tp.kind=TP_KIND::ext_c_tp and sig.is_ext_c_sig));
	 -- we are not quite finished here. Attributes and ashareds are 
	 -- allowed in the 1.1 external C classes and AM_ATTR_EXPR or 
	 -- AM_SHARED_EXPR should be generated instead of AM_EXT_CALL_EXPR
	 -- We need to check if the call is an attribute reference or not
	 if self_tp.kind=TP_KIND::ext_c_tp and sig.is_ext_c_sig then
	    if sig.is_reader_sig or sig.is_attr_writer_sig then
	       -- could be an attribute reader or writer. Need to
	       -- check if the attribute exists in
	       -- the class this is called on
	       elt ::= self_tp.impl.elts.elt_with_sig(sig);
	       if ~void(elt) then
		  if elt.is_attr_reader or elt.is_attr_writer or
			   elt.is_shared_reader or elt.is_shared_writer
		  then
		     external_call := false;
		  end;
	       end;
	    end;
	 end;

	 if external_call then
	    if in_constant then ext_call_const_err(e); return void end;
	    im:IMPL:=self_tp.impl;
	    if void(im) then
	       #OUT + "Compiler err, TRANS::transform_call_expr, "
		     "im=void."; return void end;
	    el:ELT:=im.elt_with_sig(sig);
	    if void(el) then
	       #OUT + "Compiler err, TRANS::transform_call_expr, "
		     "el=void.";
	       return void end;	    
	    er:=#AM_EXT_CALL_EXPR(nargs+1,e.source,name_for_ext(el)); 
	    er[0]:=#(self_val); er.fun:=sig;
	    if ~void(args) then
	       i:INT:=0; 
	       loop while!(i<nargs); er[i+1]:=args[i]; i:=i+1 end;
	    end;
	    cr:=er;
	 elsif e.name.is_iter then 
	    if in_protect_but_not_loop then 
	       iter_in_protect_err(e); return void;
	    end;
	    ir:=#AM_ITER_CALL_EXPR(nargs+1,e.source); 
	    ir[0]:=#(self_val); ir.fun:=sig;
	    if ~void(args) then
	       i:INT:=0; 
	       loop while!(i<nargs); ir[i+1]:=args[i]; i:=i+1 end;
	    end;
	    cr:=call_fix_iter(ir);
	 else rr:=#AM_ROUT_CALL_EXPR(nargs+1,e.source); 
	    rr[0]:=#(self_val); rr.fun:=sig;
	    if ~void(args) then
	       i:INT:=0; 
	       loop while!(i<nargs); rr[i+1]:=args[i]; i:=i+1 end;
	       -- If it came from a ">" or "<=" sugar, need to flip
	       -- self and the first argument evaluations.  DPS
	       if e.flip then t::=rr[0]; rr[0]:=rr[1]; rr[1]:=t; end;
	    end;
	    cr:=rr; 
	    if prog.psather and in_class then
	       -- Find AS-form of return type. Type is needed for attributes.
	       im:IMPL:=self_tp.impl;
	       if void(im) then
		  #OUT + "Compiler err, TRANS::transform_call_expr, "
			"im=void."; return void end;
	       el:ELT:=im.elt_with_sig(sig);
	       if void(el) then
		  #OUT + "Compiler err, TRANS::transform_call_expr, "
			"el=void.";
		  return void end;
	       -- #OUT+"Call of elt:"+el.sig.str+"\n";
	       -- #OUT+"Type: "; AS_OUT::AS_TYPE_SPEC_out(el.as_tp); #OUT+"\n";
	       rr.as_type := el.as_tp;
	    end;
	 end;
      when TP_ROUT then
	 if in_constant then bnd_rout_call_const_err; return void end;
	 brr:=#AM_BND_ROUT_CALL_EXPR(nargs,e.source); 
	 brr.br:=self_val; 
	 brr.br_tp:=self_tp;  -- Have to do this in case it's in a typecase
	 if ~void(args) then
	    loop
	       i::=args.ind!;
	       brr[i]:=args[i];
	    end;
	 end;
	 cr:=brr;
      when TP_ITER then
	 if in_protect_but_not_loop then
	    iter_in_protect_err(e); return void;
	 end;
	 bir:=#AM_BND_ITER_CALL_EXPR(nargs,e.source); 
	 bir.bi:=self_val;
	 bir.bi_tp:=self_tp;  -- Have to do this in case it's in a typecase
	 if ~void(args) then
	    i:INT:=0; 
	    loop while!(i<nargs); 
	       bir[i]:=args[i]; i:=i+1;
	    end;
	 end;
	 cr:=call_fix_bnd_iter(bir,sig) -- move once args
      end;
      
      if void(cr) then return void end;
      if ~void(tp) and ~void(cr.tp) then
	 if ~cr.tp.is_subtype(tp) then
	    call_context_err(e,cr.tp,tp);
	    return void 
	 end 
      end;
      
      -- may need to do some fixups for attributes and array elements
      -- passed as out/inout parameters
      ncr:$AM_EXPR:=cr;
	   
      if call_need_fix_out_args(cr) then
	 ncr := call_fix_out_args(cr);
      else
	 cur_se.mark_context(cr);
	 -- Try inlining.
	 typecase cr
	 when AM_ROUT_CALL_EXPR then
	    ncr:=special_inline(cr);
	 when AM_ITER_CALL_EXPR then
	    ncr:=special_inline(cr);
	    typecase ncr
	    when AM_ITER_CALL_EXPR then
	       cur_loop.its:=cur_loop.its.push(ncr);
	    else end;
	 else
	 end;
      end;
      if prog.psather then sys_closure_nest(cr) end;

      -- see if still an $AM_CALL_EXPR and add to list if so
      if ~void(cur_rout) then 
	 typecase ncr
	 when $AM_CALL_EXPR then cur_rout.calls:=cur_rout.calls.push(ncr);
	    -- inform the optimizer about out/inout args, if any
	    loop
	       i::=0.upto!(ncr.asize-1);
	       if ncr[i].mode = MODES::out_mode or ncr[i].mode = MODES::inout_mode
	       then
		  cur_se.mark_se(ncr[i].expr,true);
	       end;
	    end;
	 else
	 end;
      end;
      return ncr; 
   end;

   iter_in_protect_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("An iter call may not occur in a protect statement without an enclosing loop.")
   end;
   
   -------------------

   call_need_fix_out_args(cr:$AM_CALL_EXPR): BOOL is
      -- attributes and array elements passed as out and inout parameters
      -- need very special treatment. The same goes for attributes.
      -- Return true is these are present      
      
      loop
	 i::=0.upto!(cr.asize-1);
	 a::=cr[i];
	 ae ::=a.expr;
	 typecase ae
	 when AM_ROUT_CALL_EXPR then
	    if SYS::ob_eq(a.mode, MODES::out_mode) or
		     SYS::ob_eq(a.mode, MODES::inout_mode) then
	       if is_aget_sig(ae.fun) then
		  -- array element as out/inout arg argument
		  return true
	       elsif ae.fun.is_reader_sig then 
		  -- handles a case when attribute accesses could
		  -- not be inlined due to, say, dispatching
		  -- attribute as out/inout argument
		  return true;
	       end;
	    end;
	 when AM_ATTR_EXPR then
	    -- simple (not dispatched) attribute accesses might
	    -- have already been inlined
	    if SYS::ob_eq(a.mode, MODES::out_mode) or
		     SYS::ob_eq(a.mode, MODES::inout_mode) then
	       return true;
	    end;
	 else
	 end;
      end;
      return false;
   end;

   -- fix bound iter part 
   call_fix_out_args(cr:$AM_CALL_EXPR): $AM_EXPR is
      -- attributes and array elements passed as out and inout parameters
      -- need very special treatment. First, they must be evaluated into
      -- a temporary (reader, aget), a temporary is passed as out/inout, 
      -- then they are set (writer, aset)

      -- For now make things simple: evaluate every argument into a 
      -- temporary! Will fix when have time
      
      res:AM_STMT_EXPR;
      args:ARRAY{AM_CALL_ARG};
      
      res := #AM_STMT_EXPR(cr.source);
      args := #(cr.asize);
      
      start:INT:=0;
      typecase cr
      when AM_ROUT_CALL_EXPR then
	 start := 1;
	 args[0] := cr[0].copy;
      when AM_ITER_CALL_EXPR then
	 start := 1;
	 args[0] := cr[0].copy;
      else
      end;

      loop
	 i::=start.upto!(cr.asize-1);
	 a::=cr[i].copy;
	 ae ::=a.expr;

	 typecase ae
	 when $AM_CONST then     
	    args[i] := a;
	 else                -- do the copying
	    l:AM_LOCAL_EXPR := #AM_LOCAL_EXPR(cr.source, void, ae.tp);
	    stmt ::= #AM_ASSIGN_STMT(cr.source);
	    stmt.src := ae;
	    add_local(l);
	    stmt.dest := l;
	    if void(res.stmts) then
	       res.stmts := stmt;
	    else
	       res.stmts.append(stmt);
	    end;
	    args[i] := #AM_CALL_ARG(l, a.mode);	    
	 end;
      end;
      
      -- now, generate a call that has only newly created locals as
      -- arguments
      new_call_stmt:$AM_STMT;
      new_res:AM_LOCAL_EXPR;
      ret_tp:$TP;  -- return type of the call
      ncr:$AM_EXPR;
            

      typecase cr
      when AM_ROUT_CALL_EXPR then
	 nr ::= #AM_ROUT_CALL_EXPR(cr.asize);
	 nr.fun := cr.fun;
	 loop 
	    i::=0.upto!(cr.asize-1);
	    nr[i] := args[i];
	 end;
	 ret_tp := nr.fun.ret;
	 -- try inlinining
	 cur_se.mark_context(nr);	 
	 ncr := special_inline(nr);
     when AM_ITER_CALL_EXPR then
	 ni ::= #AM_ITER_CALL_EXPR(cr.asize);
	 ni.fun := cr.fun;
	 ni.init := cr.init;
	 ni.lp := cr.lp;
	 ni.init_before_loop := cr.init_before_loop;
	 loop 
	    i::=0.upto!(cr.asize-1);
	    ni[i] := args[i];
         end;	
         ret_tp := ni.fun.ret;
	 --try inlining
	 cur_se.mark_context(ni);	 
	 ncr := special_inline(ni);
	 
         -- update enclosing loop if inlining did not work!
         typecase ncr
         when AM_ITER_CALL_EXPR then
	    cur_loop.its := cur_loop.its.push(ncr);
         else
         end;
      when AM_BND_ROUT_CALL_EXPR then
	 nb ::= #AM_BND_ROUT_CALL_EXPR(cr.asize);
	 nb.br := cr.br;
	 nb.br_tp := cr.br_tp;
	 loop 
	    i::=0.upto!(cr.asize-1);
	    nb[i] := args[i];
	 end;	
	 ncr:=nb;
	 ret_tp := nb.tp;
      when AM_BND_ITER_CALL_EXPR then
	 nbi ::= cr.copy; -- no inout stuff yet for iters 
      when AM_EXT_CALL_EXPR then
	 ne ::= #AM_EXT_CALL_EXPR(cr.asize);
	 ne.fun := cr.fun;
	 ne.nm := cr.nm;
	 loop 
	    i::=0.upto!(cr.asize-1);
	    ne[i] := args[i];
	 end;
	 ncr := ne;
	 ret_tp := ne.fun.ret;
      end;
      
      if void(ret_tp) then
	 expr_stmt ::= #AM_EXPR_STMT(cr.source);
	 expr_stmt.expr := ncr;
	 new_call_stmt := expr_stmt;
      else
	 ass_stmt ::= #AM_ASSIGN_STMT(cr.source);
	 new_res := #AM_LOCAL_EXPR(cr.source, void, ret_tp);
	 add_local(new_res);
	 ass_stmt.src := ncr;
	 ass_stmt.dest := new_res;
	 res.expr := new_res;
	 new_call_stmt := ass_stmt;
      end;
      
      -- append the call statement
      res.stmts.append(new_call_stmt);
      
      -- all we need to do is to copy back all inout/out args
      -- note the way attributes and array elements are handled!
      loop
	 i ::= start.upto!(cr.asize-1);
	 a::=cr[i].copy;
	 ae::=a.expr;
	 
	 if SYS::ob_eq(a.mode, MODES::out_mode) or
		  SYS::ob_eq(a.mode, MODES::inout_mode) then
	    typecase ae
	    when AM_ROUT_CALL_EXPR then
	       if is_aget_sig(ae.fun) then
		  if ae[0].expr.tp.is_immutable then
		     err("It is illegal to pass elements of immutable arrays as out/inout arguments.");
		  end;
		  
		  aset_call ::= #AM_ROUT_CALL_EXPR(ae.size+1);
		  aset_call_sig ::= #CALL_SIG;
		  aset_call_sig.args:=#ARRAY{CALL_ARG}(ae.size);
		  aset_call_sig.tp := ae.fun.tp;  -- type on which the call is made
		  aset_call_sig.name := IDENT_BUILTIN::aset_ident;
		  aset_call_sig.has_ret:=false;  -- aset has no return
		  loop
		     aset_call_sig.args.set!(#CALL_ARG(ae.fun.args.elt!.tp));
		     -- type of index
		  end;
		  aset_call_sig.args[ae.size-1] := #(ae.fun.ret);
		  -- type of held element

		  aset_call.fun := ae.fun.tp.ifc.sig_for_call(aset_call_sig);

		  if void(aset_call.fun) then
		     err("Passing array element as out/inout argument: aset not found.");
		  else
		     loop
			aset_call.set!(ae.elt!);
		     end;
		     aset_call[aset_call.size-1] := #(args[i].expr);
		     
		     cur_rout.calls:=cur_rout.calls.push(aset_call);  
		     
		     expr_stmt ::= #AM_EXPR_STMT(cr.source);
		     expr_stmt.expr := aset_call;
		     res.stmts.append(expr_stmt);
		  end;
		  
	       elsif ae.fun.is_reader_sig then
		  if ae[0].expr.tp.is_immutable then
		     err("It is illegal to pass attributes of immutable objects as out/inout parameters.");
		  end;
		  writer_call ::= #AM_ROUT_CALL_EXPR(2);
		  writer_call_sig ::= #CALL_SIG;
		  writer_call_sig.args := #ARRAY{CALL_ARG}(1);
		  writer_call_sig.tp := ae.fun.tp;
		  writer_call_sig.name := ae.fun.name;
		  writer_call_sig.has_ret := false;  -- ref attr writer
		  writer_call_sig.args[0] := #(ae.fun.ret);
		  
		  writer_call.fun := ae.fun.tp.ifc.sig_for_call(writer_call_sig);
		  
		  if void(writer_call.fun) then
		     err("Passing an attribute as out/inout argument: writer not found");
		  else		  
		     writer_call[0] := ae[0];
		     writer_call[1] := #(args[i].expr.copy);
		     
		     cur_rout.calls:=cur_rout.calls.push(writer_call);     
		     
		     expr_stmt ::= #AM_EXPR_STMT(cr.source);
		     expr_stmt.expr := writer_call;
		     res.stmts.append(expr_stmt);
		  end;
	       end;
	    else
	       -- simple copy
	       stmt:AM_ASSIGN_STMT;
	       stmt:=#AM_ASSIGN_STMT(cr.source);
	       stmt.src := args[i].expr.copy; 
	       stmt.dest := cr[i].expr.copy;
	       res.stmts.append(stmt);	       
	    end;
	 end;
      end;
      return res;
   end;
   
   call_check_out_args(as_call:AS_CALL_EXPR) is
      e:$AS_EXPR;
      m:AS_ARG_MODE;

      e:=as_call.args;
      m:=as_call.modes;
      
      loop
	 while!(~void(e));
	 if (m.mod = AS_ARG_MODE::out_mode) or 
		  (m.mod = AS_ARG_MODE::inout_mode) then
	    typecase e
	    when AS_SELF_EXPR then 
	       err("It is illegal to pass `self' as out/inout argument.");
	    when AS_VOID_EXPR then 
	       err("It is illegal to pass `void' as out/inout argument.");
	    when AS_IS_VOID_EXPR then 
	       err("It is illegal to pass `void' test expression as out/inout argument.");
	    when AS_ARRAY_EXPR then 
	       err("It is illegal to pass array expression as out/inout argument.");
	    when AS_CREATE_EXPR then
	       err("It is illegal to pass a creation expression as out/inout argument.");
	    when AS_BOUND_CREATE_EXPR then 
	       err("It is illegal pass a bound create expression as out/inout argument.");
	    when AS_AND_EXPR then 
	       err("It is illegal to pass an `and' expression as out/inout argument.");
	    when AS_OR_EXPR then 
	       err("It is illegal to pass `or' expression as out/inout argument.");	 
	    when AS_EXCEPT_EXPR then
	       err("It is illegal to pass a `exception' expression as out/inout argument.");
	    when AS_NEW_EXPR then 
	       err("It is illegal to pass a `new' expression as out/inout argument.");
	    when AS_INITIAL_EXPR then
	       err("It is illegal to pass an `initial' expression as out/inout argument.");
	    when AS_BREAK_EXPR then 
	       err("It is illegal to pass a `break!' expression as out/inout argument.");	
	    when AS_RESULT_EXPR then 
	       err("It is illegal to pass a result' expression as out/inout argument.");	
	    when AS_BOOL_LIT_EXPR then
	       err("It is illegal to pass a boolean literal as out/inout argument.");	
	    when AS_CHAR_LIT_EXPR then
	       err("It is illegal to pass a character literal as out/inout argument.");	
	    when AS_STR_LIT_EXPR then 
	       err("It is illegal to pass a string literal as out/inout argument.");	
	    when AS_INT_LIT_EXPR then 
	       err("It is illegal to pass an integer literal as out/inout argument.");	
	    when AS_FLT_LIT_EXPR then 
	       err("It is illegal to pass a floating point literal as out/inout argument.");
	    when AS_CLUSTER_EXPR then 
	       err("It is illegal to pass a `cluster' expression as out/inout argument.");
	    when AS_CLUSTER_SIZE_EXPR then 
	       err("It is illegal to pass a `cluster_size' expression as out/inout argument.");	       
	    when AS_GLOBAL_EXPR then 
	       err("It is illegal to pass a `global' expression as out/inout argument.");	       
	    when AS_CALL_EXPR then
	       if e.is_array=false and ~void(e.args) then
		  err("It is illegal to pass a call with arguments as out/inout parameter.");
	       end;
	    else end;
	 end;
	 e := e.next;
	 m := m.next;
      end;
   end;
	 
   call_local_context_err(e:AS_CALL_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of this local variable: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 
   
   call_const_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("Illegal call for a shared or constant initialization "
	    "expression."); 
   end;

   call_expr_check_local(e:AS_CALL_EXPR,tp:$TP):AM_LOCAL_EXPR is
      -- Check if the call `e' is a local variable reference.
      -- If it is return the local.
      if in_constant then return void end; -- No locals in initializers.
      if void(e) then
	 err("Compiler error, TRANS::call_expr_check_local on void.");
	 return void end;
      self_as:$AS_EXPR:=e.ob; 
      r:AM_LOCAL_EXPR;
      if void(self_as) and void(e.tp) and void(e.args) and 
	 e.is_array=false 
      then	-- check for local.
	 r:=local_with_name(e.name);
	 if ~void(r) then
	    if ~void(tp) then
	       if ~r.tp.is_subtype(tp) then
		  call_local_context_err(e,r.tp,tp); return void
	       end
	    end;
	 end;
      end;
      return r; 
   end;
   
   call_self(e:AS_CALL_EXPR):TUP{$AM_EXPR,$TP} 
      -- Return an expression for self and the type of self for the
      -- call `e'. 
      pre ~void(e) is
      self_as:$AS_EXPR:=e.ob;
      if ~void(self_as) then	-- Call made on an expr.
	 typecase self_as
	 when AS_VOID_EXPR then call_self_void_err(e); return void
	 when AS_CREATE_EXPR then
	    if void(self_as.tp) then 
	       call_self_create_err(e); return void
	    else self_val:$AM_EXPR:=transform_expr(self_as,void); 
	       if void(self_val) then return void end;
	       return #TUP{$AM_EXPR,$TP}(self_val,self_val.tp) end;
	 when AS_ARRAY_EXPR then call_self_array_err(e); return void
	 when AS_UNDERSCORE_ARG then 
	    call_self_underscore_err(e); return void
	 else self_val:$AM_EXPR:=transform_expr(self_as,void);
	    if void(self_val) then return void end;
	    return #TUP{$AM_EXPR,$TP}(self_val,self_val.tp); 
	 end;
      elsif ~void(e.tp) then	-- Double colon call.
	 av::=#AM_VOID_CONST(e.source);
	 av.tp_at:=tp_of(e.tp);
	 return #TUP{$AM_EXPR,$TP}(av,av.tp_at)
      else			-- Call on self.
	 self_val:$AM_EXPR;
	 if in_constant then	-- Self is void in initializers.
	    av::=#AM_VOID_CONST(e.source);
	    av.tp_at:=tp_con.same; self_val:=av;
	 else
	    self_val:=cur_rout.self_local end;
	 if void(self_val) then
	    #OUT + "Compiler error, TRANS::call_self, self_val=void.";
	    return void end;
	 return #TUP{$AM_EXPR,$TP}(self_val,self_val.tp) end end;
   
   call_self_void_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("Calls may not be made directly on `void'."); 
   end;
   
   call_self_create_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("Calls may not be made on create expressions which "
	    "don't specify the type of object being created."); 
   end;
   
   call_self_array_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("Calls may not be made on array expressions."); 
   end;
   
   call_self_underscore_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("Underscore arguments may not appear in this position.") 
   end;
   
   call_context_err(e:AS_CALL_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the call: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 

   ext_call_const_err(e:AS_CALL_EXPR) is
      err_loc(e);
      err("External calls may not appear in shared or constant "
	    "initialization expressions."); 
   end;
   
   call_expr_get_sig(e:AS_CALL_EXPR, call_sig:CALL_SIG, 
      args:ARRAY{AM_CALL_ARG},in_class:BOOL):SIG is
      -- Get the signature of the call with `call_sig' and if there
      -- are arguments, put their expressions in `args'. If anything fails,
      -- return void. If `in_class' is true then look at private routines
      -- as well as public ones. 
      if void(args) then
	 if ~void(e.args) then 
	    err("Compiler error, TRANS::call_expr_get_sig, args size.");
	    return void end;
      elsif args.size/=e.args_size or 
	 call_sig.args.size/=e.args_size then
	       err("Compiler error, TRANS::call_expr_get_sig, args size.");
	 return void end;
      a:$AS_EXPR:=e.args; m:AS_ARG_MODE:=e.modes; i:INT:=0;
      ce:$AM_EXPR; md:$MODE;
      loop while!(~void(a));
	 ct:$CALL_TP:=call_tp_of_expr(a);
	 if void(ct) then ce:=transform_expr(a,void); 
	    if void(ce) then return void
	    else ct:=ce.tp end;
	 else ce:=void end;
	 md := MODE::create_from_as(m);
	 call_sig.args[i]:=#(ct,md); args[i]:=#(ce,md); 
	 a:=a.next; m:=m.next; i:=i+1 end;
      err_loc(e); r::=call_sig.lookup(in_class);
      if void(r) then return void end; -- Failure.
      if r.args.size/=e.args_size then
	 err("Compiler error, TRANS::call_expr_get_sig, res size.");
	 return void end;
      a:=e.args; m:=e.modes; i:=0;
      loop while!(~void(a));
	 ce:=args[i].expr; at:$TP:=r.args[i].tp;
	 if void(ce) then ce:=transform_expr(a,at) end;
	 if void(ce) then return void end;
	 args[i]:=#(ce,MODE::create_from_as(m)); 
	  a:=a.next; m:=m.next; i:=i+1 end;
      return r; 
   end;
      
   call_expr_rout_name(e:AS_CALL_EXPR):IDENT 
      -- The name of the routine being called.
      pre ~void(e) is
      if e.is_array then return IDENT_BUILTIN::aget_ident
      else return e.name end; 
   end;  
   
   call_fix_iter(ir:AM_ITER_CALL_EXPR):AM_ITER_CALL_EXPR 
      -- Move the once args out in the iter call `ir'.
      pre ~void(ir) is
      if in_constant then iter_call_const_err; return void end;      
      if void(cur_loop) then iter_call_out_of_loop_err; return void end;
      ir.lp:=cur_loop;
      if void(ir[0].expr) then 
	 #OUT + "Compiler error, TRANS::call_fix_iter, ir[0]=void."; 
	 return void end;      
      if void(ir.fun) then 
	 #OUT + "Compiler error, TRANS::call_fix_iter, ir.fun=void."; 
	 return void end;      
      if contains_iter_call(ir[0].expr) then -- iter in self expression.
	 iter_call_in_once_arg_err(0); return void end;      
      nl::=#AM_LOCAL_EXPR(ir.source, void, ir[0].expr.tp); 
      add_local(nl); 
      ass::=#AM_ASSIGN_STMT(ir.source); 
      ass.dest:=nl;
      ass.src:=ir[0].expr; ir[0].expr:=nl; ir.init:=ass;
      i:INT:=0;
      loop while!(i<ir.size-1);
	 if void(ir[i+1].expr) then
	    #OUT + "Compiler error, TRANS::call_fix_iter, ir[" + (i+1) +
		  "].expr=void."; return void end;      	    
	 aonce:BOOL:=false;
	 if void(ir.fun.hot) then aonce:=true 
	 elsif ~ir.fun.hot[i] then aonce:=true end;
	 if aonce then
	    if contains_iter_call(ir[i+1].expr) then
	       iter_call_in_once_arg_err(i+1); return void end;
	    nl:=#AM_LOCAL_EXPR(ir.source,void, ir[i+1].expr.tp);
	    add_local(nl); 
	    ass:=#AM_ASSIGN_STMT(ir.source); ass.dest:=nl;
	    ass.src:=ir[i+1].expr; ir[i+1].expr:=nl; 
	    if void(ir.init) then ir.init:=ass
	    else ir.init.append(ass) end end; 
	 i:=i+1 end;
      -- Moved(ivin) cur_loop.its:=cur_loop.its.push(ir);
      return ir; 
   end;

   iter_call_const_err is
      err("Iter calls may not appear in shared or constant "
	    "initialization expressions."); 
   end;
   
   contains_iter_call(e:$AM_EXPR):BOOL is
      -- True if `e' contains an iter call. This is used to check for
      -- iter calls in the expressions for once iter arguments.
      if void(e) then return void end;
      typecase e
      when AM_ROUT_CALL_EXPR then
	 loop if contains_iter_call(e.elt!.expr) then return true end end;
      when AM_ITER_CALL_EXPR then return true
      when AM_ARRAY_EXPR then
	 loop if contains_iter_call(e.elt!) then return true end end;
      when AM_BND_CREATE_EXPR then 
	 loop if contains_iter_call(e.elt!.expr) then return true end end;	 
      when AM_BND_ROUT_CALL_EXPR then
	 loop if contains_iter_call(e.elt!.expr) then return true end end;
      when AM_BND_ITER_CALL_EXPR then return true
      when AM_IF_EXPR then
	 if contains_iter_call(e.test) or 
	    contains_iter_call(e.if_true) or
		  contains_iter_call(e.if_false) then return true end	 
      when AM_IS_VOID_EXPR then
	 if contains_iter_call(e.arg) then return true end	 
      when AM_NEW_EXPR then
	 if contains_iter_call(e.asz) then return true end	 
      when AM_ATTR_EXPR then 
	 if contains_iter_call(e.ob) then return true end    
      when AM_EXT_CALL_EXPR then
	 loop if contains_iter_call(e.elt!.expr) then return true end end;	
      else end;
      return false; 
   end;
   
   iter_call_in_once_arg_err(i:INT) is
      if i=0 then
	 err("The expression specifying `self' in this iter call, "
	       "itself contains an iter call.")
      else err("The expression for argument number " + i +
	 " in this iter call, itself contains an iter call."); 
      end; 
   end;
	 
   bnd_rout_call_const_err is
      err("Bound routine calls may not appear in shared or "
	    "constant initialization expressions."); 
   end;

   call_fix_bnd_iter(bir:AM_BND_ITER_CALL_EXPR,
		     sig:SIG):AM_BND_ITER_CALL_EXPR is
      -- Move the once args out in the bound iter call `bir' with 
      -- signature `sig'.      
      if void(bir) or void(sig) then return void end;
      if in_constant then bnd_iter_call_const_err; return void end;      
      if void(cur_loop) then 
	 bnd_iter_call_out_of_loop_err; return void end;
      bir.lp:=cur_loop;
      i:INT:=0;
      loop while!(i<bir.size);
	 if void(bir[i].expr) then err_loc(bir);
	    err("Compiler error, TRANS::call_fix_bnd_iter, bir[" +
		  i + "].expr=void."); return void end;
	 aonce:BOOL:=false;
	 if void(sig.hot) then aonce:=true
	 elsif ~sig.hot[i] then aonce:=true end;
	 if aonce then
	    if contains_iter_call(bir[i].expr) then
	       bnd_iter_call_in_once_err(i); return void end;
	    nl::=#AM_LOCAL_EXPR(bir.source,void,bir[i].expr.tp);
	    add_local(nl); 
	    ass::=#AM_ASSIGN_STMT(bir.source); 
	    ass.dest:=nl;
	    ass.src:=bir[i].expr; bir[i].expr:=nl; 
	    if void(bir.init) then bir.init:=ass
	    else bir.init.append(ass) end end;
	 i:=i+1 end;
      cur_loop.bits:=cur_loop.bits.push(bir); 
      return bir; 
   end;
      
   bnd_iter_call_const_err is
      err("Bound iter calls may not appear in shared or constant "
	    "initialization expressions."); 
   end;
   
   bnd_iter_call_out_of_loop_err is
      err("Bound iters may only be called inside loop statements.");
   end;
      
   bnd_iter_call_in_once_err(i:INT) is
      err("Argument " + i + " of this bound iter call is " +
	    "a once argument, but an iter call appears in its expression."); 
   end;
      
-----------
         
   transform_void_expr(e:AS_VOID_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      r::=#AM_VOID_CONST(e.source); 
      if void(tp) then
	 err_loc(e);
	 err("Compiler error, no type for void."); return void end;
      r.tp_at:=tp; 
      return r;
   end;      
      
-----------
            
   transform_is_void_expr(e:AS_IS_VOID_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if ~void(tp) then
	 if ~TP_BUILTIN::bool.is_subtype(tp) then
	    err_loc(e); 
	    err("Void test expressions return BOOL objects which "
	    "are not subtypes of " + tp.str + "."); return void end end;
      r::=#AM_IS_VOID_EXPR(e.source); 
      r.tp_at:=TP_BUILTIN::bool; err_loc(e.arg);
      earg::=e.arg;
      typecase earg
      when AS_VOID_EXPR then
	 err("void(void) is not allowed."); return void
      when AS_CREATE_EXPR then 
	 if void(earg.tp) then 
	    err("void() on create expression without type."); 
	    return void end;
      when AS_ARRAY_EXPR then 
	 err("void() on array creation expression."); return void
      when AS_UNDERSCORE_ARG then 
	 err("void(_) is illegal."); return void
      else end;
      r.arg:=transform_expr(e.arg,void); 
      if void(r.arg) then return void end;
      return r; 
   end;      
   
-----------
         
   transform_array_expr(e:AS_ARRAY_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if void(tp) then array_tp_void_err(e); return void end;
      pt:$TP;
      typecase tp
      when TP_CLASS then
	 if tp.name/=IDENT_BUILTIN::ARRAY_ident 
	    or tp.params.size/=1 then
		  array_wrong_tp_err(e,tp); return void end;
	 pt:=tp.params[0];	-- The parameter type.
      else array_wrong_tp_err(e,tp); return void end;
      r::=#AM_ARRAY_EXPR(e.elts_size, e.source); 
      r.tp_at:=tp;
      ae:$AS_EXPR:=e.elts; i:INT:=0;
      loop while!(~void(ae));
	 tae:$AM_EXPR:=transform_expr(ae,pt);
	 if void(tae) then return void end;
	 r[i]:=tae;
	 ae:=ae.next; i:=i+1 end;
      return r; 
   end;
   
   array_tp_void_err(e:AS_ARRAY_EXPR) is
      err_loc(e);
      err("The type of this array creation expression cannot be "
	    "inferred from context."); 
   end;
	 
   array_wrong_tp_err(e:AS_ARRAY_EXPR, tp:$TP) is
      err_loc(e);
      err("The inferred type: " + tp.str + " for this array " +
	    "creation expression is not of the form `ARRAY{T}'."); 
   end;
      
-----------
         
   transform_create_expr(e:AS_CREATE_EXPR, tp:$TP):$AM_EXPR
    -- Expression implementing `e' in type context `tp'.
    is
	at:$TP;
	if in_constant then create_const_err(e); return void end;      
	if ~void(e.tp) then
	    at:=tp_of(e.tp);
	    if ~void(tp) then
		if ~at.is_subtype(tp) then 
		    create_context_err(e,at,tp);
		    return void
		end
	    end;
	elsif void(tp) then 
	    create_tp_spec_err(e); return void
	else at:=tp end;
	-- Now `at' has the type we are creating.
	if at.is_abstract then
	    -- *H* Catching that a creation expressions in a generic class creates an
	    -- object of a class used as a type parameter. One does not know whether the
	    -- this class is concrete or abstract. This code disables the errormessage
	    -- for this case. Does not change program behaviour, as there is no code
	    -- being generated for generic classes.
	    dummyclass: BOOL := false;
	    if prog.check_generics then
		typecase at
		when TP_CLASS then
		    dummyclass := at.is_dummy_class
		else
		end
	    end;
	    -- *H* end
	    if ~ dummyclass then
		err_loc(e);
		err("Creation expressions may not specify abstract types.");
		return void;
	    end;
	end;
	
	if at.is_partial and (e.tp.kind /= AS_TYPE_SPEC::same) and
		  ~prog.is_check_am 
	    -- this error is not reported during unreachable code stage
	    -- since whenever the code is complete SAME in partial classes
	    -- becomes a concrete class
	then
	    err("Partial classes cannot be instantiated.");
	end;
      
	check_params_for_partial(e.tp); 
	
	na:INT:=e.elts_size;	-- Number of arguments.
	r::=#AM_ROUT_CALL_EXPR(na+1,e.source); 
	r.as_type := e.tp;
	av::=#AM_VOID_CONST(e.source); av.tp_at:=at;
	r[0]:=#(av);	 
	cs::=#CALL_SIG; 
	if na>0 then cs.args:=#ARRAY{CALL_ARG}(na) end;
	cs.tp:=at; cs.name:=IDENT_BUILTIN::create_ident;
	cs.has_ret:=true;		-- Creation expressions always return vals.
	ce:$AS_EXPR:=e.elts; i:INT:=0;
	m:AS_ARG_MODE:=e.modes;
	
	loop while!(~void(ce));
	    cs.args[i]:=#(call_tp_of_expr(ce), MODE::create_from_as(m));
	    if void(cs.args[i].tp) then -- Not a type inference case.
		-- Compute arg expr.
		r[i+1]:=#(transform_expr(ce,void),MODE::create_from_as(m));
		if void(r[i+1].expr) then return void end;
		cs.args[i].tp:=r[i+1].expr.tp; 
		cs.args[i].mode := r[i+1].mode;
	    end;  -- Get type from expr.
	    ce:=ce.next; m:=m.next; i:=i+1 
	end;
	err_loc(e);
	
	-- DPS: was: r.fun:=at.ifc.sig_for_call(cs);
	if at=tp_con.same then
	    r.fun:=at.impl.sig_for_internal_call(cs);
	else
	    r.fun:=at.ifc.sig_for_call(cs);
	end;
	-- DPS end of change
	
	
	if void(r.fun) then return void end;
	ce:=e.elts; i:=0;
	loop while!(~void(ce));
	    if void(r[i+1]) then	-- Need to compute by inference.
		r[i+1]:=#(transform_expr(ce,r.fun.args[i].tp),r.fun.args[i].mode); 
		-- Here is where the type inference gets done. We tell
		-- it to use the found signature type an mode to evaluate ce.
		if void(r[i+1].expr) then return void end end; 
	    ce:=ce.next; i:=i+1 
	end;
	if r.fun.ret/=at then
	    create_bad_return_type_err(e,r.fun.ret,at); return void end;
	cur_rout.calls:=cur_rout.calls.push(r);      
	cur_se.mark_context(r);
	r2 ::= special_inline(r);
	return r2;
    end;
   
   create_const_err(e:AS_CREATE_EXPR) is
      err_loc(e);
      err("Creation expressions may not appear in shared or "
	    "constant initialization expressions."); 
   end;
   
   create_context_err(e:AS_CREATE_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the creation expression: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end;
   
   create_tp_spec_err(e:AS_CREATE_EXPR) is
      err_loc(e); 
      err("This creation expression does not specify its type "
	    "and it cannot be inferred from context."); 
   end;
   
   create_bad_return_type_err(e:AS_CREATE_EXPR, rt,at:$TP) is
      err_loc(e);
      err("This creation expression returns the type: " + rt.str +
	    " rather than " + at.str + " as it must."); 
   end;
   
-----------
       
   transform_bound_create_expr(e:AS_BOUND_CREATE_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if in_constant then bound_create_in_const_err(e); return void end; 
      st::=bound_create_self(e); self_val::=st.t1; self_tp::=st.t2;
      nbnd::=bound_create_num_bnd(self_val,e);
      r::=#AM_BND_CREATE_EXPR(nbnd);
      r.fun:=bound_create_sig(e,self_tp, tp);
      if void(r.fun) then return void end; -- Failure.
      if e.is_iter and r.fun.is_iter.not then
	 bound_create_not_iter_err(e); return void
      elsif ~e.is_iter and r.fun.is_iter then
	 bound_create_iter_err(e); return void end;
      r.bnd_args:=bound_create_bnd_args(nbnd,e);
      r.unbnd_args:=bound_create_unbnd_args(nbnd,e);
      b_ind::=0;			-- Index into bound arguments.
      if ~void(self_val) then
	 r[b_ind]:=#(self_val); b_ind:=b_ind+1;
	 if e.is_iter and contains_iter_call(self_val) then
	    bound_create_self_has_iter_err(e); return void end;
	 -- This used to enclose entire following loop!
      end;
      hot:BOOL;
      a::=e.call.args;
      m::=e.call.modes;
      loop while!(~void(a)); atp::=r.fun.args.elt!.tp;
	 --
	 if ~void(r.fun.hot) then hot:=r.fun.hot.elt! end;
	 typecase a when AS_UNDERSCORE_ARG then else
	    r[b_ind]:=#(transform_expr(a,atp), MODE::create_from_as(m));
	    if void(r[b_ind].expr) then return void end;
	    if e.is_iter and ~hot and contains_iter_call(r[b_ind].expr) then
	       bound_create_iter_in_once_err(a); return void end;
	    b_ind:=b_ind+1 end;
	 a:=a.next;
      end;
      bound_create_set_tp(e,r);
      if ~void(tp) and ~r.tp.is_subtype(tp) then
	 bound_create_context_err(e,r.tp,tp); return void end;
      cur_rout.calls:=cur_rout.calls.push(r);
      
      if r.tp.is_fortran then
	 -- need to make sure that legal Fortran routines is bound up
	 if ~r.fun.is_ext_fortran_sig then
	    f_rout_create_sig_err(e);
	 end;
	 
	 if r.bnd_args.size > 0 then
	    -- Don't really care about self
	    if ~(r.bnd_args.size = 1 and r.bnd_args[0] = 0) then
	       f_rout_create_bound_arg_err(e);
	    end;
	 end;
      end;
      return r;
   end;

   bound_create_in_const_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Bound creation expressions may not appear in shared or "
	    "constant initialization expressions."); 
   end;

   f_rout_create_sig_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Illegal routine is passed as argument to #F_ROUT.");
   end;

   f_rout_create_bound_arg_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("All arguments must be left unbound in F_ROUT creation expression.");
   end;
   
   
   bound_create_self(e:AS_BOUND_CREATE_EXPR):TUP{$AM_EXPR,$TP} is
      -- Return an expression for self and the type of self for the
      -- bound create expression `e'. If `t1' is void, then it is a 
      -- call on underscore, or an error!.
      call::=e.call; self_as::=call.ob;
      self_val:$AM_EXPR;
      if ~void(self_as) then	-- Call made on an expr.
	 typecase self_as
	 when AS_VOID_EXPR then bound_create_self_void_err(e); 
	    return #(void,void)
	 when AS_CREATE_EXPR then 
	    if void(self_as.tp) then bound_create_self_create_err(e); 
	       return #(void,void)
	    else self_val:=transform_expr(self_as,void); 
	       return #(self_val,self_val.tp) end;
	 when AS_ARRAY_EXPR then bound_create_self_array_err(e); 
	    return #(void,void)
	 when AS_UNDERSCORE_ARG then
	    -- `self_val' is void if self is an underscore expression, or if it
	    -- does not exist for some erroneus reason.
	    if void(self_as.tp) then return #(void,void)
	    else 
	       return #(void,tp_of(self_as.tp)) 
	    end;
	 else self_val:=transform_expr(self_as,void);
	    -- error: dispatch on void , if self_val is void.
	    --if void(self_val) then err("Dispatch on void, trans !, temporary!");
	    --else   
	    return #(self_val,self_val.tp); --end;
	 end;
	 elsif ~void(call.tp) then	-- Double colon call.
	 res::=#AM_VOID_CONST(call.source);
	 res.tp_at:=tp_of(call.tp);
	 return #(res, res.tp_at);
      else			-- Call on self.
	 if void(call.args) then	-- Might be a local.
	    l::=local_with_name(call.name);
	    if ~void(l) then 
	       bound_create_self_local_err(e); return #(void,void)
	    else end end;
	 self_val:=cur_rout.self_local; 
	 return #(self_val, self_val.tp); 
      end; 
   end;
   
   bound_create_self_void_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Bound creation calls may not be made directly on `void'.") 
   end;
   
   bound_create_self_create_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Bound creation calls may not be made on create "
	    "expressions which don't specify the type of object being "
	    "created."); 
   end;
   
   bound_create_self_array_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Bound creation calls may not be made on array "
	    "expressions."); 
   end;

   bound_create_self_local_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e); 
      err("Bound creation calls must be calls on routines or iters, "
	    "not references to local variables."); 
   end;

   bound_create_sig(e:AS_BOUND_CREATE_EXPR, self_tp:$TP, ctp:$TP):SIG is
      -- The signature of the call represented by `e' where the type of
      -- self has been determined to be `self_tp'.  If self_tp is void,
      -- self is untyped '_' and we need to figure out the type from the
      -- context. ctp is the type context.
      -- Void if there is a problem.

      con_args: ARRAY{ARG};  -- args from context
      con_ret:$TP;           -- return type from context
      if ~void(ctp) then
	 typecase ctp
	 when TP_ROUT then
	    con_args := ctp.args;
	    con_ret := ctp.ret;
	 when TP_ITER then
	    con_args := ctp.args;
	    con_ret := ctp.ret;
	 end; -- nothing else is possible here
      end;

      if void(self_tp) then
	 -- need to take from context
	 if ~void(con_args) then
	    self_tp := con_args[0].tp; 
	 else
	    err("Failure to infer the type of the unbound self argument");
	    return void;
	 end;
      end;
      
      call_sig::=#CALL_SIG; call_sig.tp:=self_tp;
      call_sig.name:=e.call.name;
      call_sig.args:=#ARRAY{CALL_ARG}(e.call.args_size);
      if ~void(con_ret) then call_sig.has_ret:=true end;
      if void(ctp) and void(e.ret) then
	 call_sig.unknown_ret:=true 
      end;
      ca::=e.call.args;
      cm::=e.call.modes;  -- tells u whether its once i.e. once_mod
      i:INT;  -- arg poistion

      -- figure out if self is unbound
      ob ::= e.call.ob;
      typecase ob
      when AS_UNDERSCORE_ARG then
	 i := 1;
      else
	 i := 0;
      end;

      if ~void(con_args) then
	 -- compute the number of unbound arguments
	 arg::=ca;
	 unbound_args:INT := i;
	 loop
	    while!(~void(arg));
	    atp::=call_tp_of_expr(arg);	
	    if ~void(atp) then
	       typecase atp
	       when CALL_TP_UNDERSCORE then
		  unbound_args := unbound_args + 1;
	       end;
	    end;
	    arg := arg.next;
	 end;
	 
	 if unbound_args /= con_args.size then
	    if unbound_args < con_args.size then
	       err("Too few unbound arguments in a closure creation expression");
	    else
	       err("Too many unbound arguments in a closure creation expression");		     
	    end;
	    return void;
	 end;
      end;
	 
      loop while!(~void(ca)); 
	 atp::=call_tp_of_expr(ca);
	 if void(atp) then 
	    -- normal case
	    atp:=transform_expr(ca,void).tp 
	 else
	    -- possible type inference case
	    if ~void(con_args) then
	       typecase atp
	       when CALL_TP_UNDERSCORE then
		  if void(atp.tp) then
		     -- need to use type inferencing
		     atp.tp := con_args[i].tp;
		  end;
		  i := i + 1;
	       else
	       end;
	    end;
	 end;
	    
	 call_sig.args.set!(#CALL_ARG(atp, MODE::create_from_as(cm)));
	
	 ca:=ca.next;  cm:=cm.next; 
      end;
      -- At this point call_sig is complete, except for hots which were left out
      err_loc(e);		-- Just in case.
      -- setting of the hot in SIG must happen in the following call
      s::=call_sig.lookup(self_tp=tp_con.same); 
      return s;
   end;

   bound_create_not_iter_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Bound iters must be formed from iter calls."); 
   end;

   bound_create_iter_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("Bound routines must be formed from routine calls."); 
   end;
   
   bound_create_num_bnd(self_val:$AM_EXPR, e:AS_BOUND_CREATE_EXPR):INT is
      -- The number of argument which are bound up (including self).
      r:INT;
      if void(self_val) then r:=0 else r:=1 end; -- Count self.
      a::=e.call.args;
      loop while!(~void(a));
	 typecase a when AS_UNDERSCORE_ARG then else r:=r+1 end;
	 a:=a.next end;
      return r; 
   end;
   
   bound_create_bnd_args(nbnd:INT,e:AS_BOUND_CREATE_EXPR):ARRAY{INT} is
      -- An array of the indices of arguments which are bound up in
      -- order. 0 is self. `nbnd' is the number of bound args.
      r:ARRAY{INT};
      if (nbnd /= 0) then r:=#ARRAY{INT}(nbnd); end;
      rind::=0;			-- Index into r.
      st::=e.call.ob;
      typecase st when AS_UNDERSCORE_ARG then 
      else r[rind]:=0; rind:=rind+1 end;
      aind::=0;			-- Index into argument list.      
      a::=e.call.args;
      loop while!(~void(a)); aind:=aind+1;
	 typecase a when AS_UNDERSCORE_ARG then 
	 else r[rind]:=aind; rind:=rind+1 end;
	 a:=a.next end;
      return r; 
   end;

   bound_create_unbnd_args(nbnd:INT,e:AS_BOUND_CREATE_EXPR):ARRAY{INT} is
      -- An array of the indices of arguments which are not bound in
      -- order. 0 is self. `nbnd' is the number of bound args.

      nr_unbound_arg::=1+e.call.args_size-nbnd;      
      r:ARRAY{INT};
      if (nr_unbound_arg /= 0) then  
	 r:=#ARRAY{INT}(nr_unbound_arg);
      end;
      rind::=0;			-- Index into r.
      st::=e.call.ob;
      typecase st when AS_UNDERSCORE_ARG then 
	 r[rind]:=0; rind:=rind+1 else end;
      aind::=0;			-- Index into argument list.      
      a::=e.call.args;
      loop while!(~void(a)); aind:=aind+1; 
	 typecase a when AS_UNDERSCORE_ARG then 
	    r[rind]:=aind; rind:=rind+1 else end;
	 a:=a.next end;
      return r; 
   end;

   bound_create_self_has_iter_err(e:AS_BOUND_CREATE_EXPR) is
      err_loc(e);
      err("The expression for self in an iter call may not "
	    "itself contain an iter call."); 
   end;
   
   bound_create_iter_in_once_err(a:$AS_EXPR) is
      err_loc(a);
      err("Once arguments of iter calls may not themselves "
	    "contain iter calls."); 
   end;

   bound_create_set_tp(as:AS_BOUND_CREATE_EXPR,r:AM_BND_CREATE_EXPR) is
      -- Set the type in `r', assuming everything else is there (incl. mode)
      -- ctp is the context type (if any)
      fun::=r.fun;
      args::=#ARRAY{ARG}(r.unbnd_args.size);      
      t:$TP; m:$MODE; h:BOOL; hot : ARRAY{BOOL};

      if fun.is_iter then	-- A bound iter.
	 
	 -- if in bnd type no arg is hot the hot needs to be void
	 one_is_hot ::= false;
	       
	 if void(fun.hot) then 
	    hot := void;
	 else
	    hot:=#ARRAY{BOOL}(r.unbnd_args.size);
	 end;
	 loop i::=r.unbnd_args.elt!;
	    if i=0 then 
	       t:=fun.tp;
	       if fun.is_iter then
		  -- If self is left unbound in the bound iter
		  -- it must have "once" mode
		  if r.unbnd_args[0] = 0 then
		     m := #ONCE_MODE;
		  end;
	       else
		  m:=#IN_MODE;   --can't change self
	       end;
	    else 
		t:=fun.args[i-1].tp;
		m:=fun.args[i-1].mode;
	    end;
	    args.set!(#ARG(t,m));
	    if ~void(fun.hot) then 
	       if i=0 then h:=false else h:=fun.hot[i-1] end;
	       hot.set!(h);
	       one_is_hot := one_is_hot or h; -- set whenever there is a hot arg.
	    end; -- if there is nothing hot we DO want hot to be void!
	 end; -- ends loop
	 if ~one_is_hot then hot := void;  end;
	 r.tp_at:=prog.tp_tbl.tp_iter_for(args,hot,fun.ret)
      else			-- A bound routine.
	 loop i::=r.unbnd_args.elt!;
	     if i=0 then 
		 t:=fun.tp;
		 m:=#IN_MODE;
	     else 
		 t:=fun.args[i-1].tp; 
		 m:=fun.args[i-1].mode;
	     end;
	     args.set!(#ARG(t,m)) end;
	 -- add to the appropriate table
	 if as.is_f_rout then
	    r.tp_at:=prog.tp_tbl.tp_f_rout_for(args,fun.ret); 	    
	 else
	    r.tp_at:=prog.tp_tbl.tp_rout_for(args,fun.ret); 
	 end;
      end; 
   end;

   bound_create_context_err(e:AS_BOUND_CREATE_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the bound creation expression: " + stp.str + 
	    " is not a subtype of " + tp.str + "."); 
   end; 
   
-----------
      
   transform_and_expr(e:AS_AND_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if ~void(tp) then
	 if ~TP_BUILTIN::bool.is_subtype(tp) then
	    and_context_err(e,tp); return void end end;
      e1:$AM_EXPR:=transform_expr(e.e1, TP_BUILTIN::bool);      
      e2:$AM_EXPR:=transform_expr(e.e2, TP_BUILTIN::bool);            
      if void(e1) or void(e2) then return void end; -- Not booleans.
      r::=#AM_IF_EXPR(e.source);
      r.test:=e1; r.if_true:=e2;
      abc::=#AM_BOOL_CONST(e.source); 
      abc.val:=false;
      r.if_false:=abc;
      r.tp_at:=TP_BUILTIN::bool; 
      return r;
   end;      
   
   and_context_err(e:AS_AND_EXPR, tp:$TP) is
      err_loc(e); 
      err("And expressions return BOOL objects which are " +
	    "not subtypes of " + tp.str + "."); 
   end; 
   
-----------
         
   transform_or_expr(e:AS_OR_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if ~void(tp) then
	 if ~TP_BUILTIN::bool.is_subtype(tp) then
	    or_context_err(e,tp); return void end end;
      e1:$AM_EXPR:=transform_expr(e.e1, TP_BUILTIN::bool);      
      e2:$AM_EXPR:=transform_expr(e.e2, TP_BUILTIN::bool);            
      if void(e1) or void(e2) then return void end; -- Not booleans.
      r::=#AM_IF_EXPR(e.source);
      r.test:=e1; r.if_false:=e2;
      abc::=#AM_BOOL_CONST(e.source); abc.val:=true;
      r.if_true:=abc;
      r.tp_at:=TP_BUILTIN::bool; 
      return r;
   end;

   or_context_err(e:AS_OR_EXPR, tp:$TP) is
      err_loc(e); 
      err("Or expressions return BOOL objects which are " +
	    "not subtypes of " + tp.str + "."); 
   end; 
   
-----------
         
   transform_except_expr(e:AS_EXCEPT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if in_constant then except_const_err(e); return void end;      
      if in_protect_then=false then except_loc_err(e); return void end;
      r::=#AM_EXCEPT_EXPR(ex_tp);
      if ~void(tp) then
	 if ~r.tp.is_subtype(tp) then
	    except_context_err(e,r.tp,tp); return void end end;
      return r; 
   end;
   
   except_const_err(e:AS_EXCEPT_EXPR) is
      err_loc(e);
      err("`exception' expressions may not appear in shared "
	    "or constant initialization expressions."); 
   end;

   except_loc_err(e:AS_EXCEPT_EXPR) is
      err_loc(e); 
      err("`exception' expressions may only appear in `then'"
	    "and `else' clauses of `protect' statements."); 
   end;
   
   except_context_err(e:AS_EXCEPT_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the exception expression: "+ stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 
   
-----------
         
   transform_new_expr(e:AS_NEW_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if in_constant then new_const_err(e); return void end;      
      t::=impl.tp;		-- The type in which this appears.
      k:INT:=t.kind;
      if (k/=TP_KIND::ref_tp and k/=TP_KIND::spr_tp and k/=TP_KIND::part_tp) 
      then 
        new_in_non_ref_or_part_err(e); 
        return void;
      end;
      r:AM_NEW_EXPR;
      -- new expressions can not be optimized out because they
      -- actually modify state
      cur_se.mark_unsafe;
      if ~void(cur_se) then cur_se.has_new:=true; end;
      if ~void(tp) then
	 if ~t.is_subtype(tp) then
	    new_context_err(e,t,tp); return void end end;
      if ~void(e.arg) then	-- Specifies asize.
	 if void(impl.arr) then new_arg_no_array_err(e); return void end;
	 r:=#AM_NEW_EXPR(e.source); r.tp_at:=t; 
	 r.asz:=transform_expr(e.arg,TP_BUILTIN::int);
	 if void(r.asz) then return void end;
      else			-- Not an array class.
	 if ~void(impl.arr) then new_no_arg_array_err(e); return void end;
	 r:=#AM_NEW_EXPR(e.source); r.tp_at:=t end;
      return r; 
   end;

   new_const_err(e:AS_NEW_EXPR) is
      err_loc(e);
      err("`new' expressions may not appear in shared or constant "
	    "initialization expressions."); 
   end;
   
   new_in_non_ref_or_part_err(e:AS_NEW_EXPR) is
      err_loc(e);
      err("`new' expressions may only appear in reference partial classes.") 
   end;

   new_context_err(e:AS_NEW_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the `new' expression: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 
   
   new_arg_no_array_err(e:AS_NEW_EXPR) is
      err_loc(e);
      err("`new' expressions only take an argument in classes "
	    "which have an include path to AREF."); 
   end;      
      
   new_no_arg_array_err(e:AS_NEW_EXPR) is
      err_loc(e);
      err("`new' expressions must take an argument specifying "
	    "`asize' in classes which have an include path to AREF."); 
   end;
   
-----------
         
   transform_initial_expr(e:AS_INITIAL_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      -- Append initialization code to `init_stmts'.
      if ~in_post then initial_out_of_post_err(e); return void end;
      if in_initial then nested_initial_err(e); return void end;
      in_initial:=true; 
      te:$AM_EXPR:=transform_expr(e.e,tp); 
      in_initial:=false;
      if void(te) then return void end;
      v::=#AM_LOCAL_EXPR(e.source, void,te.tp);
      cur_rout.locals:=cur_rout.locals.push(v);
      as::=#AM_ASSIGN_STMT(e.source); 
      as.src:=te; as.dest:=v;
      inst::=#AM_INITIAL_STMT(e.source); 
      inst.tp:=impl.tp; inst.stmts:=as;
      if void(init_stmts) then init_stmts:=inst
      else init_stmts.append(inst) end;
      return v; 
   end;
   
   initial_out_of_post_err(e:AS_INITIAL_EXPR) is
      err_loc(e);
      err("`initial' expressions can only occur in `post' clauses.") 
   end;

   nested_initial_err(e:AS_INITIAL_EXPR) is
      err_loc(e);
      err("`initial' expressions may not be nested."); 
   end; 
   
   initial_context_err(e:AS_INITIAL_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the `initial' expression: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 
   
-----------
         
   transform_break_expr(e:AS_BREAK_EXPR, tp:$TP):$AM_EXPR is
      -- Break's must always be handled in expression statements. If
      -- we get here, something's wrong.
      err_loc(e);
      err("`break!' may not appear as a part of an expression.");
      return void; 
   end;

-----------
         
   transform_result_expr(e:AS_RESULT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if in_post=false then result_out_of_post_err(e); return void end;
      if in_initial=true then result_in_initial_err(e); return void end;
      if void(cur_rout.rres) then 
	 if void(cur_rout.sig.ret) then 
	    result_and_no_return_err(e); return void end;
	 cur_rout.rres:=#AM_LOCAL_EXPR(e.source,void,cur_rout.sig.ret) end;
      if ~void(tp) then
	 if ~cur_rout.rres.tp.is_subtype(tp) then
	    result_context_err(e,cur_rout.rres.tp,tp); return void end end;
      r::=cur_rout.rres;
      return r;
   end;

   result_out_of_post_err(e:AS_RESULT_EXPR) is
      err_loc(e);
      err("`result' expressions can only occur in `post' clauses.")
   end;

   result_in_initial_err(e:AS_RESULT_EXPR) is
      err_loc(e);
      err("`result' expressions may not appear in `initial' expressions."); 
   end; 
   
   result_and_no_return_err(e:AS_RESULT_EXPR) is
      err_loc(e); 
      err("`result' expressions may not appear in routines or "
	    "iters without return values."); 
   end;
   
   result_context_err(e:AS_RESULT_EXPR, stp,tp:$TP) is
      err_loc(e); 
      err("The type of the `result' expression: " + stp.str +
	    " is not a subtype of " + tp.str + "."); 
   end; 

-----------
         
   transform_bool_lit_expr(e:AS_BOOL_LIT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if ~void(tp) then
	 if ~TP_BUILTIN::bool.is_subtype(tp) then
	    bool_lit_context_err(e,tp); return void end end;
      r::=#AM_BOOL_CONST(e.source); 
      r.tp_at:=TP_BUILTIN::bool;
      r.val:=e.val; 
      return r; 
   end;

   bool_lit_context_err(e:AS_BOOL_LIT_EXPR, tp:$TP) is
      err_loc(e); 
      err("Boolean literals are not subtypes of " + tp.str + ".");
   end;
   
-----------
         
   transform_char_lit_expr(e:AS_CHAR_LIT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if ~void(tp) then
	 if ~TP_BUILTIN::char.is_subtype(tp) then
	    char_lit_context_err(e,tp); return void end end;
      r::=#AM_CHAR_CONST(e); 
      r.tp_at:=TP_BUILTIN::char;
      return r; 
   end;

   char_lit_context_err(e:AS_CHAR_LIT_EXPR, tp:$TP) is
      err_loc(e); 
      err("Character literals are not subtypes of " + tp.str + ".") 
   end;

-----------
         
   transform_str_lit_expr(e:AS_STR_LIT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if ~void(tp) then
	 if ~TP_BUILTIN::str.is_subtype(tp) then
	    str_lit_context_err(e,tp); return void end end;
      r::=#AM_STR_CONST(e); r.tp_at:=TP_BUILTIN::str;
      return r; 
   end;

   str_lit_context_err(e:AS_STR_LIT_EXPR, tp:$TP) is
      err_loc(e); 
      err("String literals are not subtypes of " + tp.str + "."); 
   end;
   
-----------
         
   transform_int_lit_expr(e:AS_INT_LIT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.
      if e.is_inti then
	 ri::=#AM_INTI_CONST(e); 
	 ri.tp_at:=TP_BUILTIN::inti; 
	 if void(tp) then 
	    return ri
	 elsif ~ri.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of INTI."); return void
	 else 
	    return ri 
         end;
      else
	 r::=#AM_INT_CONST(e); 
	 r.tp_at:=TP_BUILTIN::int; 
	 if void(tp) then 
	    return r
	 elsif ~r.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of INT."); return void
	 else 
	    return r 
         end;
      end;
   end;

-----------
         
   transform_flt_lit_expr(e:AS_FLT_LIT_EXPR, tp:$TP):$AM_EXPR is
      -- Expression implementing `e' in type context `tp'.   
      case e.tp
      when AS_FLT_LIT_EXPR::flt then
	 rf::=#AM_FLT_CONST(e); 
	 rf.tp_at:=TP_BUILTIN::flt; 
	 if void(tp) then 
	    return rf
	 elsif ~rf.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of FLT."); return void
	 else 
	    return rf 
         end;
      when AS_FLT_LIT_EXPR::fltd then
	 rfd::=#AM_FLTD_CONST(e); 
	 rfd.tp_at:=TP_BUILTIN::fltd; 
	 if void(tp) then 
	    return rfd
	 elsif ~rfd.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of FLTD."); return void
	 else 
	    return rfd 
         end;
      when AS_FLT_LIT_EXPR::fltx then
	 rfx::=#AM_FLTX_CONST(e); 
	 rfx.tp_at:=TP_BUILTIN::fltx; 
	 if void(tp) then 
	    return rfx
	 elsif ~rfx.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of FLTX."); return void
	 else 
	    return rfx 
         end;
      when AS_FLT_LIT_EXPR::fltdx then
	 rfdx::=#AM_FLTDX_CONST(e); 
	 rfdx.tp_at:=TP_BUILTIN::fltdx; 
	 if void(tp) then 
	    return rfdx
	 elsif ~rfdx.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of FLTDX."); return void
	 else 
	    return rfdx 
         end;
      when AS_FLT_LIT_EXPR::flti then
	 rfi::=#AM_FLTI_CONST(e); 
	 rfi.tp_at:=TP_BUILTIN::flti; 
	 if void(tp) then 
	    return rfi
	 elsif ~rfi.tp_at.is_subtype(tp) then
	    err_loc(e); err("The type of the destination: " +
	    tp.str + " is not a supertype of FLTI."); return void
	 else 
	    return rfi 
         end;
      end; 
   end;

-----------         

   transform_cluster_expr(e:AS_CLUSTER_EXPR, tp:$TP):$AM_EXPR is
     -- Although clusters belongs to pSather it is translated in serial
     -- Sather as well.
     
     if ~prog.psather then
	-- we allow cluster to appear in SYS::builtin_clusters!
	if     cur_rout.sig.tp = TP_BUILTIN::sys 
           and cur_rout.sig.name = #IDENT("builtin_clusters!") 
	then 
	   asint ::= #AS_INT_LIT_EXPR; 
	   asint.val := #INTI(1);
  	   r ::= #AM_INT_CONST(asint);
	   return r
	else
	   err("`clusters' is a key word of pSather and may not be used in sequential Sather'");
	   return void;
	end;
     else
	if ~void(tp) then
	   if ~TP_BUILTIN::int.is_subtype(tp) then
	      cluster_context_err(e,tp); return void; 
	   end;
	end;
	r::=#AM_CLUSTER_EXPR(e.source);
	return r;
     end;
   end;
   
   cluster_context_err(e:AS_CLUSTER_EXPR, tp:$TP) is
      err_loc(e);
      err("'clusters' (INT) is not a subtype of " + tp.str + ".");
   end;

   transform_cluster_size_expr(e:AS_CLUSTER_SIZE_EXPR, tp:$TP):$AM_EXPR is
     if ~prog.psather then
	err("`cluster_size' is a key word of pSather and may not be used in sequential Sather'");
	return void;
     else
	if ~void(tp) then
	   if ~TP_BUILTIN::int.is_subtype(tp) then
	      cluster_size_context_err(e,tp); return void; 
	   end;
	end;
	r::=#AM_CLUSTER_SIZE_EXPR(e.source);
	return r;
     end;
   end;
   
   cluster_size_context_err(e:AS_CLUSTER_SIZE_EXPR, tp:$TP) is
      err_loc(e);
      err("'clusters_procs' (INT) is not a subtype of " + tp.str + ".");
   end;
   
-----------         

   transform_at_expr(e:AS_AT_EXPR, tp:$TP):$AM_EXPR is
      r::=#AM_AT_EXPR(e.source);
      r.e := transform_expr(e.e,tp);
      if void(r.e) then return void end;  -- Type Error.
      if prog.zones then
	 r.at := transform_expr(e.at, TP_BUILTIN::zone);
      else
	 r.at := transform_expr(e.at, TP_BUILTIN::int);
      end;
      if void(r.at) then return void end; -- Type Error
      return r;
   end;

-----------         

   check_return(t:AS_ROUT_DEF) is
      -- Check the routine `t' to make sure that if it has a return
      -- value, then the last statement actually returns a value.
      -- If not, then print an error.
      if void(t) then return end;
      if void(t.ret_dec) then return end; -- No return value.
      if t.name.is_iter then return end; -- No check for iters.
      if t.is_builtin then return end; -- No check for builtins.
      err_loc(t);
      check_stmt_list_for_return(t.body) end;
   
   check_stmt_list_for_return(l:AS_STMT_LIST) is
      -- `l' must either be a return statement, a raise statement
      -- or terminate in one. If not, print an error.
      t : $AS_STMT := l.stmts;
      if void(t) then return_err; return end;
      s:$AS_STMT:=t; loop until!(void(s.next)); s:=s.next end;
      err_loc(s);
      typecase s
      when AS_DEC_STMT then return_err
      when AS_ASSIGN_STMT then return_err
      when AS_IF_STMT then check_stmt_list_for_return(s.then_part);
	 if ~void(s.else_part) then check_stmt_list_for_return(s.else_part) end;
      when AS_LOOP_STMT then 
	 -- Don't check anything if the last statement is a loop since
	 -- can't be sure. (Maybe later check whether there is a return
	 -- or raise somewhere in the loop.)
	 -- check_stmt_list_for_return(s.body);	 
      when AS_RETURN_STMT then 
      when AS_YIELD_STMT then return_err
      when AS_QUIT_STMT then return_err
      when AS_CASE_STMT then 
	 if ~s.no_else then
	    check_stmt_list_for_return(s.else_part) end;
	 wp:AS_CASE_WHEN:=s.when_part;
	 loop while!(~void(wp));
	    check_stmt_list_for_return(wp.then_part);
	    wp:=wp.next end;
      when AS_TYPECASE_STMT then
	 if ~s.no_else then
	    check_stmt_list_for_return(s.else_part) end;	 
	 wp:AS_TYPECASE_WHEN:=s.when_part;
	 loop while!(~void(wp));
	    check_stmt_list_for_return(wp.then_part);
	    wp:=wp.next end;
      when AS_ASSERT_STMT then return_err
      when AS_PROTECT_STMT then 
	 if ~s.no_else then
	    check_stmt_list_for_return(s.else_part) end;	 
	 wp:AS_PROTECT_WHEN:=s.when_part;
	 loop while!(~void(wp));
	    check_stmt_list_for_return(wp.then_part);
	    wp:=wp.next end;
      when AS_RAISE_STMT then 
      when AS_EXPR_STMT then return_err
      else check_pSather_stmt_for_return(s);
      end;
   end;

   return_err is
      err("Routine must terminate with a `return' statement or a "
	    "`raise' statement."); 
   end;

   name_for_ext(el:ELT):IDENT is
      -- Name to use for an external class call.
      if el.is_abstract or el.sig.is_ext_fortran_sig or 
	       el.sig.is_ext_c_sig then
	 return el.sig.name;
      else 
	 return #IDENT(el.tp.str+'_'+el.sig.name.str);
      end;
   end;

   ------------------------------------------------------------
   -- Everything after this point is concerned with pSather. --
   ------------------------------------------------------------
   
   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.
   attr is_in_par:BOOL;

   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
      else
	 -- True if we are working on a lock
	 return ~void(cur_lock)
      end;
   end;

-----------         

   is_in_par_or_fork:BOOL 
      -- is called in non-pSather programs as well
   is
      if ~prog.psather then return is_in_par;
      else
	 -- True if we are working on a par, parloop, or fork
	 return (cur_rout.is_fork_routine or cur_rout.is_par_routine or 
		 in_simple_par)
      end;
   end;

-----------         

   active_locals_and_params!:AM_LOCAL_EXPR 
      pre prog.psather
   is
      if void(cur_rout) then quit; end;
      -- return parameters (without self) first
      if cur_rout.asize > 1 then
	 loop
	    yield cur_rout.elt!(1).expr;
	 end;
      end;
      -- return locals which are not "nonames" and have a type
      if active_locals.size > 0 then
	 loop
	    loc ::= active_locals.elt!;
	    if ~void(loc.name) and ~void(loc.tp_at) then yield loc; end;
	 end;
      end;
   end;
   
-----------      

   last_declared_helper:AM_LOCAL_EXPR 
      pre prog.psather
   is
      idx ::= active_locals.size;
      loop while!(idx > 0);
	 idx := idx - 1;
	 loc ::= active_locals[idx];
	 if ~void(loc.name) and ~void(loc.tp_at) 
	    and (loc.name.str.size >= 7)
            and (   loc.name.str.head(7) = "_pS_par"  -- par or fork
		 or loc.name.str.head(7) = "_pS_att") 
	 then return loc end;
      end;
      idx := cur_rout.size;
      loop while!(idx > 0);
	 idx := idx - 1;
	 loc ::= cur_rout[idx].expr;
         if ~void(loc.name) and ~void(loc.tp_at) 
	    and (loc.name.str.size >= 7)
	    and (   loc.name.str.head(7) = "_pS_par"  -- par or fork
		 or loc.name.str.head(7) = "_pS_att") 
         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
   is
      idx ::= active_locals.size;
      loop while!(idx > 0);
	 idx := idx - 1;
	 loc ::= active_locals[idx];
	 if ~void(loc.name) and ~void(loc.tp_at) 
	    and loc.name.str.size >= 10
	    and loc.name.str.head(10) = "_pS_par_ob"
	 then return loc end;
      end;
      idx := cur_rout.size;
      loop while!(idx > 0);
	 idx := idx - 1;
	 loc ::= cur_rout[idx].expr;
         if ~void(loc.name) and ~void(loc.tp_at) 
	    and loc.name.str.size >= 10
	    and loc.name.str.head(10) = "_pS_par_ob"
         then return loc end;
      end;
      return void;
   end;  

-----------      

   previous(s:$AS_STMT):$AS_STMT 
      pre 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;
      prev : $AS_STMT;
      loop
	 if void(curr) then break! end;
	 if SYS::ob_eq(curr,s) then return prev end;
	 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
	 err("Iters may only be called within loop statements."); 
      else
	 if void(cur_param_ob) then
	    err("Iters may only be called within loop statements.")
	 elsif cur_rout.is_attach_routine then
	    err("Iters may not be called on the rhs of an attach statement.")
	 else
	    err("Iters need a surrounding loop inside `fork',"+
		 "`par', and `parloop'.");
	 end;
      end;
   end;

-----------      

   transform_pSather_rout_elt_stuff(as:AS_ROUT_DEF) 
      pre prog.psather
   is
      cur_rout.is_par_routine := as.is_par_routine;
      cur_rout.is_fork_routine := as.is_fork_routine;
      cur_rout.is_attach_routine := as.is_attach_routine;
      cur_rout.sig.is_par_routine := cur_rout.is_par_routine;
      cur_rout.sig.is_fork_routine := cur_rout.is_fork_routine;
      cur_rout.sig.is_attach_routine := cur_rout.is_attach_routine;
      if cur_rout.sig.is_forked then
	 cur_param_ob:=cur_rout[1].expr;
	 if  cur_rout.is_par_routine    then cur_par_ob := cur_rout[1].expr end;
	 if ~cur_rout.is_attach_routine then cur_cohort:=cur_rout[2].expr   end;
      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;
      if void(s) then return void end;
      osize:INT;
      if ~void(active_locals) then osize:=active_locals.size end;
      r:$AM_STMT;
      last : $AS_STMT;
      loop while!(~void(s));
	 -- #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);

	 if prog.psather then
	    -- add export before current statement?
	    -- #OUT+"add export before current statement\n";
	    export : $AS_STMT := void; 
	    if ~s.transformed then
	       if cur_rout.export_locals_pending then
		  -- #OUT+"insert export:\n"; AS_OUT::AS_STMT_out(s);
		  if do_helper_export then
		     export := as_for_import_export(export_code,l,s.source);
		  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
		  -- 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);
		  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;
	    if ~void(export) then
	       -- keep import.pending states:
	       ----------------------------------------------------------------
	       imp_local_pending ::= cur_rout.import_locals_pending;
	       imp_call_pending  ::= cur_rout.import_call_pending;
	       -- make new statement list and transform this list into AM form
	       ----------------------------------------------------------------
	       exp_stmt_list ::= #AS_STMT_LIST;
	       exp_stmt_list.stmts := export;
	       -- #OUT+"new export statements in list\n";
	       -- AS_OUT::AS_STMT_LIST_out(exp_stmt_list);
	       exp ::= transform_stmt_list(exp_stmt_list);
	       -- #OUT+"exp erzeugt\n";
	       -- #OUT+"export - appending\n";
	       export.append(s);
	       if void(last) then l.stmts := export;
	       else last.next := export; end;
	       -- #OUT+"done\n";
	       if ~void(exp) then
		  -- #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;
	       if imp_call_pending  then cur_rout.needs_import_call   end;
	    end;
	 end; -- pSather only

	 if void(r) then r:=t; else r.append(t) end;

	 if prog.psather then
	    -- add import after current statement
	    -- #OUT+"add import after current statement\n";
	    if ~s.transformed then
	       if cur_rout.import_locals_pending then 
		  insert_import_after(s) ;
		  -- #OUT+"stmt list after imp loc:\n";
		  -- AS_OUT::AS_STMT_LIST_out(l);
	       end;
	       if cur_rout.import_call_pending then
		  -- 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);
		     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;
	 end; -- pSather only

	 s.transformed := true;
	 last:=s; s:=s.next;
      end;
      -- Close off the scope:
      if ~void(active_locals) then
	 loop while!(active_locals.size>osize); 
	    ignore::=active_locals.pop end;
      end;
      return r; 
   end;

-----------      

   transform_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);      
      r.test:=transform_expr(s.test, TP_BUILTIN::bool);
      if void(r.test) then return void end; -- Not a boolean.

      -- pSather add leading export
      if prog.psather then
	 if ~s.transformed then
	    if cur_rout.import_locals_pending then
	       if ~void(s.then_part) then 
		  insert_import(s.then_part,s.source) end;
	       if ~void(s.else_part) then 
		  insert_import(s.else_part,s.source) end;
	    end;
	    if cur_rout.import_call_pending then
	       if ~void(s.then_part) then
		  sys_imp ::= as_for_sys_import_export(import_code,s.then_part,s.source);
		  sys_imp.transformed := true;
		  sys_imp.append(s.then_part.stmts);
		  s.then_part.stmts := sys_imp;
	       end;
	       if ~void(s.else_part) then
		  sys_imp ::= as_for_sys_import_export(import_code,s.else_part,s.source);
		  sys_imp.transformed := true;
		  sys_imp.append(s.else_part.stmts);
		  s.else_part.stmts := sys_imp;
	       end;
	    end;
	 end;
	 cur_rout.import_done; 
      end; -- pSather only

      r.if_true:=transform_stmt_list(s.then_part);
      r.if_false:=transform_stmt_list(s.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);
      -- Assign test to a local variable.
      r.src:=transform_expr(s.test,void);
      if void(r.src) then return void end; 
      l::=#AM_LOCAL_EXPR(s.source,void,r.src.tp); 
      add_local(l); r.dest:=l;

      if prog.psather then
	 -- pSather add leading export
	 if ~s.transformed then
	    if cur_rout.import_locals_pending then
	       wp ::= s.when_part;
	       loop
		  if void(wp) then break!; end;
		  insert_import(wp.then_part,s.source);
		  wp := wp.next;
	       end;
	       if ~void(s.else_part) then
		  insert_import(s.else_part,s.source);
	       end;
	    end;
	    if cur_rout.import_call_pending then
	       wp ::= s.when_part;
	       loop
		  if void(wp) then break!; end;
		  sys_imp ::= as_for_sys_import_export(import_code,wp.then_part,s.source);
		  sys_imp.transformed := true;
		  sys_imp.append(wp.then_part.stmts);
		  wp.then_part.stmts := sys_imp;
		  wp := wp.next;
	       end;
	       if ~void(s.else_part) then
		  sys_imp ::= as_for_sys_import_export(import_code,s.else_part,s.source);
		  sys_imp.transformed := true;
		  sys_imp.append(s.else_part.stmts);
		  s.else_part.stmts := sys_imp;
	       end;
	    end;
	 end;
	 cur_rout.import_done; 
      end; -- pSather only

      r.next:=transform_case_when(s,s.when_part,l);
      return r;
   end;

-----------         

   insert_import_after(t:$AS_STMT) 
      pre 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 
	 import := as_for_import_export(import_code,t.surr_stmt_list,t.source) 
      end;
      -- #OUT+"import:\n"; AS_OUT::AS_STMT_out(import);              
      if ~void(import) then
        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
   is 
      -- #OUT+"insert_import:\n"; AS_OUT::AS_STMT_LIST_out(l);
      import : $AS_STMT;
      if do_helper_import then 
	 import := as_for_import_export(import_code,l,source) 
      end;
      -- #OUT+"import:\n"; AS_OUT::AS_STMT_out(import);              
      if ~void(import) then
        if ~void(l) then import.append(l.stmts) end;
        l.stmts := import;
        -- #OUT+"remaining stmts:\n"; AS_OUT::AS_STMT_out(import);
      end;
   end;

-----------         
   
   transform_pSather_stmt(s:$AS_STMT):$AM_STMT is
      -- A list of AM_STMT's which implements the source statement `s'.
      if void(s) then return void end;
      r:$AM_STMT;
      if prog.psather then
	 typecase s
	 when AS_PAR_STMT then r:= transform_par_stmt(s)
	 when AS_INTERF_ATTACH_STMT then  r:= transform_interf_attach_stmt(s)
	 when AS_LOCK_STMT then r:= transform_lock_stmt(s)
	 when AS_UNLOCK_STMT then r:= transform_unlock_stmt(s)
	 when AS_WITH_NEAR_STMT then r:= transform_with_near_stmt(s)
	 when AS_ATTACH_STMT then r:= transform_attach_stmt(s)
	 when AS_FORK_STMT then r:= transform_fork_stmt(s)
	 when AS_SYNC_STMT then r:= transform_sync_stmt(s)
	 end;
      else
         -- Simple implementation when full pSather isn't operational.
         -- Implements the threaded but non-synchronizing extension 
         -- in the trivial way.
	 typecase s
	 when AS_PAR_STMT then
	    was::=is_in_par;
	    is_in_par:=true;
	    r:= transform_stmt_list(s.body);
	    is_in_par:=was;
	 when AS_FORK_STMT then
	    if ~is_in_par then fork_outside_par_err(s); return void end;
	    if ~void(s.at) then
	       err_loc(s);
	       warning("Emitting non-psather `@' on fork or parloop");
	    end;
	    r:= transform_stmt_list(s.body);
	 end;
      end;
      return r;
    end;

-----------      

   transform_pSather_assign_stmt_err(s:AS_ASSIGN_STMT) 
      pre prog.psather
   is
      -- A list of AM_STMT's which implements the source statement `s'.
      lhs:$AS_EXPR:=s.lhs_expr; err_loc(lhs); 
      typecase lhs
      when AS_HERE_EXPR then 
	 err("It is illegal to assign to a `here' expression.");
      when AS_ANY_EXPR then 
	 err("It is illegal to assign to an `any' expression.");
      when AS_COHORT_EXPR then
         err("It is illegal to assign to a `cohort' expression.");
      when AS_WHERE_EXPR then 
	 err("It is illegal to assign to a where' expression.");
      when AS_NEAR_EXPR then 
	 err("It is illegal to assign to a `near' expression.");
      when AS_FAR_EXPR then 
	 err("It is illegal to assign to a `far' expression.");
      when AS_AT_EXPR then 
	 err("It is illegal to assign to an `at' expression.");
      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
   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
	 if void(cur_cohort) then
	    cur_cohort := loc;
	 end;
      end;

      if ~s.transformed then
	 s.transformed := true;
	 if ~do_direct_export then return end;

	 -- 1) Find out the appropriate helper object for export
	 ------------------------------------------------------------
	 as : AS_ASSIGN_STMT := void;
	 last_helper ::= last_declared_helper;
	 if void(last_helper) then return end;
	 rel_helper : AM_LOCAL_EXPR;
	 if void(cur_param_ob) then
	    -- not inside of par or fork routine
	    rel_helper := last_helper;
	 else
	    -- inside of par or fork routine
	    rel_helper := 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) 
	 then
	    as := #AS_ASSIGN_STMT;
	    as.source := s.source;
	    as.surr_stmt_list := s.surr_stmt_list;
	    locvar ::= #AS_CALL_EXPR;
	    locvar.source := s.source;
	    locvar.name := loc.name;
	    helploc ::= as_of_local_in_helpers(loc.name,rel_helper,s.source);
	    as.lhs_expr := helploc;
	    as.rhs := locvar;
	    -- #OUT+"immediate export statement:\n";
	    -- AS_OUT::AS_ASSIGN_STMT_out(as);
	    as.next := s.next; s.next := as;
	    -- #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
   is
      -- Create Type for new class
      tp :TP_CLASS := prog.tp_tbl.tp_class_for(helper,orig_cl_params);
      if void(tp) then err("Compiler Err:PTRANS::add_helper_to_tbls") end;
      if ~prog.tp_done.test(tp) then 
	 -- #OUT+"Add Helper to tp_done:"+tp.str+"\n";
	 prog.tp_done := prog.tp_done.insert(tp); 
      end;
      return tp;
   end;

----

   private update_routine_in_tbls(cur_class_tp:TP_CLASS,newrout:AS_ROUT_DEF) 
      pre prog.psather
   is
      -- Update Routine Definition in Interfaces for current type

      sig ::= SIG::rout_sig(newrout,newrout.name,tp_con.ptypes,tp_con);
      if void(sig) then err("Compiler Err:PTRANS::update_rout_in_tbls - 1") end;
      elt ::= #ELT(sig,sig,newrout,tp_con,newrout.is_private);
      if void(elt) then err("Compiler Err:PTRANS::update_rout_in_tbls - 2") end;
      impl ::= cur_class_tp.impl;
      if void(impl) then err("Compiler Err:PTRANS::update_rout_in_tbls - 3") end;
      f:ELT:=impl.elts.elt_same_name_as(elt);
      if void(f) then impl.elts := impl.elts.insert(elt) end;

      -- 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
   is
      -- #OUT+"enter create helper object\n";
      -- Create AS for new class
      as ::= #AS_CLASS_DEF;
      as.source := s.source;
      as.kind := AS_CLASS_DEF::ref;
      as.name := newid_cl;
	 
      class_param ::= orig_class_as.params;
      loop
	 if void(class_param) then break! end;
	 pardec ::= #AS_PARAM_DEC;
	 pardec.source := s.source;
	 pardec.name := class_param.name;
	 if void(as.params) then as.params := pardec 
	 else as.params.append(pardec) end;
	 class_param := class_param.next;
      end;
      
      prog.as_tbl := prog.as_tbl.insert(as);
      tp ::= add_helper_to_tbls(newid_cl,orig_cl_params);

      -- Create Attribute Declarations
      loop loc::=active_locals_and_params!;
	 if     loc.name.str.head(1) /= "_"
	    and (   void(cur_param_ob)
	         or ~local_is_in_par_helpers(loc.name,cur_param_ob))
	 then
  	    var ::= #AS_ATTR_DEF;
	    var.source := s.source;
	    var.name := loc.name;
	    -- #OUT+"Name = "+loc.name.str;	    
	    tps : AS_TYPE_SPEC;
	    if     ~void(loc.as_type)  then
	       if loc.as_type.kind /= AS_TYPE_SPEC::same then
		  tps := loc.as_type;
		  -- #OUT+" (1) ";	       		  
	       else
		  -- SAME
		  tps := loc.tp.as;
		  -- #OUT+" (2) ";	       		  		  
	       end;
	    else 
	       tps := loc.tp.as;
               -- #OUT+" (3) ";	       
	    end;
            -- AS_OUT::AS_TYPE_SPEC_out(tps);
	    var.tp := tps;
	    if void(as.body) then as.body:=var else as.body.append(var); end;
	 end;
      end;

      if is_in_par_or_fork and newid_cl.str.head(7) = "_pS_att" then
	 -- put current cohort into helper object
	 if void(cur_cohort) then err("Compiler Err: PTRANS create helper") end;
	 var ::= #AS_ATTR_DEF;
	 var.source := s.source;
	 var.name := cur_cohort.name;
	 tps ::= #AS_TYPE_SPEC;
	 tps.source := s.source;
	 tps.name := #IDENT("PAR_ATTACH");
	 var.tp := tps;
	 if void(as.body) then as.body:=var else as.body.append(var); end;
      end;

      -- If there is a surrounding par object add this to next helper:
      if ~void(cur_par_ob) then
	 -- this happens inside of a par routine, therefore the current par
	 -- becomes part of the new helper object
	 var ::= #AS_ATTR_DEF;
	 var.source := s.source;
	 var.name := cur_par_ob.name;
	 tps : AS_TYPE_SPEC;
	 if ~void(cur_par_ob.as_type) then tps := cur_par_ob.as_type
	 else tps := cur_par_ob.tp.as end;
	 var.tp := tps;
	 if void(as.body) then as.body:=var else as.body.append(var); end;
      elsif ~void(cur_param_ob) then
	 -- 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;
	 loop
	    elt ::= elts.elt!;
	    if elt.name.str.head(1) = "_" then
	       if ~void(elt.ret) then -- skip writer routine
		  if     elt.name.str.size >= 8 
		     and elt.name.str.head(8) = "_pS_par_"
		  then
		     var ::= #AS_ATTR_DEF;
		     var.source := s.source;
		     var.name := elt.name;
		     tps : AS_TYPE_SPEC;
		     if ~void(elt.as_tp) then tps := elt.as_tp
		     else tps := elt.ret.as end;
		     var.tp := tps;
		     if void(as.body) then as.body:=var 
		     else as.body.append(var); end;
		     break!;
		  end;
	       end;
	    end;
	 end;
      end;
      
      -- Create Create Routine
      crt ::= #AS_ROUT_DEF;
      crt.source := s.source;
      crt.name := #IDENT("create");
      ret_dec ::= #AS_TYPE_SPEC; 
      ret_dec.source := s.source;
      ret_dec.kind := AS_TYPE_SPEC::same;
      crt.ret_dec := ret_dec;
      crtbdy ::= #AS_RETURN_STMT;
      crtbdy.source := s.source;
      crtnew ::= #AS_NEW_EXPR;
      crtnew.source := s.source;
      crtbdy.val := crtnew;
      crt.body := #AS_STMT_LIST;
      crt.body.source := s.source;
      crtbdy.surr_stmt_list := crt.body;
      crtbdy.surr_stmt_list := crt.body;
      crt.body.stmts := crtbdy;
      if void(as.body) then as.body:=crt else as.body.append(crt); end;
      
      -- Create Impl Entry
      impl :IMPL:= tp.impl;
      -- Modify Type Graph
      -- Put Helper Class unter $OB
      dob:TP_CLASS:=TP_BUILTIN::dollar_ob;
      prog.tp_graph_abs_des.add(dob,tp);
      -- Ancestors and Descendants of Helper Class
      ip1 ::= prog.tp_graph.get_anc(tp);
      ip2 ::= prog.tp_graph.get_des(tp);
      
      -- #OUT+"after create of helper object:\n"; AS_OUT::AS_CLASS_DEF_out(as);
      return #AM_LOCAL_EXPR(s.source,newid_ob,tp);
   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
   is
      -- returns AS_node for the following assignment statement:
      -- helper_object ::= #helper_object_class {type_params if any}

      as3 ::= #AS_ASSIGN_STMT;
      as3.source := source;
      as3.name := newid_ob;
      as3.surr_stmt_list := body;
      tp3 ::= #AS_TYPE_SPEC;
      tp3.source := source;
      tp3.name := newid_cl;
      class_param ::= orig_class_as.params;
      loop
	 if void(class_param) then break! end;
	 pardec ::= #AS_TYPE_SPEC;
	 pardec.source := source;
	 pardec.name := class_param.name;
	 if void(tp3.params) then tp3.params := pardec 
	 else tp3.params.append(pardec) end;
	 class_param := class_param.next;
      end;
      rhs3 ::= #AS_CREATE_EXPR;
      rhs3.source := source;
      rhs3.tp := tp3;
      as3.rhs := rhs3;
      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
   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;
      newrout.source := source;
      newrout.name := routname;
      case code
      when par_code then newrout.is_par_routine := true;
      when frk_code then newrout.is_fork_routine := true;
      when att_code then newrout.is_attach_routine := true;
      end;
      argdec0 ::= #AS_ARG_DEC;
      argdec0.source := source;
      argdec0.name := helper_ob;
      argdec0.mode :=#(AS_ARG_MODE::in_mode);
      argdec0tp ::= #AS_TYPE_SPEC;
      argdec0tp.source := source;
      argdec0tp.name := helper_cl;
      class_param ::= orig_class_as.params;
      loop
	 if void(class_param) then break! end;
	 pardec ::= #AS_TYPE_SPEC;
	 pardec.source := source;
	 pardec.name := class_param.name;
	 if void(argdec0tp.params) then argdec0tp.params := pardec 
	 else argdec0tp.params.append(pardec) end;
	 class_param := class_param.next;
      end;
      argdec0.tp := argdec0tp;
      argdec1 ::= #AS_ARG_DEC;
      argdec1.source := source;
      argdec1.name := gate;
      argdec1.mode :=#(AS_ARG_MODE::in_mode);
      if void(gate_tp) then
	 gate_tp := #AS_TYPE_SPEC;
	 gate_tp.source := source;
	 gate_tp.name := #IDENT("PAR_ATTACH");
      end;
      argdec1.tp := gate_tp;
      argdec2 ::= #AS_ARG_DEC;
      argdec2.mode :=#(AS_ARG_MODE::in_mode);
      argdec2.source := source;
      argdec2.name := #IDENT("_pS_at");
      argdec2tp ::= #AS_TYPE_SPEC;
      argdec2tp.source := source;
      argdec2tp.name := #IDENT("INT");;
      argdec2.tp := argdec2tp;
      argdec0.append(argdec1);
      argdec0.append(argdec2);
      newrout.args_dec := argdec0;
      newrout.is_private := true;
      newrout.body := #AS_STMT_LIST;
      newrout.body.source := source;
      
      -- b) Include Routine Definition in Interfaces

      orig_class_as.body.append(newrout);
      update_routine_in_tbls(current_class_tp,newrout);
      
      -- c) Add Initial Var Declaration and Helper Unpack Statements

      decl_stmts : $AS_STMT;
      asdec : AS_DEC_STMT;
      loop loc::=active_locals_and_params!;
	 if    loc.name.str.head(1) /= "_" 
	    or (    newrout.is_attach_routine 
		and ~void(cur_cohort)
		and loc.name = cur_cohort.name)
	 then
	    -- loc : TYPE;
	    asdec := #AS_DEC_STMT;
	    asdec.source := source;
	    asdec.name := loc.name;
	    asdec.surr_stmt_list := newrout.body;
	    if ~void(loc.as_type) then asdec.tp := loc.as_type
	    else asdec.tp := loc.tp.as end;
	    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);
      -- 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!;
	 if     (loc.name.str.head(1) /= "_" 
	         or (    newrout.is_attach_routine
                     and ~void(cur_cohort)
                     and loc.name = cur_cohort.name))
	    and ~local_is_in_par_helpers(loc.name,helper) 
	 then
	    -- loc := _pS_params_ob.loc;
	    asin := #AS_ASSIGN_STMT;
	    asin.source := source;
	    asin.transformed := true;
	    asinlhs ::= #AS_CALL_EXPR;
	    asinlhs.source := source;
	    asinlhs.name := loc.name;
	    asin.lhs_expr := asinlhs;
	    asin.rhs := as_of_local_in_helpers(loc.name,helper,source);
	    asin.surr_stmt_list := newrout.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.
      -- Comment on this comment: We do not have to pass a value, since
      -- this is the translation of the par (and parloop) statement.
      -- A value is only passed when threads are attached to a gate, but that
      -- case is transformed somewhere else.

      -- The call of death is executed at the location of the ATTACH object.
      -- This improves performance and avoids a racing condition in the
      -- Brahma spinlock implementation.
      copy_out_stmts: $AS_STMT;
      if void(orig_gate_tp) then
	 -- Generate a statement.
	 call ::= #AS_EXPR_STMT;
	 call.source := source;
	 call.surr_stmt_list := body;
         -- Genetrate an at-expression.
	 atexpr ::= #AS_AT_EXPR;
	 atexpr.source := source;
	 -- Generate a call expression for ATTACH::death.
	 callexpr ::= #AS_CALL_EXPR;
	 callexpr.source := source;
	 callexpr.name := #IDENT("death");
	 callexprob ::= #AS_CALL_EXPR;
	 callexprob.source := source;
	 callexprob.name := gate;
	 callexpr.ob := callexprob;
	 callexpr.args := void;  -- without at expressions;
	 callexpr.modes:=#(AS_ARG_MODE::in_mode);
	 -- Generate a where expression with the ATTACH obj. 'gate' as argument.
	 whereexpr ::= #AS_WHERE_EXPR;
	 whereexpr.source := source;
	 whereobexpr ::= #AS_CALL_EXPR;
	 whereobexpr.source := source;
	 whereobexpr.name := gate;
	 whereexpr.e := whereobexpr;
	 -- Link all together.
	 atexpr.e := callexpr;
	 atexpr.at := whereexpr;
	 call.e := atexpr;
	 call.transformed := true;  -- will prevent surrounding import/export
	 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);
      else
	 copy_out_stmts.append(as_for_sys_import_export(export_code,newrout.body,source));
      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 
	 if ~void(copy_in_stmts) then 
	    copy_in_stmts.append(body.stmts);
	    body.stmts := copy_in_stmts;
	 end;
      -- prtct.body.stmts.append(copy_out_stmts) 
         body.stmts.append(copy_out_stmts) 
      end;
      
      newrout.body.stmts := decl_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;
      else newrout.body.stmts.append(body.stmts); end;
      return newrout;
   end;      
 
-----------

   link_helper_stmt(newid_ob:IDENT,body:AS_STMT_LIST,
      source:SFILE_ID):AS_ASSIGN_STMT 
      pre prog.psather
   is
      exp : AS_ASSIGN_STMT;
      if ~void(cur_par_ob) then
	 exp := #AS_ASSIGN_STMT;
	 exp.source := source;
	 exp.surr_stmt_list := body;
	 lhs ::= #AS_CALL_EXPR;
	 lhs.source := source;
	 lhsob ::= #AS_CALL_EXPR;
	 lhsob.source := source;
	 lhsob.name := newid_ob;
	 lhs.ob := lhsob;
	 lhs.name := cur_par_ob.name;
	 exp.lhs_expr := lhs;
	 rhs ::= #AS_CALL_EXPR;  
	 rhs.source := source;
	 rhs.name := cur_par_ob.name;
	 exp.rhs := rhs;
      elsif ~void(cur_param_ob) then  -- in fork routine
	 exp := #AS_ASSIGN_STMT;
	 exp.source := source;
	 exp.surr_stmt_list := body;
	 elts : ELT_TBL := cur_param_ob.tp.impl.elts;
	 par_ob : IDENT;
	 loop
	    elt ::= elts.elt!;
	    if elt.name.str.head(1) = "_" then
	       if ~void(elt.ret) then -- skip writer routine
		  if     elt.name.str.size >= 8 
		     and elt.name.str.head(8) = "_pS_par_"
		  then
		     par_ob := elt.name;
		     break!;
		  end;
	       end;
	    end;
	 end;
	 if void(par_ob) then err("Compiler Error: PTRANS:link_helper") end;
	 rhs ::= as_of_local_in_helpers(par_ob,cur_param_ob,source);
	 lhs ::= #AS_CALL_EXPR;
	 lhs.source := source;
	 lhsob ::= #AS_CALL_EXPR;
	 lhsob.source := source;
	 lhsob.name := newid_ob;
	 lhs.ob := lhsob;
	 lhs.name := par_ob;
         exp.lhs_expr := lhs;
	 exp.rhs := rhs;
      end;
      return exp;
   end;

   ---------------------------------------------------------------------------
   is_simple_par_stmt(par_stmt:AS_PAR_STMT):BOOL is
      -- If the statement is "simple", we do not do any weird
      -- and costly transformations. A simple par statement is
      -- the one that contains only "simple" forks
      cursor:AS_STMT_CURSOR := #AS_STMT_CURSOR;
      simple_par:BOOL := true;
      loop
	 stmt:$AS_STMT;
	 stmt := cursor.preorder!(par_stmt.body.stmts);
	 typecase stmt
	 when AS_FORK_STMT then
	    if ~is_simple_fork_stmt(stmt) then
	       simple_par := false;
	       break!;
	    end;
	 when AS_PAR_STMT then
	    if ~is_simple_par_stmt(stmt) then
	       simple_par := false;
	       break!;
	    end;	    
	 else
	 end;
      end;
      
      return simple_par;
   end;
   ---------------------------------------------------------------------------

   -- helper for is_simple+fork_stmts

   is_simple_arg_expr(ae:$AS_EXPR):BOOL is
      e:$AS_EXPR := ae;
      typecase e
      when AS_SELF_EXPR then return true;
      when AS_VOID_EXPR then return true;
      when AS_ARRAY_EXPR then return true;
      when AS_BOOL_LIT_EXPR then return true;
      when AS_CHAR_LIT_EXPR then return true;
      when AS_STR_LIT_EXPR then return true;		     
      when AS_INT_LIT_EXPR then return true;		     
      when AS_FLT_LIT_EXPR then return true;
      when AS_CALL_EXPR then
	 -- may be a simple name
	 -- for now just make sure that it has no args
	 -- A real check will be done during code generation
	 if e.args_size = 0 then
	    return true;
	 end;
      else
      end;
      return false;
   end;
   
   ---------------------------------------------------------------------------

   is_simple_fork_stmt(fork_stmt:AS_FORK_STMT):BOOL is
      s:$AS_STMT;
      if void(fork_stmt.body) then return false; end;
      
      s := fork_stmt.body.stmts;
      typecase s 
      when AS_EXPR_STMT then
	 -- check if call expression
	 e:$AS_EXPR := s.e;
	 typecase e
	 when AS_CALL_EXPR then
	    -- make sure nothing follows the call
	    if void(s.next) then
	       -- a simple fork foo(..) end;
	       -- now have to figure out if the call is "simple" enough
	       -- A simple call contains up to 2 basic expressions as
	       -- arguments
	       
	       -- We are at a very early stage here and cannot obtain 
	       -- a call signature yet because the arguments and or self
	       -- might not have been declared yet. We hope for the best,
	       -- count the number of arguments, make sure they are locals,
	       -- constants or globals and procede optimistically.
	       -- CGEN may later determine that we were wrong (though
	       -- highly unlikely) and bomb with an error message.
	       -- Well, this stuff works only with -O_fast_fork and is
	       -- flakey anyway, so I'll leave it as it is. The problem
	       -- ain't here, but rather in a rather weird and error prone
	       -- syncatic transformations of pSather stuff. Hopefully
	       -- in the future somebody will get rid of it.
	       
	       if e.args_size > 2 then
		  return false;
	       end;
	       
	       -- make sure modes are ok: only in modes allowed for simple case
	       -- for now
	       m:AS_ARG_MODE := e.modes;
	       loop
		  while!(~void(m));
		  if m.mod /= AS_ARG_MODE::in_mode then
		     return false;
		  end;
		  m := m.next;
	       end;
	       
	       -- make sure the args are "simple": 
	       ae:$AS_EXPR := e.args;	       
	       loop
		  while!(~void(ae));
		  if ~is_simple_arg_expr(ae) then return false; end;
		  ae := ae.next;
	       end;

	       -- well, if we get here, there is a good chance we are
	       -- doing the right thing. CGEN will make sure later
	       return true;
	    else
	       return false;
	    end;
	 else
	    return false;
	 end;
      else
	 -- not a simple fork statement
	 return false;
      end;
      return false;
   end;
   
   transform_simple_par_stmt(s:AS_PAR_STMT):$AM_STMT is
      -- a simple par statement: requires no gates or wierd syntactic
      -- transformations. A par statement is "simple" iff all par
      -- and fork statements that it contains syntactically are also
      -- "simple"
      r:AM_PAR_STMT := #AM_PAR_STMT(s.source);

      old_simple_par:AM_PAR_STMT := cur_simple_par;
      cur_simple_par := r;
      
      r.body := transform_stmt_list(s.body);
      
      cur_simple_par := old_simple_par;
      return r;     
   end;
   ---------------------------------------------------------------------------
   
   transform_par_stmt(s:AS_PAR_STMT):$AM_STMT 
      pre prog.psather
	    is
      
      in_simple_par_old:BOOL := in_simple_par;
      if prog.fast_fork then
	 in_simple_par := is_simple_par_stmt(s);
	 if in_simple_par then
	    fast_par_message(s);
	    res:$AM_STMT := transform_simple_par_stmt(s);
	    in_simple_par := in_simple_par_old;
	    return res;
	 else
	    -- the current statement s is not a simple PAR stmt
	    -- hence, the original in_simple_par (now in_simple_par_old)
	    -- was false (simple par stmts must not contain non-simple
	    -- par statements). We do not need to restore in_simple_par
	    -- it is set to the right value anyway
	    -- This saves us from having to deal with the somewhat less
	    -- than bright design that pushes transformed syntax back
	    -- onto the incoming list (leave alone doing this in AS ...)
	    
	    -- inform  about performance consequences
	    expensive_par_warning(s);
	 end;
      end;
      
      ret_as : $AS_STMT;
      if ~void(cur_se) then cur_se.may_block:=true; end;
      if ~void(cur_se) then cur_se.forks:=true; end;
      
      -- 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;
      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;
	 num : INT := 0;
	 if ~void(orig_cl_params) then
	    num := orig_cl_params.size;
	 end;
	 orig_class_as:= prog.parse.tree_for(orig_class_tp.name,num);
      else err("Compiler Error: PTRANS: transform_par: 0");
      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;
      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");
      end;
     
      -- #OUT + "current_class_tp = " + current_class_tp.str + "\n";
      if s.transformed then
	 -- #OUT + "Adding to tables\n";
	 dummy ::= add_helper_to_tbls(s.helper_class,orig_cl_params);
	 update_routine_in_tbls(current_class_tp,s.rout);
	 return void;
      end;
      
      -- 1) Create new identifiers
      ----------------------------------------------------------------------
      
      newidpar    ::= #IDENT(IDENT::next_tmp("par"));
      newidpar_cl ::= #IDENT(IDENT::next_tmp("par_cl"));
      newidpar_ob ::= #IDENT(IDENT::next_tmp("par_ob"));
      newidcohort ::= #IDENT(IDENT::next_tmp("cohort"));
      s.helper_class := newidpar_cl;
      
      -- 2) Create class definition (Helper Object)
      ----------------------------------------------------------------------
      
      helper ::= create_helper_object(s,newidpar_ob,newidpar_cl,
	               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;
      asc.source := s.source;
      asc.name := newidcohort;
      asc.surr_stmt_list := s.surr_stmt_list;
      tpc ::= #AS_TYPE_SPEC;
      tpc.source := s.source;
      tpc.name := #IDENT("PAR_ATTACH");
      rhsc ::= #AS_CREATE_EXPR;
      rhsc.source := s.source;
      rhsc.tp := tpc;
      asc.rhs := rhsc;
      ret_as := asc;
      
      ret_as.append(create_helper_object_stmt(newidpar_ob,newidpar_cl,
            orig_class_as,s.surr_stmt_list,s.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));
      loop loc::=active_locals_and_params!;
         if     loc.name.str.head(1) /= "_" 
	    and (   void(cur_param_ob) 
                 or ~local_is_in_par_helpers(loc.name,cur_param_ob))
         then
            exp ::= #AS_ASSIGN_STMT;
	    exp.source := s.source;
            exp.surr_stmt_list := s.surr_stmt_list;
            exp.lhs_expr:=as_of_local_in_helpers(loc.name,helper,s.source);
            rhs ::= #AS_CALL_EXPR;
	    rhs.source := s.source;
            rhs.name := loc.name;
            exp.rhs := rhs;
            ret_as.append(exp);
         end;
      end;
      ret_as.append(as_for_sys_import_export(export_code,s.surr_stmt_list,s.source));
      
      -- 5) Turn Par Body Into Routine
      ----------------------------------------------------------------------
      
      s.rout := turn_into_routine(newidpar,newidpar_ob,newidpar_cl,helper,
         orig_class_as,current_class_tp,newidcohort,void,s.body,par_code,
	 s.source);
      s.body := void;
      
      -- 6) _pS_par(_pS_par_ob,_pS_cohort);
      ----------------------------------------------------------------------
      
      att8 ::= #AS_INTERF_ATTACH_STMT;
      att8.source := s.source;
      att8.surr_stmt_list := s.surr_stmt_list;
      att8.routname := newidpar;
      att8.helpername := newidpar_ob;
      att8.gatename := newidcohort;
      att8.at := void;
      ret_as.append(att8);
      
      -- 7) Append: lock cohort.no_threads then end;
      --    Then SYS::import;
      ----------------------------------------------------------------------
      
      aslck ::= #AS_LOCK_STMT;
      aslck.source := s.source;
      aslck.surr_stmt_list := s.surr_stmt_list;
      nthr ::= #AS_CALL_EXPR;
      nthr.source := s.source;
      nthrob ::= #AS_CALL_EXPR;
      nthrob.source := s.source;
      nthrob.name := newidcohort;
      nthr.ob := nthrob;
      nthr.name := #IDENT("no_threads");
      tru ::= #AS_BOOL_LIT_EXPR; 
      tru.val := true;
      aslck.if_when_part := #AS_LOCK_IF_WHEN;
      aslck.if_when_part.val := tru;
      aslck.if_when_part.e_list := nthr;
      aslck.else_part := void;
      aslck.no_else := true;
      aslck.transformed := true;
      ret_as.append(aslck);
      ret_as.append(as_for_sys_import_export(import_code,s.surr_stmt_list,s.source));
      
      -- 8) Push replacement statements into statement list
      ----------------------------------------------------------------------
      
      ret_as.append(s.next);
      s.next := ret_as;
      
      -- #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
   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("SYS");
      impexpe.tp := impexpetp;
      case imporexp
      when import_code then impexpe.name := #IDENT("import");
      when export_code then impexpe.name := #IDENT("export");
      end;
      impexp.e := impexpe;
      return impexp;
   end;

-----------         

   as_for_import_export(imporexp:INT,body:AS_STMT_LIST,
      source:SFILE_ID):$AS_STMT 
      pre prog.psather
   is
      as   : AS_ASSIGN_STMT;
      code : $AS_STMT := void;

      last_helper     ::= 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 
	 -- not inside of par or fork routine
	 rel_helper := last_helper;
      else 
	 -- inside of par or fork routine
	 rel_helper := 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!;
	 if loc.name.str.head(1) /= "_" and
--	    (   void(cur_param_ob) 
--           or local_is_in_par_helpers(loc.name,rel_helper))
            local_is_in_par_helpers(loc.name,rel_helper)
	 then
	    -- export: <helpers>.loc := loc;
	    -- import: loc := <helpers>.loc;
  	    as := #AS_ASSIGN_STMT;
	    as.source := source;
	    as.surr_stmt_list := body;
	    as.transformed := true;
	    locvar ::= #AS_CALL_EXPR;
	    locvar.source := source;
	    locvar.name := loc.name;
	    helploc ::= as_of_local_in_helpers(loc.name,rel_helper,source);
	    case imporexp
	    when import_code then
	       as.lhs_expr := locvar;
	       as.rhs := helploc;
	    when export_code then
	       as.lhs_expr := helploc;
	       as.rhs := locvar;
	    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;
        typecase tp
        when TP_CLASS then
           return tp.name = #IDENT("SYS") and s.name = #IDENT("import");
        else 
           return false;
        end;
   end;

   is_sys_export(s:SIG):BOOL is
      tp::=s.tp;
      typecase tp
      when TP_CLASS then
	 return tp.name = #IDENT("SYS") and s.name = #IDENT("export");
      else
	 return false;
      end;
   end;

   has_import(s:SIG):BOOL is
      return s.is_builtin and s.builtin_info.does_import;
   end;

   has_export(s:SIG):BOOL is
      return s.is_builtin and s.builtin_info.does_export;
   end;

   sys_closure_self(sig:SIG) 
      pre 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
	 if has_import(sig) then 
	    cur_rout.needs_import_locals;
	    -- #OUT+" needs import locals";
	    if ~is_sys_import(sig) then
	       cur_rout.needs_import_call;
	       -- #OUT+" and call";
	    end;
	 end;
	 if has_export(sig) then 
	    cur_rout.needs_export_locals;
	    -- #OUT+" needs export locals";
	    if ~is_sys_export(sig) then
	       cur_rout.needs_export_call; 
	       -- #OUT+" and call";
	    end;
	 end;
      end;
      -- #OUT+"]\n";
   end;
  
   sys_closure_nest(ncs:$AM_EXPR) 
      pre prog.psather
   is
      -- transitive closure for SYS::import/export
      -- #OUT+"{";
      if ~void(cur_rout) and ~void(ncs) then
	 typecase ncs
	 when AM_ROUT_CALL_EXPR then
	    if ncs.needs_import then 
	       -- #OUT+ncs.fun.name.str+" needs import";
	       cur_rout.needs_import_locals; 
	    end;
	    if ncs.needs_export then 
	       -- #OUT+ncs.fun.name.str+" needs export";
	       cur_rout.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
   is
      -- #OUT+"Name_of_Local_in_Helper ("+local.str+") ";
      -- #OUT+"in helper ("+helper.name.str+"/"+helper.tp.str+") ";
      
      names ::= #FLIST{IDENT};

      tp ::= helper.tp;
      names := names.push(helper.name);

      if helper.name  = local then
	 return names;
      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;
	    names := names.push(local);
	    break!;
	 end;
	 if found then break! end;
	 found := false;
	 loop
	    elt ::= elts.elt!;
	    -- #OUT+"("+elt.name.str+"?)";
	    if elt.name.str.size>=7 and elt.name.str.head(7) = "_pS_par" then
	       if ~void(elt.ret) then  -- skip writer routine
		  -- #OUT+"in helper ("+elt.name.str+"/"+elt.ret.str+") ";
		  found := true;
		  tp := elt.ret;
		  names := names.push(elt.name);
		  break!;
	       end;
	    end;
	 end;
	 if ~found then
	    -- 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
   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);
      
      if void(names) or names.size < 2 then return false end;
      return (    names[names.size-2].str.size >= 10 
	    and names[names.size-2].str.head(10) = "_pS_par_ob");
   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
   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);
      
      -- Turn list of names into AS tree:
      as:AS_CALL_EXPR;
      loop name ::= names.elt!;
	 if void(as) then as := #AS_CALL_EXPR; as.source := source 
	 else as_new ::= #AS_CALL_EXPR; as_new.source := source;
	    as_new.ob := as; as := as_new;
	 end;
	 as.name := 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
   is

      r::= #AM_ATTACH_STMT(s.source);
      r.helper := local_with_name(s.helpername);
      r.gate   := local_with_name(s.gatename);
      if ~void(s.at) then 
	 if prog.zones then
	    r.at := transform_expr(s.at,TP_BUILTIN::zone) 
	 else
	    r.at := transform_expr(s.at,TP_BUILTIN::int) 
	 end;
      end;
      
      -- Similar to transform_call_expr. This must be done to make the
      -- compiler actually translating the routine
      
      callexpr ::= #AS_CALL_EXPR;
      callexpr.source := s.source;
      callexpr.name := s.routname;
      mod1::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);
      arg1 ::= #AS_CALL_EXPR;
      arg1.source := s.source;
      arg1.name := s.helpername;
      mod2::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);
      arg2 ::= #AS_CALL_EXPR;
      arg2.source := s.source;
      arg2.name := s.gatename;
      mod3::=#AS_ARG_MODE(AS_ARG_MODE::in_mode);
      arg3 ::= #AS_INT_LIT_EXPR;  -- since we only need type, choose arbitrary
      arg3.source := s.source;
      arg3.val := #INTI(0);
      arg1.next := arg2;
      mod1.next := mod2;
      arg2.next := arg3;
      mod2.next := mod3;
      callexpr.args := arg1;
      callexpr.modes := mod1;
      
      -- 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);
      
      if void(callam) then
	 err("Compiler Error: PTRANS: transf_interf_attach: Cannot locate par/fork/attach routine");
      else
	 typecase callam
	 when AM_ROUT_CALL_EXPR then
	    r.rout   := callam.fun;
	 else
	    err("Compiler Error: PTRANS: transf_interf_attach: Cannot locate par/fork/attach Routine");
	 end;
	 cur_rout.calls := cur_rout.calls.push(callam);
      end;
      return r;
   end;  -- of transform_interf_attach_stmt

-----------

   transform_lock_stmt(s:AS_LOCK_STMT):$AM_STMT 
      pre prog.psather
   is
      
      -- pSather add leading export
      if ~void(cur_se) then cur_se.may_block:=true; end;
      if ~s.transformed then
	 iwp ::= s.if_when_part;
	 loop
	    if void(iwp) then break!; end;
	    if void(iwp.then_part) then iwp.then_part := #AS_STMT_LIST; 
	    iwp.then_part.source := s.source; end;
	    -- Insert Import Code before
	    import ::= as_for_sys_import_export(import_code,iwp.then_part,
						s.source);
	    if void(iwp.then_part.stmts) then 
	       iwp.then_part.stmts := import
	    else 
	       import.next := iwp.then_part.stmts; 
	       iwp.then_part.stmts := import 
	    end;
	    --Append Export Code
	    append_export_in_list(iwp.then_part,false); -- at least one export
	    iwp := iwp.next;
	 end;
	 if ~void(s.else_part) then
	    -- Insert Import Code before
	    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;
	    --Append Export Code
	    append_export_in_list(s.else_part,false); -- at least one export
	 end;
      end;
      
      -- semantics checked.

      if void(s) then return void end;
      r::=#AM_LOCK_STMT(s.source);
      
      old_cur_lock::=cur_lock;
      cur_lock := r;
      
      iwp ::= s.if_when_part;
      loop while!(~void(iwp));
	 guardt ::= transform_expr(iwp.val,TP_BUILTIN::bool);
	 
	 locks ::= #ARRAY{$AM_EXPR}(iwp.elts_size);
	 lck ::= iwp.e_list;
	 loop
	    while!(~void(lck));
	    idx ::= 0.up!;
	    locks[idx] := transform_expr(lck,TP_BUILTIN::dollar_lock);
	    lck := lck.next;
	 end;
	 
	 body ::= transform_stmt_list(iwp.then_part);
	 
	 r.guards := r.guards.push(guardt);
	 r.locks := r.locks.push(locks);
	 r.stmts := r.stmts.push(body);
	 
	 iwp := iwp.next; 
      end;
      if ~s.no_else then
	 r.else_stmts := transform_stmt_list(s.else_part);
      end;
      
      cur_lock := old_cur_lock;

      return r;
   end;
   
-----------

   transform_unlock_stmt(s:AS_UNLOCK_STMT):$AM_STMT 
      pre prog.psather
   is
     
      if ~is_in_lock then
	 if is_in_par_or_fork then
	    unlock_in_par_fork_err(s);
	 else
	    unlock_outside_lock_err(s); 
	 end;
	 return void; 
      end;
      
      ret : $AM_STMT;
      
      if ~s.transformed then
	 -- Insert Export before Unlock Statement
	 prev ::= previous(s);
	 export::= as_for_sys_import_export(export_code,s.surr_stmt_list,s.source);
	 export.next := s;
	 if void(prev) then s.surr_stmt_list.stmts := export 
	 else prev.next := export end;
	 ret := transform_stmt(export);
      end;
      
      r::=#AM_UNLOCK_STMT(s.source);
      if void(ret) then ret := r else ret.append(r) end;
      r.lock_ob := transform_expr(s.e,TP_BUILTIN::dollar_lock);
      return ret;
   end;
   
   unlock_outside_lock_err(s:AS_UNLOCK_STMT) 
      pre prog.psather
   is
      err_loc(s);
      err("'unlock' statement must appear inside of `lock'.");
   end;
   
   unlock_in_par_fork_err(s:AS_UNLOCK_STMT) 
      pre prog.psather
   is
      err_loc(s);
      err("'unlock' statement may not not appear inside of `par', `parloop', or `fork'.");
  end;

-----------

   transform_with_near_stmt(s:AS_WITH_NEAR_STMT):$AM_STMT 
      pre prog.psather
   is
     
      r::=#AM_WITH_NEAR_STMT(s.source);
      r.objects :=#ARRAY{$AM_EXPR}(s.elts_size);
      obj ::= s.idents;
      if void(cur_rout) then 
	 err("Compiler Error: PTRANS: transf_with_near_stmt: cur_rout void");
      end;
      loop
	 while!(~void(obj));
         -- obj is of type IDENT
         l:AM_LOCAL_EXPR:=local_with_name(obj.name);
         if void(l) then
	    with_near_locals_only_err(obj);
	    return void;
         end;
         k:INT:=l.tp.kind;
         if (k/=TP_KIND::ref_tp and k/=TP_KIND::spr_tp) then 
	    with_near_non_ref_err(obj); 
	    return void;
         end;
         r.objects.set!(l);
	 obj := obj.next;
      end;
      if s.self_occurred then
	 r.objects[s.elts_size - 1] := cur_rout.self_local;
      end;
      r.near_part := transform_stmt_list(s.near_part);
      r.else_part := transform_stmt_list(s.else_part);
      return r;
   end;
   
   with_near_non_ref_err(i:AS_IDENT_LIST) 
      pre prog.psather
   is
      err_loc(i);
      err("'with near' can't use "+i.name.str+
	    ". (Reference objects only.)");
   end;
   
   with_near_locals_only_err(i:AS_IDENT_LIST) 
      pre prog.psather
   is
      err_loc(i);
      err("`with near' can't use "+i.name.str+
              ". (Locals, arguments and 'self' only.)");
   end;
   
-----------
   private is_of_type_attach(tp:$TP):BOOL is
      typecase tp when TP_CLASS then
         return tp.is_subtype(
            prog.tp_tbl.class_tbl.get_query(#(#IDENT("$ATTACH"),tp.params)));
      end;
   end;

   transform_attach_stmt(s:AS_ATTACH_STMT):$AM_STMT 
      pre prog.psather
   is

      -- #OUT+"entering transform of attach stmt\n";

      if void(s.lhs) then attach_without_attach_err(s); return void end;

      lhs_am ::= transform_expr(s.lhs,void);
      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
	 attach_without_attach_err(s);
      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
      else end;

      if ~void(lhs_as.params) then
	 -- lhs has the form $ATTACH{...}
	 if ~void(lhs_as.params.next) then
	    attach_without_attach_err(s);
	    return void;
	 end;
	 rhs_tp := tp_of(lhs_as.params);
      end;

      -- at this point rhs_tp has the correct result type of the rhs expr
      
      -- strip any at-Expressions:
      
      rhs ::= s.rhs;
      at : $AS_EXPR;
      atexpr : AS_AT_EXPR;
      rhsexpr ::= s.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;
	 else
	    break!
	 end;
	 -- atexpr is AS_AT_EXPR here
	 rhsexpr := atexpr.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));
      else
	 rhs_am  := transform_expr(rhs,rhs_tp);
      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;
      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;
	 num : INT := 0;
	 if ~void(orig_cl_params) then
	    num := orig_cl_params.size;
	 end;
	 orig_class_as:= prog.parse.tree_for(orig_class_tp.name,num);
      else err("Compiler Error: PTRANS: transform_attach: 0");
      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;
      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");
      end;
      
      if s.transformed then
	 dummy ::= add_helper_to_tbls(s.helper_class,orig_cl_params);
	 update_routine_in_tbls(current_class_tp,s.rout);
	 return void;
      end;


      -- 1) Create new identifiers
      ----------------------------------------------------------------------

      newidattach    ::= #IDENT(IDENT::next_tmp("attach"));
      newidattach_cl ::= #IDENT(IDENT::next_tmp("attach_cl"));
      newidattach_ob ::= #IDENT(IDENT::next_tmp("attach_ob"));
      newidgate      ::= #IDENT(IDENT::next_tmp("gate"));
      s.helper_class := newidattach_cl;

      -- 2) Create class definition (Helper Object)
      ----------------------------------------------------------------------

      helper ::= create_helper_object(s,newidattach_ob,newidattach_cl,
	               orig_class_as,orig_cl_params);

      -- 3) insert
      --    newgate ::= lhsexpr
      --    _pS_attach_ob ::= #_pS_attach_cl;
      ----------------------------------------------------------------------

      as1 ::= #AS_ASSIGN_STMT;
      as1.source := s.source;
      as1.surr_stmt_list := s.surr_stmt_list;
      as1.name := newidgate;
      as1.rhs := s.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,
      orig_class_as,s.surr_stmt_list,s.source));

      -- 4) Statements to Fill Helper Object
      ----------------------------------------------------------------------

      ret_as.append(link_helper_stmt(newidattach_ob,s.surr_stmt_list,s.source));
      loop loc::=active_locals_and_params!;
         if     (   loc.name.str.head(1) /= "_" 
	         or (    ~void(cur_cohort)
		     and loc.name = cur_cohort.name))
            and (   void(cur_param_ob)
                 or ~local_is_in_par_helpers(loc.name,cur_param_ob))
         then
            exp ::= #AS_ASSIGN_STMT;
	    exp.source := s.source;
            exp.surr_stmt_list := s.surr_stmt_list;
            exp.lhs_expr := as_of_local_in_helpers(loc.name,helper,s.source);
            rhsx ::= #AS_CALL_EXPR;
	    rhsx.source := s.source;
            rhsx.name := loc.name;
            exp.rhs := rhsx;
            ret_as.append(exp);
         end;
      end;
      ret_as.append(as_for_sys_import_export(export_code,s.surr_stmt_list,s.source));

      -- 5) Turn Attached Expression Into Routine
      --    either newgate.enqueue(rhsexpr);
      --    or     rhsexpr; newgate.enqueue;
      ----------------------------------------------------------------------

      attachbody ::= #AS_STMT_LIST;
      attachbody.source := s.source;
      if ~void(rhs_tp) then
	 call ::= #AS_EXPR_STMT;
	 call.source := s.source;
	 call.surr_stmt_list := attachbody;
	 callexpr ::= #AS_CALL_EXPR;
	 callexpr.source := s.source;
	 callexpr.name := #IDENT("death");
	 callexprob ::= #AS_CALL_EXPR;
	 callexprob.source := s.source;
	 callexprob.name := newidgate;
	 callexpr.ob := callexprob;
	 callexpr.args := rhs;  -- without at expressions;
	 callexpr.modes:=#(AS_ARG_MODE::in_mode);
	 call.e := callexpr;
	 call.transformed := true;  -- will prevent surrounding import/export
	 attachbody.stmts := call;
      else 
	 exprstmt ::= #AS_EXPR_STMT;
	 exprstmt.source := s.source;
	 exprstmt.surr_stmt_list := attachbody;
	 exprstmt.e := rhs;  -- without at expressions;
	 attachbody.stmts := exprstmt;
	 call ::= #AS_EXPR_STMT;
	 call.source := s.source;
	 call.surr_stmt_list := attachbody;
	 callexpr ::= #AS_CALL_EXPR;
	 callexpr.source := s.source;
	 callexpr.name := #IDENT("death");
	 callexprob ::= #AS_CALL_EXPR;
	 callexprob.source := s.source;
	 callexprob.name := newidgate;
	 callexpr.ob := callexprob;
	 call.e := callexpr;
	 call.transformed := true;  -- will prevent surrounding import/export
	 attachbody.stmts.append(call);
      end;

      s.rout:=turn_into_routine(newidattach,newidattach_ob,newidattach_cl,helper,
	 orig_class_as,current_class_tp,newidgate,lhs_as,attachbody,att_code,
         s.source);

      -- 6) _pS_attach(_pS_attach_ob,_pS_gate);
      ----------------------------------------------------------------------

      att8 ::= #AS_INTERF_ATTACH_STMT;
      att8.source := s.source;
      att8.surr_stmt_list := s.surr_stmt_list;
      att8.routname := newidattach;
      att8.helpername := newidattach_ob;
      att8.gatename := newidgate;
      att8.at := at;
      ret_as.append(att8);

      -- 8) Push replacement statements into statement list 
      ----------------------------------------------------------------------

      ret_as.append(s.next);
      s.next := ret_as;

      s.dont_print := true;  -- flag for AS_out that atach must not be printed

      -- #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
   is
      err_loc(s);
      err("':-' statement must have  $ATTACH or $ATTACH{T} expr as lhs");
   end;
 
-----------
   transform_simple_fork_stmt(s:AS_FORK_STMT):$AM_STMT is
      r:AM_FORK_STMT := #AM_FORK_STMT(s.source);
      r.body := transform_stmt_list(s.body);
      r.at := transform_expr(s.at, TP_BUILTIN::int);
      r.par_stmt := cur_simple_par;
      return r;
   end;
   
   expensive_fork_warning(s:AS_FORK_STMT) is
      err_loc(s);
      warning("Expensive fork statement encountered");
   end;
   
   expensive_par_warning(s:AS_PAR_STMT) is
      err_loc(s);
      warning("Expensive par or parloop statement encountered");
   end;   
   
   fast_par_message(s:AS_PAR_STMT) is
      err_loc(s);
      message("Fast par or parloop statement encountered");
   end;      
   
   fast_fork_message(s:AS_FORK_STMT) is
      err_loc(s);
      message("Fast fork statement encountered");
   end;         
   
   transform_fork_stmt(s:AS_FORK_STMT):$AM_STMT 
      pre prog.psather
   is
     
      if ~is_in_par_or_fork then fork_outside_par_err(s); return void end;
      if ~void(cur_se) then cur_se.forks:=true; end;

      -- Filter out an easy case when a simple routine is forked
      -- This could be implemented very efficiently 
      if prog.fast_fork then 
	 if is_simple_fork_stmt(s) then
	    fast_fork_message(s);
	    return transform_simple_fork_stmt(s);
	 else
	    -- inform about performance consequences
	    expensive_fork_warning(s);
	 end;
      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_fork: 0");
--    end;
      
      orig_cl_tp     : $TP := cur_rout.srcsig.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;
	 num : INT := 0;
	 if ~void(orig_cl_params) then
	    num := orig_cl_params.size;
	 end;
	 orig_class_as:= prog.parse.tree_for(orig_class_tp.name,num);
      else err("Compiler Error: PTRANS: transform_fork: 0");
      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;
      current_class_tp : TP_CLASS;
      typecase current_tp
      when TP_CLASS then
  	 current_class_tp := current_tp;
      else err("Compiler Error: PTRANS: transform_pa:r 0");
      end;
      
      if s.transformed then
	 dummy ::= add_helper_to_tbls(s.helper_class,orig_cl_params);
	 update_routine_in_tbls(current_class_tp,s.rout);
	 return void;
      end;
      
      -- 1) Create new identifiers
      ----------------------------------------------------------------------
      
      newidfork      ::= #IDENT(IDENT::next_tmp("fork"));
      newidparams_cl ::= #IDENT(IDENT::next_tmp("params_cl"));
      newidparams_ob ::= #IDENT(IDENT::next_tmp("params_ob"));
      s.helper_class := newidparams_cl;
      
      -- 2) Create class definition (Helper Object)
      ----------------------------------------------------------------------
      
      helper ::= create_helper_object(s,newidparams_ob,newidparams_cl,
	               orig_class_as,orig_cl_params);

      -- 3) _pS_params_ob ::= #_pS_params_cl;
      ----------------------------------------------------------------------
     
      chos ::= create_helper_object_stmt(newidparams_ob,newidparams_cl,
	    orig_class_as,s.surr_stmt_list,s.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));
      loop loc::=active_locals_and_params!;
	 if     loc.name.str.head(1) /= "_" 
	    and ~local_is_in_par_helpers(loc.name,cur_param_ob)
	 then
	    exp ::= #AS_ASSIGN_STMT;
	    exp.source := s.source;
	    exp.surr_stmt_list := s.surr_stmt_list;
	    exp.lhs_expr:=as_of_local_in_helpers(loc.name,helper,s.source);
	    rhs ::= #AS_CALL_EXPR;
	    rhs.source := s.source;
	    rhs.name := loc.name;
	    exp.rhs := rhs;
	    ret_as.append(exp);
	 end;
      end;
      ret_as.append(as_for_sys_import_export(export_code,s.surr_stmt_list,s.source));
      
      -- 5) Turn Fork Body Into Routine
      ----------------------------------------------------------------------

      s.rout := turn_into_routine(newidfork,newidparams_ob,newidparams_cl,helper,
	 orig_class_as,current_class_tp,cur_cohort.name,void,s.body,frk_code,
	 s.source);
      s.body := void;
      
      -- 6) _pS_fork(_pS_params_ob,_pS_cohort);
      ----------------------------------------------------------------------
      
      att8 ::= #AS_INTERF_ATTACH_STMT;
      att8.source := s.source;
      att8.surr_stmt_list := s.surr_stmt_list;
      att8.routname := newidfork;
      att8.helpername := newidparams_ob;
      att8.gatename := cur_cohort.name;
      att8.at := s.at;
      ret_as.append(att8);
      
      -- 7) 
      ----------------------------------------------------------------------
      
      -- 8) Push replacement statements into statement list 
      ----------------------------------------------------------------------
      
      ret_as.append(s.next);
      s.next := ret_as;
      
      -- #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
   is
      err_loc(s);
      err("`fork' statement must appear inside of `par' or `parloop'");
   end;
            
-----------

   transform_sync_stmt(s:AS_SYNC_STMT):$AM_STMT 
      pre prog.psather
   is
      ret : $AM_STMT;
      
      if ~s.transformed then
	 -- Insert Export before Sync Statement
	 prev ::= previous(s);
	 export::=as_for_sys_import_export(export_code,s.surr_stmt_list,s.source);
	 export.next := s;
	 if void(prev) then s.surr_stmt_list.stmts := export 
	 else prev.next := export end;
	 ret := transform_stmt(export);
      end;
      
      r::=#AM_SYNC_STMT(s.source);
      if void(ret) then ret := r else ret.append(r) end;
      if ~void(cur_se) then cur_se.may_block:=true; end;
      
      -- Append Import statement after Sync Statement.
      import::=as_for_sys_import_export(import_code,s.surr_stmt_list,s.source);
      import.next := s.next; s.next := import;
      
      return ret;
   end;

-----------         

   transform_here_expr(e:AS_HERE_EXPR, tp:$TP):$AM_EXPR 
      pre prog.psather or prog.zones
   is
     if ~void(tp) then
       if prog.zones then
	  if ~TP_BUILTIN::zone.is_subtype(tp) then
	    here_context_zone_err(e,tp); return void; 
	  end;
       else
	  if ~TP_BUILTIN::int.is_subtype(tp) then
	    here_context_int_err(e,tp); return void; 
	  end;
       end;
     end;
     r::=#AM_HERE_EXPR(e.source, prog.zones);
     return r;
   end;
   
   here_context_zone_err(e:AS_HERE_EXPR, tp:$TP) 
      pre prog.zones
   is
      err_loc(e);
      err("'here' (ZONE) is not a subtype of " + tp.str + ".");
   end;
   
   here_context_int_err(e:AS_HERE_EXPR, tp:$TP) 
      pre prog.psather and ~prog.zones
   is
      err_loc(e);
      err("'here' (INT) is not a subtype of " + tp.str + ".");
   end;
   
-----------

   transform_any_expr(e:AS_ANY_EXPR, tp:$TP):$AM_EXPR 
      pre prog.psather
   is
     
     if ~void(tp) then
       if ~TP_BUILTIN::int.is_subtype(tp) then
         any_context_err(e,tp); return void; 
       end;
     end;
     r::=#AM_ANY_EXPR(e.source);
     return r;
   end;
   
   any_context_err(e:AS_ANY_EXPR, tp:$TP) 
      pre prog.psather
   is
      err_loc(e);
      err("'any' (INT) is not a subtype of " + tp.str + ".");
   end;
   
-----------

   transform_where_expr(e:AS_WHERE_EXPR, tp:$TP):$AM_EXPR 
      pre prog.psather or prog.zones
   is
     
     if ~void(tp) then
	if prog.zones then
	  if ~TP_BUILTIN::zone.is_subtype(tp) then
	    where_context_zone_err(e,tp); return void; 
	  end;
	else
	  if ~TP_BUILTIN::int.is_subtype(tp) then
	    where_context_int_err(e,tp); return void; 
	  end;
	end;
     end;
     r::=#AM_WHERE_EXPR(e.source, prog.zones);
     -- Check parameter
     r.arg := transform_expr(e.e, TP_BUILTIN::dollar_ob);
     if void(r.arg) then return void end;  -- Type Error.
     return r;
   end;
   
   where_context_zone_err(e:AS_WHERE_EXPR, tp:$TP) 
      pre prog.zones
   is
      err_loc(e);
      err("'where' (ZONE) is not a subtype of " + tp.str + ".");
   end;
   
   where_context_int_err(e:AS_WHERE_EXPR, tp:$TP) 
      pre prog.psather and ~prog.zones
   is
      err_loc(e);
      err("'where' (INT) is not a subtype of " + tp.str + ".");
   end;
   
-----------

   transform_near_expr(e:AS_NEAR_EXPR, tp:$TP):$AM_EXPR 
      pre prog.psather
   is
     
     if ~void(tp) then
       if ~TP_BUILTIN::bool.is_subtype(tp) then
         near_context_err(e,tp); return void; 
       end;
     end;
     r::=#AM_NEAR_EXPR(e.source);
     -- Check parameter
     r.arg := transform_expr(e.e, TP_BUILTIN::dollar_ob);
     if void(r.arg) then return void end;  -- Type Error.
     return r;
   end;
   
   near_context_err(e:AS_NEAR_EXPR, tp:$TP) 
      pre prog.psather
   is
      err_loc(e);
      err("'near' (INT) is not a subtype of " + tp.str + ".");
   end;
   
-----------

   transform_far_expr(e:AS_FAR_EXPR, tp:$TP):$AM_EXPR 
      pre prog.psather
   is
     
     if ~void(tp) then
       if ~TP_BUILTIN::bool.is_subtype(tp) then
         far_context_err(e,tp); return void; 
       end;
     end;
     r::=#AM_FAR_EXPR(e.source);
     -- Check parameter
     r.arg := transform_expr(e.e, TP_BUILTIN::dollar_ob);
     if void(r.arg) then return void end;  -- Type Error.
     return r;
   end;
   
   far_context_err(e:AS_FAR_EXPR, tp:$TP) 
      pre prog.psather
   is
      err_loc(e);
      err("'far' (INT) is not a subtype of " + tp.str + ".");
   end;
   
-----------

   transform_cohort_expr(e:AS_COHORT_EXPR, tp:$TP):$AM_EXPR 
      pre prog.psather
   is
     
      if ~is_in_par_or_fork and void(cur_cohort) then 
	 cohort_outside_par_fork_err(e); 
	 return void;
      end;
      if ~void(tp) then
	 if ~TP_BUILTIN::attach.is_subtype(tp) then
	    cohort_context_err(e,tp); return void; 
	 end;
      end;
      r:AM_LOCAL_EXPR:=local_with_name(cur_cohort.name);
      if void(r) then err("Comp. Err:PTRANS::transf_cohort_xpr");return void end;
      r.source := e.source;
      e.name_after_pSather_trafo := cur_cohort.name;
      return r;
   end;
   
   cohort_outside_par_fork_err(s:AS_COHORT_EXPR) 
      pre prog.psather
   is
     err_loc(s);
     err("'cohort' must not appear outside of `par', `parloop', or `fork'.");
   end;
   
   cohort_context_err(e:AS_COHORT_EXPR, tp:$TP) 
      pre prog.psather
   is
      err_loc(e);
      err("'cohort' (ATTACH) is not a subtype of " + tp.str + ".");
   end;
         
-----------         

   check_pSather_stmt_for_return(t:$AS_STMT) 
      pre prog.psather
   is
      s:$AS_STMT:=t;
      err_loc(s);
      typecase s
      when AS_PAR_STMT then check_stmt_list_for_return(s.body);
      when AS_LOCK_STMT then 
	 if ~s.no_else then check_stmt_list_for_return(s.else_part) end;
	 iwp : AS_LOCK_IF_WHEN := s.if_when_part;
	 loop while!(~void(iwp));
	    check_stmt_list_for_return(iwp.then_part);
	    iwp := iwp.next; end;
      when AS_UNLOCK_STMT then return_err;
      when AS_WITH_NEAR_STMT then check_stmt_list_for_return(s.near_part);
         if ~void(s.else_part) then check_stmt_list_for_return(s.else_part); end;
      when AS_ATTACH_STMT then return_err;
      when AS_FORK_STMT then check_stmt_list_for_return(s.body);
      end;
   end;
   
-----------  
       
   private prev_export(p:$AS_STMT,s:$AS_STMT,l:AS_STMT_LIST) 
      pre prog.psather
   is
      export ::= as_for_sys_import_export(export_code,l,s.source);
      export.next := s; 
      if void(p) then l.stmts := export;
      else p.next := export end;
   end;

   private is_in_loop_and_calls_iter(e:$AS_EXPR):BOOL 
      pre prog.psather
   is
      return (~void(cur_loop) and contains_iter_call(transform_expr(e,void)));
   end;

-----------         

   append_export_in_list(l:AS_STMT_LIST,on_exit_only:BOOL) 
      pre 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; 
      if void(s) then 
	 export ::= as_for_sys_import_export(export_code,l,l.source);
	 l.stmts:=export; 
	 -- AS_OUT::AS_STMT_LIST_out(l);
	 return; 
      end;
      p:$AS_STMT:=void; 
      loop 
	 if is_in_lock then
	    typecase s
	    when AS_ASSIGN_STMT then
	       if is_in_loop_and_calls_iter(s.rhs) then prev_export(p,s,l) end;
	    when AS_ASSERT_STMT then
	       if is_in_loop_and_calls_iter(s.test) then prev_export(p,s,l) end;
	    when AS_EXPR_STMT then
	       e:$AS_EXPR:=s.e;
	       typecase e
	       when AS_BREAK_EXPR then prev_export(p,s,l)
	       when AS_CALL_EXPR then 
		  if     ~void(cur_loop) 
		     and contains_iter_call(transform_call_expr(e,void,false)) 
		  then prev_export(p,s,l) end;
	       when AS_AT_EXPR then 
		  if    is_in_loop_and_calls_iter(e.e)
		     or is_in_loop_and_calls_iter(e.at) 
		  then prev_export(p,s,l) end;
	       else
	       end;
	    when AS_IF_STMT then 
	       if is_in_loop_and_calls_iter(s.test) then prev_export(p,s,l) end;
	       append_export_in_list(s.then_part,true); -- on exit only
	       append_export_in_list(s.else_part,true); -- on exit only
	    when AS_LOOP_STMT then 
	       append_export_in_list(s.body,true); -- on exit only
	    when AS_CASE_STMT then 
	       if is_in_loop_and_calls_iter(s.test) then prev_export(p,s,l) end;
	       if ~s.no_else then append_export_in_list(s.else_part,true) end; 
	       wp:AS_CASE_WHEN:=s.when_part;
	       loop while!(~void(wp));
		  append_export_in_list(wp.then_part,true); -- on exit only
		  wp:=wp.next end;
	    when AS_TYPECASE_STMT then
	       if ~s.no_else then append_export_in_list(s.else_part,true) end;	 
	       wp:AS_TYPECASE_WHEN:=s.when_part;
	       loop while!(~void(wp));
		  append_export_in_list(wp.then_part,true); -- on exit only
		  wp:=wp.next end;
	    when AS_WITH_NEAR_STMT then 
	       append_export_in_list(s.near_part,true); -- on exit only
	       append_export_in_list(s.else_part,true); -- on exit only
	    when AS_LOCK_STMT then
	       iwp ::= s.if_when_part;
	       loop 
		  if void(iwp) then break! end;
		  lck : $AS_EXPR := iwp.e_list; 
		  loop while!(~void(lck)); 
		     if is_in_loop_and_calls_iter(lck) 
		     then prev_export(p,s,l) end;
		     lck := lck.next;
		  end;
		  iwp := iwp.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 
	 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);
	    s.append(export); 
	 end;
      end;
      -- AS_OUT::AS_STMT_LIST_out(l);
   end;
end; -- class TRANS
-------------------------------------------------------------------


