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

-- prog.sa: Classes relating to entire Sather programs.
-------------------------------------------------------------------
-- PROG: The most common program object.
-- $PROG_ERR:Parent for classes which can identify error locations.
-- PROG_AS_TBL: Table mapping a classname idents to source trees.
-- CS_COMPONENT: Included by those who want delegated access to prog.
-------------------------------------------------------------------
class PROG  is

-- These tables are shared by the different phases of the compiler.

    attr benchmark:BOOL;	-- true if only running benchmarks
				-- prevents the write of C files, but
				-- the files are still generated in memory
    attr config:CONFIG_TBL;	-- the configuration table 
    attr tp_tbl:TP_TBL;		-- The type table.
    attr tp_graph:TP_GRAPH;	-- The type graph. 
    attr tp_graph_abs_des:TP_GRAPH_ABS_DES; -- Abstract descendants.
    attr tp_done:FSET{$TP};	-- Table of types which have already
    -- been examined to get other types.      
    attr as_tbl:PROG_AS_TBL;	-- The table of code trees.
    attr stat:$STAT;		-- used to gather statistics;

-- These objects control the various stages of compilation.
-- See the file `stages.sa' for their interfaces.

    attr get_options:$GET_OPTIONS;
    attr parse:$PARSE;		
    attr find_types:$FIND_TYPES;
    attr find_generics:FIND_GENERICS; -- *H*
    attr build_type_graph:$BUILD_TYPE_GRAPH; 
    attr check_ifc_conformance:$CHECK_IFC_CONFORMANCE;
    attr get_main_sig:$GET_MAIN_SIG;
    attr generate_am:$GENERATE_AM;
    attr inliner:$INLINE;
    attr optimizer:$OPTIMIZE;
    attr back_end:$BACK_END;
    attr check_am:$CHECK_AM;
    attr check_gen:CHECK_GENERICS; -- *H*

    attr is_check_am:BOOL; -- true during check am stage
-- These are general options.  Other options are found in the
-- components which need them.

    attr sather_files:FSET{STR};     -- Sather source files
    attr main_class:STR;             -- The class with main
    attr home:STR;		     -- home
    attr verbose:BOOL;	             -- Be noisy
    attr print_version:BOOL;         -- Prints info about compiler version. etc
    attr prolix:BOOL;                -- Be really noisy
    attr platforms:FLIST{STR};	     -- list of platforms to be used
    attr genuine_platforms:INT;	     -- counter, incremented each time a "real" platform (as
				     -- opposed to bogus platforms like -gui) is used.
				     -- At most one real platfomr can be specified.
    attr boot:BOOL;		     -- true if a boot compiler is beeing generated
    attr threads:BOOL;		     -- Accept pSather code and generate code for one cluster
    attr distributed:BOOL;		     -- Accept pSather code and generate code for more than one cluster
    psather:BOOL is return threads or distributed; end;
    attr zones:BOOL;		     -- use zones
    attr trace:BOOL;
    attr arch:STR;		     -- Architecture to compile for (pSather only)
    attr opt_debug:BOOL;	     -- print out optimizer debug info
    attr opt_verbose:BOOL;	     -- print out opt. info
    attr opt_debug_func:FLIST{STR};  -- if not void only functions with a signature that contains one of these strings are "opt_debuggged"
    attr inline_iters:BOOL;	     -- true if iters are to be inlined
    attr inline_routs:BOOL;	     -- true if routines are to be inlined
    attr hoist_const:BOOL;	     -- true if loop constants should be hoisted
   attr yields_in_locks:BOOL;       -- true if yields in locks should be optimized 
   attr locks_on_stack:BOOL;        -- true if locks that don't have to be on the exc. stack should not be put there
   attr fast_fork:BOOL;              -- is true, attempt to optimize special 
   -- cases of fork
   attr fast_at1:BOOL;               -- optimizes special cases ofr @ expr
   attr fast_at2:BOOL;               -- as above, but more agrressively so
   attr warnings:BOOL;               -- if true, print out all warnings
    attr move_while:BOOL;	     -- true if while!/until! have to be moved to the end of loops
    attr hoist_iter_init:BOOL;	     -- true if the initialization of iters has to be hoisted
    attr pre_checks:BOOL;	     -- true if at least one class makes pre checks
    attr post_checks:BOOL;	     -- true if at least one class makes post checks
    attr assert_checks:BOOL;	     -- true if at least one class makes assert checks
    attr arith_checks:BOOL;	     -- true if at least one class makes arith. checks
   attr void_checks:BOOL;	     -- true if at least one class makes void access checks
   attr chk_no_line_numbers:BOOL;  -- If true, chk/assertion failures
   -- do not print out source locations. Improves incrementality
    


-- These attributes are used to control debugging output.

    attr show_parse_file:BOOL;	-- Show files parsed.
    attr show_tr:BOOL;           -- Show TR.
    attr show_as_insert:BOOL;	-- Show trees inserted.
    attr show_impl_create:BOOL;	-- Show when an impl is created.
    attr show_ifc_abs_create:BOOL; -- Show when abstract ifc's are created.
    attr show_include:BOOL;	-- Show when an include is processed.
    attr show_types:BOOL;	-- Show all types found.
    attr show_graphs:BOOL;	-- Show the type graphs.
    attr show_ifc:BOOL;		-- Show all interfaces.
    attr show_main:BOOL;		-- Show the main sig.
    attr show_generated_sig:BOOL; -- Show the sigs with code generated.
    attr show_am:BOOL;		-- Show the am code generated.
    attr show_checked_sig:BOOL;	-- Show the sigs as they are checked.
    attr show_am_check:BOOL;	-- Show am for for checked sigs.

   attr temp_option_fast_identifiers:BOOL; -- This option must be removed
   -- when fast identifiers are known to work !
   
   attr no_new_types: BOOL; -- True, when find_types has finished.
   -- for debugging

    -- Generic type checking options *H*
    attr trace_tp_tables: BOOL;
    -- If true, the compiler reports input into local tables.
    
    attr check_generics: BOOL;
    attr trace_generics: BOOL;
    -- True if verbose dispay of generics classes is requested.
    
    attr find_types_stage: BOOL;
    attr find_generics_stage: BOOL;
    -- Flag to indicate this stage. Used for assertions.
    -- end of *H*
    
   attr debug_mangle: BOOL;	-- False by default
   
-- These are to use in the presence of errors:   
    attr generate_checked_code:BOOL; -- Generate all code if true.
    attr all_reached:BOOL;	-- True when all reachable code emitted
   
    -- Used for collecting statistics:
    attr itercounts:ARRAY{INT};
    attr hotcounts:ARRAY{INT};
    attr loops_seen:FSET{SFILE_ID};

    create:SAME is
	-- A new program object.  All the components have to be filled
	-- in from outside, after creation.
	r::=new; 
	IDENT_BUILTIN::init;
	return r;
    end;
    

-- The following routines handle error messages.
    
    attr eloc:SFILE_ID;		-- Current error location.
    attr err_seen:BOOL;		-- True if an error has been seen.
    attr err_list:FLIST{SFILE_ID};
    
    
    err_loc(t:$PROG_ERR) is
	-- Make the node held by 
	-- `t' be the culprit for the next error, if any. If `t' is void, 
	-- then don't print a location with the next message.
	if void(t) then eloc:=void; return end;
	eloc:=t.source end;
    
    set_eloc(l:SFILE_ID) is
	-- Set `eloc' to `l'.
	eloc:=l end;

    err(s:STR) is
	-- Report an error with `s' as the error
	-- string and the last tree node given to `err_loc' as the 
	-- location. This string shouldn't have information like "Error" 
	-- and should be an unformatted line of text. It should be a 
	-- complete sentence beginning with a capital letter and ending 
	-- with a period.  If this is called during a compile, source code
	-- will not be generated, but the compile will proceed as far as 
	-- possible.

	if verbose and ~err_seen then #OUT + '\n'; end;
	
	err_seen:=true;
	if ~void(eloc) then if err_loc_old(eloc) then return end end;
	if ~void(eloc) then #OUT + eloc.str + ": " end;
	#OUT + s + "\n";
    end;

    warning(s:STR) is
	-- Report a warning.  Like an error, but doesn't stop compile.
	-- In general, our philosophy is that warnings are poor compiler
	-- interface and their use should be avoided.
	-- if ~void(eloc) then if err_loc_old(eloc) then return end end;
	if ~void(eloc) then #OUT + eloc.str + ": " end;
	#OUT + "WARNING: " + s + "\n" end;
   
   message(s:STR) is
      -- A friendly compiler message 
	if ~void(eloc) then #OUT + eloc.str + ": " end;
	#OUT + "MESSAGE: " + s + "\n" end;   

    err_loc_old(l:SFILE_ID):BOOL is
	-- Return true if `l' has been seen before, otherwise add
	-- it to the list.
	i::=0;
	if void(err_list) then err_list:=err_list.push(l); return false end;
	loop while!(i<err_list.size);
	    if l=err_list[i] then return true end;
	    i:=i+1 end;
	err_list:=err_list.push(l);
	return false end;

    barf(msg:STR) is barf_at(msg,void); end;
    -- Something wrong within the compiler, but we can't say where.

    barf_at(msg:STR,at:$PROG_ERR) is
	-- Something wrong, and we know where.
	err_loc(at);
	err("Internal compiler error: "+msg);
	UNIX::exit(1);  -- Why bother continuing?  Something's very wrong.
    end;

end; -- class PROG

-------------------------------------------------------------------
abstract class $PROG_ERR is
    -- Parent class for classes which can identify error locations.
    
    source:SFILE_ID; -- The origin of a node in a Sather 
    -- source file.
end; 
    
-------------------------------------------------------------------
class PROG_AS_TBL is
    -- Table mapping a classname idents to source trees.
    -- 
    -- `get_query(TUP{IDENT,INT}):AS_CLASS_DEF' looks up a class.
    -- `test_query(TUP{IDENT,INT}):BOOL' tests for a class.
    -- `test(AS_CLASS_DEF):BOOL' tests for a tree.      
    -- `insert(AS_CLASS_DEF):SAME' inserts a tree.
    -- `delete(AS_CLASS_DEF):SAME' deletes a tree.
    include FQSET{TUP{IDENT,INT},AS_CLASS_DEF};

    query_test(q:TUP{IDENT,INT}, t:AS_CLASS_DEF):BOOL is
	-- True if `t' is the type described by `q'.
	if void(t) then return false end;
	if q.t1/=t.name then return false end;
	if q.t2/=t.params.size then return false end;
	return true end;

    query_hash(q:TUP{IDENT,INT}):INT is
	-- A hash value computed from the query types.
	return q.t1.hash+1111*q.t2 end;

    elt_hash(e:AS_CLASS_DEF):INT is
	-- Hash on the types in `e'.
	return e.name.hash+1111*e.params.size end;
    
-- Output of TR for debugging purposes
    as_out(p:PROG) is
	AS_OUT::prog:=p;
	loop
	    classdef ::= elt!;
	    -- only print out those that are not in has map.
	    fn::=classdef.source.file_in;
	    parse ::= p.parse;
	    typecase parse
	    when PARSE then
		if ~parse.known_files.test(fn) then
		    AS_OUT::AS_NODE_out(classdef);
		end;
	    else
	    end;
	end;
    end;

    dump is
        loop
            classdef ::= elt!;
            res ::= classdef.name.str + "{";
            param ::= classdef.params;
            loop until!(void(param));
               res := res + ",".separate!(param.name.str);
               param := param.next
            end;
            #OUT + res + "}\n";
        end
    end;
    
end; -- class PROG_AS_TBL
-------------------------------------------------------------------
class CS_COMPONENT is
    -- gives delegated access to the central PROG object.

    attr prog:PROG;

    barf(msg:STR) is prog.barf(msg); end;
    -- Something wrong within the compiler, but we can't say where.

    barf_at(msg:STR,at:$PROG_ERR) is prog.barf_at(msg,at); end;
    -- Something wrong, and we know where.

    err(s:STR) is prog.err(s); end;
    -- Report an error.

    err_loc(t:$PROG_ERR) is prog.err_loc(t); end;
    -- Set where a future error should be reported at.

    warning(s:STR) is prog.warning(s); end;
    -- report a warning (doesn't stop compile);

    message(s:STR) is prog.message(s); end;
end;

