sym_intent i1, i2;
gfc_symbol *sym;
bt t1, t2;
- int args;
+ int args, r1, r2, k1, k2;
if (intr == NULL)
return;
args = 0;
t1 = t2 = BT_UNKNOWN;
i1 = i2 = INTENT_UNKNOWN;
+ r1 = r2 = -1;
+ k1 = k2 = -1;
for (formal = intr->sym->formal; formal; formal = formal->next)
{
{
t1 = sym->ts.type;
i1 = sym->attr.intent;
+ r1 = (sym->as != NULL) ? sym->as->rank : 0;
+ k1 = sym->ts.kind;
}
if (args == 1)
{
t2 = sym->ts.type;
i2 = sym->attr.intent;
+ r2 = (sym->as != NULL) ? sym->as->rank : 0;
+ k2 = sym->ts.kind;
}
args++;
}
- if (args == 0 || args > 2)
- goto num_args;
-
sym = intr->sym;
+ /* Only +, - and .not. can be unary operators.
+ .not. cannot be a binary operator. */
+ if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
+ && operator != INTRINSIC_MINUS
+ && operator != INTRINSIC_NOT)
+ || (args == 2 && operator == INTRINSIC_NOT))
+ {
+ gfc_error ("Operator interface at %L has the wrong number of arguments",
+ &intr->where);
+ return;
+ }
+
+ /* Check that intrinsics are mapped to functions, except
+ INTRINSIC_ASSIGN which should map to a subroutine. */
if (operator == INTRINSIC_ASSIGN)
{
if (!sym->attr.subroutine)
}
}
- switch (operator)
+ /* Check intents on operator interfaces. */
+ if (operator == INTRINSIC_ASSIGN)
{
- case INTRINSIC_PLUS: /* Numeric unary or binary */
- case INTRINSIC_MINUS:
- if ((args == 1)
- && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX))
+ if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
+ gfc_error ("First argument of defined assignment at %L must be "
+ "INTENT(IN) or INTENT(INOUT)", &intr->where);
+
+ if (i2 != INTENT_IN)
+ gfc_error ("Second argument of defined assignment at %L must be "
+ "INTENT(IN)", &intr->where);
+ }
+ else
+ {
+ if (i1 != INTENT_IN)
+ gfc_error ("First argument of operator interface at %L must be "
+ "INTENT(IN)", &intr->where);
+
+ if (args == 2 && i2 != INTENT_IN)
+ gfc_error ("Second argument of operator interface at %L must be "
+ "INTENT(IN)", &intr->where);
+ }
+
+ /* From now on, all we have to do is check that the operator definition
+ doesn't conflict with an intrinsic operator. The rules for this
+ game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
+ as well as 12.3.2.1.1 of Fortran 2003:
+
+ "If the operator is an intrinsic-operator (R310), the number of
+ function arguments shall be consistent with the intrinsic uses of
+ that operator, and the types, kind type parameters, or ranks of the
+ dummy arguments shall differ from those required for the intrinsic
+ operation (7.1.2)." */
+
+#define IS_NUMERIC_TYPE(t) \
+ ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
+
+ /* Unary ops are easy, do them first. */
+ if (operator == INTRINSIC_NOT)
+ {
+ if (t1 == BT_LOGICAL)
goto bad_repl;
+ else
+ return;
+ }
- if ((args == 2)
- && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
- && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
+ if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
+ {
+ if (IS_NUMERIC_TYPE (t1))
goto bad_repl;
+ else
+ return;
+ }
- break;
+ /* Character intrinsic operators have same character kind, thus
+ operator definitions with operands of different character kinds
+ are always safe. */
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
+ return;
- case INTRINSIC_POWER: /* Binary numeric */
- case INTRINSIC_TIMES:
- case INTRINSIC_DIVIDE:
+ /* Intrinsic operators always perform on arguments of same rank,
+ so different ranks is also always safe. (rank == 0) is an exception
+ to that, because all intrinsic operators are elemental. */
+ if (r1 != r2 && r1 != 0 && r2 != 0)
+ return;
+ switch (operator)
+ {
case INTRINSIC_EQ:
case INTRINSIC_NE:
- if (args == 1)
- goto num_args;
-
- if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
- && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
goto bad_repl;
+ /* Fall through. */
+ case INTRINSIC_PLUS:
+ case INTRINSIC_MINUS:
+ case INTRINSIC_TIMES:
+ case INTRINSIC_DIVIDE:
+ case INTRINSIC_POWER:
+ if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
+ goto bad_repl;
break;
- case INTRINSIC_GE: /* Binary numeric operators that do not support */
- case INTRINSIC_LE: /* complex numbers */
- case INTRINSIC_LT:
case INTRINSIC_GT:
- if (args == 1)
- goto num_args;
-
+ case INTRINSIC_GE:
+ case INTRINSIC_LT:
+ case INTRINSIC_LE:
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+ goto bad_repl;
if ((t1 == BT_INTEGER || t1 == BT_REAL)
&& (t2 == BT_INTEGER || t2 == BT_REAL))
goto bad_repl;
+ break;
+ case INTRINSIC_CONCAT:
+ if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
+ goto bad_repl;
break;
- case INTRINSIC_OR: /* Binary logical */
case INTRINSIC_AND:
+ case INTRINSIC_OR:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
- if (args == 1)
- goto num_args;
if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
goto bad_repl;
break;
- case INTRINSIC_NOT: /* Unary logical */
- if (args != 1)
- goto num_args;
- if (t1 == BT_LOGICAL)
- goto bad_repl;
- break;
-
- case INTRINSIC_CONCAT: /* Binary string */
- if (args != 2)
- goto num_args;
- if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
- goto bad_repl;
- break;
-
- case INTRINSIC_ASSIGN: /* Class by itself */
- if (args != 2)
- goto num_args;
- break;
default:
- gfc_internal_error ("check_operator_interface(): Bad operator");
- }
-
- /* Check intents on operator interfaces. */
- if (operator == INTRINSIC_ASSIGN)
- {
- if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
- gfc_error ("First argument of defined assignment at %L must be "
- "INTENT(IN) or INTENT(INOUT)", &intr->where);
-
- if (i2 != INTENT_IN)
- gfc_error ("Second argument of defined assignment at %L must be "
- "INTENT(IN)", &intr->where);
- }
- else
- {
- if (i1 != INTENT_IN)
- gfc_error ("First argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
-
- if (args == 2 && i2 != INTENT_IN)
- gfc_error ("Second argument of operator interface at %L must be "
- "INTENT(IN)", &intr->where);
- }
+ break;
+ }
return;
+#undef IS_NUMERIC_TYPE
+
bad_repl:
gfc_error ("Operator interface at %L conflicts with intrinsic interface",
&intr->where);
return;
-
-num_args:
- gfc_error ("Operator interface at %L has the wrong number of arguments",
- &intr->where);
- return;
}
--- /dev/null
+! { dg-do run }
+! Test the extension of intrinsic operators
+module m1
+ interface operator(*)
+ module procedure f1
+ module procedure f2
+ module procedure f3
+ end interface
+
+ interface operator(.or.)
+ module procedure g1
+ end interface
+
+ interface operator(//)
+ module procedure g1
+ end interface
+
+contains
+
+ function f1(a,b) result (c)
+ integer, dimension(2,2), intent(in) :: a
+ integer, dimension(2), intent(in) :: b
+ integer, dimension(2) :: c
+ c = matmul(a,b)
+ end function f1
+ function f2(a,b) result (c)
+ real, dimension(2,2), intent(in) :: a
+ real, dimension(2), intent(in) :: b
+ real, dimension(2) :: c
+ c = matmul(a,b)
+ end function f2
+ function f3(a,b) result (c)
+ complex, dimension(2,2), intent(in) :: a
+ complex, dimension(2), intent(in) :: b
+ complex, dimension(2) :: c
+ c = matmul(a,b)
+ end function f3
+
+ elemental function g1(a,b) result (c)
+ integer, intent(in) :: a, b
+ integer :: c
+ c = a + b
+ end function g1
+
+end module m1
+
+ use m1
+ implicit none
+
+ integer, dimension(2,2) :: ai
+ integer, dimension(2) :: bi, ci
+ real, dimension(2,2) :: ar
+ real, dimension(2) :: br, cr
+ complex, dimension(2,2) :: ac
+ complex, dimension(2) :: bc, cc
+
+ ai = reshape((/-2,-4,7,8/),(/2,2/)) ; bi = 3
+ if (any((ai*bi) /= matmul(ai,bi))) call abort()
+ if (any((ai .or. ai) /= ai+ai)) call abort()
+ if (any((ai // ai) /= ai+ai)) call abort()
+
+ ar = reshape((/-2,-4,7,8/),(/2,2/)) ; br = 3
+ if (any((ar*br) /= matmul(ar,br))) call abort()
+
+ ac = reshape((/-2,-4,7,8/),(/2,2/)) ; bc = 3
+ if (any((ac*bc) /= matmul(ac,bc))) call abort()
+
+end
+! { dg-final { cleanup-modules "m1" } }
--- /dev/null
+! { dg-do compile }
+! Test that we can't override intrinsic operators in invalid ways
+module foo
+
+ interface operator(*)
+ module procedure f1 ! { dg-error "conflicts with intrinsic interface" }
+ end interface
+
+ interface operator(>)
+ module procedure f2 ! { dg-error "conflicts with intrinsic interface" }
+ end interface
+
+ interface operator(/)
+ module procedure f3
+ end interface
+
+contains
+
+ function f1(a,b) result (c)
+ integer, intent(in) :: a
+ integer, dimension(:), intent(in) :: b
+ integer, dimension(size(b,1)) :: c
+ c = 0
+ end function f1
+
+ function f2(a,b)
+ character(len=*), intent(in) :: a
+ character(len=*), intent(in) :: b
+ logical :: f2
+ f2 = .false.
+ end function f2
+
+ function f3(a,b) result (c)
+ integer, dimension(:,:), intent(in) :: a
+ integer, dimension(:), intent(in) :: b
+ integer, dimension(size(b,1)) :: c
+ c = 0
+ end function f3
+
+end