home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / sa104os2.zip / SATHR104.ZIP / SATHER / COMPILER / PROG.SA < prev    next >
Text File  |  1995-02-13  |  34KB  |  859 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. -- prog5.sa: Classes relating to entire Sather programs.
  9. -------------------------------------------------------------------
  10. -- PROG: The most common program object.
  11. -- $PROG_ERR:Parent for classes which can identify error locations.
  12. -- PROG_TR_TBL: Table mapping a classname idents to source trees.
  13. -- PROG_PARSE: All files are parsed and tree forms built.
  14. -- PROG_FIND_TYPES: Find all possible types in the program.
  15. -- PROG_TYPE_GRAPH: Build the type graph of all types.
  16. -- PROG_IFC_CONFORMANCE: Check the conformance of interfaces.
  17. -- PROG_GET_MAIN: Determine the signature of main.
  18. -- PROG_AM_GENERATE: Generate the AM form.
  19. -- PROG_AM_CHECK: Check any remaining code.
  20. -------------------------------------------------------------------
  21. class PROG  is
  22.  
  23.    attr ident_tbl:IDENT_TBL;
  24.    attr tp_tbl:TP_TBL;        -- The type table.
  25.    attr tp_builtin:TP_BUILTIN;    -- Built-in types.
  26.    attr ident_builtin:IDENT_BUILTIN; -- Built-in identifiers.   
  27.    attr tp_graph:TP_GRAPH;    -- The type graph. 
  28.    attr tp_graph_abs_des:TP_GRAPH_ABS_DES; -- Abstract descendants.
  29.    attr impl_tbl:IMPL_TBL;    -- The implementation table for this 
  30.       -- program. These entries may take a lot of space and so may be
  31.       -- deleted whenever space is needed. They can be regenerated 
  32.       -- without adverse affects on the rest of the compiler.
  33.    attr ifc_tbl:IFC_TBL;    -- The table of class interfaces.   
  34.    attr global_tbl:GLOBAL_TBL;    -- Table of globals for this program.
  35.    attr prog_parse:PROG_PARSE;    -- The code trees.
  36.    attr prog_find_types:PROG_FIND_TYPES; -- Find the types.
  37.    attr prog_type_graph:PROG_TYPE_GRAPH; -- Build the type graph. 
  38.    attr prog_ifc_conformance:PROG_IFC_CONFORMANCE; -- Check interfaces.
  39.    attr prog_get_main:PROG_GET_MAIN; -- Get main.
  40.    attr prog_am_generate:PROG_AM_GENERATE; -- Generate code.
  41.    attr prog_am_check:PROG_AM_CHECK; -- Check the remainder.
  42.    attr show_parse_file:BOOL;    -- Show files parsed.
  43.    attr show_tr_insert:BOOL;    -- Show trees inserted.
  44.    attr show_impl_create:BOOL;    -- Show when an impl is created.
  45.    attr show_ifc_abs_create:BOOL; -- Show when abstract ifc's are created.
  46.    attr show_include:BOOL;    -- Show when an include is processed.
  47.    attr show_types:BOOL;    -- Show all types found.
  48.    attr show_graphs:BOOL;    -- Show the type graphs.
  49.    attr show_ifc:BOOL;        -- Show all interfaces.
  50.    attr show_main:BOOL;        -- Show the main sig.
  51.    attr show_generated_sig:BOOL; -- Show the sigs with code generated.
  52.    attr show_am:BOOL;        -- Show the am code generated.
  53.    attr show_checked_sig:BOOL;    -- Show the sigs as they are checked.
  54.    attr show_am_check:BOOL;    -- Show am for for checked sigs.
  55.       -- These are to use in the presence of errors:   
  56.    attr generate_checked_code:BOOL; -- Generate all code if true.
  57.    attr back_end:BE;            -- The back end
  58.    attr options:OPTIONS;    -- Command line options
  59.    attr all_reached:BOOL;    -- True when all reachable code emitted
  60.    
  61.    create:SAME is
  62.       -- A new program object.
  63.       r::=new; 
  64.       r.options:=#OPTIONS;
  65.       r.tp_tbl:=#(r);
  66.       r.tp_builtin:=#(r);
  67.       r.ident_builtin:=#(r);
  68.       r.tp_graph:=#(r);
  69.       r.tp_graph_abs_des:=#(r);
  70.       r.impl_tbl:=#(r);
  71.       r.ifc_tbl:=#(r);
  72.       r.global_tbl:=#(r);
  73.       r.prog_parse:=#(r);
  74.       r.prog_find_types:=#(r);
  75.       r.prog_type_graph:=#(r);
  76.       r.prog_ifc_conformance:=#(r);
  77.       r.prog_get_main:=#(r);
  78.       r.prog_am_generate:=#(r);
  79.       r.prog_am_check:=#(r);
  80.       return r end;
  81.  
  82.    do_find_types_phase is
  83.       -- Find all types in the program, assuming the parse phase has
  84.       -- completed without error.
  85.       prog_find_types.find_types end;
  86.    
  87.    do_type_graph_phase is
  88.       -- Build the type graphs, assuming the find types phase has
  89.       -- completed without error.
  90.       prog_type_graph.build_graphs end;
  91.  
  92.    do_ifc_conformance_phase is
  93.       -- Check interfaces for conformance with parents and children.
  94.       prog_ifc_conformance.check_ifc_conformance end;
  95.    
  96.    do_get_main_phase(nm:STR) is
  97.       -- Do the get main phase for class name `nm'.
  98.       prog_get_main.get_main_sig(nm) end;
  99.    
  100.    do_am_generate_phase is
  101.       -- Generate the code.
  102.       prog_am_generate.am_generate end;
  103.  
  104.    do_am_check_phase is
  105.       -- Check any remaining code for types etc.
  106.       all_reached:=true;
  107.       prog_am_check.check_code end;
  108.    
  109.    am_ob_def_for_tp(tp:$TP):AM_OB_DEF is
  110.       -- The object layout for the type `tp'.
  111.       impl::=impl_tbl.impl_of(tp);
  112.       if void(impl) then return void end;
  113.       return impl.am_ob_def end;
  114.    
  115.    ident_for(s:STR):IDENT is
  116.       -- The identifier corresonding to the string `s'.
  117.       i::=ident_tbl.get_query(s); 
  118.       if void(i) then i:=#(s); 
  119.      ident_tbl:=ident_tbl.insert(i) end; 
  120.       return i end;
  121.    
  122.    abs_subtype_test(t:$TP, at:TP_CLASS):BOOL
  123.       -- Return true if the type `t' is a subtype of the type `at'.
  124.       -- `at' must be abstract.
  125.       pre at.is_abstract is
  126.       return tp_graph.abs_subtype_test(t,at) end;
  127.  
  128.    descendants_of_abs(t:TP_CLASS):FSET{$TP} is
  129.       -- A table of the concrete descendants of the abstract type `t'.
  130.       if ~void(tp_graph_abs_des) then 
  131.      return tp_graph_abs_des.des_of(t) 
  132. --    else return void end end;                                                 -- NLP
  133.       end; return void; end;                                                    -- NLP
  134.    
  135.    pnames_for(t:TP_CLASS):ARRAY{IDENT} 
  136.       -- An array of the parameter names for the type `t'. Void if none.
  137.       pre ~void(t) is
  138.       tr::=tree_for(t.name,t.params.size);
  139.       if void(tr) then return void end;
  140.       if void(tr.params) then return void end;
  141.       r::=#ARRAY{IDENT}(tr.params.size);
  142.       pd:TR_PARAM_DEC:=tr.params; i:INT:=0;
  143.       loop until!(void(pd)); r.set!(pd.name); pd:=pd.next end;
  144.       return r end;
  145.    
  146.    tp_context_for(t:TP_CLASS):TP_CONTEXT 
  147.       -- The type context appropriate for the body of `t'. Void if
  148.       -- `t' is not a known type.
  149.       pre ~void(t) is
  150.       pn:ARRAY{IDENT}:=pnames_for(t);
  151.       ps:INT;
  152.       if ~void(pn) then ps:=pn.asize end;
  153.       if ps/=t.params.size then return void end;
  154.       r::=#TP_CONTEXT(t, pn, t.params, self);
  155.       if t.is_abstract then r.is_abs:=true end;
  156.       return r end;
  157.    
  158.    tp_kind(t:$TP):INT is
  159.       -- One of `TP_KIND::missing_tp', `TP_KIND::val_tp', 
  160.       -- `TP_KIND::ref_tp', `TP_KIND::abs_tp', or `TP_KIND::ext_tp',
  161.       -- `TP_KIND::rout_tp', `TP_KIND::iter_tp'. 
  162.       -- `TP_KIND::missing_tp' if no such class.
  163.       typecase t
  164.       when TP_CLASS then
  165.      tr:TR_CLASS_DEF:=prog_parse.tree_for(t.name,t.params.size);
  166.      if void(tr) then return TP_KIND::missing_tp end;
  167.      return tr.kind 
  168.       when TP_ROUT then return TP_KIND::rout_tp
  169. --    when TP_ITER then return TP_KIND::iter_tp end end;                        -- NLP
  170.       when TP_ITER then return TP_KIND::iter_tp end; return 0; end;             -- NLP
  171.  
  172.    attr eloc:SFILE_ID;        -- Current error location.
  173.    
  174.    err_loc(t:$PROG_ERR) is
  175.       -- Make the node held by 
  176.       -- `t' be the culprit for the next error, if any. If `t' is void, 
  177.       -- then don't print a location with the next message.
  178.       if void(t) then eloc:=void; return end;
  179.       eloc:=t.source end;
  180.    
  181.    set_eloc(l:SFILE_ID) is
  182.       -- Set `eloc' to `l'.
  183.       eloc:=l end;
  184.  
  185.    attr err_seen:BOOL;        -- True if an error has been seen.
  186.  
  187.    attr err_list:FLIST{SFILE_ID};
  188.    
  189.    err(s:STR) is
  190.       -- Report an error with `s' as the error
  191.       -- string and the last tree node given to `err_loc' as the 
  192.       -- location. This string shouldn't have information like "Error" 
  193.       -- and should be an unformatted line of text. It should be a 
  194.       -- complete sentence beginning with a capital letter and ending 
  195.       -- with a period.  If this is called during a compile, source code
  196.       -- will not be generated, but the compile will proceed as far as 
  197.       -- possible.
  198.       err_seen:=true;
  199.       if ~void(eloc) then 
  200.      if err_loc_old(eloc) then return end end;
  201.       if ~void(eloc) then
  202.      #OUT + eloc.str + ": " end;
  203.       #OUT + s + "\n" end;
  204.  
  205.    err_loc_old(l:SFILE_ID):BOOL is
  206.       -- Return true if `l' has been seen before, otherwise add
  207.       -- it to the list.
  208.       i::=0;
  209.       if void(err_list) then err_list:=err_list.push(l); return false end;
  210.       loop while!(i<err_list.size);
  211.      if l=err_list[i] then return true end;
  212.      i:=i+1 end;
  213.       err_list:=err_list.push(l);
  214.       return false end;
  215.       
  216.    tree_head_for(nm:IDENT, num:INT):TR_CLASS_DEF is
  217.       -- Return the code tree for the class with name `nm' and the 
  218.       -- number of type parameters `num'. Return void if no such class. 
  219.       -- This differs from `tree_for' in that the class `body' may
  220.       -- optionally be missing. Operations which only need the header
  221.       -- info should call this since in some settings there may be
  222.       -- no need to parse the whole class.
  223.       return prog_parse.tree_for(nm,num) end;
  224.  
  225.    tree_sigs_for(nm:IDENT, num:INT):TR_CLASS_DEF is
  226.       -- Return the code tree for the class with name `nm' and the
  227.       -- number of type parameters `num'. Return void if no such
  228.       -- class. This differs from `tree_for' in that the "stmts"
  229.       -- clause of any routines and iters may optionally be missing. 
  230.       -- Operations which only access the signature information 
  231.       -- should call this since in some settings there may be no
  232.       -- need to parse the whole class.
  233.       return prog_parse.tree_for(nm,num) end;      
  234.    
  235.    tree_for(nm:IDENT, num:INT):TR_CLASS_DEF is
  236.       -- Return the code tree for the class with name `nm' and the
  237.       -- number of type parameters `num'. Return void if no such class.
  238.       return prog_parse.tree_for(nm,num) end;      
  239.  
  240.    output_am_rout_def(a:AM_ROUT_DEF) is
  241.       -- Do whatever is necessary to output the routine definition `a'.
  242.       -- This is the main connection to the backend. 
  243.       if ~all_reached and ~options.only_check then
  244.       back_end.output_am_rout_def(a)
  245.       end;
  246.    end;
  247.  
  248.    create_back_end is
  249.       -- Start up back-end.  Must occur after tp_tbl has been filled in.
  250.       back_end:=#BE(self);
  251.    end;
  252.  
  253.    finalize_back_end is
  254.       -- Conclude code generation, invoking C compiler etc.
  255.       if ~options.only_check then back_end.finalize end;
  256.    end;
  257.    
  258. end; -- class PROG
  259.  
  260. -------------------------------------------------------------------
  261. type $PROG_ERR is
  262.    -- Parent class for classes which can identify error locations.
  263.    
  264.    source:SFILE_ID; -- The origin of a node in a Sather 
  265.       -- source file.
  266. end; 
  267.    
  268. -------------------------------------------------------------------
  269. class PROG_TR_TBL is
  270.    -- Table mapping a classname idents to source trees.
  271.    -- 
  272.    -- `get_query(TUP{IDENT,INT}):TR_CLASS_DEF' looks up a class.
  273.    -- `test_query(TUP{IDENT,INT}):BOOL' tests for a class.
  274.    -- `test(TR_CLASS_DEF):BOOL' tests for a tree.      
  275.    -- `insert(TR_CLASS_DEF):SAME' inserts a tree.
  276.    -- `delete(TR_CLASS_DEF):SAME' deletes a tree.
  277.    include FQSET{TUP{IDENT,INT},TR_CLASS_DEF};
  278.  
  279.    query_test(q:TUP{IDENT,INT}, t:TR_CLASS_DEF):BOOL is
  280.       -- True if `t' is the type described by `q'.
  281.       if void(t) then return false end;
  282.       if q.t1/=t.name then return false end;
  283.       if q.t2/=t.params.size then return false end;
  284.       return true end;
  285.  
  286.    query_hash(q:TUP{IDENT,INT}):INT is
  287.       -- A hash value computed from the query types.
  288.       return q.t1.hash+1111*q.t2 end;
  289.  
  290.    elt_hash(e:TR_CLASS_DEF):INT is
  291.       -- Hash on the types in `e'.
  292.       return e.name.hash+1111*e.params.size end;
  293.       
  294. end; -- class PROG_TR_TBL
  295.  
  296. -------------------------------------------------------------------
  297. class PROG_PARSE is
  298.    -- The phase in which all files are parsed and tree forms built.
  299.    -- This phase catches both syntactic errors and multiply defined
  300.    -- classes. 
  301.  
  302.    attr prog:PROG;        -- The program
  303.    attr tr_tbl:PROG_TR_TBL;    -- The table of code trees.
  304.    attr parsed:FSET{STR};    -- Table of already parsed files.
  305.    
  306.    create(p:PROG):SAME is
  307.       r::=new; r.prog:=p; return r end;
  308.  
  309.    tree_for(nm:IDENT, num:INT):TR_CLASS_DEF is
  310.       -- Return the code tree for the class with name `nm' and the 
  311.       -- number of type parameters `num'. Return void if no such class. 
  312.       r::=tr_tbl.get_query(#(nm,num));
  313.       if void(r) then
  314.      -- If we haven't found it, try the -has files
  315.      fn::=prog.options.has.get(nm.str);
  316.      if ~void(fn) then
  317.          parse(fn);
  318.          r:=tr_tbl.get_query(#(nm,num));
  319.      end;
  320.       end;
  321.       if void(r) then
  322.      prog.err("There is no class with name " + nm.str + " and " +
  323.         num + " parameters.")
  324.       end;
  325.       return r;
  326.    end;
  327.    
  328.    parse(f:STR) is
  329.       -- Tell the parser to parse the file `f', put the tree in
  330.       -- `tr_tbl'.
  331.  
  332.       if parsed.test(f) then return; end;
  333.       parsed:=parsed.insert(f);
  334.       if prog.show_parse_file then 
  335.      #OUT + "(Parse " + f + ") " end;
  336.       parser ::= #PARSER(prog, f, prog.options.psather);
  337.       if ~void(parser) then
  338.          tcd: TR_CLASS_DEF := parser.source_file;
  339.          loop until!(void(tcd)); 
  340.             if prog.show_tr_insert then
  341.            #OUT + "(Tree for " + tcd.name.str + ") " end;
  342.             ntcd:TR_CLASS_DEF:=tcd.next; tcd.next:=void;
  343.         hf::=prog.options.has.get(tcd.name.str);
  344.             if tr_tbl.test_query(#(tcd.name,tcd.params.size)) 
  345.            or (~void(hf) and hf/=f) then
  346.            dup_class_err(tcd)
  347.             else tr_tbl:=tr_tbl.insert(tcd) end; 
  348.             tcd:=ntcd end end end;
  349.  
  350.    dup_class_err(tcd:TR_CLASS_DEF) is
  351.       prog.err_loc(tcd);
  352.       prog.err("There are two classes with the name " + tcd.name.str +
  353.       " and " + tcd.params.size + " parameters.") end;
  354.    
  355. end; -- class PROG_PARSE
  356.  
  357. -------------------------------------------------------------------
  358. class PROG_FIND_TYPES is
  359.    -- This is the phase which finds all possible types in the program.
  360.    -- It starts from the non-parameterized types parsed in the first 
  361.    -- phase. It produces an IMPL for each such type and determines all
  362.    -- types mentioned within it. If any of these types is missing or if
  363.    -- any of the builtin types is missing an error is signalled
  364.    -- and compilation ends. It causes errors for overloaded name
  365.    -- conflicts.
  366.    attr prog:PROG;        -- The program.
  367.    attr err_names:FSET{IDENT};    -- Erroneous names already reported.
  368.    attr tp_todo:FSET{$TP};    -- Table of types which must still be
  369.       -- examined to get other types. 
  370.    attr tp_done:FSET{$TP};    -- Table of types which have already
  371.       -- been examined to get other types.      
  372.    attr con:TP_CONTEXT;        -- Context in which to interpret types.
  373.    
  374.    create(p:PROG):SAME is
  375.       r::=new; r.prog:=p; return r end;
  376.  
  377.    tree_for(nm:IDENT, num:INT):TR_CLASS_DEF is
  378.       -- Return the code tree for the class with name `nm' and the 
  379.       -- number of type parameters `num'. Return void if no such class. 
  380.       return prog.prog_parse.tree_for(nm,num) end;
  381.  
  382.    find_types is
  383.       -- Walk through all the code trees and find all the types referred
  384.       -- to and put them in `tp_done'. Cause errors for any types
  385.       -- referred to but not existing.
  386.       loop
  387.       got_all:BOOL:=true;
  388.       loop
  389.          tcd:TR_CLASS_DEF:=prog.prog_parse.tr_tbl.elt!;
  390.          if tcd.params.size=0 then -- Non-parameterized.
  391.         tp:TP_CLASS:=prog.tp_tbl.tp_class_for(tcd.name,void);
  392.         if ~tp_done.test(tp) then
  393.             got_all:=false;
  394.             con:=prog.tp_context_for(tp);
  395.             tp_done:=tp_done.insert(tp); -- Mark this type as done.
  396.             do_tps(tcd);    -- Do types in the header and the
  397.                -- include clauses.
  398.             if tp.is_abstract then do_abs(tcd)
  399.             else do_impl(prog.impl_tbl.impl_of(tp)) -- Do elts.
  400.             end;
  401.         end;
  402.          end;
  403.       end;
  404.       until!(got_all);
  405.       end;
  406.      -- At this point we have done all the non-parameterized 
  407.      -- classes. Now we go through `tp_todo' to see which
  408.      -- parameterizations we need.
  409.       fe:$TP:=tp_todo.first_elt;
  410.       loop while!(~void(fe)); tp_todo:=tp_todo.delete(fe);
  411.      if ~tp_done.test(fe) then -- Must be parameterized and
  412.         -- must be a class type, and must have tree for it.
  413.         ctp:TP_CLASS;
  414.         typecase fe when TP_CLASS then ctp:=fe end;
  415.         tcd:TR_CLASS_DEF:=tree_for(ctp.name,ctp.params.size);
  416.  
  417.         con:=prog.tp_context_for(ctp);
  418.         tp_done:=tp_done.insert(ctp); -- Mark this type as done.
  419.         if ~void(tcd) then
  420.            do_tps(tcd);    -- Do types in the header and the
  421.           -- include clauses.
  422.            if ctp.is_abstract then do_abs(tcd)
  423.            else do_impl(prog.impl_tbl.impl_of(ctp)) end; -- Elements.
  424.         end;
  425.      end;
  426.      fe:=tp_todo.first_elt end;
  427.       if prog.show_types then tbl_out end
  428.    end;
  429.    
  430.    process_tp(t:$TP) 
  431.       -- If there isn't a class with the right name and number of 
  432.       -- parameters for `t' and all of its subtypes, then print an
  433.       -- error if it isn't already in `err_names'. Otherwise, if
  434.       -- it is a parameterized class type and its not already in `tp_done'
  435.       -- then put it in `tp_todo'.
  436.       pre ~void(t) is
  437.       typecase t
  438.       when TP_CLASS then
  439.      nm:IDENT:=t.name; pnum:INT:=t.params.size;
  440.      if void(tree_for(nm,pnum)) then
  441.         if ~err_names.test(nm) then
  442.            prog.err("There is no source class for the type " + t.str);
  443.            err_names:=err_names.insert(nm) end;
  444.      elsif pnum>0 then    -- Is parameterized.
  445.         if ~tp_done.test(t) then -- Not done yet.
  446.            tp_todo:=tp_todo.insert(t);
  447.            i:INT:=0;
  448.            loop while!(i<pnum); process_tp(t.params[i]); 
  449.           i:=i+1 end end end;
  450.       when TP_ROUT then
  451.      if ~tp_done.test(t) then -- Not done yet.
  452.         tp_done:=tp_done.insert(t);
  453.         i:INT:=0;
  454.         if ~void(t.args) then
  455.            loop while!(i<t.args.size); process_tp(t.args[i]); 
  456.           i:=i+1 end end;
  457.         if ~void(t.ret) then process_tp(t.ret); end;
  458.      end;
  459.       when TP_ITER then 
  460.      if ~tp_done.test(t) then -- Not done yet.
  461.         tp_done:=tp_done.insert(t);
  462.         i:INT:=0;
  463.         if ~void(t.args) then
  464.            loop while!(i<t.args.size); process_tp(t.args[i]); 
  465.           i:=i+1 end end;
  466.         if ~void(t.ret) then process_tp(t.ret); end;
  467.      end end end;
  468.    
  469.    do_tps(tr:$TR_NODE) is
  470.       -- Find all the types mentioned in `tr' and interpret them via
  471.       -- `con'. If a class with the right name and number of parameters
  472.       -- doesn't exist, then print an error if the class name isn't
  473.       -- already in `err_names'. If it is a parameterized 
  474.       -- class and it's not already in `tp_done', then put it in 
  475.       -- `tp_todo'.
  476.       -- Have to do this on TR_CLASS_DEF and individual class elts
  477.       -- separately (so that includes are properly taken care of.
  478.       if void(tr) then return end;
  479.       prog.err_loc(tr);        -- Set error location.
  480.       typecase tr
  481.       when TR_CLASS_DEF then do_tps(tr.params); do_tps(tr.under); 
  482.      do_tps(tr.over); b:$TR_CLASS_ELT:=tr.body;
  483.      loop while!(~void(b));    -- Just do the "includes" here.
  484.         typecase b
  485.         when TR_INCLUDE_CLAUSE then do_tps(b) 
  486.         else end;
  487.         b:=b.next end;
  488.       when TR_PARAM_DEC then do_tps(tr.type_constraint); do_tps(tr.next);
  489.       when TR_TYPE_SPEC then process_tp(con.tp_of(tr)); do_tps(tr.next);
  490.       when TR_CONST_DEF then do_tps(tr.tp); do_tps(tr.init); 
  491.       when TR_SHARED_DEF then do_tps(tr.tp); do_tps(tr.init); 
  492.       when TR_ATTR_DEF then do_tps(tr.tp); 
  493.       when TR_ROUT_DEF then do_tps(tr.args_dec); do_tps(tr.ret_dec);
  494.      do_tps(tr.pre_e); do_tps(tr.post_e); do_tps(tr.stmts);     
  495.       when TR_ARG_DEC then do_tps(tr.tp); do_tps(tr.next);     
  496.       when TR_INCLUDE_CLAUSE then do_tps(tr.tp); 
  497.       when TR_DEC_STMT then do_tps(tr.tp); do_tps(tr.next);
  498.       when TR_ASSIGN_STMT then do_tps(tr.lhs_expr); do_tps(tr.tp); 
  499.      do_tps(tr.rhs); do_tps(tr.next);
  500.       when TR_IF_STMT then do_tps(tr.test); do_tps(tr.then_part); 
  501.      do_tps(tr.else_part); do_tps(tr.next);
  502.       when TR_LOOP_STMT then do_tps(tr.body); do_tps(tr.next);
  503.       when TR_RETURN_STMT then do_tps(tr.val); do_tps(tr.next);
  504.       when TR_YIELD_STMT then do_tps(tr.val); do_tps(tr.next);
  505.       when TR_QUIT_STMT then do_tps(tr.next);
  506.       when TR_CASE_STMT then do_tps(tr.test); do_tps(tr.when_part); 
  507.      do_tps(tr.else_part); do_tps(tr.next);
  508.       when TR_CASE_WHEN then do_tps(tr.val); do_tps(tr.then_part); 
  509.      do_tps(tr.next);
  510.       when TR_TYPECASE_STMT then do_tps(tr.when_part); 
  511.      do_tps(tr.else_part); do_tps(tr.next);     
  512.       when TR_TYPECASE_WHEN then do_tps(tr.tp); do_tps(tr.then_part); 
  513.      do_tps(tr.next); 
  514.       when TR_ASSERT_STMT then do_tps(tr.test); do_tps(tr.next);
  515.       when TR_PROTECT_STMT then do_tps(tr.stmts); do_tps(tr.when_part); 
  516.      do_tps(tr.else_part); do_tps(tr.next);
  517.       when TR_PROTECT_WHEN then do_tps(tr.tp); do_tps(tr.then_part); 
  518.      do_tps(tr.next); 
  519.       when TR_RAISE_STMT then do_tps(tr.val); do_tps(tr.next);
  520.       when TR_EXPR_STMT then do_tps(tr.e); do_tps(tr.next);
  521.       when TR_SELF_EXPR then do_tps(tr.next);
  522.       when TR_CALL_EXPR then do_tps(tr.ob); do_tps(tr.tp); 
  523.      do_tps(tr.args); do_tps(tr.next);
  524.       when TR_VOID_EXPR then do_tps(tr.next);
  525.       when TR_IS_VOID_EXPR then do_tps(tr.arg);
  526.       when TR_ARRAY_EXPR then do_tps(tr.elts); do_tps(tr.next);
  527.       when TR_CREATE_EXPR then do_tps(tr.tp); do_tps(tr.elts); 
  528.      do_tps(tr.next);
  529.       when TR_BOUND_CREATE_EXPR then do_tps(tr.call); do_tps(tr.ret); 
  530.      do_tps(tr.next);     
  531.       when TR_UNDERSCORE_ARG then do_tps(tr.tp); do_tps(tr.next);     
  532.       when TR_AND_EXPR then do_tps(tr.e1); do_tps(tr.e2); do_tps(tr.next);
  533.       when TR_OR_EXPR then do_tps(tr.e1); do_tps(tr.e2); do_tps(tr.next);
  534.       when TR_EXCEPT_EXPR then do_tps(tr.next);
  535.       when TR_NEW_EXPR then do_tps(tr.arg); do_tps(tr.next);
  536.       when TR_INITIAL_EXPR then do_tps(tr.e); do_tps(tr.next);     
  537.       when TR_BREAK_EXPR then do_tps(tr.next);
  538.       when TR_RESULT_EXPR then do_tps(tr.next);
  539.       when TR_BOOL_LIT_EXPR then do_tps(tr.next);
  540.       when TR_CHAR_LIT_EXPR then do_tps(tr.next);
  541.       when TR_STR_LIT_EXPR then do_tps(tr.next);
  542.       when TR_INT_LIT_EXPR then do_tps(tr.next);
  543.       when TR_FLT_LIT_EXPR then do_tps(tr.next);
  544.       end end;
  545.    
  546.    do_impl(im:IMPL) is
  547.       -- Find all types in just the elements of the implementation 
  548.       -- `im'. Need to do the header and include types separately.
  549.       if void(im) then return end;
  550.       loop e:ELT:=im.elts.elt!; con:=e.con; do_tps(e.tr) end end;
  551.  
  552.    do_abs(tcd:TR_CLASS_DEF) is
  553.       -- Find all types in the body of an abstract class.
  554.       tb:$TR_CLASS_ELT:=tcd.body;
  555.       loop until!(void(tb)); do_tps(tb); tb:=tb.next end end;
  556.    
  557.    tbl_out is
  558.       -- Output the tables for debugging.
  559.       #OUT + "\n\nPROG_FIND_TYPES=";
  560.       if ~void(tp_done) then
  561.      loop #OUT + " ".separate!(tp_done.elt!.str) end end;
  562.       #OUT + "\n\n" end;
  563.    
  564. end; -- class PROG_FIND_TYPES
  565.  
  566. -------------------------------------------------------------------
  567. class PROG_TYPE_GRAPH is
  568.    -- This phase builds the type graph of the types found above. 
  569.    -- It causes errors if there are loops.
  570.    attr prog:PROG;        -- The program.
  571.    
  572.    create(p:PROG):SAME is
  573.       r::=new; r.prog:=p; return r end;
  574.    
  575.    build_graphs is
  576.       -- Build the type graphs for all types in the program.
  577.       loop tp:$TP:=prog.prog_find_types.tp_done.elt!;
  578.      typecase tp
  579.      when TP_CLASS then
  580.         ig1::=prog.tp_graph.anc.get_anc(tp);
  581.         ig2::=prog.tp_graph.des.get_des(tp)
  582.      else end end;
  583.       prog.tp_graph_abs_des.do_tbl;
  584.       if prog.show_graphs then
  585.      anc_out; des_out; abs_des_out end end;
  586.  
  587.    anc_out is
  588.       -- The ancestors of all types in `tp_done' with some.
  589.       loop tp:$TP:=prog.prog_find_types.tp_done.elt!;
  590.      at:FSET{TP_CLASS}:=void;
  591.      typecase tp
  592.      when TP_CLASS then at:=prog.tp_graph.anc.get_anc(tp) 
  593.      else end;
  594.      if ~void(at) then
  595.         #OUT + "Ancestors of " + tp.str + "=";
  596.         loop #OUT + " ".separate!(at.elt!.str) end;
  597.         #OUT + "\n" end end;
  598.       #OUT + "\n" end;
  599.       
  600.    des_out is
  601.       -- The descendants of all types in `tp_done' with some.
  602.       loop tp:$TP:=prog.prog_find_types.tp_done.elt!;
  603.      at:FSET{$TP}:=void;
  604.      typecase tp
  605.      when TP_CLASS then at:=prog.tp_graph.des.get_des(tp) 
  606.      else end;
  607.      if ~void(at) then
  608.         #OUT + "Descendants of " + tp.str + "=";
  609.         loop #OUT + " ".separate!(at.elt!.str) end;
  610.         #OUT + "\n" end end;
  611.       #OUT + "\n" end;
  612.       
  613.    abs_des_out is
  614.       -- The concrete descendants of abstract types.
  615.       loop p::=prog.tp_graph_abs_des.tbl.pairs!;
  616.      #OUT + "The abstract type " + p.t1.str +
  617.      " has concrete descendants ";
  618.      loop #OUT + " ".separate!(p.t2.elt!.str) end;
  619.      #OUT + "\n" end;
  620.       #OUT + "\n" end;
  621.    
  622. end; -- class PROG_TYPE_GRAPH
  623.    
  624. -------------------------------------------------------------------
  625. class PROG_IFC_CONFORMANCE is
  626.    -- This phase checks the conformance of interfaces for each
  627.    -- type against its parents and children.
  628.    attr prog:PROG;        -- The program.
  629.    
  630.    create(p:PROG):SAME is
  631.       r::=new; r.prog:=p; return r end;
  632.    
  633.    check_ifc_conformance is
  634.       -- Check all type interfaces for conformance to their ancestors
  635.       -- and descendants.
  636.       prog.err_loc(void);  -- Don't print a source location for these.
  637.       loop tp::=prog.prog_find_types.tp_done.elt!;
  638.      typecase tp
  639.      when TP_CLASS then
  640.         ti::=prog.ifc_tbl.ifc_of(tp);
  641.         if void(ti) then 
  642.            prog.err("Can't compute interface of "+ tp.str + ".");
  643.            return end;
  644.         if prog.show_ifc then ti.show end;
  645.         loop par:TP_CLASS:=prog.tp_graph.anc.get_parents(tp).elt!;
  646.            ncs:SIG:=ti.nonconforming_sig(prog.ifc_tbl.ifc_of(par));
  647.            if ~void(ncs) then
  648.           prog.err("The interface of type " + tp.str +
  649.           " doesn't have a signature conforming to " +
  650.           ncs.str + " in its parent " + par.str + ".") end end;
  651.         loop chld:$TP:=prog.tp_graph.des.get_children(tp).elt!;
  652.            typecase chld
  653.            when TP_CLASS then
  654.           if ~prog.ifc_tbl.ifc_of(chld).conforms_to(ti) then
  655.              prog.err("The interface of type " + tp.str +
  656.              " isn't conformed to by the child " +
  657.              chld.str + ".") end;
  658.            else break! end; -- Bail out for non-class types. 
  659.           -- Do right later.
  660.         end;
  661.      else end;
  662.       end;
  663.    end;
  664.    
  665. end; -- class PROG_IFC_CONFORMANCE
  666.  
  667. -------------------------------------------------------------------
  668. class PROG_GET_MAIN is
  669.    -- This phase determines the signature of main.
  670.    attr prog:PROG;        -- The program.
  671.    attr main_sig:SIG;        -- The signature of `main'.
  672.    
  673.    create(p:PROG):SAME is
  674.       r::=new; r.prog:=p; return r end;
  675.    
  676.    get_main_sig(nm:STR) is
  677.       -- Get the signature of the main routine in the class named `nm'
  678.       -- and put it in `main_sig'.
  679.       if void(prog.prog_parse.tree_for(prog.ident_for(nm),0)) then
  680.      prog.err_loc(void);
  681.      prog.err("There is no type " + nm + " for main."); return end;
  682.       mt::=prog.tp_tbl.tp_class_for(prog.ident_for(nm),void);
  683.       im:IMPL; im:=prog.impl_tbl.impl_of(mt);
  684.       ifc:IFC:=prog.ifc_tbl.ifc_of(mt); if void(ifc) then return end;
  685.       msig,omsig:SIG;
  686.       loop msig:=ifc.sigs.get_query!(prog.ident_builtin.main_ident);
  687.      if ~void(omsig) then
  688.         prog.err(
  689.         "There may only be one `main' routine in the main class."); 
  690.         return end;
  691.      omsig:=msig end;
  692.       if void(msig) then 
  693.      prog.err("No routine named `main' in " + ifc.tp.str + ".");
  694.      return end;
  695.       if ~void(msig.args) then
  696.      if msig.args.size/=1 or msig.args[0]/=prog.tp_builtin.arr_of_str
  697.         then prog.err("The signature of main: " + msig.str +
  698.      " doesn't have legal arguments."); return end;
  699.       elsif ~void(msig.ret) and msig.ret/=prog.tp_builtin.int then
  700.      prog.err("The signature of main: " + msig.str +
  701.      " doesn't have a legal return type."); return end;
  702.       if prog.show_main then #OUT + "Main sig=" + msig.str + "\n" end;
  703.       main_sig:=msig end;
  704.    
  705. end; -- class PROG_GET_MAIN
  706.  
  707. -------------------------------------------------------------------
  708. class PROG_AM_GENERATE is
  709.    -- This phase does a code walk from main and generates the AM form
  710.    -- It causes errors for failures of type checking, name clashes,
  711.    -- etc.
  712.    attr prog:PROG;        -- The program.
  713.    attr sig_tbl:SIG_TBL;    -- Table of signatures which have been
  714.       -- output.
  715.    attr sig_list:FLIST{SIG};    -- Signatures to still consider 
  716.       -- outputting.
  717.    attr inline_tbl:INLINE_TBL;    -- Table for inlining.
  718.  
  719.    create(p:PROG):SAME is
  720.       r::=new; r.prog:=p; r.inline_tbl:=#(p); return r end;   
  721.  
  722.    am_generate is
  723.       -- Generate all the code.
  724.       mn:SIG:=prog.prog_get_main.main_sig;
  725.       if void(mn) then return end;
  726.       if prog.show_generated_sig then 
  727.      #OUT + "Output sig " + mn.str + "\n" end;     
  728.       output_sig(mn);
  729.       output_externals_with_bodies;
  730.       loop until!(sig_list.is_empty); 
  731.      s:SIG:=sig_list.pop;
  732.      if prog.show_generated_sig then 
  733.         #OUT + "Output sig " + s.str + "\n" end;     
  734.      output_sig(s) end end;
  735.    
  736.    output_sig(s:SIG) 
  737.       -- Transform and output the signature `s' if it hasn't already
  738.       -- been done. Put the routines and iters that it calls on
  739.       -- `sig_list'. Now searches depth first on routines, so these
  740.       -- don't get put on the list.
  741.       -- Puts information in the inline table for inlining.
  742.       pre ~void(s) is
  743.       if ~void(sig_tbl.sig_eq_to(s)) then return end;
  744.       if s.tp.is_abstract then output_abs_sig(s); return end;
  745.       sig_tbl:=sig_tbl.insert(s);
  746.       elt:ELT:=prog.impl_tbl.impl_of(s.tp).elts.elt_with_sig(s);
  747.       if elt.is_external and elt.is_abstract then return end;
  748.       if void(elt) then return end;
  749.       am:AM_ROUT_DEF:=TRANS::transform_elt(elt);
  750.       if void(am) then return end;
  751.       inline_tbl:=inline_tbl.test_and_insert(am);
  752.       if prog.show_am then
  753.      #OUT + "\nAM for " + am.sig.str + "="; 
  754.      AM_OUT::AM_ROUT_DEF_out(am); #OUT + "\n" end;
  755.       i:INT;
  756.       loop while!(i<am.calls.size);
  757.      c:$AM_EXPR:=am.calls[i];
  758.      typecase c
  759.      when AM_ROUT_CALL_EXPR then 
  760.         if void(sig_tbl.sig_eq_to(c.fun)) then 
  761.            sig_list:=sig_list.push(c.fun) end;
  762.      when AM_ITER_CALL_EXPR then
  763.         if void(sig_tbl.sig_eq_to(c.fun)) then 
  764.            sig_list:=sig_list.push(c.fun) end;        
  765.      when AM_BND_CREATE_EXPR then
  766.         if void(sig_tbl.sig_eq_to(c.fun)) then
  767.            sig_list:=sig_list.push(c.fun) end;
  768.      else end; 
  769.      i:=i+1 end; 
  770.       if ~prog.err_seen then
  771.      prog.output_am_rout_def(am) end end;
  772.    
  773.    output_abs_sig(s:SIG)
  774.       -- Do the output for the abstract call `s'.
  775.       pre ~void(s) is
  776.       if ~void(sig_tbl.sig_eq_to(s)) then return end;
  777.       sig_tbl:=sig_tbl.insert(s);
  778.       am:AM_ROUT_DEF:=#AM_ROUT_DEF(1+s.args.size,void);
  779.       am.sig:=s; am.is_abstract:=true;
  780.       stp:TP_CLASS; ostp::=s.tp;
  781.       typecase ostp when TP_CLASS then stp:=ostp end;
  782.       loop tp::=prog.descendants_of_abs(stp).elt!;
  783.      ifc:IFC:=prog.ifc_tbl.ifc_of(tp);
  784.      cs:SIG:=ifc.sig_conforming_to(s); -- The call in the descendant.
  785.      sig_list:=sig_list.push(cs) end;
  786.       if prog.show_am then
  787.      #OUT + "\nAM for " + am.sig.str + "="; 
  788.      AM_OUT::AM_ROUT_DEF_out(am); #OUT + "\n" end;
  789.       if ~prog.err_seen then
  790.      prog.output_am_rout_def(am) end end;
  791.  
  792.    output_externals_with_bodies is
  793.        loop
  794.        tp::=prog.tp_tbl.class_tbl.elt!;
  795.        if tp.kind=TP_KIND::ext_tp then
  796.            et::=prog.impl_tbl.impl_of(tp).elts;
  797.            sig_tbl::=prog.ifc_tbl.ifc_of(tp).sigs;
  798.            loop
  799.            sig::=sig_tbl.elt!;
  800.            elt::=et.elt_with_sig(sig);
  801.            if ~elt.is_abstract then output_sig(sig) end;
  802.            end;
  803.        end;
  804.        end;
  805.    end;
  806.    
  807. end; -- class PROG_AM_GENERATE
  808.  
  809. -------------------------------------------------------------------
  810. class PROG_AM_CHECK is
  811.    -- Check the code for routines which aren't called, but don't output
  812.    -- any am code for them.
  813.    attr prog:PROG;        -- The program.
  814.    attr sig_tbl:SIG_TBL;    -- Table of signatures which have been
  815.       -- output.
  816.    
  817.    create(p:PROG):SAME is
  818.       r::=new; r.prog:=p; return r end;   
  819.  
  820.    check_code is
  821.       sig_tbl:=prog.prog_am_generate.sig_tbl; -- Start with those already
  822.      -- checked.
  823.       loop tp:$TP:=prog.prog_find_types.tp_done.elt!;
  824.      typecase tp
  825.      when TP_CLASS then
  826.         if ~tp.is_abstract then 
  827.            ti::=prog.ifc_tbl.ifc_of(tp);
  828.            if ~void(ti) and ~void(ti.sigs) then 
  829.           loop check_sig(ti.sigs.elt!) end;
  830.           end;
  831.            end;
  832.      else end;
  833.      end;
  834.       end;
  835.    
  836.    check_sig(s:SIG) 
  837.       -- Check `s' for errors, but only generate code for it if 
  838.       -- `generate_checked_code' is true.
  839.       pre ~void(s) is
  840.       if ~void(sig_tbl.sig_eq_to(s)) then return end; -- Already did it.
  841.       sig_tbl:=sig_tbl.insert(s); -- Mark it done.
  842.       if prog.show_checked_sig then
  843.      #OUT + "Check sig " + s.str + "\n" end;     
  844.       if s.tp.is_abstract then return end;
  845.       elt:ELT:=prog.impl_tbl.impl_of(s.tp).elts.elt_with_sig(s);
  846.       if elt.is_external and elt.is_abstract then return end;
  847.       if void(elt) then return end;
  848.       am:AM_ROUT_DEF:=TRANS::transform_elt(elt);
  849.       if void(am) then return end;
  850.       if prog.show_am_check then
  851.      #OUT + "\nCheck AM for " + am.sig.str + "="; 
  852.      AM_OUT::AM_ROUT_DEF_out(am); #OUT + "\n" end;
  853.       if prog.generate_checked_code then
  854.      prog.output_am_rout_def(am) end end;
  855.      
  856. end; -- class PROG_AM_CHECK
  857.  
  858. -------------------------------------------------------------------
  859.