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

-- tp.sa: Classes relating to types in the Sather compiler.
-------------------------------------------------------------------
-- $TP: Abstract interface to Sather types.
-- TP_CLASS: Reference, immutable, abstract, or external types.
-- TP_ROUT: Bound routine (or Fortran bound routine) types.
-- TP_ITER: Bound iter types.
-- TP_CONTEXT: Context for AS_TYPE_SPEC -> $TP conversion.
-- TP_TBL: Table of all types.
-- TP_CLASS_TBL: Table of class types.
-- TP_ROUT_TBL: Table of bound routine types.
-- TP_ITER_TBL: Table of bound iter types. 
-- TP_GRAPH: Computes the type graph.
-- TP_GRAPH_ABS_DES: Table of all concrete decendants of a given type.
-- TP_BUILTIN: Cache of the type objects for builtin types.
-------------------------------------------------------------------
abstract class $TP < $CALL_TP, $IS_LT{$TP}, $STR, $HASH is
    -- Abstract interface to classes representing Sather types.
    -- Descendants are TP_CLASS, TP_ROUT, and TP_ITER.

    prog:PROG;			-- This type's program object.

    str:STR;			-- The string representation of self.
    -- Uses no whitespace, eg: "FOO{A,B{C},D}".

    is_abstract:BOOL;		-- True if self is abstract.
    
    is_immutable:BOOL;		-- True is self is an immutable type.
   
    is_partial:BOOL;            -- True if self is a partial class
   
    is_external:BOOL;           -- True is self is one of external types

    is_atomic:BOOL;		-- True if an assignment to self is atomic 
    				-- used only for pSather
   
    is_reference_free:BOOL;	-- Does the implementation use pointers
    -- that may affect garbage collection?

    is_builtin:BOOL;		-- True if self is a builtin type
   
    is_fortran:BOOL;            -- True if Fortran type
   
    is_c:BOOL;                  -- true if C type

    is_bound:BOOL;		-- True if self is a bound type.

    is_subtype(t:$CALL_TP):BOOL;-- True if self is a subtype of `t'.

    is_generic: BOOL;
    -- True if self is derived from a generic class. *H*
    
    is_eq(t:$OB):BOOL;		-- Equality test.
    
    hash:INT;                   -- Hash function

    is_lt(t:$TP):BOOL;          -- Canonical ordering.
    
    kind:INT;			-- One of TP_KIND::missing_tp, 
    -- TP_KIND::val_tp, TP_KIND::ref_tp, TP_KIND::abs_tp, 
    -- TP_KIND::part_tp, TP_KIND::ext_c_tp, TP_kind::ext_fortran_tp, 
    -- pSather: TP_KIND::spr_tp,
    -- TP_KIND::rout_tp, TP_KIND::iter_tp.

    as:AS_TYPE_SPEC; -- construct AS_TYPE_SPEC for self;

    impl: IMPL; -- Returns the implementation of the type.
    -- Produces error, if the type cannot have any implementation.

    ifc: IFC; -- Returns the interface of the type. If neccessary
    -- the interface will be computed.

end; -- type $TP
    
-------------------------------------------------------------------
class TP_KIND is
    -- A set of constants defining the different kinds of types. 
    const missing_tp, 
	 val_tp,			-- Value types.
	 ref_tp,			-- Reference types.
	 abs_tp,			-- Abstract types.
	 part_tp,                       -- Partial type.
	 ext_c_tp,			-- External C types.
	 ext_fortran_tp,                -- External Fortran types.
	 
         --pSather
	 spr_tp,                        -- Spread types.
	 
	 rout_tp,			-- Bound routine types.
	 iter_tp;			-- Bound iter types. 

end; -- class TP_KIND
    -------------------------------------------------------------------   
class TP is
   -- Implementation to be included by $TP objects.
    attr prog:PROG;		-- This type's program object.   

    private attr my_ifc: IFC;

    readonly attr is_generic: BOOL; -- *H*
    
    is_immutable:BOOL
	-- True if an immutable type.
    is
        return kind=TP_KIND::val_tp;
    end;
   
    is_partial:BOOL
	-- True if partial class
    is
        return kind=TP_KIND::part_tp;
    end;   
   
    is_external:BOOL
      -- True if one of external types
    is
        return kind=TP_KIND::ext_c_tp or kind=TP_KIND::ext_fortran_tp;
    end;
      
    is_builtin:BOOL
       -- Conservative answer
    is
        return false;
    end;

    is_atomic:BOOL
       -- Conservative answer
    is
        return false;
    end;

    is_reference_free:BOOL
	-- Conservative answer
    is
	return false;
    end;
   
   is_c:BOOL is
      case self
      when TP_BUILTIN::c_char, TP_BUILTIN::c_unsigned_char, 
	       TP_BUILTIN::c_signed_char, TP_BUILTIN::c_short,
	       TP_BUILTIN::c_int, TP_BUILTIN::c_long, 
	       TP_BUILTIN::c_unsigned_int, TP_BUILTIN::c_unsigned_short,
	       TP_BUILTIN::c_unsigned_long, TP_BUILTIN::c_float,
	       TP_BUILTIN::c_double, TP_BUILTIN::c_long_double,
	       
	       TP_BUILTIN::c_ptr, TP_BUILTIN::c_char_ptr, 
	       TP_BUILTIN::c_unsigned_char_ptr, TP_BUILTIN::c_signed_char_ptr, 
	       TP_BUILTIN::c_short_ptr, TP_BUILTIN::c_int_ptr,
	       TP_BUILTIN::c_long_ptr, TP_BUILTIN::c_unsigned_short_ptr,
	       TP_BUILTIN::c_unsigned_int_ptr,TP_BUILTIN::c_unsigned_long_ptr,
	       TP_BUILTIN::c_float_ptr, TP_BUILTIN::c_double_ptr,
	       TP_BUILTIN::c_long_double_ptr, TP_BUILTIN::c_size_t,	       
	       TP_BUILTIN::c_ptrdiff_t
      then
	 return true;
      else
	 -- could be still a user defined C type (struct)
	 return kind=TP_KIND::ext_c_tp;
      end;
   end;

   is_fortran:BOOL is
      case self
      when TP_BUILTIN::f_integer, TP_BUILTIN::f_real, 
	       TP_BUILTIN::f_character, TP_BUILTIN::f_logical,
	       TP_BUILTIN::f_double, TP_BUILTIN::f_complex,
	       TP_BUILTIN::f_double_complex, TP_BUILTIN::f_string,
	       TP_BUILTIN::f_handler
      then
	 return true;
      else
	 -- could be still one of fortran array types
	 tp ::= self;
	 typecase tp
	 when TP_CLASS then
	    if (tp.name = IDENT_BUILTIN::F_ARRAY_ident or
		tp.name = IDENT_BUILTIN::F_ARRAY2_ident or
		tp.name = IDENT_BUILTIN::F_ARRAY3_ident) then
	       return true;
	    end;
	 else
	 end;
      end;
      return false;
   end;
   
    kind:INT
    is
	raise "kind is expected to be redefined";
    end;

    hash:INT
    is
        return SYS::id(self).hash;
    end;

   is_eq(t:$OB):BOOL 
   -- Equality note: changed from $CALL_TP
   -- True if self equals `t'.
    is
	return SYS::ob_eq(self,t)
    end;

   is_lt(t:$CALL_TP):BOOL
   -- True if self is less than `t' in a canonical (arbitrary) ordering.
   is
      return str<t.str
    end;
    
    as:AS_TYPE_SPEC
	-- construct AS_TYPE_SPEC for self;`
    is
	return void;
    end;

    str:STR is raise "TP::Str not implemented."; end;

    impl:IMPL is return void; end;

    ifc:IFC is return void; end;
   

end; -- class TP
    
-------------------------------------------------------------------
class TP_CLASS < $TP is
    -- Representation of reference, immutable, abstract, and external types.
    include TP;
    
    attr name:IDENT;		-- The name of the type.
    attr params:ARRAY{$TP};	-- Specifiers for the type
    -- parameters in order, void if none.

    private attr my_as_tree: AS_CLASS_DEF;
    -- Textual representation of the class. *H*
    
    private attr my_impl: IMPL;   -- The implementation of this type.
    private attr sas_cache:STR;	-- Cache for string representation.
    private attr kind_cache:INT;	-- Cache for the kind of class this is
    readonly attr is_builtin:BOOL;
    readonly attr is_atomic:BOOL;
    
    readonly attr is_dummy_class:BOOL;
    -- True if generated by TP_TBL::register_generic. *H*

    create(name:IDENT, params:ARRAY{$TP}, prog:PROG):SAME
	-- A class type object with the specified attributes.
    is
	r::=new;
        r.name:=name; r.params:=params; r.prog:=prog;
	r.kind_cache:=TP_KIND::missing_tp;
	d::=prog.config.get_def("BUILTIN_CLASSES");
	loop
	    e::=d.elt!;
	    loop
		if e.elt!=r.str then 
		    r.is_builtin:=true; 
		    break!; 
		end;
	    end;
	    until!(r.is_builtin);
	end;
	-- if prog.psather then -- this test is bogus, as the flag
	-- is only set after some builtin types have 
	-- already been created.
	d := prog.config.get_def("ATOMIC_CLASSES");
	loop
	   e::=d.elt!;
	   loop
	      if e.elt!=r.str then 
		 r.is_atomic:=true; 
		 break!; 
	      end;
	   end;
	   until!(r.is_atomic);
	end;
	if prog.check_generics and ~ void(params) then
	    loop
		-- *H* shifed behind ATOMIC stuff to secure.
		if params.elt!.is_generic then
		    r.is_generic := true;
		    break!;
		end;
	    end;
	end;
	if prog.find_generics_stage then
	    prog.find_generics.add(r)
	end;
	return r
    end; -- create

    create_dummyclass(as:AS_CLASS_DEF,p:PROG): SAME
    -- *H*
    -- Creating a dummy class (meaning a class used as an instantiation
    -- of the type parameter for the generic type check.)
      pre ~p.find_generics_stage
    is
	if p.trace_generics then
	    #ERR + "\nCreating " + as.name.str;
	end;
	res ::= create(as.name,void,p);
	res.my_as_tree := as;
	res.is_generic := true;
	res.is_dummy_class := true;
	return res
    end; -- create_dummyclass

    set_context(con:TP_CONTEXT)
    -- *H*
    -- Setting the context from the outside is easier.
      pre ~prog.find_generics_stage and void(my_context) and is_dummy_class
    is
	my_context := con
    end; -- set_context

    str:STR
	-- The string version of the type represented by self. Uses no
	-- whitespace, eg: "FOO{A,B{C},D}".
    is
	if ~void(sas_cache) then return sas_cache end;
	if void(self) then return "void" end;
	if void(params) then
            sas_cache:=name.str 
	else
            s::=#FSTR + name.str + '{'; 
	    loop s:=s+",".separate!(params.elt!.str) end;
	    s:=s+'}';
            sas_cache:=s.str
        end;
	return sas_cache
    end; -- str

    is_abstract:BOOL
	-- True if self is abstract.
    is
	if void(self) then return false end;
	return name.str[0]='$'
    end;

    is_bound:BOOL
	-- Returns false.
    is
	return false
    end;
    
    is_subtype(t:$CALL_TP):BOOL
	-- True if self is a subtype of `t'.
    is
	if void(self) then return false end;      
	if self=t then
            return true 
	else
            typecase t
            when CALL_TP_UNDERSCORE then
                if ~void(t.tp) then
                    return is_subtype(t.tp);
                else
                    -- everything is a subtype of untyped underscore
                    return true;
                end;
            when TP_CLASS then 
                if t.is_abstract then
                    return prog.tp_graph.abs_subtype_test(self,t)
                else
                    return false
                end;
            else
                return false
            end
        end
    end; -- is_subtype

    kind:INT
	-- One of TP_KIND::missing_tp, TP_KIND::val_tp, TP_KIND::ref_tp,
	-- TP_KIND::abs_tp, TP_KIND::ext_c_tp, TP_KIND::ext_fortran_tp,       
	-- pSather: AS_KIND::spr_tp
	-- TP_KIND::rout_tp, TP_KIND::iter_tp.
    is
	if kind_cache=TP_KIND::missing_tp then
	    if ~void(as_tree) then
		kind_cache:=my_as_tree.kind;
	    end;
	end;
	return kind_cache
    end;

    is_reference_free:BOOL
	-- mbk
    is
	if void(self) then return false end;
	return impl.is_reference_free;
    end;

    as:AS_TYPE_SPEC
    is
	ret ::= #AS_TYPE_SPEC;
	ret.name := name;
	-- deal with params
	asp : AS_TYPE_SPEC;
	loop
            paramtp ::= params.elt!;
	    as0 ::= paramtp.as;
	    if void(asp) then asp := as0; else asp.append(as0); end;
	end;
	ret.params := asp;
	return ret;
    end;

   --    private pnames:ARRAY{IDENT} 
   pnames:ARRAY{IDENT}    
        -- An array of the parameter names for the type `self'. Void if none.
	pre ~void(self)
    is
	as ::= as_tree; -- *H*prog.parse.tree_for(self.name,self.params.size);
	if void(as) then return void end;
	if void(as.params) then return void end;
	r ::= #ARRAY{IDENT}(as.params.size);
	pd:AS_PARAM_DEC := as.params;
        i:INT:=0;
	loop until!(void(pd)); r.set!(pd.name); pd:=pd.next end;
	return r
    end;
   
    private attr my_context: TP_CONTEXT; -- *H* re-inserted

    tp_context_for:TP_CONTEXT 
        -- The type context appropriate for the body of `self'. Void if
        -- `self' is not a known type.
	pre ~void(self)
    is
        if ~void(my_context) then return my_context end;
	pn:ARRAY{IDENT}:=pnames;
	ps:INT;
	if ~void(pn) then ps:=pn.asize end;
	if ps/=self.params.size then return void end;
	r::=#TP_CONTEXT(self, pn, params, prog);
	if is_abstract then r.is_abs:=true end;
        my_context := r;
	return r
    end;

    impl: IMPL
        -- Creates the implementation of this class. Does nothing if
        -- already computed. Test for cyclic implementation contruction
        -- with include clauses.
    is
        if void(my_impl) then
            my_impl := IMPL_CREATE::create_for_tp_class(self);
        end;
        return my_impl
    end;

    ifc: IFC
    is
        if void(my_ifc) then my_ifc := IFC::ifc_for_class(self); end;
        return my_ifc
    end;
    
    as_tree: AS_CLASS_DEF
    -- *H* neccessary to keep syhthetic as representation of dummy classes.
    is
	if void(my_as_tree) then
	    my_as_tree := prog.parse.tree_for(name,params.size);
	end;
	return my_as_tree;
    end;
    
end; -- TP_CLASS
-------------------------------------------------------------------
class TP_ROUT < $TP is
    -- Representation of bound routine types.
    include TP;

    attr args:ARRAY{ARG};	-- Specifiers for the arguments
    -- in order, void if none.
    attr ret:$TP;		-- The return type, void if none.
    attr is_remote:BOOL;	-- used by pSather for remote
   -- proc. calls
   attr is_fortran:BOOL;        -- true for F_ROUTs

    create(args:ARRAY{ARG}, ret:$TP, prog:PROG):SAME
	-- A bound routine type object with the specified attributes.
    is
	r::=new; r.args:=args; r.ret:=ret; r.prog:=prog;
	loop -- *H*
	    arg: ARG := args.elt!;
	    if ~void(arg) and arg.tp.is_generic then
		r.is_generic := true;
		break!;
	    end
	end;
	if ~void(ret) and ret.is_generic then r.is_generic := true; end; -- *H*
        return r 
    end;      

    private attr sas_cache:STR;	-- Cache for string representation.   
    
   str:STR
	-- The string version of the type represented by self. Uses no
	-- whitespace, eg: "ROUT{A,B{C},outD}:E".
    is
	if void(self) then return "void" end;
	if ~void(sas_cache) then
            -- Don't need to do anything.
	elsif void(args) and void(ret) then
	   if is_fortran then
	      sas_cache:="F_ROUT"
	   else
	      sas_cache:="ROUT"
	   end;
	else
	   s:FSTR;
	   if is_fortran then
	      s:=#FSTR + "F_ROUT";
	   else
	      s:=#FSTR + "ROUT";	      
	   end;
	    if ~void(args) then
                s:=s + '{'; 
		loop
		    arg ::= args.elt!;
		    s := s+",".separate!(arg.mode.str+arg.tp.str)
                end;
		s:=s + '}'
            end;
	    if ~void(ret) then s:=s + ':' + ret.str end;
	    sas_cache:=s.str
        end;
	return sas_cache
    end;
    
    is_abstract:BOOL is return false end;            

    is_bound:BOOL is return true end;
    
    is_subtype(t:$CALL_TP):BOOL
	-- True if self is a subtype of `t'. 
    is
	if void(self) then return false end;
	typecase t
	when TP_CLASS then 
	    if ~t.is_abstract then
                return false
	    else
                return prog.tp_graph.abs_subtype_test(self,t)
            end;
	when TP_ROUT then
	    -- Test for contravariant conformance. This means:
	    -- 1) Self and `t' have the same number of arguments.
	    -- 2) Both have a return value or both do not.
	    -- 3) The mode of each argument is the same.
	    -- 4) for any in arguments, the type in t is a subtype
            --    of a type in self;
	    --    for any inout arguments, the type in self is the same
            --    as the type in t;
	    --    for any out arguments, the type in self is a subtype of
            --    of the type in t;
	    -- 5) The return type of self must be a subtype of the return
	    --    type of t, if present

	    if args.size/=t.args.size then return false end;
	    if has_ret/=t.has_ret then return false end;
	    loop
                if args.elt!.mode /= t.args.elt!.mode then return false; end;
            end;
	    loop 
		self_arg ::= args.elt!; t_arg ::= t.args.elt!;
		case self_arg.mode
		when MODES::in_mode then
		    if ~t_arg.tp.is_subtype(self_arg.tp) then 
			return false;
		    end;
		when MODES::out_mode then
		    if ~self_arg.tp.is_subtype(t_arg.tp) then 
			return false;
		    end;
		when MODES::inout_mode then
		    if self_arg.tp /= t_arg.tp then 
			return false; 
		    end;
		when MODES::once_mode then -- aj ?? there are no once here
		    if ~t_arg.tp.is_subtype(self_arg.tp) then 
			return false;
		    end;
		end;
	     end;
             -- well, unfortunately, dispatched ROUTs are not implemented
             -- yet, so make sure things match exactly. When they are 
             -- finally implemented, loop below should be deleted
             loop 
                 if args.elt!.tp /= t.args.elt!.tp then 
                    prog.err(
                        "Dispatched bound routines are not implemented yet, check argument types");
                    return false; 
                 end;
             end;
	     -- same accounts for return value
	     -- foo(R:ROUT:$STR) may, so far, only be called with 
	     -- a bound routine of type ROUT:$STR.
	     -- note NOT with a type of ROUT:INT 
	     
	     if has_ret and ret /= t.ret then
		prog.err(
                        "Dispatched bound routines are not implemented yet, check return types.");
		return false; 
	     end;
	     
	     -- once its fixed do the following:
	     --if has_ret and ~ret.is_subtype(t.ret) then return false end;
             return true
	else
             return false
	end; -- typecase t
    end; -- is_subtype
    
    has_ret:BOOL
	-- True if self has a return value.
    is
	return ~void(ret)
    end;

    kind:INT
	-- The kind of this type.
    is
	return TP_KIND::rout_tp
    end;

   as:AS_TYPE_SPEC
    is
      r ::= #AS_TYPE_SPEC;
      if is_fortran then
	 r.kind := AS_TYPE_SPEC::f_rt;
      else
	 r.kind := AS_TYPE_SPEC::rt;
      end;
	
	asp : AS_TYPE_SPEC;
	loop
	    arg ::= args.elt!;
	    paramtp ::= arg.tp;
	    as0 ::= paramtp.as;
	    if void(asp) then asp := as0; else asp.append(as0); end;
	end;
	r.params := asp;
	if ~void(ret) then
	   r.ret := ret.as;
	end;
	return r;
    end; 

    ifc: IFC
    is
       if void(my_ifc) then my_ifc := IFC::ifc_for_rout(self) end;
       return my_ifc
    end;

end; -- class TP_ROUT
    
-------------------------------------------------------------------
class TP_ITER < $TP is
   -- Representation of bound iter types.
   include TP;
    
   attr args:ARRAY{ARG};	-- Specifiers for the argument types
   -- in order, void if none.
   attr hot:ARRAY{BOOL};	-- Treu for each arg which is marked 
   -- with a "!". None are hot if this array is void.
   attr ret:$TP;		-- The return type, void if none.
   
   create(args:ARRAY{ARG}, hot:ARRAY{BOOL}, ret:$TP, prog:PROG):SAME
   -- A bound iter type object with the specified attributes.
   is
	r::=new; r.args:=args; r.hot:=hot; r.ret:=ret; r.prog:=prog; 
	loop -- *H*
	    arg: ARG := args.elt!;
	    if ~void(arg) and arg.tp.is_generic then
		r.is_generic := true;
		break!;
	    end
	end;
	if ~void(ret) and ret.is_generic then r.is_generic := true; end; -- *H*
	return r
   end;
   
   attr sas_cache:STR;	-- Cache for string representation.   
   
   str:STR
	-- The string version of the type represented by self. Uses no
	-- whitespace, eg: "ITER{A!,B{C},D}:E".
	-- If self is void, returns "void".
    is
	if void(self) then return "void" end;
	if ~void(sas_cache) then
            -- Don't need to do anything.
	elsif void(args) and void(ret) then
            sas_cache:="ITER"
	else
            s::=#FSTR + "ITER";
	    if ~void(args) then
		s:=s + '{'; 
		loop
		    arg ::= args.elt!;
		    s:=s+",".separate!(arg.mode.str+arg.tp.str);
		    if ~void(hot) and hot.elt! then s:=s + '!' end
                end;
		s:=s + '}'
            end;
	    if ~void(ret) then s:=s + ':' + ret.str end;
	    sas_cache:=s.str
        end;
	return sas_cache 
    end; -- str
    
   
   
   is_abstract:BOOL is
      -- Returns false.
      return false end;      
   
   is_bound:BOOL is
      -- Returns true.
      return true end;
   
   is_subtype(t:$CALL_TP):BOOL is
      -- True if self is a subtype of `t'.
            
      if void(self) then return false end;      
      typecase t
      when TP_CLASS then 
	 if ~t.is_abstract then return false
	 else return prog.tp_graph.abs_subtype_test(self,t) end;
      when TP_ITER then
	 -- Test for contravariant conformance. This means:
	 -- 1) Self and `t' have the same number of arguments.
	 -- 2) Both have a return value or both do not.
	 -- 3) The mode of each argument is the same 
	 -- 4) for any in arguments, the type in t is a subtype
	 --    of a type in self;
	 --    for any inout arguments, the type in self is the same
	 --    as the type in t;
	 --    for any out arguments, the type in self is a subtype of
	 --    of the type in t;
	 -- 5) The return type of self must be a subtype of the return
	 --    type of t, if present

	 if args.size/=t.args.size then return false end;
	 loop 
	    sar ::= args.elt!;
	    tar ::= t.args.elt!;
	    
	    sar_tp ::= sar.tp;
	    
	    typecase sar_tp
	    when CALL_TP_UNDERSCORE then
	       -- modes do not need to match
	       sar.mode := tar.mode;
	    else
	       if (sar.mode /= tar.mode) then
		  return false; 
	       end 
	    end;
	 end;
	 
	 loop 
	    self_arg ::= args.elt!; t_arg ::= t.args.elt!;
	    case self_arg.mode
	    when MODES::in_mode then
	       if ~t_arg.tp.is_subtype(self_arg.tp) then 
		  return false;
	       end;
	    when MODES::out_mode then
	       if ~self_arg.tp.is_subtype(t_arg.tp) then 
		  return false;
	       end;
	    when MODES::inout_mode then
	       if self_arg.tp /= t_arg.tp then 
		  return false; 
	       end;
	    when MODES::once_mode then
	       if ~t_arg.tp.is_subtype(self_arg.tp) then 
		  return false;
	       end;
	    end;
	 end;
	 
	 -- well, unfortunately, dispatched ITERs are not implemented
	 -- yet, so make sure things match exactly. When they are 
	 -- finally implemented, loop below should be deleted
	 loop 
	    if args.elt!.tp /= t.args.elt!.tp then 
	       prog.err("Dispatched bound iterators are not implemented yet, check argument types.");
	       return false; 
	    end;
	 end;
	 if hot.size/=t.hot.size then return false end;
	 loop 
	    if hot.elt!/=t.hot.elt! then 
	       #OUT + "hot mismatch\n";
	       return false;
	    end; 
	 end;
	 if has_ret/=t.has_ret then return false end;
	 -- same accounts for return value
	 -- foo(R:ITER:$STR) may, so far, only be called with 
	 -- a bound routine of type ITER:$STR.
	 -- note NOT with a type of ITER:INT 
	 
	 if has_ret and ret /= t.ret then
	    prog.err(
		     "Dispatched bound iterators are not implemented yet, check return types.");
	    return false; 
	 end;
	     
	 -- once its fixed do the following:
	 -- if has_ret and ~ret.is_subtype(t.ret) then
	 -- return false 
	 -- end;
	 return true;
      else 
	 return false 
      end; -- ends typecase
   end;
   
   has_ret:BOOL
   -- True if self has a return value.
   is
      if void(self) then return false end;      
      return ~void(ret)
   end;
   
   kind:INT
   -- The kind of this type.
   is
      return TP_KIND::iter_tp
   end;
   
   as:AS_TYPE_SPEC
   is
	r ::= #AS_TYPE_SPEC;
	r.kind := AS_TYPE_SPEC::it;
	
	asp : AS_TYPE_SPEC;
	loop
	    arg ::= args.elt!;
	    paramtp ::= arg.tp; 
	    i::=0.up!;
	    as0 ::= paramtp.as;
	    if ~void(hot) then
		as0.is_hot := hot[i];
	    end;
	    if void(asp) then asp := as0; else asp.append(as0); end;
	end;
	r.params := asp;
	-- ben - caused the browser to crash and seemed to require the void 
	-- test
	if ~void(ret) then  r.ret := ret.as; end;
	return r;
    end;   
   
    ifc: IFC
    is
        if void(my_ifc) then my_ifc := IFC::ifc_for_iter(self) end;
        return my_ifc;
    end;

end; -- class TP_ITER

-------------------------------------------------------------------
class TP_CONTEXT is
    -- A context for converting AS_TYPE_SPEC trees into $TP objects.
    
   attr same:TP_CLASS;		-- The type that replaces "SAME",
   attr pnames:ARRAY{IDENT};	-- Type parameter names, if any.
   attr ptypes:ARRAY{$TP};	-- Type parameter values, if any.
   attr is_abs:BOOL;		-- True if in an abstract class.
   attr prog:PROG;		-- The program this is for.
   
   create(same:TP_CLASS, pnames:ARRAY{IDENT}, ptypes:ARRAY{$TP},
	  prog:PROG):SAME
   -- A type context object with the specified attributes.
   is
      r::=new;
      r.same:=same; r.pnames:=pnames; r.ptypes:=ptypes; r.prog:=prog;
      return r
   end;
   
   value_of_param(s:IDENT):$TP
   -- The value of the parameter named by `s'. If `s' doesn't
   -- name a parameter, returns void.
   is
      if void(pnames) then return void end;
      loop
	 i::=pnames.ind!; 
	 if s=pnames[i] then return ptypes[i] end
      end;
      return void
   end;
   
   tp_of(t:AS_TYPE_SPEC): $TP is return tp_of(t,true) end;
   
   tp_of(t:AS_TYPE_SPEC,memorize:BOOL):$TP
   -- The type object corresponding to the type specifier `t' in
   -- this context. Void if `t' is void.
   -- If memorize is false to not write this type into the global
   -- type table.
   is
      if void(t) then return void end;      
      case t.kind
      when AS_TYPE_SPEC::ord then return tp_class_of(t,memorize)
      when AS_TYPE_SPEC::rt then return tp_rout_of(t)
      when AS_TYPE_SPEC::it then return tp_iter_of(t)
      when AS_TYPE_SPEC::f_rt then return tp_f_rout_of(t)
      when AS_TYPE_SPEC::same then 
	 --*H*
	 --if is_abs then prog.err_loc(t); 
	 --	prog.err("SAME is not allowed in abstract classes.") end;
	 return same
      end
   end; -- tp_of
   
   str: STR
   -- For debugging
   is
      res ::= "(" + same.str + ";";
      if ~void(pnames) and pnames.size > 0 then
	 loop
	    res:=res+",".separate!(pnames.elt!.str+"->"+ptypes.elt!.str);
	 end
      end;
      return res + ")";
   end;
   
   tp_class_of(t:AS_TYPE_SPEC,memorize:BOOL):$TP
   -- The type object corresponding to the class type specifier 
   -- `t' in this context. 
      pre ~void(t) and t.kind=t.ord and void(t.ret)
   is
      -- SAME is not allowed in parametrizations of abstract classes
      if t.name.str[0]='$' then
	 if type_spec_params_have_same(t) then
	    prog.err_loc(t);
	    prog.err("SAME is allowed only inside bodies of concrete classes.");
	 end;
      end;
      if void(t.params) then 
	 pv::=value_of_param(t.name); 
	 if ~void(pv) then return pv end; -- A parameter reference. 
	 if ~void(t.name) then
	    return prog.tp_tbl.tp_class_for(t.name, void, memorize)
	 end;
      end;
      ptps::=#ARRAY{$TP}(t.params.size);
      tpe::=t.params;
      loop 
	 until!(void(tpe)); 
	 ptp::=tp_of(tpe);  -- parameter type
	 
	 ptps.set!(ptp); 
	 tpe:=tpe.next 
      end;
      if ~void(t.name)
      then
	 return prog.tp_tbl.tp_class_for(t.name, ptps, memorize);
      else
	 return void;
      end;
   end;
   
   tp_rout_of(t:AS_TYPE_SPEC):$TP
   -- The type object corresponding to the bound routine type
   -- specifier `t' in this context. 
      pre ~void(t) and t.kind=t.rt
   is
      if void(t.params) then
	 return prog.tp_tbl.tp_rout_for(void, tp_of(t.ret))
      end;
      args ::= #ARRAY{ARG}(t.params.size);
      tpe ::= t.params;
      loop
	 until!(void(tpe)); 
	 i ::= 0.up!;
	 args[i] := #(tp_of(tpe), MODE::create_from_as(tpe.mode));
	 tpe:=tpe.next 
      end;
      -- currently, no overloading on modes is allowed
      return prog.tp_tbl.tp_rout_for(args, tp_of(t.ret)) 
   end;
   
   tp_iter_of(t:AS_TYPE_SPEC):$TP
   -- The type object corresponding to the bound iter type
   -- specifier `t' in this context. 
      pre ~void(t) and t.kind=t.it
   is
      if void(t.params) then
	 return prog.tp_tbl.tp_iter_for(void, void, tp_of(t.ret)) end;
      args::=#ARRAY{ARG}(t.params.size);
      tpa::=t.params;
      loop
	 until!(void(tpa)); 
	 i ::= 0.up!;
	 args[i] := #(tp_of(tpa), MODE::create_from_as(tpa.mode));
	 tpa:=tpa.next 
      end; 
      hot::=#ARRAY{BOOL}(args.size);
      tpa:=t.params;
      -- to be eliminated (Boris)
      loop until!(void(tpa)); hot.set!(tpa.is_hot); tpa:=tpa.next end;
      if ~hot.contains(true) then hot:=void end;
      -- currently, no overloading based on arg modes is allowed
      return prog.tp_tbl.tp_iter_for(args, hot, tp_of(t.ret)) 
   end;

   tp_f_rout_of(t:AS_TYPE_SPEC):$TP
   -- The type object corresponding to the bound Fortran routine type
   -- specifier `t' in this context. 
      pre ~void(t) and t.kind=t.f_rt
   is
      if void(t.params) then
	 return prog.tp_tbl.tp_f_rout_for(void, tp_of(t.ret))
      end;
      args ::= #ARRAY{ARG}(t.params.size);
      tpe ::= t.params;
      loop
	 until!(void(tpe)); 
	 i ::= 0.up!;
	 args[i] := #(tp_of(tpe), MODE::create_from_as(tpe.mode));
	 tpe:=tpe.next 
      end;
      -- currently, no overloading on modes is allowed
      return prog.tp_tbl.tp_f_rout_for(args, tp_of(t.ret)) 
   end;

   type_spec_has_same(t:AS_TYPE_SPEC):BOOL 
   -- True if the type spec `t' contains "SAME".
      pre ~void(t)
   is
      if t.kind=t.same then return true; end;
      if type_spec_params_have_same(t) then return true end;
      if ~void(t.ret) then 
	 return type_spec_has_same(t.ret); 
      else
	 return false;
      end;
   end;
   
   type_spec_params_have_same(t:AS_TYPE_SPEC):BOOL 
   -- True if the type spec `t' contains "SAME".
      pre ~void(t)
   is
      p::=t.params;
      loop
	 while!(~void(p));
	 if type_spec_has_same(p) then return true end;
	 p:=p.next
      end;
      return false
   end;
   
   type_spec_is_param(t:AS_TYPE_SPEC):BOOL 
   -- True if `t' is a type specifier which is just a type 
   -- parameter. 
      pre ~void(t)
   is
      if t.kind/=t.ord or ~void(t.params) then return false end;
      return pnames.contains(t.name)
   end;
   
end; -- class TP_CONTEXT

-------------------------------------------------------------------
class TP_TBL is
    -- A table of types in a program. This ensures that each type 
    -- is only represented by a single object so that object 
    -- equality can be used to test for type equality.

    attr prog:PROG;		-- The program this belongs to.
    attr class_tbl:TP_CLASS_TBL; -- Types defined by classes.
    
    attr gen_tbl:TP_GEN_TBL;
    -- *H* List of parameterized classes and dummy classes during the
    -- find_types stage. Storing them seperately keeps them out of the
    -- find_types scanning loop.
    
    attr included_classes:TP_CLASS_TBL;
        -- Types defined by include clauses.
   attr rout_tbl:TP_ROUT_TBL;	-- Bound routine types.
   attr iter_tbl:TP_ITER_TBL;	-- Bound iter types.
   attr f_rout_tbl:TP_ROUT_TBL;	-- Fortran bound routine types.   
   
    create(prog:PROG):SAME
	-- A table of type for the program `prog'.
    is
	r::=new;
	r.prog:=prog;
	TP_BUILTIN::initialize(r,prog);
      return r; 
    end;      

    tp_class_for(s:STR,inout i:INT):TP_CLASS
        -- converts a string representation of a type to tp.
	-- reads only as many characters as needed. Returns
	-- the number of characters in i, and starts to read
	-- the string at pos i
    is
	params:ARRAY{$TP}; 
	cl:STR;
	if s[i]='$' then
 	   cl:=cl+s[i];
	   i:=i+1;
	end;
	loop 
	    while!(i<s.size and (s[i].is_upper or s[i]='_' or s[i].is_digit or s[i].is_lower));
	    -- lower is *H* debug
	   cl:=cl+s[i];
	   i:=i+1;
	end;
	if i=0 then 
	   prog.barf("syntax error in tp string '"+s+"'");
	end;
	if i<s.size then
	   if s[i]='{' then
	      i:=i+1;
	      j::=0;
	      p:ARRAY{$TP}:=#(50); -- not more than 50 args
	      loop
		 p[j]:=tp_class_for(s,inout i);
		 j:=j+1;
		 if s[i]='}' then
		    i:=i+1;
		    break!;
		 elsif s[i]=',' then
		    i:=i+1;
		 else
		    prog.barf("syntax error in tp string '"+s+"', expected ',' or '}', got '"+s[i]+"'");
		 end;
	      end;
	      params:=#(j);
	      params.copy(p);
	   else
	      if s[i]/='}' and s[i]/=',' then
	         prog.barf("syntax error in tp string '"+s+"', expected '{' or ',', got '"+s[i]+"'");
	      end;
	   end;
        end;
	return tp_class_for(#IDENT(cl),params);
    end;

    tp_class_for(s:STR):TP_CLASS
    is
       i::=0;
       return tp_class_for(s,inout i);
    end;

    tp_class_for(name:IDENT, params:ARRAY{$TP}): TP_CLASS
    is
        return tp_class_for(name,params,true);
    end;

    tp_class_for(name:IDENT, params:ARRAY{$TP}, memorize:BOOL ):TP_CLASS
	-- Return the class type object for the name `name' and the
	-- parameters (if any) `params'. If this has already been
	-- accessed, return the old object, otherwise create a new
	-- one using the array `params'.
    is
        query ::= #TUP{IDENT,ARRAY{$TP}}(name,params);
	r:TP_CLASS :=class_tbl.get_query(query);
	if void(r) then
            r := included_classes.get_query(query);
            if void(r) then
                -- assert ~ prog.no_new_types;
                r := #TP_CLASS(name,params,prog);
                included_classes := included_classes.insert(r);
            end;
	    -- *H* debug
	    if prog.find_generics_stage and r.is_partial and memorize
	    then
		#ERR + "\nError: creating partial class "+r.str;
		assert false;
	    end;
	    -- end *H*
            if memorize then
                -- assert ~ prog.no_new_types;
                class_tbl := class_tbl.insert(r);
            end;
	    TP_BUILTIN::register_other_builtins(name,r,params);
        end;
	return r
    end;
    
 
    register_generic(name:IDENT, p:INT)
    -- Creating the generic class as an instantiation using unique
    -- subtypes of the typebound as type parameters. *H*
        pre prog.check_generics
    is
	r ::= gen_tbl.get_query(#(name,p));
	if ~void(r) then return; end;
	as ::= prog.parse.tree_for(name,p);
	if void(as) then return; end;
	
	-- Creating a name designating the generic class it comes from.
	-- T for FOO{T} becomes $TinFOOp1 (1 stands for 1 parameter).
	name_suffix: STR := name.str;
	if name_suffix[0]='$' then
	    name_suffix := "p" + name_suffix.substring(1);
	end;
	name_suffix := "in"+name_suffix+"p"+p;
	
	param_types ::= #ARRAY{$TP}(p);
	param_names ::= #ARRAY{IDENT}(p);
	param ::= as.params;
	loop
	    until!(void(param));

	    -- The artificial AS tree and the dummy class.
	    as_classdef: AS_CLASS_DEF := #;
	    as_classdef.name := #IDENT("$"+param.name.str + name_suffix);
	    as_classdef.kind := TP_KIND::abs_tp;
	    as_classdef.under := param.type_constraint;
	    as_classdef.source := as.source;
	    dummy_class ::= TP_CLASS::create_dummyclass(as_classdef,prog);
	    
	    -- The artificial context data (remember that type
	    -- parameters are visible only to the right.)
	    param_names.set!( param.name );
	    param_types.set!( dummy_class );
	    dc_names ::= #ARRAY{IDENT}(1.up!);
	    dc_types ::= #ARRAY{$TP}(1.up!);
	    loop dc_names.set!(param_names.elt!) end;
	    loop dc_types.set!(param_types.elt!) end;
	    dummy_class.set_context
		  (#TP_CONTEXT(dummy_class,dc_names,dc_types,prog));
	    
	    -- Making sure that no dummy class gets in twice.
	    assert ~prog.tp_tbl.class_tbl.test(dummy_class);
	    gen_tbl := gen_tbl.insert( dummy_class ); -- *H* putting
	    -- nto gen_tbl to keep them out of the way when doing fild_types
	    
	    param := param.next;
	end;
	r := TP_CLASS::create(name,param_types,prog);
	gen_tbl := gen_tbl.insert(r);
    end;
    
    tp_rout_for(args:ARRAY{ARG}, ret:$TP):TP_ROUT
	-- Return the bound routine type object for the argument
	-- `args' (if any) and the return type `ret' (if any).
	-- If this has already been accessed, return the old object, 
	-- otherwise create a new one using the array `args'.
    is
	r::=rout_tbl.get_query(#(args,ret));
	if void(r) then r:=#(args,ret,prog);
	    rout_tbl:=rout_tbl.insert(r)
        end;
	return r
    end;

    tp_iter_for(args:ARRAY{ARG}, hot:ARRAY{BOOL}, ret:$TP):TP_ITER is
	-- Return the bound iter type object for the argument
	-- types `args' (if any), marked according to `hot' (if any)
	-- and with return type `ret' (if any). If this has already
	-- been accessed, return the old object, otherwise create a
	-- new one using the arrays `args' and `hot'.
	r::=iter_tbl.get_query(#(args,hot,ret)); -- might be buggy aj
	if void(r) then r:=#(args,hot,ret,prog);
	    iter_tbl:=iter_tbl.insert(r)
        end;
	return r
    end;
    
   tp_f_rout_for(args:ARRAY{ARG}, ret:$TP):TP_ROUT
   -- Return the bound Fortran routine type object for the argument
   -- `args' (if any) and the return type `ret' (if any).
   -- If this has already been accessed, return the old object, 
   -- otherwise create a new one using the array `args'.
   is
      r::=f_rout_tbl.get_query(#(args,ret));
      if void(r) then r:=#(args,ret,prog);
	 r.is_fortran := true;
	 f_rout_tbl:=f_rout_tbl.insert(r)
      end;
      return r
   end;
   
   test(t:$TP):BOOL
   -- True if the type `t' is in the table.
   is
      typecase t
      when TP_CLASS then return class_tbl.test(t)
      when TP_ROUT then 
	 if t.is_fortran then
	    return f_rout_tbl.test(t)
	 else
	    -- "normal" case
	    return rout_tbl.test(t)
	 end;
      when TP_ITER then return iter_tbl.test(t)
      end
   end; 

   insert(t:$TP)
   -- Insert the type `t' into the table. 
   is
      typecase t
      when TP_CLASS then class_tbl:=class_tbl.insert(t)
      when TP_ROUT then 
	 if t.is_fortran then
	    f_rout_tbl:=f_rout_tbl.insert(t);	    
	 else
	    rout_tbl:=rout_tbl.insert(t);
	 end;
      when TP_ITER then 
	 iter_tbl:=iter_tbl.insert(t);
      end 
   end;
   
   delete(t:$TP)
   -- Delete the type `t' from the table.
   is
      typecase t
      when TP_CLASS then class_tbl:=class_tbl.delete(t)
      when TP_ROUT then 
	 if t.is_fortran then
	    f_rout_tbl:=f_rout_tbl.delete(t)
	 else
	    rout_tbl:=rout_tbl.delete(t)
	 end;
      when TP_ITER then iter_tbl:=iter_tbl.delete(t)
      end
   end;
    
end; -- class TP_TBL

-------------------------------------------------------------------
class TP_CLASS_TBL is
    -- Table of types defined by classes: abstract, reference, 
    -- immutable, and external types. 
    -- 
    -- `get_query(TUP{IDENT,ARRAY{$TP}}):TP_CLASS' looks up a type.
    -- `test(TP_CLASS):BOOL' tests for a type.   
    -- `insert(TP_CLASS):SAME' inserts a type.
    -- `delete(TP_CLASS):SAME' deletes a type.
    
    include FQSET{TUP{IDENT,ARRAY{$TP}},TP_CLASS};

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

    query_hash(q:TUP{IDENT,ARRAY{$TP}}):INT
	-- A hash value computed from the query types.
    is
	r::=q.t1.hash;		-- Make depend on name.
	loop
	    i::=q.t2.ind!;
	    r:=r.mplus(SYS::id(q.t2[i])).mplus(i).mtimes(19);
	end; -- And on params.
	return r.hash; 
    end;

    elt_hash(e:TP_CLASS):INT
	-- Hash on the types in `e'.
    is
	r::=e.name.hash;		-- Make depend on name.
	loop
	    i::=e.params.ind!;
	    r:=r.mplus(SYS::id(e.params[i])).mplus(i).mtimes(19);
	end; -- And on params.
	return r.hash; 
    end;
    
end; -- class TP_CLASS_TBL
-------------------------------------------------------------------
class TP_GEN_TBL is -- almost a literal compy if TP_CLASS_TBL (*H*)
    -- `get_query(TUP{IDENT,INT}):TP_CLASS' looks up a type.
    -- `test(TP_CLASS):BOOL' tests for a type.   
    -- `insert(TP_CLASS):SAME' inserts a type.
    -- `delete(TP_CLASS):SAME' deletes a type.
    
    include FQSET{TUP{IDENT,INT},TP_CLASS};

    query_test(q:TUP{IDENT,INT}, t:TP_CLASS):BOOL
	-- True if `t' is the type described by `q'.
    is
	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
	-- A hash value computed from the query types.
    is
	return q.t1.hash.mtimes(37).mplus(q.t2).mtimes(19).hash
    end;

    elt_hash(e:TP_CLASS):INT
	-- Hash on the types in `e'.
    is
	return e.name.hash.mtimes(37).mplus(e.params.size).mtimes(19).hash
    end;
    
end; -- class TP_GEN_TBL

-------------------------------------------------------------------   
class TP_ROUT_TBL is
    -- Tables of bound routine types.
    -- 
    -- `get_query(TUP{ARRAY{ARG},$TP}):TP_ROUT' look up a type.
    -- `test(TP_ROUT):BOOL' tests for a type.   
    -- `insert(TP_ROUT):SAME' inserts a type.
    -- `delete(TP_ROUT):SAME' deletes a type.
    
    include FQSET{TUP{ARRAY{ARG},$TP}, TP_ROUT};

    query_test(q:TUP{ARRAY{ARG},$TP}, t:TP_ROUT):BOOL
	-- True if `t' is a bound routine with arg and return types as
	-- listed in `q'.
    is
	if void(t) then return false end;
	if void(q.t2) then if ~void(t.ret) then return false end
	elsif q.t2/=t.ret then return false end;
	if q.t1.size/=t.args.size then return false end;
	loop if q.t1.elt!/=t.args.elt! then return false end end;
	return true
    end;

    query_hash(q:TUP{ARRAY{ARG},$TP}):INT
	-- A hash value computed from the query types.
    is
	r::=0;
	-- Make depend on return type.
	if ~void(q.t2) then r:=SYS::id(q.t2).hash; end;
	-- And arg types.
	loop
	    i::=q.t1.ind!;
	    r:=r.mplus(SYS::id(q.t1[i].tp)).mplus(i).mtimes(19);
	end;
	return r.hash
    end;

    elt_hash(e:TP_ROUT):INT
	-- A hash value computed from the query types.
    is
	r::=0;
	-- Make depend on return type.
	if ~void(e.ret) then r:=SYS::id(e.ret).hash; end;
	-- And arg types.
	loop
	    i::=e.args.ind!;
	    r:=r.mplus(SYS::id(e.args[i].tp)).mplus(i).mtimes(19);
	end;
	return r.hash
    end;

end; -- class TP_ROUT_TBL

-------------------------------------------------------------------
class TP_ITER_TBL is
   -- Tables of bound iter types.
   -- 
   -- `get_query(TUP{ARRAY{ARG},ARRAY{BOOL},$TP}):TP_ITER' look up a type.
   -- `test(TP_ITER):BOOL' tests for a type.   
   -- `insert(TP_ITER):SAME' inserts a type.
   -- `delete(TP_ITER):SAME' deletes a type.
   
   include FQSET{TUP{ARRAY{ARG},ARRAY{BOOL},$TP}, TP_ITER};
   
   query_test(q:TUP{ARRAY{ARG},ARRAY{BOOL},$TP}, t:TP_ITER):BOOL
   -- True if `t' is a bound iter with arg types, arg hotness and
   -- return type as listed in `q'.
   is
      if void(t) then return false end;
      if void(q.t3) then 
	 if ~void(t.ret) then return false end;
      elsif q.t3 /= t.ret then  return false end; 
      if q.t1.size/=t.args.size then return false end;
      loop if q.t1.elt!/=t.args.elt! then return false end end;
      if q.t2.size/=t.hot.size then return false end;      
      loop if q.t2.elt!/=t.hot.elt! then return false end end;
      return true 
   end;
   
   query_hash(q:TUP{ARRAY{ARG},ARRAY{BOOL},$TP}):INT is
      -- A hash value computed from the query types.
      r::=0;
      -- Make depend on return type.
      if ~void(q.t3) then r:=SYS::id(q.t3).hash; end;
      -- And arg types.
      loop
	 i::=q.t1.ind!;
	 r:=r.mplus(SYS::id(q.t1[i].tp)).mplus(i).mtimes(19);
      end;
      -- leav out hotness for now
      return r.hash 
   end;
   
   elt_hash(e:TP_ITER):INT is
      -- A hash value computed from the query types.
      r::=0;
      -- Make depend on return type.
      if ~void(e.ret) then r:=SYS::id(e.ret).hash; end;
	-- And arg types.
	loop
	   i::=e.args.ind!;
	   r:=r.mplus(SYS::id(e.args[i].tp)).mplus(i).mtimes(19);
	end;
	-- ignore hotness for now
	return r.hash 
     end;

end; -- class TP_ITER_TBL
    

-------------------------------------------------------------------
class TP_GRAPH is
    -- Objects which represent Sather type graphs. 
    -- The tables do not explicitly represent the edges between 
    -- bound objects 

   attr prog:PROG;
   attr par_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}};
   -- Map from each class type to the direct supertypes
   attr anc_tbl:FMAP{TP_CLASS,FSET{TP_CLASS}};
   -- Map from each class type to its ancestors 
   attr child_tbl:FMAP{TP_CLASS,FSET{$TP}};
   -- Map from each abstract type to any explicit children
   attr des_tbl:FMAP{TP_CLASS,FSET{$TP}};
   -- Table of descendants for each abstract type.   

   attr cur:FSET{TUP{IDENT,INT}};
   -- The set of type names and number of parameters which are in
   -- the process of determining their ancestors. Used to detect loops.
   
   create(prog:PROG):SAME
   -- A type graph for the program `prog'.
   is
      r::=new; r.prog:=prog; 
      return r
   end;

    str
    is
	loop
	    cl::= anc_tbl.ind!;
	    s: STR := cl.str + ":";
	    ancs ::= anc_tbl.get(cl);
	    loop
		anc ::= ancs.elt!;
		s := s + " " + anc.str;
	    end;
	    #ERR + s + "\n";
	end;
    end;
    
   abs_subtype_test(t:$TP, at:TP_CLASS):BOOL
   -- True if the type `t' is a subtype of the abstract type `at'.
      pre at.is_abstract
   is
      if t=at or at=TP_BUILTIN::dollar_ob then return true end;
      typecase t 
      when TP_CLASS then 
	 if get_anc(t).test(at) then return true end;
      else
      end;
      if get_des(at).test(t) then return true end;
      return false
   end;
   
   tup_str(t:TUP{IDENT,INT}):STR
   -- A string for the specified type of the form "FOO{_,_,_}".
   is
      return t.t1.str(t.t2);
   end;
   
   get_parents(tp:TP_CLASS):FSET{TP_CLASS} is
      return par_tbl.get(tp);
   end;
   
   get_children(tp:TP_CLASS):FSET{$TP} is
      return child_tbl.get(tp);
   end;   
   
   make_family_members is
	-- compute parents and children information for all classes
	-- using both subtyping ``>'' and supertyping ``<''
	children:FSET{$TP};
	parents:FSET{TP_CLASS};
	
	loop 
	    t:$TP:=prog.tp_done.elt!;
	    typecase t
	    when TP_CLASS then
		as ::= t.as_tree;
		--*H* as ::= prog.parse.tree_for(t.name, t.params.size);	
		if ~void(as) then 
		    con ::= t.tp_context_for;
		    if ~void(as.under) then
			parents := #;
			children := #;
			ts ::= as.under;
			loop
			    until!(void(ts));
			    tp ::= con.tp_of(ts);
			    typecase tp
			    when TP_CLASS then
				if ~tp.is_abstract then 
				    prog.err("In type " + t.str + " the type " + tp.str + 
					     " appears in the supertype list but is not abstract.") 
				else
				    parents := parents.insert(tp);
				    children := child_tbl.get(tp);
				    children := children.insert(t);
				    child_tbl := child_tbl.insert(tp, children);
				end;
			    else
				prog.err("In type " + t.str + " the type " + tp.str
					 + " appears in the supertype list but is a bound type.")
			    end;
			    ts := ts.next;
			end;
			parents := par_tbl.get(t).to_union(parents);
			par_tbl := par_tbl.insert(t, parents);
		    end;
		    
		    if ~void(as.over) then
			parents := #;
			children := #;	       
			ts ::= as.over;
			loop
			    until!(void(ts));
			    tp ::= con.tp_of(ts);
			    typecase tp
			    when TP_CLASS then
				if tp.is_external then 
				    prog.err("The type " + t.str + " lists the external type "
					     + tp.str + " in its subtype list.")
				else	
				    children := children.insert(tp);
				    parents := par_tbl.get(tp);
				    parents := parents.insert(t);
				    par_tbl := par_tbl.insert(tp, parents);
				end;
			    end;
			    ts := ts.next;
			end;
			children := child_tbl.get(t).to_union(children);
			child_tbl := child_tbl.insert(t, children);
		    end;
		end;
	    else
	    end;
	end;
    end;
    
   get_anc(t:TP_CLASS):FSET{TP_CLASS}
   -- The set of "<" ancestors for `t'. Void if none. $OB is not
   -- explicitly included. Do not modify the returned table.      
   -- Reports an error if there is a loop. All returned types 
   -- should be abstract.
   is
      p ::= anc_tbl.get_pair(t);
      if ~void(p.t1) then return p.t2 end;
      --      parents ::= get_parents(t); 
      parents ::= par_tbl.get(t); 
      if void(parents) then return void end;
      cq ::= #TUP{IDENT,INT}(t.name,t.params.size);
      if cur.test(cq) then 
	  as ::= t.as_tree; --*H* prog.parse.tree_for(t.name, t.params.size)
	  prog.err_loc(as); 
	  s ::= #FSTR + "Subtype cycle detected involving the types: ";
	  loop s:=s+", ".separate!(tup_str(cur.elt!)) end;
	  prog.err(s.str); 
	  anc_tbl := anc_tbl.insert(t,void);
	  cur := cur.delete(cq); 
	  return void
      end;
      r:FSET{TP_CLASS};
      cur:=cur.insert(cq); 
      loop
	 t2 ::= parents.elt!; 
	 r := r.insert(t2); r := r.to_union(get_anc(t2))
      end;
      anc_tbl := anc_tbl.insert(t,r); cur:=cur.delete(cq);
      return r
   end; -- get_anc
   
   get_des(t:TP_CLASS):FSET{$TP}
   -- The set of ">" descendants for `t'. Void if none.
   -- Do not modify the returned table. Reports an error if there
   -- is a loop.
   is
      r:FSET{$TP};
      
      p ::= des_tbl.get_pair(t);
      if ~void(p.t1) then return p.t2 end;
      cld ::= child_tbl.get(t);
      if void(cld) then return void end;
      cq ::= #TUP{IDENT,INT}(t.name,t.params.size);
      if cur.test(cq) then 
	  as ::= t.as_tree; -- *H*prog.parse.tree_for(t.name, t.params.size)
	  prog.err_loc(as); 
	  s ::= #FSTR + "Supertype cycle detected involving the types with "
		"the following names and number of parameters: ";
	  loop s:=s+", ".separate!(tup_str(cur.elt!)) end;
	  prog.err(s.str); 
	  des_tbl := des_tbl.insert(t,void);
	  cur:=cur.delete(cq); 
	  return void
      end;
      cur:=cur.insert(cq); 
      loop
	 t2 ::= cld.elt!; 
	 r := r.insert(t2); 
	 typecase t2
	 when TP_CLASS then r:=r.to_union(get_des(t2))
	 else end
      end;
      des_tbl := des_tbl.insert(t,r);
      cur:=cur.delete(cq);
      return r
   end; -- get_des
   
end; -- class TP_GRAPH

-------------------------------------------------------------------
class TP_GRAPH_ABS_DES is
    -- Table of all concrete descendants of abstract types. 
    
    
--pSather 
    attr gate, mutex, dollar_lock:TP_CLASS;
    
    attr prog:PROG;		-- The program this table belongs to.   
    attr tbl:FMAP{TP_CLASS,FSET{$TP}}; -- Table of concrete descendants 
    -- of each abstract type.   

    create(prog:PROG):SAME is
	-- Compute an abstract descendant table for the program `prog', 
	-- from the explicit ancestor and descendant tables `anc' and
	-- `des'.
	r::=new; r.prog:=prog; return r end;
    
    do_tbl is
	-- Compute the table assuming that `prog.tp_graph' and 
	-- `prog.find_types' are done.
	do_dollar_ob; do_anc; do_des end;
    
    do_dollar_ob is
	-- Put in all concrete types under $OB.
	dob:TP_CLASS:=TP_BUILTIN::dollar_ob;
	tt:FSET{$TP}:=prog.tp_done;
	if void(tt) then return end;
	loop tp::=tt.elt!; 
	    if ~tp.is_abstract then add(dob,tp) end end end;
    
    do_anc is
	-- Put entries in the table based on the subtype edges.
	loop p::=prog.tp_graph.anc_tbl.pairs!; 
	    if ~p.t1.is_abstract then
		loop add(p.t2.elt!,p.t1) end end end end; 
    
    do_des is
	-- Put entries in the table based on the supertype edges.
	loop p::=prog.tp_graph.des_tbl.pairs!; 
	    loop ct::=p.t2.elt!;
		if ~ct.is_abstract then add(p.t1,ct) end end end end;

    add(at:TP_CLASS,ct:$TP) is
	-- Add the concrete type `ct' as one of the descendants of the
	-- abstract type `at'.
	s::=tbl.get(at); s:=s.insert(ct); tbl:=tbl.insert(at,s) end;
    
    des_of(tp:TP_CLASS):FSET{$TP} is
	-- A table of the concrete descendants of the abstract type
	-- `tp'. Void if none.
	return tbl.get(tp) end;
    
end; -- class TP_GRAPH_ABS_DES
    
-------------------------------------------------------------------
class TP_BUILTIN is
    -- Cache for quick access to the type objects for builtin types.

   readonly shared 
	 dollar_ob, bool, char, int, inti, flt, fltd, 
	 fltx, fltdx, flti,  -- The strange ones
	 str, 
	 sys,  ext_ob, 
	 attach, prefetch, 
	 arr_of_str,
	 zone,
   -- Below this point, the shareds are initialized on an as-needed basis
   -- by register_other_builtins
	 fstr,
	 runtime, c_unix,
	 f_integer, f_real, f_logical, f_character, f_double, 
	 f_complex, f_double_complex, f_handler,
	 f_string, 
	 
   -- external C stuff 
	 c_char, c_unsigned_char, c_signed_char, c_short, c_int, c_long, 
	 c_unsigned_short, c_unsigned_int, c_unsigned_long, c_float, 
	 c_double, c_long_double, c_ptr, c_char_ptr, 
	 c_unsigned_char_ptr, c_signed_char_ptr, c_short_ptr, c_int_ptr,
	 c_long_ptr, c_unsigned_short_ptr, c_unsigned_int_ptr,
	 c_unsigned_long_ptr, c_float_ptr, c_double_ptr, c_long_double_ptr, 
	 c_size_t, c_ptrdiff_t : TP_CLASS;
   readonly shared f_array, f_array2, f_array3:ARRAY{TP_CLASS};

   readonly shared rout:TP_ROUT;

    --pSather
    readonly shared gate, mutex, dollar_lock:TP_CLASS;

   -- Identifiers are initialized for use in the case statement in TP_TBL
   -- -- otherwise they would have to regenerated every time the 
   -- case statement is reached
   private shared 
	 fstr_ident,
	 runtime_ident, c_unix_ident,
	 f_integer_ident, f_real_ident, f_logical_ident, 
	 f_character_ident, f_double_ident, 
	 f_complex_ident, f_double_complex_ident, f_handler_ident, 
	 f_rout_ident, f_string_ident, 

   -- external C stuff 
	 c_char_ident, c_unsigned_char_ident, c_signed_char_ident, 
	 c_short_ident, c_int_ident, c_long_ident, c_unsigned_short_ident,
	 c_unsigned_int_ident, c_unsigned_long_ident, 
	 c_float_ident, c_double_ident, c_long_double_ident, c_ptr_ident, 
	 c_char_ptr_ident, c_unsigned_char_ptr_ident, c_signed_char_ptr_ident,
	 c_short_ptr_ident, c_int_ptr_ident, c_long_ptr_ident, 
	 c_unsigned_short_ptr_ident, c_unsigned_int_ptr_ident,
	 c_unsigned_long_ptr_ident, c_float_ptr_ident, c_double_ptr_ident, 
	 c_long_double_ptr_ident, c_size_t_ident, c_ptrdiff_t_ident: IDENT;
   private shared f_array_ident, f_array2_ident, f_array3_ident:IDENT;
   
   initialize(t:TP_TBL,prog:PROG)
	-- A table of builtin types for the program `prog'.
   is
      -- ben: Leave these alone - They are either from pSather or are
      -- manually inserted by the back end during optimizations 
      -- and creation of built-in routines etc.
      dollar_ob:=t.tp_class_for(#IDENT("$OB"),void);
      bool:=t.tp_class_for(#IDENT("BOOL"),void);   
      char:=t.tp_class_for(#IDENT("CHAR"),void);   
      int:=t.tp_class_for(#IDENT("INT"),void);   
      inti:=t.tp_class_for(#IDENT("INTI"),void);   
      flt:=t.tp_class_for(#IDENT("FLT"),void);   
      fltd:=t.tp_class_for(#IDENT("FLTD"),void);   
      str:=t.tp_class_for(#IDENT("STR"),void);   

      sys:=t.tp_class_for(#IDENT("SYS"),void);   
      ext_ob:=t.tp_class_for(#IDENT("EXT_OB"),void);   
      attach:=t.tp_class_for(#IDENT("$ATTACH"),void);   
      prefetch:=t.tp_class_for(#IDENT("PREFETCH"),void);
      
      rout:=t.tp_rout_for(void,void); -- ROUT
      arr:ARRAY{$TP}:=ARRAY{$TP}::create(1); arr[0]:=str;
      arr_of_str:=t.tp_class_for(#IDENT("ARRAY"),arr);

      -- Create IDENTs for the built-in classes that
      -- are not created up-front.  These idents are used
      
      
      -- Fortran arrays can be parametrized over fint, freal, fchar
      -- flogical,fdouble,fcomplex,fdoublecomplex.
      -- These are created in tp_class_for, when needed
      f_array := #(7);
      f_array2 := #(7);
      f_array3 := #(7);

      
      fstr_ident :=  #IDENT("FSTR");
      runtime_ident :=  #IDENT("RUNTIME");
      c_unix_ident :=  #IDENT("C_UNIX");
      f_integer_ident :=  #IDENT("F_INTEGER");
      f_real_ident :=  #IDENT("F_REAL");
      f_logical_ident:=  #IDENT("F_LOGICAL");
      f_character_ident :=  #IDENT("F_CHARACTER");
      f_double_ident:=  #IDENT("F_DOUBLE");
      f_complex_ident:=  #IDENT("F_COMPLEX");
      f_double_complex_ident:=  #IDENT("F_DOUBLE_COMPLEX");
      f_handler_ident:=  #IDENT("F_HANDLER");
      f_rout_ident := #IDENT("F_ROUT");                        
      f_string_ident:=  #IDENT("F_STRING");
      f_array_ident:=  #IDENT("F_ARRAY");
      f_array2_ident:=  #IDENT("F_ARRAY2");
      f_array3_ident:=  #IDENT("F_ARRAY3");
      
      -- external C stuff
      c_char_ident := #IDENT("C_CHAR");
      c_unsigned_char_ident := #IDENT("C_UNSIGNED_CHAR");      
      c_signed_char_ident := #IDENT("C_SIGNED_CHAR");
      c_short_ident := #IDENT("C_SHORT");      
      c_int_ident := #IDENT("C_INT");
      c_long_ident := #IDENT("C_LONG");      
      c_unsigned_short_ident := #IDENT("C_UNSIGNED_SHORT");      
      c_unsigned_int_ident := #IDENT("C_UNSIGNED_INT");      
      c_unsigned_long_ident := #IDENT("C_UNSIGNED_LONG");
      c_float_ident := #IDENT("C_FLOAT");      
      c_double_ident := #IDENT("C_DOUBLE");      
      c_long_double_ident := #IDENT("C_LONG_DOUBLE");
      
      c_ptr_ident := #IDENT("C_PTR");      
      c_char_ptr_ident := #IDENT("C_CHAR_PTR");
      c_unsigned_char_ptr_ident := #IDENT("C_UNSIGNED_CHAR_PTR");      
      c_signed_char_ptr_ident := #IDENT("C_SIGNED_CHAR_PTR");
      c_short_ptr_ident := #IDENT("C_SHORT_PTR");      
      c_int_ptr_ident := #IDENT("C_INT_PTR");
      c_long_ptr_ident := #IDENT("C_LONG_PTR");      
      c_unsigned_short_ptr_ident := #IDENT("C_UNSIGNED_SHORT_PTR");      
      c_unsigned_int_ptr_ident := #IDENT("C_UNSIGNED_INT_PTR");      
      c_unsigned_long_ptr_ident := #IDENT("C_UNSIGNED_LONG_PTR");
      c_float_ptr_ident := #IDENT("C_FLOAT_PTR");      
      c_double_ptr_ident := #IDENT("C_DOUBLE_PTR");      
      c_long_double_ptr_ident := #IDENT("C_LONG_DOUBLE_PTR");      

      c_size_t_ident := #IDENT("C_SIZE_T");
      c_ptrdiff_t_ident := #IDENT("C_PTRDIFF_T");      
      
      --pSather
      dollar_lock:=t.tp_class_for(#IDENT("$LOCK"),void);

      -- Zones
      if prog.zones then
	 zone:=t.tp_class_for(#IDENT("ZONE"),void);
      end;
   end;
   
   
   register_other_builtins(class_name:IDENT, r:TP_CLASS,params:ARRAY{$TP}) is
      -- If one of the other classes that was not initialized in the
      -- beginning is reached, initialize it later
      -- Called by TP_TBL::tp_class_for
      case class_name
      when fstr_ident then fstr := r;
      when runtime_ident then runtime := r;
      when c_unix_ident then c_unix := r;
      when f_integer_ident then f_integer := r;
      when f_real_ident then f_real := r;
      when f_logical_ident then f_logical:=r;
      when f_character_ident then  f_character := r;
      when f_double_ident then f_double:=r;
      when f_complex_ident then f_complex:=r;
      when f_double_complex_ident then	 f_double_complex:=r;
      when f_handler_ident then f_handler:=r;
      when f_rout_ident then f_handler:=r;	 
      when f_string_ident then  f_string :=r;
      when f_array_ident then
	 assert (params.size = 1);
	 add_builtin_farray(r,f_array);
      when f_array2_ident then
	 assert (params.size = 1);
	 add_builtin_farray(r,f_array2);
      when f_array3_ident then
	 assert (params.size = 1);
	 add_builtin_farray(r,f_array3);
	 
      when c_char_ident then c_char := r;
      when c_unsigned_char_ident then c_unsigned_char := r;	 
      when c_signed_char_ident then c_signed_char := r;
      when c_short_ident then c_short := r;	 
      when c_int_ident then c_int := r;	 	 
      when c_long_ident then c_long := r;	 
      when c_unsigned_short_ident then c_unsigned_short := r;	 	 
      when c_unsigned_int_ident then c_unsigned_int := r;	 
      when c_unsigned_long_ident then c_unsigned_long := r;	 
      when c_float_ident then c_float := r;	 	 
      when c_double_ident then c_double := r;	 
      when c_long_double_ident then c_long_double := r;	 	 

      when c_ptr_ident then c_ptr := r;	 
      when c_char_ptr_ident then c_char_ptr := r;
      when c_unsigned_char_ptr_ident then c_unsigned_char_ptr := r;	 
      when c_signed_char_ptr_ident then c_signed_char_ptr := r;
      when c_short_ptr_ident then c_short_ptr := r;	 
      when c_int_ptr_ident then c_int_ptr := r;	 	 
      when c_long_ptr_ident then c_long_ptr := r;	 
      when c_unsigned_short_ptr_ident then c_unsigned_short_ptr := r;
      when c_unsigned_int_ptr_ident then c_unsigned_int_ptr := r;	 
      when c_unsigned_long_ptr_ident then c_unsigned_long_ptr := r;	 
      when c_float_ptr_ident then c_float_ptr := r;	 	 
      when c_double_ptr_ident then c_double_ptr := r;	 
      when c_long_double_ptr_ident then c_long_double_ptr := r;	 	 
	 
      when c_size_t_ident then c_size_t := r;
      when c_ptrdiff_t_ident then c_ptrdiff_t := r;	 
	 
      else
	 -- Do nothing
      end;
   end;

     private add_builtin_farray(r: TP_CLASS,arr: ARRAY{TP_CLASS}) is
      -- Add "r" to an array of builtin fortran array types, if it
      -- is not already there. -ben
      i ::= 0;
      loop until!(i=arr.size);
	 fel ::= arr.elt!;
	 if r = fel then break! end;
	 if void(fel) then arr[i] := r; break!; end;
	 i := i + 1;
      end;
      -- This error will occur if for some reason the pre-created
      -- fortran arrays are different in size from the number of
      -- legal parametrizations
      if i = arr.size then
	 #ERR+"INTERNAL ERROR.Builtin F_ARRAY Error.\n";
	 #ERR+r.name.str+" array size="+arr.size+ " i="+i+"\n";
      end;
   end;
   
end; -- class TP_BUILTIN
-------------------------------------------------------------------
