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

class FIND_TYPES < $FIND_TYPES is
    -- This is the phase which finds all possible types in the program.
    -- It starts from the non-parameterized types parsed in the first 
    -- phase. It produces an IMPL for each such type and determines all
    -- types mentioned within it. If any of these types is missing or if
    -- any of the builtin types is missing an error is signalled
    -- and compilation ends. It causes errors for overloaded name
    -- conflicts.

    include CS_COMPONENT;
    
    private attr con:TP_CONTEXT;	-- Context in which to interpret types.
    
    create(p:PROG):SAME
    is
        r ::= new;
        r.prog := p;
        r.pending_includes := #;
        return r
    end;
    
    private tree_for(nm:IDENT, num:INT):AS_CLASS_DEF
        -- Return the code tree for the class with name `nm' and the 
        -- number of type parameters `num'. Return void if no such class. 
    is
        return prog.parse.tree_for(nm,num)
    end;

    find_types
        -- Walk through all the code trees and find all the types referred
        -- to and put them in `tp_done'. Cause errors for any types
        -- referred to but not existing.
    is
        -- Make sure the main class at least gets searched.
        err_loc(void);
        dummy_tree ::= tree_for( #IDENT(prog.main_class), 0 );
        dummy ::= prog.tp_tbl.tp_class_for( #IDENT(prog.main_class), void );

        -- All non parameterized classes which are NOT in the library
        -- should be parsed in any case.
        loop
	    nonlib_class ::= prog.as_tbl.elt!;
	    if prog.show_types then
	       (#OUT+"Adding non lib class:"+nonlib_class.name.str+"\n").flush;
	    end;
            if void(nonlib_class.params) then
                dummy := prog.tp_tbl.tp_class_for( nonlib_class.name, void );
            end
        end;

        loop
            -- Fetch all classes to do for the next loop.
            -- get only the ones which are not already done.
            tp_doing ::= #FSET{TP_CLASS};
            tp: TP_CLASS;

            loop
                tp := prog.tp_tbl.class_tbl.elt!;
	        if ~prog.tp_done.test(tp) then
		    if prog.show_types then
		       (#OUT+"Adding to tp_doing table:"+tp.str+"\n").flush;
		    end;
                    tp_doing := tp_doing.insert(tp);
                end;
            end;
            until!( void(tp_doing) );

            loop
                tp := tp_doing.elt!;
                if prog.show_types then
                    (#OUT+"\nfinding types in "+tp.str+"\n").flush;
                end;
		if prog.check_generics and tp.params.size>0
		then
		    -- *H* collecting all parameterized classes.
		    if prog.trace_generics then
			#ERR + "\nFinding " + tp.name.str(tp.params.size)
		    end;
		    prog.tp_tbl.register_generic(tp.name,tp.params.size);
		end;
                prog.tp_done:=prog.tp_done.insert(tp); 
		as_tree ::= tp.as_tree;
                if ~void(as_tree) then
                    con := tp.tp_context_for;
                    do_tps(as_tree)
                end;
            end;
            if 0.up! > 100 then
                -- Rather stupid detection of infinite class generation loops.
                prog.err( "Probably infinite class loop detected,"
                    " perhaps involving " + tp.str );
                break!;
            end;
        end;
    end;

    private process_tp(t:$TP) 
        -- Looks up, whether there is a tree for this class.
        -- ROUTs and ITERs are completely checked and marked as done.
        -- CLASSes are only marked in the find_types loop!
    is
        if void(t) then return end; -- A typespec error, ignore.
        if prog.tp_done.test(t) then return end; -- Already processed.
	if prog.show_types then
	   if t.str /= "STR" and t.str /= "INT" and t.str /= "FLT"
		    and t.str /= "BOOL" and t.str /= "FLTD" 
		    and t.str /= "OUT"  then
	      (#OUT+"[-"+t.str+"]").flush;
	   end;
	end;
        typecase t
        when TP_CLASS then
            -- Does not go into tp_done, as the implementation has to be
            -- checked.
            nm:IDENT:=t.name; pnum:INT:=t.params.size;
	    --assert ~t.is_generic; -- *H*
	    if t.is_generic then
		#ERR + "\nprocess_tp " + t.str + "?";
	    end;
            if ~void(t.as_tree) and pnum > 0 then
                loop process_tp(t.params[0.upto!(pnum-1)]); end
            end;
        when TP_ROUT then
            prog.tp_done:=prog.tp_done.insert(t);
            if ~void(t.args) then
                loop process_tp(t.args[0.upto!(t.args.size-1)].tp); end
            end;
            if ~void(t.ret) then process_tp(t.ret); end;
        when TP_ITER then 
            prog.tp_done:=prog.tp_done.insert(t);
            if ~void(t.args) then
                loop process_tp(t.args[0.upto!(t.args.size-1)].tp) end
            end;
            if ~void(t.ret) then process_tp(t.ret); end;
        end;
    end;
 
    private do_tps(as:$AS_NODE)
        -- Find all the types mentioned in `as' and interpret them via
        -- `con'. INCLUDE_CLAUSEs are treated specially.
    is
        as_n: $AS_NODE;
        loop
            until!(void(as));
            err_loc(as);		-- Set error location.
            typecase as
            when AS_CLASS_DEF then
                do_tps(as.params); do_tps(as.under); do_tps(as.over);
                do_tps(as.body); return
            when AS_PARAM_DEC then do_tps(as.type_constraint);
		as_n := as.next;

            -- The following typecase braches iterate within this loop
            -- in order to reduce the stack load. Note that the above
            -- branches do 'return'.
            when AS_TYPE_SPEC then prog.err_loc(as); process_tp(con.tp_of(as));
                as_n := as.next;
            when AS_INCLUDE_CLAUSE then do_include(as.tp); as_n:=as.next;

            when AS_CONST_DEF then do_tps(as.tp); do_tps(as.init);
                as_n:=as.next;
            when AS_SHARED_DEF then do_tps(as.tp); do_tps(as.init);
                as_n:=as.next;
            when AS_ATTR_DEF then do_tps(as.tp);
                as_n:=as.next;
            when AS_ROUT_DEF then do_tps(as.args_dec); do_tps(as.ret_dec);
               do_tps(as.pre_e); do_tps(as.post_e); do_tps(as.body);
               as_n:=as.next;
            when AS_STMT_LIST then do_tps(as.stmts); return
            when AS_ARG_DEC then do_tps(as.tp); as_n:=as.next;
            when AS_DEC_STMT then do_tps(as.tp); as_n:=as.next;
            when AS_ASSIGN_STMT then do_tps(as.lhs_expr); do_tps(as.tp); 
               do_tps(as.rhs); as_n:=as.next;
            when AS_IF_STMT then do_tps(as.test); do_tps(as.then_part); 
               do_tps(as.else_part); as_n:=as.next;
            when AS_LOOP_STMT then do_tps(as.body); as_n:=as.next;
            when AS_RETURN_STMT then do_tps(as.val); as_n:=as.next;
            when AS_YIELD_STMT then do_tps(as.val); as_n:=as.next;
            when AS_QUIT_STMT then as_n:=as.next;
            when AS_CASE_STMT then do_tps(as.test); do_tps(as.when_part); 
               do_tps(as.else_part); as_n:=as.next;
            when AS_CASE_WHEN then
                do_tps(as.val); do_tps(as.then_part);  as_n:=as.next;
            when AS_TYPECASE_STMT then do_tps(as.when_part); 
                do_tps(as.else_part); as_n:=as.next;
            when AS_TYPECASE_WHEN then
                do_tps(as.tp); do_tps(as.then_part);  as_n:=as.next;
            when AS_ASSERT_STMT then do_tps(as.test); as_n:=as.next;
            when AS_PROTECT_STMT then do_tps(as.body); do_tps(as.when_part); 
                do_tps(as.else_part); as_n:=as.next;
            when AS_PROTECT_WHEN then
                do_tps(as.tp); do_tps(as.then_part);  as_n:=as.next;
            when AS_RAISE_STMT then do_tps(as.val); as_n:=as.next;
            when AS_EXPR_STMT then do_tps(as.e); as_n:=as.next;
            when AS_SELF_EXPR then as_n:=as.next;
            when AS_CALL_EXPR then do_tps(as.ob); do_tps(as.tp); 
               do_tps(as.args); as_n:=as.next;
            when AS_VOID_EXPR then as_n:=as.next;
            when AS_IS_VOID_EXPR then do_tps(as.arg); as_n:=as.next;
            when AS_ARRAY_EXPR then do_tps(as.elts); as_n:=as.next;
            when AS_CREATE_EXPR then do_tps(as.tp); do_tps(as.elts); 
               as_n:=as.next;
            when AS_BOUND_CREATE_EXPR then do_tps(as.call); do_tps(as.ret); 
               as_n:=as.next;	 
            when AS_UNDERSCORE_ARG then do_tps(as.tp); as_n:=as.next;	 
            when AS_AND_EXPR then do_tps(as.e1); do_tps(as.e2); as_n:=as.next;
            when AS_OR_EXPR then do_tps(as.e1); do_tps(as.e2); as_n:=as.next;
            when AS_EXCEPT_EXPR then as_n:=as.next;
            when AS_NEW_EXPR then do_tps(as.arg); as_n:=as.next;
            when AS_INITIAL_EXPR then do_tps(as.e); as_n:=as.next;	 
            when AS_BREAK_EXPR then as_n:=as.next;
            when AS_RESULT_EXPR then as_n:=as.next;
            when AS_BOOL_LIT_EXPR then as_n:=as.next;
            when AS_CHAR_LIT_EXPR then as_n:=as.next;
            when AS_STR_LIT_EXPR then as_n:=as.next;
            when AS_INT_LIT_EXPR then as_n:=as.next;
            when AS_FLT_LIT_EXPR then as_n:=as.next;
            
            --pSather
            when AS_PAR_STMT then do_tps(as.body); as_n:=as.next;
            when AS_ATTACH_STMT then
                do_tps(as.lhs); do_tps(as.rhs); as_n:=as.next;
            when AS_LOCK_STMT then
                do_tps(as.e_list); do_tps(as.then_part); as_n:=as.next;
            when AS_LOCK_IF_WHEN then do_tps(as.val); do_tps(as.e_list);
                do_tps(as.then_part); as_n := as.next;
            when AS_UNLOCK_STMT then do_tps(as.e); as_n:=as.next;
            when AS_WITH_NEAR_STMT then
                do_tps(as.near_part); do_tps(as.else_part); as_n:=as.next;
                -- ident_list skipped (only locals, args and self)
            when AS_FORK_STMT then
                do_tps(as.at); do_tps(as.body); as_n:=as.next;
            when AS_INTERF_ATTACH_STMT then do_tps( as.at );
                as_n := as.next;
            when AS_SYNC_STMT then as_n := as.next;
            when AS_HERE_EXPR then as_n:=as.next
            when AS_WHERE_EXPR then do_tps(as.e); as_n:=as.next;
            when AS_NEAR_EXPR then do_tps(as.e); as_n:=as.next;
            when AS_FAR_EXPR then do_tps(as.e); as_n:=as.next;
            when AS_AT_EXPR then do_tps(as.e); do_tps(as.at); as_n:=as.next;
            when AS_ANY_EXPR then as_n:=as.next;
            when AS_CLUSTER_EXPR then as_n:=as.next;
            when AS_CLUSTER_SIZE_EXPR then as_n:=as.next;	       
            when AS_COHORT_EXPR then as_n:=as.next;
            when AS_GLOBAL_EXPR then as_n:=as.next
            end;
            as := as_n;
        end; -- loop
    end;

    private shared pending_includes: FLIST{TUP{IDENT,INT}};

    private cycle_error
    is
        str: STR;
        loop
            cur ::= pending_includes.elt!;
            str := str + ", ".separate!( cur.t1.str(cur.t2) );
        end;
        prog.err( "Cyclic include detected involving "+str+"." );
    end;

    do_include( inc_type: AS_TYPE_SPEC )
        -- Processing an include clause.
        -- 1.) Trying to load the syntax tree of the included type.
        --     Checking against cyclic inclusion.
        -- 2.) If included type is parameterized:
        -- 2a) Resolving the actual type parameters.
        --     This is done even if the syntax tree was not found.
        -- 2b) Retrieving the formal type parameters.
        -- 3.) Creating a new context for the syntax tree.
        -- 4.) Processing the tree.
        -- 5.) Restoring the old context.
    is
        params: ARRAY{$TP}; 
        pnames: ARRAY{IDENT};
	included_class: $TP; -- *H* is in fact a dummy variable.
	
        inc_param_c ::= inc_type.params.size;

        typeid: TUP{IDENT,INT} := #(inc_type.name, inc_param_c);
        if pending_includes.contains(typeid) then
            cycle_error;
            return;
        end;
        pending_includes := pending_includes.push(typeid);

        include_tree ::= tree_for( inc_type.name, inc_param_c );

        if inc_param_c = 0 then
	    included_class := con.tp_of(inc_type,false);
	else
            params := #ARRAY{$TP}(inc_param_c);
            inc_param ::= inc_type.params;
            loop until!(void(inc_param));
                params.set!( con.tp_of(inc_param) );
                inc_param := inc_param.next;
            end;

            if void(include_tree) then return end;

            pnames := #ARRAY{IDENT}(inc_param_c);
            tree_pnames ::= include_tree.params;
            assert tree_pnames.size = inc_param_c;
            loop until!(void(tree_pnames));
                pnames.set!( tree_pnames.name );
                tree_pnames := tree_pnames.next;
            end;
	    
	    included_class := con.tp_of(inc_type,false);
	    if prog.check_generics then
		prog.tp_tbl.register_generic(inc_type.name,inc_param_c);
	    end;
        end;

        old_con ::= con;
        con := #TP_CONTEXT(con.same,pnames,params,prog);
        do_tps( include_tree );
            -- include_tree can be void if inc_param_c = 0 !
            -- but this should be caught in do_tps.
        con := old_con;
        dummy ::= pending_includes.pop;

    end; -- do_include

end; -- class FIND_TYPES
