check_ifc_conformance.sa

 
---------------------------> Sather 1.1 source file <--------------------------


class CHECK_IFC_CONFORMANCE < $CHECK_IFC_CONFORMANCE 
class CHECK_IFC_CONFORMANCE < $CHECK_IFC_CONFORMANCE is
    -- This phase checks the conformance of interfaces for each
    -- type against its parents and children.

    include CS_COMPONENT;
   
    create(p:PROG):SAME
    is
       r::=new; r.prog:=p; return r-- CHECK_IFC_CONFORMANCE::prog
    end;
   
    check_ifc_conformance
        -- Check all type interfaces for conformance to their ancestors
        -- and descendants.
    is
        loop
            tp ::= prog.tp_done.elt!;-- CHECK_IFC_CONFORMANCE::prog PROG::tp_done FSET{1}::elt!
            typecase tp
            when TP_CLASS then
                ti:IFC := tp.ifc; -- this computes also the impl's.-- TP_CLASS::ifc
                if void(ti) then 
                    err_loc(void);  -- Don't print a source location-- CHECK_IFC_CONFORMANCE::err_loc
                    err("Can't compute interface of "+ tp.str + ".");-- CHECK_IFC_CONFORMANCE::err STR::plus TP_CLASS::str STR::plus
                    return
                end;
                if prog.show_ifc then ti.show end;-- CHECK_IFC_CONFORMANCE::prog PROG::show_ifc IFC::show
                loop
		   parents:TP_CLASS := prog.tp_graph.get_parents(tp).elt!;-- CHECK_IFC_CONFORMANCE::prog PROG::tp_graph TP_GRAPH::get_parents FSET{1}::elt!
		   pi:IFC := parents.ifc;-- TP_CLASS::ifc
		   ncs:FLIST{SIG} := ti.nonconforming_sig_list(pi);-- IFC::nonconforming_sig_list
		   -- print_err: STR := "The interface of type " + tp.str
		   --      + " doesn't have a signature conforming to "
		   --	    + ncs.str + " in its parent " + parents.str + ".";
		   if ~void(ncs) then-- BOOL::not
		      print_err: STR := "The interface of type "+tp.str-- STR::plus TP_CLASS::str
	   	          +" doesn't conform to its parent: "+parents.str+".";-- STR::plus STR::plus TP_CLASS::str STR::plus
		      sigtbl: SIG_TBL := ti.sigs; -- What we *do* have-- IFC::sigs
		      loop sig_index:INT := ncs.size.times!;-- FLIST{1}::size INT::times!
			 asig:SIG := ncs[sig_index];-- FLIST{1}::aget
			 -- Look for a match in name but not in type
			 found_one ::= false;
			 sug_str: STR := "";
			 loop actual:SIG := sigtbl.get_query!(asig.name);-- SIG_TBL::get_query! SIG::name
			    found_one := true;
			    sug_str:=sug_str+
				  " and\n\t   ".separate!(actual.str);-- STR::plus STR::separate! SIG::str
			 end;
			 print_err := print_err
			       +"\n\t"+(sig_index+1)+")For signature:"+asig.str;-- STR::plus STR::plus INT::plus STR::plus STR::plus SIG::str
			 if found_one then
			    print_err := print_err+"\n\t  It has:"+sug_str;-- STR::plus STR::plus
			 end;
		      end;
		      err_loc(prog.parse.tree_for(tp.name,tp.params.size));-- CHECK_IFC_CONFORMANCE::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
                        -- *H* (Don't) print a source location
		      err( print_err);-- CHECK_IFC_CONFORMANCE::err
                    end
                end;
                loop
                    chld:$TP := prog.tp_graph.get_children(tp).elt!;-- CHECK_IFC_CONFORMANCE::prog PROG::tp_graph TP_GRAPH::get_children FSET{1}::elt!
                    typecase chld
                    when TP_CLASS then
                        if ~chld.ifc.conforms_to(ti) then-- TP_CLASS::ifc IFC::conforms_to BOOL::not
                            err_loc(prog.parse.tree_for(tp.name,tp.params.size)); -- CHECK_IFC_CONFORMANCE::prog PROG::parse TP_CLASS::name TP_CLASS::params ARRAY{1}::size
                            --err_loc(void);  -- Don't print a source location
                            err( "The interface of type " + tp.str-- CHECK_IFC_CONFORMANCE::err STR::plus TP_CLASS::str
                                + " isn't conformed to by the child "
                                + chld.str + ".")-- STR::plus STR::plus TP_CLASS::str STR::plus
                        end;
                    else
                        break!;
                        -- Bail out for non-class types. Do right later.
                    end;
                end;
            else
            end; -- typecase tp
        end; -- loop
    end; -- check_ifc_conformance
   
end; -- class CHECK_IFC_CONFORMANCE