------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1994 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>  <--------------

-- impl.sa: Type implementations.
-------------------------------------------------------------------
-- IMPL: The implementation of a type. 
-- IMPL_TBL: A table of implementations indexed by type.
-- IMPL_INCLUDE: Information for handling an `include' clause.
-- IMPL_CREATE: An object used while creating an interface.
-------------------------------------------------------------------

class IMPL is
   -- The implementation of a type. 
   include SELECT_SIG; -- needed to resolve overloaded calls
   
   attr tp:$TP;			-- The type this is for.
   attr ifc:IFC;		-- The public interface of the type.
   attr elts:ELT_TBL;		-- The elements of the type.
   attr arr:TP_CLASS;		-- AREF{T} or AVAL{T} if there is an
   private attr is_ref_cache:BOOL;
   private attr use_ref_cache:BOOL;
      -- include path to one of them, or void if not. 
      
   prog:PROG is
      -- The program this belongs to.
      return tp.prog end;

   create:SAME is
      -- An empty IMPL object.
      return new end;
   
   sig_for_internal_call(c:CALL_SIG):SIG 
      -- The signature in self which corresponds to the internal call 
      -- signature `c'. err_call_sig if none. Reports an error if the call 
      -- is ambiguous or missing (assumes that "err_loc" has been set).
      pre ~void(c)
    is
	r:SIG;
	sig_list:FLIST{SIG}:=#;  --a list of sigs conformed to by the call
	loop
	    s::=elts.get_query!(c.name).sig;
	    if c.conforms_to(s) then
		if c.unknown_ret or (c.has_ret = ~void(s.ret)) then
		    sig_list := sig_list.push(s);
		end;
	    end
	end;
      
	r := select_sig(c, sig_list, true);
      
      if void(r) then
	 found_one ::= false;
	 res ::= "";
	 loop s ::= elts.get_query!(c.name).sig;
	    found_one := true;
	    res := res+" or\n\t".separate!(s.str);
	 end;
	 -- #ERR+"Printing result:"+res+"\n";
	 print_err: STR := c.str;
	 if found_one then
	    print_err := print_err+"\n"+"\tSuggest:"+res;
	 end;
	 c.prog.err("No match for the internal call " + print_err);
      end;
      return r;
   end;

   sig_for_call(c:CALL_SIG):SIG is
      -- The signature in the public interface which corresponds to
      -- the call `c'. Void if none. Reports an error if the call is
      -- ambiguous or missing (assumes that "err_loc" has been set).
      return ifc.sig_for_call(c) end;

   elt_with_sig(s:SIG):ELT is
      -- The element in this implementation with the signature `s',
      -- if present, void if not.
      return elts.elt_with_sig(s) end;

   has_invariant:BOOL is
      -- True if this implementation defines a routine: `invariant:BOOL'.
      loop 
	 if elts.get_query!(IDENT_BUILTIN::invariant_ident).is_invariant then
	    return true end end;
      return false end;
   
   invariant_sig:SIG is
      -- Return the invariant signature if there is one, void if not.
      loop e::=elts.get_query!(IDENT_BUILTIN::invariant_ident);
	 if e.is_invariant then return e.sig end end;
      return void end;

   asize_val:INT is
      -- If `asize' is defined as an integer constant, this returns its
      -- value. Otherwise it returns -1.
      loop asze::=elts.get_query!(IDENT_BUILTIN::asize_ident);
	 if asze.is_const_reader and 
	    asze.sig.ret=TP_BUILTIN::int then
	       as::=asze.as;
	       typecase as 
	       when AS_CONST_DEF then
	          ai::=as.init;
		  typecase ai when AS_INT_LIT_EXPR then
		     return ai.val.int;
		  else
		     #OUT + "TYPE: "+tp+"\n";
		     prog.barf("asize for AVAL has to be a integer literal!");
		  end;
	       else
		  #OUT + "TYPE: "+tp+"\n";		     
	          prog.barf("asize for AVAL has to be a integer literal!");
	       end;
	 else return -1 end end;
      return -1; -- added this ???
   end;

   C_name_val:STR is
      return string_const_val(IDENT_BUILTIN::C_name_ident);
   end;

   C_header_val:STR is
      return string_const_val(IDENT_BUILTIN::C_header_ident);
   end;
   
   string_const_val(ident:IDENT):STR is
      -- if the constant with a name ``ident'' is defined in the class,
      -- this returns its string value. Otherwise, void.
      
      loop cnst::=elts.get_query!(ident);
	 if cnst.is_const_reader and 
		  cnst.sig.ret=TP_BUILTIN::str then
	    as::=cnst.as;
	    typecase as 
	    when AS_CONST_DEF then
	       ai::=as.init;
	       typecase ai when AS_STR_LIT_EXPR then
		  return ai.s;
	       else
		  #OUT + "TYPE: "+tp+"\n";
		  prog.barf(ident.str+" for an external C class  has to be a string literal!");
	       end;
	    else
	       #OUT + "TYPE: "+tp+"\n";		     
	       prog.barf(ident.str+" for an external C class  has to be a string literal!");
	    end;
	 else return 
	    void 
	 end 
      end;
      return void; -- added this ???
   end;
   
    is_reference_free:BOOL pre ~void(self) is
       -- return true if we can be allocated atomically.
       if use_ref_cache then return is_ref_cache; end;
       use_ref_cache:=true;
       if tp.is_builtin then
	  d::=prog.config.get_def("REFERENCE_FREE");
	  loop e::=d.elt!;
	     loop
		c::=e.elt!;
	        if tp.str=c then 
		   is_ref_cache:=true;
		   return true;
	        end;
	     end;
	  end;
	  is_ref_cache:=false;
	  return false;
       end;

       loop e::= elts.elt!;
        if e.is_attr_reader then
           atp::=e.sig.ret;    -- the type of this attribute.
           if ~(atp.is_immutable) then
              -- we have a reference type or bound type.
              --#ERR + tp.str + " is non-atomic because attribute "
              --+e.sig.str+" is not a value type\n";
	      is_ref_cache:=false;
              return false;
           end;
           if ~(atp.is_reference_free) then
              --#ERR + tp.str + " is non-atomic because value attribute "
              --+e.sig.str+" is not atomic\n";
	      is_ref_cache:=false;
              return false;
           end;
        end;
       end;
       -- now we check included AREF{T} or AVAL{T}.
       if void(arr) then
        -- guess it's OK
        --#ERR + tp.str + " looks atomic with no included AREF/AVAL\n";
	is_ref_cache:=true;
        return true;
       else
        -- now we need implementation of array portion to find out
        -- it's type parameter.
        if void(arr.params) then
           --#ERR + "Void parameter list in inclusion of AREF{T}\n";
	   is_ref_cache:=false;
           return false;
        elsif arr.params.asize /= 1 then
           --#ERR + "Funny, >1 type param found in AREF{T} atomic checking.\n";
	   is_ref_cache:=false;
           return false;
        else
           tparam ::= arr.params[0];
           if ~(tparam.is_immutable) then
              --#ERR + tp.str + " is non-atomic because included array param "
              --+ " is not immutable type.\n";
	      is_ref_cache:=false;
              return false;
           elsif ~(tparam.is_reference_free) then
              --#ERR + tp.str + " is non-atomic because included value" +
              --" array param is not atomic.\n";
	      is_ref_cache:=false;
              return false;
           else
              --#ERR + tp.str + " looks atomic with atomic AREF/AVAL.\n";
	      is_ref_cache:=true;
              return true;
           end;
        end;
       end;  
    end;

end; -- class IMPL
   
-------------------------------------------------------------------
class IMPL_INCLUDE is
   -- Information for handling an `include' clause.
   
   attr tp:TP_CLASS;		-- The type with the include clause.
   attr as:AS_INCLUDE_CLAUSE;	-- The include clause.
   attr itp: TP_CLASS;          -- The included class.
   attr con:TP_CONTEXT;         -- The context, in which impl is to be created.
   attr impl:IMPL;		-- The implementation of the included class
                                -- but with SAME referring to 'tp'.
   attr used_mods:FSET{AS_FEAT_MOD};  -- The modifiers which were used.
   attr elt_tbl:ELT_TBL;	-- The translated included elements.   
   
   prog:PROG is
      -- The program object for this interface.
      return tp.prog end;   
   
   create(
        tp:TP_CLASS,              -- Class which includes.
        as:AS_INCLUDE_CLAUSE,     -- AS-tree of the include.
        context:TP_CONTEXT        -- Context in which the include occured.
      ):SAME 
      -- Compute the "include" information corresponding to the clause
      -- `as' within the definition of the type `tp'. If there  
      -- is an error, return void.
      pre ~void(tp) and ~void(as)
   is
      r::=new; r.tp:=tp; r.as:=as;
      r.con := context;
      r.itp:=r.included_tp;
      if void(r.itp) then return void end;      
      if tp.prog.show_include then
	 #OUT + "(Including " + r.itp.str + " in " +
	    tp.str + ") " end;
      r.impl:=r.included_impl;
      if void(r.impl) then return void end;
      if r.test_array_err then return void end;
      if r.test_duplicate_feat_mod_err then return void end;
      r.elt_tbl:=r.included_elt_tbl; 
      if void(r.elt_tbl) then return void end;
      return r
   end;
      
   included_tp:TP_CLASS is
      -- Compute the type which is included by the clause `as' in
      -- the type `tp'. Print an error and return void if the included
      -- type is external, bound, or a type parameter.
      if con.type_spec_is_param(as.tp) then
	 param_include_err(as); return void
      end;
      r::=con.tp_of(as.tp,false); 
      typecase r
      when TP_CLASS then
	 if r.is_abstract then 
	    prog.err_loc(as); 
	    prog.err("Classes may not include abstract types."); 
	    return void end;
	 if r.is_external then 
	    include_ext_err(as); return void end;	 
	 return r
      when TP_ROUT then
	 include_bound_err(as); return void
      when TP_ITER then
	 include_bound_err(as); return void
      end 
   end;
   
   param_include_err(t:$AS_CLASS_ELT) is
      prog.err_loc(t);
      prog.err("Type specifiers in include clauses may not be class "
      "parameters.") end;
   
   include_ext_err(t:$AS_CLASS_ELT) is
      prog.err_loc(t);
      prog.err("Classes may not include external types.") end;
      
   include_bound_err(t:$AS_CLASS_ELT) is
      -- Print an error message about including bound types.
      prog.err_loc(t);
      prog.err("Classes may not include bound types.") end;
   
   include_readonly_err(t:$AS_CLASS_ELT) is
      -- Print an error message if a reader or writer (or both) 
      -- are missing for readonly features.
      prog.err_loc(t);
      prog.err("Both reader and writer routines must be present for readonly modifier"); 
   end;

   included_impl:IMPL
      -- Compute the implementation `impl' of the included 
      -- type. Set the location for reporting an error in case a loop 
      -- is found.
   is
      prog.err_loc(as);
      itp_context ::= itp.tp_context_for;
      subcon ::= #TP_CONTEXT(con.same,
        itp_context.pnames, itp_context.ptypes, prog);
      return IMPL_CREATE::impl_of( itp, subcon );
   end;
   
   test_array_err:BOOL is
      -- Print an error message and return true if `tp' is a value type
      -- and `itp' includes AREF or if `tp' is a reference type and
      -- `itp' includes AVAL.
      k:INT:=tp.kind;
      if void(impl.arr) then return false end;
      if k=TP_KIND::val_tp and 
	 impl.arr.name=IDENT_BUILTIN::AREF_ident then
	 prog.err_loc(as); 
	 prog.err("The value type " + tp.str +
	 " may not have an include path to the reference array type " +
	 impl.arr.str + '.');
	 return true
      elsif (k=TP_KIND::ref_tp or k=TP_KIND::spr_tp) and 
	 impl.arr.name=IDENT_BUILTIN::AVAL_ident then
	 prog.err_loc(as); 
	 prog.err("The reference type " + tp.str +
	 " may not have an include path to the value array type " +
	 impl.arr.str + '.');
	 return true end;
      return false end;
   
   test_duplicate_feat_mod_err:BOOL is
      -- If two feature modifiers have the same name then print
      -- an error and return true, otherwise return false. 
      m1::=as.mods;
      loop until!(void(m1));
	 m2::=as.mods;
	 loop until!(void(m2));
	    if ~SYS::ob_eq(m1,m2) and m1.name=m2.name then
	       prog.err_loc(m1);
	       prog.err("There are two feature modifiers for the name: " + 
	       m1.name.str + "."); 
	       return true end;
	    m2:=m2.next end;
	 m1:=m1.next end;
      return false end;

   modifier_for_name(i:IDENT):AS_FEAT_MOD is
      -- Return the feature modifier in `as' for the name `i', or
      -- void, if there isn't one for that name.
      e::=as.mods;
      loop until!(void(e)); if e.name=i then 
	 used_mods:=used_mods.insert(e);
	 return e; 
      end;
	 e:=e.next end;
      return void end;   

   included_elt_tbl:ELT_TBL is
      -- The table of elements as transformeded by the new value of SAME 
      -- and any feature modification clauses. 
      r:ELT_TBL;
      loop e::=impl.elts.elt!; en::=modify_elt(e);
	 if ~void(en) then
	     f::=r.elt_conflicting_with(en);
	     if ~void(f) then 
		 include_conflict_err(en,f);
	    else r:=r.insert(en) end end end;
      if used_mods.size/=as.mods.size then
	 m::=as.mods;
	 loop until!(void(m));
	    if ~used_mods.test(m) then unused_mod_err(m) end;
	    m:=m.next end end;
      return r end;
   
   include_conflict_err(en,f:ELT) is
      prog.err_loc(as);      
      prog.err("Two of the included signatures conflict: " +
      en.sig.str + " and " + f.sig.str + ".") end;      

   unused_mod_err(t:AS_FEAT_MOD) is
      prog.err_loc(t);
      prog.err("There are no features with the name: " + t.name.str 
         + ".") end;

   modify_elt(e:ELT):ELT 
      -- Make a new element from `e' by changing its name by the 
      -- modifiers in `as', by changing SAME to have the value
      -- `tp', and by modifying `is_private' according to the include
      -- clause and feature modifier. Make `srctp' be the old `srctp'.
      -- Return void if an error or if the element is made to be undefined.
      pre ~void(e) and ~void(con)
   is
      --con::=#TP_CONTEXT(tp, e.con.pnames, e.con.ptypes, prog);
      --if void(con) then return void end;
      con ::= e.con; -- WARNING !!! SHADOWS CONTEXT OF IMPL_CREATE
      name:IDENT; read_pri:BOOL; write_pri:BOOL;
      m::=modifier_for_name(e.name);
      srcparams ::= e.srcsig.src_tparams;
      if ~void(m) then		-- Have a matching modifier. 
	 if m.new_name=#IDENT(void) then return void end; -- Feat undef.
	 name:=m.new_name; 
	 read_pri:=m.is_private; 
	 write_pri:=m.is_private or m.is_readonly;
	 -- if readonly, need to make sure that the included class
	 -- has both the reader and writer routines
	 if m.is_readonly then
	    has_reader:BOOL := false;
	    has_writer:BOOL := false;
	    loop
	       elt::=impl.elts.get_query!(e.name);
	       es ::= elt.sig;
	       if es.is_reader_sig then
		  has_reader := true;
	       elsif es.is_attr_writer_sig or es.is_shared_writer_sig then
		  has_writer := true;
	       end;
	    end;
	    if ~(has_reader and has_writer) then
	       include_readonly_err(as);
	       return void;
	    end;
	 end;
      else name:=e.name;
	 read_pri:=as.is_private or e.is_private; 
	 write_pri:=read_pri end;
      sig:SIG; pri:BOOL;
      eas::=e.as; typecase eas
      when AS_CONST_DEF then 
	 sig:=SIG::const_reader_sig(eas,name,srcparams,con); pri:=read_pri;
      when AS_SHARED_DEF then
	 if e.is_shared_writer then 
	    sig:=SIG::shared_writer_sig(eas,name,srcparams,con);
            pri:=write_pri;
	 else 
	    sig:=SIG::shared_reader_sig(eas,name,srcparams,con);
            pri:=read_pri end;
      when AS_ATTR_DEF then	    
	 if e.is_attr_writer then 
	     sig:=SIG::attr_writer_sig(eas,name,srcparams,con); pri:=write_pri;
	 else 
	    sig:=SIG::attr_reader_sig(eas,name,srcparams,con);
	    pri:=read_pri;
         end;
      when AS_ROUT_DEF then 
	 sig:=SIG::rout_sig(eas,name,srcparams,con); 
	 -- if ``readonly'' feature modifier used, use read_pri for readers
	 -- and write_pri for writers
	 pri:=read_pri; 	 	 
	 
	 if ~void(m) then
	    if m.is_readonly then
	       if ~sig.is_reader_sig then
		  pri := write_pri;
	       end;
	    end;
	 end;
      end;
      if void(sig) then return void end;
      return ELT::create(sig, e.srcsig, e.as, con, pri) end;
	 
end; -- class IMPL_INCLUDE

-------------------------------------------------------------------
class IMPL_CREATE is
   -- An object used while creating an interface.
   
   attr tp:TP_CLASS;		-- The type it is for.
   attr is_external:BOOL;	-- True if an external class. 
   attr con:TP_CONTEXT;		-- The type context for tp.
   attr as:AS_CLASS_DEF;	-- The definition tree for tp.
   attr class_elts:ELT_TBL;	-- Table of the elements explicitly
      -- defined by this class. 
   attr incs:FLIST{IMPL_INCLUDE}; -- A list of information
      -- computed from each include clause. 

   create_for_tp_class(t:TP_CLASS): IMPL
      -- Computes the implementation of type 't'.
      pre ~void(t) and void(self)
   is
      if t.is_abstract then return void end;
      return impl_of(t,t.tp_context_for);
   end;
   
   impl_of(t:TP_CLASS,context:TP_CONTEXT):IMPL 
      -- Compute the implementation of the type `t'.
      pre ~void(t)
   is
      if t.prog.show_impl_create then
	 #OUT + "(Impl create " + t.str + ") Context = " + context.str +"\n"
      end;
      ic:IMPL_CREATE:=new; ic.tp:=t;
      ic.is_external:=t.is_external;
      ic.con:=context;
      if void(ic.con) then return void end;
      ic.as:=t.as_tree; --*H* ic.prog.parse.tree_for(t.name,t.params.size);
      if void(ic.as) then return void end;
      ic.class_elts:=ic.explicit_class_elts;
      ic.do_incs;
      r::=#IMPL; r.tp:=t; 
      r.arr:=ic.get_arr; 
      r.elts:=ic.elt_tbl;
      r.ifc:=r.elts.public_ifc;
      if void(r.ifc) then r.ifc:=IFC::create(void,t) end;
      return r end;

   prog:PROG is
      -- The program this belongs to.
      return tp.prog end;
   
   explicit_class_elts:ELT_TBL is
      -- A table of class elements explicit defined in the class 
      -- (i.e. ignoring "include" clauses). Prints an error 
      -- if features with conflicting signatures are defined.
      t:$AS_CLASS_ELT:=as.body; r:ELT_TBL;
      loop while!(~void(t)); 
	 er:ELT:=reader_elt_for(t);
	 if ~void(er) then
	    if is_external then
	       f:ELT:=r.elt_same_name_as(er);
	       if ~void(f) then ext_conflict_err(er,f)
	       else r:=r.insert(er) end;
	    else
	       f:ELT:=r.elt_conflicting_with(er);
	       if ~void(f) then reader_conflict_err(er,f)
	       else r:=r.insert(er) end end end; 
	 ew:ELT:=writer_elt_for(t);
	 if ~void(ew) then
	    f:ELT:=r.elt_conflicting_with(ew);
	    if ~void(f) then writer_conflict_err(ew,f)
	    else r:=r.insert(ew) end end;
	 t:=t.next;
      end;
      return r end;

   reader_conflict_err(er,f:ELT) is
      prog.err_loc(er.as);
      prog.err("The signature: " + er.sig.str +
      " of the reader routine for this feature conflicts with "
      "the earlier feature signature: " + f.sig.str + '.') end;

   ext_conflict_err(er,f:ELT) is
      prog.err_loc(er.as);
      prog.err("The signature: " + er.sig.str +
      " has the same name as the earlier feature signature: " +
      f.sig.str + " in an external class.") end;
   
   writer_conflict_err(ew,f:ELT) is
      prog.err_loc(ew.as);
      prog.err("The signature: " + ew.sig.str +
      " of the writer routine for this feature conflicts with " 
      "the earlier feature signature: " + f.sig.str + '.') end;

   reader_elt_for(t:$AS_CLASS_ELT):ELT 
      -- The "reader" elt corresponding to `t' if there is one, 
      -- void if not.
      pre ~void(t) is
      sig:SIG; r:ELT;
      typecase t
      when AS_CONST_DEF then
	 if is_external and ~tp.is_c then prog.err_loc(t);
	    prog.err("External classes may not define constants.");
	    return void end;
	 sig:=SIG::const_reader_sig(t,t.name,con.ptypes,con)
      when AS_SHARED_DEF then 
	 if is_external and ~tp.is_c then prog.err_loc(t);
	    prog.err("External classes may not define shareds.");
	    return void end;
	 sig:=SIG::shared_reader_sig(t,t.name,con.ptypes,con)
      when AS_ATTR_DEF then 
	 if is_external and ~tp.is_c then prog.err_loc(t);
	    prog.err("External classes may not define attributes.");
	    return void 
	 end;
	 sig:=SIG::attr_reader_sig(t,t.name,con.ptypes,con)
      when AS_ROUT_DEF then 
	 sig:=SIG::rout_sig(t,t.name,con.ptypes,con);
	 if t.is_abstract then
	    if is_external then
	       if ~sig.is_legal_ext_abs then return void end;
	       r:=ELT::create(sig,sig,t,con,t.is_private); 
	       r.is_external:=true; return r
	    elsif ~tp.is_partial then
	       prog.err_loc(t);
	       prog.err("Stub features or features without bodies not allowed."); return void end;
	 elsif is_external then
	    if ~sig.is_legal_ext_bod then return void end;
	    r:=#ELT(sig,sig,t,con,t.is_private); 
	    r.is_external:=true; return r end;
      else return void end; -- Nothing for includes
      if void(sig) then return void end;
      r:=#ELT(sig,sig,t,con,t.is_private);
      return r end;
   
   writer_elt_for(t:$AS_CLASS_ELT):ELT is
      -- The "writer" elt corresponding to `t' if there is one, 
      -- void if not.
      sig:SIG; pri:BOOL;
      if is_external and ~tp.is_c then return void end; 
      -- Already complained at reader.
      typecase t
      when AS_SHARED_DEF then
	 sig:=SIG::shared_writer_sig(t,t.name,con.ptypes,con);
	 pri:=t.is_private or t.is_readonly; 	 
      when AS_ATTR_DEF then
	 sig:=SIG::attr_writer_sig(t,t.name,con.ptypes,con); 
	 pri:=t.is_private or t.is_readonly; 	 
      else return void end;      
      if void(sig) then return void end;
      return ELT::create(sig,sig,t,con,pri) end;
   
   do_incs is
      -- Compute and fill in `incs' with information computed from 
      -- each include statement in `tp'.
      e:$AS_CLASS_ELT:=as.body;
      loop while!(~void(e));
	 typecase e
	 when AS_INCLUDE_CLAUSE then
	    if is_external then prog.err_loc(e);
	       prog.err("External classes may not have include clauses.");
	    else
	       ii::=IMPL_INCLUDE::create(tp, e, con);
	       if ~void(ii) then incs:=incs.push(ii) end end;
	 else end;
	 e:=e.next end end;

   get_arr:TP_CLASS is
      -- If we include AREF{T} or AVAL{T} or any class which includes
      -- one of these return it. If we include more than one and they
      -- are different, then print an error.
      if tp.name=IDENT_BUILTIN::AREF_ident and tp.params.size=1 then 
	 return tp end;
      if tp.name=IDENT_BUILTIN::AVAL_ident and tp.params.size=1 then 
	 return tp end;      
      r:TP_CLASS;
      loop
         inc::=incs.elt!;
         a::=inc.impl.arr;
	 if ~void(a) then
	    if void(r) then r:=a;
	    elsif r=a then	-- They agree.
	    else 
	       array_conflict_err(inc,r,a)
            end
         end
      end;
      return r
   end;
   
   array_conflict_err(inc:IMPL_INCLUDE, a1,a2:TP_CLASS) is
      prog.err_loc(inc.as);
      prog.err("This class has include paths to the array types: " +
      a1.str + " and " + a2.str + '.') end;
   
   elt_tbl:ELT_TBL is
      -- Compute the final element table for the class. Print an error 
      -- if there is a conflict.
      r:ELT_TBL;
      loop r:=r.insert(class_elts.elt!) end;
      loop while!(incs.is_empty.not); inc::=incs.pop; 
	 loop e::=inc.elt_tbl.elt!;
	    f::=r.elt_conflicting_with(e);

	    -- DPS: added "and ~f.is_ATTR_access" below
	    -- Need is_attr_acess only if the non attr sig is not a stub
	    -- Boris 6/6/96
	    if ~void(f) then
	       if ~((inc.itp.is_partial and e.is_abstract) or 
		    (tp.is_partial and f.is_abstract)) then
		  if e.is_attr_access and ~f.is_attr_access and ~f.is_abstract
		  then
		     attr_conflict_err(e,f,inc) 
		  end;
	       end;
	    end;
	       
	    if void(f) and (~e.is_abstract or tp.is_abstract or 
			    inc.itp.is_partial) then
	       -- Note, that we get stubs from partial classes
	       -- that will need to be overwritten at some point
	       loop inc2::=incs.elt!;
		   g::=inc2.elt_tbl.elt_conflicting_with(e);
		  if ~void(g) then 
		     -- stubs don't cause a conflict error when
		     -- colliding with implemented included features
		     if ~((inc.itp.is_partial and e.is_abstract) or
			  (inc2.itp.is_partial and g.is_abstract)) then    
			include_conflict_err(inc,inc2,e,g) 
		     end;
		  end;
	       end;
	       r:=r.insert(e) 
	    end; 
	    
	    if ~tp.is_abstract then
	       if ~void(f) then -- overwrite stubs
		  if f.is_abstract and ~e.is_abstract then
		     r := r.delete(f);
		     r := r.insert(e);
		  end;
	       end;
	    end;
	 end 
      end;
      
      -- make sure all stubs have been implemented
      if ~tp.is_partial and ~tp.is_abstract and ~tp.is_external then
	 loop
	    e ::= r.elt!;
	    if e.is_abstract then
	       undef_stub_err(e);
	    end;
	 end;
      end;
      return r 
   end;

   attr_conflict_err(e,f:ELT, inc:IMPL_INCLUDE) is
      prog.err_loc(f.as);
      prog.err("This explicitly defined routine conflicts with "
      "the attribute access routine: " + e.sig.str + 
	       " which is included from " + inc.itp.str + ".") end;
   
   undef_stub_err(e:ELT, inc:IMPL_INCLUDE) is
      prog.err_loc(as);
      prog.err("Unimplemented stub: " + e.sig.str + 
	       " which is included from " + inc.itp.str + ".") 
   end;

   undef_stub_err(e:ELT) is
      prog.err_loc(as);
      prog.err("Unimplemented stub: " + e.sig.str)
   end;
   
   include_conflict_err(inc,inc2:IMPL_INCLUDE, e,g:ELT) is
      prog.err_loc(inc.as);
      prog.err("This includes the feature: " + e.sig.str + 
      " which conflicts with: " + g.sig.str + 
      " which is included from: " + inc2.itp.str + ".") end;      
   
end; -- class IMPL_CREATE

-------------------------------------------------------------------


