------------------------->  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>  <--------------

class CGEN < $BACK_END is
   include CS_COMPONENT;
   include FORTRAN_CALL;
   include FORTRAN_ROUTINE;
   include C_CALL;
   include C_ROUTINE;
   
   -- back-end C generation from an AM structure.

   -- These are options that may be set from outside CGEN.

   attr c_flags:FLIST{STR};	-- Flags to pass to C compiler
   attr externals:FMAP{STR,FSET{STR}}; -- Files linked if class reachable
   attr executable:STR;		-- The executable to output, or void

   attr optimize:BOOL;		-- Attempt optimizations
   attr debug:BOOL;		-- Generate debugging information
   attr deterministic:BOOL;	-- generate id determinism
   attr type_tables:BOOL;	-- generate type tables
   attr func_tables:BOOL;	-- generate func tables
   attr print_ob:BOOL;		-- generate PO() function
   attr print_ob_g:BOOL;	-- generate POG() function
   attr force_routines:FSET{STR}; -- Routines to be generated no matter what
   attr force_all:BOOL;		-- Force all generation
   attr gen_c:BOOL;		-- If true, generate C files
   attr only_C:BOOL;		-- Stop after making C
   attr only_check:BOOL;	-- Don't do code generation
   attr c_files:FSET{STR};	-- C source files
   attr object_files:FSET{STR};	-- object files
   attr archive_files:FLIST{STR}; -- `library' archive files
   attr pretty:BOOL;		-- Make generated C look nice
   attr builtin_cntr_n:INT;	-- used to make uniq vars for builtins
   attr func_name_comment:STR;	-- printed in the function comment
   attr func_name_suffix:STR;	-- name used as suffix for functions that expect some
			        -- arguments to be near (pSather only)
   attr no_destroy:BOOL;	-- if true AM nodes may not be destroyed,
				-- as they will be reused.
   attr no_destroy_lock:BOOL;	-- if true AM nodes may not be destroyed,
				-- as they will be reused.


   shared max_identifier_length:INT := 24;
   -- Maximum allowed identifier length. Used by mangle (ben).
   -- Must be set before mangler is created. The mangler may use fewer characters, since it
   -- leaves some space for names to be uniquified.

   -- Options garnered from CONFIG file
   attr fortran_append_underscore:STR;
   attr fortran_prepend_underscore:STR;
   attr fortran_bind_func:BOOL;
   attr null_segfaults:BOOL;
   attr polling:BOOL;		-- currently only true or false

   attr ignore_lock:BOOL;	-- gross hack, search for the attribute 
			        -- inside cgen for more information.
   
   attr mangler:MANGLE;
   attr gen:GENERATE_AM;

   -- These are private state needed for the translation.

   private attr in_bnd_rout_call:BOOL; -- true if we are generating the stub for
   -- bound routines (only needed with print_ob)
   
   private attr in_bnd_iter_call:BOOL; -- true if we are generating the stub for
   -- bound iter (only needed with print_ob) 

   private attr options:CS_OPTIONS; -- Typesafe options

   private attr indent:INT;	-- current level of indentation

   private attr state_counter:INT; -- for yield goto's
   
   -- esc: Added flag files to avoid unnecessary recompilation 
   --private attr sather_h, tags_h, makefile:CODE_FILE;
   readonly attr sather_h, tags_h, makefile, comp_options, 
	 link_options:CODE_FILE;

   private attr code_c, system_c, dispatch_c, unbox_c, strings_c:CODE_FILE;
   private attr print_c:CODE_FILE;
    
   attr globals_c:CODE_FILE;
   -- The header and C files.

   private attr code_dir:STR;
   -- The directory all this happens in

   private attr needs_tag:FSET{$TP};
   -- Types which will need tags assigned

   readonly attr tags:FMAP{$TP,INT};
   -- Integers associated with classes

   private attr main_sig:SIG;
   -- SIG corresponding to main

   private attr current_sig:SIG;
   -- SIG of current function being translated

   private attr current_am_rout_def:AM_ROUT_DEF;
   -- AM_ROUT_DEF of current function being translated

   private attr current_function_str:STR;
   -- Name of current function being translated

   private attr current_arg_list:ARRAY{STR};
   -- mangled names of args of current function
   
   private attr current_iter_out_arg_locals:FLIST{AM_LOCAL_EXPR};
   -- iter locals used in place of out/inout args to ensure value/result
   -- semantics 
   
   private attr saw_outer_return:BOOL;
   -- was a return at outer level seen in this routine?

   private attr chk_pre, chk_post, chk_invariant, chk_assert,
	 chk_arith, chk_bounds, chk_void, chk_when, chk_return:BOOL;
   -- whether different checks are on for the current function
   
   attr nested_its:FMAP{AM_ROUT_DEF,FLIST{AM_ITER_CALL_EXPR}};
   -- Stack of iter calls

   attr nested_bits:FMAP{AM_ROUT_DEF,FLIST{AM_BND_ITER_CALL_EXPR}};
   -- Map of biter calls
   
   private attr current_loop:STR;
   -- label to goto to at end of loop

   private attr abstract_routs:FLIST{AM_ROUT_DEF};
   -- List of abstract routines to make dispatch tables for

   private attr abstract_iters:FLIST{AM_ROUT_DEF};
   -- List of abstract iters to make dispatch tables for

   private attr bnd_rout_creates:FLIST{AM_BND_CREATE_EXPR};
   private attr bnd_rout_creates_done:FLIST{AM_BND_CREATE_EXPR};
   -- List of bound routine stubs to generate
   -- and list of bound routine stubs generated
   
   private attr bnd_iter_creates:FLIST{AM_BND_CREATE_EXPR};
   -- List of bound iter stubs to generate
   
   private attr itersig_map: FMAP{SIG,AM_ROUT_DEF};
   -- an auxiluary datastructure which is filled in emit_am_bnd_iter_create
   -- to map iter sigs to their am_rout_defs, which is needed across
   -- code_file boundaries
   
   private attr arg_frames:FSET{SIG};
   -- List of routs to generate arg frames for

   private attr emitted_iter_allocators:FSET{SIG};
   -- List of dispatched iters for which allocators have been generated

   private attr routine_code:FSTR;
   -- code waiting to be emitted

   private attr str_count:INT;
   -- number of STR constants emitted (for making their id)

   private attr string_constants:FMAP{STR,STR};
   -- cache of emitted string constants, so we don't duplicate them

   private attr not_emitted:FMAP{SIG,AM_ROUT_DEF};
   -- routines not initially emitted because they were inlined
    
   private attr leftovers:FSET{AM_ROUT_DEF};
   -- routines that need to be generated even though inlined

   private attr emitted_leftovers:FSET{AM_ROUT_DEF};
   -- leftover routines that have been already emitted

   private attr routine_count:INT;
   -- count of emitted routines, reset for each new file

   private attr inlined_iter_count:INT;
   -- count of how many iters got inlined

   private attr code_files:FMAP{$TP,CODE_FILE};

   private attr abstract_calls, concrete_calls,
	 inlined_value_ob_eq_calls,
	 inlined_pointer_ob_eq_calls:INT;

   private attr ex_nesting, current_loop_ex_nesting:INT; 
   -- Number of protects we are in syntactically, so that we
   -- can pop out on a iterator quit, or a return.

   readonly attr comp_home:STR;
   -- The location of the SHOME variable in the generated Makefile.
   -- This is different than prog.home if relative path names are used

   private attr in_constant:BOOL;
   -- true if the translated expression occurs in
   -- constant initialization code (to bypass inlining)

   private attr manual_unlock:BOOL;
   -- true if the current code is in a lock statment that has to be manually
   -- unlocked before leaving the function

   private attr manual_loop_unlock:BOOL;
   -- true if the current code is inside a lock statement that has to 
   -- be manually unlocked before leaving the lock.

   private attr siva:BOOL;
   -- Generate calls for the Siva interface.

   attr threshold:INT;		-- How big to make files before splitting up.

   create(p:PROG):SAME is

      res::=new;
      res.prog:=p;
      LAYOUT_TBL::prog:=p;
      LAYOUT_TBL::cgen:=res;
      res.threshold:=150_000;	-- Default target size of 150KB per C file
      return res;

      -- Most initialization really occurs when "init" is called.

   end;

   init is
      -- initialization should occur after the layouts and sigs have
      -- been constructed
      if only_check then return; end;
      if max_identifier_length = 0 then max_identifier_length := 24 end;
      if prog.psather then type_tables:=true; end;
      polling:=#INT(prog.config.get_str("POLLING",0))>0;

      null_segfaults:=BOOL::from_str(prog.config.get_str("NULL_SEGFAULTS",0));
      need_to_append ::= prog.config.get_bool("FORTRAN_APPEND_UNDERSCORE");
      if need_to_append then
	 fortran_append_underscore := "_";
      end;
      
      need_to_prepend ::= prog.config.get_bool("FORTRAN_PREFIX_UNDERSCORE");
      if need_to_prepend then
	 fortran_prepend_underscore := "_";
      end;
      
      -- if using exotic name mangling, call the appropriate mangling
      -- function
      fortran_bind_func := prog.config.get_bool("FORTRAN_BIND_FUNC");      

      if force_all or ~force_routines.is_empty then
	 warning("-force options not implemented");
      end;

      mangler:=#MANGLE(prog);
      -- mangle_force all builtin classes
      d::=prog.config.get_def("BUILTIN_CLASSES");
      loop e::=d.elt!;
	 loop
	    c::=e.elt!;
--	    if c[0]='$' then
--	       c:=c.tail(c.size-1);
--	    end;
--	    
--	    mangler.force_mangle(prog.tp_tbl.tp_class_for(#IDENT(e.elt!),void),c,void);
	    tp_class:TP_CLASS:=prog.tp_tbl.tp_class_for(c);
	    class_name:STR; 
	    nm::=tp_class.name.str;
	    if nm[0] = '$' then
	       class_name := nm.tail(nm.size-1);
	    else
	       class_name := nm;
	    end;
	    
	    loop
	       pname::=tp_class.params.elt!.str;
	       class_name := class_name.append("_",pname);
	    end;
	    mangler.force_mangle(tp_class,class_name,void);
	 end;
      end; 
      


      op::=prog.get_options;
      typecase op when CS_OPTIONS then options:=op; end;
      genam::=prog.generate_am;
      typecase genam when GENERATE_AM then gen:=genam; end;
      nested_its:=#;
      nested_bits:=#;
      abstract_routs:=#;
      abstract_iters:=#;
      not_emitted:=#;
      leftovers:=#;
      emitted_leftovers:=#;
      bnd_rout_creates:=#;
      bnd_rout_creates_done:=#;
      bnd_iter_creates:=#; 
      --frames:=#;
      arg_frames:=#;
      emitted_iter_allocators:=#;
      str_count:=1;
      string_constants:=#;
      --routs_with_frames:=#;
      emitted_dispatch_wrappers:=#;
      code_files:=#;

      indent:=0;

      abstract_calls:=0;
      concrete_calls:=0;
      inlined_value_ob_eq_calls:=0;
      inlined_pointer_ob_eq_calls:=0;

      in_constant := false;

      code_dir:=executable+".code";

      CODE_FILE::set_directory(prog,code_dir);

      sather_h:=#CODE_FILE("sather.h");
      tags_h:=#CODE_FILE("tags.h");
      
      -- esc: Added flag files to avoid unnecessary recompilation
      makefile:=#CODE_FILE("Makefile");
      comp_options:=#CODE_FILE("COMPILE_OPTIONS");
      link_options:=#CODE_FILE("LINK_OPTIONS");

      -- The system code is special; it doesn't bother with
      -- the checking macros definitions.
      system_c:=#CODE_FILE("system.c");
      code_files:=code_files.insert(TP_BUILTIN::sys,system_c);
      system_c.is_c_code:=true;
      system_c.do_not_merge:=true;

      globals_c:=#CODE_FILE("globals.c");
      globals_c.is_c_code:=true;
      globals_c.do_not_merge:=true;

      strings_c:=#CODE_FILE("strings.c");
      strings_c.is_c_code:=true;
      strings_c.do_not_merge:=true;

      dispatch_c:=#CODE_FILE("dispatch.c");
      dispatch_c.is_c_code:=true;

      unbox_c:=#CODE_FILE("unbox.c");
      unbox_c.is_c_code:=true;
      if print_ob or print_ob_g then unbox_c+"\n#define FF (*pFF)\n"; end;

      comp_home:=prog.home;
      if comp_home[0]/='/' then comp_home:="../"+comp_home; end; 

      sather_h+"#ifndef _SATHER_H_\n#define _SATHER_H_\n";
      if print_ob or print_ob_g then sather_h+"#define PRINT_PO\n"; end;
      if (print_ob or print_ob_g) and func_tables then sather_h+"#define PRINT_BACKTRACE\n"; end;
      if print_ob_g then sather_h+"#define PRINT_POG\n"; end;
      if deterministic then sather_h+"#define DETERMINISTIC\n"; end;
      if debug then sather_h+"#define DEBUG\n"; end;
      if options.destroy_chk then sather_h+"#define DESTROY_CHK\n"; end;
      if null_segfaults then sather_h+"#define NULL_SEGFAULTS\n"; end;
      if options.stats then sather_h+"#define STATS\n"; end;

      -- The Siva interface is used whenever zones:true in the platform
      -- config file.  However, zones may not actually be in the interface
      -- the programmer sees unless "-zones" is passed.  So two different
      -- macros are used to distinguish these two cases.
      if prog.config.get_bool("ZONES") then 
	 siva:=true;
	 sather_h+"#define SIVA\n"; 
      end;
      if prog.zones then sather_h+"#define ZONES\n"; end;

      if options.cache then 
	 sather_h+"#define IMPORT_CACHE\n"+
	          "#define IMPORT_CACHE_SIZE "+options.cache_size+"\n"+
		  "#define IMPORT_CACHE_TRESHOLD "+options.cache_slot_size+"\n";
      end;
      if polling then sather_h+"#define POLLING\n"; end;

      sather_h+"#include \""+comp_home+"/System/Common/header.h\"\n";
      loop
	 n::=prog.platforms.elt!;
	 if n[0]/='/' then n:="../"+n; end;
         sather_h+"#include \""+n+"/header.h\"\n";
      end;

      sather_h+"#endif\n";

      needs_tag:=#;
      tags:=#;
      --neg_tag_count:=1;
      --pos_tag_count:=1;

      main_sig:=prog.get_main_sig.main_sig;

   end;

   -- iter_frame return "frame->" if current_sig.is_iter, "" otherwise
   iter_frame:STR is
      if current_sig.is_iter then
         return "frame->";
      else
         return "";
      end;
   end;

   -- mangling is all done by the mangler.  The common uses are delegated
   -- here, with a single shared namespace associated with the back-end
   -- itself by default.

   private mang(ob:$OB):STR is	
      return mangler.mangle(ob,void);
   end;

   private mang(ob,ns:$OB):STR is
      return mangler.mangle(ob,ns);
   end;
   
   builtin_cntr:INT is
      builtin_cntr_n:=builtin_cntr_n+1;
      return builtin_cntr_n;
   end;

   private forbid(s:STR) is mangler.forbid(s); end;

   -- Because local variables have to precede any use, it is necessary to
   -- queue up code until all the locals that will be needed have been
   -- discovered.  This is done by using the following calls.

   private in is indent:=indent+1; end;
   -- move indentation in a logical level

   private move_out is indent:=indent-1; end;
   -- move indentation out a logical level 

   private defer_newline is	-- start a new line in queued-up code
      routine_code:=routine_code+eol;
      loop indent.times!; routine_code:=routine_code+' '; end;
   end;

   private newline is code_c+eol; loop indent.times!; code_c+' '; end; end;
   -- start a new line to code file

   private attr last_lineno:INT;
   private attr last_file:STR;
   private announce_at(s:SFILE_ID) is
      if debug or pretty then
	 -- terminate current C line and emit #line directive
	 lineno:INT:=s.line_num_in;
	 if lineno>0 then
	    prog.set_eloc(s);
	    if lineno=last_lineno+1 and last_file=s.file_in then
	       if pretty then 
		  routine_code:=routine_code+"\n/* #line "+lineno+" "
			+" \""+s.file_in+"\"*/\n";
	       else
		  routine_code:=routine_code+'\n';
	       end;
	    elsif lineno=last_lineno and last_file=s.file_in then
	       -- do nothing
	    else
	       if debug then
		  routine_code:=routine_code+"\n#line "+lineno+" "
			+" \""+s.file_in+"\"\n";
	       else
		  routine_code:=routine_code+"\n/* #line "+lineno+" "
			+" \""+s.file_in+"\"*/\n";
	       end;
	    end;
	    last_lineno:=lineno;
	    last_file:=s.file_in;
	 end;
      end;
   end;

   private eol:STR is
      -- generate a newline or backslash newline, depending on whether
      -- or not debugging #line directives are happening.

      -- For some reason, backslash-newline doesn't seem to work.  So
      -- I've taken them out :-(

      if debug then
	 if pretty then return "\n#line "+last_lineno+"\n";
	 else return "";
	 end;
      else return "\n";
      end;
   end;

   private defer(s:STR) is routine_code:=routine_code+s; end;
   -- queue up code for emmission

   private ndefer(s:STR) is defer_newline; routine_code:=routine_code+s; end;
   -- same as defer but emits preceding newline

   private comment(f:CODE_FILE,com:STR) is
      -- make a C comment
      if pretty then f+" /* "+com+" */"; end;
   end;

   private comment(com:STR) is
      -- make C comment in routine_code.  Has newline.
      if pretty then ndefer("/* "+com+" */"); end;
   end;

   private dec_am_local_expr_out(t:$TP):AM_LOCAL_EXPR is
      -- declare a local and return a pointer to it
      am::=#AM_LOCAL_EXPR(void);
      am.tp_at:=t;
      am.not_in_frame:=true;
      code_c+eol+' '+mang(t)+" *"+emit_am_local_expr(am)+';';
      return am;
   end;

   private dec_am_local_expr(t:$TP):AM_LOCAL_EXPR is
      -- decalre a local and return a corresponding AM_LOCAL_EXPR;
      am::=#AM_LOCAL_EXPR(void);
      am.tp_at:=t;
      am.not_in_frame:=true;
      code_c+eol+' '+mang(t)+' '+emit_am_local_expr(am)+';';
      return am;
   end;

   private dec_local(t:$TP):STR is
      -- declare local with no comment
      res::=mangler.genlocal(current_sig);
      code_c+eol+' '+mang(t)+' '+res+';';
      return res;
   end;
   
   private dec_local_for_arg(a:AM_FORMAL_ARG, sig:SIG, s:STR): STR is
      -- declare local of type a.tp initialized to s
      -- To be used instead of arg in out/inout args
      res::=mangler.space(sig).next_unique_with_prefix("L");
      -- force the mangling of the argument expr
      mangler.force_mangle(a.expr, res, sig);
      code_c+eol+' '+mang(a.tp)+' '+res+" = " + s + ';' + "/*Local for arg*/";
      return res;
   end;

   private dec_local_object(t:$TP):STR 
   -- declare local object (not reference) of reference type t
   -- used in implementation of out/inout arguments
   is
      res::=mangler.genlocal(current_sig);
      code_c+eol+' '+mang(t)+"_struct "+res+';';
      return res;
   end;

   private dec_local_ptr(t:$TP):STR is
      -- declare local pointer to type t
      -- used in implementation of out/inout arguments
      res::=mangler.genlocal(current_sig);
      code_c+eol+' '+mang(t)+"* "+res+';';
      return res;
   end;

   private dec_local_ptr_comment(t:$TP,com:STR):STR is
      -- declare local pointer to type t
      -- used in implementation of out/inout arguments
      res::=mangler.genlocal(current_sig);
      code_c+eol+' '+mang(t)+"* "+res+';';
      comment(code_c,com);
      return res;
   end;
   
   private dec_local_comment(t:$TP,com:STR):STR is
      res::=dec_local(t);
      comment(code_c,com);
      return res;
   end;

   am_ob_def_for_tp(tp:$TP):AM_OB_DEF is
      -- The object layout for the type `tp'.
      impl::=tp.impl;
      if void(impl) then return void end;
      r::=#AM_OB_DEF(void);
      r.tp:=impl.tp;
      if ~void(impl.arr) then a::=impl.arr;
	 typecase a when TP_CLASS then r.arr:=a.params[0] end end;
      r.asize:=impl.asize_val;
      if r.asize /= -1 then
	 code_c.uses_extern("extern INT ".append(mang(tp),"_asize;",eol));
      end;
      loop e::=impl.elts.elt!; 
	 if e.is_attr_reader then 
	    r.at:=r.at.insert(e.sig.name,e.sig.ret)
	 end;
      end;
      sorted_attrs:ARRAY{IDENT} := #ARRAY{IDENT}(r.at.size);
      loop sorted_attrs.set!(r.at.keys!) end;
      sorted_attrs.sort;
      r.sorted_at := sorted_attrs;
      return r;
   end;
   
   private set_chks is
      -- set checking states for this function

      n::=current_sig.tp.str;
      chk_pre:=options.pre_chk(n);
      chk_post:=options.post_chk(n);
      chk_invariant:=options.invariant_chk(n);
      chk_assert:=options.assert_chk(n);
      chk_arith:=options.arith_chk(n);
      chk_bounds:=options.bounds_chk(n);
      chk_void:=options.void_chk(n);
      chk_when:=options.when_chk(n);
      chk_return:=options.return_chk(n);
   end;

   emit(func:AM_ROUT_DEF) is

      announce_at(func.source);

      if only_check then return; end;

      if prog.show_am then #OUT+"Generating C for "+func.sig.str+'\n'; end;
      if func.sig=main_sig then
	 mangler.force_mangle(func.sig,"sather_main",void);
	 system_c.uses_sig(func.sig);
      end;
	
      if func.is_abstract then
	 if ~func.is_iter then
	    abstract_routs:=abstract_routs.push(func);
	 else
	    abstract_iters := abstract_iters.push(func);		
	 end
      else
	 -- Ivin: do emit code for inlined recursive functions.
	 if prog.inliner.inlined(func.sig) and
		  ~prog.generate_am.sig_recursive.test(func.sig) then
	    not_emitted:=not_emitted.insert(func.sig,func);
	    -- it's inline, so don't bother generating it now;
	    -- it will get generated if used in a dispatch table or as biter
	    
	    -- registery needed to retrieve am_rout_defs of iters from their
	    -- signatures, whenever they have been inlined, note a similar map
	    -- exists, namely not_emitted, it cannot be used since it is used
	    -- jointly with leftovers, see make_sure_emitted and generate_bnd_iter
	    -- map is also used in emit_am_bnd_iter_create, to store itersigs
	    -- for later use
	    if func.sig.is_iter then
	       itersig_map := itersig_map.insert(func.sig,func); end;
	 
	 elsif ~func.sig.is_builtin_routine then
	    emit_routine(func);
	 end;
      end;
   end;
   
   private code_file_for_tp(t:$TP,srcloc:SFILE_ID):CODE_FILE is
      cc::=code_files.get(t);
      if void(cc) then 
	 mangled_file_name:STR;
	 if ~void(srcloc) then
	    source_file_name:STR := srcloc.file_in;
	    -- Here we should choose some portion of the sather file
	    -- name to append to the class name.  When sorting the
	    -- codefiles, stuff that in related sather files stays
	    -- closer together
	    nchars:INT := source_file_name.size;
	    clean_name:FSTR := #FSTR(nchars);
	    last_dir_point:INT := 0;
	    loop i:INT := nchars.times!;
	       c:CHAR := source_file_name[i];
	       case c
	       when '.' then clean_name := clean_name+'_';
	       when ' ' then clean_name := clean_name+'_';
	       when '/' then clean_name := clean_name+'_'; last_dir_point := i+1;
	       when '\\' then clean_name := clean_name+'_'; last_dir_point := i+1;
	       else clean_name := clean_name+c;
	       end;
	    end;
	    clean_name_str:STR := clean_name.str;
	    file_prefix:STR := clean_name_str.tail((nchars - last_dir_point).max(0));
	    -- Lop off the last 3 characters - usually _sa. with at least 2 characters left
	    file_prefix := file_prefix.head((file_prefix.size-3).max(2));
	    -- #ERR+" Point:"+last_dir_point +" size:"+nchars+" file prefix:"+file_prefix+"\n";
	    -- prepend as
	    mangled_file_name := FILE_MANGLE::unique_file_name(file_prefix,t)+".c";
	 else		
	    -- If the source location is void
	    mangled_file_name := mang(t)+".c";
	 end;
	 -- Now mangle the file name
	 -- #ERR+"Mangled name:"+mangled_file_name+"\n";


	 cc:=#CODE_FILE(mangled_file_name);

	 cc.chk_pre:=chk_pre;
	 cc.chk_post:=chk_post;
	 cc.chk_invariant:=chk_invariant;
	 cc.chk_return:=chk_return;
	 cc.chk_when:=chk_when;
	 cc.chk_arith:=chk_arith;
	 cc.chk_assert:=chk_assert;
	 cc.chk_bounds:=chk_bounds;
	 cc.chk_void:=chk_void;

	 cc.is_c_code:=true;

	 -- esc: the output will be sorted alphabetically,
	 -- with breakpoints set at the 'good_place_to_split' positions.
	 -- therefore, this doesn't quite make sense.
	 -- (it will be moved almost to the end of the C file.)
	 --cc+"\n\n/* C for type "+mang(t)+" */\n\n";

	 code_files:=code_files.insert(t,cc);
      end;
      return cc;
   end;

   private setup_routine(func:AM_ROUT_DEF) is

      current_sig:=func.sig;
      current_am_rout_def:=func;
      current_function_str:=func.sig.str;
      set_chks;
      code_c:=code_file_for_tp(current_sig.tp,func.source);

      if func.sig.is_iter then 	 	
	 nested_its:=nested_its.insert(func,#FLIST{AM_ITER_CALL_EXPR}(5));
	 -- that 5 is important - it keeps it from being void()
	 
	 nested_bits:=nested_bits.insert(func,#FLIST{AM_BND_ITER_CALL_EXPR}(5));
	 -- that 5 is important - it keeps it from being void(),
	 -- this non void business is important, since we need it in emit_am_loop
	 -- to check for nested calls
      end;
      routine_code:=#FSTR;
   end;

   private create_iter(func:AM_ROUT_DEF)
   is
      func.num_yields:=1;
      it::=#AM_ITER_CALL_EXPR(func.size,func.source);
      it.fun:=func.sig;
      lp::=#AM_LOOP_STMT(func.source);
      func.calls:=func.calls.push(it);
      lp.its:=lp.its.push(it);
      lp.has_yield:=true;
      it.lp:=lp;
      it.init_before_loop:=true;
      it.uniq:="I_u_I";
      loop
         i::=it.ind!;
	 it[i]:=#AM_CALL_ARG(func[i].expr,func[i].mode);
      end;
      yl::=#AM_YIELD_STMT(func.source);
      yl.ret:=1;
      if func.sig.has_ret then
         yl.val:=it;
	 lp.body:=yl;
      else
         st::=#AM_EXPR_STMT(func.source);
	 st.expr:=it;
	 st.next:=yl;
	 lp.body:=st;
      end;
      func.code:=lp;
   end;

   private emit_routine(func:AM_ROUT_DEF) is
      func_name_comment:="";
      if options.local_call and ~void(func.sig.opt_info) and ~void(func.sig.opt_info.consider) then
	 no_destroy:=true;
	 loop i::=func.sig.opt_info.near_local.aind!;
	    if(i/=0) then
	       func_name_suffix:="___";
	       func_name_comment:="";
	       loop aa::=func.sig.opt_info.consider.size.times!; 
		  if i.aelt! then 
		     func_name_suffix:=func_name_suffix+"L";
		     func_name_comment:=func_name_comment+"  arg"+func.sig.opt_info.consider[aa]+" is local";
		  else 
		     func_name_suffix:=func_name_suffix+"f";
		  end;
	       end;
	       loop
		  func.sig.opt_info.near_local[i].elt!.is_always_near:=true;
	       end;
	       pemit_routine(func);
	       loop
		  func.sig.opt_info.near_local[i].elt!.is_always_near:=false;
	       end;
	    end;
	 end;
	 func_name_comment:="  attr_access:";
	 loop
	    func_name_comment:=func_name_comment+" "+func.sig.attr_access.elt!;
	 end;
      end;
      no_destroy:=false;
      func_name_suffix:="";
      pemit_routine(func);
   end;

   private pemit_routine(func:AM_ROUT_DEF) is
      arg_list:ARRAY{STR};
      ex_nesting:=0;
      ind::=indent;
      indent:=0;
      manual_unlock:=false;
      manual_loop_unlock:=false;
      if func.sig.is_builtin then
         if func.sig.is_iter then 
	    create_iter(func);
	 else return; 
	 end;
      end;
      routine_count:=routine_count+1;
      setup_routine(func);
      if func.is_external and func.sig.is_ext_fortran_sig then
	 emit_fortran_prologue(func);
	 emit_code(func.code);
	 emit_epilogue(func);	 
      elsif func.is_external and func.sig.is_ext_c_sig then
	 emit_c_prologue(func);
	 emit_code(func.code);
	 emit_epilogue(func);	
      else
	 -- "Normal Case"
	 emit_prologue(func);
	 if polling then ndefer("AM_POLL_NETWORK;"); end;
	 emit_code(func.code);	 
	 emit_epilogue(func);	 	 
      end;

      -- if an iter, do typedef with same name for holding the frame
      if func.is_iter then
	 --frames:=frames.push(func);
	 code_c.here_is_iter(func);
	 code_c.uses_iter(func.sig);
      else
	 -- Try to make some garbage.
	 mangler.dispose_namespace(func.sig);
      end;

      -- esc: this is a good place to split, isn't it?
      code_c.good_place_to_split;
      indent:=ind;
   end;

   finalize is
      -- finish up files, and call C compiler.

      if only_check then return; end;

      make_sure_emitted (main_sig); -- Ivin - prevent inlining main.
      define_main_and_globals;
      make_tag_table;

      -- there may be a circular dependency between leftover
      -- routines and bound routine creations. That is emitting
      -- code for a leftover routine may introduce more bound
      -- routine creations, and emitting stubs for bound routines
      -- may introduce more leftover routines. The loop bellow is
      -- executed until both lists are empty simultaneously
      -- Each leftover function may also produce some more
      -- entries for the dispatch table, which in turn may create
      -- more leftovers, and so on..... ( generate_dispathc...
      -- adjusts the tag table too).

      -- For bound routines we need to redefine FF
      if print_ob or print_ob_g then system_c+"\n#define FF (*pFF)\n"; end;
      loop
	 generate_bnd_rout_stubs;
	 generate_bnd_iter_stubs; 
	 generate_leftovers;
	 generate_dispatch_rout_and_iters;
	 until!(leftovers.size=0 and bnd_rout_creates.is_empty and 
		bnd_iter_creates.is_empty);
      end; 
      -- For bound routines we need to undefine FF here
      if print_ob or print_ob_g then system_c+"\n#undef FF\n"; end;

      -- Ivin: leftovers may introduce more tags.
      generate_dispatch_tables;
      -- Generating dispatched table may also introduce
      -- some more tags (for immutable classes)
      -- So, need to adjust tags accordingly
      -- Boris, 8/22/96
      tmp::=adjust_tag_table;
      generate_sys_tables;

      if prog.prolix then
	 #OUT+"\nAbstract calls:              "+abstract_calls;
	 #OUT+"\nConcrete calls:              "+concrete_calls;
	 #OUT+"\nInlined value ob_eq calls:   "+inlined_value_ob_eq_calls;
	 #OUT+"\nInlined pointer ob_eq calls: "+inlined_pointer_ob_eq_calls;
	 #OUT+"\nMarked read attr routs:      "+INLINE_ATTR_READ::routines;
	 #OUT+"\nInlined read attr calls:     "+INLINE_ATTR_READ::inlined;
	 #OUT+"\nMarked write attr routs:     "+INLINE_ATTR_WRITE::routines;
	 #OUT+"\nInlined write attr calls:    "+INLINE_ATTR_WRITE::inlined;
	 #OUT+"\nMarked global routs:         "+INLINE_GLOBAL_READ::routines;
	 #OUT+"\nInlined global calls:        "+INLINE_GLOBAL_READ::inlined;
	 #OUT+"\nMarked INT routs:            "+INLINE_INT_FOLD::routines;
	 #OUT+"\nFolded INT calls:            "+INLINE_INT_FOLD::inlined;
	 #OUT+"\nMarked short routs:          "+INLINE_ROUT::routines;
	 #OUT+"\nInlined short rout calls:    "+INLINE_ROUT::inlined;
	 #OUT+"\nMarked flat iters:           "+INLINE_ITER::iters;
	 #OUT+"\nInlined flat iter calls:     "+INLINE_ITER::inlined;
	 #OUT+"\nInlined builtin iter calls:  "+inlined_iter_count+"\n\n";
	 if ~void(prog.itercounts) then
	    #OUT+"\nThe following do not include break!, while! or until!.\n";
	    #OUT+"\nIters:\tIters\t# loops\n";
	    loop
	       i::=0.upto!(9);
	       ct::=prog.itercounts[i];
	       while!(ct>0);
	       #OUT+'\t'+i+'\t'+ct+'\n';
	    end;
	    #OUT+"\n\nHots:\tIters\t# loops\n";
	    loop
	       i::=0.upto!(9);
	       ct::=prog.hotcounts[i];
	       while!(ct>0);
	       #OUT+'\t'+i+'\t'+ct+'\n';
	    end;
	 end;
      end;

      allflags::=prog.config.get_str("CC_OPTIONS",0);
      libs ::= "";

      -- I moved the processing of the default flag before
      -- the processing of user defined flags (comming from
      -- -C_flag). This way the user can overwrite the default 
      -- flags, for example with -O2. CMF

      -- esc 1996/06/07: Space has to be *before* '-I.' option
      --allflags:=allflags+"-I. ";
      allflags:=allflags+" -I.";

      if debug then
	 allflags:=allflags+' '+prog.config.get_str("CC_DEBUG_FLAG",1);
      else
	 allflags:=allflags+' '+prog.config.get_str("CC_DEBUG_FLAG",0);
      end;
      if optimize then
	 allflags:=allflags+' '+prog.config.get_str("CC_OPTIMIZE_FLAG",1);
      else
	 allflags:=allflags+' '+prog.config.get_str("CC_OPTIMIZE_FLAG",0);
      end;
      if prog.prolix then
	 allflags:=allflags+' '+prog.config.get_str("CC_PROLIX_FLAG",0);
      else
	  allflags:=allflags+' '+prog.config.get_str("CC_PROLIX_FLAG",1);
      end;
      
      loop
	 flag::=c_flags.elt!;
	 if flag.size>2 and flag.head(2)="-l" then libs:=libs+' '+flag;
	 else allflags:=allflags+' '+flag;
	 end; -- if
      end;
      libs:=libs+' '+prog.config.get_str("GC_LINK",0)
		+' '+prog.config.get_str("LINK_OPTIONS",0);
      
      if prog.psather then
	 if options.psather_chk then allflags:=allflags+" -DPSATHER_CHK"; end;
	 if options.psather_stats then 
	    allflags:=allflags+" -DPSATHER_STATISTICS"; 
	 end;
	 if options.psather_trace then 
	    allflags:=allflags+" -DPSATHER_TRACE\n"; 
	 end;
      end;
      
      obfiles::=CODE_FILE::merge;

      syscom::="$(CC) $(CFLAGS) ";
      syscom:=syscom+prog.config.get_str("EXEC_OPTION",0)+"../$(CS) $(OBJ)";

      other::="";
      loop
	 s: STR := c_files.elt!.replace_suffix(prog.config.get_str("C_EXT",0),
					prog.config.get_str("OBJECT_EXT",0));
	 obfiles:=obfiles+' '+s.substring(s.search_backwards('/')+1);
      end;
      loop
	 s: STR := object_files.elt!;
	 if s[0] = '/' then other:=other+' '+s;
	 else
	    if s[0] = '-' then
	       other := other + s;
	    else
	       other:=other+' '+"../"+s;
	    end;
	 end; -- if
      end;

      -- Add any files needed by external classes
      loop
	 cl::=prog.tp_tbl.class_tbl.elt!;
	 files::=externals.get(cl.str);
	 if ~void(files) then
	    loop
	       file::=files.elt!;
	       if prog.prolix then
		  #OUT +"Including "+file+"; "+cl+" was reached\n";
	       end;
	       if file[0] = '/' then other:=other+' '+file;
	       else
		  if file[0] = '-' then
		     other := other + ' ' +  file;
		  else
		     other:=other+" ../"+file;
		  end;
	       end;
	    end;
	 end;
      end;

      loop
	 s: STR := archive_files.elt!;
	 if s[0] = '/' then other:=other+' '+s;
	 else other:=other+" ../"+s;
	 end; -- if
      end;
      syscom:=syscom+" $(OTHER)";

      syscom := syscom + " $(LIBS)";

      -- compute exec file name (no path)
      exec_name:STR;
      index: INT;
      suffix_length::=0;
      loop
	 i::=(executable.size-1).downto!(0);
	 if executable[i] = '/' then
	    break!;
	 end;
	 suffix_length := suffix_length + 1;
      end;
      
      exec_name := executable.tail(suffix_length);
      
      -- esc 1996/06/07: Create the files that contain the flags used
      -- for compiling and linking.  These are used as dependencies in
      -- the Makefile instead of the Makefile itself, in order to
      -- avoid recompilation when only an unimportant part of the
      -- Makefile changes.

      -- These options govern compilation
      comp_opt::=#FSTR;
      
      loop -- include any files "Make.target.inc" of the selected platforms
         make_include_file ::= BFILE::open_for_read(
	         prog.platforms.elt!+"/Make.target.inc");
	 if ~void(make_include_file) and ~make_include_file.error then
	     comp_opt := comp_opt + make_include_file.fstr + "\n\n";
	     make_include_file.close;
	 end;
      end; 
	       
      comp_opt := comp_opt
	    +"SHOME  ="+comp_home+'\n'
	    +"CFLAGS ="+allflags+'\n'
	    +"CC     ="+prog.config.get_str("C_COMPILER",0)+'\n'
	    +"HDR    =sather.h tags.h\n";
      comp_options+comp_opt;
      
      -- These options govern linking
      link_opt::=#FSTR
	    +comp_opt           -- All of the compile options
	    +"LIBS   ="+libs+'\n'
	    +"CS     ="+exec_name+prog.config.get_str("EXEC_SUFFIX",0)+'\n'
	    +"OBJ    ="+obfiles+'\n'
	    +"OTHER  ="+other+'\n';
      link_options+link_opt;

      -- This is the Makefile
      makefile+link_opt;      -- All of the above options
      makefile+"\n\n../$(CS): LINK_OPTIONS $(OBJ) $(HDR)";
      makefile+"\n\t"+syscom+"\n\n";
      link_options+"syscom: "+syscom+'\n';
      makefile+"$(OBJ): COMPILE_OPTIONS $(HDR)\n";
      
      loop
	 s: STR := c_files.elt!;
	 o::=s.replace_suffix(prog.config.get_str("C_EXT",0),prog.config.get_str("OBJECT_EXT",0));
	 o:=o.substring(o.search_backwards('/')+1);
	 if s[0]/='/' then s:="../"+s; end;
	 makefile+"\n"+o+": "+s+" COMPILE_OPTIONS $(HDR)\n\t$(CC) $(CFLAGS) -c "+s+"\n";
      end;

      -- esc 1996/06/07: What does this line mean?
      --makefile+"\n.c.o:; $(CC) $(CFLAGS) -c $*.c\n";
      --makefile+"\n.c.o: COMPILE_OPTIONS $(HDR)\n\t$(CC) $(CFLAGS) -c $*.c\n";   

      -- Write out any files which have changed, including the Makefile.
      CODE_FILE::finalize;

      syscom:="cd "+code_dir+prog.config.get_str("SHELL_SEP",0)+" "+prog.config.get_str("MAKE_COMMAND",0);
      if prog.verbose then
	 syscom:=syscom+' '+prog.config.get_str("MAKE_VERBOSE_FLAG",1);
      else
	 syscom:=syscom+' '+prog.config.get_str("MAKE_VERBOSE_FLAG",0);
      end;

      if only_C or prog.benchmark then
	 if prog.prolix then #OUT + "\nSkipping make.\n"; end;
      else
	 if prog.prolix then #OUT+'\n'+syscom+'\n'; end;
	 if UNIX::system(syscom)/=0 then barf("Make failed."); end;
      end;

      if ~gen_c and ~prog.benchmark then 
	 -- This is a quick hack which should be replaced!
	 dummy::=UNIX::system("rm -fr "+code_dir);
      end;

      -- Attempt to make garbage
      if(~no_destroy and ~no_destroy_lock) then SYS::destroy(self); end;
   end;
   
   private cast(dest_tp,src_tp:$TP,expr:STR, only_boxing:BOOL):STR is
      return do_cast(dest_tp, src_tp, expr, only_boxing, void);
   end;
   
   private cast_arg(dest_tp,src_tp:$TP,expr:STR, only_boxing:BOOL, mode:$MODE):STR is
      return do_cast(dest_tp, src_tp, expr, only_boxing, mode);
   end;

   private do_cast(dest_tp,src_tp:$TP,expr:STR, only_boxing:BOOL, mode:$MODE):STR 
   --        pre dest_tp=src_tp -- make sure cast isn't nonsense
   --                or (dest_tp.is_abstract and src_tp.is_abstract)
   --                or dest_tp.is_subtype(src_tp)
   --                or src_tp.is_subtype(dest_tp)
   is
      if ~ (dest_tp=src_tp	-- make sure cast isn't nonsense
	    or (dest_tp.is_abstract and src_tp.is_abstract)
	    or dest_tp.is_subtype(src_tp)
	    or src_tp.is_subtype(dest_tp)) then
	 #OUT+"CASTING ERROR: \n";
	 #OUT+"   dest_tp=";if void(dest_tp) then #OUT+"(void)"; else #OUT+dest_tp.str;end;
	 #OUT+"\n   src_tp=";if void(src_tp) then #OUT+"(void)"; else #OUT+src_tp.str;end;
	 #OUT+"\n   expr="+expr+"\n";
	 UNIX::exit(1);
      end;
      
      use_ptr:BOOL := false;
      if ~void(mode) then
	 use_ptr := (mode = MODES::out_mode) or 
	       (mode = MODES::inout_mode);
      end;
      
      -- possibly convert an expression to another type to sooth C's
      -- savage type beast when up- or down-typing.

      code_c.uses_tp(dest_tp);
      --code_c.uses_tp(src_tp);

      res:STR;
      if dest_tp=src_tp then
	 res:=expr;
      elsif dest_tp.is_abstract and
	 (src_tp.is_immutable or src_tp=TP_BUILTIN::ext_ob) then
	 -- boxing
	 res:=dec_local_comment(dest_tp,"local for boxed "+src_tp.str);
	 ndefer(res+" = ("+mang(dest_tp)+")"+allocate(src_tp)+";");
	 if use_ptr then expr := "*"+expr; end;
	 ndefer("(("+mang(src_tp)+"_boxed) "
		+res+")->immutable_part = "+expr+";");
      elsif (dest_tp.is_immutable or dest_tp=TP_BUILTIN::ext_ob)
	 and src_tp.is_abstract then
	 -- unboxing
	 if use_ptr then
	    expr := "*"+expr;
	    res:=dec_local_ptr_comment(dest_tp,"local ptr for unboxed "+src_tp.str);	
	 else
	    res:=dec_local_comment(dest_tp,"local for unboxed "+src_tp.str);
	 end;
	 if prog.distributed then
	    if dest_tp.is_atomic then
	       ndefer("F_VA_RATTR_NN("+res+","+mang(dest_tp)+"_boxed,"+expr+",immutable_part);");
	    else
	       ndefer("F_V_RATTR_LL("+mang(dest_tp)+","+res+","+mang(dest_tp)+"_boxed,"+expr+",immutable_part);");
	    end;
	 else
	    if dest_tp.is_atomic or ~prog.psather then
	       immutable_part::="(("+mang(dest_tp)+"_boxed) "
		     +expr+")->immutable_part";
	       if use_ptr then
		  immutable_part := "&(".append(immutable_part,")");
	       end;
	       ndefer(res.append(" = ", immutable_part, ";"));
	    else
	       ndefer("VASS_LL("+res+","+mang(dest_tp)+",(("+mang(dest_tp)+"_boxed) "
		      +expr+")->immutable_part);");
	    end;
         end;
      else 
	 if ~only_boxing then 
	    res:="(("+mang(dest_tp);

	    if use_ptr then
	       res := res + "*";
	    end;
	    res := res + ") " + expr+")";
	 else 
	    res:=expr; 
         end;
      end;
      return res;
   end;

   private sizeof(tp:$TP):STR is
      -- an expression for the storage size of a given type.
      if tp.is_immutable then return "sizeof("+mang(tp)+")";
      else return "sizeof(struct "+mang(tp)+"_struct)";
      end;
   end;

   private sizeof_boxed(tp:$TP):STR pre tp.is_immutable is
      -- an expression for the size of a boxed value type
      return "sizeof(struct "+mang(tp)+"_boxed_struct)";
   end;

   private allocate(t:$TP):STR is
      -- generate call which allocates memory and fills in tag for an
      -- object of type t.  This properly sets the tag field too.  If
      -- t is a value type it allocates the boxed version.

      r ::= dec_local(TP_BUILTIN::dollar_ob);
      leaf::=t.is_reference_free;
      sz :STR;
      if t.is_immutable or t=TP_BUILTIN::ext_ob then sz:=sizeof_boxed(t)
      else sz:=sizeof(t);
      end;
      if leaf then
	 ndefer(r+"=ZALLOC_LEAF("+sz+");");
      else
	 ndefer(r+"=ZALLOC("+sz+");");
      end;
      -- The Siva interface doesn't pass NULL on failure, and
      -- the Boehm collector doesn't zero atomic allocations
      if ~siva then
	 ndefer("if ("+r+"==NULL) FATAL(\"Unable to allocate more memory\");");
	 if leaf then ndefer("memset("+r+",0,"+sz+");"); end;
      end;
      ndefer("((OB)"+r+")->header.tag="+tag_for(t)+";");
      if deterministic then
	 ndefer("((OB)"+r+")->header.id=ob_count++;");
      end;
      if t.is_immutable then return "(("+mang(t)+"_boxed) "+r+")";
      elsif t=TP_BUILTIN::ext_ob then return "((EXT_OB_boxed) "+r+")";
      else return "(("+mang(t)+") "+r+")";
      end;
   end;

   private array_allocate(t:$TP,n:STR):STR is
      -- generate call which allocates memory and fills in tag for an
      -- object of type t and an array portion with n elements.  This
      -- sets the tag field but NOT asize, because it isn't reachable
      -- from an untyped C routine.  If t is a value type it allocates
      -- the boxed version.

      t2:$TP:=am_ob_def_for_tp(t).arr;
      code_c.uses_tp(t);
      code_c.uses_tp(t2);

      leaf::=t.is_reference_free;
      call_string, xtra:STR;
      r ::= dec_local(TP_BUILTIN::dollar_ob);
      sz2 ::=dec_local(TP_BUILTIN::int);
      sz:STR;
      if t.is_immutable then sz:=sizeof_boxed(t);
      else sz:=sizeof(t); 
      end;
      if leaf then 
	 -- Allocate one extra character to ensure strings have
	 -- a terminating zero.
	 call_string:="=ZALLOC_LEAF_BIG("; 
	 xtra:="+1";
      else 
	 call_string:="=ZALLOC_BIG("; 
	 xtra:="";
      end;
      s2::="sizeof("+mang(t2)+")";
      ndefer(sz2+"=("+sz+xtra+"-"+s2+")+("+n+")*"+s2+";");
      ndefer(r+call_string+sz2+");");
      -- The Siva interface doesn't pass NULL on failure.  Also, there isn't
      -- any need to zero memory for atomic allocations.
      if ~siva then
	 ndefer("if ("+r+"==NULL) FATAL(\"Unable to allocate more memory\");");
	 if leaf then ndefer("memset("+r+",0,"+sz2+");"); end;
      end;
      ndefer("((OB)"+r+")->header.tag="+tag_for(t)+";");
      
      if deterministic then
	 ndefer("((OB)"+r+")->header.id=ob_count++;");
      end;
      
      defer("\n#ifdef DESTROY_CHK\n");
      ndefer("  ((OB)"+r+")->header.destroyed=0;");  
      defer("\n#endif\n");

      if t.is_immutable then return "(("+mang(t)+"_boxed) "+r+")";
      else return "(("+mang(t)+") "+r+")";
      end;
   end;

   private default_init(t:$TP):STR is
      -- string representing default initialization expression
      -- for a given type.

      code_c.uses_tp(t);
      if t.is_immutable then
	 return mang(t)+"_zero";
      else return "((".append(mang(t),") NULL)");
      end;
   end;

   private is_const_expr(e:$AM_EXPR):BOOL is
      -- is this something we can make a C initializing constant for?
      if void(e) then return false; end;
      typecase e
      when AM_VOID_CONST then return true;
      when AM_BOOL_CONST then return true;
      when AM_CHAR_CONST then return true;
      when AM_STR_CONST then return true;
      when AM_INT_CONST then return true;
      else return false;
      end;
   end;

   private define_main_and_globals is
      -- generate actual main call, which then calls sather_main.
      -- has to initialize any globals and declare them.

      main_tp::=mang(main_sig.tp);

      code_c:=system_c;
      system_c+'\n';
      comment(system_c,"Definition of main (generated)");
      system_c+"\nint main(int argc, char *argv[]) {";
      if func_tables then
	 system_c+"\n struct _func_frame FF={ 0,NULL,NULL };";
      end;

      routine_code:=#FSTR+"\n"; 
      in;
      ndefer(main_tp+" main_ob;");

      if ~void(main_sig.args) then
	 ndefer(mang(TP_BUILTIN::arr_of_str)+" main_args;");
	 ndefer("int i,j,length;");
	 ndefer("STR s;");
      end;

      ndefer("int res=0;"); 
      ndefer("sather_prog_name=argv[0];");

      ndefer("rt_start(0,argc,argv);");
      if prog.psather then ndefer("PSATHER_START(argc,argv)");in; end;

      -- emit globals and any initializing expressions needed
      emit_globals;
      code_c:=system_c;

      -- default object for main
      if main_sig.tp.is_immutable then ndefer("main_ob = "+main_tp+"_zero;");
      else ndefer("main_ob = "+allocate(main_sig.tp)+";");
      end;

      -- arguments, if needed
      if ~void(main_sig.args) then
	 ndefer("main_args = "
		+array_allocate(TP_BUILTIN::arr_of_str,"argc")+";");
	 ndefer("main_args->asize = argc;");
	 ndefer("for (i=0;i<argc;i++) {");
	 ndefer(" for (length=0; argv[i][length]!=0; length++);");
	 ndefer(" s = "+array_allocate(TP_BUILTIN::str,"length")+";");
	 ndefer(" s->asize = length;");
	 ndefer(" for (j=0;j<length;j++) s->arr_part[j] = argv[i][j];");
	 ndefer(" main_args->arr_part[i] = s;");
	 ndefer("}");
      end;

      if null_segfaults then
	 ndefer("signal(SIGSEGV,(void(*)(int))rt_segfault_handler);");
      end;

      ndefer("PROTECT_BEGIN");
      in;
      f:STR:="";
      if func_tables then f:=",NULL"; end;

      if ~void(main_sig.ret) then
	 if ~void(main_sig.args) then
	    ndefer("res = sather_main(main_ob,main_args"+f+");");
	 else ndefer("res = sather_main(main_ob"+f+");");
	 end;
      else
	 if ~void(main_sig.args) then
	    ndefer("sather_main(main_ob,main_args"+f+");");
	 else ndefer("sather_main(main_ob"+f+");");
	 end;
      end;

      ndefer("rt_stop();");

      move_out;
      ndefer("PROTECT_WHEN");
      in;
      code_c.uses_tp(TP_BUILTIN::str);
      if prog.distributed then
	 ndefer("if(F_TAG(EXCEPTION)=="+tag_for(TP_BUILTIN::str) +") {");
	 ndefer(" STR s;");
	 ndefer(" s=(STR)rt_arr_alloc_atomic(sizeof(struct STR_struct),STR_tag,sizeof(CHAR),F_ASIZE(STR,EXCEPTION));");
	 ndefer(" s->asize=F_ASIZE(STR,EXCEPTION);");
	 ndefer(" F_R_ARRAY_OBJECT_NN(STR,CHAR,s,EXCEPTION);");
	 ndefer(" fprintf(stderr,\"Uncaught STR exception: %s\\n\",s->arr_part);");
	 ndefer("} else fprintf(stderr,\"Uncaught exception of type %s\\n\",gen_SYS_str_for_tp(F_TAG(EXCEPTION))->arr_part);");
      else
	 ndefer("if(TAG(EXCEPTION)=="+tag_for(TP_BUILTIN::str) +") {");
	 ndefer(" fprintf(stderr,\"Uncaught STR exception: %s\\n\",((STR)EXCEPTION)->arr_part);");
	 ndefer("} else fprintf(stderr,\"Uncaught exception of type %s\\n\",gen_SYS_str_for_tp(TAG(EXCEPTION))->arr_part);");
      end;
      if prog.psather then
         ndefer("PSATHER_ABORT;");
      else
         ndefer("abort();");
      end;
      move_out;
      --ndefer("}");
      ndefer("PROTECT_END");
      if prog.psather then move_out;ndefer("PSATHER_STOP"); end;
      ndefer("return res;"); 
      move_out;
      system_c+routine_code+"\n}\n\n";
   end;

   private emit_globals is
      -- emit declarations for globals and any code in main
      -- that has to execute to initialize to them before other code

      loop
	 age::=gen.global_tbl.top_sort.elt!;
	 globals_c.uses_tp(age.tp);
	 system_c.uses_tp(age.tp);
	 --globals_c.uses_global(age);
	 system_c.uses_global(age);
	 if is_const_expr(age.init) then
	    code_c:=globals_c;
	    globals_c+'\n';
	    e:STR:=emit_expr(age.init);
	    if age.is_const then 
	       globals_c+"const "; 
	    end;
	    globals_c+mang(age.tp)+' '+mang(age)+" = "+e+';';
	    comment(globals_c,
		    "Const ".append(mang(age.class_tp),"::",age.name.str));
	 else
	    if ~void(age.init) or 
		     (age.tp.is_immutable and ~age.tp.is_builtin) then
	       -- will be initialized in main
	       code_c:=system_c;
	       globals_c+'\n'+mang(age.tp)+' '+mang(age)+';';
	       comment(globals_c,"Shared "+mang(age.class_tp)
		       +"::"+age.name.str);
	       comment("Initialize shared "+mang(age.class_tp)
		       +"::"+age.name.str);
	       if ~void(age.init) then
		  in_constant := true;
		  ndefer(mang(age)+" = "+emit_expr(age.init)+';');
		  in_constant := false;
	       else 
		  ndefer(mang(age)+" = "+default_init(age.tp)+';');
	       end;
	    else
	       code_c:=globals_c;
	       globals_c+'\n'+mang(age.tp)+' '+mang(age)
		     +" = "+default_init(age.tp)+';';
	       comment(globals_c,"Shared "+mang(age.class_tp)
		       +"::"+age.name.str);
	    end;
	    broadcast(age);
	 end;
      end;
   end;

   private generate_sys_tables is
      -- make routines/tables needed by the SYS class
      -- also, make const declarations for all the tags encountered

      -- ultra short programs may not use INT_tag and CHAR_tag, but those
      -- tags are used in builtin functions. so we make sure that all builtin
      -- functions get their tags emitted
      s::=tag_for(TP_BUILTIN::int);
      s:=tag_for(TP_BUILTIN::char);
      s:=tag_for(TP_BUILTIN::bool);
      s:=tag_for(TP_BUILTIN::flt);
      s:=tag_for(TP_BUILTIN::fltd);
      s:=tag_for(TP_BUILTIN::str);

      -- PRINT_OB may return a string that needs to be in an include file
      -- included by System/Debug/print.c. One possibility is to add it to tags_h.
      -- Thats not very clean, but easy.
      if type_tables then tags_h+PRINT_OB::print(prog,self).str; end;
	
      print_dec:FSTR;
      code_c:=system_c;
      system_c+"\nSTR gen_SYS_str_for_tp(INT i) {\n";
      routine_code:=#FSTR+"\n";
      ndefer(" switch (i) {");
      ts::=#ARRAY{STR}(tags.size);
      -- Pre sort the tags to eliminate non-det
      tags_keys:ARRAY{$TP} := #ARRAY{$TP}(tags.size);
      loop tags_keys.set!(tags.keys!); end;
      tags_keys.sort;		
      loop
	 p::=tags.pairs!;
	 if p.t1.is_immutable and ~void(p.t1.impl) and ~void(p.t1.impl.arr) then
	    tags_h+"\n#define "+mang(p.t1)+"_ASIZE "+p.t1.impl.asize_val;
	 end;
	 ts.set!("\n#define "+mang(p.t1)+"_tag "+p.t2);
      end;
      ts.sort;			-- To keep stable over changes
      loop
	 tags_h+ts.elt!;
      end;
      loop
	 p_key::=tags_keys.elt!;
	 dummy::=#AM_STR_CONST;
	 dummy.bval:=p_key.str;
	 ts.set!("  case "+mang(p_key)+"_tag: return "
	 	 +emit_am_str_const(dummy)+";"); -- (ben) Sorted these
      end;
      ts.sort;			-- To keep stable over changes.
      -- May not be needed anymore? (ben)
      loop
	 ndefer(ts.elt!);
      end;
      ndefer("  default: fprintf(stderr,\"Internal error: unknown tag?\\n\");");
      if prog.psather then ndefer("            PSATHER_ABORT;\n"); end;
      ndefer("           abort();\n");
      ndefer(" }");
      system_c+routine_code+"}\n\n";
      code_c:=system_c;
      system_c+"\nBOOL gen_SYS_ob_eq(OB o1,OB o2) {\n";
      system_c+" INT t1,t2;BOOL r=1;\n";
      routine_code:=#FSTR+"\n";
      ndefer(" if (o1==o2) return TRUE;");
      if prog.distributed then
 	 ndefer(" if (FVOID(o1) && FVOID(o2)) return TRUE;");
	 ndefer(" if (FVOID(o1) || FVOID(o2)) return FALSE;");
	 ndefer(" t1 = F_TAG(o1); t2 = F_TAG(o2);");
      else
	 ndefer(" if (o1==NULL || o2==NULL) return FALSE;");
	 ndefer(" t1 = o1->header.tag; t2 = o2->header.tag;");
      end;
      ndefer(" if (t1!=t2) return FALSE;");
      ndefer(" switch (t1) {");
      loop
	 tp:$TP :=tags_keys.elt!;	-- Changed from tags.keys! (ben)
	 tpstr:STR :=mang(tp);
	 system_c.uses_tp(tp);
	 if tp.is_immutable then
	    if prog.distributed then
 	       if tp.is_atomic then
 		  ndefer("  case "+tpstr+"_tag:");
 		  ndefer("    {"+tpstr+" v1,v2;F_VA_RATTR_NA(v1,"+tpstr+"_boxed,o1,immutable_part);");
 		  ndefer("     F_VA_RATTR_NA(v2,"+tpstr+"_boxed,o2,immutable_part);");
 		  ndefer("     return r&&"+value_compare(tp,"v1","v2")+";}");
 	       else
 		  ndefer("  case "+tpstr+"_tag:");
 		  ndefer("    {"+tpstr+" v1,v2;F_V_RATTR_LP("+tpstr+",v1,"+tpstr+"_boxed,o1,immutable_part);");
 		  ndefer("     F_V_RATTR_LP("+tpstr+",v2,"+tpstr+"_boxed,o2,immutable_part);");
 		  ndefer("     return r&&"+value_compare(tp,"v1","v2")+";}");
 	       end;
	    else
	       ndefer("  case "+tpstr+"_tag:");
	       ndefer("    {"+tpstr+" v1 = (("+tpstr+"_boxed)o1)->immutable_part;");
	       ndefer("     "+tpstr+" v2 = (("+tpstr+"_boxed)o2)->immutable_part;");
	       ndefer("     return r&&"+value_compare(tp,"v1","v2")+";}");
	    end;
	 end;
      end;
      ndefer("  default: return FALSE;");
      ndefer("   }");
      system_c+routine_code+"}\n\n";
   end;

   private emit_prologue(f:AM_ROUT_DEF) pre ~void(f.sig) is

      arg_list:ARRAY{STR}:=#(f.asize);

      saw_outer_return:=false;
      sig:SIG:=f.sig;
      mangler.force_mangle(f[0].expr,"self",sig);

      newline; newline;
      if f.sig.is_iter then code_c+"\n#undef IS_ITER\n#define IS_ITER 1\n";
      else code_c+"\n#undef IS_ITER\n#define IS_ITER 0\n"; end;

      comment(code_c,"Definition of "+sig.str+func_name_comment);
      code_c+'\n';

      rout_index:STR;
      if func_tables then
	 rout_index:=PRINT_OB::register(f.sig);
      end; 
      if debug then
	 code_c+"\n#line "
	       +f.source.line_num_in+" \""+f.source.file_in+"\"\n";
	 last_lineno:=f.source.line_num_in;
      elsif pretty then
	 code_c+"\n/* #line "
	       +f.source.line_num_in+" \""+f.source.file_in+"\" */\n";
	 last_lineno:=f.source.line_num_in;
      end;

      if ~void(sig.ret) then code_c+mang(sig.ret)+' ';
      else code_c+"void ";
      end;

      -- The spec guarantees that external functions are mangled in 
      -- a special way: classname_funcname
      -- This is no longer necessary for fortran as this is taken care
      -- of in fortran_call.sa
      if f.is_external then
	 name:STR := sig.tp.str.append("_",sig.name.str);
 	 mangler.force_mangle(sig, name, void);
      end;
      -- the suffix is used to distinguish different versions of the same
      -- functions (they expect different arguments to be near)
      code_c+mang(sig)+func_name_suffix+'(';

      code_c.uses_sig(sig);
      iter_out_arg_locals:FLIST{AM_LOCAL_EXPR}; -- a list of temporaries for iter 
      -- out/inout args
      out_args:BOOL:=false;
      
      -- if an iter, pointer for frame, otherwise regular args
      if f.is_iter then
	 -- just a single frame argument
	 code_c+mang(f.sig)+"_frame frame";
	 if func_tables then -- function frame
	    code_c+", struct _func_frame *prev_func_frame";
	 end;
	 -- also, arguments are on frame
	 if f.size>1 then
	    loop 
	       arg ::= f.elt!(1); 
	       lv:AM_LOCAL_EXPR := arg.expr;
	       -- if out or inout args, a local will be used 
	       -- instead of arg until the very end when results are
	       -- copied back
	       if arg.mode=MODES::out_mode or arg.mode=MODES::inout_mode then 
		  iter_out_arg_locals := iter_out_arg_locals.push(lv);
		  -- create a new argument expression
		  arg.expr := #AM_LOCAL_EXPR(lv.source, lv.name, 
					     lv.tp, lv.as_type);
		  out_args := true;
		  d::=mang(lv,sig); -- fix mangling before we delete the name
		  lv.name:=void; -- otherwise -PO treats it as a standard local
	       end;
	       mangler.force_mangle(arg.expr,"arg"+1.up!,sig);
	    end;
	 end;
      else
	 -- if not an iter, declare arguments
	 if f.is_abstract then
	    -- in abstract routine, arg names are canonical
	    code_c+mang(f.sig.tp)+" self";
	    if ~void(f.sig.args) then
	       i::=0;
	       loop 
		  e::=f.sig.args.elt!;
		  arg_list[i] := " arg"+1.up!;
		  code_c+", "+arg_type_str(e)+arg_list[i];
	       end;
	    end;
	    if func_tables then -- function frame
	       code_c+", struct _func_frame *prev_func_frame";
	    end;
	 elsif f.is_external then 
	    loop i::=1.upto!(f.asize-1);
	       e::=f[i];
	       assert ~void(e) and ~void(e.tp);
	       if e.mode=MODES::inout_mode or e.mode=MODES::out_mode then
		  expr ::= e.expr;
		  lv ::= #AM_LOCAL_EXPR(expr.source, expr.name, 
					     expr.tp, expr.as_type);
		  arg_list[i]:=mang(lv, sig);
		  out_args := true;
	       else
		  arg_list[i] := mang(e.expr,sig);
	       end;
	       code_c+", ".separate!(arg_type_str(e)+' '+arg_list[i]);
	    end;
	       
	 elsif sig.is_forked then 
	    loop i::=0.upto!(f.asize-1);
	       e::=f[i];
	       assert ~void(e) and ~void(e.tp);
	       if i=0 then 
		  arg_list[i]:="self_to_be";
		  code_c+"OB "+arg_list[i];
	       else
		  if e.mode=MODES::out_mode or e.mode=MODES::inout_mode
		  then
		     expr::=e.expr;
		     lv ::= #AM_LOCAL_EXPR(expr.source, expr.name, 
					     expr.tp, expr.as_type);
		     arg_list[i]:=mang(lv, sig);
		     out_args := true;
		  else
		     arg_list[i]:=mang(e.expr, sig);
		  end;
		  code_c+", "+arg_type_str(e)+' '+arg_list[i];
	       end;
	    end;
	 else
	    loop i::=0.upto!(f.asize-1);
	       e::=f[i];
	       assert ~void(e) and ~void(e.expr.tp);
	       if e.mode=MODES::inout_mode or e.mode=MODES::out_mode then
		  -- don't mangle arg yet! Instead, a temporary will be used
		  expr ::= e.expr;
		  lv ::= #AM_LOCAL_EXPR(expr.source, expr.name, 
					     expr.tp, expr.as_type);  
		  arg_list[i]:=mang(lv,sig);
		  --arg_list[i]:=mang(lv,sig);		  
		  out_args := true;
	       else
		  arg_list[i] := mang(e.expr,sig);
	       end;
	       code_c+", ".separate!(arg_type_str(e)+' '+arg_list[i]);
	    end;
	    if func_tables then -- function frame
	       code_c+", struct _func_frame *prev_func_frame";
	    end;
	 end;
      end;
	
      code_c+") {";
      in;
      -- Declare/initialize out/inout stuff
      if out_args and ~f.is_iter then
	 loop i::=1.upto!(f.asize-1);
	    e::=f[i];
	    if e.mode = MODES::inout_mode or e.mode = MODES::out_mode then
	       -- declare temporaries playing the role of *arg
	       init_str:STR;
	       if e.mode = MODES::inout_mode then
		  --declare & initialize the temporary
		  init_str := "*"+arg_list[i];
	       else
		  init_str := default_init(e.tp);
	       end;
	       local::=dec_local_for_arg(e, f.sig, init_str);
	    end;
	 end;	   
      end;
	 
      -- If PO is on, generate function frame
      if func_tables then
	 -- ndefer("void *_local_frame[]={");
	 -- because of a bug in GCC the above way to define local_frame compiles,
	 -- but produces buggy code. So we have to count the number of
	 -- elements first;
	 ll:FLIST{STR}:=#;
	 cn::=0;
	 if f.is_iter then
	    loop 
	       cn:=cn+1;
	       e::=f.elt!;
	       loc::=e.expr;
	       if e.mode=MODES::out_mode or e.mode=MODES::inout_mode then 
		  loc:=iter_out_arg_locals.elt!;
	       end;
	       ll:=ll.push("(void *)&frame->"+mang(loc,sig));
	    end;
	    loop l::=f.locals.elt!;
	       if ~void(l.name) and l/=f.rres then
		  l.needs_init:=true;
		  ll:=ll.push("(void *)&frame->"+mang(l,sig));
		  cn:=cn+1;
	       end;
	    end;
	 else
	    loop
	       k::="(void *)&"+mang(f.elt!.expr,sig);
	       if f.is_external and 1.up!=1 then k:="NULL"; end;
	       ll:=ll.push(k);
	       cn:=cn+1;
	    end;
	    loop l::=f.locals.elt!;
	       if ~void(l.name) and l/=f.rres then
		  l.needs_init:=true;
		  ll:=ll.push("(void *)&"+mang(l,sig));
		  cn:=cn+1;
	       end;
	    end;
	 end;
	 -- Had to rewrite the following to avoid automatic
	 -- struct and array initialization: native SGI and alpha compilers
	 -- can't handle this, although it appears to be ANSI
	 -- Now do field by field assignments
	 -- Boris, 8/21/96
	 ndefer("void *_local_frame["+cn+"];");
	 ndefer("struct _func_frame FF;");
	 
	 loop
	    i::=0.upto!(cn-1);
	    defer("_local_frame[".append(i.str,"]=",ll.elt!,";"));
	 end;
	 defer("FF.func=".append(rout_index,";"));
	 if f.is_external or sig.is_forked then
	    defer("FF.prev=NULL;");
	 else
	    defer("FF.prev=prev_func_frame;");
	 end;
	 defer("FF.args=_local_frame;");
      end;

      -- We cannot do the following above before doing the -PO
      -- stuff. We want the rest to be done before, so
      -- that those locals are initialized BEFORE the function
      -- frame. This is not critical for iters, as their frame
      -- is initialized to zero anyway (because it's allocated
      -- on the heap).
      if out_args and f.is_iter then
	 f.locals := f.locals.append(iter_out_arg_locals);
	 -- don't need to declare: the layout structure will include
	 -- the temporary for args automatically
	 l: AM_LOCAL_EXPR;
	 loop e::=f.elt!;
	    if e.mode=MODES::out_mode or e.mode=MODES::inout_mode then 
	       l := iter_out_arg_locals.elt!;
	       case e.mode
	       when MODES::inout_mode then
		  ndefer("frame->"+mang(l, sig) + " = *(" + "frame->"+mang(e.expr, sig)+");");
	       when MODES::out_mode then
		  -- default init
		  ndefer("frame->"+mang(l, sig) + " = " + default_init(l.tp)+';');
	       end;
	    end;
	 end;
      end;
      -- now emit local declarations (if an iter, they are on the
      -- frame and don't need to be declared).
      if ~f.is_iter and ~void(f.locals) then  
	 loop 
	    lv:AM_LOCAL_EXPR:=f.locals.elt!;
	    assert ~void(lv) and ~void(lv.tp);
	    code_c.uses_tp(lv.tp); --here
	    newline;
	    if lv.is_volatile then code_c+"volatile "; end;
	    if lv.needs_init or lv.tp.is_immutable then
	       def:STR:=default_init(lv.tp);
	       code_c+mang(lv.tp)+' '+mang(lv,sig)+" = "+def+';';
	    else
	       code_c+mang(lv.tp)+' '+mang(lv,sig)+';';
	    end;
	 end;
      end;

      if sig.is_forked then	-- unbox the self
	 newline;
	 code_c+mang(f[0].expr.tp)+" self;";
	 ndefer( "self = " + cast(sig.tp,TP_BUILTIN::dollar_ob,"self_to_be",false)+';');
      end;

      -- if an iter, maybe return a dummy value when quit, so declare
      -- one.  Also generate switch statement.  The first state
      -- initializes any locals to the iter that need it.  (It shouldn't
      -- be possible to get there more than once in an invocation.)
      if f.is_iter then
	 if ~void(sig.ret) then
	    newline;
	    code_c+mang(sig.ret)+' '+"dummy = "+default_init(sig.ret)+';';
	 end;
	 if prog.psather and (~prog.yields_in_locks or ~options.side_effects
	    or sig.get_se_context(prog).has_yield_in_lock) then
	    ndefer("if(frame->state) SET_EXCEPTION_STACK(frame->ex);");
	 end;
	 ndefer("switch (frame->state) {");
	 in;

	 loop 
	    i::=0.upto!(f.num_yields);
	    ndefer("case "+i+": goto state"+i+';');
	 end;
	 ndefer("}");
	 move_out;
	 ndefer("state0:;");
	 state_counter:=1;

	 -- initialize any locals that need it
	 if ~void(f.locals) then
	    loop i::=f.locals.elt!;
	       if i.needs_init then
		  ndefer("frame->"+mang(i,sig)
			 +" = "+default_init(i.tp)+";");
	       end;
	    end;
	 end;
      end;
      current_arg_list := arg_list;
      current_iter_out_arg_locals := iter_out_arg_locals;
   end;

   arg_type_str(e:AM_FORMAL_ARG): STR is
      res::= mang(e.expr.tp);
      if e.mode=MODES::inout_mode or e.mode=MODES::out_mode 
      then 
	 res := res+"*";
      end;
      return res;
   end;

   arg_type_str(e:ARG): STR is
      res::= mang(e.tp);
      if e.mode=MODES::inout_mode or e.mode=MODES::out_mode  
      then 
	 res := res+"*";
      end;
      return res;
   end;

   boxed_arg_type_str(e:AM_FORMAL_ARG): STR is
      res::= mang(e.expr.tp)+"_boxed";
      if e.mode=MODES::inout_mode or e.mode=MODES::out_mode 
      then 
	 res := res.append("*");
      end;
      return res;
   end;

   boxed_arg_type_str(e:ARG): STR is
      res::= mang(e.tp)+"_boxed";
      if e.mode=MODES::inout_mode or e.mode=MODES::out_mode 
      then 
	 res := res.append("*");
      end;
      return res;
   end;
   
   private emit_epilogue(f:AM_ROUT_DEF) is
      if ~void(current_am_rout_def.specul_prefetch) then
	 ndefer("PREFETCH_SPECUL_WAIT("+emit_expr(current_am_rout_def.specul_prefetch)+");");
      end;
      if ~saw_outer_return then
	 callee_copy_out;
      end;
      
      if chk_return and ~saw_outer_return
	       and ~f.is_iter and
	       ~void(f.sig.ret) then
	 -- if it has a return value, it is necessary to
	 -- make sure doesn't exit without a return
	 runtime_error("Last statement wasn't return",f);
      end;

      code_c+routine_code;	-- output all the code

      
      if f.is_iter then		-- add an explicit 'quit'
	 newline; code_c+"frame->state = -1;"; 
	 if ~void(f.sig.ret) then newline; code_c+"return dummy;";
	 else newline; code_c+"return;";
	 end;
      end;

      move_out; newline; code_c+"}";
      if indent/=0 then
         #OUT+"WARNING: function "+f.sig.str+" has wrong indent: "+indent+"\n";
      end;
      if func_tables then
         PRINT_OB::print_frame(prog,self,code_c,f,current_iter_out_arg_locals); 
      end;
      -- esc: we don't want to split here, because there still are
      -- references to the code file later on (see emit_routine)
      --code_c.good_place_to_split;
   end;

 
   -- Note, handling of binding of bound rout closures, 'a::=bind(foo); b::=bind(a.call)'
   -- In the wrapper function for b, the fctptr defined in 'self', i.e. 'a'
   -- is traversed and the 'dangling' fct. is called. 
   -- This call is not 'as usual' an existing method with corresponding C-fcten. 
   private generate_bnd_rout_stubs is
      code_c:=system_c;
      loop
	 until!(void(bnd_rout_creates) or bnd_rout_creates.is_empty);
	 -- this is needed to avoid generating the same stubs multiple times
	 e::=bnd_rout_creates.pop;  
	 bnd_rout_creates_done:=bnd_rout_creates_done.push(e);

	 code_c.uses_bnd_rout_create(e); 
	 code_c.uses_layout(#BOUND_OBJECT_LAYOUT(e)); 
	 name::=mang(e); -- get its name
	 forbid(name+"_ob");
	 forbid(name+"_ob_struct");
	 if ~void(e.fun.ret) and ~e.is_remote then code_c+mang(e.fun.ret)+' ';
	 else code_c+"void ";
	 end;
	 code_c+name+'('+name+"_ob ob";  -- name(name_ob ob
	 -- note that out and inout arguments must be left
	 -- unbound. The check is done earlier.

	 loop -- generate variable for unb args
	    -- Well, we may have out and inout bound args if compiling
	    -- psather. They are used for remote execution
	    i::=e.unbnd_args.elt!;
	    num::=0.up!;
	    dec:STR;
	    if i=0 then
	       if ~e.fun.tp.is_external then 
		  dec:=mang(e.fun.tp);
		  code_c+", "+dec+" unbound_arg"+num;
	       end;
	    else 
	       a::=e.fun.args[i-1];
	       code_c+", "+arg_type_str(a)+" unbound_arg"+num;
	    end;
	 end;
	 if func_tables then
	    code_c+",struct _func_frame *pFF";
	 end;
	 code_c+") {"+eol;
	 in;
	 code_c.uses_sig(e.fun);
 	 routine_code:=#FSTR;
 
 	 -- for pSather: if ob is remote, we have to copy it over
 	 if prog.distributed then
 	    if ~e.is_remote then
 	       if ~void(e.fun.ret) then 
 		  code_c+" "+mang(e.fun.ret)+" retval;\n";
 	       end;
 	       code_c+" "+name+"_ob obn=NULL;";
 	       ndefer(" if(FAR(ob)) {");
 	       ndefer("  obn=ZALLOC(sizeof(*ob));");
 	       ndefer("  get_memory(obn,ob,sizeof(*ob));");
 	       loop arg::=e.elt!;
 		  i::=e.ind!;
 		  if arg.expr.tp.is_immutable then
 		     if ~arg.expr.tp.is_atomic then
 			ndefer("  RECVOB("+tag_for(arg.expr.tp)+",&obn->bound_arg"+i+",WHERE(ob));");
 		     end;
 		  else
 		     ndefer("  obn->bound_arg"+i+"=RECVFOB(obn->bound_arg"+i+",WHERE(ob));");
 		  end;
 	       end;
 	       ndefer("  ob=obn;");
 	       ndefer(" }");
 	    end;
 	 end;
	 arg_list::=#ARRAY{STR}(e.fun.args.size+1);
	 -- Make a dummy routine call and generate it
	 -- Note that we are not daeling here with parameter passing
	 -- stuff. It should be handled by the called ``real'' function
	 -- and also at the point of the call as for normal routines
	 bnd::=0;		-- The index of the next bound argument
	 unbnd::=0;		-- The index of the next unbound argument
	 is_bnd:BOOL;		-- So, is the next arg bound or unbound?
	 loop
	    i::=arg_list.ind!;	-- The index we're on.
	    if bnd<e.bnd_args.size then
	       if e.bnd_args[bnd]=i then is_bnd:=true;
	       elsif e.unbnd_args[unbnd]=i then is_bnd:=false;
	       else barf("Ran off unbound arg list");
	       end;
	    elsif e.unbnd_args[unbnd]=i then is_bnd:=false;
	    else barf("Ran off unbound arg list 2nd");
	    end;
	    isout::=false;
	    if i>0 and e.fun.args.elt!.mode/=MODES::in_mode then
	       isout:=true;
	    end;
	    if ~(i=0 and e.fun.tp.is_external) then
	       if is_bnd then
		  if isout then
		     arg_list[i]:="&ob->bound_arg"+bnd;
		  else
		     arg_list[i]:="ob->bound_arg"+bnd;
		  end;
	       else
		  arg_list[i]:="unbound_arg"+unbnd;
	       end;
	    end;
	    if is_bnd then
	       bnd:=bnd+1;
	    else
	       unbnd:=unbnd+1;
	    end;
	 end;
	 make_sure_emitted(e.fun);
	 func_res:STR:=void;
	 in_bnd_rout_call:=true;
	 ec : STR;
	 if e.fun.tp.is_external then
	    ec := emit_ext_call(e.fun,arg_list);
	 else
   	    ec:=emit_call(e.fun,e,arg_list);
	 end;
	 in_bnd_rout_call:=false;
	 code_c+routine_code;
	 if ~void(e.fun.ret) then 
	    if e.is_remote then 
 	       code_c+"\n ob->ret_arg=";
 	    elsif prog.distributed then
 	       code_c+"\n retval=";
 	    else
 	       code_c+"\n return ";
	    end;
	 else code_c+"\n ";
	 end;
 	 code_c+ec+";\n";
 	 if prog.distributed and ~e.is_remote then
 	    code_c+" if(obn!=NULL) SYSDESTROY(obn);\n";
 	    if ~void(e.fun.ret) then code_c+" return retval;\n"; end;
  	 end;
 	 code_c+"}\n\n";
 	 move_out;
      end;
   end;

     
   -- generates wrapper functions for bnd iter call
   -- we treat several cases differently to ease debugging, once things
   -- are stable these could be merged.
   -- bind regular iter, binding closures, self bnd/unbnd, self abstract 
   private generate_bnd_iter_stubs is
      l_ret_val : STR;
      loop
	 until!(void(bnd_iter_creates) or bnd_iter_creates.is_empty);
	 e::=bnd_iter_creates.pop;  
	
	 -- check whether we are currently binding an iterator closure
	 -- this case needs to be treated separately, since in the case
	 -- of 'bind_iter_closure' we do not need to allocate a  frame
	 -- for the iterator bound. The frame is already available via
	 -- self which incarnates a bound iter closuyre. This frame,
	 -- however, needs to be copied since it cannot serve multiple 
	 -- calls, which we do not know at this point.
	 binding_iter_closure ::= false; ident ::= #IDENT("call!");
	 if (e.fun.name = ident)  then binding_iter_closure := true; end;
	 
	 -- tell it to generate an bound iter stub
	 code_c.uses_bnd_iter_create(e);
		 
	 -- tell it to generate a frame plus the iter frame referenced inside 
	 -- this does not create a dependency, it just tells it to emit in 
	 -- the same file a FRAME for the iterator referenced.
	 if e.fun.tp.is_abstract then
	    code_c.uses_layout(#ABSTRACT_FRAME_LAYOUT(e.fun,prog)); 
	 elsif binding_iter_closure  then 
	    -- the referenced frame is already present, due to previous
	    -- bindings, we do not get here if something goes wrong.
	 else
	    -- the following table is filled in emit and in emit_am_bnd_iter
	    iframe:AM_ROUT_DEF:= itersig_map.get(e.fun);
	    if void(iframe) then
	       barf("Iter signature not found in : generate_bnd_iter : " + e.fun.str);
	    end;
	    code_c.uses_layout(#FRAME_LAYOUT(iframe,prog)); 
	 end;
	 code_c.uses_layout(#BOUND_ITER_FRAME_LAYOUT(e,prog)); 
	 
	 -- generate its name
	 name::=mang(e);
	 forbid(name+"_iter_ob");
	 forbid(name+"_iter_ob_struct");
	 
	 -- generate fct.head eg.INT call_function_name (name_iter_ob f)  
	 if ~void(e.fun.ret) then 
	    code_c+mang(e.fun.ret)+' ';
	 else 
	    code_c+"void "; 
	 end;
	 
	 code_c+name+"_call_function" + '(' + name + "_iter_ob f"; 
	 if func_tables then
	    code_c+", struct _func_frame *pFF";
	 end;
	 code_c+")";
	 code_c+"{"+eol;
	 -- we do not need a stub for a bound iter closure.
	 if ~binding_iter_closure then code_c.uses_sig(e.fun); end; 
	 
	 -- now generate the body of the iter stub :
	 if ~void(e.fun.ret) then 
	    code_c+"  "+mang(e.fun.ret)+' '+"  ret_val;\n"; 
	 end;
	 	    
	 -- some declarations needed below 
	 routine_code := #FSTR;
	 self_str : STR; state0 : STR:=""; state1 : STR:=""; 
	 if ~void(e.bnd_args) and (e.bnd_args[0] = 0) then
	    self_str := "bound_arg0";  
	 else
	    self_str := "oncearg0";
	 end;
	 
	 -- the switch stm
	 ndefer("switch (f->state) { \n     case 0: goto state0; \n");
	 defer("     case 1: goto state1;\n}");
	 
	 -- state0:;
	 ndefer("state0:;");
	 
	 if binding_iter_closure then
	    arg_mode:ARRAY{BOOL}; args_list:ARRAY{ARG};
	    type_of_bnd_create ::= e.tp_at;
	    typecase type_of_bnd_create
	    when TP_ITER then 
	       arg_mode := type_of_bnd_create.hot;  
	       args_list := type_of_bnd_create.args;
	    end;
	 
	    -- arguments of the closure type need to be set and passed in the right
	    -- structure. Note WE ARE ONLY TOUCHING THE TYPE HERE and NOTHING BUT 
	    -- THE TYPE.
	    
	    -- iterate over e.bnd_args generating '  ... = f->bound_argx' and 
	    -- find corresponding LHS by indexing into e.fun.tp.hot
	    -- LHS can either be `f->bound_arg0->hotargx or ...onceargx',
	    -- since it corresponds to the type of self 
	    
	    -- NOTE: it might seem somewhat abstruse to index with 'a' from the
	    -- current closure type into the bound closure types fields, this
	    -- is, however, correct since the closure being bound has to have 
	    -- these fields otherwise this point should not have been reached.
	    
	    -- NOTE, the unbnd_args are counted consecutively from 0
	    i_arg : INT:= 0;  -- counter for arg # of LHS, i.e. type sig args
	    loop a ::= e.bnd_args.elt!; i ::= 0.up!;
	       if a /= 0 then 
		  if ~void(e.fun.hot) and e.fun.hot[a-1] then 
		     state1 := state1 + "   f->"+self_str+"->hotarg"+(a-1)+
			   " = f->bound_arg"+i+ ";\n";
		  else
		     state0 := state0 + "   f->"+self_str+"->oncearg"+(a-1)+
			   " = f->bound_arg"+i+ ";\n";
		  end;
		  i_arg:=i_arg+1;
	       end;
	    end;  -- ends loop over bndargs
	    
	    -- iterate over e.unbnd_args generating '... = f->hotargz/onceargx'
	    -- i.e. the arguments provided by the caller, e.g. b::= bind(a.call!(1,_))
	    -- b.call!(5),   '5' in this example.
	    -- Note the information whether RHS is hot or once is obtained from the
	    -- current type of the bound closure i.e. from e.tp_at NOT from e.fun.tp
	    -- which is the type of the bound closure being bound here.
	    -- LHS is obtained as abvoe by indexing into into e.fun.tp.hot with the 
	    -- above counters NOT reset.
	    
	    -- NOTE, the values in e.unbnd_args correspond to the argument position
	    -- in the bound expression, whereas their location (indicies) in 
	    -- unbnd_args correspond to the argument in the type e.g. in ITER{I,I}.
	    arg_cnt ::= 0;
	    -- if self is unbnd then we have to inc. the arg counter since 
	    -- we start from oncearg0
	    if self_str = "oncearg0" then arg_cnt := 1; end;
	    loop a ::= e.unbnd_args.elt!; i ::= 0.up!;
	       if a /= 0 then
		  if ~void(e.fun.hot) and e.fun.hot[a-1] then
		     state1 := state1 + "   f->"+self_str+"->hotarg"+(a-1)+ " = ";
		     if ~void(arg_mode) and arg_mode[i] then
			state1 := state1 + "   f->hotarg"+ arg_cnt +";\n";
		     else -- should never happen
			barf("In generate_bnd_iter_stub: something wrong with"+
			     " arguments of bound closure (1).");
		     end;
		  else
		     state0 := state0 + "   f->"+self_str+"->oncearg"+(a-1)+ " = ";
		     if ~void(arg_mode) and arg_mode[i] then   -- never !
			barf("In generate_bnd_iter_stub: something wrong with"+
			     " arguments of bound closure (2).");
		     else
			state0 := state0 + "   f->oncearg"+ arg_cnt +";\n";
		     end;
		  end;
		  i_arg:=i_arg+1; arg_cnt := arg_cnt + 1;
	       end; 
	    end; -- ends loop over unbdn args
	 elsif e.fun.tp.is_abstract then 
	    dtbl_ptr ::= mang(e.fun);
	    if chk_void and ~null_segfaults then
	       ndefer("if (f->"+self_str+" == NULL) {"); in;
	       runtime_error("Dispatched call to "+e.fun.str + " on void self in " 
			     + current_function_str); move_out;       
	       ndefer("}");
	    end;
	    ndefer("f->iter_frame = ("
		   + mang(e.fun)+"_frame)"
		   +"(*"+ dtbl_ptr
		   +"[TAG(f->"+self_str+")].alloc_frame)();");
	 else  -- the commong case bind(foo!);
	    ndefer("f->iter_frame = OB_ALLOC(");
	    defer(mang(e.fun)+"_frame);");
	 end;
	 comment("Initialize iter state.");
	 if ~binding_iter_closure then ndefer("f->iter_frame->state=0;"); end;
	 
	 if binding_iter_closure then
	    -- set self's state to zero. Note, it could have been called eralier
	    -- leaving the effect of a non-zero state
	    l ::= dec_local(e.fun.tp);
	    ndefer(l+" = ZALLOC(f->"+self_str+"->size);");
	    ndefer(l+" = ("+mang(e.fun.tp)+") memcpy("+l+", f->"+
		   self_str+", f->"+self_str+"->size);"); 
	    ndefer(l+"->state = 0;");
	    ndefer("f->"+self_str+" = "+l+";");
	    ndefer(state0);  -- calculated above
	 else
	    -- fill in arguments : first once (state0) then hots (state1)
	    -- Note, there are some similaities but alos some differences to the
	    -- above treatment of binding closures which would introduce yet more 
	    -- ifs ... . To get at ease with bugs leave it as it is for now.
	    comment("Fill in once arguments.");
	    loop a ::= e.unbnd_args.elt!; i ::= 0.up!;  
	       if a = 0 then 
		  ndefer("f->iter_frame->self = f->oncearg0;"); 
	       else
		  if void(e.fun.hot) then 
		     ndefer("f->iter_frame->arg"+a+" = f->oncearg"+i+";"); 
		  else
		     hot ::= e.fun.hot[a-1];
		     if ~hot then ndefer("f->iter_frame->arg"+a+" = f->oncearg"
					 +i+";"); end;
		  end;       
	       end;
	    end;
	    -- now go over bnd args
	    loop a ::= e.bnd_args.elt!; i ::= 0.up!;
	       -- not the worlds most efficient way, (FIXME) later
	       
	       if a = 0 then
		  if ~binding_iter_closure then
		     ndefer("f->iter_frame->self = f->bound_arg0;"); 
		  end;
	       else
		  if void(e.fun.hot) then 
		     ndefer("f->iter_frame->arg"+a+" = f->bound_arg"+i+";"); 
		  else
		     hot ::= e.fun.hot[a-1]; -- access of void error
		     if ~hot then ndefer("f->iter_frame->arg"+a+" = f->");
			defer("bound_arg"+i+";"); 
		     end;
		  end;       
	       end;
	    end; -- ends loop 
	 end;
	 
	 -- state1:; i.e. treatment of hot args
	 ndefer("state1:; \n ");
	 comment("Set hot arguments, call iter and check iter state.");
	 if binding_iter_closure then
	    ndefer(state1);  -- computed above
	 else
	    -- argument 0 is never hot (self is by def. always once )
	    comment("Fill in hot arguments."); 
	    -- if there are no hots don`t do nothing !
	    if ~void(e.fun.hot) then 
	       -- check out unbnd first
	       loop a ::= e.unbnd_args.elt!; i ::= 0.up!;
		  if a /= 0 then 
		     hot ::= e.fun.hot[a-1];
		     if hot then ndefer("f->iter_frame->arg"+a+" = f->");
			defer("hotarg"+i+";"); end; 
		  end;       
	       end;
	 
	       -- check out bnd args
	       loop a ::= e.bnd_args.elt!; i ::= 0.up!; 
		  if a /= 0 then 
		     hot ::= e.fun.hot[a-1];
		     if hot then ndefer("f->iter_frame->arg"+a+" = f->");
			defer("bound_arg"+i+";"); end;
		  end;       
	       end;
	    end;
	 end;
	 -- The call to the bound iter stub looks always something like that:
	 -- void bound2_call_function(bound2_iter_ob f){
	 --   ... MAIN_foob_INT_INT_INT_IN(f->iter_frame)
	 -- NOTE. self is part of the frame
	 
	 -- for rout closures:
	 -- void bound(bound_ob ob, unbnds ...){
	 --   ... MAIN_foo_INT_INT_INT_INT(
	 --  ob->bound_arg0, unbound_arg0, unbound_arg1, ob->bound_arg1, 
	 --  ob->bound_arg2);
	 
	 -- NOTE, unlike in the case of bound routines, here the entire context 
	 -- has to be passed at each invokation rendering the above form more apt. 
	 -- The stub is the incarnation of an iterator.

	 comment("call iter");
	 arg_list::=#ARRAY{STR}(1); 
	 if binding_iter_closure then
	    arg_list[0] := "f->"+self_str;
	 else
	    arg_list[0] := "f->iter_frame"; 
	 end;
	 iter_call : STR;
	 iter_call:=emit_call(e.fun,e, arg_list);	 
	 iter_call :=  iter_call+";";
	 if ~void(e.fun.ret) then 
	    ndefer("ret_val = " + iter_call);
	    if binding_iter_closure then
	       ndefer("f->state = (f->"+self_str+"->state == -1 ? -1 : 1);");
	    else
	       ndefer("f->state = (f->iter_frame->state == -1 ? -1 : 1);");
	    end;
	    ndefer("return ret_val" + ";\n}");
	 else 
	    -- iter is not returning anything
	    ndefer(iter_call);
	    if binding_iter_closure then
	       ndefer("f->state = (f->"+self_str+"->state == -1 ? -1 : 1);");
	    else
	       ndefer("f->state = (f->iter_frame->state == -1 ? -1 : 1);");
	    end;
	    ndefer("return;\n}");
	 end;
	 code_c + routine_code+ "\n\n";
	 make_sure_emitted(e.fun);  
      end; 
   end;
	   
   private generate_dispatch_rout_and_iters is
      -- make sure that all functions reachable through
      -- dispatch tables are actually emited
      -- Note that we do not emit any features in partial classes
      -- since partial classes cannot be instantiated
      loop
         loop
	    abs_rout::=abstract_routs.elt!;
	    gh:FSET{$TP};
	    fst::=abs_rout.sig.tp;
	    --#OUT+"Working on Dispatch Table for "+abs_rout.sig.str+", tp: "+fst.str+"\n";
	    typecase fst
	    when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); 
	    end;
	    loop
	       e::=gh.elt!;
	       -- skip partial classes - they can never be instantiated
	       if ~e.is_partial then
		  if tags.get(e)/=0 then
		     real_sig:SIG:=e.ifc.sig_conforming_to(abs_rout.sig);
		     if ~void(real_sig) then 
			make_sure_emitted(real_sig);
		     end;
		  end;
	       end;
	    end;
	 end;
	 loop
	    abs_iter::=abstract_iters.elt!;
	    gh:FSET{$TP};
	    fst::=abs_iter.sig.tp;
	    --#OUT+"Working on Dispatch Table for "+abs_iter.sig.str+", tp: "+fst.str+"\n";
	    typecase fst
	    when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); 
	    end;
	    loop
	       e::=gh.elt!;
	       -- skip partial classes - they can never be instantiated
	       if ~e.is_partial then
		  if tags.get(e)/=0 then
		     real_sig:SIG:=e.ifc.sig_conforming_to(abs_iter.sig);
		     if ~void(real_sig) then 
			make_sure_emitted(real_sig);
		     end;
		  end;
	       end;
	    end;
	 end;
	 -- we could have generated some more functions,
	 -- which in turn could have changed the reachable
	 -- code, so we have to adjust the tag table, and 
	 -- if there are any changes there, we need to recheck
	 -- dispatched calls.
	 while!(adjust_tag_table);
      end;
   end;

   private generate_dispatch_tables is
      -- first, emit dispatch tables for functions
      loop 
	 abs_rout ::= abstract_routs.elt!;
	 emit_dispatch_func_table(abs_rout); 
      end;
      -- emit dispatch table for iters
      loop 
	 abs_iter ::= abstract_iters.elt!;
	 emit_dispatch_iter_table(abs_iter); 
      end;
   end;

   private attr emitted_dispatch_wrappers:FMAP{SIG,STR};

   private emit_dispatched_version(s,abs:SIG):STR is
      -- emit a wrapper function for boxing/unboxing value types
      -- when dispatched.  Return the function name generated.
      -- If no boxing has to happen, don't generate anything.
      -- 's' is the signature to call, and 'abs' is the signature
      -- of the dispatch.

      call, decl:STR;

      -- First, see if we can weasel out and not worry about boxing.
      if ~s.is_builtin then -- we have to generate a function
      			    -- for all builtins
	 w::= abs.tp=s.tp and abs.ret=s.ret;
	 loop
	    while!(w);
	    if s.args.elt!/=abs.args.elt! then w:=false; end;
	 end;
	 if w then
	    return mang(s);
	 end;
      end;

      -- It is possible to emit a wrapper more than once if there
      -- are multiple abstract types it could be dispatched from.
      -- So we keep them in a table to avoid duplication.
      res::=emitted_dispatch_wrappers.get(s);
      if ~void(res) then return res; end;

      code_c:=unbox_c;
      unbox_c.uses_unbox(s,abs);
      unbox_c.uses_sig(abs);
      if ~s.is_builtin or s.is_iter then-- builtins have no body
	 dispatch_c.uses_sig(s);
	 unbox_c.uses_sig(s);
      end;
      dispatch_c.uses_unbox(s,abs);

      -- until mangling is really correct, use func_unbox as name
      res:=mang(s)+"_unbox";
      unbox_c+'\n';
      comment(unbox_c,"Wrapper to unbox "+s.str);
      unbox_c+'\n';
      if void(s.ret) then
	 unbox_c+"void ";
      else
	 unbox_c+mang(abs.ret)+' ';      
      end;

      pog::="";
      if func_tables then
	 pog:=",struct _func_frame *pFF";
      end;
      if s.is_iter then
	    unbox_c+res+'('+mang(abs)+"_frame frame"+pog+") {\n"
      else
	 if abs.tp.is_abstract and
		  (s.tp.is_immutable or s.tp=TP_BUILTIN::ext_ob) then
	    unbox_c+res+"("+mang(s.tp)+"_boxed self";
	 else
	    unbox_c+res+"("+mang(s.tp)+" self";
	 end;

	 loop
	    a::=s.args.elt!;
            set::=a.tp;
	    absa::=abs.args.elt!;
	    abset ::= absa.tp;
	    idx::=1.up!;
	    if abset.is_abstract and 
		     (set.is_immutable or set=TP_BUILTIN::ext_ob) then
	       unbox_c+", ".append(boxed_arg_type_str(a)," arg",idx.str);
	    else
	       unbox_c+", ".append(arg_type_str(absa)," arg",idx.str);
	    end;
	 end;
	 unbox_c+pog+") {\n";
      end;
      routine_code:=#FSTR;
      if s.is_iter then
	 call:=mang(s)+"(("+mang(s)+"_frame) frame";
	 decl:=mang(s)+'('+mang(s)+"_frame";
	 if func_tables then
	    call:=call+",pFF";
	    decl:=decl+",struct _func_frame *";
	 end;
	 call:=call+')';
	 decl:=decl+')';
	 if ~void(s.ret) then
	    call:="return "+cast(abs.ret,s.ret,call,false);
	    decl:=mang(s.ret)+' '+decl;
	 else
	    decl:="void "+decl;
	 end;
      else
	 arg_str:STR := "arg";
	 if s.is_builtin then
	    arg_list ::= #ARRAY{STR}(s.num_args+1);
	    arg_list[0] := cast(s.tp, abs.tp, "self",false);
	    loop i::=1.upto!(s.num_args);
	       arg_list[i] := cast(s.args[i-1].tp, abs.args[i-1].tp,arg_str+i,true);
	    end;
	    call := process_builtin_routs(s, void, arg_list);
	 else
	    -- "Normal" case
	    call:=mang(s)+'('+cast(s.tp,abs.tp,"self",false);
	    decl:=mang(s)+'('+mang(s.tp);
	    loop i::=1.upto!(s.num_args);
	       call:=call+", "+cast_arg(s.args[i-1].tp,abs.args[i-1].tp,arg_str+i,false, s.args[i-1].mode);
	       decl:=decl+", "+arg_type_str(s.args[i-1]);
	    end;
	    if func_tables then
	       call:=call+",pFF";
	       decl:=decl+",struct _func_frame *";
	    end;
	    call:=call+')';
	    decl:=decl+')';
	 end;
	 if ~void(s.ret) then
	    call:="return "+cast(abs.ret,s.ret,call,false);
	    decl:=mang(s.ret)+' '+decl;
	 else
	    decl:="void "+decl;
	    if void(call) then call:=""; end;
	 end;
      end;
      if s.is_builtin then
         unbox_c+' '+routine_code+"\n "+call+";\n"+"}\n";
      else
	 -- unbox_c+' '+decl+";\n "+routine_code+"\n "+call+";\n"+"}\n";
	 unbox_c+' '+routine_code+"\n "+call+";\n"+"}\n";
      end;

      emitted_dispatch_wrappers:=emitted_dispatch_wrappers.insert(s,res);
      return res;
   end;

   private emit_dispatched_allocator(s, abs:SIG):STR is
      res ::= mang(s)+"_frame_alloc";
      --emit dispatched allocator only once!
      if ~emitted_iter_allocators.test(s) then
	 emitted_iter_allocators := emitted_iter_allocators.insert(s);
	
	 unbox_c + "void* "+res+"() {\n"
	       + " return OBALLOC("+mang(s)+"_frame);\n"
	       + "}\n";
      end;
      return res;
   end;

   private emit_dispatch_func_table(f:AM_ROUT_DEF) is
      -- emit function pointer table for dispatched routines 

      dispatch_c.uses_sig(f.sig);

      -- first, collect descendents' info.  We want to make the smallest
      -- table possible, so find the min and max tags needed.

      des::=#FLIST{$TP};
      mintag::=INT::maxint;
      maxtag::=INT::minint;
      cst:STR;			-- Cast to correct function pointer type

      gh:FSET{$TP};
      fst::=f.sig.tp;
      --#OUT+"Working on Dispatch Table for "+f.sig.str+", tp: "+fst.str+"\n";
      typecase fst
      when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); 
      end;
      loop t::=gh.elt!;
	 -- skip fetures coming from partial classes - they cannot be called
	 -- since partial classes cannot be instantiated
	 if ~t.is_partial then
	    des:=des.push(t);
	    --tag:INT:=num_tag_for(t);
	    tag:INT:=tags.get(t);
	    --#OUT+tag+" --> "+t.str+"\n";
	    if tag=0 then
	       --#OUT+"oops, tag for TP "+t.str+" = 0??\n";
	    else
	       maxtag:=maxtag.max(tag);
	       mintag:=mintag.min(tag);
	    end;
	 end;
      end;

      -- comment(dispatch_c,"Dispatch table for "+f.sig.str+" ["+mang(f.sig)+"]");
      -- dispatch_c+"\nconst int "+mang(f.sig)+"_offset = "+(-mintag)+";\n";
      -- forbid(mang(f.sig)+"_offset");
      -- Some of native C compilers do not like returning qualified constant types
      -- use the macro here instead of ``const'' to avoid this if needed 
      decl::="RETURNED_CONST ";
      tbl::="RETURNED_CONST ";
      cst:="(RETURNED_CONST ";
      if ~void(f.sig.ret) then
	 decl:=decl+mang(f.sig.ret);
	 tbl:=tbl+mang(f.sig.ret);
	 cst:=cst+mang(f.sig.ret);
      else
	 decl:=decl+"void";
	 tbl:=tbl+"void";
         cst:=cst+"void";
      end;
      decl:=decl+" (*"+mang(f.sig)+"_tbl[])("+mang(f.sig.tp);
      tbl:=tbl+" (**"+mang(f.sig)+")("+mang(f.sig.tp);
      cst:=cst+" (*)("+mang(f.sig.tp);
      if ~void(f.sig.args) then
	 loop 
	    e::=f.sig.args.elt!;
	    tbl:=tbl+", "+arg_type_str(e);
	    decl:=decl+", "+arg_type_str(e);
	    cst:=cst+", "+arg_type_str(e);
	 end;
      end;

      if func_tables then
         decl:=decl+", struct _func_frame *";
         tbl:=tbl+", struct _func_frame *";
	 cst:=cst+", struct _func_frame *";
      end;
      decl:=decl+")";
      tbl:=tbl+")="+mang(f.sig)+"_tbl+("+(-mintag)+");\n";
      dispatch_c+decl+" = {\n";
      cst:=cst+"))";

      -- Manufacture table initialization 
      -- this is quadratic in number of descendents
      loop 
	 i::=mintag.upto!(maxtag);
	 exists:BOOL:=false;
	 loop 
	    e::=des.elt!;
	    --tag:INT:=num_tag_for(e);
	    tag:INT:=tags.get(e);
	    real_sig:SIG:=e.ifc.sig_conforming_to(f.sig);
	    if ~void(real_sig) and tag=i and tag/=0 then
	       exists:=true;
	       functocall:STR;
	       make_sure_emitted(real_sig);
	       functocall:=emit_dispatched_version(real_sig,f.sig);
	       dispatch_c+' '+cst+functocall;
	       if i/=maxtag then dispatch_c+","; end;
	       comment(dispatch_c,real_sig.str);
	       dispatch_c+'\n';
	    end;
	 end;
	 if ~exists then
	    dispatch_c+"/* "+i+" */"+" NULL";
	    if i/=maxtag then dispatch_c+","; end;
	    dispatch_c+'\n';
	 end;
      end;
      if mintag>maxtag then
	 dispatch_c+" NULL /* No descendents found - how odd. */\n";
      end;
      dispatch_c+"};\n"+tbl+"\n";
   end;

   private emit_dispatch_iter_table(f:AM_ROUT_DEF) is
      -- emit function pointer table for dispatched iters
      -- The entry corresponding to a particular tag contains
      -- 2 function pointers: one to a function implementing the
      -- iter, and the other to the function that allocates the
      -- frame of an appropriate size.

      dispatch_c.uses_sig(f.sig);
	
      -- first, collect descendents' info.  We want to make the smallest
      -- table possible, so find the min and max tags needed.

      des::=#FLIST{$TP};
      mintag::=INT::maxint;
      maxtag::=INT::minint;
      cst:STR;			-- Cast to correct function pointer type

      gh:FSET{$TP};
      fst::=f.sig.tp;
      typecase fst
      when TP_CLASS then gh:=prog.tp_graph_abs_des.des_of(fst); 
      end;
      loop t::=gh.elt!;
	 -- anything coming from partial classes 
	 if ~t.is_partial then
	    des:=des.push(t);
	    --tag:INT:=num_tag_for(t);
	    tag:INT:=tags.get(t);
	    if tag/=0 then
	       maxtag:=maxtag.max(tag);
	       mintag:=mintag.min(tag);
	    end;
	 end;
      end;
      
      comment(dispatch_c,"Iterator dispatch table for "+f.sig.str);
      -- dispatch_c+"\nconst int "+mang(f.sig)+"_offset = "+(-mintag)+";\n";
      -- forbid(mang(f.sig)+"_offset");
      decl::="RETURNED_CONST "+mang(f.sig)+"_entry ";
      tbl::="RETURNED_CONST "+mang(f.sig)+"_entry ";
      cst:="(RETURNED_CONST ";
      decl:=decl+mang(f.sig)+"_tbl[]";
      tbl:=tbl+"*"+mang(f.sig);
      if ~void(f.sig.ret) then
	 cst:=cst+mang(f.sig.ret);
      else
	 cst := cst + "void";
      end;
      cst:=cst+" (*)("+mang(f.sig)+"_frame";
      dispatch_c+"\n"+decl+" = {\n";
      if func_tables then cst:=cst+",struct _func_frame *"; end;
      cst:=cst+"))";
      tbl:=tbl+"="+mang(f.sig)+"_tbl+("+(-mintag)+");\n";

      alloc_cast ::= "(const void* (*)())";

      -- Manufacture table initialization 
      -- this is quadratic in number of descendents
      loop 
	 i::=mintag.upto!(maxtag);
	 exists:BOOL:=false;
	 loop 
	    e::=des.elt!;
	    --tag:INT:=num_tag_for(e);
	    tag:INT:=tags.get(e);
	    real_sig:SIG:=e.ifc.sig_conforming_to(f.sig);
	    if ~void(tag) and tag=i and tag/=0 then
	       exists:=true;
	       functocall:STR;
	       make_sure_emitted(real_sig);

	       -- make sure that typedef for iter frame is
	       -- placed in the file containing dispatch tables
	       dispatch_c.uses_iter(real_sig);
	       unbox_c.uses_iter(real_sig);

	       functocall:=emit_dispatched_version(real_sig,f.sig);
	       funcalloc ::=emit_dispatched_allocator(real_sig, f.sig);
	       dispatch_c+" {"+cst+functocall + ", " + 
		     alloc_cast+funcalloc+"}";
	       if i/=maxtag then dispatch_c+","; end;
	       comment(dispatch_c,real_sig.str);
	       dispatch_c+'\n';
	    else
	    end;
	 end;
	 if ~exists then
	    dispatch_c+" {NULL, NULL}";
	    if i/=maxtag then dispatch_c+","; end;
	    dispatch_c+'\n';
	 end;
      end;
      if mintag>maxtag then
	 dispatch_c+" {NULL, NULL} /* No descendents found - how odd. */\n";
      end;
      dispatch_c+"};\n"+tbl+"\n";
   end;

   private generate_leftovers is
      -- Generate code for routines which were inlined but
      -- need a definition anyway because they were dispatched
      -- or bound.

      -- put all leftover routines for which code has been
      -- emitted onto emitted_leftovers list
      loop 
	 e ::= leftovers.first_elt;
	 if ~leftovers.is_elt_nil(e) then
	    if ~emitted_leftovers.test(e) then
	       emit_routine(e);
	       emitted_leftovers:=emitted_leftovers.insert(e);
	    end;
	    leftovers:=leftovers.delete(e);
	 else
	    break!;
	 end;
      end;
   end;

   private emit_code(arg:$AM_STMT) is
      -- emit code associated with sequence of $AM_STMTs
      s1,s2:STR;
      loop until!(void(arg));
	 announce_at(arg.source);
	 typecase arg 
	 when AM_ASSIGN_STMT then emit_am_assign_stmt(arg);
	 when AM_IF_STMT then emit_am_if_stmt(arg);
	 when AM_LOOP_STMT then emit_am_loop_stmt(arg);
	 when AM_BREAK_STMT then emit_am_break_stmt(arg);
	 when AM_RETURN_STMT then emit_am_return_stmt(arg); 
	 when AM_COMMENT_STMT then emit_am_comment_stmt(arg);
	 when AM_EXPR_STMT then emit_am_expr_stmt(arg);
	 when AM_YIELD_STMT then emit_am_yield_stmt(arg);
	 when AM_CASE_STMT then emit_am_case_stmt(arg);
	 when AM_PRE_STMT then emit_am_pre_stmt(arg);
	 when AM_POST_STMT then emit_am_post_stmt(arg);
	 when AM_INITIAL_STMT then emit_am_initial_stmt(arg);
	 when AM_ASSERT_STMT then emit_am_assert_stmt(arg);
	 when AM_TYPECASE_STMT then emit_am_typecase_stmt(arg);
	 when AM_RAISE_STMT then emit_am_raise_stmt(arg);
	 when AM_INVARIANT_STMT then emit_am_invariant_stmt(arg);
	 when AM_PROTECT_STMT then emit_am_protect_stmt(arg);

	    -- pSather constructs
	 when AM_ATTACH_STMT then emit_am_attach_stmt(arg);
	 when AM_FORK_STMT then emit_am_fork_stmt(arg);
	 when AM_PAR_STMT then emit_am_par_stmt(arg);	    
	 when AM_LOCK_STMT then emit_am_lock_stmt(arg);
	 when AM_UNLOCK_STMT then emit_am_unlock_stmt(arg);
	 when AM_WITH_NEAR_STMT then emit_am_with_near_stmt(arg);
	 when AM_SYNC_STMT then emit_am_sync_stmt(arg);
	 when AM_PREFETCH_STMT then emit_am_prefetch_stmt(arg);
	 when AM_WAITFOR_STMT then emit_am_waitfor_stmt(arg);

	 else barf("The back-end encountered an improperly"
		   " translated $AM_STMT: "+SYS::str_for_tp(SYS::tp(arg)));
	 end;
	 next::=arg.next;
	 typecase arg
	 when AM_LOOP_STMT then	-- gets mangled so don't destroy
	 when AM_PAR_STMT then	-- gets mangled so don't destroy	    
	 when AM_FORK_STMT then	-- gets mangled so don't destroy
	 else  if(~no_destroy and ~no_destroy_lock) then SYS::destroy(arg); end;
	 end;
	 arg:=next;
      end;
   end;

   -- make a write to a global variable available to all clusters
   broadcast(global:AM_SHARED_EXPR) 
   is
      if prog.distributed then
	 dummy::=tag_for(global.tp);
	 if global.tp.is_immutable then
	    if global.tp.is_atomic then
	       ndefer("BROADCAST_GLOBAL_VA("+mang(global.tp)+","+emit_am_shared_expr(global)+");");
	    else
	       ndefer("BROADCAST_GLOBAL_V("+mang(global.tp)+","+emit_am_shared_expr(global)+");");
	    end;
	 else
	    ndefer("BROADCAST_GLOBAL_R("+mang(global.tp)+","+emit_am_shared_expr(global)+");");
	 end;
      end;
   end;

   -- detect if an expression would be valid on the left side of
   -- an assignment. Basically it checks it we could take the address
   -- of this expression in C. This test is needed whenever we assign
   -- value types in pSather
   is_valid_lhs(e:$AM_EXPR):BOOL is
      typecase e
      when AM_LOCAL_EXPR then return true;
      when AM_SHARED_EXPR then return true;
      when AM_ATTR_EXPR then return true;
      else return false;
      end;
   end;

   -- process an assignment statement.  Optimization is checked for
   -- the lhs of the assignment.  If the node is optimized, then 
   -- insert the appropriate initialization code. (Only init_optimization
   -- is legal here.)
   private emit_am_assign_stmt(arg:AM_ASSIGN_STMT) is
      lside::=arg.dest;
      global:AM_SHARED_EXPR:=void;

      code_c.uses_tp(lside.tp);
      s1,sp:STR;
      is_attr::=false;
      is_immutable::=false;
      lside_tp:$TP;
      sft::=""; -- * for value types, empty otherwise
      lhs_near::=lside.is_near;
      
      
      typecase lside
      when AM_ATTR_EXPR then
	 tmp::=emit_expr(lside.ob);
	 tmp:=cast(lside.self_tp,lside.ob.tp,tmp,false);
	 attrname::=mang(lside.at,lside.self_tp);
	 lside_tp:=lside.self_tp;

	 if prog.psather then
	    lhsob::=lside.ob;
	    lhs_near:=lhsob.is_near;
	    typecase lhsob 
	    when AM_LOCAL_EXPR then
	    when AM_SHARED_EXPR then
	    else
	       l::=dec_local(lside.self_tp);
	       if lside.self_tp.is_immutable and ~lside.self_tp.is_atomic then
	          ndefer("VASS_LP("+l+","+mang(lside.self_tp)+","+tmp+");");
	       else
		  ndefer(l+"="+tmp+";");
	       end;
	       tmp:=l;
	    end;
	 end;
	 if lside.self_tp.is_immutable then
	    if ~prog.psather then 
	       s1:=tmp+"."+attrname; 
	    else 
	       s1:="&"+tmp+','+attrname;
	       sft:="*";
	    end;
	 else
	    if prog.psather and lhs_near and arg.dest.tp.is_immutable and ~arg.dest.tp.is_atomic then
	       s1:=tmp+"->"+attrname;
	    else
	       s1:=tmp+','+attrname;
	    end;
	 end;
	 is_attr:=true;
	 sp:=tmp;
      when AM_SHARED_EXPR then
         global:=lside;
	 s1:=emit_expr(lside);
      else
	 -- A global or a local.
	 s1:=emit_expr(lside);
      end;

      if is_attr then
	 rhs::=cast(arg.dest.tp,arg.src.tp,emit_expr(arg.src),false);
	 if prog.psather then
	    l::=dec_local(arg.dest.tp);
	    if arg.src.tp.is_immutable and ~arg.src.tp.is_atomic and is_valid_lhs(arg.src) then
	       ndefer("VASS_LP("+l.append(",",mang(arg.dest.tp),",",rhs,");"));
	    else
	       ndefer(l.append("=",rhs,";"));
	    end;
	    pw::="F";
	    if options.post_write then pw:="POST"; end;
	    if lhs_near then
	       prog.stat.incr("O: # of local accesses");
	       if arg.dest.tp.is_immutable and ~arg.dest.tp.is_atomic then
		  ndefer("VASS_PL("+s1+","+mang(arg.dest.tp)+","+l+");");
	       else
		  ndefer("SATTR(".append(s1,",",l,");"));
	       end;
	    else
	       if arg.dest.tp.is_immutable then
		  if arg.dest.tp.is_atomic then
		     ndefer(pw+"_VA_WATTR_AA(".append(mang(lside_tp)+sft,",",s1,",",l+");"));
		  else
		     ndefer(pw+"_V_WATTR_PP(".append(mang(lside_tp)+sft,",",s1,",",mang(arg.dest.tp)+","+l+");"));
		  end;
	       else
		  ndefer(pw+"_R_WATTR_AA(".append(mang(lside_tp)+sft,",",s1,",",l+");"));
	       end;
	    end;
	 else
	    ndefer("SATTR(".append(s1,",",rhs,");"));
	 end;
      else
	 is_val_attr_expr::=false;
	 -- See if it is an expression of the form
	 -- c:=c.a(...) where c is a value type
	 -- and a is an attribute assignment expr.  If
	 -- so, do the assignment in place.  This isn't
	 -- trivially generalized to multiple assignments
	 -- because side-effects must not be observed, and
	 -- the arguments to later assignments might have
	 -- a dependance on the earlier assignment.
	 if lside.tp.is_immutable then
	    before_dot::=arg.src;
	    typecase before_dot
	    when AM_VATTR_ASSIGN_EXPR then
	       arg_before_dot::=before_dot.ob;
	       typecase arg_before_dot
	       when AM_LOCAL_EXPR then
		  if SYS::ob_eq(arg_before_dot,lside) then
		     is_val_attr_expr:=true;
		     rhs::=cast(before_dot.real_tp,before_dot.val.tp,emit_expr(before_dot.val),false);
		     if prog.psather and lside.tp.is_immutable and ~lside.tp.is_atomic then
			l::=dec_local(before_dot.val.tp);
			if before_dot.tp.is_immutable and ~before_dot.tp.is_atomic 
			   and is_valid_lhs(before_dot.val) then
			   ndefer("VASS_LP("+l.append(",",mang(before_dot.val.tp),",",rhs,");"));
			else
			   ndefer(l.append("=",rhs,";"));
			end;
			ndefer("LOCKV(&"+s1+");");
			defer(s1.append(".",
				mang(before_dot.at,before_dot.ob.tp)," = ",l,";"));
			defer("UNLOCKV(&"+s1+");");
		     else
			ndefer(s1.append(".",
				      mang(before_dot.at,before_dot.ob.tp),
				      " = ",rhs,";"));
		     end;
		     -- #OUT + "untested did it lhs: " + s1 + '\n';
		  end;
	       else 
	       end;
	    else
	    end;
	 end;
		
	 if ~is_val_attr_expr then
	    -- Otherwise, do the usual thing.
	    rhs::=cast(arg.dest.tp,arg.src.tp,emit_expr(arg.src),false);
	    if prog.psather and lside.tp.is_immutable and ~lside.tp.is_atomic then
	       if ~is_valid_lhs(arg.src) then
		  l::=dec_local(arg.dest.tp);
		  ndefer(l.append("=",rhs,";"));
		  if lside.tp.is_atomic then
		     ndefer(s1+"="+l+";");
		  else
		     ndefer("VASS_PL("+s1+","+mang(lside.tp)+","+l+");");
		  end;
	       else
		  if lside.tp.is_atomic then
		     ndefer(s1+"="+rhs+";");
		  else
		     ndefer("VASS_PP("+s1+","+mang(lside.tp)+","+rhs+");");
		  end;
	       end;
	    else
	       ndefer(s1.append(" = ",rhs,";"));
	    end;
	 end;
      end;
      if ~void(global) and prog.psather then
         broadcast(global);
      end;
   end;

   -- prefetch a value. Works like an assignment statement, but the 
   -- rhs must be an ATTR_EXPR of a reference class.
   -- and the lhs must be an AM_LOCAL_EXPR. Anything else will
   -- still work, but it is executed immediatly.
   -- In the cases not accepted as special it works like an AM_ASSIGN
   private emit_am_prefetch_stmt(arg:AM_PREFETCH_STMT) is
      r::=arg.src;
      l::=arg.dest;
      typecase l 
      when AM_LOCAL_EXPR then
         typecase r when AM_ATTR_EXPR then
	    if ~r.ob.tp.is_immutable and ~r.ob.is_near then
	       ax::=emit_expr(r.ob);
	       loc::=emit_expr(l);
	       pr::=emit_expr(arg.prefetch);
	       arg.prefetch.is_hot:=true; -- need a wait for this variable
	       attrname::=mang(r.at,r.self_tp);
	       sp::="(*(PREFETCH *)NULL)";
	       if ~void(current_am_rout_def.specul_prefetch) then
	          sp:=emit_expr(current_am_rout_def.specul_prefetch);
	       end;
	       if r.tp.is_immutable then
		  if r.tp.is_atomic then
		     ndefer("PRE_VA_RATTR_NA(".append(pr,","+sp,","+loc,",",mang(r.self_tp),",".append(ax,",",attrname,");")));
		  else
		     ndefer("PRE_V_RATTR_LP(".append(pr,","+sp,","+mang(r.tp)+","+loc,",",mang(r.self_tp),",".append(ax,",",attrname,");")));
		  end;
	       else
		  ndefer("PRE_R_RATTR_NA(".append(pr,","+sp,","+loc,",",mang(r.self_tp),",".append(ax,",",attrname,");")));
	       end;
	       return;
	    end;
	 else end
      else end;
      -- no special case, make the assignment
      emit_am_assign_stmt(#AM_ASSIGN_STMT(arg));
   end;

   private emit_am_waitfor_stmt(arg:AM_WAITFOR_STMT) is
      if arg.prefetch.is_hot then
	 ndefer("PREFETCH_WAIT("+emit_expr(arg.prefetch)+");");
      end;
   end;

   private emit_am_if_stmt(arg:AM_IF_STMT) is
      s1::=emit_expr(arg.test);
      ndefer("if (".append(s1,") {")); in;
      emit_code(arg.if_true);
      move_out; ndefer("}");
      if ~void(arg.if_false) then
	 ndefer("else {");
	 in;
	 emit_code(arg.if_false);
	 move_out; ndefer("}");
      end;
   end;
       
   private emit_am_loop_stmt(arg:AM_LOOP_STMT) is
      arg_init::=arg.init; -- store arg.init to restore loop at the end
      mlunl::=manual_loop_unlock;
      manual_loop_unlock:=false;
      outer_loop:STR:=current_loop; -- label to go to after loop
      current_loop:=mang(arg, current_sig);
      outer_loop_ex_nesting:INT:=current_loop_ex_nesting;  -- for exception handling
      current_loop_ex_nesting:=ex_nesting;
      fname:STR:=mangler.genother(current_sig); fnamecount::=0; -- otherx ptr
      
      -- contains an association between an iter and all its nested calls, i.e.
      -- the calls in its body!,  ni, nbi are non-void but empty, upon first 
      -- invokation, they are being filled in here
      ni::=nested_its.get(current_am_rout_def);
      nbi::=nested_bits.get(current_am_rout_def);  -- same for biters
      
            
      -- used by optimizer for array stuff
      if ~void(arg.loop_index_var) then 
	 arg.loop_index:=emit_am_local_expr(arg.loop_index_var);
      end;
      
      -- Ivin: do firsts.
      arg.has_init_stmt:=false;
      if prog.psather then
	 if arg.bits.size+arg.its.size>0 and ~arg.no_begin_loop and
	   (~current_sig.is_iter or (~prog.yields_in_locks or ~options.side_effects
	    or current_sig.get_se_context(prog).has_yield_in_lock)) then
	    ndefer("LOOP_BEGIN("+(arg.bits.size+arg.its.size)+")");in;
	    ex_nesting:=ex_nesting+1;
	    current_loop_ex_nesting:=current_loop_ex_nesting+1;
         end;
      end;
      
      -- outputs block deliminator for the loop enclosing block
      if ~void(arg.bits) or ~void(arg.its) or ~void(arg.firsts) or 
	       ~void(arg.init) then
	 comment("loop");
	 arg.has_init_stmt:=true;
	 ndefer("{"); in;
      end;
      
      -- loop over its and later bits
      if ~void(arg.its) then
	 loop e::=arg.its.elt!;
	    
	    -- See comment in emit_iter_call_expr for why these must be here.
	    code_c.uses_sig(e.fun);
	    code_c.uses_iter(e.fun);
	    
	    if ~e.fun.is_builtin then
	       if ~void(ni) then
		  -- inside an iter, so nested frames must be
		  -- placed in this frame instead of as locals.
		  
		  -- make sure same nested iter found only once
		  assert ~ni.contains(e);
		  ni:=ni.push(e);
		  
		  mangler.force_mangle(e,"frame->nested"
		      +ni.size,current_sig);
		  
	       else -- void(ni)
		  comment("Frame for call to "+e.fun.str);		  
	       end;
	       defer_newline;

	       if arg.has_yield then
		  if void(ni) then
		     ndefer(mang(e.fun)+"_frame ");
		  end;
		  if ~(~void(ni) and e.fun.tp.is_abstract) then
		     defer(mang(e,current_sig));
		  end;
		  if ~e.fun.tp.is_abstract then
		     defer(" = OBALLOC("+mang(e.fun)+"_frame);");
		  else
		     defer(";");
		  end;
		  
	       else -- ~arg.has_yield
		  -- at this point iter which are defined on the stack are being 
		  -- handled.
		  tname::=fname+'_'+fnamecount; -- e.g. other1_0
		  fnamecount:=fnamecount+1;
		  if e.fun.tp.is_abstract then
		     if void(ni) then
			ndefer(mang(e.fun)+"_frame ");
			ndefer(mang(e,current_sig)+";"); 
		     end;
		  else  -- ~e.fun.tp.is_abstract
		     defer("struct "+mang(e.fun)
			   +"_frame_struct "+tname+";\n");
		     if void(ni) then
			defer(mang(e.fun)+"_frame ");
			defer(mang(e,current_sig)+" = &"+tname+';');
		     end;
		  end;
	       end;
	    else -- e.fun.is_builtin
	       -- assert(void(e.uniq));
	       if void(e.uniq) then
		  e.uniq:=mang(builtin_cntr,current_sig)+"_";
	       end;
	       if ~void(ni) then
		  -- inside an iter, so nested frames must be
		  -- placed in this frame instead of as locals.
		
		  -- make sure same nested iter found only once
		  assert ~ni.contains(e);

		  ni:=ni.push(e);
		  mangler.force_mangle(e,"frame->nested"
				       +ni.size,current_sig);
	       end;
	       if ~current_sig.is_iter then
		  ndefer("BOOL "+"f_"+e.uniq+" = TRUE;");
	       end;
	    end;
	 end;
	 
	 
	 -- for all dispatched iters compute self
	 -- to be able to determine the tag for dispatch
	 -- emit loop init stmts
	 if ~void(arg.init) then 
	    emit_code(arg.init);
	    arg.init:=void; 
	 end;
	 
	 loop
	    d::=arg.its.elt!;
	    if d.fun.tp.is_abstract then
	       abs_frame_cast ::= "("+mang(d.fun)+"_frame) ";
	       -- put self in a local so it isn't called twice
	       self_ob ::= dec_local(d.fun.tp);
	       the_self ::= emit_expr(d[0].expr);

	       -- initialize self for dispatched frame allocation
	       init_self ::= d.init;
	       typecase init_self
	       when AM_ASSIGN_STMT then
		  emit_am_assign_stmt(init_self);
	       else end; -- init_self can be void (because of const hoisting)
	       ndefer(self_ob.append(" = ",the_self,";"));
	       if chk_void and ~null_segfaults then
		  ndefer("if (".append(self_ob,"==NULL) {"));
		  in; 
		  runtime_error("Dispatched call to "+d.fun.str + " on void self in " + current_function_str); 
		  move_out;
		  ndefer("}");
	       end;
	       tag::="TAG";
	       if prog.distributed then tag:="F_TAG"; end;

	       -- ndefer(mang(d,current_sig)+" = "+abs_frame_cast
	       --     +"(*"+mang(d.fun)+"["+tag+"("+self_ob+")+"
	       --     +mang(d.fun)+"_offset].alloc_frame)();");
	       ndefer(mang(d,current_sig)+" = "+abs_frame_cast
		      +"(*"+mang(d.fun)+"["+tag+"("+self_ob+")].alloc_frame)();");
                 
	    end;
	 end;

	 -- make pointers to frames which are really on the stack
	 -- this couldn't be done above because in C all decs
	 -- must proceed ordinary assignments.
	 
	 
	 if ~void(ni) then
	    fnamecount:=0;
	    loop e::=arg.its.elt!;
	       if ~e.fun.is_builtin_iter then
		  if ~arg.has_yield and ~e.fun.tp.is_abstract then
		     ndefer(mang(e,current_sig)+" = &"+fname
			    +'_'+fnamecount+';');
		     fnamecount:=fnamecount+1;
		  end;
	       end;
	    end;
	 end;
	 
	 -- initialize all iter states, e.g. ... ->state=0
	 loop 
	    it::=arg.its.elt!;
	    if it.init_before_loop then
	       emit_iter_initialization(it); 
	    end;
	    if it.fun.is_builtin then
	       if current_sig.is_iter then ndefer(iter_frame+"f_"+it.uniq+" = TRUE;"); end;
	    else
	       ndefer(mang(it,current_sig)+"->state = 0;");
	    end;
	 end;
      elsif ~void(arg.init) then 
	 emit_code(arg.init);
	 arg.init:=void;
      end;
      -- Ivin.
      if ~void(arg.firsts) then
	 loop
	    e::=arg.firsts.elt!;
	    ndefer (emit_am_local_expr(e)+" = TRUE;");
	 end
      end;
      nested_its:=nested_its.insert(current_am_rout_def,ni);
       
      -- now biters are being treated
      if ~void(arg.bits) then 
       	 defer_newline;
	 comment("Binary copy of bound iterator object for pot. multiple use.");
	 loop e ::= arg.bits.elt!; 
	    -- distinguish between nested bound iter calls, i.e. biter calls within 
	    -- iter calls and biter calls elsewhere
	    if ~void(nbi) and current_sig.is_iter then 
	       -- optimization for later! : first biter does not need to be copied
	       -- since it already exists as object.
	       nbi:=nbi.push(e); 
	       mangler.force_mangle(e,"frame->nested_biter"
		      +nbi.size,current_sig);
	       name ::= "frame->nested_biter"+nbi.size;
	       
	       bnd_iter_expr ::= emit_expr(e.bi);
	       l ::= mangler.genlocal(current_sig); 
	       code_c+eol+' '+mang(e.bi_tp) +' '+l+";";
	       ndefer(l+" = " + bnd_iter_expr+";");
	       ndefer(name+" =  ZALLOC(" + l + "->size);" );
	       ndefer(name + " = ("
		      +mang(e.bi_tp)+") memcpy("+name+","+l+","+l+"->size);");
	       defer_newline;
	    else    
	       -- biter call not within enclosing iter
	       bnd_iter_expr ::= emit_expr(e.bi);
	       l ::= mangler.genlocal(current_sig); 
	       code_c+eol+' '+mang(e.bi_tp) +' '+l+";";
	       ndefer(l+" = " + bnd_iter_expr+";");
	       name ::= mang(e,current_sig);
	       code_c+eol+' '+mang(e.bi_tp) +' '+name+";";
	       ndefer(name+" =  ZALLOC(" + l + "->size);" );
	       ndefer(name+" = ("
		      +mang(e.bi_tp)+") memcpy("+name+","+l+","+l+"->size);");
	       defer_newline;
	    end;
	 end;
      end;
      nested_bits:=nested_bits.insert(current_am_rout_def,nbi);
      ndefer("while (1) {");
      in;
      if polling and options.loop_poll then ndefer("AM_POLL_NETWORK;\n"); end;
      emit_code(arg.body);
      move_out;
      ndefer("}");
      -- Ivin.
      if arg.has_init_stmt then
	 move_out; ndefer("}");
      end;
      ndefer(current_loop.append(": ;"));
      -- Explicitly free any heap-allocated frames
      if arg.has_yield and ~void(arg.its) then
	 loop e::=arg.its.elt!;
	    if ~e.fun.is_builtin_iter then
	       ep::=mang(e,current_sig);
	       ndefer("ZFREE(".append(ep,"); ",ep," = NULL;"));
	    end;
	 end;
      end;
      if prog.psather then
	 if arg.bits.size+arg.its.size>0 and ~arg.no_begin_loop and
	   (~current_sig.is_iter or (~prog.yields_in_locks or ~options.side_effects
	    or current_sig.get_se_context(prog).has_yield_in_lock)) then
	    move_out;ndefer("LOOP_END");
	    ex_nesting:=ex_nesting-1;
         end;
      end;
      current_loop:=outer_loop;
      current_loop_ex_nesting:=outer_loop_ex_nesting;
      manual_loop_unlock:=mlunl;
      arg.init:=arg_init;
   end;

   private emit_am_break_stmt(arg:AM_BREAK_STMT) is
      if manual_loop_unlock then ndefer("LM_LOCK_UNLOCK_NOW;"); end;
      pop_exceptions(ex_nesting-current_loop_ex_nesting);
      ndefer("goto ".append(current_loop,";"));
   end;

   private pop_exceptions(n:INT) is
      -- Pop out n exception levels
      case n
      when 0 then		-- Don't need to take any action
      when 1 then ndefer("POP_EXCEPTION1;");
      else ndefer("POP_EXCEPTION(".append(n.str,");"));
      end;
   end;

   private emit_am_comment_stmt(arg:AM_COMMENT_STMT) is
      ndefer("/* "+arg.comment+" */");
   end;

   private emit_am_return_stmt(arg:AM_RETURN_STMT) is
      if current_am_rout_def.is_external and
	       current_am_rout_def.sig.is_ext_fortran_sig then
	 emit_fortran_return_stmt(arg);
	 return;
      end;
      if current_sig.is_iter then
	 ndefer("frame->state = -1;");
      end;
      if manual_unlock then ndefer("LM_LOCK_UNLOCK_NOW;"); end;
      pop_exceptions(ex_nesting);

      callee_copy_out;
      
      if ~void(current_am_rout_def.specul_prefetch) then
	 ndefer("PREFETCH_SPECUL_WAIT("+emit_expr(current_am_rout_def.specul_prefetch)+");");
      end;
      if ~void(arg.val) then
	 s1::=emit_expr(arg.val);
	 ndefer("return ".append(cast(current_sig.ret,arg.val.tp,s1,false),";"));
      else
	 assert void(current_sig.ret)
	       or current_sig.is_iter;
	 ndefer("return;");
      end;
      if indent=1 then saw_outer_return:=true; end;
   end;

   callee_copy_out is
      -- take care of inout/out args before the function returns
      loop i::=1.upto!(current_am_rout_def.size-1);
	 if current_am_rout_def[i].mode = MODES::inout_mode or
		  current_am_rout_def[i].mode = MODES::out_mode then
	    --copy the local back out
	    if current_am_rout_def.is_iter then
	       l ::= current_iter_out_arg_locals.elt!;
	       ndefer("*"+"frame->" + "arg"+i.str+" = "+
		      "frame->"+mang(l,current_am_rout_def.sig) 
		      + ";");		     
	    else
	       -- normal routine
	       arg_pos:INT;
	       -- self arg is not emitted for Fortran and C
	       if current_am_rout_def.sig.is_ext_fortran_sig or
			current_am_rout_def.sig.is_ext_c_sig then
		  arg_pos := i-1;
	       else
		  arg_pos := i;
	       end;
	       ndefer("*"+current_arg_list[arg_pos]+" = "+
		      mang(current_am_rout_def[i].expr,current_am_rout_def.sig) 
		      + ";");
	    end;
	 end;
      end;
   end;
   
   private emit_am_expr_stmt(arg:AM_EXPR_STMT) is
      if ~void(arg.expr) then	-- the optimizer may produce void expr.
	 s1::=emit_expr(arg.expr);
	 if ~void(s1) then
	    if ~void(arg.expr.tp) then ndefer("(void) ".append(s1,";")); 
	    else ndefer(s1+';');
	    end;
	 end;
      end;
   end;

   private emit_am_yield_stmt(arg:AM_YIELD_STMT) is
      ndefer("frame->state = ".append(arg.ret.str,";"));
      if prog.psather and (~prog.yields_in_locks or ~options.side_effects
	    or current_sig.get_se_context(prog).has_yield_in_lock) then
	 ndefer("frame->ex = GET_EXCEPTION_STACK;");
      end;
      callee_copy_out;
      if ~void(arg.val) then 
	 ndefer("return ".append(
	       cast(current_sig.ret,arg.val.tp,emit_expr(arg.val),false),";"));
      else 
	 ndefer("return;");
      end;
      ndefer("state".append(state_counter.str,":;"));	
      state_counter:=state_counter+1;
   end;

   private emit_am_case_stmt(arg:AM_CASE_STMT) is
      targets:ARRAY{ARRAY{STR}};
      test:STR:=emit_expr(arg.test);

      -- produce C expressions for all target expressions
      if ~void(arg.tgts) then
	 targets:=#ARRAY{ARRAY{STR}}(arg.tgts.size);
	 loop
	    i::=targets.ind!;
	    targets[i]:=#ARRAY{STR}(arg.tgts[i].size);
	    loop 
	       j::=targets[i].ind!;
	       targets[i][j]:=emit_expr(arg.tgts[i][j]);
	    end;
	 end;
	 ndefer("switch (".append(test,") {"));
	 in;
	 comment("case statement");

	 loop
	    i::=targets.ind!;
	    emit_case:BOOL := false;
	    case_str:STR;
	    loop
	       j::=targets[i].ind!;
	       -- emit this target only if it has not been emitted
	       -- before. Can't have duplicate targets in C and
	       -- there is no particular need for it either, as the
	       -- first matching one will be always executed.
	       case_str := "case ";
	       already_emitted:BOOL:=false;
	       loop
		  k ::= 0.upto!(i);
		  
		  loop
		     l:INT;
		     if k/=i then
			l := targets[k].ind!;
		     else
			l :=0.upto!(j-1);
		     end;
		     if targets[k][l] = targets[i][j] then
			already_emitted := true;
		     end;
		  end;
	       end;
	       if ~already_emitted then
		  case_str := case_str + ",".separate!(targets[i][j]); 
		  emit_case := true;
	       end;
	    end;
	    
	    if emit_case then
	       ndefer(case_str + ": ");
	       in; emit_code(arg.stmts[i]); move_out;
	       ndefer(" break;");
	    end;
	 end;

	 ndefer("default: ;");
	 in;
	 if arg.no_else then
	    runtime_error("No applicable target in case statement",arg);
	 else emit_code(arg.else_stmts);
	 end;
	 move_out; move_out;
	 ndefer("}");
      else
	 runtime_error("No applicable target in case statement",arg);
      end;
   end;

   private emit_am_pre_stmt(arg:AM_PRE_STMT) is
      if chk_pre then
	 ndefer("if (!(".append(emit_expr(arg.test),")) {"));
	 in; runtime_error("Violation of precondition",arg);move_out;
	 ndefer("}");
      end;
   end;

   private emit_am_post_stmt(arg:AM_POST_STMT) is
      if chk_post then
	 ndefer("if (!(".append(emit_expr(arg.test),")) {"));
	 in;
	 runtime_error("Violation of postcondition",arg);
	 move_out; 
	 ndefer("}");
      end;
   end;

   private emit_am_initial_stmt(arg:AM_INITIAL_STMT) is
      if chk_post then emit_code(arg.stmts); end;
   end;

   private emit_am_assert_stmt(arg:AM_ASSERT_STMT) is
      if chk_assert then
	 ndefer("if (!(".append(emit_expr(arg.test),")) {"));
	 in; runtime_error("Violation of assertion",arg); move_out; 
	 ndefer("}");
      end;
   end;

   private emit_am_typecase_stmt(arg:AM_TYPECASE_STMT) is
      label:STR; 
      if arg.has_void_stmts or chk_when then
          if prog.distributed and ~arg.test.is_near then
 	    ndefer("if (FVOID(".append(emit_expr(arg.test),")) {"));
 	 else
 	    ndefer("if (".append(emit_expr(arg.test),"==NULL) {"));
 	 end;
	 in;
	 if arg.has_void_stmts then 
	    label := mangler.genother(void);     -- generate label name
	    ndefer("goto "+label+";");
	 else runtime_error("Void object of typecase",arg);
	 end;
	 move_out; 
	 ndefer("} else");
      end;
      emit_typeswitch(arg.test,arg.tgts,arg.stmts);
      if arg.no_else then
	 in;
	 runtime_error("No applicable type in typecase",arg);
	 move_out;
      else
	 if ~void(label) then ndefer(label+": ;"); end;
	 in; emit_code(arg.else_stmts); move_out;
      end;
      move_out;
      ndefer("}");
   end;

   private emit_am_raise_stmt(arg:AM_RAISE_STMT) is
      assert ~void(arg.val);
      ndefer("RAISE(".append(
	   cast(TP_BUILTIN::dollar_ob,arg.val.tp,emit_expr(arg.val),false),
	");"));
   end;

   private emit_am_invariant_stmt(arg:AM_INVARIANT_STMT) is
      if chk_invariant then
         make_sure_emitted(arg.sig);
	 if current_sig.is_iter then
	    if func_tables then
	       ndefer("if (!".append(mang(arg.sig),"(frame->self,&FF)) {"));
	    else
	       ndefer("if (!".append(mang(arg.sig),"(frame->self)) {"));
	    end;
	 else
	    if func_tables then
	       ndefer("if (!".append(mang(arg.sig),"(self,&FF)) {"));
	    else
	       ndefer("if (!".append(mang(arg.sig),"(self)) {"));
	    end;
	 end;
	 in;
	 runtime_error("Failed invariant ".append(arg.sig.str),arg);
	 move_out;
	 ndefer("}");
      end;
   end;

   private emit_am_protect_stmt(arg:AM_PROTECT_STMT) is
      ndefer("PROTECT_BEGIN");
      in;
      ex_nesting:=ex_nesting+1;
      emit_code(arg.body);
      ex_nesting:=ex_nesting-1;
      move_out;
      ndefer("PROTECT_WHEN");
      in;
      emit_typeswitch(#AM_EXCEPT_EXPR(TP_BUILTIN::dollar_ob),
		      arg.tgts, arg.stmts);
      if ~arg.no_else then
	 in; emit_code(arg.else_stmts); move_out;
      else
	 ndefer("RAISE(EXCEPTION);");
      end;
      move_out;
      ndefer("}");		-- Closes type switch
      move_out;
      ndefer("PROTECT_END");
   end;

   private emit_typeswitch(test_expr: $AM_EXPR, tgts:FLIST{$TP}, stmts:FLIST{$AM_STMT}) is
      -- Emit a structure that switches on type.  This is used by both
      -- protect and typecase statements.  The type of an exception
      -- expression should be $OB.  It stops after emitting the
      -- "default:" entry which should then be generated appropriately
      -- by the caller, along with an "out;" and closing curly braces.

      etp ::= test_expr.tp;
      assert etp.is_abstract;	-- all others should have been caught
      
      -- possible types of test_expr
      -- will be shrunken by those which were emitted
      consider: FSET{$TP};
      
      typecase etp
      when TP_CLASS then
         consider := prog.tp_graph_abs_des.des_of(etp).copy;
      end;
      
      test ::= emit_expr(test_expr);

      if prog.distributed then
	 ndefer("switch (F_TAG("+test+")) {");
      else
	 ndefer("switch (TAG("+test+")) {");
      end;
      in;
      if ~void(tgts) then
         -- avoid repeated array creation
         case_arr ::= #ARRAY{$TP}(consider.size); -- big enough to capture all
         case_num : INT;	-- the number of cases to test
         
         loop
            i::=tgts.ind!;
            tp::=tgts[i];
            this_branch: FSET{$TP};
            
            if tp.is_abstract then
               typecase tp
               when TP_CLASS then
                  -- these are subtypes of tp AND test_expr.tp AND not tested already
                  this_branch := prog.tp_graph_abs_des.
			des_of(tp).intersect(consider);
                  -- CAUTION:               ===/\====
                  -- One should use to_intersect here, but that one is broken !
                  -- Fix it first !
               end;

               -- Have to sort it to make canonical ordering
               -- to avoid recompilation

               case_num := this_branch.size;
               if case_num > 0 then
                  loop case_arr.set!(this_branch.elt!) end;
                  case_arr.quicksort_range(0, case_num - 1);
               end;
            else		-- concrete or bound
               if consider.test(tp) then
                  this_branch := #FSET{$TP}.insert(tp);
                  case_num := 1;
                  case_arr[0] := tp;
               else
                  case_num := 0
               end;
            end;

            -- only emit code if some descendant was seen
            if case_num > 0 then
               loop
                  t ::= case_arr.elt!(0, case_num);
                  ndefer("case "+tag_for(t)+":");
               end;

               in;
               emit_code(stmts[i]);
               defer(" break;");
               move_out;

               consider := consider.to_difference(this_branch); -- forget about these
	       -- else emit some warning ?
            end;
         end;
      end;
      ndefer("default: ;"); 
   end; 

   private emit_am_attach_stmt(arg:AM_ATTACH_STMT) is
      -- arg_frames:=arg_frames.insert(arg.rout);
      -- code_c.uses_layout(#ARG_LAYOUT(arg.rout));
      code_c.uses_sig(arg.rout);
      stmt::="";
      if arg.rout.opt_fork then
	 if arg.rout.is_par_routine then
	    stmt:="PARLOOP_";
	    -- the next statement is a lock statement used 
	    -- to wait until the parloop finishes. This is not
	    -- necessary if we use the PARLOOP_ macro. By setting
	    -- this attribute we instruct the compiler to ignore the
	    -- next lock statement.
	    ignore_lock:=true;
	 elsif arg.rout.is_fork_routine and current_sig.opt_fork then
	    stmt:="PARLOOP_FORK_"
	 end;
      elsif arg.rout.is_fork_routine or arg.rout.is_par_routine then
	 stmt:="FORK_";
      end;
      stmt:=stmt+"ATTACH("+mang(arg.rout)
	    +", "+cast(TP_BUILTIN::dollar_ob,arg.rout.tp,"self",false)
	    +", "+emit_expr(arg.helper)
	    +", "+emit_expr(arg.gate);
      if ~void(arg.at) then
	 stmt:=stmt+", "+emit_expr(arg.at);
      else
	 if prog.zones then
	    stmt:=stmt+",SI_HERE()->cluster";
	 else
	    stmt:=stmt+",HERE";
	 end;
      end;
      stmt:=stmt+");";
      if arg.rout.is_fork_routine then stmt:=stmt+"/* forked */"; end;
      if arg.rout.is_attach_routine then stmt:=stmt+"/* attached */"; end;
      if arg.rout.is_par_routine then stmt:=stmt+"/* par */"; end;
      ndefer(stmt);
   end;
   
   private emit_am_fork_stmt(arg:AM_FORK_STMT) is
      -- for now, we handle only a simple call here
      s:$AM_STMT;
      s := arg.body;
      typecase s
      when AM_EXPR_STMT then
	 e:$AM_EXPR := s.expr;
	 typecase e
	 when AM_ROUT_CALL_EXPR then
	    dest:STR; 
	    if ~void(arg.at) then
	       dest := emit_expr(arg.at);
	    else
	       dest := "BR_HERE()";
	    end;
	    ndefer("PAR_INCREMENT(".append(mang(arg.par_stmt), ");"));
	    -- emit a simple fork handler (executed on the remote end
	    
	    -- first, mangle the fork statement itself to the name of the
	    -- fork handler
	    handler:STR := mang(arg);
	    arg_list:ARRAY{STR} := emit_and_cast_args(e);
	    num_args:INT := arg_list.size+1; -- extra arg for par attach 

	    -- emit BR_FORK
	    fork_str:STR := "BR_FORK_".append(num_args.str,"(",dest,",",
					      handler,",");
	    fork_str := fork_str.append("(BR_word_t)&",mang(arg.par_stmt),",");
	    
	    -- take care of self
	    if e.fun.tp.is_immutable then
	       if ~e.fun.tp.is_atomic then
		  barf("non atomic self in a simple fork statement");
	       end;
	       fork_str := fork_str.append("(BR_word_t)", arg_list[0]);
	    else
	       -- reference object. Need to fix cluster number bits
	       fork_str := fork_str.append("(BR_word_t)SENDFOB(", 
					   arg_list[0], ",", dest, ")");
	    end;

	    -- append args
	    loop
	       arg_str:STR;
	       i ::= 1.upto!(e.asize-1);
	       sa ::= e.fun.args[i-1];
	       if sa.tp.is_immutable then
		  if ~sa.tp.is_atomic then
		     barf("non atomic argument in simple fork statement");
		  end;
		  arg_str := "(BR_word_t)"+arg_list[i];
	       else
		  arg_str := "(BR_word_t)".append("SENDFOB(", 
						  arg_list[i],",", dest,")");
	       end;
	       fork_str:=fork_str.append(",",arg_str);
	    end;
	    fork_str := fork_str + ");";
	    ndefer(fork_str);

	    
	    
	    -- emit the BR_FORK_* handler 
	    decl:STR := "void ".append(handler,"(BR_cluster_t src, BR_word_t par_ptr");
	    loop
	       arg_str::=arg_list.elt!;
	       decl := decl.append(", BR_word_t ", "arg_", arg_str);
	    end;
	    decl := decl+")";
	    
	    -- append the declaration to code_c
	    code_c + "\n extern ".append(decl,";\n");
	    unbox_c + "\n/* Fork handler */\n";
	    unbox_c + decl+"{\n";

	    -- previous frame is possibly on a differemt cluster
	    -- this is a new thread, so start from scratch
	    if func_tables then
	       unbox_c + " struct _func_frame FF_NULL={ 0,NULL,NULL };\n"
	    end;
	    
	    -- Initialize local thread memory, etc
	    unbox_c + " INIT_THREAD_MEMORY();\n";
	    unbox_c +  " ".append(mang(e.fun),"(");
	    loop
	       unbox_c + ",".separate!("(".append(mang(e.elt!.expr.tp),")",
						  "arg_", arg_list.elt!));
	    end;
	    if func_tables then
	       -- append an extra arg
	       unbox_c + ",&FF_NULL";
	    end;
	    unbox_c + ");\n";
	    unbox_c + " PAR_DECREMENT(src,(SIMPLE_PAR_ATTACH)par_ptr);\n";
	    unbox_c + "}\n";
	    unbox_c.uses_sig(e.fun);
	 else
	    #OUT + "Error: emit_am_fork_stmt\n";
	    UNIX::exit(1);
	 end;
      else
	 #OUT + "Error: Simple fork body is not a call\n";
	 UNIX::exit(1);	 
      end;
      
   end;
   
   
   private emit_am_par_stmt(stmt:AM_PAR_STMT) is
      comment("PAR start");
      ndefer("do{");
      in;
      
      ndefer("PAR_DEC(".append(mang(stmt),");"));
      ndefer("PAR_START(".append(mang(stmt),");"));
      comment("PAR body");	    
      emit_code(stmt.body);
      ndefer("PAR_END(".append(mang(stmt),");"));
      
      move_out;
      ndefer("}while(0);");
      comment("PAR end");      
   end;   
   
   private find_and_emit_rout_call(ident:STR,arg:AM_LOCK_STMT):STR is
      -- Helper method for emit_am_lock_stmt(arg:AM_LOCK_STMT).
      --
      -- Create a new AM_ROUT_CALL_EXPR on the first lock, that is used to generate
      -- a call for acquiring, trying, releasing or unlocking. This avoids the
      -- use of an external C interface for the lock manager and (in many cases)
      -- dynamic dispatch. So, it's just a performance issue.
      am_call ::= #AM_ROUT_CALL_EXPR(arg.locks[0].asize,arg.source);
      -- Set the argument list.
      loop am_call.set!(#AM_CALL_ARG(arg.locks[0].elt!)); end;
      -- Retrieve the call's signature. This requires the first lock's type.
      -- The type is contained in the first argument which is 'self'.
      tp ::= arg.locks[0][0].tp;
      lock_tp:TP_CLASS := void;
      typecase tp when TP_CLASS then lock_tp := tp; end;
      if void(lock_tp) then barf("Bad type of lock in lock statement."); end;
 
      method_id ::= #IDENT(ident);
      if ~lock_tp.is_abstract then
         loop
	    am_call.fun := lock_tp.impl.elts.get_query!(method_id).sig;
	    break!
	 end;
      else
	 -- For abstract classes we use the dispatch table of class $LOCK
	 -- which does already exist. A dispatch table for system locks
	 -- like $GATE or user defined locks might not exist and is difficult
	 -- to produce at this point.
	 lock_tp := prog.tp_tbl.tp_class_for("$LOCK");
	 loop
	    am_call.fun := lock_tp.ifc.sigs.get_query!(method_id);
	    break!
	 end;
      end;
      -- Here is the code.
      return emit_call(am_call.fun,am_call,emit_and_cast_args(am_call));
   end;
 

   private emit_am_lock_stmt(arg:AM_LOCK_STMT) is
      if ignore_lock then ignore_lock:=false;return; end;
      if arg.manual_unlock then
	 prog.stat.incr("O: # of locks not put on exception stack");
	 assert(~manual_unlock);
	 manual_unlock:=true;
	 manual_loop_unlock:=true;
      end;
      branches::=arg.locks.size;
      cols::=0;
      loop cols:=cols.max(arg.locks.elt!.size); end;
      if manual_unlock and branches = 1 and cols = 1 then
	 -- Shortcut for faster execution in simple cases: no exception stack
	 -- entry required and only one lock.
	 -- Check for a guard.
	 stmt:STR;
	 if ~void(arg.guards[0]) then
	    ndefer("if("+emit_expr(arg.guards[0])+") {");
	 else
	    ndefer("{");
	 end;
	 -- Create a string of the lock. Avoid destroying it, it'll be reused.
         no_destroy_lock:=true;
	 this_lock_str ::= emit_expr(arg.locks[0][0]);
         no_destroy_lock:=false;
         -- Check the type of the lock object.
	 if void(arg.else_stmts) then
	    -- No else clause.
	    -- Code for acquiring the lock Avoid destroying it, it'll be reused.
            no_destroy_lock:=true;
	    ndefer(find_and_emit_rout_call(
                                   "access_acquire_single_lock",arg)+";");
            no_destroy_lock:=false;
            -- The following two variables are used by unlock and release.
	    ndefer("{   void* pp_n = (void*)0; void* locked_lock = "
		   + this_lock_str + ";");
	    -- Code inside the lock statement (the when clause).
	    in; emit_code(arg.stmts[0]); move_out;
	    -- Code for releasing the lock.
	    -- If the lock has been unlocked explicitely, 'locked_lock' is void.
	    ndefer("locked_lock = "+this_lock_str+";");
	    ndefer(find_and_emit_rout_call("access_release_single_lock",arg)+";}");
	    manual_unlock:=false;
	    manual_loop_unlock:=false;
	 else
	    -- Else clause present.
	    -- Code for trying the lock.
	    ndefer("if (" + find_and_emit_rout_call("access_try_single_lock",arg)
		          + ")");
            -- The following two variables are used by unlock and release.
	    ndefer("{   void* pp_n = (void*)0; void* locked_lock = "
		   + this_lock_str + ";");
	    -- Code inside the lock statement (the when clause).
	    in; emit_code(arg.stmts[0]); move_out;
	    -- Code for releasing the lock.
	    -- If the lock has been unlocked explicitely, 'locked_lock' is void.
	    ndefer("locked_lock = "+this_lock_str+";");
	    ndefer(find_and_emit_rout_call("access_release_single_lock",arg)+";");
	    manual_unlock:=false;
	    manual_loop_unlock:=false;
	    ndefer("} else {");
	    in; emit_code(arg.else_stmts); move_out;
	    ndefer("}");
	 end;
	 ndefer("}");
      else
	 -- Exception stack entry required or multiple when clauses present.
         stmt::="DECLARE_LOCK("+branches+","+cols+",0";
         if ~void(arg.else_stmts) then stmt:=stmt+"|LOCK_WITH_ELSE"; end;
         if arg.manual_unlock then stmt:=stmt+"|LOCK_NO_STACK"; end;
         stmt:=stmt+")";
         ndefer(stmt);
         loop
	    c::=0.up!;
	    l::=arg.locks.elt!;
	    g::=arg.guards.elt!;
	    if l.size>15 then barf("You cannot have more than 15 locks in one 'when' branch");end;
	    stmt:="";    
	    if ~void(g) then stmt:=stmt+"if("+emit_expr(g)+") {"; end;
	    loop
	       ln::=0.up!;
	       stmt:=stmt+"ADD_LOCK("+c+","+ln+","+emit_expr(l.elt!)+");";
	    end;
	    if ~void(g) then stmt:=stmt+" }"; end;
	    ndefer(stmt);
         end;
         if ~manual_unlock then ex_nesting:=ex_nesting+1; end;
         -- Now select the Function to call for acquiring the lock(s).
         if branches = 1 then
	    -- Only one when clause.
	    if cols = 1 then
	       -- Only one lock.
	       if void(arg.else_stmts) then
	          -- No else clause.
	          -- Code for acquiring the lock.
		  ndefer("LM_ACQUIRE_SINGLE_LOCK");
	          -- Code inside the lock statement (the when clause).
	          if ~manual_unlock then ndefer("LM_PUSH_ON_EXEPT_STACK"); end;
	          in; emit_code(arg.stmts[0]); move_out;
	          if ~manual_unlock then ex_nesting:=ex_nesting-1; end;
	          -- Code for releasing the lock.
		  ndefer("LM_RELEASE_SINGLE_LOCK");
	          if ~manual_unlock then ndefer("LM_POP_OFF_EXEPT_STACK"); end;
	          manual_unlock:=false;
	          manual_loop_unlock:=false;
	       else
	          -- Else clause present.
	          -- Code for trying the lock.
		  ndefer("LM_TRY_SINGLE_LOCK");
	          if ~manual_unlock then ndefer("LM_PUSH_ON_EXEPT_STACK"); end;
	          -- Code inside the lock statement (the when clause).
	          in; emit_code(arg.stmts[0]); move_out;
	          if ~manual_unlock then ex_nesting:=ex_nesting-1; end;
		  ndefer("LM_RELEASE_SINGLE_LOCK");
	          if ~manual_unlock then ndefer("LM_POP_OFF_EXEPT_STACK"); end;
	          manual_unlock:=false;
	          manual_loop_unlock:=false;
	          ndefer("} else {");
	          in; emit_code(arg.else_stmts); move_out;
	          ndefer("}");
	       end;
	    else
	       -- Multiple conjunctive locks.
	       if void(arg.else_stmts) then
	          -- No else clause.
	          ndefer("LM_ACQUIRE_CONJUNCTIVE_LOCKS");
	          if ~manual_unlock then ndefer("LM_PUSH_ON_EXEPT_STACK"); end;
	          in; emit_code(arg.stmts[0]); move_out;
	          if ~manual_unlock then ex_nesting:=ex_nesting-1; end;
	          ndefer("LM_RELEASE_CONJUNCTIVE_LOCKS");
	          if ~manual_unlock then ndefer("LM_POP_OFF_EXEPT_STACK"); end;
	          manual_unlock:=false;
	          manual_loop_unlock:=false;
	       else
	          -- Else clause present.
	          ndefer("LM_TRY_CONJUNCTIVE_LOCKS");
	          if ~manual_unlock then ndefer("LM_PUSH_ON_EXEPT_STACK"); end;
	          in; emit_code(arg.stmts[0]); move_out;
	          if ~manual_unlock then ex_nesting:=ex_nesting-1; end;
	          ndefer("LM_RELEASE_CONJUNCTIVE_LOCKS");
	          if ~manual_unlock then ndefer("LM_POP_OFF_EXEPT_STACK"); end;
	          manual_unlock:=false;
	          manual_loop_unlock:=false;
	          ndefer("} else {");
	           in; emit_code(arg.else_stmts); move_out;
	         ndefer("}");
	       end;
	    end;
         else
	    -- Multiple when clauses.
	    ndefer("LM_SELECT_DISJUNCTIVE_LOCKS");
	    loop
	       stt::=arg.stmts.elt!;
	       ndefer("LM_LOCK_CLAUSE("+0.up!+")");
	       if ~manual_unlock then ndefer("LM_PUSH_ON_EXEPT_STACK"); end;
	       in; emit_code(stt); move_out;
	       ndefer("LM_RELEASE_DISJUNCTIVE_LOCKS");
	       if ~manual_unlock then ndefer("LM_POP_OFF_EXEPT_STACK"); end;
	    end;
            if ~manual_unlock then ex_nesting:=ex_nesting-1; end;
            manual_unlock:=false;
            manual_loop_unlock:=false;
	    if ~void(arg.else_stmts) then
	       ndefer("LM_ELSE_CLAUSE");
	       in; emit_code(arg.else_stmts); move_out;
	    end;
	    ndefer("LM_END_DISJUNCTIVE_LOCKS_SELECTION");
         end;
         ndefer("LM_CLOSE_LOCK_STATEMENT");
      end;
   end;

   private emit_am_sync_stmt(arg:AM_SYNC_STMT) is
      ndefer("SYNC;");
   end;

   private emit_am_unlock_stmt(arg:AM_UNLOCK_STMT) is
      ndefer("/* Should implement unlock checking here! */");
      ndefer("LM_UNLOCK("+emit_expr(arg.lock_ob)+");");
   end;

   private runtime_error(s:STR,am:$AM) is
      if prog.chk_no_line_numbers then
	 -- This can significantly improve incrementality, especially
	 -- if source files are large
	 runtime_error(s+"\\nin "+current_function_str+"\\n");
      else
	 runtime_error(s+"\\nin "+current_function_str+"\\n"+am.source.str);
      end;
   end;

   private runtime_error(s:STR) is
      -- emit (deferred) code to generate a fatal error at runtime.

      ndefer("FATAL(\""+s+"\");");
   end;

   private emit_args(arg:$AM_CALL_EXPR):ARRAY{STR} is
      -- declare auto variables for any subexpressions that
      -- can't be in-line; at the moment that means anything
      -- which is a call.  Anything which might be emitted
      -- as a macro (built in functions) need to not have
      -- subexpressions as arguments either 
      
      subexpr:STR;
      res::=#ARRAY{STR}(arg.asize);
      sig_args:ARRAY{ARG};	-- formal parameters in the signature
      
      is_ext::=false;
      is_ext_fortran::=false;
      is_bnd::=false;
      is_iter::=false;
      
      might_be_macro::=false;
      typecase arg 
      when AM_EXT_CALL_EXPR then 
	 is_ext:=true;
	 sig_args := arg.fun.args; 
      when AM_ROUT_CALL_EXPR then
	 might_be_macro:=arg.fun.is_builtin;
	 sig_args := arg.fun.args;
      when AM_ITER_CALL_EXPR then 
	 might_be_macro:=arg.fun.is_builtin;
      	 sig_args := arg.fun.args;
         is_iter:=true;
      when AM_BND_ROUT_CALL_EXPR then
	 sig_args := arg.br_tp.args;
	 is_bnd := true;
     when AM_BND_ITER_CALL_EXPR then  
	sig_args := arg.bi_tp.args;  
	is_bnd := true;
	is_iter:=true;
      when AM_ATTR_EXPR then
	 -- those are macros in psather that need locals as arguments
         might_be_macro:=prog.psather;
      end; -- bound iters are not implemented yet
      
      -- first, find the last argument which isn't a call
      last:INT;
      loop last:=(arg.asize-1).downto!(-1);
	 while!(last>=0);
	 if ~void(arg[last]) then
	    e::=arg[last].expr;
	    typecase e when $AM_CALL_EXPR then break!; else end;
         end;
      end;
      last:=(last+1).min(arg.asize-1);

      -- first emit self. It always has ``in'' mode
      if ~is_bnd then
	 if ~is_ext and ~void(arg[0]) then
	    self_expr::=arg[0].expr; 
	    res[0] := emit_expr(self_expr);
	    typecase self_expr
	    when AM_LOCAL_EXPR then -- locals can't be affected
	    when $AM_CONST then	-- constants can't be affected
	       if prog.psather and might_be_macro then
		  subexpr:=res[0];
		  res[0]:=dec_local(self_expr.tp);
		  ndefer(res[0].append(" = ",subexpr,";"));
	       end;
	    else
	       if might_be_macro or last>0 then
		  subexpr:=res[0];
		  res[0]:=dec_local(self_expr.tp);
		  ndefer(res[0].append(" = ",subexpr,";"));
	       end;
	    end;		 	  
	 end;
	 
	 if arg.asize>1 then
	    loop i::=1.upto!(arg.asize-1);
	       if ~void(arg[i]) then -- this happens in builtin iter_init, non once
	                        -- arguments are set to void.
		  e::=arg[i].expr;
		  typecase e
		  when $AM_CONST then 
		     if prog.psather and might_be_macro then 
		     		-- even constants have to be in locals,
		     	        -- as many builtins need their address.
			res[i] := emit_call_arg(arg[i], sig_args[i-1], true, false);
		     else
		        res[i] := emit_expr(e) -- constants can't be affected
		     end;
		  when AM_LOCAL_EXPR then
		     res[i] := emit_call_arg(arg[i], sig_args[i-1], false,false);
		  else
		     if might_be_macro or i<last or 
			      SYS::ob_eq(arg[i].mode, MODES::out_mode) or
			      SYS::ob_eq(arg[i].mode, MODES::inout_mode) 
		     then
			res[i] := emit_call_arg(arg[i], sig_args[i-1], true, false);
		     else
			res[i] := emit_expr(e);
		     end;
		  end;
	       else
		  res[i]:="\n#error Internal Sather Compiler error: using hot argument in builtin iter initialization\n";
	       end;
	    end;
	 end;
      else			-- bound rout call
	 loop i::=0.upto!(arg.asize-1);
	    e::=arg[i].expr;
	    typecase e
	    when $AM_CONST then 
	       res[i] := emit_expr(e) -- constants can't be affected
	    when AM_LOCAL_EXPR then
	       res[i] := 
		     emit_call_arg(arg[i], sig_args[i], false, false);
	    else
	       if might_be_macro or i<last or 
		  SYS::ob_eq(arg[i].mode, MODES::out_mode) or
			SYS::ob_eq(arg[i].mode, MODES::inout_mode) then
		  res[i] := emit_call_arg(arg[i], sig_args[i], true, false);
	       else
		  res[i] := emit_expr(e);
	       end;
	    end;
	 end;
      end;
      return res;
   end;

   emit_call_arg(a:AM_CALL_ARG, sa:ARG, need_local:BOOL, force_reference:BOOL):STR is
      res:STR;
      se: STR;
      
      se := emit_expr(a.expr);
      if a.mode = MODES::out_mode or 
	       a.mode = MODES::inout_mode then
	 if sa.tp.is_immutable and 
		  SYS::ob_eq(a.mode, MODES::out_mode) and
		  a.expr.tp.is_abstract then
	    -- casting is done after the call!
	    tmp ::= dec_local(sa.tp);	   
	    res := dec_local_ptr(sa.tp);
	    ndefer(res.append(" = &", tmp, ";"));
	 else
	    res := dec_local_ptr(a.expr.tp);
	    ndefer(res.append(" = &", se,";")); 
	 end;
      elsif force_reference then
	 if need_local then
	    tmp ::= dec_local(a.expr.tp);
	    ndefer(tmp.append(" = " + se + ";"));
	    res := "&"+tmp;
	 else
	    res := "&"+se;
	 end;
      else
	 if need_local then
	    res := dec_local(a.expr.tp);
	    ndefer(res.append(" = ", se, ";"));
	 else
	    res := se;
	 end;
      end;
      return res;
   end;
   
 
   
   caller_copy_out(ce:$AM_CALL_EXPR, arg_list:ARRAY{STR}) is
      -- Update the out/inout arguments in the external call and
      -- sometimes out arguments in internal calls (usually done by
      -- the callee), to reflect the 
      -- results of execution (value-result semantics)
      res:STR;
      arg:AM_CALL_ARG;
      sig_arg:ARG;
      
      typecase ce
      when AM_EXT_CALL_EXPR then
	 loop i::= 1.upto!(ce.asize-1);
	    ca ::= ce[i];
	    caller_ext_copy_out(ca,ce.fun.args[i-1], arg_list[i]);
	 end;
      when AM_ROUT_CALL_EXPR then
	 loop i::= 1.upto!(ce.asize-1); 
	    caller_value_boxing(ce[i], ce.fun.args[i-1], arg_list[i]);
	 end;
      when AM_ITER_CALL_EXPR then
	 loop
	    e::=ce.elt!(1);
	    fe::=ce.fun.args.elt!;
	    i::=1.up!;
	    -- use canonical names for args on the frame
	    caller_value_boxing(e, fe,(mang(ce,current_sig)+"->"+"arg"+i.str));
	 end;
      when AM_BND_ROUT_CALL_EXPR then
	 loop i::= 0.upto!(ce.asize-1); 
	    caller_value_boxing(ce[i], ce.br_tp.args[i], arg_list[i]);
	 end;	 
      end;
   end;
      
   need_caller_copy_out(ce:$AM_CALL_EXPR): BOOL is
      arg:AM_CALL_ARG;
      sig_arg:ARG;
      sig_args:ARRAY{ARG};
      is_ext:BOOL:=false;
      is_bnd:BOOL := false;
      
      typecase ce
      when AM_EXT_CALL_EXPR then
	 sig_args:=ce.fun.args;
	 is_ext := true;
      when AM_ROUT_CALL_EXPR then
	 sig_args := ce.fun.args;
      when AM_ITER_CALL_EXPR then
	 sig_args := ce.fun.args;
      when AM_BND_ROUT_CALL_EXPR then
	 sig_args := ce.br_tp.args;
	 is_bnd := true;
      when AM_BND_ITER_CALL_EXPR then
	 sig_args := ce.bi_tp.args;
	 is_bnd := true;
      end;
      if ~is_bnd then
	 loop i::= 1.upto!(ce.asize-1); 
	    arg:= ce[i];
	    a::=arg.expr;
	    typecase a when AM_SHARED_EXPR then
	       if arg.mode=MODES::out_mode or arg.mode=MODES::inout_mode then
	          return true;
	       end;
	    else end;
	    sig_arg := sig_args[i-1];
	    
	    if is_ext and arg.mode = MODES::out_mode 
		     or arg.mode = MODES::inout_mode then
	       return true;
	    end;
	    
	    if sig_arg.tp.is_immutable  and arg.expr.tp.is_abstract and 
		     sig_arg.mode = MODES::out_mode then
	       return true;  
	    end;
	 end;
      else			-- Bound routines/iters
	 loop i::= 0.upto!(ce.asize-1); 
	    arg:= ce[i];
	    typecase arg when AM_SHARED_EXPR then
	       if arg.mode=MODES::out_mode or arg.mode=MODES::inout_mode then
	          return true;
	       end;
	    else end;
	    sig_arg := sig_args[i];

	    if sig_arg.tp.is_immutable  and arg.expr.tp.is_abstract and 
		     sig_arg.mode = MODES::out_mode then
	       return true;  
	    end;
	 end;
      end;
      return false;
   end;

   -- This needs to be fixed to take into account arrays and attributes
   caller_value_boxing(arg: AM_CALL_ARG, sig_arg: ARG, arg_str:STR) is
      -- Do boxing for out args if needed: actual arg is abstract 
      -- and formal is value
      if sig_arg.tp.is_immutable and SYS::ob_eq(arg.mode, MODES::out_mode) 
	       and arg.expr.tp.is_abstract then 
	 -- need to cast back out args
	 local::=cast(arg.expr.tp, sig_arg.tp, "*"+arg_str,false);
	 ndefer(emit_expr(arg.expr) + " = "+local+';');	 
      end;
      g::=arg.expr;
      typecase g when AM_SHARED_EXPR then
         broadcast(g);
      else end;
   end;

   caller_ext_copy_out(arg: AM_CALL_ARG, sig_arg: ARG, arg_str:STR) is
      -- copy out in caller to ensure pass by value/result for
      -- external calls. It has to be done here since ext. routines
      -- are beyond our control
      if arg.mode = MODES::out_mode or arg.mode = MODES::inout_mode then
	 if arg.expr.tp.is_abstract then
	    local::=cast(arg.expr.tp, sig_arg.tp, "*"+arg_str,false);
	    ndefer(emit_expr(arg.expr) + " = "+local+';');	
	 else
	    if arg.expr.tp.is_immutable then
	       ndefer(emit_expr(arg.expr) + " = *"+arg_str+';');
	    else
	       ndefer("*(" + emit_expr(arg.expr)+") = *"+arg_str+';');
	    end;
	 end;
	 g::=arg.expr;
	 typecase g when AM_SHARED_EXPR then
	    broadcast(g);
	 else end;
      end;
   end;
   
   private emit_and_cast_once_args(arce:AM_ITER_CALL_EXPR):ARRAY{STR} is
      -- emit args, properly casted for the given routine call
      am::=#ARRAY{AM_CALL_ARG}(arce.asize);
      loop 	-- hide all hot (non once) arguments
	 i::=am.ind!;
	 am[i]:=arce[i];
	 if i>0 and ~void(arce.fun.hot) and arce.fun.hot[i-1] then
	    arce[i]:=void;
	 end;
      end;
      arg_list::=emit_args(arce);
      loop arce.set!(am.elt!); end;
      arg_list[0]:=cast(arce.fun.tp,arce[0].expr.tp,arg_list[0],false);
      loop
	 i::=1.upto!(arg_list.size-1);

	 if void(arce.fun.hot) or ~arce.fun.hot[i-1] then
	    if ~(arce.fun.args[i-1].tp.is_immutable and 
		 SYS::ob_eq(arce[i].mode, MODES::out_mode) and
		 arce[i].expr.tp.is_abstract)
	    then
	       arg_list[i]:=cast(arce.fun.args[i-1].tp,
				 arce[i].expr.tp,arg_list[i],arce.fun.is_builtin);
	    end;
	    -- casting for out args in the opposite direction is done
	    -- after the call
	 end;
      end;
      arce.arg_list:=arg_list;
      return arg_list;
   end;

   private emit_and_cast_hot_args(arce:AM_ITER_CALL_EXPR):ARRAY{STR} is
      if void(arce.fun.hot) then return arce.arg_list; end;
      am::=#ARRAY{AM_CALL_ARG}(arce.asize);
      loop 	-- hide all hot (non once) arguments
	 i::=am.ind!;
	 am[i]:=arce[i];
	 if i>0 and (void(arce.fun.hot) or ~arce.fun.hot[i-1]) then
	    arce[i]:=void;
	 end;
      end;
      arce[0]:=void; -- self is never hot
      arg_list::=emit_args(arce);
      loop arce.set!(am.elt!); end;
      arg_list[0]:=cast(arce.fun.tp,arce[0].expr.tp,arg_list[0],arce.fun.is_builtin);
      loop
	 i::=1.upto!(arg_list.size-1);

	 if arce.fun.hot[i-1] then
	    if ~(arce.fun.args[i-1].tp.is_immutable and 
		 SYS::ob_eq(arce[i].mode, MODES::out_mode) and
		 arce[i].expr.tp.is_abstract) 
	    then
	       arg_list[i]:=cast(arce.fun.args[i-1].tp,
			      arce[i].expr.tp,arg_list[i],arce.fun.is_builtin);
	    end;
	    arce.arg_list[i]:=arg_list[i];
	    -- casting for out args in the opposite direction is done
	    -- after the call
	 end;
      end;
      return arce.arg_list;
   end;

   private emit_and_cast_args(arce:$AM_CALL_EXPR):ARRAY{STR} is
      -- emit args, properly casted for the given routine call
      sig_args:ARRAY{ARG};
      self_tp:$TP; -- self type

      arg_list::=emit_args(arce);
      
      typecase arce
      when AM_ROUT_CALL_EXPR then 
	 arg_list[0]:=cast(arce.fun.tp,arce[0].expr.tp,arg_list[0],arce.fun.is_builtin);
	 loop
	    i::=1.upto!(arg_list.size-1);
	    if ~(arce.fun.args[i-1].tp.is_immutable and 
		 SYS::ob_eq(arce[i].mode, MODES::out_mode) and
		 arce[i].expr.tp.is_abstract)
	    then
	       arg_list[i]:=cast_arg(arce.fun.args[i-1].tp,
				 arce[i].expr.tp,arg_list[i], arce.fun.is_builtin, arce[i].mode);
	    end;
	    -- casting for out args in the opposite direction is done
	    -- after the call
	 end;	 
      when AM_BND_ROUT_CALL_EXPR then 
--	 arg_list[0]:=cast(arce.br_tp.args[0].tp,arce[0].expr.tp,arg_list[0]);
	 loop
	    i::=0.upto!(arg_list.size-1);
	    if ~(arce.br_tp.args[i].tp.is_immutable and 
		 SYS::ob_eq(arce.br_tp.args[i].mode, MODES::out_mode) and
		 arce[i].expr.tp.is_abstract)
	    then
	       arg_list[i]:=cast_arg(arce.br_tp.args[i].tp,
				 arce[i].expr.tp,arg_list[i], false, arce[i].mode);
	    end;
	    -- casting for out args in the opposite direction is done
	    -- after the call
	 end;	 	 
      end;
      -- iters never get here!
      return arg_list;
   end;

   expand_macro(r:STR,call:$AM_CALL_EXPR,fun:SIG,args:ARRAY{STR},uniq:STR):STR is
      return expand_macro(r,call,fun,args,uniq,"",void);
   end;

   expand_macro(r:STR,call:$AM_CALL_EXPR,fun:SIG,args:ARRAY{STR},uniq:STR,frame:STR):STR is
      return expand_macro(r,call,fun,args,uniq,frame,void);
   end;

   expand_macro(r:STR,call:$AM_CALL_EXPR,fun:SIG,args:ARRAY{STR},uniq:STR,frame:STR,loop_index:STR):STR is
      res:STR;
      i:INT:=0;
      has_near:BOOL;
      near_failed:BOOL;
      loop while!(i<r.size);
	 case r[i]
	 when '\\' then
	    i:=i+1;
	    res:=res+r[i];
	 when '@' then
	    i:=i+1;
	    cast::=false;
	    tp:$TP;
	    if r[i]='(' then cast:=true; i:=i+1; end;
	    case r[i] 
	    when '0' then
	       tp:=fun.tp;
	    when '1','2','3','4','5','6','7','8','9' then
	       l:INT:=r[i].int-'1'.int;
	       tp:=fun.args[l].tp;
	    when 'r' then
	       if void(fun.ret) then
		  barf("@r is undefined for macro ("+r+") in CONFIG for "+fun.str);
	       end;
	       tp:=fun.ret;
	    when 'P' then
	       i:=i+1;
               tparams ::= fun.src_tparams;
	       if r[i]<'0' or r[i]>'9' then
	          barf("@P must be followd by a digit, not by "+r[i]+"\n");
	       end;
               if r[i].int-'0'.int>=tparams.size then
                  barf("@P"+r[i]
                        +" out of bounds (macro "+r+", sig "+fun.str+")\n");
               end;
               tp:=tparams[r[i].int-'0'.int];
	    when '@' then
	       res:=res+" ";
	       ru::="";
	       if manual_loop_unlock then ru:="LM_LOCK_UNLOCK_NOW;"; end;
	       case ex_nesting-current_loop_ex_nesting
	       when 0 then res:=res.append(ru,"goto ",current_loop);
	       when 1 then res:=res.append("do { ",ru,"POP_EXCEPTION1; goto ",current_loop,";} while(0)");
	       else res:=res.append("do { "+ru,"POP_EXCEPTION(",
				    (ex_nesting-current_loop_ex_nesting).str,
				    "); goto ",current_loop,";} while(0)");
	       end;
	    when '.' then
	       arg_name::="";
	       i:=i+1;
	       loop
	          while!(r[i].is_alphanum or r[i]='_');
		  arg_name:=arg_name+r[i];
		  i:=i+1;
	       end;
	       i:=i-1;
	       tp:=void;
	       argi::=#IDENT(arg_name);
	       loop
		  elt::=fun.tp.impl.elts.elt!;
		  if (elt.is_attr_reader or elt.is_shared_reader or elt.is_const_reader) and elt.name=argi then
		     tp:=elt.ret;
		     break!;
		  end;
	       end;
	       if void(tp) then 
	          barf("unknwon attribute name ."+arg_name+" in CONFIG macro for "+fun.str+" ("+r+")");
	       end;
	    else
	       barf("unknown '@"+r[i]+"' macro in CONFIG for "+fun.str+" ("+r+")");
	    end;
	    if r[i]/='@' then
	       if cast then
	          if ~tp.is_immutable then
		     res:=res+"("+mang(tp)+")";
		  end;
		  i:=i+1;
	       else
	          res:=res+mang(tp);
	       end;
	    end;
	 when '^' then
	    i:=i+1;
	    if void(call) then 
	       res:=res+"0"; 
	    else
	       case r[i] 
	       when '0','1','2','3','4','5','6','7','8','9' then
		  if void(args) then
		     barf("^n cannot be used in the string '"+r+"', in CONFIG for "+fun.str);
		  end;
		  l:INT:=r[i].int-'0'.int;
		  has_near:=true;
		  if call[l].expr.is_near then
		     res:=res+"1"+"/*"+args[l]+"*/";
		  else 
		     res:=res+"0";
		     near_failed:=true;
		  end;
	       end;
	    end;
	 when '$' then
	    i:=i+1;
	    case r[i] 
	    when '0','1','2','3','4','5','6','7','8','9' then
	       if void(args) then
		  barf("$n cannot be used in the string '"+r+"', in CONFIG for "+fun.str);
	       end;
	       l:INT:=r[i].int-'0'.int;
	       res:=res+args[l];
	    when '$' then
	       if i>1 and r[i-2].is_alpha then
		  res:=res+uniq;
	       else
		  res:=res+frame+uniq;
	       end;
	    when '#' then
	       if void(loop_index) then
		  res:=res+frame+"i_"+uniq;
	       else
		  res:=res+loop_index; -- frame is included in loop_index
	       end;
	    when '.' then
	       arg_name::="";
	       i:=i+1;
	       loop
	          while!(r[i].is_alphanum or r[i]='_');
		  arg_name:=arg_name+r[i];
		  i:=i+1;
	       end;
	       i:=i-1;
	       done::=false;
	       argi::=#IDENT(arg_name);
	       loop
		  elt::=fun.tp.impl.elts.elt!;
		  if (elt.is_attr_reader or elt.is_shared_reader or elt.is_const_reader) and elt.name=argi then
		     res:=res+mang(argi,elt.tp);
		     done:=true;
		     break!;
		  end;
	       end;
	       if ~done then
	          barf("unknwon attribute name ."+arg_name+" in CONFIG macro for "+fun.str+" ("+r+")");
	       end;
	    else
	       barf("unknown '$"+r[i]+"' macro in CONFIG for "+fun.str+" ("+r+")");
	    end;
	 when '%' then
	    i:=i+1;
	    case r[i] 
	    when '0' then
	       if fun.tp.is_immutable then 
	          if fun.tp.is_atomic then 
		     res:=res+'1'; 
		  else
		     res:=res+'2';
		  end;
	       else res:=res+'0'; end;
	    when '1','2','3','4','5','6','7','8','9' then
	       l:INT:=r[i].int-'1'.int;
	       if fun.args[l].tp.is_immutable then
	          if fun.args[l].tp.is_atomic then
		     res:=res+'1'; 
	          else
		     res:=res+'2'; 
	          end;
	       else res:=res+'0'; end;
	    when '.' then
	       arg_name::="";
	       i:=i+1;
	       loop
	          while!(r[i].is_alphanum or r[i]='_');
		  arg_name:=arg_name+r[i];
		  i:=i+1;
	       end;
	       i:=i-1;
	       done::=false;
	       argi::=#IDENT(arg_name);
	       loop
		  elt::=fun.tp.impl.elts.elt!;
		  if (elt.is_attr_reader or elt.is_shared_reader or elt.is_const_reader) and elt.name=argi then
		     if elt.ret.is_immutable then
			if elt.ret.is_atomic then
			   res:=res+'1'; 
			else
			   res:=res+'2'; 
			end;
		     else res:=res+'0'; end;
		     done:=true;
		     break!;
		  end;
	       end;
	       if ~done then
	          barf("unknwon attribute name ."+arg_name+" in CONFIG macro for "+fun.str+" ("+r+")");
	       end;
	    when 'r' then
	       if void(fun.ret) then
		  barf("%r is undefined for macro ("+r+") in CONFIG for "+fun.str);
	       end;
	       if fun.ret.is_immutable then 
	          if fun.ret.is_atomic then
		     res:=res+'1'; 
	          else
		     res:=res+'2';
		  end;
	       else res:=res+'0'; end;
	    when 'P' then
	       i:=i+1;
               tparams ::= fun.src_tparams;
	       if r[i]<'0' or r[i]>'9' then
	          barf("%P must be followd by a digit, not by "+r[i]+"\n");
	       end;
               if r[i].int-'0'.int>=tparams.size then
                  barf("%P"+r[i]+" out of bounds (macro "+r
                     +", sig "+fun.str+")\n");
               end;
	       if tparams[r[i].int-'0'.int].is_immutable then 
                   if tparams[r[i].int-'0'.int].is_atomic then
                      res:=res+'1'; 
                   else
                      res:=res+'2'; 
                   end;
	       else
                   res:=res+'0';
               end;
	    when '%' then
	       res:=res+'%';
	    else
	       barf("unknown '%"+r[i]+"' macro in CONFIG for "+fun.str+" ("+r+")");
	    end;
	 else res:=res+r[i];
	 end;
	 i:=i+1;
      end;
      if void(res) then res:=""; end;
      if has_near and ~near_failed then prog.stat.incr("O # of builtins with near access"); end;
      return res;
   end;

   -- works only for builtin routines, not for iters!
   -- note that call may be void.
   private process_builtin_routs(fun:SIG, call:$AM_CALL_EXPR, arg_list:ARRAY{STR}):STR is
      res : STR;
      ret : STR;
      biname:STR:=void;

      prog.stat.incr("B: # of builtin function calls");
      if ~prog.distributed and ~void(fun.builtin_info.declare) then 
	 loop code_c.uses_extern(fun.builtin_info.declare.elt!+"\n"); end;
      end;
      if prog.distributed and ~void(fun.builtin_info.f_declare) then 
	 loop code_c.uses_extern(fun.builtin_info.f_declare.elt!+"\n"); end;
      end;
      uniq::=mang(builtin_cntr,current_sig)+"_";

      if ~prog.distributed and ~void(fun.builtin_info.var) then
	 loop res:=res+eol+' '+fun.builtin_info.var.elt!; end;
	 code_c:=code_c+expand_macro(res,call,fun,arg_list,uniq);
	 res:="";
      end;
      if prog.distributed and ~void(fun.builtin_info.f_var) then
	 loop res:=res+eol+' '+fun.builtin_info.f_var.elt!; end;
	 code_c:=code_c+expand_macro(res,call,fun,arg_list,uniq);
	 res:="";
      end;
  	
      exec::=fun.builtin_info.exec;
      if prog.distributed then exec:=fun.builtin_info.f_exec; end;
      loop
	 i::=exec.ind!;
	 if i=exec.size-1 and ~void(fun.ret) then
	    ret:=exec[i];
	 else
	    if exec[i][0]='#' then
	       res:=res+'\n'+exec[i]+'\n';
	       if debug then
		  res:=res+"#line "+last_lineno+" \""+last_file+"\"\n";
	       end;
	    else
	       res:=res+exec[i]+" ";
	    end;
	 end;
      end;
      ndefer(expand_macro(res,call,fun,arg_list,uniq));
      return expand_macro(ret,call,fun,arg_list,uniq);
   end;	

   
   private emit_call(fun:SIG, amexpr:$AM_EXPR, arg_list:ARRAY{STR}):STR is
      -- 'amexpr' can either be a $AM_CALL_EXPR or an AM_BND_CREATE_EXPR.
      -- The later is needed to derive the argument which points to the 
      -- object containing the funcptr that points to the wrapper function to
      -- be called in the case of binding a closure, i.e. bind bind a.call
      call:$AM_CALL_EXPR; ltp::=amexpr; 
      if ~void(amexpr) then
	 typecase ltp
	 when $AM_CALL_EXPR then call := ltp;
	 when AM_BND_CREATE_EXPR then call := void;
	 end;
      else
	 call := void;
      end;
      if ~prog.distributed 
         or ~options.local_call_dynamic 
	 or fun.tp.is_abstract 
	 or fun.is_iter 
	 or fun.is_forked 
	 or void(fun.opt_info) 
	 or void(fun.opt_info.consider) then
	    return pemit_call(fun,void,amexpr,arg_list);
      else
	 to_cons:ARRAY{INT}:=#(fun.opt_info.consider.asize);
	 to_cons_s::=0;
	 remote_call::= -1;
	 remote_call_access::=0;
	 loop
	    i::=fun.opt_info.consider.elt!;
	    if (void(call) or ~call[i].is_near) and
		    fun.opt_info.attr_access[i]>=options.local_call_dynamic_access then
	       to_cons[to_cons_s]:=i;
	       to_cons_s:=to_cons_s+1;
	    end;
	    if remote_call_access<fun.opt_info.attr_access[i] then
	       remote_call_access:=fun.opt_info.attr_access[i];
	       -- if we know already that the best arg. to decide if a 
	       -- remote call is necessary is local, we don't have to do it.
	       if (void(call) or ~call[i].is_near) then remote_call:=i;
	       else remote_call:=-1; end;
	       -- if another argument is as good to call remotly as the one
	       -- we were already considering, and the new one is already local,
	       -- we make no remote call
	    elsif remote_call_access=fun.opt_info.attr_access[i] 
	            and ~void(call) and call[i].is_near then remote_call:=-1;
	    end;
         end;
	 -- #OUT+"calling "+fun.str+":";
	 -- #OUT+"   remote_call_access="+remote_call_access+"\n";
	 if ~options.remote_call or remote_call_access<options.remote_call_access or ~options.side_effects or
	    (fun.get_se_context(prog).has_new and ~options.remote_call_create) then
	       remote_call:=-1;
	 end;

	 if to_cons_s=0 then
	    return pemit_call(fun,void,amexpr,arg_list);
	 end;
	 l:STR;
	 if ~void(fun.ret) then
	    l:=dec_local(fun.ret);
	 end;
	 nearness::=#ARRAY{BOOL}(arg_list.asize);
	 ndefer("switch(");
	 loop 
	    i::=to_cons_s.times!;
	    defer("+(NEAR("+arg_list[to_cons[i]]+")?"+2.pow(0.up!)+":0)");
	 end;
	 defer(") {");
	 loop j::=1.upto!(2.pow(to_cons_s)-1);
	    accs::=0;
	    if remote_call>=0 then
	       loop k::=to_cons_s.times!;
		  -- if the argument we would use to make a far call is already near, 
		  -- we don't need the far call.
		  if j.aelt! then 
		     if remote_call=to_cons[k] then accs:=remote_call_access;break!; end;
		     accs:=accs+fun.opt_info.attr_access[k];
		  end;
	       end;
	    end;
	    if remote_call_access<=accs or remote_call<0 then
	       ndefer("case "+j+": ");
	       in;
	       if ~void(fun.ret) then ndefer(l+"="); end;
	       loop k::=to_cons_s.times!;
		  if j.aelt! then nearness[to_cons[k]]:=true; end;
	       end;
	       defer(pemit_call(fun,nearness,amexpr,arg_list)+";break;");
	       nearness.clear;
	       move_out;
	    end;
	 end;
	 ndefer("default: ");
	 in;
	 if remote_call>=0 then
	    -- assign all arguments to some locals. We need to do that
	    -- as we have no longer access to the AM_EXPR for the arguments
	    -- (actually we do, but as they have already been emitted, we cannot
	    -- use them for our new call used for the AM_AT_EXPR.)
	    args:ARRAY{AM_LOCAL_EXPR}:=#(fun.args.size+1); -- used for standard call
	    argsr:ARRAY{AM_LOCAL_EXPR}:=#(fun.args.size+1); -- used for remote call
	    args[0]:=dec_am_local_expr(fun.tp);
	    argsr[0]:=args[0];
	    ndefer(emit_am_local_expr(args[0])+"="+arg_list[0]+";");
	    arg_list[0]:=emit_am_local_expr(args[0]);
	    loop
	       i::=fun.args.ind!;
	       if fun.args[i].mode/=MODES::in_mode then
		  args[i+1]:=dec_am_local_expr_out(fun.args[i].tp);
		  argsr[i+1]:=dec_am_local_expr(fun.args[i].tp);
		  ndefer(emit_am_local_expr(args[i+1])+"="+arg_list[i+1]+";");
		  arg_list[i+1]:=emit_am_local_expr(args[i+1]);
		  if fun.args[i].mode=MODES::inout_mode then
		     ndefer(emit_am_local_expr(argsr[i+1])+"= *"+arg_list[i+1]+";");
		  end;
	       else
		  args[i+1]:=dec_am_local_expr(fun.args[i].tp);
		  argsr[i+1]:=args[i+1];
		  ndefer(emit_am_local_expr(args[i+1])+"="+arg_list[i+1]+";");
		  arg_list[i+1]:=emit_am_local_expr(args[i+1]);
	       end;
	    end;
	    ndefer("if(FAR("+arg_list[remote_call]+")) {");
	    in;
	    amat::=#AM_AT_EXPR(void);
	    amw::=#AM_WHERE_EXPR(void);
	    amw.arg:=args[remote_call];
	    amat.at:=amw;
	    amf::=#AM_ROUT_CALL_EXPR(args.size,void);
	    amf.fun:=fun;
	    loop 
	       i::=args.ind!;
	       amc::=#AM_CALL_ARG(argsr[i]);
	       if i=0 then
		  amc.mode:=MODES::in_mode;
	       else
		  amc.mode:=fun.args[i-1].mode;
	       end;
	       amf[i]:=(amc);
	    end;
	    amat.e:=amf;
	    att::=emit_am_at_expr(amat);
	    if ~void(fun.ret) then ndefer(l+"="); end;
	    defer(att+";");
	    loop
	       i::=fun.args.ind!;
	       if fun.args[i].mode/=MODES::in_mode then
	          ndefer("*"+arg_list[i+1]+"="+emit_am_local_expr(argsr[i+1])+";");
	       end;
	    end;
	    move_out;
	    ndefer("} else {");
	    if ~void(fun.ret) then defer(l+"="); end;
	    defer(pemit_call(fun,void,amexpr,arg_list)+"; }");
	 else
	    if ~void(fun.ret) then defer(l+"="); end;
	    defer(pemit_call(fun,void,amexpr,arg_list)+";");
	 end;
	 move_out;
	 ndefer("}");
	 return l;
      end;
   end;


   -- this function is no longer called directly, but only via emit_call.
   -- This is needed to allow pSather programs to create special
   -- dispatch calls based on the nearness of some of the arguments.
   private pemit_call(fun:SIG,nearness:ARRAY{BOOL},amexpr:$AM_EXPR,
		      arg_list:ARRAY{STR}):STR is
      -- 'amexpr' can either be a $AM_CALL_EXPR or an AM_BND_CREATE_EXPR.
      -- The later is needed to derive the argument which points to the 
      -- object containing the funcptr that points to the wrapper function to
      -- be called in the case of binding a closure, i.e. bind bind a.call
      l::=amexpr; call:$AM_CALL_EXPR; binding_iter_closure ::= false; 
      binding_rout_closure ::= false; name::=""; self_str : STR;
      if ~void(l) then
	 typecase l 
	 when $AM_CALL_EXPR then call := l; name := mang(fun);
	 when AM_BND_CREATE_EXPR then
	    call:=void; ident_iter ::= #IDENT("call!"); ident_rout ::= #IDENT("call"); 
	    if (fun.name = ident_iter) then
	       binding_iter_closure := true;
	       -- check for the nasty case of : a:ITER{ITER}:=bind(_.call!), since then 
	       -- there wont be a bnd_arg0, but unbnd_arg0 (i.e. onceargo) does the trick.
	       if ~void(l.bnd_args) and (l.bnd_args[0] = 0) then
		  self_str := "bound_arg0";  
	       else
		  self_str := "oncearg0";
	       end;
	       name := "(*(f->".append(self_str+"->call))");
	    elsif (fun.name = ident_rout) then 
	       binding_rout_closure := true;
	       -- same nasty case above for rout closures
	       if (~void(l.unbnd_args)) and (l.unbnd_args[0] = 0) then
		  name := "(*(unbound_arg0->funcptr))";
	       else
		  name := "(*(ob->bound_arg0->funcptr))";
	       end;
	    else  -- binding 'just' an iter or a rout
	       name := mang(fun); 
	    end;
	 end;  -- ends typecase
      else
	 call := void;
	 name := mang(fun);
      end;
      
      -- assumes all args are appropriately casted already
      res:STR;
      
      -- find out if this requires special handling
      
      if fun.is_builtin_routine then
	 return process_builtin_routs(fun, call,arg_list);
      elsif fun.is_builtin_iter then
	 if fun.tp.is_abstract then
	    barf("Dispatch on self for builtin iters should never occur (please report).")
	 else
	    res:=name+"(";
	 end;
      elsif fun.tp.is_abstract then
	 if fun.is_iter then
	    -- abstract biter calls 
	    dtbl_ptr ::= name;
	    res := "(*"+dtbl_ptr+"[TAG(f->iter_frame->self)].iter)(";
	 elsif fun.is_routine then
	    self_ob::=dec_local(fun.tp); -- put self in a lcl so it isn't called twice
	    ndefer(self_ob.append(" = ",arg_list[0],";"));
	    arg_list[0]:=self_ob;

	    if chk_void and ~null_segfaults then
	       ndefer("if (".append(arg_list[0],"==NULL) {"));
	       runtime_error("Dispatched call to "+fun.str 
			     + " on void self in " + current_function_str); 
	       ndefer("}");
	    end;
	    if options.stats then ndefer("COUNT_DISPATCH;"); end;
	    if prog.distributed then
	       if fun.is_iter and fun.tp.is_bound then 
		  barf("Distributed biters still at large.");
	       else
		  res:="(*".append(name,"[F_TAG(",arg_list[0],")])(");
	       end;
	    else
	       res:="(*".append(name,"[TAG(",arg_list[0],")])(");
	    end;
	 else
	    barf("In emit_call, unclassifiable signature : " +  fun.str); 
	 end;  -- ends fun.tp.is_abstract
      else  -- top level
	 -- must be ordinary call    
	 -- pSather:  make local call if possible
	 suffix::="";
	 if options.local_call and ~void(fun.opt_info) and ~void(fun.opt_info.consider) 
	 then 
	    suffix:="___";
	    has_local::=false;
	    loop
	       i::=fun.opt_info.consider.elt!;
	       if (~void(nearness) and nearness[i]) or (~void(call) and call[i].is_near) 
	       then 
		  has_local:=true;
		  suffix:=suffix+"L";
	       else
		  suffix:=suffix+"f";
	       end;
	    end;
	    if ~has_local then suffix:=""; end;
	 end;
	 res:=name+suffix+"(";
      end;
      
      if ~binding_iter_closure and ~binding_rout_closure then
	 code_c.uses_sig(fun); 
      end;
      
      -- emit the argument identifiers.
      if ~fun.tp.is_external then
	 res:=res+arg_list[0];
      end;
      loop 
	 i::=1.upto!(arg_list.size-1);
	 if fun.tp.is_external then
	    if i=1 then res:=res+arg_list[i];
	    else res:=res.append(", ",arg_list[i]);
	    end;
	 else
	    res:=res.append(", ",arg_list[i]);
	 end;
      end;
      if func_tables then  -- not sure about biters here
	 if in_bnd_rout_call then
	    res:=res.append(", pFF");
      	 else
	    res:=res.append(", &FF");
	 end;
      end;
      return res.append(")");
   end;

   -- Some of this is temporary commented out and will have to
   -- be restored properly once the header rewrite works.
   private emit_stubs_for_forked_call(fun:SIG) is

      name::=mang(fun);

      -- make header for the marshalling function
      --	decs_h+"void "+name+"_stub1(GATE, INT, "+mang(fun.tp);
      loop 
	 e::=fun.args.elt!;
	 --	    decs_h+", "+mang(e.tp);
      end;
      --	decs_h+");\n";

      -- make header for the unmarshalling function
      --	decs_h+"void "+name+"_stub2("+name+"_arg_frame);\n";

      -- stub1: declare and fill in struct, make the call
      code_c+"void "+name+"_stub1("+mang(TP_BUILTIN::attach)+" gate, INT at, "+mang(fun.tp)+" self";
      loop 
	 e::=fun.args.elt!;
	 code_c+", "+arg_type_str(e)+" arg"+1.up!;
      end;
      code_c+") {\n";
      code_c+' '+name+"_arg_frame frame = ARG_ALLOC(struct "
	    +name+"_arg_frame_struct);\n";
      code_c+" frame->self = self;\n";
      loop
	 i::=fun.args.ind!;
	 code_c+" frame->arg"+1.up!+" = arg"+1.up!+";\n";
      end;
      code_c+" ATTACH("+name+"_stub2, gate, frame, at);\n";
      code_c+"}\n\n";

      -- stub2: make the call from the struct
      code_c+"void "+mang(fun)+"_stub2("+name+"_arg_frame fptr) {\n";
      code_c+' '+name+"(fptr->self";
      loop
	 i::=fun.args.ind!;
	 code_c+", fptr->arg"+1.up!;
      end;
      code_c+");\n";
      code_c+" ARG_FREE(fptr);";
      code_c+"}\n\n";
	
   end;

   private emit_builtin_iter_call(aice:AM_ITER_CALL_EXPR):STR is
      inlined_iter_count:=inlined_iter_count+1;
      res : STR;
      ret : STR;
      biname:STR:=void;
      li:STR;
      if aice.fun.builtin_info.use_index and aice.use_loop_index then
         li:=aice.lp.loop_index;
      end;

      prog.stat.incr("B: # of builtin iter calls");

      if ~prog.distributed and ~void(aice.fun.builtin_info.declare) then 
	 loop code_c.uses_extern(aice.fun.builtin_info.declare.elt!); end;
      end;
      if prog.distributed and ~void(aice.fun.builtin_info.f_declare) then 
	 loop code_c.uses_extern(aice.fun.builtin_info.f_declare.elt!); end;
      end;

      if prog.distributed then 
	 if ~void(aice.fun.builtin_info.f_break) then
	    ndefer(expand_macro("if($#>="+aice.fun.builtin_info.f_break[0]+") @@; ",aice,aice.fun,aice.arg_list,aice.uniq,iter_frame,li));
	 end;
      else
	 if ~void(aice.fun.builtin_info.break) then
	    ndefer(expand_macro("if($#>="+aice.fun.builtin_info.break[0]+") @@; ",aice,aice.fun,aice.arg_list,aice.uniq,iter_frame,li));
	 end;
      end;
      in::=aice.fun.builtin_info.iter;
      if prog.distributed then
	 in:=aice.fun.builtin_info.f_iter;
      end;
      if ~void(in) then
	 loop
	    i::=in.ind!;
	    if i=in.size-1 and ~void(aice.fun.ret) then
	       ret:=in[i];
	    else
	       if in[i][0]='#' then
		  res:=res+'\n'+in[i]+'\n';
		  if debug then
		     res:=res+"#line "+last_lineno+" \""+last_file+"\"\n";
	          end;
	       else
		  res:=res+in[i]+" ";
	       end;
	    end;
	 end;
	 if aice.fun.builtin_info.use_index and ~aice.use_loop_index then
	    res:=res+"$#++;";
	 end;
	 aice.arg_list:=emit_and_cast_hot_args(aice);
	 ndefer(expand_macro(res,aice,aice.fun,aice.arg_list,aice.uniq,iter_frame,li));
	 return expand_macro(ret,aice,aice.fun,aice.arg_list,aice.uniq,iter_frame,li);
      else
	 if aice.fun.builtin_info.use_index and ~aice.use_loop_index then
	    ndefer(expand_macro("$#++;",aice,aice.fun,void,aice.uniq,iter_frame));
	 end;
	 return "";
      end;
   end;

   private emit_expr(arg:$AM_EXPR):STR pre ~void(arg) is
      -- emit code for computing expr if necessary, and return handle
      -- to the result.

      t::=arg.tp;
      if ~void(t) then code_c.uses_tp(t); end;

      typecase arg
      when AM_LOCAL_EXPR then return emit_am_local_expr(arg);
      when AM_ROUT_CALL_EXPR then return emit_rout_call_expr(arg);
      when AM_ITER_CALL_EXPR then return emit_iter_call_expr(arg);
      when AM_VOID_CONST then return emit_am_void_const(arg);
      when AM_STR_CONST then return emit_am_str_const(arg);
      when AM_BOOL_CONST then return emit_am_bool_const(arg);
      when AM_INT_CONST then return emit_am_int_const(arg);
      when AM_CHAR_CONST then return emit_am_char_const(arg); 
      when AM_FLT_CONST then return emit_am_flt_const(arg);
      when AM_FLTD_CONST then return emit_am_fltd_const(arg);
      when AM_IF_EXPR then return emit_am_if_expr(arg);
      when AM_NEW_EXPR then return emit_am_new_expr(arg);
      when AM_ATTR_EXPR then return emit_am_attr_expr(arg);
      -- when AM_ASIZE_EXPR then return emit_am_asize_expr(arg);
      when AM_VATTR_ASSIGN_EXPR then return emit_am_vattr_assign_expr(arg);
      -- when AM_ARR_EXPR then return emit_am_arr_expr(arg);
      -- when AM_VARR_ASSIGN_EXPR then return emit_am_varr_assign_expr(arg);
      when AM_EXT_CALL_EXPR then return emit_am_ext_call_expr(arg);
      when AM_SHARED_EXPR then return emit_am_shared_expr(arg);
      when AM_ARRAY_EXPR then return emit_am_array_expr(arg);
      when AM_IS_VOID_EXPR then return emit_am_is_void_expr(arg);
      when AM_STMT_EXPR then return emit_am_stmt_expr(arg);
      when AM_EXCEPT_EXPR then return emit_am_except_expr(arg);
      when AM_BND_CREATE_EXPR then return emit_am_bnd_create_expr(arg);
      when AM_BND_ROUT_CALL_EXPR then return emit_am_bnd_rout_call_expr(arg);
      when AM_BND_ITER_CALL_EXPR then return emit_am_bnd_iter_call_expr(arg); --AJ- 
	 
	 
	 -- psather
      when AM_HERE_EXPR then return emit_am_here_expr(arg);
      when AM_ANY_EXPR then return emit_am_any_expr(arg);
      when AM_CLUSTER_EXPR then return emit_am_cluster_expr(arg);
      when AM_CLUSTER_SIZE_EXPR then return emit_am_cluster_size_expr(arg);	 
      when AM_WHERE_EXPR then return emit_am_where_expr(arg);
      when AM_NEAR_EXPR then return emit_am_near_expr(arg);
      when AM_FAR_EXPR then return emit_am_far_expr(arg);
      when AM_AT_EXPR then return emit_am_at_expr(arg);

      -- only with zones
      when AM_GLOBAL_EXPR then return emit_am_global_expr(arg);

	-- from here not yet implemented  
      when AM_ARR_CONST then
	 barf_at("constant array literals not implemented yet",arg);
      when AM_INTI_CONST then
	 barf_at("INTI literals not implemented yet",arg);
      when AM_FLTI_CONST then
	 barf_at("FLTI constants not implemented yet",arg);
      when AM_FLTX_CONST then
	 barf_at("FLTX literals not implemented yet",arg);
      when AM_FLTDX_CONST then
	 barf_at("FLTDX literals not implemented yet",arg);
      end; -- typecase
      barf("Got to end of emit_expr");
      return "";		-- because this routine is required to end with a return
   end;

   private emit_am_local_expr(arg:AM_LOCAL_EXPR):STR is
      if current_sig.is_iter and ~arg.not_in_frame then
	 return "frame->".append(mang(arg,current_sig));
      else
	 return mang(arg,current_sig);
      end;
   end;

   private emit_am_void_const(arg:AM_VOID_CONST):STR pre ~void(arg.tp) is
      return default_init(arg.tp);
   end;

   private emit_rout_call_expr(arce:AM_ROUT_CALL_EXPR):STR is

      if arce.fun.tp.is_abstract then abstract_calls:=abstract_calls+1;
      else concrete_calls:=concrete_calls+1;
      end;

      -- constant initializations are not inlined
      if in_constant then
	 make_sure_emitted(arce.fun);
      end;

      if arce.fun.tp=TP_BUILTIN::sys then
	 if arce.fun.name=IDENT_BUILTIN::ob_eq_ident then
	    -- Make special case for SYS::ob_eq.  We want to avoid
	    -- boxing up value types for the general case (because
	    -- the args are $OB) because this might be used to
	    -- compare value types with hash tables.  This can't
	    -- be done where we handle the other special cases
	    -- because we have to get to it before argument
	    -- casting (boxing) has occured.  Similarly, we want
	    -- to just compare pointers if both args are in
	    -- pointers already, something that can't be done if
	    -- boxing gets involved.
	    t1::=arce[1].expr.tp;
	    t2::=arce[2].expr.tp;
	    arg1::=emit_expr(arce[1].expr);
	    arg2::=emit_expr(arce[2].expr);
	    if t1.is_immutable and t2.is_immutable then
	       inlined_value_ob_eq_calls:=inlined_value_ob_eq_calls+1;
	       if t1=t2 then return value_compare(t1,arg1,arg2);
	       else return "FALSE";
	       end;
	    elsif t1.is_immutable or t2.is_immutable
	       or t1.is_abstract or t2.is_abstract then
	       -- needs boxed comparison
	       carg1::=cast(TP_BUILTIN::dollar_ob,t1,arg1,false);
	       carg2::=cast(TP_BUILTIN::dollar_ob,t2,arg2,false);
 	       if prog.distributed then
 		  return "F_SYSOBEQ(".append(carg1,",",carg2,")");
 	       else
 		  return "SYSOBEQ(".append(carg1,",",carg2,")");
 	       end;
	    else
	       inlined_pointer_ob_eq_calls:=inlined_pointer_ob_eq_calls+1;
	       return "(".append(arg1,"==",arg2,")");
	    end;
	 elsif arce.fun.name.str="inlined_C" then
	    -- WARNING: if you change the meaning or how inlined_C work you 
	    -- have to change the interpretation in OPT_LOCAL::work_on_inined_C too!
	    -- otherwise the pSather optimization relying on the local analysis may
	    -- not work correctly.
	    argexpr::=arce[1].expr;
	    arg:STR;
	    typecase argexpr
	    when AM_STR_CONST then arg:=argexpr.bval;
	    else barf("inlined_C arg something other than STR literal");
	    end;
	    res:STR:="";
	    i::=0;
	    loop
	       while!(i<arg.size);
	       c::=arg[i];
	       case c
	       when '#' then
	          if i+2<arg.size and arg[i+1]='#' then
		     i:=i+2;
		     res:=res+"#";
		  else
		     var:STR:="";
		     loop
			i:=i+1;
			while!(i<arg.size);
			vc::=arg[i];
			while!(vc.is_alphanum or vc='_');
			var:=var+vc;
		     end;
		     done:BOOL:=false;
		     loop
			-- First check arguments
			lcl::=current_am_rout_def.elt!.expr;
			if lcl.name.str=var then
			   res:=res+emit_expr(lcl);
			   done:=true;
			   break!;
			end;
		     end;
		     if ~done then
			loop
			   -- It wasn't an arg, try for a local
			   lcl::=current_am_rout_def.locals.elt!;
			   if lcl.name.str=var then
			      res:=res+emit_expr(lcl);
			      done:=true;
			      break!;
			   end;
			end;
			if ~done then
			   barf("Unknown variable '"+var+"' to inline in "+arg);
			end;
		     end;
	          end;
	       else
		  res:=res+c;
		  i:=i+1;
	       end;
	    end;
	    return res;
	 end;
      end;
      
      arg_list::=emit_and_cast_args(arce);

      if need_caller_copy_out(arce)  then
	 if ~void(arce.fun.ret) then
	    func_res ::= dec_local(arce.fun.ret);
	    ndefer( func_res+" = " + emit_call(arce.fun,arce,arg_list) + ';');
	    caller_copy_out(arce, arg_list);
	    return func_res;
	 else
	    -- no result is needed
	    ndefer(emit_call(arce.fun,arce,arg_list)+';');
	    caller_copy_out(arce, arg_list);
	    return void;
	 end;
      else
	 return emit_call(arce.fun,arce,arg_list);
      end;
   end;

   private emit_iter_initialization(aice:AM_ITER_CALL_EXPR) is
      comment("Initialize once arguments of call to "+aice.fun.str);
      emit_code(aice.init);
      aice_init::=aice.init; -- store init to restore at end of function
      aice.init:=void;
      if aice.fun.is_builtin then
	 assert(~void(aice.uniq));
	 aice.arg_list:=emit_and_cast_once_args(aice);
	 if ~prog.distributed and ~void(aice.fun.builtin_info.var) and ~current_sig.is_iter then 
	    res::="";
	    loop res:=res+eol+" "+aice.fun.builtin_info.var.elt!; end;
	    code_c:=code_c+expand_macro(res,aice,aice.fun,aice.arg_list,aice.uniq);
	 end;
	 if prog.distributed and ~void(aice.fun.builtin_info.f_var) and ~current_sig.is_iter then 
	    res::="";
	    loop res:=res+eol+" "+aice.fun.builtin_info.f_var.elt!; end;
	    code_c:=code_c+expand_macro(res,aice,aice.fun,aice.arg_list,aice.uniq);
	 end;
	 if aice.fun.builtin_info.use_index and ~current_sig.is_iter and ~aice.use_loop_index then
	    code_c:=code_c+expand_macro(eol+"INT $#=0;",aice,aice.fun,void,aice.uniq);
	 end;
	 if prog.distributed and ~void(aice.fun.builtin_info.f_temp) then
	    res::="";
	    loop res:=res+eol+" "+aice.fun.builtin_info.f_temp.elt!; end;
	    code_c:=code_c+expand_macro(res,aice,aice.fun,aice.arg_list,aice.uniq);
	 end;
	 if ~prog.distributed and ~void(aice.fun.builtin_info.temp) then
	    res::="";
	    loop res:=res+eol+" "+aice.fun.builtin_info.temp.elt!; end;
	    code_c:=code_c+expand_macro(res,aice,aice.fun,aice.arg_list,aice.uniq);
	 end;
	 in::=aice.fun.builtin_info.init;
	 if prog.distributed then in:=aice.fun.builtin_info.f_init; end;
	 if ~void(in) then
	    res::="";
	    loop
	       i::=in.ind!;
	       if in[i][0]='#' then
		  res:=res+'\n'+in[i]+'\n';
		  if debug then
		     res:=res+"#line "+last_lineno+" \""+last_file+"\"\n";
	          end;
	       else
		  res:=res+in[i]+" ";
	       end;
	    end;
	    ndefer(expand_macro(res,aice,aice.fun,aice.arg_list,aice.uniq,iter_frame));
	 end;
	 if aice.fun.builtin_info.use_index and ~aice.use_loop_index then
	    ndefer(expand_macro("$#=0;",aice,aice.fun,void,aice.uniq,iter_frame));
	 end;
      else
	 -- for each once argument, copy into frame
	 loop
	    i::=aice.ind!;
	      
	    -- beware the difference in argument indices between
	    -- aice[] and aice.fun.hot[]!!!
	      
	    if i=0 then
	       ndefer(mang(aice,current_sig)
		      .append("->self = ",emit_expr(aice[i].expr),";"));
	    elsif void(aice.fun.hot) or ~aice.fun.hot[i-1] then
	       ndefer(mang(aice,current_sig).append("->arg",i.str," = ",
						    cast(aice.fun.args[i-1].tp,
							 aice[i].expr.tp,
							 emit_expr(aice[i].expr),false),
						    ";"));
	    end;
	 end;
      end;
      aice.init:=aice_init;
   end;
   
   private emit_bnd_iter_initialization(biter:AM_BND_ITER_CALL_EXPR) is
      -- emit code setting once arguments 
      comment("Initialize once arguments of call to "+biter.bi_tp.str);
      emit_code(biter.init);
      biter.init:=void;

      -- treatment of builtin iters/p.sather comes here
      biter_name ::= mang(biter,current_sig);
      if void(biter_name) then barf("Unrecognized Sather bound iter name: "
				    +emit_expr(biter.bi));
      end;
      
      loop
	 i::=biter.ind!;
	 
	 -- loop over unbnd args and pick out once args
	 if void(biter.bi_tp.hot) or ~biter.bi_tp.hot[i] then 
	    ndefer(biter_name.append("->oncearg"+i+" = ",
				     cast(biter.bi_tp.args[i].tp,
					  biter[i].expr.tp,
					  emit_expr(biter[i].expr),false)
				     +";")); 
	 end;
      end;
   end;
   
   private emit_iter_call_expr(aice:AM_ITER_CALL_EXPR):STR is

      -- The uses_sig and uses_iter calls are made during loop
      -- initialization, so they don't happen here.  This is important
      -- because it is possible to have iterators that are eliminated
      -- as the result, for example, of optimizaing away typecase
      -- branches.

      call_str:STR;
      
      -- constant initializations are not inlined
      if in_constant then
	 make_sure_emitted(aice.fun);
      end;
      
      s1,res:STR;
      
      if ~void(aice.tp) then
	 -- local variable to hold result (since we have to imbed
	 -- in a control structure to check for possible termination)
	 s1:=dec_local_comment(aice.tp,
			       "Holds result of call to "+aice.fun.str);
      end;
      
      if aice.fun.is_builtin_iter then
	 if ~aice.init_before_loop then
	    ndefer("if (".append(iter_frame,"f_",aice.uniq,") {"));
	    in;
	    ndefer(iter_frame+"f_"+aice.uniq+" = FALSE;");
	    emit_iter_initialization(aice);
	    move_out;
	    ndefer("}");
	 end;
	 return emit_builtin_iter_call(aice);
      end;
      -- if first time through, compute once arguments
      -- (all once args before any hot args).
      if ~aice.init_before_loop then
	 ndefer("if (".append(mang(aice,current_sig),"->state == 0) {"));
	 in;
	 emit_iter_initialization(aice);
	 move_out;
	 ndefer("}");
      end;
      
      -- compute all hot in/inout arguments into frame
      if ~void(aice.fun.hot) then
	 
	 -- beware the difference in indices!!!
	 
	 loop i::=1.upto!(aice.asize-1);
	    if aice.fun.hot[i-1] then
	       arg_str ::=emit_call_arg(aice[i], aice.fun.args[i-1], false, false);
	       if aice.fun.args[i-1].tp.is_immutable and
			SYS::ob_eq(aice[i].mode, MODES::out_mode) and
			aice[i].expr.tp.is_abstract then
		  -- otherwise casting is done after the call!		
		  ndefer(mang(aice,current_sig).append("->arg",i.str,
						       " = ",
						       arg_str,
						       ";"));			
	       else
		  ndefer(mang(aice,current_sig).append("->arg",i.str,
						       " = ",
						       cast_arg(aice.fun.args[i-1].tp,aice[i].expr.tp,arg_str, false, aice[i].mode),
						       ";"));
	       end; 
	       comment("hot argument");
	    end;
	 end;
      end;
      pro::="";
      if func_tables then 
         pro:=",&FF";
      end;
      if prog.psather and ~aice.lp.no_begin_loop and current_sig.is_iter then
         ndefer("RESTORE_CURRENT_EX;");
      end;
      if aice.fun.tp.is_abstract then
	 if chk_void and ~null_segfaults then
	    ndefer("if (".append(emit_expr(aice[0].expr),"==NULL) {"));
	    in; 
	    runtime_error("Dispatched call to "+aice.fun.str + " on void self in " + current_function_str); 
	    move_out;
	    ndefer("}");
	 end;
	 if options.stats then ndefer("COUNT_DISPATCH;"); end;
	 
	 tag::="TAG";
	 if prog.distributed then tag:="F_TAG"; end;
	 if ~void(aice.tp) then
	    ndefer(s1
		   +" = (*"+mang(aice.fun)
		   +"["+tag+"("+emit_expr(aice[0].expr)+")].iter)"
		   +"("+mang(aice,current_sig)+pro+");");
--	    ndefer(s1
--		   +" = (*"+mang(aice.fun)
--		   +"["+tag+"("+emit_expr(aice[0].expr)+")+"
--		   +mang(aice.fun)+"_offset].iter)"
--		   +"("+mang(aice,current_sig)+pro+");");
	    res:=s1;
	 else
---	    ndefer("(*"+mang(aice.fun)+"["+tag+"("+emit_expr(aice[0].expr)+")+"+
---		   mang(aice.fun)+"_offset].iter)"+"("+mang(aice,current_sig)+pro+
---		   ");");
	    ndefer("(*"+mang(aice.fun)+"["+tag+"("+emit_expr(aice[0].expr)+
		   ")].iter)"+"("+mang(aice,current_sig)+pro+
		   ");");
	    res:="/* No return value from iter call */";
	 end;
      else			-- normal call
	 if ~void(aice.tp) then
	    ndefer(s1.append(" = ",mang(aice.fun),"(",
			     mang(aice,current_sig)+pro,");"));
	    res:=s1;
	 else
	    ndefer(mang(aice.fun).append("(",mang(aice,current_sig)+pro,");"));
	    res:="/* No return value from iter call */";
	 end;
      end;
      
	      
      if prog.psather and ~aice.lp.no_begin_loop and (~prog.yields_in_locks or ~options.side_effects
	    or aice.fun.get_se_context(prog).has_yield_in_lock) and 
	   (~current_sig.is_iter or (~prog.yields_in_locks or ~options.side_effects
	    or current_sig.get_se_context(prog).has_yield_in_lock)) then
         ndefer("SET_CURRENT_EXCEPTION;");
      end;
      ndefer("if (".append(mang(aice,current_sig),"->state == -1) {"));
      in;
      if manual_loop_unlock then ndefer("LM_LOCK_UNLOCK_NOW;"); end;
      pop_exceptions(ex_nesting-current_loop_ex_nesting);
      ndefer("goto ".append(current_loop,";"));
      move_out;
      ndefer("}");
      
      -- out args are not updated if iter quits!
      if need_caller_copy_out(aice) then
	 -- there is always a local for a yielded value, 
	 -- so out args are copied out before the returned
	 -- temporary is used
	 caller_copy_out(aice, void); 
	 --don't need to pass arg_list - it's canonical for iters;
      end;
      
      return res;
   end;
   
   
   private emit_am_str_const(asc:AM_STR_CONST):STR is
      s::=asc.bval;
      name::=string_constants.get(s);
      if void(name) then
	 name:=mang(asc);
	 strings_c+"struct {\n";
	 strings_c+" OB_HEADER header;\n";
	 strings_c+" INT asize;\n";
	 strings_c+" CHAR arr_part["
	       +(s.length+1)	-- +1 for Object Center bug
	       +"];\n  } "+name+" = { ";
	 strings_c+"{"+tag_for(TP_BUILTIN::str);
	 if options.destroy_chk then
	    strings_c+", 0";
	 end;
	 if deterministic then
	    strings_c+", -"+str_count;
	    str_count:=str_count+1;
	 end;
	 strings_c+"}, "+s.length+", \""+mangler.Cify(s)+"\" };\n";
	 string_constants:=string_constants.insert(s,name);
	 strings_c.good_place_to_split;
      end;
      code_c+eol+" extern STR "+name+';';
      return "((STR) &".append(name,")");
   end;
     
   private emit_am_bool_const(arg:AM_BOOL_CONST):STR is
      if arg.val then return "TRUE" else return "FALSE" end;
   end;

   private emit_am_int_const(arg:AM_INT_CONST):STR is
      return arg.val.str;
   end;

   private emit_am_char_const(arg:AM_CHAR_CONST):STR is
      return "'".append(mangler.Cify(arg.bval),"\'");
   end;

   private emit_am_flt_const(arg:AM_FLT_CONST):STR is
      return arg.val.str(8);	-- two extra
   end;

   private emit_am_fltd_const(arg:AM_FLTD_CONST):STR is
      return arg.val.str(17);	-- two extra
   end;

   private emit_am_if_expr(arg:AM_IF_EXPR):STR is
      res::=dec_local_comment(arg.tp,"local for :? test");
      ndefer("if (".append(emit_expr(arg.test),") {"));
      in; ndefer(res.append(" = ",emit_expr(arg.if_true),";")); move_out;
      ndefer("} else {");
      in; ndefer(res.append(" = ",emit_expr(arg.if_false),";")); move_out;
      ndefer("}");
      return res;
   end;

   private emit_am_new_expr(arg:AM_NEW_EXPR):STR is
      res::=dec_local_comment(arg.tp_at,
			      "local for ".append(arg.tp_at.str,"::create"));
      if ~void(arg.asz) then
	 sizevar::=dec_local(arg.asz.tp);
	 s2::=emit_expr(arg.asz);
	 ndefer(sizevar.append(" = ",s2,";"));
	 ndefer(res.append(" = ",array_allocate(arg.tp_at,sizevar),";"));
	 ndefer(res.append("->asize = ",sizevar,";"));
      else ndefer(res.append(" = ",allocate(arg.tp_at),";"));
      end;
      if arg.tp_at.is_subtype(TP_BUILTIN::dollar_lock) then
         ndefer("INIT_LOCK_HEADER("+res+");");
      end;
      return res;
   end;

   private emit_am_attr_expr(arg:AM_ATTR_EXPR):STR is
      s1::=emit_expr(arg.ob);
      attrname::=mang(arg.at,arg.self_tp);
      if ~prog.distributed then
	 sfe::=arg.ob; 
	 typecase sfe  -- check if we need a local
	 when AM_LOCAL_EXPR then 
	 when AM_SHARED_EXPR then 
	 when AM_ATTR_EXPR then
	 else
	    l4::=dec_local(arg.self_tp);
	    ndefer(l4+"="+s1+";");
	    s1:=l4;
	 end;
	 s1:=cast(arg.self_tp,arg.ob.tp,s1,false);
	 if arg.self_tp.is_immutable then return s1.append(".",attrname);
	 elsif arg.secure then 
	    if prog.psather then -- ATTRs is not an lvalue, but we need on in pSather
	       l::=dec_local(arg.tp);
	       return "(("+l+"=ATTRs(".append(s1,",",attrname,",",default_init(arg.tp),")),"+l+")");
	    else
	       return "ATTRs(".append(s1,",",attrname,",",default_init(arg.tp),")");
	    end;
	 else return "ATTR(".append(s1,",",attrname,")"); end;
      else
	 -- Warning: we don't check for non atomic value types or secure attr!!!
	 l::=dec_local(arg.tp);
	 sf::="";
	 sft::="";
	 if arg.self_tp.is_immutable then sf:="&"; sft:="*"; end;
	 sfe::=arg.ob; 
	 typecase sfe  -- check if we need a local
	 when AM_LOCAL_EXPR then 
	 when AM_SHARED_EXPR then -- AM_ATTR_EXRP are not safe in pSather
	 else
	    l4::=dec_local(arg.self_tp);
	    ndefer(l4+"="+s1+";");
	    s1:=l4;
	 end;
	 code_c.uses_tp(arg.self_tp);
	 code_c.uses_tp(arg.tp);
	 if arg.ob.is_near then
	    prog.stat.incr("O: # of local accesses");
	    a::="";
	    if arg.self_tp.is_immutable then a:= s1.append(".",attrname);
	    else a:="ATTR("+s1+","+attrname+")";
	    end;
	    if arg.tp.is_immutable and ~arg.tp.is_atomic then
	       ndefer("VASS_LP("+l+","+mang(arg.tp)+","+a+");");
	    else
	       ndefer(l+"="+a+";");
	    end;
	 else
	    if arg.tp.is_immutable then
	       if arg.tp.is_atomic then
		  ndefer("F_VA_RATTR_NA(".append(l,",",mang(arg.self_tp)+sft,",".append(sf+s1,",",attrname,");")));
	       else
		  ndefer("F_V_RATTR_LP(".append(mang(arg.tp)+","+l,",",mang(arg.self_tp)+sft,",".append(sf+s1,",",attrname,");")));
	       end;
	    else
	       ndefer("F_R_RATTR_NA(".append(l,",",mang(arg.self_tp)+sft,",".append(sf+s1,",",attrname,");")));
	    end;
	 end;
	 return l;
      end;
   end;

   private emit_am_vattr_assign_expr(arg:AM_VATTR_ASSIGN_EXPR):STR is
      s1::=emit_expr(arg.ob);
      s2::=mang(arg.at,arg.ob.tp);
      s3::=cast(arg.real_tp,arg.val.tp,emit_expr(arg.val),false);
      res::=dec_local_comment(arg.tp,
			      "local for value type array assignment");
      ndefer(res.append(" = ",s1,";"));
      ndefer(res.append(".",s2," = ",s3,";"));
      return res;
   end;

   private emit_am_ext_call_expr(arg:AM_EXT_CALL_EXPR):STR is
      ext_tp ::= arg.fun.tp;
      typecase ext_tp
      when TP_CLASS then 
	 case ext_tp.kind
	 when TP_KIND::ext_fortran_tp then 
	    return emit_fortran_call(arg);
	 when TP_KIND::ext_c_tp then
	    if arg.fun.is_ext_c_sig then
	       -- the check is_ext_c_sig is needed to provide compatibility
	       -- with the old 1.1 C interface
	       -- emit_c_call takes care only of "true" 1.1 external C calls
	       return emit_c_call(arg);	    
	    end;
	 else
	    -- A hook for others external calls
	 end;
      end;

      arg_list:ARRAY{STR}:=emit_args(arg);
      extern:STR:="extern ";
      if ~void(arg.tp) then extern:=extern.append(mang(arg.tp)," ");
      else extern:=extern.append("void ");
      end;
      extern:=extern.append(arg.nm.str,"("); 
      res ::= arg.nm.str;
      if arg.fun.tp.kind = TP_KIND::ext_fortran_tp then
	 res := 
	    fortran_prepend_underscore.append(res, fortran_append_underscore);
      end;
      res:=res.append("(");
      i:INT:=1;			-- self is not passed to external routines 
      loop 
	 until!(i>=arg_list.asize);
	 sa ::= arg.fun.args[i-1];
	 tp::=sa.tp;
	 arr:TP_CLASS := aref_of(tp);
	 if ~void(arr) then
	    -- AREF{FOO} passed to external routines really
	    -- passes a pointer to the array portion.
	    local::=dec_local_comment(tp,"Local for ext arr arg");
	    ndefer(local.append(" = ",cast(tp, arg[i].expr.tp, arg_list[i],false),";"));
	    extern:=extern.append(mang(arr.params[0])," []");
	    res:=res.append("((",local,"==NULL)?NULL:",local,"->arr_part)");
	 else
	    extern:=extern.append(arg_type_str(sa));
	    res:=res.append(cast(tp,arg[i].expr.tp,arg_list[i],false));
	 end;
	 i:=i+1;
	 if i<arg_list.asize then
	    extern:=extern.append(", ");
	    res:=res.append(", ");
	 end;
      end;
      extern:=extern.append(");"+eol);
      -- do not emit prototypes for features in runtime. They should
      -- be in the system header files.
      if ~arg.ext_tp.is_builtin then
	 code_c.uses_extern(extern);
      end;
      return res.append(")");
   end;

   aref_of(tp:$TP):TP_CLASS is
      arr:TP_CLASS;
      if tp.kind=TP_KIND::ref_tp then
	 arr:=tp.impl.arr;
	 if ~void(arr) then
	    return arr;
	 end;
      end;
      return void;
   end;

   -- a less general version of calls to features in external class.
   -- argument strings need to be precomputed beforehand
   -- This is used, for example, in generating bound stubs
   -- when the closure is created for an extern routine
   private emit_ext_call(sig:SIG,arg_list:ARRAY{STR}):STR is
      -- if a call to a Sather routine with a body, go through
      -- normal call generation stage
      elt ::= sig.tp.impl.elt_with_sig(sig);
      if ~elt.is_abstract then
	 return emit_call(sig, void, arg_list);
      end;
      
      extern:STR:="extern ";
      if ~void(sig.ret) then extern:=extern.append(mang(sig.ret)," ");
      else extern:=extern.append("void ");
      end;
      res ::= sig.name.str;
      if sig.tp.kind = TP_KIND::ext_fortran_tp then
	 res := bind_fortran_name(res);
      end;
      res:=res.append("(");     
      extern:=extern.append(sig.name.str,"("); 
      loop 
	 i::=1.upto!(arg_list.size-1); -- self is not passed to ext routines
	 sa ::= sig.args[i-1];
	 tp::=sa.tp;
	 
	 arr:TP_CLASS := aref_of(tp);
	 if ~void(arr) then 
	    -- AREF{FOO} passed to external routines really
	    -- passes a pointer to the array portion.	    
	    local::=dec_local_comment(tp,"Local for ext arr arg");
	    ndefer(local.append(" = (",arg_type_str(sig.args[i-1]),")",arg_list[i], ";"));
	    extern:=extern.append(mang(arr.params[0])," []");
	    res:=res.append("((",local,"==NULL)?NULL:", local, "->arr_part)");
	 else 
	    extern:=extern + arg_type_str(sig.args[i-1]);
	    res:=res + arg_list[i];
	 end;
	 if i<arg_list.asize-1 then
	    extern:=extern.append(", ");
	    res:=res.append(", ");	 
	 end;
      end;
      extern:=extern.append(");"+eol);
      -- do not emit prototypes for features in runtime. They should
      -- be in the system header files.
      if ~sig.tp.is_builtin then
	 code_c.uses_extern(extern);
      end;
      return res.append(")");
   end;
      
      
   private emit_am_shared_expr(arg:AM_SHARED_EXPR):STR is
      -- get the global definition stored in the global table,
      -- so it will be mangled correctly
      orig ::= gen.global_tbl.get(arg.name,arg.class_tp);
      code_c.uses_global(orig);
      -- shrareds in external 1.1 C classes (c globals) are
      -- mangled to the attribute name part only similar to
      -- other external class features
      if arg.class_tp.is_c then
	 mangler.force_mangle(orig,arg.name.str,void);
	 return arg.name.str;
      else
	 return mang(orig);
      end;
   end;

   private emit_am_array_expr(arg:AM_ARRAY_EXPR):STR is
      t:$TP:=arg.tp_at;
      t2:$TP:=am_ob_def_for_tp(t).arr;
      res::=dec_local_comment(t,"local for array creation expression");
      ndefer(res.append(" = ",array_allocate(t,arg.asize.str),";"));
      ndefer(res.append("->asize = ",arg.asize.str,";"));
      loop i::=arg.ind!;
	 rhs::=cast(t2,arg[i].tp,emit_expr(arg[i]),false);
	 ndefer(res.append("->arr_part[",i.str,"] = ",rhs,";"));
      end;
      return res;
   end;

   private emit_am_is_void_expr(arg:AM_IS_VOID_EXPR):STR 
      pre ~void(arg.arg) is
      arg_tp:$TP:=arg.arg.tp;
      assert ~void(arg_tp);
      if arg_tp.is_immutable then
	 return value_void(arg_tp,emit_expr(arg.arg));
      else
	 if prog.distributed then
	    return "FVOID(".append(emit_expr(arg.arg),")");
	 else 
	    return "(".append(emit_expr(arg.arg),"==",
			      default_init(arg_tp),")");
         end;
      end;
   end;

   private emit_am_stmt_expr(arg:AM_STMT_EXPR):STR is
      if ~void(arg.stmts) then emit_code(arg.stmts); end;
      if ~void(arg.expr) then return emit_expr(arg.expr);
      else return void;
      end;
   end;

   private emit_am_except_expr(arg:AM_EXCEPT_EXPR):STR is
      return cast(arg.tp,TP_BUILTIN::dollar_ob,"EXCEPTION",false);
   end;

   ---------------------------------------------------------------
   -- here comes stuff for bnd_routines and for bnd_iters
   
   private emit_am_bnd_create_expr(arg:AM_BND_CREATE_EXPR):STR is
      dummy:FLIST{STR};
      res:STR;
      if arg.fun.is_iter then 
	 res:= emit_am_bnd_iter_create_expr(arg); -- (arg,true,out dummy);
      else 
	 tp::=arg.tp;
	 typecase tp
	 when TP_ROUT then
	    if tp.is_fortran then
	       res := emit_f_rout_create_expr(arg);
	    else
	       res := emit_am_bnd_rout_create_expr(arg,true,out dummy);
	    end;
	 end;
      end;
      return res;
   end;
   
   private emit_am_bnd_rout_create_expr(arg:AM_BND_CREATE_EXPR,
					casting:BOOL,
					out argstr:FLIST{STR}):STR is
      argstr:=void;
      carg:AM_BND_CREATE_EXPR:=void;
      -- check if we already created the same bound routine
      loop
	 c::=bnd_rout_creates.elt!;
	 if c.equals(arg) then
	    carg:=c;
	    break!;
	 end;
      end;
      if void(carg) then
	 loop
	    c::=bnd_rout_creates_done.elt!;
	    if c.equals(arg) then
	       carg:=c;
	       break!;
	    end;
	 end;
      end;
      if void(carg) then
	 bnd_rout_creates:=bnd_rout_creates.push(arg);
	 carg:=arg;
      end;
      code_c.uses_bnd_rout_create(carg);
      code_c.uses_layout(#BOUND_OBJECT_LAYOUT(carg));
      res::=mangler.genlocal(current_sig);
      code_c+eol+' '+mang(carg)+"_ob "+res+';';
      ndefer(res+" = ("+mang(carg)+"_ob) ZALLOC(sizeof(struct "
	     +mang(carg)+"_ob_struct));");
      ndefer(res+"->header.tag = "+tag_for(arg.tp)+';');
      ndefer(res+"->funcptr = "+mang(carg)+';');
      loop
	 i::=arg.ind!;
	 entry:STR;
	 idx::=arg.bnd_args[i];
	 if idx=0 then
	    if ~arg.fun.tp.is_external then
 	       a::=arg.fun;
 	       entry:=cast(arg.fun.tp,arg[i].expr.tp,emit_expr(arg[i].expr),false);
 	       if arg.is_remote then
 		  if a.tp.is_immutable then
 		     ndefer(res+"->bound_arg"+i+" = "+entry+';');
 		     if ~a.tp.is_atomic then
 			   ndefer("SENDOB("+tag_for(a.tp)+
 				",&"+res+"->bound_arg"+i+
 				","+arg.clst+");");
 		     end;
 		  else
 		     ndefer(res+"->bound_arg"+i+" = SENDFOB("+entry+","+arg.clst+");");
 		  end;
 	       else
 		  ndefer(res+"->bound_arg"+i+" = "+entry+';');
 	       end;
	    end;
	 else
	    -- outmode is only possible for remote procedure calls generated
	    -- for pSather, but never for BND ROUT created by user code
	    a::=arg.fun.args[idx-1];
	    if a.mode/=MODES::out_mode then
	       ex::=emit_expr(arg[i].expr);
	       if a.mode=MODES::inout_mode then
	          argstr:=argstr.push(ex);
	       end;
	       entry:=cast(a.tp,arg[i].expr.tp,ex,false);
	       if arg.is_remote then
		  if a.tp.is_immutable then
		     ndefer(res+"->bound_arg"+i+" = "+entry+';');
		     if ~a.tp.is_atomic then
			   ndefer("SENDOB("+tag_for(a.tp)+
				",&"+res+"->bound_arg"+i+
				","+arg.clst+");");
		     end;
		  else
		     ndefer(res+"->bound_arg"+i+" = SENDFOB("+entry+","+arg.clst+");");
		  end;
	       else
		  ndefer(res+"->bound_arg"+i+" = "+entry+';');
	       end;
	    end;
	 end;
      end;
      make_sure_emitted(arg.fun);
      if casting then 
	 return "("+mang(arg.tp)+") "+res;
      else
         return res;
      end;
   end;

   private emit_f_rout_create_expr(arg:AM_BND_CREATE_EXPR):STR is
      -- emit a pretty stupid void pointer (F_ROUT). At the moment anything
      -- will do since F_ROUTs are just passed to Fortran. When and
      -- if it becomes necessary to pass functions from Fortran to 
      -- Sather, a more serious solution (hopefully by someone else ;-)
      -- will be necessary
      -- Boris
      res::=mangler.genlocal(current_sig);
      code_c+eol+" F_ROUT "+res+';';
      ndefer(res+"=(F_ROUT)".append(bind_fortran_name(arg.fun.name.str)+";"));
      make_sure_emitted(arg.fun);
      return res;
   end;
   
   private get_inout_args_back(arg:AM_BND_CREATE_EXPR,arglist:FLIST{STR},local:STR,where_str:STR) is
      loop
	 i::=arg.ind!;
	 entry:STR;
	 idx::=arg.bnd_args[i];
	 if idx/=0 then -- self is never of type out
	    -- outmode is only possible for remote procedure calls generated
	    -- for pSather, but never for BND ROUT created by user code
	    a::=arg.fun.args[idx-1];
	    ex::="";
	    if a.mode/=MODES::in_mode then
	       if a.mode=MODES::out_mode then
	          ex:=emit_expr(arg[i].expr);
	       else
		  ex:=arglist.elt!;
	       end;
	       b::=local+"->bound_arg"+i;
	       entry:=cast(arg[i].expr.tp,a.tp,b,false);
	       if arg[i].expr.tp.is_immutable then
		  ndefer(ex+" = "+entry+";");
		  if ~arg[i].expr.tp.is_atomic then
		     ndefer("RECVOB("+tag_for(arg[i].expr.tp)+",&"+ex+","+where_str+");");
	          end;
	       else
		  ndefer(ex+" = RECVFOB("+entry+","+where_str+");");
	       end;
	    end;
	 end;
      end;
   end;

	 
      
   make_sure_emitted(s:SIG) is
      -- Some routines are skipped because they are inlined.
      -- If they need to be generated anyway, e.g. for dispatching,
      -- then they get put in 'leftovers'.
      
      ard::=not_emitted.get(s);
      if ~void(ard) then
	 leftovers:=leftovers.insert(ard);
	 not_emitted:=not_emitted.delete(s);
      end;
   end;

   private emit_am_bnd_rout_call_expr(arg:AM_BND_ROUT_CALL_EXPR):STR is
      tp::=arg.br_tp;
      br::=dec_local(tp);
      ndefer(br.append(" = ",cast(tp,arg.br.tp,emit_expr(arg.br),false),";"));
      -- The cast is necessary if it's in a typecase.
      
      res::="(*(".append(br,"->funcptr))(",br);
      arg_list::=emit_and_cast_args(arg);
      arg_strs:STR;
      loop  
	 i::=0.upto!(arg_list.size-1);
	 arg_strs := arg_strs + "," + arg_list[i];
      end;
      
      if ~void(arg_strs) then
	 res := res.append(arg_strs);
      end;
      if func_tables then
         res:=res.append(",&FF");
      end;
      res := res.append(")");
      
      if need_caller_copy_out(arg)  then
	 if ~void(arg.tp) then
	    func_res ::= dec_local(arg.tp);
	    ndefer( func_res+" = " + res + ';');
	    caller_copy_out(arg, arg_list);
	    return func_res;
	 else
	    -- no result is needed
	    ndefer(res + ';');
	    caller_copy_out(arg, arg_list);
	    return void;
	 end;
      else
	 return res;
      end;      
   end;
   

   private emit_am_bnd_iter_create_expr(arg:AM_BND_CREATE_EXPR):STR is
      binding_iter_closure ::= false; ident ::= #IDENT("call!");	 
      if (arg.fun.name = ident) then  binding_iter_closure := true; end;
      bnd_iter_creates:=bnd_iter_creates.push(arg);
      code_c.uses_bnd_iter_create(arg);
      if ~binding_iter_closure then
	 code_c.uses_sig(arg.fun);
      end;
      code_c.uses_iter(arg.fun);
      
      if arg.fun.tp.is_abstract then 
	 code_c.uses_layout(#ABSTRACT_FRAME_LAYOUT(arg.fun,prog));
      elsif binding_iter_closure then
	 -- frame already available
      else
	 a:AM_ROUT_DEF:=code_c.iter_sigs.get(arg.fun);
	 if void(a) then
	    -- iter could have been inlined so check our table
	    a:=itersig_map.get(arg.fun);
	    if void(a) then  -- this sould never happen !
	       barf("Iter signature not found in : emit_am_bnd_iter_create."); 
	    end;
	 end;
	 	       
	 -- table that maps sigs of iters to their am_rout_defs for later use
	 -- in generate_bnd_iter_stubs, 
	 itersig_map := itersig_map.insert(arg.fun,a);
	 code_c.uses_layout(#FRAME_LAYOUT(a,prog)); 
      end;   
      -- builtin iters are not stored in iter_sig !!
      code_c.uses_layout(#BOUND_ITER_FRAME_LAYOUT(arg,prog));
      l_res ::= mangler.genlocal(current_sig); 
      code_c+eol+' '+mang(arg)+"_iter_ob "+l_res+';';--in; 
      ndefer(" ");
      ndefer(eol+l_res+" = OBALLOC(" + mang(arg) + "_iter_ob);"); 
      ndefer(l_res+"->header.tag = "+tag_for(arg.tp)+';');
      ndefer(l_res+"->size = sizeof(struct " +  mang(arg) + "_iter_ob_struct);"); 
      ndefer(l_res + "->state = 0;" + "  /* initialize state */");
      
      ndefer(l_res + "->call = ");   
      if ~void(arg.fun.ret) then  
	 defer("("+mang(arg.fun.ret, void) + " (*) (");
      else 
	 defer("( void (*) ("); 
      end;      
         
      defer(mang(arg) + "_iter_ob");
      if func_tables then
	 defer(", struct _func_frame *"); end;
      defer("))"+mang(arg)+"_call_function;"); 
      
      -- set bound arguments
      comment("set bound arguments");
      loop
	 i::=arg.ind!;
	 entry:STR;
	 idx::=arg.bnd_args[i];
	 if idx=0 then
	    entry:=cast(arg.fun.tp,arg[i].expr.tp,emit_expr(arg[i].expr),false);
	    ndefer(l_res+"->bound_arg"+i+" = "+entry+';');
	 else
	    entry:=cast(arg.fun.args[idx-1].tp,arg[i].expr.tp,
			emit_expr(arg[i].expr),false);
	    ndefer(l_res+"->bound_arg"+i+" = "+entry+';')
	 end;
      end;
      code_c + " \n";
      make_sure_emitted(arg.fun);
      return "("+mang(arg.tp)+") "+l_res;
   end;
   
   private emit_am_bnd_iter_call_expr(arg:AM_BND_ITER_CALL_EXPR):STR is
      tp::=arg.bi_tp;                 
      bi::=dec_local(tp);
            
      s1,res:STR;
      if ~void(arg.tp) then
	 s1:=dec_local_comment(arg.tp,
			       "Holds result of call to "+arg.bi_tp.str);
      end;
      -- treatment of builtin iters comes here
      biter_name ::= mang(arg,current_sig);
      if void(biter_name) then barf("Unrecognized Sather bound iter name: "
				    +emit_expr(arg.bi));
      end;
      ndefer("if (".append(biter_name,"->state == 0) {"));
      in;
      -- initialization : treatment of once arg
      emit_bnd_iter_initialization(arg);
      move_out;
      ndefer("}");
      
      -- treatment of hot args, loop over unbnd args and pick out hot ones
      -- hot might be void, if there are non hot !
      if ~void(arg.bi_tp.hot) then 
	 loop
	    i::=arg.ind!;
	    if arg.bi_tp.hot[i] then
	       comment("hot argument");
	       -- check whether indicies are right aj, arg[] includes self !!
	       arg_str ::= emit_call_arg(arg[i], tp.args[i], false, false);
	       if tp.args[i].tp.is_immutable 
			and SYS::ob_eq(arg[i].mode, MODES::out_mode) 
			and arg[i].expr.tp.is_abstract then
		  ndefer(biter_name.append("->hotarg",i.str," = ",arg_str
					   ,";"));
	       else
		  ndefer(biter_name.append("->hotarg",i.str," = ",
						      cast_arg(tp.args[i].
							       tp,arg[i].expr.
							       tp,
							       arg_str, 
							       false, 
							       arg[i].mode),
					   ";"));
	       end; -- ends if is_immutable
	    end; -- ends if hot
	 end; -- ends loop
      end; -- ends ~void(arg.bi_tp.hot) then 
      pro::="";
      if func_tables then 
         pro:=",&FF";
      end;
      -- potentially handling of abstract stuff/psather stuff
      -- the actual call
      if ~void(arg.tp) then
	 ndefer(s1+" = (*(".append(biter_name, "->call))((void *) " +
				   biter_name) + pro +");");
	 res:=s1;
      else
	 ndefer("(*(".append(biter_name, "->call))((void *) " +
			     biter_name) + pro +");");
	 res:="/* No return value from iter call */";
      end;
      -- termination test
      ndefer("if (".append(biter_name,"->state == -1) {"));
      in;
      ndefer("goto ".append(current_loop,";"));
      move_out;
      ndefer("}");
      pop_exceptions(ex_nesting-current_loop_ex_nesting);
      return res;
   end;
      
   -- pSather nodes
   private emit_am_here_expr(arg:AM_HERE_EXPR):STR is
      if prog.zones then
	 return("SI_HERE()");
      else
	 if ~prog.distributed then return "0"; end;
	 return("HERE");
      end;
   end;

   private emit_am_any_expr(arg:AM_ANY_EXPR):STR is
      return "ANY";
   end;

   private emit_am_global_expr(arg:AM_GLOBAL_EXPR):STR 
      pre prog.zones
   is
      return "SI_global";
   end;

   private emit_am_cluster_expr(arg:AM_CLUSTER_EXPR):STR is
      if ~prog.distributed then return "1"; end;
      return("CLUSTERS");
   end;

   private emit_am_cluster_size_expr(arg:AM_CLUSTER_SIZE_EXPR):STR is
      return("MY_CLUSTER_SIZE");
   end;
   
   private emit_am_far_expr(arg:AM_FAR_EXPR):STR is
      if arg.arg.tp.is_immutable then return "0"; end;
      if ~prog.distributed then return "0"; end;
      if arg.arg.tp.is_abstract then return "PS_FAR("+emit_expr(arg.arg)+")";
      else return "PSR_FAR("+emit_expr(arg.arg)+")"; end;
   end;

   private emit_am_where_expr(arg:AM_WHERE_EXPR):STR is
      if prog.zones then
	 return "SI_WHERE("+emit_expr(arg.arg)+")";
      else
	 if ~prog.distributed then return "0"; end;
	 if arg.arg.tp.is_immutable then return "HERE"; end;
	 if arg.arg.tp.is_abstract then return "PS_WHERE("+emit_expr(arg.arg)+")";
	 else return "PSR_WHERE("+emit_expr(arg.arg)+")"; end;
      end;
   end;

   private emit_am_near_expr(arg:AM_NEAR_EXPR):STR is
      if arg.arg.tp.is_immutable then return "0"; end;
      if ~prog.distributed then return "1"; end;
      if arg.arg.tp.is_abstract then return "PS_NEAR("+emit_expr(arg.arg)+")";
      else return "PSR_NEAR("+emit_expr(arg.arg)+")"; end;
   end;

   private emit_am_with_near_stmt(arg:AM_WITH_NEAR_STMT) is
      s:STR;
      loop
	 a::=arg.objects.elt!;
	 t:STR;
	 if a.tp.is_immutable then
	    t:="0";
	 else
            t:="PS_NEAR_OR_VOID("+emit_expr(arg.objects.elt!)+")";
	 end;
         s:=s+"&&".separate!(t);
      end;
      ndefer("if("+s+") {");
      in;
      nearobj::=#FLIST{BOOL};
      loop
         a::=arg.objects.elt!;
	 typecase a when AM_LOCAL_EXPR then
	    nearobj:=nearobj.push(a.check_near).push(a.is_always_near);
	    a.check_near:=true;
	    a.is_always_near:=true;
	 else end;
      end;
      emit_code(arg.near_part);
      loop
         a::=arg.objects.elt!;
	 typecase a when AM_LOCAL_EXPR then
	    a.check_near:=nearobj.pop;
	    a.is_always_near:=nearobj.pop;
	 else end;
      end;
      move_out;
      ndefer("} else {");
      in;
      emit_code(arg.else_part);
      move_out;
      ndefer("}");
   end;

   private is_simple_type(tp:$TP):BOOL is
      if tp.is_immutable then
	 if ~tp.is_atomic then
	    return false;
	 end;
      end;
      return true;
   end;
   
   private is_simple_am_at_expr(ate:AM_AT_EXPR):BOOL is
      e::=ate.e;
      typecase e
      when AM_ROUT_CALL_EXPR then
	 if e.size > 2 then return false; end;
	 -- take care of self
	 if ~is_simple_type(e.fun.tp) then return false; end;
	 -- take care of return value, if any
	 if ~void(e.fun.ret) then
	    if ~is_simple_type(e.fun.ret) then return false; end;
	 end;
	 -- check arguments;
	 loop
	    a ::= e.fun.args.elt!; 
	    if ~is_simple_type(a.tp) or a.mode.is_out_inout then
	       return false;
	    end;
	 end;
	 
	 -- if raises an exception, go though full translation
	 -- actually, it is probably possible to handle this here
	 -- without slowing down the simplest case, but since
	 -- exceptions are rare, I do not worry about this stuff
 
         -- The side effect analysis is not done for methods that
         -- are unreachable from the Sather program. So, for methods
         -- that are reachable from an external C class only, the
         -- attribute 'se_context' of the signature is void.
         -- Below we are catching these cases. A better solution
         -- would be to run side effect analysis for also for all
         -- methods of external classes and their call trees.
         -- For now, is is assumed, that those methods do not raise
         -- an exceptions. (What C code would catch them?)
         sec ::= e.fun.get_se_context(prog);
         if void(sec) then
            return true;
         end;
         if sec.has_raise then
            return false;
         end;
 
         return true;
      else
         return false;
      end;
      return false;
   end;
      
   -- This is a "FORK" handler that gets invokde on the remote end to execute
   -- the "at" expression. Returns a handler prototype
   private emit_simple_at_handler(ate:AM_AT_EXPR,ca:AM_ROUT_CALL_EXPR,
				fork_handler:BOOL):STR is
      decl:STR;

      decl := "void ".append(mang(ate),"(BR_cluster_t src, BR_word_t at_attach_ptr, BR_word_t tid");
      loop
	 ind::=0.upto!(ca.size-1);
	 decl := decl.append(", BR_word_t ", "arg_", ind.str);
      end;
      decl := decl+")";
      
      if fork_handler then
	 unbox_c + "\n/* Simple @ expr fork handler */\n";
      else
	 unbox_c + "\n/* Simple @ expr request handler */\n";
      end;
      
      unbox_c + decl+"{\n";
      -- Declare res value
      unbox_c + " ";
      if ~void(ca.fun.ret) then
	 unbox_c + mang(ca.fun.ret)+" __res;\n";
      else
	 unbox_c + "BR_word_t __res = 0;\n"; 
      end;
      
      -- previous frame is possibly on a different cluster
      -- this is a new thread, so start from scratch
      if func_tables then
	 unbox_c + " struct _func_frame FF_NULL={ 0,NULL,NULL };\n";
	 unbox_c + " struct _func_frame *pFF=&FF_NULL;\n";
      end;
      
      -- if reusing some thread on the remote end (REQUEST/REPLY
      -- rather than FORK Brahma call, need to temporarily
      -- switch the local memory structure;
      if ~fork_handler then
	 unbox_c + " LOCAL_MEM prev_local_mem=(LOCAL_MEM)BR_GET_THREAD_LOCAL();\n";
	 unbox_c + " struct LOCAL_MEM_struct local_mem;\n\n";
	 unbox_c + " BR_SET_THREAD_LOCAL((void *)&local_mem);\n";
      end;
      
      -- Initialize local thread memory, etc
      unbox_c + " INIT_THREAD_MEMORY();\n";
      -- make sure the id is the same as that of the thread that calls '@' expr
      unbox_c + " PSATHER_THREAD_ID_SET(*((BR_thread_t *)&tid));\n";
      unbox_c + " THREAD_PROTECT_BEGIN\n\n";

      -- Create a simple call expression 
      call::=#AM_ROUT_CALL_EXPR(ca.size);
      call.fun := ca.fun;
      loop
	 i::=ca.ind!;
	 arg_expr ::= #AM_LOCAL_EXPR(void);
	 arg_expr.tp_at := ca[i].expr.tp;
	 arg_expr.name := #IDENT("arg_"+i.str);
	 call[i] := #AM_CALL_ARG(arg_expr); --in mode default
      end;
	    
      -- manufacture a casted arg list
      arg_list:ARRAY{STR} := #(ca.size);
      loop
	 i::=ca.ind!;
	 arg_list.set!("(".append(mang(ca[i].expr.tp),")","arg_", i.str));
      end;
      
      -- the following  is hack to be able to use emit_call 
      -- temporarily, switch string on ndefer!
      save_rout_code ::= routine_code;
      save_file ::= code_c;
      routine_code := #FSTR+"\n";
      code_c := unbox_c;
      
      -- the block is necessary since some temporray could be created
      unbox_c + "  do{\n";
      call_str:STR := emit_call(call.fun,call,arg_list);
      unbox_c + routine_code;      
      -- restore current routine code
      routine_code := save_rout_code;
      code_c := save_file;
      

      -- keep the result in local, if any
      if ~void(ca.fun.ret) then
	 unbox_c + " __res =";
      end;
			  
      unbox_c + "  "+call_str + ";\n";
      unbox_c + "  }while(0);\n";
      
      unbox_c + " THREAD_PROTECT_END\n\n";
      
      -- may have to restore previously saved local mem structure
      if ~fork_handler then
	 unbox_c + " BR_SET_THREAD_LOCAL((void *)prev_local_mem);\n";
      end;
      -- depending on whether this is a fork or request handler
      -- we may have to send either a request or reply back
      if fork_handler then
	 -- we are in a fork handler
	 unbox_c + " AT_ATTACH_FORK_DONE";
      else
	 -- we are in a request handler
	 unbox_c + " AT_ATTACH_REQUEST_DONE";
      end;
      unbox_c + "(src,at_attach_ptr,__res);\n";
      unbox_c + "}\n";
      unbox_c.uses_sig(ca.fun); 
      
      return decl;
   end;

   private emit_simple_am_at_expr(ate:AM_AT_EXPR):STR is
      res:STR;
      dest:STR;
      req_str:STR;
      arg_list:ARRAY{STR};
      ca: AM_ROUT_CALL_EXPR;
      may_block:BOOL;
      
      dest := emit_expr(ate.at);
      e::=ate.e;
      typecase e
      when AM_ROUT_CALL_EXPR then
	 ca := e;

	 if prog.fast_at2 then
	    -- may be able to get away with a simple request/reply sequence
	    if  e.fun.get_se_context(prog).may_block then
	       may_block := true;
	    else
	       may_block := false;
	    end;
	 else
	    -- if at2 is not set, assume that it may block
	    may_block := true;
	 end;
      end;
      
      if ~void(ca.fun.ret) then
	 res := dec_local(ca.fun.ret);
      end;

      comment("Simple @ expression start");
      -- first, optimize for local case
      ndefer("if (BR_HERE()==".append(dest,"){"));
      in;
      call_str:STR := emit_expr(ca);
      if ~void(ca.fun.ret) then
	 ndefer(res.append("=",call_str,";"));
      else 
	 ndefer(call_str+";");
      end;
	    
      move_out;
      ndefer("} else{");
      in;
      ndefer("AT_ATTACH_DEC(at_attach);");
      ndefer("AT_ATTACH_START(at_attach);");
      
      -- emit request message
      arg_list := emit_and_cast_args(ca);
      num_args:INT := arg_list.size+2;  -- one arg for attach ob and 1 for tid
      if may_block then
	 req_str := "BR_FORK_";
      else
	 req_str := "BR_REQUEST_";
      end;
      req_str := req_str.append(num_args.str,"(",dest,",");
      req_str := req_str.append(mang(ate), ",");
      -- First 2 args are a pointer to attach and current thread id
      req_str := req_str +
	    "(BR_word_t)&at_attach, (BR_word_t)PSATHER_THREAD_ID.t";
      
      -- take care of self
      if ca.fun.tp.is_immutable then
	 req_str := req_str.append(",(BR_word_t)", arg_list[0]);
      else
	 -- reference object. Need to fix cluster number bits
	 req_str := req_str.append(",(BR_word_t)SENDFOB(", 
				   arg_list[0], ",", dest, ")");
      end;      
      
      -- append args
      loop
	 arg_str:STR;
	 i ::= 1.upto!(ca.size-1);
	 sa ::= ca.fun.args[i-1];
	 if sa.tp.is_immutable then
	    if ~sa.tp.is_atomic then
	       barf("non atomic argument in simple at expr ");
	    end;
	    arg_str := "(BR_word_t)"+arg_list[i];
	 else
	    arg_str := "(BR_word_t)".append("SENDFOB(", 
					    arg_list[i],",", dest,")");
	 end;
	 req_str:=req_str.append(",",arg_str);
      end;
      req_str := req_str + ");";
      ndefer(req_str);
      
      ndefer("AT_ATTACH_WAIT(at_attach);");
      -- if there is a return value, return it
      -- may have to fiddle around with pointer bits
      if ~void(ca.fun.ret) then
	 if ca.tp.is_immutable then
	    if ~ca.tp.is_atomic then
	       ndefer("RECVOB("+tag_for(ca.tp)+",&"+"at_attach.result,"+dest+");");
	       ndefer(res.append("=",mang(ca.fun.ret),"at_attach_result;"));
	    end;
	    -- atomic value objects are fine
	 else
	    ndefer(res.append("=(",
		     mang(ca.fun.ret),")RECVFOB((FOB)at_attach.result,",dest,");"));
	 end;
      end;
      ndefer("AT_ATTACH_END(at_attach);");
      move_out;
      ndefer("}");
      comment("Simple @ expression end");
      
      -- emit a remote handler
      decl ::= emit_simple_at_handler(ate, ca, may_block);
      code_c +"\n extern ".append(decl,";\n");
      
      return res;
   end;
   
   
   private emit_am_at_expr(arg:AM_AT_EXPR):STR is
      if prog.zones then
	 err_loc(arg);
	 if prog.distributed then
	    barf("Zones are not yet implemented for distributed platforms");
         end;
	 -- Right now, exceptions do not properly restore the value of
	 -- `here'.  This should be fixed.
	 z::=dec_local(TP_BUILTIN::zone);
	 ndefer(z+"=SI_HERE();");
	 ndefer("SI_SET_HERE("+emit_expr(arg.at)+");");
	 tp::=arg.e.tp;
	 r:STR;
	 if ~void(tp) then
	    r:=dec_local(tp);
	    ndefer(r+"="+emit_expr(arg.e)+";");
	 else
	    ndefer(emit_expr(arg.e)+';');
	    r:=void; -- Nothing will be emitted since this must be an expr_stmt
	 end;
	 ndefer("SI_SET_HERE("+z+");");
	 return r;
      end;
      if ~prog.distributed then 
	 err_loc(arg);
	 loc::=emit_expr(arg.at); -- we have to emit the expr, as
	       -- there could be a call with side effects in there
	 ndefer("{ INT dummy_INT_="+loc+";}");
	 return emit_expr(arg.e); 
      end;
      
      -- Normal Distributed Case
      
      -- try to get away with a simple translation, if possible
      if prog.fast_at1 or prog.fast_at2 then
	 if is_simple_am_at_expr(arg) then 
	    if prog.warnings then
	       message("Simple @ expression found");
	    end;
	    return emit_simple_am_at_expr(arg); 
	 else
	    if prog.warnings then
	       warning("Complex @ expression found");
	    end;
	 end;
      end;
      
      e::=arg.e;
      typecase e 
      when AM_ROUT_CALL_EXPR then
	 loc::=emit_expr(arg.at);
	 res:STR;
	 bnd::=#AM_BND_CREATE_EXPR(e.size,e.source);
	 loop bnd.set!(e.elt!); end;
	 bnd.is_remote:=true;
	 bnd.clst:=loc;
	 bnd.fun:=e.fun;
	 bnd.bnd_args:=#(e.size);
	 loop bnd.bnd_args.set!(0.up!); end;
	 tbnd::=#TP_ROUT(void,e.fun.ret,prog);
	 bnd.tp_at:=tbnd;
	 al:FLIST{STR};
	 rt::=emit_am_bnd_rout_create_expr(bnd,false,out al);
	 ndefer(rt+"->local=SENDFOB("+rt+","+loc+");");
	 if ~void(arg.e.tp) then
	    res:=dec_local(arg.e.tp);
	    ndefer("REMOTE_EXEC("+loc+","+rt+");");
	    if e.tp.is_immutable then
	       if ~e.tp.is_atomic then
		  ndefer("RECVOB("+tag_for(e.tp)+",&"+rt+"->ret_arg,"+loc+");");
	       end;
	       res:=rt+"->ret_arg";
	    else
	       res:="RECVFOB("+rt+"->ret_arg,"+loc+")";
	    end;
	 else
	    res:="REMOTE_EXEC("+loc+","+rt+");";
	 end;
	 get_inout_args_back(bnd,al,rt,loc);
	 return res;
      else
	 warning("@cluster works currently only for routine calls, not for "+SYS::str_for_tp(SYS::tp(e))+", ignoring @");
	 ndefer("/* the following call should be made at some other cluster */");
	 return emit_expr(e);
      end;
   end;

   private emit_am_arr_const(arg:AM_ARR_CONST):STR is
      barf("array constants not implemented yet"); return "";
   end;

   private emit_am_inti_const(arg:AM_INTI_CONST):STR is
      barf("INTI constants not implemented yet"); return "";
   end;

   private emit_am_flti_const(arg:AM_FLTI_CONST):STR is
      barf("FLTI constants not implemented yet"); return "";
   end;

   private emit_am_fltx_const(arg:AM_FLTX_CONST):STR is
      barf("FLTX constants not implemented yet"); return "";
   end;

   private emit_am_fltdx_const(arg:AM_FLTDX_CONST):STR is
      barf("FLTDX constants not implemented yet"); return "";
   end;

   private value_compare(tp:$TP,e1,e2:STR):STR pre tp.is_immutable is
      -- expression for comparing contents of two value types

      if tp.is_builtin then return "(".append(mang(tp),"_IS_EQ(",e1,",",e2,"))"); end;
      aod:AM_OB_DEF:=am_ob_def_for_tp(tp);
      after_first:BOOL:=false;
      if void(aod.at) then
	 -- tp has no attributes!
	 return "1";
      end;
      
      res::="";
      -- (ben) sort attributes for determinism
      aod_at:FMAP{IDENT,$TP} := aod.at;
      aod_idents:ARRAY{IDENT} := aod.sorted_at;
      assert ~void(aod_idents);
      loop
	 -- (ben) Use sorted keys. old  p:TUP{IDENT,$TP}:=aod_at.pairs!;
	 p_key:IDENT := aod_idents.elt!;
	 p_tp:$TP := aod_at.get(p_key);
	 key:STR:=mang(p_key,tp);
	 if after_first then res:=res+"&&"; end;
	 if p_tp.is_immutable then
	    res:=res+value_compare(p_tp,e1+'.'+key,e2+'.'+key);
	 else
 	    if prog.distributed then
 	       res:=res+"F_SYSOBEQ("+e1+'.'+key+','+e2+'.'+key+')';
 	    else
 	       res:=res+"SYSOBEQ("+e1+'.'+key+','+e2+'.'+key+')';
 	    end;
	 end;
	 after_first:=true;
      end;

      if ~void(aod.arr) then
	 loop
	    i::=0.for!(aod.asize);
	    if after_first then res:=res+"&&"; end;
	    if aod.arr.is_immutable then
	       res:=res+value_compare(aod.arr,e1+".arr_part["+i+"]",e2+".arr_part["+i+"]");
	    else
	       res:=res+"("+e1+".arr_part["+i+"]=="+e2+".arr_part["+i+"])";
	    end;
	    after_first:=true;
	 end;
      end;
      return res;
   end;

   private value_void(tp:$TP,e:STR):STR pre tp.is_immutable is
      -- expression for comparing value types to void (all zero elements)
      if tp.is_immutable and tp.is_builtin then return mang(tp)+"_IS_VOID("+e+")"; end;
      aod:AM_OB_DEF:=am_ob_def_for_tp(tp);
      after_first:BOOL:=false;
      res::="";
      code_c.uses_tp(tp);
      if ~void(aod.at) then
	 -- Changed to sort the attributes.(ben)
	 aod_at:FMAP{IDENT,$TP} := aod.at;
	 aod_idents:ARRAY{IDENT} := aod.sorted_at;
	 assert ~void(aod_idents);
	 loop 
	    p_key:IDENT := aod_idents.elt!;
	    p_tp:$TP := aod_at.get(p_key);
	    -- Old p::=aod.at.pairs!;
	    key:STR:=mang(p_key,tp);
	    if after_first then res:=res+"&&"; end;
	    if p_tp.is_immutable then
	       res:=res+value_void(p_tp,e+'.'+key);
	    else
	       code_c.uses_tp(p_tp);
	       res:=res+'('+e+'.'+key+"==("+mang(p_tp)+")0)";
	    end;
	    after_first:=true;
	 end;
      end;
      if ~void(aod.arr) then
	 code_c.uses_tp(aod.arr);
	 loop i::=0.for!(aod.asize);
	    if after_first then res:=res+"&&"; end;
	    if aod.arr.is_immutable then
	       res:=res+value_void(aod.arr,e+".arr_part["+i+"]");
	    else
	       res:=res+'('+e+".arr_part["+i
		     +"]==("+mang(aod.arr)+")0)";
	    end;
	    after_first:=true;
	 end;
      end;
      return res;
   end;
 
   private make_tag_table is
      -- Assign numbers to every type which needs a tag.  This
      -- needs to be deterministic to avoid recompiling everything
      -- when tag numbers change.  So we sort them alphabetically.

      a::=#ARRAY{$TP}(needs_tag.size);
      loop
	 a.set!(needs_tag.elt!);
      end;
      a.sort;
      pos:INT:=1;
      neg:INT:= -1;
      loop
	 tp::=a.elt!;
	 if tp.is_immutable then
	    tags:=tags.insert(tp,neg);
	    neg:=neg-1;
	 else
	    tags:=tags.insert(tp,pos);
	    pos:=pos+1;
	 end;
      end;
   end;

   adjust_tag_table:BOOL is
      -- Assign numbers to the types that are in needs_tag but not in
      -- the table, that is those added in the leftovers.
      -- return true if there were new tags, false otherwise

      new_ntg::=needs_tag.copy;
      loop new_ntg:=new_ntg.delete(tags.keys!) end;
      if new_ntg.size=0 then return false; end;
      a::=#ARRAY{$TP}(new_ntg.size);
      loop
	 a.set!(new_ntg.elt!);
      end;
      a.sort;
      pos:INT:=0;
      neg:INT:=0;
      loop
	 n::=tags.targets!;
	 if n>pos then pos:=n end;
	 if n<neg then neg:=n end;
      end;
      pos:=pos+1;
      neg:=neg-1;
      loop
	 tp::=a.elt!;
	 if tp.is_immutable then
	    tags:=tags.insert(tp,neg);
	    neg:=neg-1;
	 else
	    tags:=tags.insert(tp,pos);
	    pos:=pos+1;
	 end;
      end;
      return true;
   end;

   tag_for(tp:$TP):STR is
      -- Expression corresponding to a particular type.  If not known,
      -- make a new one.
        
      needs_tag:=needs_tag.insert(tp); -- make sure gets entered into table
      res::=mang(tp).append("_tag");
      forbid(res);
      return res;
   end;
	

end; -- BE

class FILE_MANGLE is
   
   shared file_names: FSET{STR};
   shared max_file_name_length:INT := 24;

   unique_file_name(prefix:STR,tp:$TP): STR is
      class_name:STR;
      typecase tp
      when TP_ROUT then class_name := tp.str;
      when TP_ITER then class_name := tp.str;
      when TP_CLASS then class_name := tp.str;
      else
	 raise "INTERNAL COMPILER ERROR. Bad type to unique_file_name";
      end;
      s: STR :=class_name;
      tmp::=#FSTR;	-- Use an FSTR for speed here
      loop c::=s.elt!;
	 case c
	 when 'a','b','c','d','e','f','g',
		  'h','i','j','k','l','m',
		  'n','o','p','q','r','s','t',
		  'u','v','w','x','y','z',
		  '0','1','2','3','4','5','6',
		  '7','8','9','_',
		  'A','B','C','D','E','F','G',
		  'H','I','J','K','L','M',
		  'N','O','P','Q','R','S','T',
		  'U','V','W','X','Y','Z' then
	    tmp:=tmp+c;
	 when '$' then tmp:=tmp+'d';
	 when '!' then tmp:=tmp+'b'
	 else		-- don't put anything else in
	 end;
      end;
      -- make sure there's something left
      if tmp.length = 0 then tmp := tmp+"name" end;
      
      -- make sure it starts with a letter
      case tmp[0]
      when '0','1','2','3','4','5','6','7','8','9','_' then
	 tmp:=#FSTR+"S"+tmp;
      else
      end;
      class_name := tmp.str;
      full_name: STR := prefix+class_name;
      hash_str:STR := full_name.hash.abs.str;
      if full_name.size > (max_file_name_length-10) then
	 full_name := full_name.head(max_file_name_length-10);
      end;
      full_name := full_name+hash_str;
      res:STR := full_name;
      -- #ERR+"Full name:"+res+"\n";
      loop i ::= 0.up!;
	 while!(file_names.test(res));
	 res := full_name+i.str;
	 if (i > 1000) then
	    raise "Internal compiler error:Something wierd is going on with file name mangling";
	 end;
      end;
      -- #ERR+"Unique file name:"+res+"\n";
      file_names := file_names.insert(res);
      return res;
   end;
   
end;

-- vim:sw=3:nosmartindent
