home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sa104os2.zip / SATHR104.ZIP / SATHER / COMPILER / BE.SA < prev    next >
Text File  |  1995-02-14  |  95KB  |  2,808 lines
  1. -- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
  2. -- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
  3. -- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
  4. -- the file "Doc/License" of the Sather distribution.  The license is also   --
  5. -- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
  6. --------> Please email comments to "sather-bugs@icsi.berkeley.edu". <----------
  7.  
  8. class BE is
  9.     -- back-end C generation from an AM structure.
  10.  
  11.     -- These are options that may be set outside BE.
  12.  
  13.     attr indent:INT;          -- current level of indentation
  14.     attr prog:PROG;          -- The program's PROG object
  15.  
  16.     -- These are private state needed for the translation.
  17.  
  18.     private attr manglemap:FMAP{$OB,STR};
  19.         -- mapping from Sather objects to C strings
  20.  
  21.     private attr mangleset:FSET{STR};
  22.         -- C strings which have already been emitted
  23.  
  24.     private attr forbidden:FSET{STR};
  25.         -- Strings which may not be used as identifiers
  26.  
  27.     private attr counter:INT;
  28.         -- Counter used for generating unique strings
  29.  
  30.     private attr local_counter:INT;
  31.         -- For making unique local declarations
  32.  
  33.     private attr state_counter:INT;
  34.         -- for yield goto's
  35.  
  36.     private attr built_in_routines:FMAP{STR,TUP{STR,STR}};
  37.         -- Compiler-known functions and their associated C name
  38.     -- (Two versions, one w/o checking and one with.)
  39.  
  40.     private attr built_in_iters:FMAP{STR,ITER_INLINE};
  41.     -- Compiler-known iters 
  42.  
  43.     private attr built_in_classes:FSET{$TP};
  44.         -- Compiler-known classes
  45.  
  46.     private attr special_externs:FMAP{STR,STR};
  47.         -- external routines that need special prototypes
  48.  
  49.     private attr typedefs_h, sather_h, decs_h,
  50.           globals_h, tags_h, strings_h, makefile:FILE;
  51.     private attr code_c_count:INT;
  52.     private attr code_c, globals_c:FILE;
  53.         -- The header and C files.
  54.     private attr code_dir:STR;
  55.         -- The directory all this happens in
  56.  
  57.     private attr tags:FMAP{$TP,INT};
  58.         -- Integers associated with classes
  59.  
  60.     private attr main_sig:SIG;
  61.         -- SIG corresponding to main
  62.  
  63.     private attr current_function:SIG;
  64.         -- SIG of ccurrent function being translated
  65.  
  66.     private attr current_function_str:STR;
  67.         -- Name of current function being translated
  68.  
  69.     private attr current_self:STR;
  70.         -- expr for self
  71.  
  72.     private attr saw_outer_return:BOOL;
  73.     -- was a return at outer level seen in this routine?
  74.  
  75.     private attr chk_pre, chk_post, chk_invariant, chk_assert,
  76.     chk_arith, chk_bounds, chk_void, chk_when,
  77.     chk_destroy, chk_return:BOOL;
  78.     -- whether different checks are on for the current function
  79.  
  80.     private attr nested_its:FLIST{AM_ITER_CALL_EXPR};
  81.         -- Stack of iter calls
  82.  
  83.     private attr current_loop:STR;
  84.         -- label to goto to at end of loop
  85.  
  86.     private attr abstract_routs:FLIST{AM_ROUT_DEF};
  87.         -- List of abstract routines to make dispatch tables for
  88.  
  89.     private attr bnd_rout_creates:FLIST{AM_BND_CREATE_EXPR};
  90.     -- List of bound routine stubs to generate
  91.  
  92.     private attr routine_code:FSTR;
  93.         -- code waiting to be emitted
  94.  
  95.     private attr str_count:INT;
  96.     -- number of STR constants emitted (for making their id)
  97.  
  98.     private attr inlined_sigs:FMAP{SIG,AM_ROUT_DEF};
  99.     -- routines that weren't generated because they were inlined
  100.  
  101.     private attr routine_count:INT;
  102.     -- count of emitted routines, reset for each new file
  103.  
  104.     private attr inlined_iter_count:INT;
  105.     -- count of how many iters got inlined
  106.  
  107.     create(p:PROG):SAME is
  108.  
  109.         res::=new;
  110.         res.prog:=p;
  111.  
  112.         res.manglemap:=#;
  113.         res.mangleset:=#;
  114.         res.forbidden:=#;
  115.         res.special_externs:=#;
  116.         res.counter:=1;
  117.     res.built_in_routines:=#;
  118.     res.built_in_iters:=#;
  119.     res.built_in_classes:=#;
  120.     res.abstract_routs:=#;
  121.     res.bnd_rout_creates:=#;
  122.     res.str_count:=1;
  123.     res.inlined_sigs:=#;
  124.  
  125.     res.insert_forbidden_names;
  126.         res.insert_built_in_routines;
  127.     res.insert_built_in_iters;
  128.     res.insert_built_in_classes;
  129.     res.insert_special_externs;
  130.      
  131.         return res;
  132.     end;
  133.  
  134.     init is
  135.     -- initialization should occur after the layouts and sigs have been constructed
  136.  
  137.         indent:=0;
  138.  
  139.      -- code_dir:=prog.options.executable+".code";                              -- NLP
  140.         code_dir:=prog.options.executable+".cod";                               -- NLP
  141.  
  142.     FILE::create_directory(code_dir);
  143.  
  144.     new_c_file;
  145.  
  146.         fn::=code_dir+'/'+"typedefs.h";
  147.     typedefs_h:=FILE::open_for_write(fn);
  148.         if typedefs_h.error then barf("Couldn't open "+fn); end;
  149.  
  150.         fn:=code_dir+'/'+"sather.h";
  151.     sather_h:=FILE::open_for_write(fn);
  152.         if sather_h.error then barf("Couldn't open "+fn); end;
  153.  
  154.         fn:=code_dir+'/'+"decs.h";
  155.     decs_h:=FILE::open_for_write(fn);
  156.         if decs_h.error then barf("Couldn't open "+fn); end;
  157.  
  158.         fn:=code_dir+'/'+"globals.h";
  159.     globals_h:=FILE::open_for_write(fn);
  160.         if globals_h.error then barf("Couldn't open "+fn); end;
  161.  
  162.         fn:=code_dir+'/'+"globals.c";
  163.     globals_c:=FILE::open_for_write(fn);
  164.         if globals_c.error then barf("Couldn't open "+fn); end;
  165.     globals_c+"#include \"sather.h\"\n";
  166.  
  167.         fn:=code_dir+'/'+"tags.h";
  168.     tags_h:=FILE::open_for_write(fn);
  169.         if tags_h.error then barf("Couldn't open "+fn); end;
  170.  
  171.         fn:=code_dir+'/'+"strings.h";
  172.     strings_h:=FILE::open_for_write(fn);
  173.         if strings_h.error then barf("Couldn't open "+fn); end;
  174.  
  175.         fn:=code_dir+'/'+"Makefile";
  176.     makefile:=FILE::open_for_write(fn);
  177.         if makefile.error then barf("Couldn't open "+fn); end;
  178.  
  179.     if prog.options.deterministic then
  180.         sather_h+"#define DETERMINISTIC\n";
  181.     end;
  182.     comp_home::=prog.options.home;
  183.     if comp_home=".." then comp_home:="../.."; end; -- For bootstrapping
  184.         sather_h+"#include \""+comp_home+"/System/GC/gc.h\"\n";
  185.         sather_h+"#include \""+comp_home+"/System/header.h\"\n";
  186.     if prog.options.deterministic then
  187.         globals_c+"BOOL deterministic = TRUE;\n";
  188.     else
  189.         globals_c+"BOOL deterministic = FALSE;\n";
  190.     end;
  191.     sather_h+"extern jmp_buf last_protect;\n";
  192.     sather_h+"extern OB exception;\n\n";
  193.     sather_h+"extern void *sbi_alloc(size_t,INT);\n";
  194.     sather_h+"extern void *sbi_arr_alloc(size_t,INT,size_t,INT);\n";
  195.         sather_h+"extern void *sbi_alloc_atomic(size_t,INT);\n";
  196.         sather_h+"extern void *sbi_arr_alloc_atomic(size_t,INT,size_t,INT);\n";
  197.     sather_h+"extern void sbi_segfault_handler();\n\n";
  198.         sather_h+"#include \"tags.h\"\n";
  199.         sather_h+"#include \"typedefs.h\"\n";
  200.         sather_h+"#include \"decs.h\"\n";
  201.         sather_h+"#include \"globals.h\"\n";
  202.         sather_h+"#include \""+comp_home+"/System/proto.h\"\n\n";
  203.  
  204.     tags:=#;
  205.     neg_tag_count:=1;
  206.     pos_tag_count:=1;
  207.  
  208.     main_sig:=prog.prog_get_main.main_sig;
  209.  
  210.     generate_layouts;
  211.  
  212.     end;
  213.  
  214.     private new_c_file is -- begin a new C file.
  215.     if ~void(code_c) then
  216.             if code_c.error then barf("Some problem writing code file");
  217.         else code_c+'\n'; code_c.close;
  218.         end;
  219.     end;
  220.         fn::=code_dir+'/'+"code"+code_c_count+".c";
  221.     code_c:=FILE::open_for_write(fn);
  222.         if code_c.error then barf("Couldn't open file "+fn); end;
  223.     code_c_count:=code_c_count+1;
  224.  
  225.         code_c+"/* C code generated by Sather 1.0 compiler */\n\n";
  226.             -- should print other info here as well about compilation
  227.     code_c+"#include \"sather.h\"\n\n";
  228.     code_c+"#include \"strings.h\"\n\n";
  229.     end;
  230.  
  231.     -- Because local variables have to precede any use, it is necessary to
  232.     -- queue up code until all the locals that will be needed have been
  233.     -- discovered.  This is done by using the following calls.
  234.  
  235.     private in is indent:=indent+1; end;
  236.         -- move indentation in a logical level
  237.  
  238.     private out is indent:=indent-1; end;
  239.         -- move indentation out a logical level 
  240.  
  241.     private defer_newline is   -- start a new line in queued-up code
  242.         routine_code:=routine_code+eol;
  243.     loop indent.times!; routine_code:=routine_code+' '; end;
  244.     end;
  245.  
  246.     private newline is code_c+eol; loop indent.times!; code_c+' '; end; end;
  247.        -- start a new line to code file
  248.  
  249.     private announce_at(s:SFILE_ID) is
  250.     if prog.options.debug then
  251.         -- terminate current C line and emit #line directive
  252.         lineno:INT:=s.line_num_in;
  253.         if lineno>0 then
  254.         prog.set_eloc(s);
  255.         routine_code:=
  256.                     routine_code+"\n#line "+lineno+" \""+s.file_in+"\"\n";
  257.         end;
  258.     end;
  259.     end;
  260.  
  261.     private eol:STR is
  262.        -- generate a newline or backslash newline, depending
  263.        -- on whether or not debugging #line directives are happening.
  264.  
  265.        if prog.options.debug then return "\\\n";
  266. --     else return "\n";                                                        -- NLP
  267.        end; return "\n";                                                        -- NLP
  268. --     end;                                                                     -- NLP
  269.     end;
  270.  
  271.     private defer(s:STR) is routine_code:=routine_code+s; end;
  272.        -- queue up code for emmission
  273.  
  274.     private ndefer(s:STR) is defer_newline; routine_code:=routine_code+s; end;
  275.        -- same as defer but emits preceding newline
  276.  
  277.     comment(f:FILE,com:STR) is
  278.     -- make a C comment to a FILE
  279.     if prog.options.pretty then f+" /* "+com+" */"; end;
  280.     end;
  281.  
  282.     comment(com:STR) is
  283.     -- make C comment in routine_code.  Has newline.
  284.     if prog.options.pretty then ndefer("/* "+com+" */"); end;
  285.     end;
  286.  
  287.     dec_local(t:$TP):STR is
  288.         -- declare local with no comment
  289.     res::=genlocal;
  290.     code_c+eol+' '+mangle(t)+' '+res+';';
  291.         return res;
  292.     end;
  293.         
  294.     dec_local_comment(t:$TP,com:STR):STR is
  295.     res::=dec_local(t);
  296.     comment(code_c,com);
  297.     return res;
  298.     end;
  299.  
  300.     barf(msg:STR) is barf_at(msg,void); end;
  301.     -- Something wrong within the compiler, but we can't say where.
  302.  
  303.     barf_at(msg:STR,at:$PROG_ERR) is
  304.         -- Something wrong, and we know where.
  305.     prog.err_loc(at);
  306.     prog.err("Internal compiler error: "+msg);
  307.     UNIX::exit(1);  -- Why bother continuing?  Something's very wrong.
  308.     end;
  309.  
  310.     forbid(s:STR) is forbidden:=forbidden.insert(s); end;
  311.     -- make sure this identifier never gets used
  312.  
  313.     private insert_forbidden_names is
  314.         -- Insert names which must not be taken.  More will also
  315.     -- be added by insert_built_in_routines.
  316.  
  317.         l::=#BE_LEX(prog.options.home+"/System/FORBID");
  318.         loop forbid(l.elt!); end;
  319.     end;
  320.  
  321.     private insert_built_in_routines is
  322.     -- Insert routines which are known to the compiler.
  323.  
  324.     l::=#BE_LEX(prog.options.home+"/System/MACROS");
  325.     loop 
  326.         ident1::=l.get_str;
  327.         ident2::=l.get_str;
  328.         ident3::=l.get_str;
  329.         if void(ident1) then break!;
  330.         elsif void(ident2) then barf("Malformed MACROS file");
  331.         elsif void(ident3) then barf("Malformed MACROS file");
  332.         else
  333.         pair:TUP{STR,STR};
  334.         if ident3="same" then pair:=#(ident2,ident2);
  335.         else pair:=#(ident2,ident3);
  336.         end;
  337.         built_in_routines:=built_in_routines.insert(ident1,pair);
  338.         -- if either starts with an identifier, forbid it
  339.         if pair.t1[0].is_alpha then
  340.             i:INT;
  341.             loop i:=1.upto!(pair.t1.length-1);
  342.             if ~pair.t1[i].is_alphanum then break!; end;
  343.             end;
  344.             forbid(pair.t1.substring(0,i-1));
  345.         end;
  346.         if pair.t2[0].is_alpha then
  347.             i:INT;
  348.             loop i:=1.upto!(pair.t2.length-1);
  349.             if ~pair.t2[i].is_alphanum then break!; end;
  350.             end;
  351.             forbid(pair.t2.substring(0,i-1));
  352.         end;
  353.         end;
  354.     end;
  355.     end;
  356.  
  357.     private insert_built_in_iters is
  358.     -- Insert iters which are known to the compiler.
  359.  
  360.     l::=#BE_LEX(prog.options.home+"/System/ITERS");
  361.     loop
  362.         name::=l.get_str;
  363.         s1::=l.get_str;
  364.         s2::=l.get_str;
  365.         s3::=l.get_str;
  366.         s4::=l.get_str;
  367.         if void(name) then break!;
  368.             elsif void(s1) or void(s2) or void(s3) or void(s4) then
  369.         barf("Malformed ITERS file");
  370.         else
  371.         it::=#ITER_INLINE(s1,s2,s3,s4);
  372.         built_in_iters:=built_in_iters.insert(name,it);
  373.         end;
  374.     end;
  375.     end;
  376.  
  377.     private insert_special_externs is
  378.     -- Insert routines known to the compiler to need special prototypes
  379.  
  380.         l::=#BE_LEX(prog.options.home+"/System/EXTERNS");
  381.     loop 
  382.         ident1:STR:=l.get_str;
  383.         ident2:STR:=l.get_str;
  384.         if void(ident1) then break!;
  385.         elsif void(ident2) then barf("Malformed EXTERNS file");
  386.         else special_externs:=special_externs.insert(ident1,ident2);
  387.         end;
  388.     end;
  389.     end;
  390.  
  391.     insert_built_in_classes is
  392.     -- add classes which shouldn't have layouts generated
  393.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.dollar_ob);
  394.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.bool);
  395.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.char);
  396.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.int);
  397.     --built_in_classes:=built_in_classes.insert(prog.tp_builtin.inti);
  398.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.flt);
  399.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.fltd);
  400.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.fltx);
  401.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.fltdx);
  402.     --built_in_classes:=built_in_classes.insert(prog.tp_builtin.flti);
  403.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.str);
  404.     --built_in_classes:=built_in_classes.insert(prog.tp_builtin.sys);
  405.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.ext_ob);
  406.     --built_in_classes:=built_in_classes.insert(prog.tp_builtin.tp);
  407.     built_in_classes:=built_in_classes.insert(prog.tp_builtin.dollar_rehash);
  408.     --built_in_classes:=built_in_classes.insert(prog.tp_builtin.rout);
  409.     --built_in_classes:=built_in_classes.insert(prog.tp_builtin.arr_of_str);
  410.  
  411.     -- make sure built-in classes mangle to the right thing.
  412.     force_mangle(prog.tp_builtin.bool,"BOOL");
  413.     force_mangle(prog.tp_builtin.char,"CHAR");
  414.     force_mangle(prog.tp_builtin.int,"INT");
  415.     force_mangle(prog.tp_builtin.flt,"FLT");
  416.     force_mangle(prog.tp_builtin.fltd,"FLTD");
  417.     force_mangle(prog.tp_builtin.fltx,"FLTX");
  418.     force_mangle(prog.tp_builtin.fltdx,"FLTDX");
  419.     force_mangle(prog.tp_builtin.str,"STR");
  420.     force_mangle(prog.tp_builtin.dollar_ob,"OB");
  421.     force_mangle(prog.tp_builtin.rout,"ROUT");
  422.     end;
  423.  
  424.     is_built_in_type(t:$TP):BOOL is 
  425.     return built_in_classes.test(t); 
  426.     end;
  427.  
  428.     private set_chks is
  429.     -- set checking states for this function
  430.  
  431.         n::=current_function.tp.str;
  432.     chk_pre:=prog.options.pre_chk(n);
  433.     chk_post:=prog.options.post_chk(n);
  434.     chk_invariant:=prog.options.invariant_chk(n);
  435.     chk_assert:=prog.options.assert_chk(n);
  436.     chk_arith:=prog.options.arith_chk(n);
  437.     chk_bounds:=prog.options.bounds_chk(n);
  438.     chk_void:=prog.options.void_chk(n);
  439.     chk_when:=prog.options.when_chk(n);
  440.     chk_return:=prog.options.return_chk(n);
  441.     chk_destroy:=prog.options.destroy_chk(n);
  442.     end;
  443.  
  444.     private inlined(s:SIG):BOOL is
  445.     inl::=prog.prog_am_generate.inline_tbl.get_query(s);
  446.     return ~void(inl);
  447.     end;
  448.  
  449.     output_am_rout_def(func:AM_ROUT_DEF) is
  450.     if prog.show_am then #OUT+"Generating C for "+func.sig.str+'\n'; end;
  451.     if func.sig=main_sig then force_mangle(func.sig,"sather_main");    end;
  452.  
  453.     if func.is_abstract then abstract_routs:=abstract_routs.push(func);
  454.     else
  455.         if inlined(func.sig) then
  456.         inlined_sigs:=inlined_sigs.insert(func.sig,func);
  457.         -- it's inline, so don't bother generating it now;
  458.         -- it will get generated if used in a dispatch table
  459.         else
  460.         start_mangling;
  461.         emit_routine(func);
  462.         end_mangling;
  463.         end;
  464.     end;
  465.     end;
  466.  
  467.     private setup_routine(func:AM_ROUT_DEF) is
  468.     current_function:=func.sig;
  469.     set_chks;
  470.     current_function_str:=func.sig.str;
  471.     if func.sig.is_iter then nested_its:=#FLIST{AM_ITER_CALL_EXPR}(5);
  472.         -- that 5 is important - it keeps it from being void()
  473.     else nested_its:=void;
  474.     end;
  475.     routine_code:=#FSTR;
  476.     end;
  477.  
  478.     private emit_routine(func:AM_ROUT_DEF) is
  479.     routine_count:=routine_count+1;
  480.     if routine_count>300 then
  481.         routine_count:=0;
  482.         new_c_file;
  483.     end;
  484.     setup_routine(func);
  485.     emit_prologue(func);
  486.     if is_asize(func.sig) then
  487.         if chk_void and ~prog.options.null_segfaults then
  488.         ndefer("if (self==NULL) {");
  489.         in; runtime_error("`asize' access of void",func); out;
  490.         ndefer("}");
  491.         end;
  492.         ndefer(" return self->asize;");
  493.     else emit_code(func.code);
  494.     end;
  495.     emit_epilogue(func);
  496.     emit_header(func);
  497.  
  498.     -- WARNING WILL ROBINSON
  499.     -- Attempt to make the AM form become garbage by lopping
  500.     -- off any pointers to code.
  501.     func.calls:=void;
  502.     func.locals:=void;
  503.     func.code:=void;
  504.     end;
  505.  
  506.     finalize is
  507.         -- finish up files, and call C compiler.
  508.  
  509.         define_main_and_globals;
  510.     generate_sys_tables;
  511.     generate_dispatch_tables;
  512.     generate_bnd_rout_stubs;
  513.     generate_bnd_rout_typedefs;
  514.  
  515.     if code_c.error 
  516.           or typedefs_h.error
  517.           or sather_h.error
  518.           or tags_h.error
  519.           or decs_h.error
  520.           or strings_h.error
  521.           or globals_h.error
  522.           or globals_c.error
  523.           or makefile.error then
  524.         barf("Some problem writing code files.");
  525.     end;
  526.  
  527.     code_c+'\n';
  528.     code_c.close;
  529.     sather_h.close;
  530.     tags_h.close;
  531.         typedefs_h.close;
  532.     decs_h.close;
  533.     strings_h+'\n';
  534.     strings_h.close;
  535.     globals_h.close;
  536.     globals_c.close;
  537.  
  538.     if prog.options.verbose then
  539.         #OUT + "\nMarked read attr routs:   "
  540.         +INLINE_ATTR_READ::routines;
  541.         #OUT + "\nInlined read attr calls:  "
  542.         +INLINE_ATTR_READ::inlined;
  543.         #OUT + "\nMarked write attr routs:  "
  544.         +INLINE_ATTR_WRITE::routines;
  545.         #OUT + "\nInlined write attr calls: "
  546.         +INLINE_ATTR_WRITE::inlined;
  547.         #OUT + "\nMarked global routs:      "
  548.         +INLINE_GLOBAL_READ::routines;
  549.         #OUT + "\nInlined global calls:     "
  550.         +INLINE_GLOBAL_READ::inlined;
  551.         #OUT + "\nMarked INT routs:         "
  552.         +INLINE_INT_FOLD::routines;
  553.         #OUT + "\nFolded INT calls:         "
  554.         +INLINE_INT_FOLD::inlined;
  555.         #OUT + "\nMarked iters:             "
  556.         +built_in_iters.size;
  557.         #OUT + "\nInlined iter calls:       "
  558.         +inlined_iter_count;
  559.     end;
  560.  
  561.     allflags::="";
  562.     loop allflags:=allflags+' '+prog.options.c_flags.elt!; end;
  563.     if prog.options.debug then
  564.         allflags:=allflags+' '+prog.options.c_debug;
  565.     end;
  566.     if prog.options.optimize then
  567.         allflags:=allflags+' '+prog.options.c_opt;
  568.     end;
  569.     if prog.options.verbose then
  570.         allflags:=allflags+' '+prog.options.c_verbose;
  571.     end;
  572.  
  573.      -- obfiles::=" globals.o";                                                 -- NLP
  574.         obfiles::=" globals.obj";                                               -- NLP
  575.     loop
  576.      --     fn::=" code"+0.for!(code_c_count)+".o";                             -- NLP
  577.             fn::=" code"+0.for!(code_c_count)+".obj";                           -- NLP
  578.         obfiles:=obfiles+fn;
  579.     end;
  580.  
  581.      -- syscom::="${CC} ";                                                      -- NLP
  582.      -- syscom:=syscom+prog.options.c_exec+"../${CS}";                          -- NLP
  583.         syscom::="$(CC) ";                                                      -- NLP
  584.         syscom:=syscom+prog.options.c_exec+"../$(CS)";                          -- NLP
  585.     syscom:=syscom+obfiles;
  586.         loop
  587.            s: STR := prog.options.c_files.elt!;
  588.       --   if s[0] = '/' then syscom:=syscom+' '+s;                             -- NLP
  589.            if s[0] = '/' or s[0] = '\\' then syscom:=syscom+' '+s;              -- NLP
  590.            else syscom:=syscom+' '+"../"+s;
  591.            end; -- if
  592.         end;
  593.         loop
  594.            s: STR := prog.options.object_files.elt!;
  595.       --   if s[0] = '/' then syscom:=syscom+' '+s;                             -- NLP
  596.            if s[0] = '/' or s[0] = '\\' then syscom:=syscom+' '+s;              -- NLP
  597.            else syscom:=syscom+' '+"../"+s;
  598.            end; -- if
  599.         end;
  600.         loop
  601.            s: STR := prog.options.archive_files.elt!;
  602.       --   if s[0] = '/' then syscom:=syscom+' '+s;                             -- NLP
  603.            if s[0] = '/' or s[0] = '\\' then syscom:=syscom+' '+s;              -- NLP
  604.            else syscom:=syscom+' '+"../"+s;
  605.            end; -- if
  606.         end;
  607.      -- syscom:=syscom+" ${CFLAGS}"+' '+prog.options.c_compile2;                -- NLP
  608.         syscom:=syscom+" $(CFLAGS)"+' ';                                        -- NLP
  609.         loop                                                                    -- NLP
  610.            c::= prog.options.c_compile2.elt!;                                   -- NLP
  611.            if c = '/' then syscom:=syscom+'\\';                                 -- NLP
  612.            else syscom:=syscom+c;                                               -- NLP
  613.            end;                                                                 -- NLP
  614.         end;                                                                    -- NLP
  615.  
  616.         makefile+"CFLAGS= "+allflags+'\n';
  617.         makefile+"CS= "+prog.options.executable+'\n';
  618.         makefile+"CC= "+prog.options.c_compile1+'\n';
  619.         makefile+"BuildProgram: ChangeDirectory CompileAll\n\n";                -- NLP
  620.         makefile+"ChangeDirectory:\n\tcd "+code_dir+"\n";                       -- NLP
  621.      -- makefile+"../${CS}:";                                                   -- NLP
  622.         makefile+"CompileAll:";                                                 -- NLP
  623.      -- makefile+obfiles+"\n\t"+syscom+'\n';                                    -- NLP
  624.         makefile+obfiles+"\n\t"+syscom+" > link.log\n";                         -- NLP
  625.  
  626.     makefile.close;
  627.  
  628.      -- syscom:="cd "+code_dir+"; "+prog.options.make_command;                  -- NLP
  629.         syscom:=prog.options.make_command+" -f "+code_dir+'\\'+"Makefile";      -- NLP
  630.         if ~prog.options.verbose then
  631.             syscom:=syscom+' '+prog.options.make_silent;
  632.         end;
  633.  
  634.     if prog.options.only_C then
  635.         if prog.options.verbose then #OUT + "\nSkipping make.\n"; end;
  636.     else
  637.             if prog.options.verbose then #OUT+'\n'+syscom+'\n'; end;
  638.             if UNIX::system(syscom)/=0 then barf("Make failed."); end;
  639.     end;
  640.  
  641.         if ~prog.options.gen_c then
  642.         -- This is a quick hack which should be replaced!
  643.      --     dummy::=UNIX::system("rm -fr "+code_dir);                            -- NLP
  644.             dummy::=UNIX::system("@if exist "+code_dir+"\\*.c   del "+           -- NLP
  645.                                              code_dir+"\\*.c");                  -- NLP
  646.             dummy:= UNIX::system("@if exist "+code_dir+"\\*.obj del "+           -- NLP
  647.                                              code_dir+"\\*.obj");                -- NLP
  648.             dummy:= UNIX::system("@if exist "+code_dir+"\\*.h   del "+           -- NLP
  649.                                              code_dir+"\\*.h");                  -- NLP
  650.             dummy:= UNIX::system("@if exist "+code_dir+"\\Makefile del "+        -- NLP
  651.                                              code_dir+"\\Makefile");             -- NLP
  652.             dummy:= UNIX::system("@if exist "+code_dir+"\\link.log del "+        -- NLP
  653.                                              code_dir+"\\link.log");             -- NLP
  654.             dummy:=UNIX::system("@if not exist "+code_dir+"\\* rmdir "+code_dir);-- NLP
  655.         end;
  656.     end;
  657.  
  658.     cast(dest_tp,src_tp:$TP,expr:STR):STR 
  659.         pre dest_tp=src_tp -- make sure cast isn't nonsense
  660.                 or (dest_tp.is_abstract and src_tp.is_abstract)
  661.                 or dest_tp.is_subtype(src_tp)
  662.                 or src_tp.is_subtype(dest_tp)
  663.         is
  664.     -- possibly convert an expression to another type to sooth C's
  665.     -- savage type beast when up- or down-typing.
  666.  
  667.     res:STR;
  668.         if dest_tp.is_abstract and src_tp.is_value then -- boxing
  669.         res:=dec_local_comment(dest_tp,"local for boxed "+src_tp.str);
  670.         ndefer(res+" = ("+mangle(dest_tp)+")"+allocate(src_tp)+";");
  671.         ndefer("(("+mangle(src_tp)+"_boxed) "
  672.                        +res+")->value_part = "+expr+";");
  673.         elsif dest_tp.is_value and src_tp.is_abstract then -- unboxing
  674.         res:=dec_local_comment(dest_tp,"local for unboxed "+src_tp.str);
  675.         ndefer(res+" = (("+mangle(dest_tp)+"_boxed) "
  676.                       +expr+")->value_part;");
  677.     elsif dest_tp/=src_tp then res:="(("+mangle(dest_tp)+") "+expr+")";
  678.     else res:=expr;
  679.     end;
  680.         return res;
  681.     end;
  682.  
  683.     sizeof(tp:$TP):STR is
  684.     -- an expression for the storage size of a given type.
  685.         if tp.is_value then return "sizeof("+mangle(tp)+")";
  686. --      else return "sizeof(struct "+mangle(tp)+"_struct)";                     -- NLP
  687.         end; return "sizeof(struct "+mangle(tp)+"_struct)";                     -- NLP
  688. --      end;                                                                    -- NLP
  689.     end;
  690.  
  691.     sizeof_boxed(tp:$TP):STR pre tp.is_value is
  692.     -- an expression for the size of a boxed value type
  693.     return "sizeof(struct "+mangle(tp)+"_boxed_struct)";
  694.     end;
  695.  
  696.     allocate(t:$TP):STR is
  697.     -- generate call which allocates memory and fills in tag for an
  698.     -- object of type t.  This properly sets the tag field too.
  699.     -- If t is a value type it allocates the boxed version.
  700.         call_string:STR;
  701.         if t.is_atomic then
  702.             call_string := "sbi_alloc_atomic(";
  703.         else
  704.             call_string := "sbi_alloc(";
  705.         end;
  706.  
  707.         if t.is_value then
  708.             return "(("+mangle(t)+"_boxed) "+call_string+sizeof_boxed(t)
  709.                                         +", "+tag_for(t)+"))";
  710. --      else                                                                    -- NLP
  711.         end;                                                                    -- NLP
  712.             return "(("+mangle(t)+") "+call_string+sizeof(t)
  713.                                         +", "+tag_for(t)+"))";
  714. --      end;                                                                    -- NLP
  715.     end;
  716.  
  717.     array_allocate(t:$TP,n:STR):STR is
  718.     -- generate call which allocates memory and fills in tag for
  719.     -- an object of type t and an array portion with n elements.
  720.     -- This sets the tag field but NOT asize, because it isn't
  721.     -- reachable from an untyped C routine.
  722.     -- If t is a value type it allocates the boxed version.
  723.  
  724.         res,call_string:STR;
  725.         t2:$TP:=prog.am_ob_def_for_tp(t).arr;
  726.         if t.is_atomic then
  727.             call_string := "sbi_arr_alloc_atomic(";
  728.         else
  729.             call_string := "sbi_arr_alloc(";
  730.         end;
  731.         if t.is_value then
  732.             res:="(("+mangle(t)+"_boxed) "+call_string+sizeof_boxed(t);
  733.         else res:="(("+mangle(t)+") "+call_string+sizeof(t);
  734.         end;
  735.         res:=res+", "+tag_for(t)+", ";
  736.  
  737.     -- Use mangle(t2) for the array portion, because we want the
  738.     -- same sizeof(x) expression whether or not it is a value type
  739.     return res+"sizeof("+mangle(t2)+") , "+n+"))";
  740.     end;
  741.  
  742.     default_init(t:$TP):STR is
  743.     -- string representing default initialization expression
  744.     -- for a given type.
  745.  
  746.     if t.is_value then
  747.         if is_built_in_type(t) then return "(("+mangle(t)+") "+"0)";
  748.         else return mangle(t)+"_zero";
  749.             end;
  750. --      else return "(("+mangle(t)+") "+"NULL)";                                -- NLP
  751.         end; return "(("+mangle(t)+") "+"NULL)";                                -- NLP
  752. --      end;                                                                    -- NLP
  753.     end;
  754.  
  755.     is_const_expr(e:$AM_EXPR):BOOL is
  756.     -- is this something we can make a C initializing constant for?
  757.     if void(e) then return false; end;
  758.     typecase e
  759.         when AM_VOID_CONST then return true;
  760.             when AM_BOOL_CONST then return true;
  761.         when AM_CHAR_CONST then return true;
  762.         when AM_STR_CONST then return true;
  763.         when AM_INT_CONST then return true;
  764. --          else return false;                                                  -- NLP
  765.             else; end; return false;                                            -- NLP
  766. --      end;                                                                    -- NLP
  767.     end;
  768.  
  769.     define_main_and_globals is
  770.     -- generate actual main call, which then calls sather_main.
  771.     -- has to initialize any globals and declare them.
  772.  
  773.     main_tp::=mangle(main_sig.tp);
  774.  
  775.         code_c+'\n';
  776.         comment(code_c,"Definition of main (generated)");
  777.     code_c+"\nint main(int argc, char *argv[]) {";
  778.  
  779.     routine_code:=#FSTR+"\n"; 
  780.         in;
  781.     ndefer(main_tp+" main_ob;");
  782.  
  783.     if ~void(main_sig.args) then
  784.         ndefer(mangle(prog.tp_builtin.arr_of_str)+" main_args;");
  785.         ndefer("int i,j,length;");
  786.         ndefer("STR s;");
  787.     end;
  788.  
  789.     -- emit globals and any initializing expressions needed
  790.     emit_globals;
  791.  
  792.     -- default object for main
  793.     ndefer("main_ob = ");
  794.     if main_sig.tp.is_value then defer(main_tp+"_zero;");
  795.     else defer(allocate(main_sig.tp)+";");
  796.     end;
  797.  
  798.     -- arguments, if needed
  799.         if ~void(main_sig.args) then
  800.         ndefer("main_args = "
  801.              +array_allocate(prog.tp_builtin.arr_of_str,"argc")+";");
  802.         ndefer("main_args->asize = argc;");
  803.         ndefer("for (i=0;i<argc;i++) {");
  804.         ndefer(" for (length=0; argv[i][length]!=0; length++);");
  805.         ndefer(" s = "+array_allocate(prog.tp_builtin.str,"length")+";");
  806.         ndefer(" s->asize = length;");
  807.         ndefer(" for (j=0;j<length;j++) s->arr_part[j] = argv[i][j];");
  808.         ndefer(" main_args->arr_part[i] = s;");
  809.         ndefer("}");
  810.     end;
  811.  
  812.     if prog.options.null_segfaults then
  813.         ndefer("signal(SIGSEGV,(void(*)())sbi_segfault_handler);");
  814.     end;
  815.  
  816.     ndefer("if (setjmp(last_protect) == 0) {");
  817.         in;
  818.     if ~void(main_sig.ret) then
  819.         if ~void(main_sig.args) then
  820.         ndefer("return sather_main(main_ob,main_args);");
  821.         else ndefer("return sather_main(main_ob);");
  822.         end;
  823.     else
  824.         if ~void(main_sig.args) then
  825.              ndefer("sather_main(main_ob,main_args); return 0;");
  826.         else ndefer("sather_main(main_ob); return 0;");
  827.         end;
  828.     end;
  829.     out;
  830.     ndefer("} else {");
  831.         in;
  832.     ndefer("if (exception->header.tag=="+tag_for(prog.tp_builtin.str)
  833.          +") fprintf(stderr,\"Uncaught STR exception: %s\\n\","
  834.          +"((STR)exception)->arr_part);");
  835.     ndefer("else fprintf(stderr,\"Uncaught exception\\n\");");
  836.      -- ndefer("abort();");                                                     -- NLP
  837.         ndefer("exit(16);");                                                    -- NLP
  838.     out;
  839.     ndefer("}");
  840.     out;
  841.     code_c+routine_code+"\n}\n\n";
  842.     end;
  843.  
  844.     private emit_globals is
  845.     -- emit declarations for globals and any code in main
  846.     -- that has to execute to initialize to them before other code
  847.  
  848.     loop
  849.         age::=prog.global_tbl.top_sort.elt!;
  850.         if is_const_expr(age.init) then
  851.         globals_c+'\n';
  852.         if age.is_const then globals_h+"const "; end;
  853.         e:STR:=emit_expr(age.init);
  854.         if age.is_const then globals_c+"const "; end;
  855.         globals_c+mangle(age.tp)+' '+mangle(age)+" = "+e+';';
  856.         comment(globals_c,"Const "+mangle(age.class_tp)
  857.                     +"::"+age.name.str);
  858.         else
  859.         if ~void(age.init) or 
  860.            (age.tp.is_value and ~is_built_in_type(age.tp)) then
  861.             -- will be initialized in main
  862.             globals_c+'\n'+mangle(age.tp)+' '+mangle(age)+';';
  863.             comment(globals_c,"Shared "+mangle(age.class_tp)
  864.                  +"::"+age.name.str);
  865.             comment("Initialize shared "+mangle(age.class_tp)
  866.                         +"::"+age.name.str);
  867.             if ~void(age.init) then
  868.             ndefer(mangle(age)+" = "+emit_expr(age.init)+';');
  869.             else 
  870.             ndefer(mangle(age)+" = "+default_init(age.tp)+';');
  871.             end;
  872.         else
  873.             globals_c+'\n'+mangle(age.tp)+' '+mangle(age)
  874.                  +" = "+default_init(age.tp)+';';
  875.             comment(globals_c,"Shared "+mangle(age.class_tp)
  876.                  +"::"+age.name.str);
  877.         end;
  878.         end;
  879.         comment(globals_h,"Const "+mangle(age.class_tp)
  880.                 +"::"+age.name.str);
  881.         globals_h+"extern ";
  882.         globals_h+mangle(age.tp)+' '+mangle(age)+";\n";
  883.     end;
  884.     end;
  885.  
  886.     generate_sys_tables is
  887.     -- make routines/tables needed by the SYS class
  888.     -- also, make const declarations for all the tags encountered
  889.  
  890.         code_c+"\nSTR c_SYS_str_for_tp_INT_STR(SYS p,INT i) {\n";
  891.     code_c+" switch (i) {\n";
  892.     loop
  893.             p::=tags.pairs!;
  894.         tags_h+"#define "+mangle(p.t1)+"_tag "+p.t2+"\n";
  895.         dummy::=#AM_STR_CONST;
  896.             dummy.bval:=p.t1.str;
  897.         code_c+"  case "+mangle(p.t1)+"_tag: return "
  898.                          +emit_str_const(dummy)+";\n";
  899.     end;
  900.      -- code_c+"  default: fprintf(stderr,\"Internal error: unknown tag?\\n\"); abort();\n";  -- NLP
  901.         code_c+"  default: fprintf(stderr,\"Internal error: unknown tag?\\n\"); exit(16);\n"; -- NLP
  902.     code_c+" }\n";
  903.     code_c+"}\n\n";
  904.  
  905.         code_c+"\nBOOL c_SYS_ob_eq_OB_OB_BOOL(OB o1,OB o2) {\n";
  906.         code_c+" INT t1,t2;\n";
  907.         code_c+" if (o1==o2) return TRUE;\n";
  908.         code_c+" if (o1==NULL || o2==NULL) return FALSE;\n";
  909.     code_c+" t1 = o1->header.tag; t2 = o2->header.tag;\n";
  910.         code_c+" if (t1!=t2) return FALSE;\n";
  911.         code_c+" switch (t1) {\n";
  912.         loop 
  913.             tp::=tags.keys!;
  914.             tpstr::=mangle(tp);
  915.             if tp.is_value then
  916.                 code_c+"  case "+tpstr+"_tag:\n";
  917.                 in;
  918.        --       code_c+"    {"+tpstr+" v1 = (("+tpstr+"_boxed)o1)->value_part;\n"; -- NLP
  919.        --       code_c+"     "+tpstr+" v2 = (("+tpstr+"_boxed)o2)->value_part;\n"; -- NLP
  920.                 code_c+"    {"+tpstr+" v1,v2;\n";                               -- NLP
  921.                 code_c+"     v1 = (("+tpstr+"_boxed)o1)->value_part;\n";        -- NLP
  922.                 code_c+"     v2 = (("+tpstr+"_boxed)o2)->value_part;\n";        -- NLP
  923.                 code_c+"     return "+value_compare(tp,"v1","v2")+";}\n";
  924.                 out;
  925.             end;
  926.         end;
  927.         code_c+"  default: return FALSE;";
  928.     comment(code_c,"Not a value type");
  929.         code_c+"\n   }\n";
  930.         code_c+"}\n\n";
  931.     end;
  932.  
  933.     generate_layouts is
  934.     -- emit typedef/struct for all concrete classes
  935.  
  936.     -- first, put classes on a "to do" list.  This will be passed over
  937.     -- repeatedly, only emitting layouts which have value typed fields
  938.     -- which have already been emitted - C requires this @*&#$*&^! 
  939.     todo::=#FLIST{TP_CLASS};
  940.     done::=#FSET{$TP};
  941.     loop todo:=todo.push(prog.tp_tbl.class_tbl.elt!); end;
  942.  
  943.         loop until!(todo.is_empty);
  944.         next_todo::=#FLIST{TP_CLASS};
  945.         loop
  946.         tp:TP_CLASS:=todo.elt!;
  947.         if tp.kind=TP_KIND::ext_tp or is_built_in_type(tp) then
  948.             -- do nothing for external or built-in classes
  949.             done:=done.insert(tp);
  950.         elsif tp.is_abstract then
  951.             -- abstract "layouts" are really just the leading header
  952.             typedefs_h+"typedef struct "+mangle(tp)+"_struct {\n";
  953.             forbid(mangle(tp)+"_struct");
  954.             typedefs_h+" OB_HEADER header;\n";
  955.             typedefs_h+" } *"+mangle(tp)+";\n\n";
  956.             done:=done.insert(tp);
  957.         elsif tp.is_bound then barf("bound types not implemented yet");
  958.         else 
  959.                     -- a reference or value type
  960.             -- Is okay to make layout? if not, put on next_todo
  961.             -- list instead of dealing with it now.
  962.  
  963.                     okay:BOOL:=true;
  964.             l:AM_OB_DEF:=prog.am_ob_def_for_tp(tp);
  965.                     if ~void(l.at) then
  966.             loop ci::=l.at.targets!;
  967.                 -- changed following line from ...class(tp)
  968.                 if ci.is_value and ~is_built_in_type(ci) 
  969.                 and ~done.test(ci) then okay:=false;
  970.                 --#OUT + tp.str+" needs "+ci.str+'\n';
  971.                 end;
  972.             end;
  973.             end;
  974.             -- added is_built_in test on following line
  975.             if ~void(l.arr) and l.arr.is_value 
  976.                   and ~is_built_in_type(l.arr)
  977.                               and ~done.test(l.arr) then okay:=false; 
  978.                   -- #OUT + tp.str+" needs "+l.arr.str+'\n';
  979.                   end;
  980.             if ~okay then next_todo:=next_todo.push(tp);
  981.             else
  982.             done:=done.insert(tp);
  983.  
  984.             cname:STR:=mangle(l.tp);
  985.             typedefs_h+"typedef struct "+cname+"_struct {";
  986.             comment(typedefs_h,"layout for "+l.tp.str);
  987.             typedefs_h+'\n';
  988.             forbid(mangle(tp)+"_struct");
  989.             if ~tp.is_value then 
  990.                             typedefs_h+" OB_HEADER header;\n";
  991.                         end;
  992.             if ~void(l.at) then
  993.                 loop p::=l.at.pairs!;
  994.                 if is_built_in_type(p.t2) then
  995.                     typedefs_h+' '+mangle(p.t2)
  996.                        +' '+mangle(p.t1)+";\n";
  997.                 elsif ~p.t2.is_value then
  998.                     typedefs_h+" struct "+mangle(p.t2)
  999.                        +"_struct *"+mangle(p.t1)+";\n";
  1000.                 else -- user-defined value class
  1001.                     typedefs_h+" struct "+mangle(p.t2)
  1002.                        +"_struct "+mangle(p.t1)+";\n";
  1003.                 end;
  1004.                 end;
  1005.             end;
  1006.             if ~void(l.arr) then
  1007.                 if ~tp.is_value then typedefs_h+" INT asize;\n"; end;
  1008.                 if is_built_in_type(l.arr) then
  1009.                 typedefs_h+' '+mangle(l.arr)+" arr_part[";
  1010.                 elsif ~l.arr.is_value then
  1011.                 typedefs_h+" struct "+mangle(l.arr)
  1012.                                +"_struct *arr_part[";
  1013.                 else -- user-defined value class
  1014.                 typedefs_h+" struct "+mangle(l.arr)
  1015.                            +"_struct arr_part[";
  1016.                 end;
  1017.                             typedefs_h+1.max(l.asize)+"];\n";
  1018.             end;
  1019.             if tp.is_value then
  1020.                 typedefs_h+" } "+cname+';'+'\n';
  1021.                             typedefs_h+"static "+cname+" "+cname+"_blob;\n";    -- NLP
  1022.                 typedefs_h+"static "+cname+" "+cname+"_zero;";
  1023.                 comment(typedefs_h,"automatically initialized");
  1024.                 typedefs_h+'\n'+'\n';
  1025.                             forbid(cname+"_blob");                              -- NLP
  1026.                 forbid(cname+"_zero");
  1027.                 typedefs_h+"typedef struct "+cname+"_boxed_struct {\n";
  1028.                 typedefs_h+" OB_HEADER header;\n";
  1029.                 typedefs_h+' '+cname+" value_part;\n";
  1030.                 typedefs_h+" } *"+cname+"_boxed;\n\n";
  1031.                 forbid(cname+"_boxed");
  1032.                 forbid(cname+"_boxed_struct");
  1033.             else
  1034.                 typedefs_h+" } *"+cname+";\n\n";
  1035.             end;
  1036.             end;
  1037.         end;
  1038.         end;
  1039.         assert next_todo.size<todo.size;
  1040.         todo:=next_todo;
  1041.     end; -- loop
  1042.  
  1043.     end;
  1044.  
  1045.     private generate_bnd_rout_typedefs is
  1046.     -- generate defs for bound routine objects.
  1047.  
  1048.     loop
  1049.         e::=prog.tp_tbl.rout_tbl.elt!;
  1050.         name::=mangle(e);
  1051.         forbid(name+"_struct");
  1052.         if ~is_built_in_type(e) then
  1053.         typedefs_h+"typedef struct "+name+"_struct {\n";
  1054.         typedefs_h+" OB_HEADER header;\n";
  1055.         if ~void(e.ret) then typedefs_h+' '+mangle(e.ret);
  1056.         else typedefs_h+" void";
  1057.         end;
  1058.         typedefs_h+" (*funcptr)(void *";
  1059.         loop
  1060.             a::=e.args.elt!;
  1061.             typedefs_h+", "+mangle(a);
  1062.         end;
  1063.         typedefs_h+");\n} *"+name+";\n\n";
  1064.         end;
  1065.     end;
  1066.     end;
  1067.  
  1068.     emit_typedef_for_iter(f:AM_ROUT_DEF) is
  1069.     typedefs_h+"\ntypedef struct "+mangle(f.sig)+"_frame_struct {\n";
  1070.     forbid(mangle(f.sig)+"_frame_struct");
  1071.     -- make slot for each argument
  1072.     loop
  1073.         fi::=f.elt!;
  1074.         typedefs_h+' '+mangle(fi.tp)+' '+"arg"+0.up!+';';
  1075.         comment(typedefs_h,"Formal argument: "+fi.name.str);
  1076.         typedefs_h+'\n';
  1077.     end;
  1078.     -- make slot for each local
  1079.     if ~void(f.locals) then
  1080.         loop
  1081.         fli::=f.locals.elt!;    
  1082.         name::=mangle(fli);
  1083.         name:=name.tail(name.length-7);
  1084.         typedefs_h+' '+mangle(fli.tp)+' '+name+';';
  1085.         comment(typedefs_h,"local");
  1086.         typedefs_h+'\n';
  1087.         end;
  1088.     end;
  1089.     -- slot for any nested iter frames
  1090.     loop 
  1091.         ni::=nested_its.elt!;
  1092.         typedefs_h+" struct "+mangle(ni.fun)+"_frame_struct *";
  1093.         name:STR:=mangle(ni);
  1094.         name:=name.tail(name.length-7);
  1095.         typedefs_h+name+"; /* nested iter frame */\n";
  1096.     end;
  1097.     -- finally, a slot for the state number
  1098.     typedefs_h+" INT state;\n";
  1099.     typedefs_h+" } *"+mangle(f.sig)+"_frame;\n\n";
  1100.     forbid(mangle(f.sig)+"_frame");
  1101.     end;
  1102.  
  1103.     emit_header(f:AM_ROUT_DEF) is
  1104.         -- emit ANSI header, and also struct to hold locals if an iter
  1105.  
  1106.         sig:SIG:=f.sig;
  1107.  
  1108.         -- if an iter, do typedef with same name for holding the frame
  1109.     if f.is_iter then emit_typedef_for_iter(f); end;
  1110.  
  1111.         if ~void(sig.ret) then decs_h+mangle(sig.ret)+' ';
  1112.         else decs_h+"void ";
  1113.     end;
  1114.         decs_h+mangle(f.sig)+'(';
  1115.  
  1116.     -- if an iter, just a pointer for frame struct
  1117.     -- otherwise, pass arguments the usual way
  1118.     if f.is_iter then decs_h+mangle(f.sig)+"_frame";
  1119.     elsif f.is_abstract then
  1120.         decs_h+mangle(f.sig.tp);
  1121.         if ~void(f.sig.args) then
  1122.                 loop decs_h+", "+mangle(f.sig.args.elt!); end;
  1123.         end;
  1124.     elsif f.is_external then
  1125.             -- an external routine with a body still doesn't have a self
  1126.         flag::=false;
  1127.         loop
  1128.         s::=mangle(f.elt!.tp);
  1129.         if flag then decs_h+", ".separate!(s); end;
  1130.         flag:=true;
  1131.         end;
  1132.     else
  1133.         loop decs_h+", ".separate!(mangle(f.elt!.tp)); end;
  1134.     end;
  1135.         decs_h+");\n";
  1136.     end;
  1137.  
  1138.     emit_prologue(f:AM_ROUT_DEF) pre ~void(f.sig) is
  1139.  
  1140.         saw_outer_return:=false;
  1141.         sig:SIG:=f.sig;
  1142.     newline; newline;
  1143.     comment(code_c,"Definition of "+sig.str);
  1144.     code_c+'\n';
  1145.  
  1146.         if ~void(sig.ret) then code_c+mangle(sig.ret)+' ';
  1147.         else code_c+"void ";
  1148.     end;
  1149.         if f.is_external then
  1150.         force_mangle(sig,f.sig.tp.str+'_'+f.sig.name.str);
  1151.     end;
  1152.         code_c+mangle(sig)+'(';
  1153.  
  1154.     -- if an iter, pointer for frame, otherwise regular args
  1155.     if f.is_iter then
  1156.         -- just a single frame argument
  1157.         code_c+mangle(f.sig)+"_frame frame";
  1158.         -- other locals now prepend "frame->"
  1159.             if ~void(f.locals) then
  1160.                 loop
  1161.                     lv:AM_LOCAL_EXPR:=f.locals.elt!;
  1162.                 was:STR:=mangle(lv);
  1163.                 remangle(lv,"frame->"+was);
  1164.         end;
  1165.         end;
  1166.             -- also, arguments are on frame
  1167.             loop 
  1168.                 lv:AM_LOCAL_EXPR:=f.elt!;
  1169.                 remangle(lv,"frame->arg"+0.up!);
  1170.         end;
  1171.     else
  1172.         -- if not an iter, declare arguments
  1173.         if f.is_abstract then
  1174.         -- in abstract routine, arg names are canonical
  1175.         code_c+mangle(f.sig.tp)+" arg0";
  1176.         if ~void(f.sig.args) then
  1177.             loop 
  1178.                         e::=f.sig.args.elt!;
  1179.                         code_c+", "+mangle(e)+" arg"+1.up!;
  1180.                     end;
  1181.         end;
  1182.         elsif f.is_external then
  1183.         flag::=false;
  1184.         loop 
  1185.                     e::=f.elt!;
  1186.                     assert ~void(e) and ~void(e.tp);
  1187.             if flag then
  1188.             code_c+", ".separate!(mangle(e.tp)+' '+mangle(e));
  1189.             end;
  1190.             flag:=true;
  1191.         end;
  1192.         else
  1193.         loop 
  1194.                     e::=f.elt!;
  1195.                     assert ~void(e) and ~void(e.tp);
  1196.             code_c+", ".separate!(mangle(e.tp)+' '+mangle(e));
  1197.         end;
  1198.         end;
  1199.     end;
  1200.     
  1201.     current_self:=mangle(f[0]);
  1202.         code_c+") {";
  1203.         in;
  1204.  
  1205.     -- now emit local declarations (if an iter, they are on the
  1206.     -- frame and don't need to be declared).
  1207.     if ~f.is_iter and ~void(f.locals) then
  1208.         loop 
  1209.         lv:AM_LOCAL_EXPR:=f.locals.elt!;
  1210.                 assert ~void(lv) and ~void(lv.tp);
  1211.         newline;
  1212.         if lv.is_volatile then code_c+"volatile "; end;
  1213.         if lv.needs_init or lv.tp.is_value then
  1214.             def:STR:=default_init(lv.tp);
  1215.             code_c+mangle(lv.tp)+' '+mangle(lv)+" = "+def+';';
  1216.         else
  1217.             code_c+mangle(lv.tp)+' '+mangle(lv)+';';
  1218.         end;
  1219.         end;
  1220.     end;
  1221.  
  1222.     -- if an iter, maybe return a dummy value when quit, so declare
  1223.         -- one.  Also generate switch statement.  The first state
  1224.     -- initializes any locals to the iter that need it.  (It shouldn't
  1225.     -- be possible to get there more than once in an invocation.)
  1226.     if f.is_iter then
  1227.         if ~void(sig.ret) then
  1228.         newline;
  1229.         code_c+mangle(sig.ret)+' '+"dummy;";
  1230.         end;
  1231.         ndefer("switch (frame->state) {");
  1232.         in;
  1233.  
  1234.             loop 
  1235.                 i::=0.upto!(f.num_yields);
  1236.         ndefer("case "+i+": goto state"+i+';');
  1237.             end;
  1238.         ndefer("}");
  1239.         out;
  1240.         ndefer("state0:;");
  1241.         state_counter:=1;
  1242.  
  1243.         -- initialize any locals that need it
  1244.         if ~void(f.locals) then
  1245.         loop i::=f.locals.elt!;
  1246.             if i.needs_init then
  1247.             ndefer(mangle(i)+" = "+default_init(i.tp)+";");
  1248.             end;
  1249.         end;
  1250.         end;
  1251.     end;
  1252.     end;
  1253.  
  1254.     emit_epilogue(f:AM_ROUT_DEF) is
  1255.  
  1256.         if chk_return and ~saw_outer_return
  1257.               and ~f.is_iter and
  1258.               ~void(f.sig.ret) then
  1259.             -- if it has a return value, it is necessary to
  1260.             -- make sure doesn't exit without a return
  1261.             runtime_error("Last statement wasn't return",f);
  1262.         end;
  1263.  
  1264.     code_c+routine_code; -- output all the code
  1265.  
  1266.     if f.is_iter then  -- add an explicit 'quit'
  1267.         newline; code_c+"frame->state = -1;"; 
  1268.         if ~void(f.sig.ret) then newline; code_c+"return dummy;";
  1269.         else newline; code_c+"return;";
  1270.         end;
  1271.     end;
  1272.  
  1273.         out; newline; code_c+"}";
  1274.  
  1275.         -- restore names of local variables and arguments
  1276.         if ~void(f.locals) and ~f.is_iter then
  1277.             loop unmangle(f.locals.elt!); end;
  1278.         end;
  1279.         loop unmangle(f.elt!); end;
  1280.     end;
  1281.  
  1282.     private generate_bnd_rout_stubs is
  1283.     -- Generate typedefs for bound routine objects and
  1284.     -- make stub functions to execute them
  1285.     loop
  1286.         e::=bnd_rout_creates.elt!;
  1287.         name::=mangle(e);
  1288.         forbid(name+"_ob");
  1289.         forbid(name+"_ob_struct");
  1290.         typedefs_h+"typedef struct "+name+"_ob_struct {\n";
  1291.         typedefs_h+" OB_HEADER header;\n";
  1292.         if ~void(e.fun.ret) then code_c+mangle(e.fun.ret)+' ';
  1293.         else code_c+"void ";
  1294.         end;
  1295.         code_c+name+'('+name+"_ob ob";
  1296.         if ~void(e.fun.ret) then decs_h+mangle(e.fun.ret)+' ';
  1297.         else decs_h+"void ";
  1298.         end;
  1299.         decs_h+name+'('+name+"_ob";
  1300.         if ~void(e.fun.ret) then typedefs_h+' '+mangle(e.fun.ret)+' ';
  1301.         else typedefs_h+" void ";
  1302.         end;
  1303.         typedefs_h+"(*funcptr)(struct "+name+"_ob_struct *";
  1304.         loop
  1305.         i::=e.unbnd_args.elt!;
  1306.         dec:STR;
  1307.                 if i=0 then dec:=mangle(e.fun.tp);
  1308.         else dec:=mangle(e.fun.args[i-1]);
  1309.         end;
  1310.         code_c+", "+dec+" unbound_arg"+0.up!;
  1311.         decs_h+", "+dec;
  1312.         typedefs_h+", "+dec;
  1313.         end;
  1314.         decs_h+");\n";
  1315.         code_c+") {\n";
  1316.         typedefs_h+");\n";
  1317.         loop
  1318.         i::=e.ind!;
  1319.         if e.bnd_args[i]=0 then
  1320.             typedefs_h+' '+mangle(e.fun.tp);
  1321.         else
  1322.             typedefs_h+' '+mangle(e.fun.args[i-1]);
  1323.         end;
  1324.         typedefs_h+" bound_arg"+i+";\n";
  1325.         end;
  1326.         typedefs_h+" } *"+name+"_ob;\n\n";
  1327.         arg_list::=#ARRAY{STR}(e.fun.args.size+1);
  1328.         -- Make a dummy routine call and generate it
  1329.         bnd::=0;        -- The index of the next bound argument
  1330.         unbnd::=0;        -- The index of the next unbound argument
  1331.         is_bnd:BOOL;    -- So, is the next arg bound or unbound?
  1332.         loop
  1333.         i::=arg_list.ind!;     -- The index we're on.
  1334.         if bnd<e.bnd_args.size then
  1335.             if e.bnd_args[bnd]=i then is_bnd:=true;
  1336.             elsif e.unbnd_args[unbnd]=i then is_bnd:=false;
  1337.             else barf("Ran off unbound arg list");
  1338.             end;
  1339.         elsif e.unbnd_args[unbnd]=i then is_bnd:=false;
  1340.         else barf("Ran off unbound arg list 2nd");
  1341.         end;
  1342.         if is_bnd then
  1343.             arg_list[i]:="ob->bound_arg"+bnd;
  1344.             bnd:=bnd+1;
  1345.         else
  1346.             arg_list[i]:="unbound_arg"+unbnd;
  1347.             unbnd:=unbnd+1;
  1348.         end;
  1349.         end;
  1350.         if ~void(e.fun.ret) then code_c+" return"; end;
  1351.         code_c+' '+emit_call(e.fun,arg_list)+";\n}\n\n";
  1352.     end;
  1353.     end;
  1354.  
  1355.     private generate_dispatch_tables is
  1356.     loop emit_dispatch_table(abstract_routs.elt!); end;
  1357.     end;
  1358.  
  1359.     private emit_dispatch_wrapper(s:SIG):STR is
  1360.     -- emit a wrapper function for unboxing value types
  1361.     -- when dispatched.  Return the function name generated.
  1362.  
  1363.     -- until mangling is really correct, use func_unbox as name
  1364.     res::=mangle(s)+"_unbox";
  1365.     code_c+'\n';
  1366.     comment(code_c,"Wrapper to unbox "+s.str);
  1367.     code_c+'\n';
  1368.     if void(s.ret) then code_c+"void "; decs_h+"void ";
  1369.         else code_c+mangle(s.ret)+' '; decs_h+mangle(s.ret)+' ';
  1370.     end;
  1371.     code_c+res+"("+mangle(s.tp)+"_boxed arg0";
  1372.     decs_h+res+"("+mangle(s.tp)+"_boxed";
  1373.         loop
  1374.             e::=s.args.elt!;
  1375.         code_c+", "+mangle(e)+" arg"+1.up!;
  1376.         decs_h+", "+mangle(e);
  1377.     end;
  1378.     code_c+") {\n";
  1379.     decs_h+");\n";
  1380.     code_c+' ';
  1381.     if ~void(s.ret) then code_c+"return "; end;
  1382.     code_c+mangle(s)+"(arg0->value_part";
  1383.     loop i::=1.upto!(s.num_args);
  1384.         code_c+", arg"+i;
  1385.     end;
  1386.     code_c+");\n"+"}\n";
  1387.         return res;
  1388.     end;
  1389.  
  1390.     private emit_dispatch_table(f:AM_ROUT_DEF) is
  1391.     -- emit function pointer table for dispatched routines and iters.
  1392.  
  1393.     -- first, collect descendents' info.  We want to make the smallest
  1394.     -- table possible, so find the min and max tags needed.
  1395.  
  1396.         des::=#FLIST{$TP};
  1397.     mintag::=INT::maxint;
  1398.     maxtag::=INT::minint;
  1399.     cst:STR; -- Cast to correct function pointer type
  1400.         decl:STR;                                                               -- NLP
  1401.  
  1402.     gh:FSET{$TP};
  1403.     fst::=f.sig.tp;
  1404.     typecase fst
  1405.         when TP_CLASS then gh:=prog.descendants_of_abs(fst); 
  1406.     end;
  1407.     loop t::=gh.elt!;
  1408.             des:=des.push(t);
  1409.             tag:INT:=num_tag_for(t);
  1410.         maxtag:=maxtag.max(tag);
  1411.         mintag:=mintag.min(tag);
  1412.     end;
  1413.  
  1414.         comment(globals_c,"Dispatch table for "+mangle(f.sig));
  1415.     globals_h+"\nextern const int "+mangle(f.sig)+"_offset;\n";
  1416.     globals_c+"\nconst int "+mangle(f.sig)+"_offset = "+(-mintag)+";\n";
  1417.     forbid(mangle(f.sig)+"_offset");
  1418.      -- decl::="const ";                                                        -- NLP
  1419.      -- cst:="(const ";                                                         -- NLP
  1420.         cst:="(";
  1421.     if ~void(f.sig.ret) then
  1422.      --     decl:=decl+mangle(f.sig.ret);                                       -- NLP
  1423.             decl:=mangle(f.sig.ret);                                            -- NLP
  1424.         cst:=cst+mangle(f.sig.ret);
  1425.         else                                                                    -- NLP
  1426.             decl:="int";                                                        -- NLP
  1427.             cst:=cst+"int";                                                     -- NLP
  1428.     end;
  1429.      -- decl:=decl+" (*"+mangle(f.sig)+"[])("+mangle(f.sig.tp);                 -- NLP
  1430.         decl:=decl+" (* const "+mangle(f.sig)+"[])("+mangle(f.sig.tp);          -- NLP
  1431.     cst:=cst+" (*)("+mangle(f.sig.tp);
  1432.     if ~void(f.sig.args) then
  1433.         loop 
  1434.                 e::=f.sig.args.elt!;
  1435.         decl:=decl+", "+mangle(e);
  1436.         cst:=cst+", "+mangle(e);
  1437.         end;
  1438.     end;
  1439.     decl:=decl+")";
  1440.     globals_h+"extern "+decl+";\n";
  1441.     globals_c+decl+" = {\n";
  1442.     cst:=cst+"))";
  1443.  
  1444.     -- Manufacture table initialization 
  1445.         -- this is quadratic in number of descendents
  1446.     loop 
  1447.             i::=mintag.upto!(maxtag);
  1448.         exists:BOOL:=false;
  1449.         loop 
  1450.                 e::=des.elt!;
  1451.         tag:INT:=num_tag_for(e);
  1452.         real_sig:SIG:=prog.ifc_tbl.ifc_of(e).sig_conforming_to(f.sig);
  1453.         if tag=i then
  1454.             exists:=true;
  1455.             functocall:STR;
  1456.             
  1457.             -- if we encounter an inlined routine, then
  1458.             -- it wasn't generated so we need to do it now.
  1459.             am::=inlined_sigs.get(real_sig);
  1460.             if ~void(am) then
  1461.             emit_routine(am);
  1462.             inlined_sigs:=inlined_sigs.delete(real_sig);
  1463.             end;
  1464.  
  1465.             if e.is_value then
  1466.             functocall:=emit_dispatch_wrapper(real_sig);
  1467.             else
  1468.             functocall:=mangle(real_sig);
  1469.             end;
  1470.             globals_c+' '+cst+functocall;
  1471.             if i/=maxtag then globals_c+","; end;
  1472.             comment(globals_c,real_sig.str);
  1473.             globals_c+'\n';
  1474.         end;
  1475.         end;
  1476.         if ~exists then
  1477.         globals_c+" NULL";
  1478.         if i/=maxtag then globals_c+","; end;
  1479.         globals_c+'\n';
  1480.         end;
  1481.     end;
  1482.     if mintag>maxtag then
  1483.         globals_c+" NULL /* No descendents found - how odd. */\n";
  1484.     end;
  1485.     globals_c+"};\n";
  1486.     end;
  1487.  
  1488.     emit_code(arg:$AM_STMT) is
  1489.         -- emit code associated with sequence of $AM_STMTs
  1490.  
  1491.         s1,s2:STR;
  1492.         loop until!(void(arg));
  1493.         announce_at(arg.source);
  1494.             typecase arg 
  1495.                 when AM_ASSIGN_STMT then
  1496.                     s1:=emit_expr(arg.dest);
  1497.                     s2:=emit_expr(arg.src);
  1498.             ndefer(s1+" = "+cast(arg.dest.tp,arg.src.tp,s2)+';');
  1499.                 when AM_IF_STMT then
  1500.                     s1:=emit_expr(arg.test);
  1501.                     ndefer("if ("+s1+") {"); in;
  1502.                     emit_code(arg.if_true);
  1503.                     out; ndefer("}");
  1504.                     if ~void(arg.if_false) then
  1505.                         ndefer("else {");
  1506.                         in;
  1507.                         emit_code(arg.if_false);
  1508.                         out; ndefer("}");
  1509.             end;
  1510.                 when AM_LOOP_STMT then
  1511.             outer_loop:STR:=current_loop;
  1512.             current_loop:=mangle(arg);
  1513.             fname:STR:=genother; fnamecount::=0;
  1514.             if ~void(arg.bits) or ~void(arg.its) then
  1515.             comment("loop");
  1516.                 ndefer("{"); in;
  1517.             end;
  1518.                     if ~void(arg.bits) then
  1519.                         defer_newline;
  1520.                         barf_at("Bound iters not implemented",arg);
  1521.             code_c+"<<initialize bound iters here>>";
  1522.             end;
  1523.             if ~void(arg.its) then
  1524.              loop e::=arg.its.elt!;
  1525.               if current_function.is_iter or ~is_built_in_iter(e.fun) then
  1526.                 comment("Frame for call to "+e.fun.str);
  1527.                 if ~void(nested_its) then
  1528.                 -- inside an iter, so nested frames must be
  1529.                 -- placed in this frame instead of as locals.
  1530.           
  1531.                                 -- make sure same nested iter found only once
  1532.                                 assert ~nested_its.contains(e);
  1533.  
  1534.                 nested_its:=nested_its.push(e);
  1535.                 force_mangle(e,"frame->nested"
  1536.                                                     +nested_its.size);
  1537.                 end;
  1538.                 defer_newline;
  1539.                 if arg.has_yield then
  1540.                 if void(nested_its) then
  1541.                     defer(mangle(e.fun)+"_frame ");
  1542.                 end;
  1543.                 defer(mangle(e)+" = ALLOCATE("
  1544.                     +mangle(e.fun)+"_frame);");
  1545.                 else
  1546.                 tname::=fname+'_'+fnamecount;
  1547.                 fnamecount:=fnamecount+1;
  1548.                 defer("struct "+mangle(e.fun)
  1549.                     +"_frame_struct "+tname+';');
  1550.                 defer_newline;
  1551.                 if void(nested_its) then
  1552.                     defer(mangle(e.fun)+"_frame ");
  1553.                     ndefer(mangle(e)+" = &"+tname+';');
  1554.                 end;
  1555.                 end;
  1556.               else
  1557.                 ndefer("BOOL "+mangle(e)+" = TRUE;");
  1558.               end;
  1559.             end;
  1560.             -- make pointers to frames which are really on the stack
  1561.             -- this couldn't be done above because in C all decs
  1562.             -- must proceed ordinary assignments.
  1563.             if ~void(nested_its) then
  1564.                 fnamecount:=0;
  1565.                 loop e::=arg.its.elt!;
  1566.                   if current_function.is_iter or ~is_built_in_iter(e.fun) then
  1567.                 if ~arg.has_yield then
  1568.                     ndefer(mangle(e)+" = &"+fname
  1569.                        +'_'+fnamecount+';');
  1570.                     fnamecount:=fnamecount+1;
  1571.                 end;
  1572.                   end;
  1573.                 end;
  1574.             end;
  1575.             -- initialize all iter states
  1576.             loop 
  1577.                 it::=arg.its.elt!;
  1578.                 if current_function.is_iter or ~is_built_in_iter(it.fun) then
  1579.                 ndefer(mangle(it)+"->state = 0;");
  1580.                 else
  1581.                 end;
  1582.             end;
  1583.             end;
  1584.                 ndefer("while (1) {");
  1585.                     in;
  1586.                     emit_code(arg.body);
  1587.                     out;
  1588.                     ndefer("}");
  1589.             if ~void(arg.bits) or ~void(arg.its) then
  1590.                         out; ndefer("}");
  1591.             end;
  1592.             ndefer(current_loop+": ;");
  1593.             -- Explicitly free any heap-allocated frames
  1594.             if arg.has_yield and ~void(arg.its) then
  1595.                 loop e::=arg.its.elt!;
  1596.               if current_function.is_iter or ~is_built_in_iter(e.fun) then
  1597.                   ep::=mangle(e);
  1598.                   ndefer("GC_free("+ep+"); "+ep+" = NULL;");
  1599.               end;
  1600.                end;
  1601.             end;
  1602.             current_loop:=outer_loop;
  1603.                 when AM_BREAK_STMT then
  1604.                     ndefer("goto "+current_loop+";");
  1605.                 when AM_RETURN_STMT then
  1606.                     if current_function.is_iter then
  1607.                         ndefer("frame->state = -1;");
  1608.                     end;
  1609.                     if ~void(arg.val) then
  1610.                         s1:=emit_expr(arg.val);
  1611.                         ndefer("return "
  1612.                              +cast(current_function.ret,arg.val.tp,s1)+';');
  1613.                     else
  1614.                         assert void(current_function.ret)
  1615.                               or current_function.is_iter;
  1616.                         ndefer("return;");
  1617.                     end;
  1618.             if indent=1 then saw_outer_return:=true; end;
  1619.                 when AM_EXPR_STMT then
  1620.                     s1:=emit_expr(arg.expr);
  1621.                     if ~void(s1) then
  1622.             if ~void(arg.expr.tp) then ndefer("(void) "+s1+';'); 
  1623.             else ndefer(s1+';');
  1624.             end;
  1625.             end;
  1626.             when AM_YIELD_STMT then
  1627.             ndefer("frame->state = "+arg.ret+';');
  1628.             if ~void(arg.val) then 
  1629.             ndefer("return "
  1630.                                   +cast(current_function.ret,arg.val.tp,
  1631.                                         emit_expr(arg.val))+';');    
  1632.             else 
  1633.             ndefer("return;");
  1634.             end;
  1635.             ndefer("state"+state_counter+":;");    
  1636.             state_counter:=state_counter+1;
  1637.         when AM_CASE_STMT then
  1638.                     targets:ARRAY{ARRAY{STR}};
  1639.             test:STR:=emit_expr(arg.test);
  1640.  
  1641.             -- produce C expressions for all target expressions
  1642.             if ~void(arg.tgts) then
  1643.             targets:=#ARRAY{ARRAY{STR}}(arg.tgts.size);
  1644.             loop
  1645.                             i::=targets.ind!;
  1646.                 targets[i]:=#ARRAY{STR}(arg.tgts[i].size);
  1647.                 loop 
  1648.                                 j::=targets[i].ind!;
  1649.                 targets[i][j]:=emit_expr(arg.tgts[i][j]);
  1650.                 end;
  1651.             end;
  1652.             ndefer("switch ("+test+") {");
  1653.             in;
  1654.             comment("case statement");
  1655.  
  1656.             loop
  1657.                             i::=targets.ind!;
  1658.                 loop ndefer("case "+targets[i].elt!+':'); end;
  1659.                 in; emit_code(arg.stmts[i]); out;
  1660.                 ndefer(" break;");
  1661.             end;
  1662.  
  1663.             ndefer("default: ;");
  1664.                         in;
  1665.             if arg.no_else then
  1666.                 runtime_error(
  1667.                                 "No applicable target in case statement",arg);
  1668.             else emit_code(arg.else_stmts);
  1669.             end;
  1670.             out; out;
  1671.                         ndefer("}");
  1672.             else
  1673.             runtime_error(
  1674.                                 "No applicable target in case statement",arg);
  1675.             end;
  1676.         when AM_PRE_STMT then
  1677.             if chk_pre then
  1678.             ndefer("if (!("+emit_expr(arg.test)+")) {");
  1679.             in; runtime_error("Violation of precondition",arg);out;
  1680.             ndefer("}");
  1681.             end;
  1682.         when AM_POST_STMT then
  1683.             if chk_post then
  1684.             ndefer("if (!("+emit_expr(arg.test)+")) {");
  1685.                         in;
  1686.             runtime_error("Violation of postcondition",arg);
  1687.             out; 
  1688.             ndefer("}");
  1689.             end;
  1690.         when AM_INITIAL_STMT then
  1691.             if chk_post then emit_code(arg.stmts); end;
  1692.         when AM_ASSERT_STMT then
  1693.             if chk_assert then
  1694.             ndefer("if (!("+emit_expr(arg.test)+")) {");
  1695.             in; runtime_error("Violation of assertion",arg); out; 
  1696.             ndefer("}");
  1697.             end;
  1698.         when AM_TYPECASE_STMT then
  1699.             if arg.has_void_stmts or chk_when then
  1700.             ndefer("if ("+mangle(arg.test)+"==NULL) {");
  1701.             in;
  1702.             if arg.has_void_stmts then emit_code(arg.void_stmts);
  1703.             else runtime_error("Void object of typecase",arg);
  1704.             end;
  1705.             out; 
  1706.             ndefer("} else"); -- DPS seemed wrong, added else
  1707.             end;
  1708.             emit_typeswitch(mangle(arg.test),arg.tgts,arg.stmts);
  1709.             if arg.no_else then
  1710.             in;
  1711.             runtime_error("No applicable type in typecase",arg);
  1712.             out;
  1713.             else
  1714.             in; emit_code(arg.else_stmts); out;
  1715.             end;
  1716.             out;
  1717.             ndefer("}");
  1718.         when AM_RAISE_STMT then
  1719.                     assert ~void(arg.val);
  1720.             ndefer("exception = "+cast(prog.tp_builtin.dollar_ob,
  1721.                        arg.val.tp,emit_expr(arg.val))+";");
  1722.             ndefer("longjmp(last_protect,1);");
  1723.         when AM_INVARIANT_STMT then
  1724.             if chk_invariant then
  1725.                         assert ~void(current_self);
  1726.             ndefer("if (!"+mangle(arg.sig)
  1727.                                       +"("+current_self+")) {");
  1728.             in;
  1729.             runtime_error("Failed invariant "+arg.sig.str,arg);
  1730.             out;
  1731.             ndefer("}");
  1732.             end;
  1733.  
  1734.         -- from here on haven't been implemented yet.
  1735.         when AM_PROTECT_STMT then
  1736.                     ndefer("{");
  1737.             in;
  1738.             ndefer("OB old_exception = exception;");
  1739.             ndefer("jmp_buf old_protect;");
  1740.             ndefer("bcopy(last_protect,old_protect,sizeof(jmp_buf));"); 
  1741.             ndefer("if (setjmp(last_protect) == 0) {");
  1742.             in;
  1743.             emit_code(arg.body);
  1744.             out;
  1745.             ndefer("} else {");
  1746.             in;
  1747.             ndefer("bcopy(old_protect,last_protect,sizeof(jmp_buf));");
  1748.             emit_typeswitch("exception",arg.tgts,arg.stmts);
  1749.             if arg.no_else then
  1750.             ndefer("longjmp(last_protect,1);");
  1751.             else
  1752.             in; emit_code(arg.else_stmts); out;
  1753.             end;
  1754.             out;
  1755.             ndefer("}"); -- closes type switch
  1756.             out;
  1757.             ndefer("}"); -- closes if
  1758.             ndefer("bcopy(old_protect,last_protect,sizeof(jmp_buf));");
  1759.             ndefer("exception = old_exception;");
  1760.             out;
  1761.             ndefer("}"); -- closes local scope
  1762.                 end;
  1763.             arg:=arg.next;
  1764.             end;
  1765.         end;
  1766.  
  1767.     private emit_typeswitch(test:STR,tgts:FLIST{$TP},stmts:FLIST{$AM_STMT}) is
  1768.     -- Emit a structure that switches on type.  This is used
  1769.     -- by both protect and typecase statements.  It stops after
  1770.     -- emitting the "default:" entry which should then be generated
  1771.     -- appropriately by the caller, along with an "out;" and
  1772.     -- closing curly braces.
  1773.  
  1774.     ndefer("switch ("+test+"->header.tag) {");
  1775.     in;
  1776.     if ~void(tgts) then
  1777.         gen::=#FSET{$TP};
  1778.         loop 
  1779.         i::=tgts.ind!;
  1780.         tp::=tgts[i];
  1781.         dseen:BOOL:=false;
  1782.         if tp.is_abstract then
  1783.             typecase tp
  1784.             when TP_CLASS then
  1785.             loop 
  1786.                d::=prog.descendants_of_abs(tp).elt!;
  1787.                if ~gen.test(d) then
  1788.                    ndefer("case "+tag_for(
  1789.                  prog.descendants_of_abs(tp).elt!)+':');
  1790.                    dseen:=true;
  1791.                    gen:=gen.insert(d);
  1792.                end;
  1793.             end;
  1794.             end;
  1795.         else
  1796.           if ~gen.test(tp) then
  1797.             ndefer("case "+tag_for(tp)+':');
  1798.             dseen:=true;
  1799.             gen:=gen.insert(tp);
  1800.           end;
  1801.         end;
  1802.         -- only emit code if some descendent was seen
  1803.         if dseen then
  1804.             in; 
  1805.             emit_code(stmts[i]);
  1806.             defer(" break;");
  1807.             out;
  1808.         end;
  1809.         end;
  1810.     end;
  1811.     ndefer("default: ;"); 
  1812.     end; 
  1813.  
  1814.     private runtime_error(s:STR) is
  1815.     -- emit (deferred) code to generate a fatal error at runtime.
  1816.  
  1817.     ndefer("fprintf(stderr,\""+s+"\\n\");");
  1818.      -- ndefer("abort();");                                                     -- NLP
  1819.         ndefer("exit(16);");                                                    -- NLP
  1820.     end;
  1821.  
  1822.     private runtime_error(s:STR,l:$PROG_ERR) is
  1823.     -- emit (deferred) code to generate a fatal error at runtime.
  1824.  
  1825.     ndefer("fprintf(stderr,\""+s+" "+l.source.str+"\\n\");");
  1826.      -- ndefer("abort();");                                                     -- NLP
  1827.         ndefer("exit(16);");                                                    -- NLP
  1828.     end;
  1829.  
  1830.     private emit_args(arg:$AM_CALL_EXPR):ARRAY{STR} is
  1831.     -- declare auto variables for any subexpressions that
  1832.     -- can't be in-line; at the moment that means anything
  1833.     -- which is a call.
  1834.  
  1835.     res::=#ARRAY{STR}(arg.asize);
  1836.     is_ext::=false;
  1837.     typecase arg when AM_EXT_CALL_EXPR then is_ext:=true; else end;
  1838.     -- first, find the last argument which isn't a call
  1839.     last:INT;
  1840.     loop last:=(arg.asize-1).downto!(-1);
  1841.         while!(last>=0);
  1842.         e::=arg[last];
  1843.         typecase e when $AM_CALL_EXPR then break!; else end;
  1844.     end;
  1845.     last:=(last+1).min(arg.asize-1);
  1846.     loop i::=0.for!(arg.asize);
  1847.         if ~(is_ext and i=0) then
  1848.         e::=arg[i];
  1849.         res[i]:=emit_expr(e);
  1850.         typecase e
  1851.             when AM_LOCAL_EXPR then -- locals can't be affected
  1852.             else
  1853.             if i<last then
  1854.                 subexpr::=res[i];
  1855.                 res[i]:=dec_local(e.tp);
  1856.                 ndefer(res[i]+" = "+subexpr+';');
  1857.             end;
  1858.         end;
  1859.         end;
  1860.     end;
  1861.         return res;
  1862.     end;
  1863.  
  1864.     private is_asize(s:SIG):BOOL is
  1865.     -- True if this call should be the built-in "asize".
  1866.  
  1867.     return s.name.str="asize"
  1868.        and ~s.tp.is_abstract
  1869.        and ~void(prog.impl_tbl.impl_of(s.tp).arr)
  1870.        and s.num_args=0
  1871.        and ~void(s.ret)
  1872.        and ~s.tp.is_value;
  1873.     end;
  1874.  
  1875.     is_built_in_routine(s:SIG):BOOL is
  1876.     return built_in_routines.test(s.str);
  1877.     end;
  1878.  
  1879.     is_built_in_iter(s:SIG):BOOL is
  1880.     return built_in_iters.test(s.str);
  1881.     end;
  1882.  
  1883.     built_in_which_may_be_emitted_anyway(s:SIG):BOOL is
  1884.        -- added by Matt Kennel, UCSD.
  1885.        -- if chk_bounds or chk_arith is on, and if
  1886.        -- the third column is "nomacro", then full unmacroized
  1887.        -- Sather code may be emitted for some built in routines
  1888.        -- never the less. This function ought to return true
  1889.        -- for those built in routines which may need to be written
  1890.        -- out in programmed form anyway.
  1891.        -- find out if any bounds check may be done?
  1892.  
  1893.        if ~void(prog.options.bounds_in) or prog.options.bounds_all or
  1894.            ~void(prog.options.arith_in) or prog.options.arith_all
  1895.                -- can only worry about it if there are some bounds checks
  1896.        then
  1897.            tuple ::= built_in_routines.get(s.str);
  1898.            if void(tuple) then return false;
  1899.            else
  1900.                if tuple.t2 = "nomacro" then return true;
  1901.                else return false; end;
  1902.            end;
  1903. --     else return false;                                                       -- NLP
  1904.        end; return false;                                                       -- NLP
  1905. --     end;                                                                     -- NLP
  1906.     end;
  1907.  
  1908.     private emit_rout_call(arce:AM_ROUT_CALL_EXPR):STR is
  1909.     arg_list::=emit_and_cast_args(arce);
  1910.     return emit_call(arce.fun,arg_list);
  1911.     end;
  1912.  
  1913.     private emit_and_cast_args(arce:AM_ROUT_CALL_EXPR):ARRAY{STR} is
  1914.     -- emit args, properly casted for the given routine call
  1915.     arg_list::=emit_args(arce);
  1916.     arg_list[0]:=cast(arce.fun.tp,arce[0].tp,arg_list[0]);
  1917.     loop
  1918.         i::=1.upto!(arg_list.size-1);
  1919.         arg_list[i]:=cast(arce.fun.args[i-1],arce[i].tp,arg_list[i]);
  1920.     end;
  1921.     return arg_list;
  1922.     end;
  1923.  
  1924.     private emit_call(fun:SIG, arg_list:ARRAY{STR}):STR is
  1925.     -- assumes all args are appropriately casted already
  1926.  
  1927.     res:STR;
  1928.  
  1929.     -- find out if this requires special handling
  1930.     biname:STR:=void;
  1931.         process_as_builtin:BOOL:= fun.is_builtin;
  1932.         if process_as_builtin and (chk_arith or chk_bounds) then
  1933.            biname:=built_in_routines.get(fun.str).t2;
  1934.            if biname = "nomacro" then process_as_builtin := false; end;
  1935.         end;
  1936.  
  1937.         if process_as_builtin then
  1938.         if chk_arith then biname:=built_in_routines.get(fun.str).t2;
  1939.         else biname:=built_in_routines.get(fun.str).t1;
  1940.         end;
  1941.         if biname[0]='@' then
  1942.         case biname[1] 
  1943.             when '1' then -- this happens for SYS::ob_eq($OB,$OB):BOOL
  1944.             -- If both arguments are already pointers, just compare
  1945.             -- them; otherwise, we have to do function call
  1946.             carg1::=arg_list[1];
  1947.             carg2::=arg_list[2];
  1948.                         if fun.args[0].is_value or fun.args[1].is_value
  1949.                or fun.args[0].is_abstract
  1950.                or fun.args[1].is_abstract then
  1951.                 return "c_SYS_ob_eq_OB_OB_BOOL("
  1952.                 +carg1+','+carg2+')';
  1953.             else
  1954.                 return "("+carg1+"=="+carg2+')';
  1955.             end;
  1956.             else barf("Don't recognize @ function in MACROS");
  1957.         end;
  1958.         end;
  1959.         res:="(";
  1960.             i:INT:=0;
  1961.         loop
  1962.                 until!(i>=biname.length); 
  1963.         if biname[i]='#' then
  1964.             i:=i+1;
  1965.             case biname[i]
  1966.             when '1' then res:=res+arg_list[0];
  1967.             when '2' then res:=res+arg_list[1];
  1968.             when '3' then res:=res+arg_list[2];
  1969.             when '4' then res:=res+arg_list[3];
  1970.             when '5' then res:=res+arg_list[4];
  1971.             else barf("Bad # spec in MACROS");
  1972.             end;
  1973.         else
  1974.             res:=res+biname[i];
  1975.         end;
  1976.                 i:=i+1;
  1977.         end;
  1978.         return res+')';
  1979.     else
  1980.         -- not in table, but maybe 'asize'
  1981.         if is_asize(fun) then
  1982.         if chk_void and ~prog.options.null_segfaults then
  1983.             ndefer("if ("+arg_list[0]+"==NULL) {");
  1984.             in; runtime_error("`asize' access of void in "+current_function_str); out;
  1985.             ndefer("}");
  1986.         end;
  1987.         return "("+arg_list[0]+"->asize)";
  1988.         elsif fun.tp.is_abstract then
  1989.         -- put self in a local so it isn't called twice
  1990.         self_ob::=dec_local(fun.tp);
  1991.         ndefer(self_ob+" = "+arg_list[0]+';');
  1992.         arg_list[0]:=self_ob;
  1993.  
  1994.         if chk_void and ~prog.options.null_segfaults then
  1995.             ndefer("if ("+arg_list[0]+"==NULL) {");
  1996.             in; runtime_error("Dispatch on void in "+current_function_str); out;
  1997.             ndefer("}");
  1998.         end;
  1999.         res:="(*"+mangle(fun)+"["
  2000.                   +arg_list[0]+"->header.tag+"
  2001.                   +mangle(fun)+"_offset])(";
  2002.         else
  2003.         -- must be ordinary call
  2004.         res:=mangle(fun)+'(';
  2005.         end;
  2006.     end;
  2007.  
  2008.     -- emit the argument identifiers.
  2009.         res:=res+arg_list[0];
  2010.     loop i::=1.upto!(arg_list.size-1);
  2011.             res:=res+", "+arg_list[i];
  2012.     end;
  2013.     return res+')';
  2014.     end;
  2015.  
  2016.     private emit_builtin_iter_call(aice:AM_ITER_CALL_EXPR):STR is
  2017.     inlined_iter_count:=inlined_iter_count+1;
  2018.     it::=built_in_iters.get(aice.fun.str);
  2019.     if void(it) then barf("Couldn't get iter inlining info"); end;
  2020.  
  2021.     not_seen::=mangle(aice); 
  2022.  
  2023.         this:STR;
  2024.     if ~void(aice.fun.ret) then
  2025.         this:=dec_local_comment(aice.fun.ret,"Inlined return value");
  2026.     else
  2027.         this:=not_seen+'t'; forbid(this);
  2028.     end;
  2029.  
  2030.     -- First argument is never hot
  2031.     arg1::=dec_local_comment(aice.fun.tp,"Inlined self to iter");
  2032.  
  2033.         -- Second argument may not exist and may be hot
  2034.     arg2nothot::=void(aice.fun.hot) or ~aice.fun.hot[0];
  2035.     arg2:STR;
  2036.     if aice.size>1 then
  2037.         if arg2nothot then
  2038.         arg2:=dec_local_comment(aice.fun.args[0],
  2039.                            "Inlined 1st arg to iter");
  2040.         else
  2041.         arg2:=emit_expr(aice[1]);
  2042.         end;
  2043.     end;
  2044.     
  2045.     code_c+eol+' '+iter_inline_xlate(this,arg1,arg2,it.at_decs);
  2046.  
  2047.     ndefer("if ("+not_seen+") {");
  2048.     in;
  2049.     ndefer(not_seen+" = FALSE;");
  2050.     comment("Initialize inlined once arguments of call to "+aice.fun.str);
  2051.     emit_code(aice.init);
  2052.         ndefer(arg1+" = "+emit_expr(aice[0])+';');
  2053.     if ~void(arg2) and arg2nothot then
  2054.         ndefer(arg2+" = "+cast(aice.fun.args[0],aice[1].tp,
  2055.                     emit_expr(aice[1]))+';');
  2056.     end;
  2057.     ndefer(iter_inline_xlate(this,arg1,arg2,it.when_first_seen));
  2058.     out;
  2059.     ndefer("} else {");
  2060.     in; ndefer(iter_inline_xlate(this,arg1,arg2,it.after)); out;
  2061.     ndefer("}");
  2062.     ndefer(iter_inline_xlate(this,arg1,arg2,it.before));
  2063.     if ~void(aice.fun.ret) then return this;
  2064. --      else return "0 /* no return value from inlined iter */";                -- NLP
  2065.         end; return "0 /* no return value from inlined iter */";                -- NLP
  2066. --      end;                                                                    -- NLP
  2067.     end;
  2068.  
  2069.     private iter_inline_xlate(this,arg1,arg2,s:STR):STR is
  2070.     -- give special meaning to strings used for inlining iters
  2071.     res::="";
  2072.     i::=0;
  2073.     loop
  2074.         until!(i>=s.size);
  2075.         c::=s[i];
  2076.         case c
  2077.         when '@' then res:=res+"goto "+current_loop;
  2078.         when '#' then 
  2079.             i:=i+1; 
  2080.             case s[i]
  2081.             when '#' then res:=res+this;
  2082.             when '1' then res:=res+arg1;
  2083.             when '2' then res:=res+arg2;
  2084.             else barf("Couldn't interpret # in iter inline");
  2085.             end;
  2086.         else res:=res+c;
  2087.         end;
  2088.         i:=i+1;
  2089.     end;
  2090.     return res;
  2091.     end;
  2092.  
  2093.     emit_iter_call(aice:AM_ITER_CALL_EXPR):STR is
  2094.  
  2095.         s1,res:STR;
  2096.     if ~current_function.is_iter and is_built_in_iter(aice.fun) then
  2097.         return emit_builtin_iter_call(aice);
  2098.         end;
  2099.     if aice.fun.tp.is_abstract then
  2100.         barf_at("Dispatched iters not implemented.",aice);
  2101.     end;
  2102.     if ~void(aice.tp) then
  2103.         -- local variable to hold result (since we have to imbed
  2104.         -- in a control structure to check for possible termination)
  2105.         s1:=dec_local_comment(aice.tp,
  2106.              "Holds result of call to "+aice.fun.str);
  2107.     end;
  2108.  
  2109.     -- if first time through, compute once arguments
  2110.     -- (all once args before any hot args).
  2111.     ndefer("if ("+mangle(aice)+"->state == 0) {");
  2112.     in;
  2113.     comment("Initialize once arguments of call to "+aice.fun.str);
  2114.     emit_code(aice.init);
  2115.  
  2116.     -- for each once argument, copy into frame
  2117.     loop
  2118.             i::=aice.ind!;
  2119.  
  2120.         -- beware the difference in argument indices between
  2121.         -- aice[] and aice.fun.hot[]!!!
  2122.  
  2123.         if i=0 then
  2124.         ndefer(mangle(aice)+"->arg"+i+" = "+emit_expr(aice[i])+';');
  2125.         elsif void(aice.fun.hot) or ~aice.fun.hot[i-1] then
  2126.         ndefer(mangle(aice)+"->arg"+i+" = "
  2127.             +cast(aice.fun.args[i-1],aice[i].tp,emit_expr(aice[i]))
  2128.             +';');
  2129.         end;
  2130.         end;
  2131.     out;
  2132.     ndefer("}");
  2133.  
  2134.     -- compute all hot arguments into frame
  2135.     if ~void(aice.fun.hot) then
  2136.  
  2137.         -- beware the difference in indices!!!
  2138.  
  2139.         loop i::=1.upto!(aice.asize-1);
  2140.         if aice.fun.hot[i-1] then
  2141.           ndefer(mangle(aice)+"->arg"+i+" = "
  2142.             +cast(aice.fun.args[i-1],aice[i].tp,emit_expr(aice[i]))
  2143.             +';');
  2144.           comment("hot argument");
  2145.         end;
  2146.         end;
  2147.     end;
  2148.     if ~void(aice.tp) then
  2149.         ndefer(s1+" = "+mangle(aice.fun)+'('+mangle(aice)+");");
  2150.         res:=s1;
  2151.     else
  2152.         ndefer(mangle(aice.fun)+'('+mangle(aice)+");");
  2153.         res:="0 /* No return value from iter call */";
  2154.     end;
  2155.     ndefer("if ("+mangle(aice)+"->state == -1) goto "+current_loop+";");
  2156.         return res;
  2157.     end;
  2158.  
  2159.     emit_str_const(asc:AM_STR_CONST):STR is
  2160.         res::="((STR) &"+mangle(asc)+')';
  2161.         globals_c+"struct {\n";
  2162.         globals_c+" OB_HEADER header;\n";
  2163.         globals_c+" INT asize;\n";
  2164.         globals_c+" CHAR arr_part["
  2165.                        +(asc.bval.length+1) -- +1 for Object Center bug
  2166.                        +"];\n  } "+mangle(asc)+" = { ";
  2167.         if prog.options.deterministic then
  2168.            globals_c+"{ "+tag_for(prog.tp_builtin.str)+", -"+str_count+" }";
  2169.            str_count:=str_count+1;
  2170.         else
  2171.            globals_c+tag_for(prog.tp_builtin.str);
  2172.         end;
  2173.         globals_c+", "+asc.bval.length+", \""+Cify(asc.bval)+"\" };\n";
  2174.     strings_h+"\nextern STR "+mangle(asc)+';';
  2175.         return res;
  2176.     end;
  2177.      
  2178.     emit_expr(arg:$AM_EXPR):STR pre ~void(arg) is
  2179.         -- emit code for computing expr if necessary, and return handle
  2180.         -- to the result.
  2181.  
  2182.         typecase arg
  2183.             when AM_LOCAL_EXPR then return mangle(arg);
  2184.             when AM_ROUT_CALL_EXPR then return emit_rout_call(arg);
  2185.             when AM_ITER_CALL_EXPR then    return emit_iter_call(arg);
  2186.         when AM_VOID_CONST then
  2187.                 assert ~void(arg.tp);
  2188.                 return default_init(arg.tp);
  2189.             when AM_STR_CONST then return emit_str_const(arg);
  2190.             when AM_BOOL_CONST then
  2191.                 if arg.val then return "TRUE" else return "FALSE" end;
  2192.             when AM_INT_CONST then return arg.val.str;
  2193.         when AM_CHAR_CONST then return "'"+Cify(arg.bval)+'\'';
  2194.         when AM_FLT_CONST then return arg.val.str(8); -- two extra
  2195.         when AM_FLTD_CONST then return arg.val.str(17); -- two extra
  2196.         when AM_FLTX_CONST then
  2197.         barf_at("FLTX literals not implemented yet",arg);
  2198.         when AM_FLTDX_CONST then
  2199.         barf_at("FLTDX literals not implemented yet",arg);
  2200.         when AM_IF_EXPR then
  2201.         res::=dec_local_comment(arg.tp,"local for :? test");
  2202.         ndefer("if ("+emit_expr(arg.test)+") {");
  2203.         in; ndefer(res+" = "+emit_expr(arg.if_true)+';'); out;
  2204.         ndefer("} else {");
  2205.         in; ndefer(res+" = "+emit_expr(arg.if_false)+';'); out;
  2206.         ndefer("}");
  2207.                 return res;
  2208.             when AM_NEW_EXPR then
  2209.         res::=dec_local_comment(arg.tp_at,
  2210.                    "local for "+arg.tp_at.str+"::create");
  2211.         if ~void(arg.asz) then
  2212.             s2::=emit_expr(arg.asz);
  2213.             ndefer(res+" = "+array_allocate(arg.tp_at,s2)+";");
  2214.             ndefer(res+"->asize = "+s2+";");
  2215.         else ndefer(res+" = "+allocate(arg.tp_at)+";");
  2216.         end;
  2217.                 return res;
  2218.         when AM_ATTR_EXPR then
  2219.         s1::=emit_expr(arg.ob);
  2220.         if chk_void and ~arg.ob.tp.is_value
  2221.                 and ~prog.options.null_segfaults then
  2222.             ndefer("if ("+s1+"==NULL) {");
  2223.             in; 
  2224.                     runtime_error("Attr access "+arg.at.str+" of void",arg);
  2225.             out; 
  2226.             ndefer("}");
  2227.         end;
  2228. --              s1:=cast(arg.self_tp,arg.ob.tp,s1);                             -- NLP
  2229. --              if arg.self_tp.is_value then return s1+"."+mangle(arg.at);      -- NLP
  2230. --              else return s1+"->"+mangle(arg.at);                             -- NLP
  2231.                 s2::=cast(arg.self_tp,arg.ob.tp,s1);                            -- NLP
  2232.                 if arg.self_tp.is_value then                                    -- NLP
  2233.                     if s1.tail(1) = ")" and s2.tail(1) = ")" then               -- NLP
  2234.                         return "("+mangle(arg.ob.tp)+"_blob="+s2+")."+mangle(arg.at); -- NLP
  2235.                     else                                                        -- NLP
  2236.                         return s2+"."+mangle(arg.at);                           -- NLP
  2237.                     end;                                                        -- NLP
  2238.                 else return s2+"->"+mangle(arg.at);                             -- NLP
  2239.         end;
  2240.         when AM_VATTR_ASSIGN_EXPR then
  2241.         s1::=emit_expr(arg.ob);
  2242.                 s2::=mangle(arg.at);
  2243.                 s3::=emit_expr(arg.val);
  2244.                 res::=dec_local_comment(arg.tp,
  2245.                           "local for value type array assignment");
  2246.         ndefer(res+" = "+s1+";");
  2247.         ndefer(res+"."+s2+" = "+s3+";");
  2248.                 return res;
  2249.         when AM_ARR_EXPR then
  2250.         s1::=emit_expr(arg.ob);
  2251.         s2::=emit_expr(arg.ind);
  2252.         if ~arg.ob.tp.is_value then
  2253.             if chk_void and ~prog.options.null_segfaults then
  2254.             ndefer("if ("+s1+"==NULL) {");
  2255.             in; runtime_error("Void array access",arg); out; 
  2256.             ndefer("}");
  2257.             end;
  2258.             if chk_bounds then
  2259.             ndefer("if ("+s2+"<0||"+s2+">="+s1+"->asize) {");
  2260.             in;
  2261.             runtime_error("Index out of bounds",arg);
  2262.             out; 
  2263.             ndefer("}");
  2264.             end;
  2265.         else
  2266.             -- FIX HERE
  2267.             ndefer("/* should do bounds check here */");
  2268.         end;
  2269.         if arg.ob.tp.is_value then return s1+".arr_part["+s2+"]";
  2270.         else return s1+"->arr_part["+s2+"]";
  2271.         end;
  2272.         when AM_VARR_ASSIGN_EXPR then
  2273.         s1::=emit_expr(arg.ob);
  2274.                 s2::=emit_expr(arg.ind);
  2275.                 s3::=emit_expr(arg.val);
  2276.                 res::=dec_local_comment(arg.tp,"local for value array assign");
  2277.                 -- FIX HERE
  2278.                 ndefer("/* should do dynamic bounds checking here */");
  2279.         ndefer(res+" = "+s1+";");
  2280.         ndefer(res+".arr_part["+s2+"] = "+s3+";");
  2281.                 return res;
  2282.         when AM_EXT_CALL_EXPR then
  2283.         arg_list:ARRAY{STR}:=emit_args(arg);
  2284.         extern:STR:="extern ";
  2285.         if ~void(arg.tp) then extern:=extern+mangle(arg.tp)+" ";
  2286.         else extern:=extern+"void ";
  2287.         end;
  2288.         extern:=extern+arg.nm.str+"("; 
  2289.                 res::=arg.nm.str+"(";
  2290.         i:INT:=1;  -- self is not passed to external routines 
  2291.         loop until!(i>=arg_list.asize);
  2292.             if arg[i].tp.kind=TP_KIND::ref_tp then
  2293.             arr:TP_CLASS:=prog.impl_tbl.impl_of(arg[i].tp).arr;
  2294.             if ~void(arr) then
  2295.                 -- AREF{FOO} passed to external routines really
  2296.                 -- passes a pointer to the array portion.
  2297.                 extern:=extern+mangle(arr.params[0])+" []";
  2298.                 res:=res+"(("+arg_list[i]+"==NULL)?NULL:"
  2299.                      +arg_list[i]+"->arr_part)";
  2300.             else
  2301.                 extern:=extern+mangle(arg[i].tp);
  2302.                 res:=res+arg_list[i];
  2303.             end;
  2304.             else
  2305.             extern:=extern+mangle(arg[i].tp);
  2306.             res:=res+arg_list[i];
  2307.             end;
  2308.             i:=i+1;
  2309.             if i<arg_list.asize then
  2310.             extern:=extern+", ";
  2311.             res:=res+", ";
  2312.             end;
  2313.         end;
  2314.         extern:=extern+");\n";
  2315.         se:STR:=special_externs.get(arg.nm.str);
  2316.         if ~void(se) then extern:=se+'\n'; end;
  2317.         decs_h+extern;
  2318.         return res+')';
  2319.         when AM_GLOBAL_EXPR then return mangle(arg);
  2320.         when AM_ARRAY_EXPR then
  2321.         res::=dec_local_comment(arg.tp_at,
  2322.                      "local for array creation expression");
  2323.         ndefer(res+" = "+array_allocate(arg.tp_at,arg.asize.str)+";");
  2324.         ndefer(res+"->asize = "+arg.asize+";");
  2325.         loop i::=arg.ind!;
  2326.             ndefer(res+"->arr_part["+i+"] = "+emit_expr(arg[i])+';');
  2327.         end;
  2328.         return res;
  2329.         when AM_IS_VOID_EXPR then
  2330.                 assert ~void(arg.arg);
  2331.         arg_tp:$TP:=arg.arg.tp;
  2332.                 assert ~void(arg_tp);
  2333.         if arg_tp.is_value and ~is_built_in_type(arg_tp) then
  2334.             return value_void(arg_tp,emit_expr(arg.arg));
  2335.         else
  2336.             return "("+emit_expr(arg.arg)+"=="
  2337.                                       +default_init(arg_tp)+")";
  2338.         end;
  2339.         when AM_STMT_EXPR then
  2340.         if ~void(arg.stmts) then emit_code(arg.stmts); end;
  2341.         if ~void(arg.expr) then return emit_expr(arg.expr);
  2342.         else return void;
  2343.         end;
  2344.         when AM_EXCEPT_EXPR then
  2345.         return cast(arg.tp,prog.tp_builtin.dollar_ob,"exception");
  2346.         when AM_BND_CREATE_EXPR then
  2347.         bnd_rout_creates:=bnd_rout_creates.push(arg);
  2348.         res::=genlocal;
  2349.         code_c+eol+' '+mangle(arg)+"_ob "+res+';';
  2350.                 ndefer(res+" = ("+mangle(arg)+"_ob) GC_malloc(sizeof(struct "
  2351.                           +mangle(arg)+"_ob_struct));");
  2352.         ndefer(res+"->funcptr = "+mangle(arg)+';');
  2353.         loop
  2354.             i::=arg.ind!;
  2355.             entry:STR;
  2356.             idx::=arg.bnd_args[i];
  2357.             if idx=0 then
  2358.             entry:=cast(arg.fun.tp,arg[i].tp,emit_expr(arg[i]));
  2359.             else
  2360.             entry:=cast(arg.fun.args[idx-1],arg[i].tp,
  2361.                     emit_expr(arg[i]));
  2362.             end;
  2363.             ndefer(res+"->bound_arg"+i+" = "+entry+';');
  2364.         end;
  2365.         return "("+mangle(arg.tp)+") "+res;
  2366.         when AM_BND_ROUT_CALL_EXPR then
  2367.         tp::=arg.br.tp;
  2368.         br::=dec_local(tp);
  2369.         ndefer(br+" = "+emit_expr(arg.br)+';');
  2370.         res::="(*("+br+"->funcptr))("+br;
  2371.         arg_list::=emit_args(arg);
  2372.         loop
  2373.             i::=arg.ind!;
  2374.             typecase tp when TP_ROUT then
  2375.             res:=res+", "+cast(tp.args[i],arg[i].tp,arg_list.elt!);
  2376.             end;
  2377.         end;
  2378.         return res+')';
  2379.         
  2380.         -- from here on haven't been implemented yet.
  2381.         when AM_BND_ITER_CALL_EXPR then
  2382.         barf_at("bound iters not implemented yet",arg);
  2383.         when AM_ARR_CONST then
  2384.         barf_at("constant array literals not implemented yet",arg);
  2385.         when AM_INTI_CONST then
  2386.         barf_at("INTI literals not implemented yet",arg);
  2387.         when AM_FLTI_CONST then
  2388.         barf_at("FLTI constants not implemented yet",arg);
  2389.     end; -- typecase
  2390.     barf("Got to end of emit_expr");
  2391.         return ""; -- because this routine must end with a return
  2392.     end;
  2393.  
  2394.     value_compare(tp:$TP,e1,e2:STR):STR pre tp.is_value is
  2395.     -- expression for comparing contents of two value types
  2396.  
  2397.     if is_built_in_type(tp) then return "("+e1+"=="+e2+")"; end;
  2398.         aod:AM_OB_DEF:=prog.am_ob_def_for_tp(tp);
  2399.         after_first:BOOL:=false;
  2400.     res::="";
  2401.         if ~void(aod.at) then
  2402.         loop
  2403.                 p::=aod.at.pairs!;
  2404.                 key:STR:=mangle(p.t1);
  2405.         if after_first then res:=res+"&&"; end;
  2406.         if p.t2.is_value then
  2407.             res:=res+value_compare(p.t2,e1+'.'+key,e2+'.'+key);
  2408.         else
  2409.             res:=res+'('+e1+'.'+key+"=="+e2+'.'+key+')';
  2410.         end;
  2411.                 after_first:=true;
  2412.         end;
  2413.     end;
  2414.     if ~void(aod.arr) then
  2415.         loop
  2416.                 i::=0.for!(aod.asize);
  2417.         if after_first then res:=res+"&&"; end;
  2418.         res:=res+"("+e1+".arr_part["+i+"]=="+e2+".arr_part["+i+"])";
  2419.         after_first:=true;
  2420.         end;
  2421.     end;
  2422.         return res;
  2423.     end;
  2424.  
  2425.     value_void(tp:$TP,e:STR):STR pre tp.is_value is
  2426.     -- expression for comparing value types to void (all zero elements)
  2427.     if is_built_in_type(tp) then return "("+e+"==("+mangle(tp)+")0)"; end;
  2428.         aod:AM_OB_DEF:=prog.am_ob_def_for_tp(tp);
  2429.         after_first:BOOL:=false;
  2430.     res::="";
  2431.         if ~void(aod.at) then
  2432.         loop 
  2433.                 p::=aod.at.pairs!;
  2434.                 key:STR:=mangle(p.t1);
  2435.         if after_first then res:=res+"&&"; end;
  2436.         if p.t2.is_value then
  2437. --                  res:=res+value_void(p.t2,e+'.'+key);                        -- NLP
  2438.                     if e.tail(1) = ")" then                                     -- NLP
  2439.                         res:=res+value_void(p.t2,"("+mangle(tp)+"_blob="+e+")."+key); -- NLP
  2440.                     else                                                        -- NLP
  2441.                         res:=res+value_void(p.t2,e+'.'+key);                    -- NLP
  2442.                     end;                                                        -- NLP
  2443.         else
  2444. --                  res:=res+'('+e+'.'+key+"==("+mangle(p.t2)+")0)";            -- NLP
  2445.                     if e.tail(1) = ")" then                                     -- NLP
  2446.                         res:=res+"(("+mangle(tp)+"_blob="+e+")."+key+"==("+mangle(p.t2)+")0)"; -- NLP
  2447.                     else                                                        -- NLP
  2448.                         res:=res+'('+e+'.'+key+"==("+mangle(p.t2)+")0)";        -- NLP
  2449.                     end;                                                        -- NLP
  2450.         end;
  2451.                 after_first:=true;
  2452.         end;
  2453.     end;
  2454.     if ~void(aod.arr) then
  2455.         loop i::=0.for!(aod.asize);
  2456.         if after_first then res:=res+"&&"; end;
  2457.         res:=res+'('+e+".arr_part["+i
  2458.                     +"]==("+mangle(aod.arr)+")0)";
  2459.         after_first:=true;
  2460.         end;
  2461.     end;
  2462.         return res;
  2463.     end;
  2464.  
  2465.     force_mangle(ob:$OB, s:STR) is
  2466.         -- see to it that a particular object gets a particular name.
  2467.         -- if this is not possible, that is an error.
  2468.  
  2469.         x:STR:=manglemap.get(ob);
  2470.         if void(x) then
  2471.         manglemap:=manglemap.insert(ob,s); 
  2472.         mangleset:=mangleset.insert(s);
  2473.         elsif x/=s then
  2474.             -- Already taken! 
  2475.             barf("Name "+s+" could not be assigned in back end");
  2476.         end;
  2477.     end;
  2478.  
  2479.     remangle(ob:$OB, s:STR) is
  2480.     -- rename object to have particular name.  This differs
  2481.     -- from force_mangle in that it doesn't remove the previous
  2482.     -- name from mangleset.
  2483.  
  2484.         x:STR:=manglemap.get(ob);
  2485.         if void(x) or x/=s then
  2486.         manglemap:=manglemap.insert(ob,s);  -- this will overwrite
  2487.         mangleset:=mangleset.insert(s);
  2488.         end;
  2489.     end;
  2490.  
  2491.     unmangle(ob:$OB) is
  2492.         -- remove object from mangling map, for instance, for local
  2493.         -- variables after the body of a functions so that their
  2494.         -- names may be reused.
  2495.  
  2496.         s:STR:=manglemap.get(ob);
  2497.         if ~void(s) then
  2498.         manglemap:=manglemap.delete(ob);
  2499.         mangleset:=mangleset.delete(s);
  2500.     end;
  2501.     end;
  2502.  
  2503.     genlocal:STR is
  2504.         -- generate a unique identifier used for intermediate results
  2505.     res:STR;
  2506.         loop 
  2507.             res:="local"+local_counter;
  2508.             local_counter:=local_counter+1;
  2509.             if ~mangleset.test(res) then break!; end;
  2510.         end;
  2511.     return res;
  2512.     end;
  2513.  
  2514.     genother:STR is
  2515.     -- generate a unique identifier for anything
  2516.     res:STR;
  2517.     loop
  2518.         res:="temp"+counter;
  2519.         counter:=counter+1;
  2520.         if ~mangleset.test(res) then break!; end;
  2521.     end;
  2522.     return res;
  2523.     end;
  2524.  
  2525.     private attr thisrout:FSET{$OB}; -- Set of mangled objects that can
  2526.     -- safely be forgotten after the current routine has been
  2527.     -- generated.
  2528.  
  2529.     private start_mangling is thisrout:=#; local_counter:=0; end;
  2530.  
  2531.     private end_mangling is
  2532.     -- go through and unmangle anything which doesn't have to
  2533.     -- be remembered outside of this function
  2534.     loop unmangle(thisrout.elt!); end;
  2535.     thisrout:=void;
  2536.     end;
  2537.  
  2538.     mangle(ob:$OB):STR pre ~void(ob) is
  2539.         -- Generate unique id that C will be happy with for each unique $OB.
  2540.         -- Uses s, if non-void, as a suggestion.
  2541.         -- Truncates at 16 chars and then puts in number in rightmost part
  2542.         -- to ensure is unique, if necessary.
  2543.         -- Also drops any non-alphanumerics.  
  2544.  
  2545.         res::=manglemap.get(ob);
  2546.         if void(res) then
  2547.             s:STR;
  2548.             typecase ob    
  2549.                 when SIG then
  2550.                     s:=ob.tp.str+'_'+ob.name.str;
  2551.             if ~void(ob.args) then
  2552.             loop s:=s+'_'+ob.args.elt!.str; end;
  2553.             end;
  2554.             if ~void(ob.ret) then s:=s+'_'+ob.ret.str; end;
  2555.                 when AM_LOCAL_EXPR then
  2556.             if ~void(ob.name) then s:=ob.name.str; end;
  2557.             thisrout:=thisrout.insert(ob);
  2558.                 when TP_CLASS then s:=ob.str;
  2559.         when TP_ROUT then s:=ob.str;
  2560.         when AM_BND_CREATE_EXPR then s:="bound";
  2561.         when STR then s:=ob;
  2562.         when IDENT then s:=ob.str;
  2563.         when AM_GLOBAL_EXPR then 
  2564.                     s:="shared_"+ob.class_tp.str+'_'+ob.name.str;
  2565.         when AM_LOOP_STMT then
  2566.             s:="after_loop";
  2567.             thisrout:=thisrout.insert(ob);
  2568.         when AM_STR_CONST then s:=ob.bval;
  2569.         else -- pick a default name
  2570.             thisrout:=thisrout.insert(ob);
  2571.             end;
  2572.             if void(s) then res:="noname"+counter; counter:=counter+1;
  2573.             else
  2574.                 tmp::=#FSTR;    -- Use an FSTR for speed
  2575.                 loop c::=s.elt!;
  2576.                     case c
  2577.                          when 'a','b','c','d','e','f','g',
  2578.                               'h','i','j','k','l','m',
  2579.                               'n','o','p','q','r','s','t',
  2580.                               'u','v','w','x','y','z',
  2581.                               '0','1','2','3','4','5','6',
  2582.                               '7','8','9','_',
  2583.                               'A','B','C','D','E','F','G',
  2584.                               'H','I','J','K','L','M',
  2585.                               'N','O','P','Q','R','S','T',
  2586.                               'U','V','W','X','Y','Z' then
  2587.                             tmp:=tmp+c;
  2588.                          else -- don't put anything else in
  2589.                     end;
  2590.                 end;
  2591.         -- make sure there's something left
  2592.                 if tmp.length = 0 then tmp := tmp+"name" end;
  2593.  
  2594.         -- make sure it starts with a letter
  2595.                 case tmp[0]
  2596.                     when '0','1','2','3','4','5','6','7','8','9','_' then
  2597.                         tmp:=#FSTR+"S"+tmp;
  2598.                     else
  2599.                 end;
  2600.         res:=tmp.str;
  2601.         -- truncate if too long
  2602.                 if res.length>20 then res:=res.head(16); end;
  2603.                 -- make sure it's unique
  2604.                 loop while!(mangleset.test(res) or forbidden.test(res));
  2605.                     -- not unique, better mangle more
  2606.                     res:=res.head(16.min(res.length))+'_'+counter;
  2607.                     counter:=counter+1;
  2608.                     end;
  2609.                 end;
  2610.             mangleset:=mangleset.insert(res);
  2611.         assert mangleset.test(res);
  2612.             manglemap:=manglemap.insert(ob,res);
  2613.         end;
  2614.     assert manglemap.test(ob);
  2615.     assert mangleset.test(res);
  2616.         return res;
  2617.     end;
  2618.  
  2619.     Cify(c:CHAR):STR is
  2620.     -- return an escaped version of c suitable for C.
  2621.     res::="";
  2622.     case c
  2623.          when 'a','b','c','d','e','f','g',
  2624.           'h','i','j','k','l','m',
  2625.           'n','o','p','q','r','s','t',
  2626.           'u','v','w','x','y','z',
  2627.           '0','1','2','3','4','5','6',
  2628.           '7','8','9',
  2629.           'A','B','C','D','E','F','G',
  2630.           'H','I','J','K','L','M',
  2631.           'N','O','P','Q','R','S','T',
  2632.           'U','V','W','X','Y','Z',
  2633.           '!','@','#','$','%','^','&',
  2634.           '*','(',')','-','=','+',
  2635.           '|',':',';','`','~','_',' ',
  2636.           ',','.','<','>','/','?','[',
  2637.           ']','{','}' then -- an acceptable character
  2638.               res:=res+c;
  2639.         --when '\a' then
  2640.         --    res:=res+"\\a";
  2641.         when '\b' then
  2642.         res:=res+"\\b";
  2643.         when '\f' then
  2644.         res:=res+"\\f";
  2645.         when '\n' then
  2646.         res:=res+"\\n";
  2647.         when '\r' then
  2648.         res:=res+"\\r";
  2649.         when '\t' then
  2650.         res:=res+"\\t";
  2651.         when '\v' then
  2652.         res:=res+"\\v";
  2653.         when '\\' then
  2654.         res:=res+"\\\\";
  2655.         when '\'' then
  2656.         res:=res+"\\'";
  2657.         when '\"' then
  2658.         res:=res+"\\\"";
  2659.         else -- must give octal
  2660.         oc:STR:=c.int.octal_str;
  2661.         oc:=oc.substring(2,oc.length-2);
  2662.         res:=res+'\\'+oc;
  2663.     end; -- case
  2664.     return res;
  2665.     end;
  2666.  
  2667.     Cify(arg:STR):STR is
  2668.     -- transform a string into a '\' escaped version suitable for C.
  2669.  
  2670.         res::=#FSTR;
  2671.     loop res:=res+Cify(arg.elt!);
  2672.     end;
  2673.         return res.str;
  2674.     end;
  2675.  
  2676.     enforce_tag(tp:$TP, tag:INT) is
  2677.     -- See to it that a particular type receives a particular tag.
  2678.  
  2679.         if tags.test(tp) then
  2680.         if tags.get(tp)/=tag then
  2681.         barf("Couldn't enforce tag for "+tp.str);
  2682.         end;
  2683.     end;
  2684.         tags:=tags.insert(tp,tag);
  2685.     end;
  2686.  
  2687.     -- private
  2688.     attr pos_tag_count:INT;
  2689.     attr neg_tag_count:INT;
  2690.  
  2691.     num_tag_for(tp:$TP):INT is
  2692.     -- Numeric tag corresponding to a particular type.  If not known,
  2693.     -- make a new one.
  2694.  
  2695.         tag:INT;
  2696.     if ~tags.test(tp) then
  2697.         if tp.is_value then    
  2698.                 tag:= -neg_tag_count; 
  2699.                 neg_tag_count:=neg_tag_count+1;
  2700.         else tag:= pos_tag_count; pos_tag_count:=pos_tag_count+1;
  2701.         end;
  2702.         tags:=tags.insert(tp,tag);
  2703.     else tag:=tags.get(tp);
  2704.     end;
  2705.     return tag;
  2706.     end;
  2707.  
  2708.     tag_for(tp:$TP):STR is
  2709.     -- Expression corresponding to a particular type.  If not known,
  2710.     -- make a new one.
  2711.         
  2712.     dummy:INT:=num_tag_for(tp);      -- make sure gets entered into table
  2713.     res::=mangle(tp)+"_tag";
  2714.     forbid(res);
  2715.         return res;
  2716.     end;
  2717.     
  2718.  
  2719. end; -- BE
  2720.  
  2721. class BE_LEX is
  2722.  
  2723.     private attr lex_state:INT; 
  2724.         -- 0 for default, 1 for in comment, 2 for in string
  2725.     private attr buf:FSTR;
  2726.     -- contents of the file being parsed
  2727.     private attr pos:INT;
  2728.     -- current read position
  2729.     private attr name:STR;
  2730.     -- Name of the file
  2731.  
  2732.     create(s:STR):SAME is
  2733.         res::=new;
  2734.     res.name:=s;
  2735.         f::=FILE::open_for_read(s);
  2736.         if f.error then barf("Couldn't open system file "+s); end;
  2737.         res.lex_state:=0;
  2738.     res.buf:=f.fstr;
  2739.     res.pos:=0;
  2740.         return res;
  2741.     end;
  2742.  
  2743.     get_str:STR is
  2744.     -- ignore comments and whitespace and read in a "-delimited string.
  2745.     -- When the last string has been read, this returns void.
  2746.  
  2747.     c:CHAR;
  2748.     tmp::=#FSTR;
  2749.  
  2750.     loop
  2751.         until!(pos>=buf.size);
  2752.         c:=buf[pos];
  2753.         pos:=pos+1;
  2754.         case lex_state
  2755.                 when 0 then
  2756.             case c
  2757.             when '-' then lex_state:=1;
  2758.             when '\"' then lex_state:=2;
  2759.             when '\n',' ','\t','\r','\\' then
  2760.             else barf("Illegal character "+c.pretty
  2761.                         +" in input file "+name);
  2762.             end;
  2763.         when 1 then
  2764.             case c
  2765.             when '\n','\r' then lex_state:=0;
  2766.             else 
  2767.             end;
  2768.         when 2 then
  2769.             case c 
  2770.             when '\"' then lex_state:=0; return tmp.str;
  2771. --            when '\\' then -- ignore backslashes               -- NLP
  2772.             else tmp:=tmp+c;
  2773.             end;
  2774.         else barf("Unknown lex state in back end");
  2775.         end;
  2776.     end;
  2777.         return void;
  2778.     end;
  2779.  
  2780.     elt!:STR is
  2781.         loop
  2782.             s::=get_str;
  2783.             if void(s) then quit;
  2784.             else yield s;
  2785.             end;
  2786.         end;
  2787.     end;
  2788.  
  2789.     barf(msg:STR) is
  2790.     #ERR + msg + '\n';
  2791.     UNIX::exit(1);
  2792.     end;
  2793.  
  2794. end; -- BE_LEX
  2795.  
  2796. class ITER_INLINE is
  2797.     attr at_decs, when_first_seen, before, after:STR;
  2798.  
  2799.     create(s1,s2,s3,s4:STR):SAME is
  2800.     res::=new;
  2801.     res.at_decs:=s1;
  2802.     res.when_first_seen:=s2;
  2803.     res.before:=s3;
  2804.     res.after:=s4;
  2805.     return res;
  2806.     end;
  2807. end;
  2808.