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

-- call.sa: Representation of routine and iter calls.

-------------------------------------------------------------------
-- $CALL_TP: Supertype of argument types in a call.
-- CALL_TP_VOID: The type of a "void" expression.
-- CALL_TP_CREATE: The type of an untyped creation expression.
-- CALL_TP_BOUND_CREATE: The type of an untyped bound creation expression.
-- CALL_TP_ARRAY: The type of an array creation expression.
-- CALL_TP_UNDERSCORE: The type of a bound underscore argument.
-- CALL_SIG: The type signature of a routine or iter call.
-- CALL_ARG: The call arguments (binds type and mode)

-------------------------------------------------------------------
abstract class $CALL_TP is
   -- Supertype of the possible types of an argument in a call.
   -- This is either an actual type under $TP or CALL_TP_VOID for a 
   -- "void" argument, CALL_TP_CREATE for a creation expression without
   -- a type, CALL_TP_BOUND_CREATE for an untyped bound creation expression,
   -- CALL_TP_ARRAY for an array creation expression,
   -- or CALL_TP_UNDERSCORE for an underscore argument in a bound
   -- routine or iter.

   str:STR;			-- The string representation of self.
   
   is_subtype(t:$TP):BOOL;	-- True if self might be a legal
      -- argument type for an argument whose declared type is `t'.
   
end; -- type $CALL_TP
    
-------------------------------------------------------------------
class CALL_TP_VOID < $CALL_TP is
   -- The type of the argument "void".
   
   shared cache:SAME;   
   
   create:SAME is
      -- The representative object.
      if void(cache) then cache:=new end; return cache end;
   
   str:STR is
      -- The string: "void".
      return "void-expression" end;

   is_subtype(t:$TP):BOOL 
      -- True.
      pre ~void(t) is
      return true end;
   
end; -- class CALL_TP_VOID

-------------------------------------------------------------------
class CALL_TP_CREATE < $CALL_TP is
   -- The type of an untyped creation expression.
   
   shared cache:SAME;
   
   create:SAME is
      -- The representative object.
      if void(cache) then cache:=new end; 
      return cache end;

   str:STR is
      -- The string: "create".
      return "create-expression" end;

   is_subtype(t:$TP):BOOL 
      -- True if `t' is a reference, value type, or partial type.
      -- pSather or a spread type
      
      pre ~void(t) is
      case t.kind
      when TP_KIND::val_tp then return true
      when TP_KIND::ref_tp then return true
      when TP_KIND::part_tp then return true
      when TP_KIND::abs_tp then return false
      when TP_KIND::ext_c_tp then return false
      when TP_KIND::ext_fortran_tp then return false	 
      when TP_KIND::spr_tp then return true
      when TP_KIND::rout_tp then return false
      when TP_KIND::iter_tp then return false end end;

end; -- class CALL_TP_CREATE

-------------------------------------------------------------------
class CALL_TP_BOUND_CREATE < $CALL_TP is
   -- The type of an untyped bound creation expression.
   
   shared cache:SAME;
   
   create:SAME is
      -- The representative object.
      if void(cache) then cache:=new end; 
      return cache end;

   str:STR is
      -- The string: "create".
      return "bound-create-expression" end;

   is_subtype(t:$TP):BOOL 
      -- True if `t' is rout_tp or iter_tp
      
      pre ~void(t) is
      case t.kind
      when TP_KIND::val_tp then return false
      when TP_KIND::ref_tp then return false
      when TP_KIND::part_tp then return false
      when TP_KIND::abs_tp then return false
      when TP_KIND::ext_c_tp then return false
      when TP_KIND::ext_fortran_tp then return false	 
      when TP_KIND::spr_tp then return false
      when TP_KIND::rout_tp then return true
      when TP_KIND::iter_tp then return true end end;

end; -- class CALL_TP_BOUND_CREATE


-------------------------------------------------------------------
class CALL_TP_ARRAY < $CALL_TP is
   -- The type of an array creation expression.
   
   shared cache:SAME;
   
   create:SAME is
      -- The representative object.
      if void(cache) then cache:=new end; 
      return cache end;
   
   str:STR is
      -- The string: "array".
      return "array-expression" end;

   is_subtype(t:$TP):BOOL is
      -- True if `t' is ARRAY{T} for some T.
      typecase t
      when TP_CLASS then
	 return t.name=#IDENT("ARRAY")
      else return false end end;
   
end; -- class CALL_TP_ARRAY

-------------------------------------------------------------------
class CALL_TP_UNDERSCORE < $CALL_TP is
   -- The type of an underscore argument in a bound routine or iter 
   -- call and doesn't have a type specified.
   
   attr tp:$TP;			-- The type if one is specified. 

   create:SAME is
      -- A new object.
      return new end;
   
   str:STR is
      -- The string: "underscore" followed by ":TYPE" if a type is 
      -- present. 
      if void(tp) then return "underscore-expression" else
	 return "underscore-expression:" + tp.str end end;
   
   is_subtype(t:$TP):BOOL 
      -- True if self may represent `t'.
      pre ~void(t) is
      if void(tp) then return true else 
	 return tp.is_subtype(t) end end;
   
end; -- class CALL_TP_UNDERSCORE

-------------------------------------------------------------------
class CALL_ARG is
    -- The type and mode of the call argument

   
   attr tp: $CALL_TP;         -- call arg type
   attr mode: $MODE;          -- call arg mode
   
   is_eq(a: $OB):BOOL is
      -- Changed equality
      typecase a
      when ARG then return is_eq(a)
      else return false; end;
   end;
   
   is_eq(a: ARG):BOOL is
      return a.tp = tp  and mode = a.mode;
   end;
   
   str:STR is
      return mode.str+tp.str;
   end;
   
   create(t:$CALL_TP): SAME is
      -- The ``default'' constructor: mode is set to IN_MODE
      res ::= new;
      res.tp := t;
      res.mode := #IN_MODE;
      return res;
   end;
   
   create(t:$CALL_TP, m:$MODE): SAME is
      res ::= new;
      res.tp := t;
      res.mode := m;
      return res;
   end;
end;
-------------------------------------------------------------------

class CALL_SIG is
   -- The type signature of a routine or iter *call*. There are special
   -- type objects for arguments which are void, untyped creation 
   -- expressions, array creation expressions, integer literals, or
   -- floating point literals.

   attr tp:$TP;			-- The type on which the call is made.
   attr name:IDENT;		-- The name of the call.
   attr args:ARRAY{CALL_ARG};	-- The argument types, if any. 
   attr has_ret:BOOL;		-- True if the return value is used. 
   attr unknown_ret:BOOL;	-- True if this is a bound routine
      -- or iter call signature and we don't know whether there
      -- is a return value or not.    

   prog:PROG is
      -- The program in which this call appears.
      return tp.prog end;

   create:SAME is
      -- An uninitialized call sig.
      return new end;

   str:STR is
      -- The string representation of self. Uses no whitespace. Use
      -- an underbar "_" for the return type if there is one, and 
      -- the special strings "void", "create", "array", and 
      -- "underscore" for call arguments whose type is inferred: 
      -- "FOO::foo!(outA,void,C,array):_". 
      -- If self is void, returns "void".
      if void(self) then return "void" end;
      s::=#FSTR + tp.str + "::" + name.str;
	if ~void(args) then
	    s:=s + '(';
	    loop
		arg ::= args.elt!;
		s:=s + ",".separate!(arg.mode.str+arg.tp.str);
	    end;
	    s:=s + ')' 
	end;
	if unknown_ret then s:=s + ":?" 
      elsif has_ret then s:=s + ":_" end;
      return s.str end;

    conforms_to(s:SIG):BOOL is
	-- True if a call with signature self could be made on the routine
	-- or iter described by `s'. They must:
	-- 1) have the same name, 
	-- 2) have the same number of arguments, 
	-- 3) Both have or do not have a return value, 
	-- 4) The mode of each argument is the same 
	-- 5) for any in or once arguments, the type in self is the subtype
	--	  of the type in s; 
	--    for any `inout' arguments, the type in self is the same as in
	--        `s'; 
	--    for any `out' arguments,the type in s is a subtype of the type in
	--        self if it has one, 
	-- 6) the return type of self is a subtype of the return
	--    type of `s' (why is this missing? Boris 4-22-96)
	-- 7) Appear in the same type.
	if void(self) or void(s) then return false end;
	if tp/=s.tp then return false; end;
	if name/=s.name then return false; end;
	if ~unknown_ret then
	    if has_ret then
		if void(s.ret) then
		    return false;
		end
	    elsif ~void(s.ret) then
		return false;
	    end;
	end;
	
	if args.size/=s.args.size then
	    return false
	end;
	
	loop 
	   car ::= args.elt!; sar ::= s.args.elt!;
	   
	   if car.mode /= sar.mode then 
	      -- Note that here we allow the mode for the once argument
	      -- to be omitted at the point of the call. If we decide
	      -- that it needs to be specified, we would need to always
	      -- return false here BV.
	      if (car.mode = MODES::in_mode) and 
		       (sar.mode = MODES::once_mode) then
		 car.mode := sar.mode;
	      else
		 return false 
	      end;
	   end 
	end;
	loop
	   ca ::= args.elt!;  sa ::= s.args.elt!;
	   call_tp::=ca.tp;
	   if sa.tp.is_bound then
	      typecase call_tp
	      when TP_CLASS then
		 if sa.tp /= call_tp then 
		    prog.err("Dispatched bound routines/iters have not yet been implemented, formal and actual bound types have to be the same. "); 
		 end;
	      else
	      end;
	   end;
	   ca_mode ::= ca.mode ; sa_mode ::= sa.mode;
	    case sa_mode
	    when MODES::in_mode then
		if ~ca.tp.is_subtype(sa.tp) then
		    return false;
		end;
	    when MODES::out_mode then
		if ~sa.tp.is_subtype(ca.tp) then
		    return false;
		end;
	    when MODES::inout_mode then
	       call_tp := ca.tp;
	       typecase  call_tp
	       when  CALL_TP_UNDERSCORE then
		  if ~void(call_tp.tp) then
		     if call_tp.tp /= sa.tp then 
			 return false;
		     end;
		  end;
	       else
		  if sa.tp /= ca.tp then
		      return false;
		  end;
	       end;
	    when MODES::once_mode then
	       if ~ca.tp.is_subtype(sa.tp) then
		   return false;
	       end;
	    end;
	end;
	return true 
    end;

   old_conforms_to(s:SIG):BOOL is
      -- True if a call with signature self could be made on the routine
      -- or iter described by `s'. They must:
      -- 1) have the same name, 
      -- 2) have the same number of arguments, 
      -- 3) each call argument must conform to the corresponding 
      --    declared argument,
      -- 4) both must have or not have a return value.
      -- 5) Appear in the same type.
      if name/=s.name then return false end;
      if void(self) or void(s) then return false end;
      if tp/=s.tp then return false end;
      if ~unknown_ret then
	  if has_ret then
	      if void(s.ret) then
		  return false
	      end
	  elsif ~void(s.ret) then
	      return false
	  end
      end;
      if args.size/=s.args.size then return false end;
--      loop 
--	  if args.elt!.mode /=s.args.elt!.mode then 
--	      return false 
--	  end 
--      end;

      loop ca::=args.elt!; sa::=s.args.elt!;
	 if ~ca.tp.is_subtype(sa.tp) then return false end end; 
      return true end;


   lookup(in_class:BOOL):SIG is
      -- Lookup self and return the corresponding signature if there
      -- is one. Print an error message if it is ambiguous or absent and
      -- return void. Callers should set the err_loc. If `in_class' 
      -- is true, then consider both public and private routines, 
      -- otherwise just public ones.
      st::=tp;			-- The type the call is made on.
      typecase st
      when TP_CLASS then
	 if in_class then
	    return tp.impl.sig_for_internal_call(self);
	 else return tp.ifc.sig_for_call(self) end;
      when TP_ROUT then
	 if name/=IDENT_BUILTIN::call_ident then
	    prog.err("Only `call' may be applied to a bound routine.");
	    return void end;
	 if ~unknown_ret then
	    if has_ret and void(st.ret) then
	       prog.err("The bound routine " + st.str +
	          " has no return value, but one is needed."); 
	       return void
	    elsif ~has_ret and ~void(st.ret) then
	       prog.err("The bound routine " + st.str +
	       " has a return value, but it isn't used."); 
	       return void end end;
	 if st.args.size/=args.size then
	    prog.err("The call " + str +
	       " has the wrong number of args for " + st.str + ".");
	     return void end;
	  loop 
	      arg::=args.elt!; br_arg::=st.args.elt!;
	      arg_mode::=arg.mode; br_arg_mode ::= br_arg.mode;
	      if arg_mode /= br_arg_mode then 
		  boud_arg_mode_error(str, arg.tp.str, arg.mode.str,
				      st.str, br_arg.tp.str, br_arg.mode.str);
		  return void;
	      end;
	      case arg_mode 
	      when MODES::in_mode then
		  if ~arg.tp.is_subtype(br_arg.tp) then
		      boud_arg_error(str, arg.tp.str, 
				     st.str, br_arg.tp.str); 
		      return void; 
		  end 
	      when MODES::out_mode then
		  if ~br_arg.tp.is_subtype(arg.tp) then
		      boud_arg_error(str, arg.tp.str, 
				     st.str, br_arg.tp.str); 
		      return void; 
		  end;
	      when MODES::inout_mode then
		  if br_arg.tp /= arg.tp then
			  boud_arg_error(str, arg.tp.str, 
					 st.str, br_arg.tp.str); 
		      return void; 
		  end;
	      when MODES::once_mode then
		  if ~arg.tp.is_subtype(br_arg.tp) then
		      boud_arg_error(str, arg.tp.str, 
				     st.str, br_arg.tp.str); 
		      return void; 
		  end;
	      end;
	  end;
	 return SIG::bound_routine_call(st)
      when TP_ITER then
	  if name/=IDENT_BUILTIN::call_bang_ident then
	    prog.err("Only `call!' may be applied to a bound iter.");
	    return void end;
	  if ~unknown_ret then
	      if has_ret and void(st.ret) then
	       prog.err("The bound iter " + st.str +
	       " has no return value, but one is needed."); return void
	    elsif ~has_ret and ~void(st.ret) then
	       prog.err("The bound iter " + st.str +
	       " has a return value, but it isn't used."); 
	       return void end end;
	 if st.args.size/=args.size then
	    prog.err("The call " + str + 
	       " has the wrong number of args for " + st.str +".");
	    return void end;
	  loop 
	      arg::=args.elt!; br_arg::=st.args.elt!;
	      arg_mode::=arg.mode; br_arg_mode ::= br_arg.mode;
	     if arg_mode /= br_arg_mode then 
		-- Note that here we allow the mode for the once argument
		-- to be omitted at the point of the call. If we decide
		-- that it needs to be specified, we would need to always
		-- return false here BV.		
		if (arg_mode = MODES::in_mode) and 
			 (br_arg_mode = MODES::once_mode) then
		   arg.mode := br_arg_mode;
		else
		   boud_arg_mode_error(str, arg.tp.str, arg.mode.str,
				       st.str, br_arg.tp.str, br_arg.mode.str);
		   return void;
		end;
	      end;
	      case arg_mode 
	      when MODES::in_mode then
		  if ~arg.tp.is_subtype(br_arg.tp) then
		      boud_arg_error(str, arg.tp.str, 
				     st.str, br_arg.tp.str); 
		      return void; 
		  end 
	      when MODES::out_mode then
		  if ~br_arg.tp.is_subtype(arg.tp) then
		      boud_arg_error(str, arg.tp.str, 
				     st.str, br_arg.tp.str); 
		      return void; 
		  end;
	      when MODES::inout_mode then
		  if br_arg.tp /= arg.tp then
			  boud_arg_error(str, arg.tp.str, 
					 st.str, br_arg.tp.str); 
		      return void; 
		  end;
	      when MODES::once_mode then
		  if ~arg.tp.is_subtype(br_arg.tp) then
		      boud_arg_error(str, arg.tp.str, 
				     st.str, br_arg.tp.str); 
		     return void; 
		  end;
	      end;
	  end; 
	 return SIG::bound_iter_call(st);
      end;
    end;

    boud_arg_error(call, arg, br, br_arg :$STR) is
	prog.err("The argument type " + arg + " in the call " +
		 call + " doesn't conform to " + br_arg + 
		 " in the bound routine " + br + "."); 
    end;

    boud_arg_mode_error(call, arg, mode, br, br_arg, br_mode:$STR) is
	prog.err("The argument mode " + mode + " " + arg + " in the call " +
		 call + " doesn't conform to " + br_mode + " " + br_arg + 
		 " in the bound routine " + br + "."); 
    end;	

end; -- class CALL_SIG

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





