OSDN Git Service

2010-06-20 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / interface.c
1 /* Deal with interfaces.
2    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009,
3    2010
4    Free Software Foundation, Inc.
5    Contributed by Andy Vaught
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
22
23
24 /* Deal with interfaces.  An explicit interface is represented as a
25    singly linked list of formal argument structures attached to the
26    relevant symbols.  For an implicit interface, the arguments don't
27    point to symbols.  Explicit interfaces point to namespaces that
28    contain the symbols within that interface.
29
30    Implicit interfaces are linked together in a singly linked list
31    along the next_if member of symbol nodes.  Since a particular
32    symbol can only have a single explicit interface, the symbol cannot
33    be part of multiple lists and a single next-member suffices.
34
35    This is not the case for general classes, though.  An operator
36    definition is independent of just about all other uses and has it's
37    own head pointer.
38
39    Nameless interfaces:
40      Nameless interfaces create symbols with explicit interfaces within
41      the current namespace.  They are otherwise unlinked.
42
43    Generic interfaces:
44      The generic name points to a linked list of symbols.  Each symbol
45      has an explicit interface.  Each explicit interface has its own
46      namespace containing the arguments.  Module procedures are symbols in
47      which the interface is added later when the module procedure is parsed.
48
49    User operators:
50      User-defined operators are stored in a their own set of symtrees
51      separate from regular symbols.  The symtrees point to gfc_user_op
52      structures which in turn head up a list of relevant interfaces.
53
54    Extended intrinsics and assignment:
55      The head of these interface lists are stored in the containing namespace.
56
57    Implicit interfaces:
58      An implicit interface is represented as a singly linked list of
59      formal argument list structures that don't point to any symbol
60      nodes -- they just contain types.
61
62
63    When a subprogram is defined, the program unit's name points to an
64    interface as usual, but the link to the namespace is NULL and the
65    formal argument list points to symbols within the same namespace as
66    the program unit name.  */
67
68 #include "config.h"
69 #include "system.h"
70 #include "gfortran.h"
71 #include "match.h"
72
73 /* The current_interface structure holds information about the
74    interface currently being parsed.  This structure is saved and
75    restored during recursive interfaces.  */
76
77 gfc_interface_info current_interface;
78
79
80 /* Free a singly linked list of gfc_interface structures.  */
81
82 void
83 gfc_free_interface (gfc_interface *intr)
84 {
85   gfc_interface *next;
86
87   for (; intr; intr = next)
88     {
89       next = intr->next;
90       gfc_free (intr);
91     }
92 }
93
94
95 /* Change the operators unary plus and minus into binary plus and
96    minus respectively, leaving the rest unchanged.  */
97
98 static gfc_intrinsic_op
99 fold_unary_intrinsic (gfc_intrinsic_op op)
100 {
101   switch (op)
102     {
103     case INTRINSIC_UPLUS:
104       op = INTRINSIC_PLUS;
105       break;
106     case INTRINSIC_UMINUS:
107       op = INTRINSIC_MINUS;
108       break;
109     default:
110       break;
111     }
112
113   return op;
114 }
115
116
117 /* Match a generic specification.  Depending on which type of
118    interface is found, the 'name' or 'op' pointers may be set.
119    This subroutine doesn't return MATCH_NO.  */
120
121 match
122 gfc_match_generic_spec (interface_type *type,
123                         char *name,
124                         gfc_intrinsic_op *op)
125 {
126   char buffer[GFC_MAX_SYMBOL_LEN + 1];
127   match m;
128   gfc_intrinsic_op i;
129
130   if (gfc_match (" assignment ( = )") == MATCH_YES)
131     {
132       *type = INTERFACE_INTRINSIC_OP;
133       *op = INTRINSIC_ASSIGN;
134       return MATCH_YES;
135     }
136
137   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
138     {                           /* Operator i/f */
139       *type = INTERFACE_INTRINSIC_OP;
140       *op = fold_unary_intrinsic (i);
141       return MATCH_YES;
142     }
143
144   *op = INTRINSIC_NONE;
145   if (gfc_match (" operator ( ") == MATCH_YES)
146     {
147       m = gfc_match_defined_op_name (buffer, 1);
148       if (m == MATCH_NO)
149         goto syntax;
150       if (m != MATCH_YES)
151         return MATCH_ERROR;
152
153       m = gfc_match_char (')');
154       if (m == MATCH_NO)
155         goto syntax;
156       if (m != MATCH_YES)
157         return MATCH_ERROR;
158
159       strcpy (name, buffer);
160       *type = INTERFACE_USER_OP;
161       return MATCH_YES;
162     }
163
164   if (gfc_match_name (buffer) == MATCH_YES)
165     {
166       strcpy (name, buffer);
167       *type = INTERFACE_GENERIC;
168       return MATCH_YES;
169     }
170
171   *type = INTERFACE_NAMELESS;
172   return MATCH_YES;
173
174 syntax:
175   gfc_error ("Syntax error in generic specification at %C");
176   return MATCH_ERROR;
177 }
178
179
180 /* Match one of the five F95 forms of an interface statement.  The
181    matcher for the abstract interface follows.  */
182
183 match
184 gfc_match_interface (void)
185 {
186   char name[GFC_MAX_SYMBOL_LEN + 1];
187   interface_type type;
188   gfc_symbol *sym;
189   gfc_intrinsic_op op;
190   match m;
191
192   m = gfc_match_space ();
193
194   if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
195     return MATCH_ERROR;
196
197   /* If we're not looking at the end of the statement now, or if this
198      is not a nameless interface but we did not see a space, punt.  */
199   if (gfc_match_eos () != MATCH_YES
200       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
201     {
202       gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
203                  "at %C");
204       return MATCH_ERROR;
205     }
206
207   current_interface.type = type;
208
209   switch (type)
210     {
211     case INTERFACE_GENERIC:
212       if (gfc_get_symbol (name, NULL, &sym))
213         return MATCH_ERROR;
214
215       if (!sym->attr.generic 
216           && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
217         return MATCH_ERROR;
218
219       if (sym->attr.dummy)
220         {
221           gfc_error ("Dummy procedure '%s' at %C cannot have a "
222                      "generic interface", sym->name);
223           return MATCH_ERROR;
224         }
225
226       current_interface.sym = gfc_new_block = sym;
227       break;
228
229     case INTERFACE_USER_OP:
230       current_interface.uop = gfc_get_uop (name);
231       break;
232
233     case INTERFACE_INTRINSIC_OP:
234       current_interface.op = op;
235       break;
236
237     case INTERFACE_NAMELESS:
238     case INTERFACE_ABSTRACT:
239       break;
240     }
241
242   return MATCH_YES;
243 }
244
245
246
247 /* Match a F2003 abstract interface.  */
248
249 match
250 gfc_match_abstract_interface (void)
251 {
252   match m;
253
254   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ABSTRACT INTERFACE at %C")
255                       == FAILURE)
256     return MATCH_ERROR;
257
258   m = gfc_match_eos ();
259
260   if (m != MATCH_YES)
261     {
262       gfc_error ("Syntax error in ABSTRACT INTERFACE statement at %C");
263       return MATCH_ERROR;
264     }
265
266   current_interface.type = INTERFACE_ABSTRACT;
267
268   return m;
269 }
270
271
272 /* Match the different sort of generic-specs that can be present after
273    the END INTERFACE itself.  */
274
275 match
276 gfc_match_end_interface (void)
277 {
278   char name[GFC_MAX_SYMBOL_LEN + 1];
279   interface_type type;
280   gfc_intrinsic_op op;
281   match m;
282
283   m = gfc_match_space ();
284
285   if (gfc_match_generic_spec (&type, name, &op) == MATCH_ERROR)
286     return MATCH_ERROR;
287
288   /* If we're not looking at the end of the statement now, or if this
289      is not a nameless interface but we did not see a space, punt.  */
290   if (gfc_match_eos () != MATCH_YES
291       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
292     {
293       gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
294                  "statement at %C");
295       return MATCH_ERROR;
296     }
297
298   m = MATCH_YES;
299
300   switch (current_interface.type)
301     {
302     case INTERFACE_NAMELESS:
303     case INTERFACE_ABSTRACT:
304       if (type != INTERFACE_NAMELESS)
305         {
306           gfc_error ("Expected a nameless interface at %C");
307           m = MATCH_ERROR;
308         }
309
310       break;
311
312     case INTERFACE_INTRINSIC_OP:
313       if (type != current_interface.type || op != current_interface.op)
314         {
315
316           if (current_interface.op == INTRINSIC_ASSIGN)
317             gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
318           else
319             gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
320                        gfc_op2string (current_interface.op));
321
322           m = MATCH_ERROR;
323         }
324
325       break;
326
327     case INTERFACE_USER_OP:
328       /* Comparing the symbol node names is OK because only use-associated
329          symbols can be renamed.  */
330       if (type != current_interface.type
331           || strcmp (current_interface.uop->name, name) != 0)
332         {
333           gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
334                      current_interface.uop->name);
335           m = MATCH_ERROR;
336         }
337
338       break;
339
340     case INTERFACE_GENERIC:
341       if (type != current_interface.type
342           || strcmp (current_interface.sym->name, name) != 0)
343         {
344           gfc_error ("Expecting 'END INTERFACE %s' at %C",
345                      current_interface.sym->name);
346           m = MATCH_ERROR;
347         }
348
349       break;
350     }
351
352   return m;
353 }
354
355
356 /* Compare two derived types using the criteria in 4.4.2 of the standard,
357    recursing through gfc_compare_types for the components.  */
358
359 int
360 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
361 {
362   gfc_component *dt1, *dt2;
363
364   if (derived1 == derived2)
365     return 1;
366
367   /* Special case for comparing derived types across namespaces.  If the
368      true names and module names are the same and the module name is
369      nonnull, then they are equal.  */
370   if (derived1 != NULL && derived2 != NULL
371       && strcmp (derived1->name, derived2->name) == 0
372       && derived1->module != NULL && derived2->module != NULL
373       && strcmp (derived1->module, derived2->module) == 0)
374     return 1;
375
376   /* Compare type via the rules of the standard.  Both types must have
377      the SEQUENCE attribute to be equal.  */
378
379   if (strcmp (derived1->name, derived2->name))
380     return 0;
381
382   if (derived1->component_access == ACCESS_PRIVATE
383       || derived2->component_access == ACCESS_PRIVATE)
384     return 0;
385
386   if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
387     return 0;
388
389   dt1 = derived1->components;
390   dt2 = derived2->components;
391
392   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
393      simple test can speed things up.  Otherwise, lots of things have to
394      match.  */
395   for (;;)
396     {
397       if (strcmp (dt1->name, dt2->name) != 0)
398         return 0;
399
400       if (dt1->attr.access != dt2->attr.access)
401         return 0;
402
403       if (dt1->attr.pointer != dt2->attr.pointer)
404         return 0;
405
406       if (dt1->attr.dimension != dt2->attr.dimension)
407         return 0;
408
409      if (dt1->attr.allocatable != dt2->attr.allocatable)
410         return 0;
411
412       if (dt1->attr.dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
413         return 0;
414
415       /* Make sure that link lists do not put this function into an 
416          endless recursive loop!  */
417       if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
418             && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
419             && gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
420         return 0;
421
422       else if ((dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
423                 && !(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
424         return 0;
425
426       else if (!(dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived)
427                 && (dt1->ts.type == BT_DERIVED && derived1 == dt1->ts.u.derived))
428         return 0;
429
430       dt1 = dt1->next;
431       dt2 = dt2->next;
432
433       if (dt1 == NULL && dt2 == NULL)
434         break;
435       if (dt1 == NULL || dt2 == NULL)
436         return 0;
437     }
438
439   return 1;
440 }
441
442
443 /* Compare two typespecs, recursively if necessary.  */
444
445 int
446 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
447 {
448   /* See if one of the typespecs is a BT_VOID, which is what is being used
449      to allow the funcs like c_f_pointer to accept any pointer type.
450      TODO: Possibly should narrow this to just the one typespec coming in
451      that is for the formal arg, but oh well.  */
452   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
453     return 1;
454    
455   if (ts1->type != ts2->type
456       && ((ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
457           || (ts2->type != BT_DERIVED && ts2->type != BT_CLASS)))
458     return 0;
459   if (ts1->type != BT_DERIVED && ts1->type != BT_CLASS)
460     return (ts1->kind == ts2->kind);
461
462   /* Compare derived types.  */
463   if (gfc_type_compatible (ts1, ts2))
464     return 1;
465
466   return gfc_compare_derived_types (ts1->u.derived ,ts2->u.derived);
467 }
468
469
470 /* Given two symbols that are formal arguments, compare their ranks
471    and types.  Returns nonzero if they have the same rank and type,
472    zero otherwise.  */
473
474 static int
475 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
476 {
477   int r1, r2;
478
479   r1 = (s1->as != NULL) ? s1->as->rank : 0;
480   r2 = (s2->as != NULL) ? s2->as->rank : 0;
481
482   if (r1 != r2)
483     return 0;                   /* Ranks differ.  */
484
485   return gfc_compare_types (&s1->ts, &s2->ts);
486 }
487
488
489 /* Given two symbols that are formal arguments, compare their types
490    and rank and their formal interfaces if they are both dummy
491    procedures.  Returns nonzero if the same, zero if different.  */
492
493 static int
494 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
495 {
496   if (s1 == NULL || s2 == NULL)
497     return s1 == s2 ? 1 : 0;
498
499   if (s1 == s2)
500     return 1;
501
502   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
503     return compare_type_rank (s1, s2);
504
505   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
506     return 0;
507
508   /* At this point, both symbols are procedures.  It can happen that
509      external procedures are compared, where one is identified by usage
510      to be a function or subroutine but the other is not.  Check TKR
511      nonetheless for these cases.  */
512   if (s1->attr.function == 0 && s1->attr.subroutine == 0)
513     return s1->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
514
515   if (s2->attr.function == 0 && s2->attr.subroutine == 0)
516     return s2->attr.external == 1 ? compare_type_rank (s1, s2) : 0;
517
518   /* Now the type of procedure has been identified.  */
519   if (s1->attr.function != s2->attr.function
520       || s1->attr.subroutine != s2->attr.subroutine)
521     return 0;
522
523   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
524     return 0;
525
526   /* Originally, gfortran recursed here to check the interfaces of passed
527      procedures.  This is explicitly not required by the standard.  */
528   return 1;
529 }
530
531
532 /* Given a formal argument list and a keyword name, search the list
533    for that keyword.  Returns the correct symbol node if found, NULL
534    if not found.  */
535
536 static gfc_symbol *
537 find_keyword_arg (const char *name, gfc_formal_arglist *f)
538 {
539   for (; f; f = f->next)
540     if (strcmp (f->sym->name, name) == 0)
541       return f->sym;
542
543   return NULL;
544 }
545
546
547 /******** Interface checking subroutines **********/
548
549
550 /* Given an operator interface and the operator, make sure that all
551    interfaces for that operator are legal.  */
552
553 bool
554 gfc_check_operator_interface (gfc_symbol *sym, gfc_intrinsic_op op,
555                               locus opwhere)
556 {
557   gfc_formal_arglist *formal;
558   sym_intent i1, i2;
559   bt t1, t2;
560   int args, r1, r2, k1, k2;
561
562   gcc_assert (sym);
563
564   args = 0;
565   t1 = t2 = BT_UNKNOWN;
566   i1 = i2 = INTENT_UNKNOWN;
567   r1 = r2 = -1;
568   k1 = k2 = -1;
569
570   for (formal = sym->formal; formal; formal = formal->next)
571     {
572       gfc_symbol *fsym = formal->sym;
573       if (fsym == NULL)
574         {
575           gfc_error ("Alternate return cannot appear in operator "
576                      "interface at %L", &sym->declared_at);
577           return false;
578         }
579       if (args == 0)
580         {
581           t1 = fsym->ts.type;
582           i1 = fsym->attr.intent;
583           r1 = (fsym->as != NULL) ? fsym->as->rank : 0;
584           k1 = fsym->ts.kind;
585         }
586       if (args == 1)
587         {
588           t2 = fsym->ts.type;
589           i2 = fsym->attr.intent;
590           r2 = (fsym->as != NULL) ? fsym->as->rank : 0;
591           k2 = fsym->ts.kind;
592         }
593       args++;
594     }
595
596   /* Only +, - and .not. can be unary operators.
597      .not. cannot be a binary operator.  */
598   if (args == 0 || args > 2 || (args == 1 && op != INTRINSIC_PLUS
599                                 && op != INTRINSIC_MINUS
600                                 && op != INTRINSIC_NOT)
601       || (args == 2 && op == INTRINSIC_NOT))
602     {
603       gfc_error ("Operator interface at %L has the wrong number of arguments",
604                  &sym->declared_at);
605       return false;
606     }
607
608   /* Check that intrinsics are mapped to functions, except
609      INTRINSIC_ASSIGN which should map to a subroutine.  */
610   if (op == INTRINSIC_ASSIGN)
611     {
612       if (!sym->attr.subroutine)
613         {
614           gfc_error ("Assignment operator interface at %L must be "
615                      "a SUBROUTINE", &sym->declared_at);
616           return false;
617         }
618       if (args != 2)
619         {
620           gfc_error ("Assignment operator interface at %L must have "
621                      "two arguments", &sym->declared_at);
622           return false;
623         }
624
625       /* Allowed are (per F2003, 12.3.2.1.2 Defined assignments):
626          - First argument an array with different rank than second,
627          - Types and kinds do not conform, and
628          - First argument is of derived type.  */
629       if (sym->formal->sym->ts.type != BT_DERIVED
630           && sym->formal->sym->ts.type != BT_CLASS
631           && (r1 == 0 || r1 == r2)
632           && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
633               || (gfc_numeric_ts (&sym->formal->sym->ts)
634                   && gfc_numeric_ts (&sym->formal->next->sym->ts))))
635         {
636           gfc_error ("Assignment operator interface at %L must not redefine "
637                      "an INTRINSIC type assignment", &sym->declared_at);
638           return false;
639         }
640     }
641   else
642     {
643       if (!sym->attr.function)
644         {
645           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
646                      &sym->declared_at);
647           return false;
648         }
649     }
650
651   /* Check intents on operator interfaces.  */
652   if (op == INTRINSIC_ASSIGN)
653     {
654       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
655         {
656           gfc_error ("First argument of defined assignment at %L must be "
657                      "INTENT(OUT) or INTENT(INOUT)", &sym->declared_at);
658           return false;
659         }
660
661       if (i2 != INTENT_IN)
662         {
663           gfc_error ("Second argument of defined assignment at %L must be "
664                      "INTENT(IN)", &sym->declared_at);
665           return false;
666         }
667     }
668   else
669     {
670       if (i1 != INTENT_IN)
671         {
672           gfc_error ("First argument of operator interface at %L must be "
673                      "INTENT(IN)", &sym->declared_at);
674           return false;
675         }
676
677       if (args == 2 && i2 != INTENT_IN)
678         {
679           gfc_error ("Second argument of operator interface at %L must be "
680                      "INTENT(IN)", &sym->declared_at);
681           return false;
682         }
683     }
684
685   /* From now on, all we have to do is check that the operator definition
686      doesn't conflict with an intrinsic operator. The rules for this
687      game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
688      as well as 12.3.2.1.1 of Fortran 2003:
689
690      "If the operator is an intrinsic-operator (R310), the number of
691      function arguments shall be consistent with the intrinsic uses of
692      that operator, and the types, kind type parameters, or ranks of the
693      dummy arguments shall differ from those required for the intrinsic
694      operation (7.1.2)."  */
695
696 #define IS_NUMERIC_TYPE(t) \
697   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
698
699   /* Unary ops are easy, do them first.  */
700   if (op == INTRINSIC_NOT)
701     {
702       if (t1 == BT_LOGICAL)
703         goto bad_repl;
704       else
705         return true;
706     }
707
708   if (args == 1 && (op == INTRINSIC_PLUS || op == INTRINSIC_MINUS))
709     {
710       if (IS_NUMERIC_TYPE (t1))
711         goto bad_repl;
712       else
713         return true;
714     }
715
716   /* Character intrinsic operators have same character kind, thus
717      operator definitions with operands of different character kinds
718      are always safe.  */
719   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
720     return true;
721
722   /* Intrinsic operators always perform on arguments of same rank,
723      so different ranks is also always safe.  (rank == 0) is an exception
724      to that, because all intrinsic operators are elemental.  */
725   if (r1 != r2 && r1 != 0 && r2 != 0)
726     return true;
727
728   switch (op)
729   {
730     case INTRINSIC_EQ:
731     case INTRINSIC_EQ_OS:
732     case INTRINSIC_NE:
733     case INTRINSIC_NE_OS:
734       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
735         goto bad_repl;
736       /* Fall through.  */
737
738     case INTRINSIC_PLUS:
739     case INTRINSIC_MINUS:
740     case INTRINSIC_TIMES:
741     case INTRINSIC_DIVIDE:
742     case INTRINSIC_POWER:
743       if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
744         goto bad_repl;
745       break;
746
747     case INTRINSIC_GT:
748     case INTRINSIC_GT_OS:
749     case INTRINSIC_GE:
750     case INTRINSIC_GE_OS:
751     case INTRINSIC_LT:
752     case INTRINSIC_LT_OS:
753     case INTRINSIC_LE:
754     case INTRINSIC_LE_OS:
755       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
756         goto bad_repl;
757       if ((t1 == BT_INTEGER || t1 == BT_REAL)
758           && (t2 == BT_INTEGER || t2 == BT_REAL))
759         goto bad_repl;
760       break;
761
762     case INTRINSIC_CONCAT:
763       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
764         goto bad_repl;
765       break;
766
767     case INTRINSIC_AND:
768     case INTRINSIC_OR:
769     case INTRINSIC_EQV:
770     case INTRINSIC_NEQV:
771       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
772         goto bad_repl;
773       break;
774
775     default:
776       break;
777   }
778
779   return true;
780
781 #undef IS_NUMERIC_TYPE
782
783 bad_repl:
784   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
785              &opwhere);
786   return false;
787 }
788
789
790 /* Given a pair of formal argument lists, we see if the two lists can
791    be distinguished by counting the number of nonoptional arguments of
792    a given type/rank in f1 and seeing if there are less then that
793    number of those arguments in f2 (including optional arguments).
794    Since this test is asymmetric, it has to be called twice to make it
795    symmetric.  Returns nonzero if the argument lists are incompatible
796    by this test.  This subroutine implements rule 1 of section
797    14.1.2.3 in the Fortran 95 standard.  */
798
799 static int
800 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
801 {
802   int rc, ac1, ac2, i, j, k, n1;
803   gfc_formal_arglist *f;
804
805   typedef struct
806   {
807     int flag;
808     gfc_symbol *sym;
809   }
810   arginfo;
811
812   arginfo *arg;
813
814   n1 = 0;
815
816   for (f = f1; f; f = f->next)
817     n1++;
818
819   /* Build an array of integers that gives the same integer to
820      arguments of the same type/rank.  */
821   arg = XCNEWVEC (arginfo, n1);
822
823   f = f1;
824   for (i = 0; i < n1; i++, f = f->next)
825     {
826       arg[i].flag = -1;
827       arg[i].sym = f->sym;
828     }
829
830   k = 0;
831
832   for (i = 0; i < n1; i++)
833     {
834       if (arg[i].flag != -1)
835         continue;
836
837       if (arg[i].sym && arg[i].sym->attr.optional)
838         continue;               /* Skip optional arguments.  */
839
840       arg[i].flag = k;
841
842       /* Find other nonoptional arguments of the same type/rank.  */
843       for (j = i + 1; j < n1; j++)
844         if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
845             && compare_type_rank_if (arg[i].sym, arg[j].sym))
846           arg[j].flag = k;
847
848       k++;
849     }
850
851   /* Now loop over each distinct type found in f1.  */
852   k = 0;
853   rc = 0;
854
855   for (i = 0; i < n1; i++)
856     {
857       if (arg[i].flag != k)
858         continue;
859
860       ac1 = 1;
861       for (j = i + 1; j < n1; j++)
862         if (arg[j].flag == k)
863           ac1++;
864
865       /* Count the number of arguments in f2 with that type, including
866          those that are optional.  */
867       ac2 = 0;
868
869       for (f = f2; f; f = f->next)
870         if (compare_type_rank_if (arg[i].sym, f->sym))
871           ac2++;
872
873       if (ac1 > ac2)
874         {
875           rc = 1;
876           break;
877         }
878
879       k++;
880     }
881
882   gfc_free (arg);
883
884   return rc;
885 }
886
887
888 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
889    Returns zero if no argument is found that satisfies rule 2, nonzero
890    otherwise.
891
892    This test is also not symmetric in f1 and f2 and must be called
893    twice.  This test finds problems caused by sorting the actual
894    argument list with keywords.  For example:
895
896    INTERFACE FOO
897        SUBROUTINE F1(A, B)
898            INTEGER :: A ; REAL :: B
899        END SUBROUTINE F1
900
901        SUBROUTINE F2(B, A)
902            INTEGER :: A ; REAL :: B
903        END SUBROUTINE F1
904    END INTERFACE FOO
905
906    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
907
908 static int
909 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
910 {
911   gfc_formal_arglist *f2_save, *g;
912   gfc_symbol *sym;
913
914   f2_save = f2;
915
916   while (f1)
917     {
918       if (f1->sym->attr.optional)
919         goto next;
920
921       if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
922         goto next;
923
924       /* Now search for a disambiguating keyword argument starting at
925          the current non-match.  */
926       for (g = f1; g; g = g->next)
927         {
928           if (g->sym->attr.optional)
929             continue;
930
931           sym = find_keyword_arg (g->sym->name, f2_save);
932           if (sym == NULL || !compare_type_rank (g->sym, sym))
933             return 1;
934         }
935
936     next:
937       f1 = f1->next;
938       if (f2 != NULL)
939         f2 = f2->next;
940     }
941
942   return 0;
943 }
944
945
946 /* 'Compare' two formal interfaces associated with a pair of symbols.
947    We return nonzero if there exists an actual argument list that
948    would be ambiguous between the two interfaces, zero otherwise.
949    'intent_flag' specifies whether INTENT and OPTIONAL of the arguments are
950    required to match, which is not the case for ambiguity checks.*/
951
952 int
953 gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, const char *name2,
954                         int generic_flag, int intent_flag,
955                         char *errmsg, int err_len)
956 {
957   gfc_formal_arglist *f1, *f2;
958
959   gcc_assert (name2 != NULL);
960
961   if (s1->attr.function && (s2->attr.subroutine
962       || (!s2->attr.function && s2->ts.type == BT_UNKNOWN
963           && gfc_get_default_type (name2, s2->ns)->type == BT_UNKNOWN)))
964     {
965       if (errmsg != NULL)
966         snprintf (errmsg, err_len, "'%s' is not a function", name2);
967       return 0;
968     }
969
970   if (s1->attr.subroutine && s2->attr.function)
971     {
972       if (errmsg != NULL)
973         snprintf (errmsg, err_len, "'%s' is not a subroutine", name2);
974       return 0;
975     }
976
977   /* If the arguments are functions, check type and kind
978      (only for dummy procedures and procedure pointer assignments).  */
979   if (!generic_flag && intent_flag && s1->attr.function && s2->attr.function)
980     {
981       if (s1->ts.type == BT_UNKNOWN)
982         return 1;
983       if ((s1->ts.type != s2->ts.type) || (s1->ts.kind != s2->ts.kind))
984         {
985           if (errmsg != NULL)
986             snprintf (errmsg, err_len, "Type/kind mismatch in return value "
987                       "of '%s'", name2);
988           return 0;
989         }
990     }
991
992   if (s1->attr.if_source == IFSRC_UNKNOWN
993       || s2->attr.if_source == IFSRC_UNKNOWN)
994     return 1;
995
996   f1 = s1->formal;
997   f2 = s2->formal;
998
999   if (f1 == NULL && f2 == NULL)
1000     return 1;                   /* Special case: No arguments.  */
1001
1002   if (generic_flag)
1003     {
1004       if (count_types_test (f1, f2) || count_types_test (f2, f1))
1005         return 0;
1006       if (generic_correspondence (f1, f2) || generic_correspondence (f2, f1))
1007         return 0;
1008     }
1009   else
1010     /* Perform the abbreviated correspondence test for operators (the
1011        arguments cannot be optional and are always ordered correctly).
1012        This is also done when comparing interfaces for dummy procedures and in
1013        procedure pointer assignments.  */
1014
1015     for (;;)
1016       {
1017         /* Check existence.  */
1018         if (f1 == NULL && f2 == NULL)
1019           break;
1020         if (f1 == NULL || f2 == NULL)
1021           {
1022             if (errmsg != NULL)
1023               snprintf (errmsg, err_len, "'%s' has the wrong number of "
1024                         "arguments", name2);
1025             return 0;
1026           }
1027
1028         /* Check type and rank.  */
1029         if (!compare_type_rank (f1->sym, f2->sym))
1030           {
1031             if (errmsg != NULL)
1032               snprintf (errmsg, err_len, "Type/rank mismatch in argument '%s'",
1033                         f1->sym->name);
1034             return 0;
1035           }
1036
1037         /* Check INTENT.  */
1038         if (intent_flag && (f1->sym->attr.intent != f2->sym->attr.intent))
1039           {
1040             snprintf (errmsg, err_len, "INTENT mismatch in argument '%s'",
1041                       f1->sym->name);
1042             return 0;
1043           }
1044
1045         /* Check OPTIONAL.  */
1046         if (intent_flag && (f1->sym->attr.optional != f2->sym->attr.optional))
1047           {
1048             snprintf (errmsg, err_len, "OPTIONAL mismatch in argument '%s'",
1049                       f1->sym->name);
1050             return 0;
1051           }
1052
1053         f1 = f1->next;
1054         f2 = f2->next;
1055       }
1056
1057   return 1;
1058 }
1059
1060
1061 /* Given a pointer to an interface pointer, remove duplicate
1062    interfaces and make sure that all symbols are either functions or
1063    subroutines.  Returns nonzero if something goes wrong.  */
1064
1065 static int
1066 check_interface0 (gfc_interface *p, const char *interface_name)
1067 {
1068   gfc_interface *psave, *q, *qlast;
1069
1070   psave = p;
1071   /* Make sure all symbols in the interface have been defined as
1072      functions or subroutines.  */
1073   for (; p; p = p->next)
1074     if ((!p->sym->attr.function && !p->sym->attr.subroutine)
1075         || !p->sym->attr.if_source)
1076       {
1077         if (p->sym->attr.external)
1078           gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
1079                      p->sym->name, interface_name, &p->sym->declared_at);
1080         else
1081           gfc_error ("Procedure '%s' in %s at %L is neither function nor "
1082                      "subroutine", p->sym->name, interface_name,
1083                      &p->sym->declared_at);
1084         return 1;
1085       }
1086   p = psave;
1087
1088   /* Remove duplicate interfaces in this interface list.  */
1089   for (; p; p = p->next)
1090     {
1091       qlast = p;
1092
1093       for (q = p->next; q;)
1094         {
1095           if (p->sym != q->sym)
1096             {
1097               qlast = q;
1098               q = q->next;
1099             }
1100           else
1101             {
1102               /* Duplicate interface.  */
1103               qlast->next = q->next;
1104               gfc_free (q);
1105               q = qlast->next;
1106             }
1107         }
1108     }
1109
1110   return 0;
1111 }
1112
1113
1114 /* Check lists of interfaces to make sure that no two interfaces are
1115    ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
1116
1117 static int
1118 check_interface1 (gfc_interface *p, gfc_interface *q0,
1119                   int generic_flag, const char *interface_name,
1120                   bool referenced)
1121 {
1122   gfc_interface *q;
1123   for (; p; p = p->next)
1124     for (q = q0; q; q = q->next)
1125       {
1126         if (p->sym == q->sym)
1127           continue;             /* Duplicates OK here.  */
1128
1129         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1130           continue;
1131
1132         if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
1133                                     0, NULL, 0))
1134           {
1135             if (referenced)
1136               gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1137                          p->sym->name, q->sym->name, interface_name,
1138                          &p->where);
1139             else if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1140               gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1141                            p->sym->name, q->sym->name, interface_name,
1142                            &p->where);
1143             else
1144               gfc_warning ("Although not referenced, '%s' has ambiguous "
1145                            "interfaces at %L", interface_name, &p->where);
1146             return 1;
1147           }
1148       }
1149   return 0;
1150 }
1151
1152
1153 /* Check the generic and operator interfaces of symbols to make sure
1154    that none of the interfaces conflict.  The check has to be done
1155    after all of the symbols are actually loaded.  */
1156
1157 static void
1158 check_sym_interfaces (gfc_symbol *sym)
1159 {
1160   char interface_name[100];
1161   gfc_interface *p;
1162
1163   if (sym->ns != gfc_current_ns)
1164     return;
1165
1166   if (sym->generic != NULL)
1167     {
1168       sprintf (interface_name, "generic interface '%s'", sym->name);
1169       if (check_interface0 (sym->generic, interface_name))
1170         return;
1171
1172       for (p = sym->generic; p; p = p->next)
1173         {
1174           if (p->sym->attr.mod_proc
1175               && (p->sym->attr.if_source != IFSRC_DECL
1176                   || p->sym->attr.procedure))
1177             {
1178               gfc_error ("'%s' at %L is not a module procedure",
1179                          p->sym->name, &p->where);
1180               return;
1181             }
1182         }
1183
1184       /* Originally, this test was applied to host interfaces too;
1185          this is incorrect since host associated symbols, from any
1186          source, cannot be ambiguous with local symbols.  */
1187       check_interface1 (sym->generic, sym->generic, 1, interface_name,
1188                         sym->attr.referenced || !sym->attr.use_assoc);
1189     }
1190 }
1191
1192
1193 static void
1194 check_uop_interfaces (gfc_user_op *uop)
1195 {
1196   char interface_name[100];
1197   gfc_user_op *uop2;
1198   gfc_namespace *ns;
1199
1200   sprintf (interface_name, "operator interface '%s'", uop->name);
1201   if (check_interface0 (uop->op, interface_name))
1202     return;
1203
1204   for (ns = gfc_current_ns; ns; ns = ns->parent)
1205     {
1206       uop2 = gfc_find_uop (uop->name, ns);
1207       if (uop2 == NULL)
1208         continue;
1209
1210       check_interface1 (uop->op, uop2->op, 0,
1211                         interface_name, true);
1212     }
1213 }
1214
1215
1216 /* For the namespace, check generic, user operator and intrinsic
1217    operator interfaces for consistency and to remove duplicate
1218    interfaces.  We traverse the whole namespace, counting on the fact
1219    that most symbols will not have generic or operator interfaces.  */
1220
1221 void
1222 gfc_check_interfaces (gfc_namespace *ns)
1223 {
1224   gfc_namespace *old_ns, *ns2;
1225   char interface_name[100];
1226   int i;
1227
1228   old_ns = gfc_current_ns;
1229   gfc_current_ns = ns;
1230
1231   gfc_traverse_ns (ns, check_sym_interfaces);
1232
1233   gfc_traverse_user_op (ns, check_uop_interfaces);
1234
1235   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1236     {
1237       if (i == INTRINSIC_USER)
1238         continue;
1239
1240       if (i == INTRINSIC_ASSIGN)
1241         strcpy (interface_name, "intrinsic assignment operator");
1242       else
1243         sprintf (interface_name, "intrinsic '%s' operator",
1244                  gfc_op2string ((gfc_intrinsic_op) i));
1245
1246       if (check_interface0 (ns->op[i], interface_name))
1247         continue;
1248
1249       if (ns->op[i])
1250         gfc_check_operator_interface (ns->op[i]->sym, (gfc_intrinsic_op) i,
1251                                       ns->op[i]->where);
1252
1253       for (ns2 = ns; ns2; ns2 = ns2->parent)
1254         {
1255           if (check_interface1 (ns->op[i], ns2->op[i], 0,
1256                                 interface_name, true))
1257             goto done;
1258
1259           switch (i)
1260             {
1261               case INTRINSIC_EQ:
1262                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ_OS],
1263                                       0, interface_name, true)) goto done;
1264                 break;
1265
1266               case INTRINSIC_EQ_OS:
1267                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_EQ],
1268                                       0, interface_name, true)) goto done;
1269                 break;
1270
1271               case INTRINSIC_NE:
1272                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE_OS],
1273                                       0, interface_name, true)) goto done;
1274                 break;
1275
1276               case INTRINSIC_NE_OS:
1277                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_NE],
1278                                       0, interface_name, true)) goto done;
1279                 break;
1280
1281               case INTRINSIC_GT:
1282                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT_OS],
1283                                       0, interface_name, true)) goto done;
1284                 break;
1285
1286               case INTRINSIC_GT_OS:
1287                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GT],
1288                                       0, interface_name, true)) goto done;
1289                 break;
1290
1291               case INTRINSIC_GE:
1292                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE_OS],
1293                                       0, interface_name, true)) goto done;
1294                 break;
1295
1296               case INTRINSIC_GE_OS:
1297                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_GE],
1298                                       0, interface_name, true)) goto done;
1299                 break;
1300
1301               case INTRINSIC_LT:
1302                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT_OS],
1303                                       0, interface_name, true)) goto done;
1304                 break;
1305
1306               case INTRINSIC_LT_OS:
1307                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LT],
1308                                       0, interface_name, true)) goto done;
1309                 break;
1310
1311               case INTRINSIC_LE:
1312                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE_OS],
1313                                       0, interface_name, true)) goto done;
1314                 break;
1315
1316               case INTRINSIC_LE_OS:
1317                 if (check_interface1 (ns->op[i], ns2->op[INTRINSIC_LE],
1318                                       0, interface_name, true)) goto done;
1319                 break;
1320
1321               default:
1322                 break;
1323             }
1324         }
1325     }
1326
1327 done:
1328   gfc_current_ns = old_ns;
1329 }
1330
1331
1332 static int
1333 symbol_rank (gfc_symbol *sym)
1334 {
1335   return (sym->as == NULL) ? 0 : sym->as->rank;
1336 }
1337
1338
1339 /* Given a symbol of a formal argument list and an expression, if the
1340    formal argument is allocatable, check that the actual argument is
1341    allocatable. Returns nonzero if compatible, zero if not compatible.  */
1342
1343 static int
1344 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1345 {
1346   symbol_attribute attr;
1347
1348   if (formal->attr.allocatable)
1349     {
1350       attr = gfc_expr_attr (actual);
1351       if (!attr.allocatable)
1352         return 0;
1353     }
1354
1355   return 1;
1356 }
1357
1358
1359 /* Given a symbol of a formal argument list and an expression, if the
1360    formal argument is a pointer, see if the actual argument is a
1361    pointer. Returns nonzero if compatible, zero if not compatible.  */
1362
1363 static int
1364 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1365 {
1366   symbol_attribute attr;
1367
1368   if (formal->attr.pointer)
1369     {
1370       attr = gfc_expr_attr (actual);
1371       if (!attr.pointer)
1372         return 0;
1373     }
1374
1375   return 1;
1376 }
1377
1378
1379 /* Given a symbol of a formal argument list and an expression, see if
1380    the two are compatible as arguments.  Returns nonzero if
1381    compatible, zero if not compatible.  */
1382
1383 static int
1384 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1385                    int ranks_must_agree, int is_elemental, locus *where)
1386 {
1387   gfc_ref *ref;
1388   bool rank_check;
1389
1390   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1391      procs c_f_pointer or c_f_procpointer, and we need to accept most
1392      pointers the user could give us.  This should allow that.  */
1393   if (formal->ts.type == BT_VOID)
1394     return 1;
1395
1396   if (formal->ts.type == BT_DERIVED
1397       && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1398       && actual->ts.type == BT_DERIVED
1399       && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1400     return 1;
1401
1402   if (actual->ts.type == BT_PROCEDURE)
1403     {
1404       char err[200];
1405       gfc_symbol *act_sym = actual->symtree->n.sym;
1406
1407       if (formal->attr.flavor != FL_PROCEDURE)
1408         {
1409           if (where)
1410             gfc_error ("Invalid procedure argument at %L", &actual->where);
1411           return 0;
1412         }
1413
1414       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1415                                    sizeof(err)))
1416         {
1417           if (where)
1418             gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1419                        formal->name, &actual->where, err);
1420           return 0;
1421         }
1422
1423       if (formal->attr.function && !act_sym->attr.function)
1424         {
1425           gfc_add_function (&act_sym->attr, act_sym->name,
1426           &act_sym->declared_at);
1427           if (act_sym->ts.type == BT_UNKNOWN
1428               && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1429             return 0;
1430         }
1431       else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1432         gfc_add_subroutine (&act_sym->attr, act_sym->name,
1433                             &act_sym->declared_at);
1434
1435       return 1;
1436     }
1437
1438   /* F2008, C1241.  */
1439   if (formal->attr.pointer && formal->attr.contiguous
1440       && !gfc_is_simply_contiguous (actual, true))
1441     {
1442       if (where)
1443         gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1444                    "must be simply contigous", formal->name, &actual->where);
1445       return 0;
1446     }
1447
1448   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1449       && !gfc_compare_types (&formal->ts, &actual->ts))
1450     {
1451       if (where)
1452         gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1453                    formal->name, &actual->where, gfc_typename (&actual->ts),
1454                    gfc_typename (&formal->ts));
1455       return 0;
1456     }
1457
1458   if (formal->attr.codimension)
1459     {
1460       gfc_ref *last = NULL;
1461
1462       if (actual->expr_type != EXPR_VARIABLE
1463           || (actual->ref == NULL
1464               && !actual->symtree->n.sym->attr.codimension))
1465         {
1466           if (where)
1467             gfc_error ("Actual argument to '%s' at %L must be a coarray",
1468                        formal->name, &actual->where);
1469           return 0;
1470         }
1471
1472       for (ref = actual->ref; ref; ref = ref->next)
1473         {
1474           if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
1475             {
1476               if (where)
1477                 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1478                            "and not coindexed", formal->name, &ref->u.ar.where);
1479               return 0;
1480             }
1481           if (ref->type == REF_ARRAY && ref->u.ar.as->corank
1482               && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
1483             {
1484               if (where)
1485                 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1486                            "and thus shall not have an array designator",
1487                            formal->name, &ref->u.ar.where);
1488               return 0;
1489             }
1490           if (ref->type == REF_COMPONENT)
1491             last = ref;
1492         }
1493
1494       if (last && !last->u.c.component->attr.codimension)
1495         {
1496           if (where)
1497             gfc_error ("Actual argument to '%s' at %L must be a coarray",
1498                        formal->name, &actual->where);
1499           return 0;
1500         }
1501
1502       /* F2008, 12.5.2.6.  */
1503       if (formal->attr.allocatable &&
1504           ((last && last->u.c.component->as->corank != formal->as->corank)
1505            || (!last
1506                && actual->symtree->n.sym->as->corank != formal->as->corank)))
1507         {
1508           if (where)
1509             gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1510                    formal->name, &actual->where, formal->as->corank,
1511                    last ? last->u.c.component->as->corank
1512                         : actual->symtree->n.sym->as->corank);
1513           return 0;
1514         }
1515
1516       /* F2008, 12.5.2.8.  */
1517       if (formal->attr.dimension
1518           && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1519           && !gfc_is_simply_contiguous (actual, true))
1520         {
1521           if (where)
1522             gfc_error ("Actual argument to '%s' at %L must be simply "
1523                        "contiguous", formal->name, &actual->where);
1524           return 0;
1525         }
1526     }
1527
1528   /* F2008, C1239/C1240.  */
1529   if (actual->expr_type == EXPR_VARIABLE
1530       && (actual->symtree->n.sym->attr.asynchronous
1531          || actual->symtree->n.sym->attr.volatile_)
1532       &&  (formal->attr.asynchronous || formal->attr.volatile_)
1533       && actual->rank && !gfc_is_simply_contiguous (actual, true)
1534       && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1535           || formal->attr.contiguous))
1536     {
1537       if (where)
1538         gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1539                    "array without CONTIGUOUS attribute - as actual argument at"
1540                    " %L is not simply contiguous and both are ASYNCHRONOUS "
1541                    "or VOLATILE", formal->name, &actual->where);
1542       return 0;
1543     }
1544
1545   if (symbol_rank (formal) == actual->rank)
1546     return 1;
1547
1548   rank_check = where != NULL && !is_elemental && formal->as
1549                && (formal->as->type == AS_ASSUMED_SHAPE
1550                    || formal->as->type == AS_DEFERRED)
1551                && actual->expr_type != EXPR_NULL;
1552
1553   /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
1554   if (rank_check || ranks_must_agree
1555       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1556       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1557       || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE)
1558       || (actual->rank == 0 && formal->attr.dimension
1559           && gfc_is_coindexed (actual)))
1560     {
1561       if (where)
1562         gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1563                    formal->name, &actual->where, symbol_rank (formal),
1564                    actual->rank);
1565       return 0;
1566     }
1567   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1568     return 1;
1569
1570   /* At this point, we are considering a scalar passed to an array.   This
1571      is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1572      - if the actual argument is (a substring of) an element of a
1573        non-assumed-shape/non-pointer array;
1574      - (F2003) if the actual argument is of type character.  */
1575
1576   for (ref = actual->ref; ref; ref = ref->next)
1577     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1578         && ref->u.ar.dimen > 0)
1579       break;
1580
1581   /* Not an array element.  */
1582   if (formal->ts.type == BT_CHARACTER
1583       && (ref == NULL
1584           || (actual->expr_type == EXPR_VARIABLE
1585               && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1586                   || actual->symtree->n.sym->attr.pointer))))
1587     {
1588       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1589         {
1590           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1591                      "array dummy argument '%s' at %L",
1592                      formal->name, &actual->where);
1593           return 0;
1594         }
1595       else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1596         return 0;
1597       else
1598         return 1;
1599     }
1600   else if (ref == NULL && actual->expr_type != EXPR_NULL)
1601     {
1602       if (where)
1603         gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)",
1604                    formal->name, &actual->where, symbol_rank (formal),
1605                    actual->rank);
1606       return 0;
1607     }
1608
1609   if (actual->expr_type == EXPR_VARIABLE
1610       && actual->symtree->n.sym->as
1611       && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1612           || actual->symtree->n.sym->attr.pointer))
1613     {
1614       if (where)
1615         gfc_error ("Element of assumed-shaped array passed to dummy "
1616                    "argument '%s' at %L", formal->name, &actual->where);
1617       return 0;
1618     }
1619
1620   return 1;
1621 }
1622
1623
1624 /* Given a symbol of a formal argument list and an expression, see if
1625    the two are compatible as arguments.  Returns nonzero if
1626    compatible, zero if not compatible.  */
1627
1628 static int
1629 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1630 {
1631   if (actual->expr_type != EXPR_VARIABLE)
1632     return 1;
1633
1634   if (!actual->symtree->n.sym->attr.is_protected)
1635     return 1;
1636
1637   if (!actual->symtree->n.sym->attr.use_assoc)
1638     return 1;
1639
1640   if (formal->attr.intent == INTENT_IN
1641       || formal->attr.intent == INTENT_UNKNOWN)
1642     return 1;
1643
1644   if (!actual->symtree->n.sym->attr.pointer)
1645     return 0;
1646
1647   if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1648     return 0;
1649
1650   return 1;
1651 }
1652
1653
1654 /* Returns the storage size of a symbol (formal argument) or
1655    zero if it cannot be determined.  */
1656
1657 static unsigned long
1658 get_sym_storage_size (gfc_symbol *sym)
1659 {
1660   int i;
1661   unsigned long strlen, elements;
1662
1663   if (sym->ts.type == BT_CHARACTER)
1664     {
1665       if (sym->ts.u.cl && sym->ts.u.cl->length
1666           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1667         strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1668       else
1669         return 0;
1670     }
1671   else
1672     strlen = 1; 
1673
1674   if (symbol_rank (sym) == 0)
1675     return strlen;
1676
1677   elements = 1;
1678   if (sym->as->type != AS_EXPLICIT)
1679     return 0;
1680   for (i = 0; i < sym->as->rank; i++)
1681     {
1682       if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1683           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1684         return 0;
1685
1686       elements *= mpz_get_si (sym->as->upper[i]->value.integer)
1687                   - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
1688     }
1689
1690   return strlen*elements;
1691 }
1692
1693
1694 /* Returns the storage size of an expression (actual argument) or
1695    zero if it cannot be determined. For an array element, it returns
1696    the remaining size as the element sequence consists of all storage
1697    units of the actual argument up to the end of the array.  */
1698
1699 static unsigned long
1700 get_expr_storage_size (gfc_expr *e)
1701 {
1702   int i;
1703   long int strlen, elements;
1704   long int substrlen = 0;
1705   bool is_str_storage = false;
1706   gfc_ref *ref;
1707
1708   if (e == NULL)
1709     return 0;
1710   
1711   if (e->ts.type == BT_CHARACTER)
1712     {
1713       if (e->ts.u.cl && e->ts.u.cl->length
1714           && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1715         strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1716       else if (e->expr_type == EXPR_CONSTANT
1717                && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1718         strlen = e->value.character.length;
1719       else
1720         return 0;
1721     }
1722   else
1723     strlen = 1; /* Length per element.  */
1724
1725   if (e->rank == 0 && !e->ref)
1726     return strlen;
1727
1728   elements = 1;
1729   if (!e->ref)
1730     {
1731       if (!e->shape)
1732         return 0;
1733       for (i = 0; i < e->rank; i++)
1734         elements *= mpz_get_si (e->shape[i]);
1735       return elements*strlen;
1736     }
1737
1738   for (ref = e->ref; ref; ref = ref->next)
1739     {
1740       if (ref->type == REF_SUBSTRING && ref->u.ss.start
1741           && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1742         {
1743           if (is_str_storage)
1744             {
1745               /* The string length is the substring length.
1746                  Set now to full string length.  */
1747               if (ref->u.ss.length == NULL
1748                   || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1749                 return 0;
1750
1751               strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1752             }
1753           substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1754           continue;
1755         }
1756
1757       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1758           && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1759           && ref->u.ar.as->upper)
1760         for (i = 0; i < ref->u.ar.dimen; i++)
1761           {
1762             long int start, end, stride;
1763             stride = 1;
1764
1765             if (ref->u.ar.stride[i])
1766               {
1767                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1768                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1769                 else
1770                   return 0;
1771               }
1772
1773             if (ref->u.ar.start[i])
1774               {
1775                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1776                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1777                 else
1778                   return 0;
1779               }
1780             else if (ref->u.ar.as->lower[i]
1781                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1782               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1783             else
1784               return 0;
1785
1786             if (ref->u.ar.end[i])
1787               {
1788                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1789                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1790                 else
1791                   return 0;
1792               }
1793             else if (ref->u.ar.as->upper[i]
1794                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1795               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1796             else
1797               return 0;
1798
1799             elements *= (end - start)/stride + 1L;
1800           }
1801       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1802                && ref->u.ar.as->lower && ref->u.ar.as->upper)
1803         for (i = 0; i < ref->u.ar.as->rank; i++)
1804           {
1805             if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1806                 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1807                 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1808               elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1809                           - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1810                           + 1L;
1811             else
1812               return 0;
1813           }
1814       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1815                && e->expr_type == EXPR_VARIABLE)
1816         {
1817           if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1818               || e->symtree->n.sym->attr.pointer)
1819             {
1820               elements = 1;
1821               continue;
1822             }
1823
1824           /* Determine the number of remaining elements in the element
1825              sequence for array element designators.  */
1826           is_str_storage = true;
1827           for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1828             {
1829               if (ref->u.ar.start[i] == NULL
1830                   || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1831                   || ref->u.ar.as->upper[i] == NULL
1832                   || ref->u.ar.as->lower[i] == NULL
1833                   || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1834                   || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1835                 return 0;
1836
1837               elements
1838                    = elements
1839                      * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1840                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1841                         + 1L)
1842                      - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1843                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1844             }
1845         }
1846       else
1847         return 0;
1848     }
1849
1850   if (substrlen)
1851     return (is_str_storage) ? substrlen + (elements-1)*strlen
1852                             : elements*strlen;
1853   else
1854     return elements*strlen;
1855 }
1856
1857
1858 /* Given an expression, check whether it is an array section
1859    which has a vector subscript. If it has, one is returned,
1860    otherwise zero.  */
1861
1862 int
1863 gfc_has_vector_subscript (gfc_expr *e)
1864 {
1865   int i;
1866   gfc_ref *ref;
1867
1868   if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1869     return 0;
1870
1871   for (ref = e->ref; ref; ref = ref->next)
1872     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1873       for (i = 0; i < ref->u.ar.dimen; i++)
1874         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1875           return 1;
1876
1877   return 0;
1878 }
1879
1880
1881 /* Given formal and actual argument lists, see if they are compatible.
1882    If they are compatible, the actual argument list is sorted to
1883    correspond with the formal list, and elements for missing optional
1884    arguments are inserted. If WHERE pointer is nonnull, then we issue
1885    errors when things don't match instead of just returning the status
1886    code.  */
1887
1888 static int
1889 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1890                        int ranks_must_agree, int is_elemental, locus *where)
1891 {
1892   gfc_actual_arglist **new_arg, *a, *actual, temp;
1893   gfc_formal_arglist *f;
1894   int i, n, na;
1895   unsigned long actual_size, formal_size;
1896
1897   actual = *ap;
1898
1899   if (actual == NULL && formal == NULL)
1900     return 1;
1901
1902   n = 0;
1903   for (f = formal; f; f = f->next)
1904     n++;
1905
1906   new_arg = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1907
1908   for (i = 0; i < n; i++)
1909     new_arg[i] = NULL;
1910
1911   na = 0;
1912   f = formal;
1913   i = 0;
1914
1915   for (a = actual; a; a = a->next, f = f->next)
1916     {
1917       /* Look for keywords but ignore g77 extensions like %VAL.  */
1918       if (a->name != NULL && a->name[0] != '%')
1919         {
1920           i = 0;
1921           for (f = formal; f; f = f->next, i++)
1922             {
1923               if (f->sym == NULL)
1924                 continue;
1925               if (strcmp (f->sym->name, a->name) == 0)
1926                 break;
1927             }
1928
1929           if (f == NULL)
1930             {
1931               if (where)
1932                 gfc_error ("Keyword argument '%s' at %L is not in "
1933                            "the procedure", a->name, &a->expr->where);
1934               return 0;
1935             }
1936
1937           if (new_arg[i] != NULL)
1938             {
1939               if (where)
1940                 gfc_error ("Keyword argument '%s' at %L is already associated "
1941                            "with another actual argument", a->name,
1942                            &a->expr->where);
1943               return 0;
1944             }
1945         }
1946
1947       if (f == NULL)
1948         {
1949           if (where)
1950             gfc_error ("More actual than formal arguments in procedure "
1951                        "call at %L", where);
1952
1953           return 0;
1954         }
1955
1956       if (f->sym == NULL && a->expr == NULL)
1957         goto match;
1958
1959       if (f->sym == NULL)
1960         {
1961           if (where)
1962             gfc_error ("Missing alternate return spec in subroutine call "
1963                        "at %L", where);
1964           return 0;
1965         }
1966
1967       if (a->expr == NULL)
1968         {
1969           if (where)
1970             gfc_error ("Unexpected alternate return spec in subroutine "
1971                        "call at %L", where);
1972           return 0;
1973         }
1974       
1975       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1976                               is_elemental, where))
1977         return 0;
1978
1979       /* Special case for character arguments.  For allocatable, pointer
1980          and assumed-shape dummies, the string length needs to match
1981          exactly.  */
1982       if (a->expr->ts.type == BT_CHARACTER
1983            && a->expr->ts.u.cl && a->expr->ts.u.cl->length
1984            && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
1985            && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
1986            && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
1987            && (f->sym->attr.pointer || f->sym->attr.allocatable
1988                || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1989            && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
1990                         f->sym->ts.u.cl->length->value.integer) != 0))
1991          {
1992            if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
1993              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
1994                           "argument and pointer or allocatable dummy argument "
1995                           "'%s' at %L",
1996                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
1997                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
1998                           f->sym->name, &a->expr->where);
1999            else if (where)
2000              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2001                           "argument and assumed-shape dummy argument '%s' "
2002                           "at %L",
2003                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2004                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2005                           f->sym->name, &a->expr->where);
2006            return 0;
2007          }
2008
2009       actual_size = get_expr_storage_size (a->expr);
2010       formal_size = get_sym_storage_size (f->sym);
2011       if (actual_size != 0
2012             && actual_size < formal_size
2013             && a->expr->ts.type != BT_PROCEDURE)
2014         {
2015           if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2016             gfc_warning ("Character length of actual argument shorter "
2017                         "than of dummy argument '%s' (%lu/%lu) at %L",
2018                         f->sym->name, actual_size, formal_size,
2019                         &a->expr->where);
2020           else if (where)
2021             gfc_warning ("Actual argument contains too few "
2022                         "elements for dummy argument '%s' (%lu/%lu) at %L",
2023                         f->sym->name, actual_size, formal_size,
2024                         &a->expr->where);
2025           return  0;
2026         }
2027
2028       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2029          is provided for a procedure pointer formal argument.  */
2030       if (f->sym->attr.proc_pointer
2031           && !((a->expr->expr_type == EXPR_VARIABLE
2032                 && a->expr->symtree->n.sym->attr.proc_pointer)
2033                || (a->expr->expr_type == EXPR_FUNCTION
2034                    && a->expr->symtree->n.sym->result->attr.proc_pointer)
2035                || gfc_is_proc_ptr_comp (a->expr, NULL)))
2036         {
2037           if (where)
2038             gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2039                        f->sym->name, &a->expr->where);
2040           return 0;
2041         }
2042
2043       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2044          provided for a procedure formal argument.  */
2045       if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
2046           && a->expr->expr_type == EXPR_VARIABLE
2047           && f->sym->attr.flavor == FL_PROCEDURE)
2048         {
2049           if (where)
2050             gfc_error ("Expected a procedure for argument '%s' at %L",
2051                        f->sym->name, &a->expr->where);
2052           return 0;
2053         }
2054
2055       if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
2056           && a->expr->ts.type == BT_PROCEDURE
2057           && !a->expr->symtree->n.sym->attr.pure)
2058         {
2059           if (where)
2060             gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2061                        f->sym->name, &a->expr->where);
2062           return 0;
2063         }
2064
2065       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2066           && a->expr->expr_type == EXPR_VARIABLE
2067           && a->expr->symtree->n.sym->as
2068           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2069           && (a->expr->ref == NULL
2070               || (a->expr->ref->type == REF_ARRAY
2071                   && a->expr->ref->u.ar.type == AR_FULL)))
2072         {
2073           if (where)
2074             gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2075                        " array at %L", f->sym->name, where);
2076           return 0;
2077         }
2078
2079       if (a->expr->expr_type != EXPR_NULL
2080           && compare_pointer (f->sym, a->expr) == 0)
2081         {
2082           if (where)
2083             gfc_error ("Actual argument for '%s' must be a pointer at %L",
2084                        f->sym->name, &a->expr->where);
2085           return 0;
2086         }
2087
2088       /* Fortran 2008, C1242.  */
2089       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2090         {
2091           if (where)
2092             gfc_error ("Coindexed actual argument at %L to pointer "
2093                        "dummy '%s'",
2094                        &a->expr->where, f->sym->name);
2095           return 0;
2096         }
2097
2098       /* Fortran 2008, 12.5.2.5 (no constraint).  */
2099       if (a->expr->expr_type == EXPR_VARIABLE
2100           && f->sym->attr.intent != INTENT_IN
2101           && f->sym->attr.allocatable
2102           && gfc_is_coindexed (a->expr))
2103         {
2104           if (where)
2105             gfc_error ("Coindexed actual argument at %L to allocatable "
2106                        "dummy '%s' requires INTENT(IN)",
2107                        &a->expr->where, f->sym->name);
2108           return 0;
2109         }
2110
2111       /* Fortran 2008, C1237.  */
2112       if (a->expr->expr_type == EXPR_VARIABLE
2113           && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2114           && gfc_is_coindexed (a->expr)
2115           && (a->expr->symtree->n.sym->attr.volatile_
2116               || a->expr->symtree->n.sym->attr.asynchronous))
2117         {
2118           if (where)
2119             gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2120                        "at %L requires that dummy %s' has neither "
2121                        "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2122                        f->sym->name);
2123           return 0;
2124         }
2125
2126       /* Fortran 2008, 12.5.2.4 (no constraint).  */
2127       if (a->expr->expr_type == EXPR_VARIABLE
2128           && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2129           && gfc_is_coindexed (a->expr)
2130           && gfc_has_ultimate_allocatable (a->expr))
2131         {
2132           if (where)
2133             gfc_error ("Coindexed actual argument at %L with allocatable "
2134                        "ultimate component to dummy '%s' requires either VALUE "
2135                        "or INTENT(IN)", &a->expr->where, f->sym->name);
2136           return 0;
2137         }
2138
2139       if (a->expr->expr_type != EXPR_NULL
2140           && compare_allocatable (f->sym, a->expr) == 0)
2141         {
2142           if (where)
2143             gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2144                        f->sym->name, &a->expr->where);
2145           return 0;
2146         }
2147
2148       /* Check intent = OUT/INOUT for definable actual argument.  */
2149       if ((a->expr->expr_type != EXPR_VARIABLE
2150            || (a->expr->symtree->n.sym->attr.flavor != FL_VARIABLE
2151                && a->expr->symtree->n.sym->attr.flavor != FL_PROCEDURE))
2152           && (f->sym->attr.intent == INTENT_OUT
2153               || f->sym->attr.intent == INTENT_INOUT))
2154         {
2155           if (where)
2156             gfc_error ("Actual argument at %L must be definable as "
2157                        "the dummy argument '%s' is INTENT = OUT/INOUT",
2158                        &a->expr->where, f->sym->name);
2159           return 0;
2160         }
2161
2162       if (!compare_parameter_protected(f->sym, a->expr))
2163         {
2164           if (where)
2165             gfc_error ("Actual argument at %L is use-associated with "
2166                        "PROTECTED attribute and dummy argument '%s' is "
2167                        "INTENT = OUT/INOUT",
2168                        &a->expr->where,f->sym->name);
2169           return 0;
2170         }
2171
2172       if ((f->sym->attr.intent == INTENT_OUT
2173            || f->sym->attr.intent == INTENT_INOUT
2174            || f->sym->attr.volatile_
2175            || f->sym->attr.asynchronous)
2176           && gfc_has_vector_subscript (a->expr))
2177         {
2178           if (where)
2179             gfc_error ("Array-section actual argument with vector "
2180                        "subscripts at %L is incompatible with INTENT(OUT), "
2181                        "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2182                        "of the dummy argument '%s'",
2183                        &a->expr->where, f->sym->name);
2184           return 0;
2185         }
2186
2187       /* C1232 (R1221) For an actual argument which is an array section or
2188          an assumed-shape array, the dummy argument shall be an assumed-
2189          shape array, if the dummy argument has the VOLATILE attribute.  */
2190
2191       if (f->sym->attr.volatile_
2192           && a->expr->symtree->n.sym->as
2193           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2194           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2195         {
2196           if (where)
2197             gfc_error ("Assumed-shape actual argument at %L is "
2198                        "incompatible with the non-assumed-shape "
2199                        "dummy argument '%s' due to VOLATILE attribute",
2200                        &a->expr->where,f->sym->name);
2201           return 0;
2202         }
2203
2204       if (f->sym->attr.volatile_
2205           && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2206           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2207         {
2208           if (where)
2209             gfc_error ("Array-section actual argument at %L is "
2210                        "incompatible with the non-assumed-shape "
2211                        "dummy argument '%s' due to VOLATILE attribute",
2212                        &a->expr->where,f->sym->name);
2213           return 0;
2214         }
2215
2216       /* C1233 (R1221) For an actual argument which is a pointer array, the
2217          dummy argument shall be an assumed-shape or pointer array, if the
2218          dummy argument has the VOLATILE attribute.  */
2219
2220       if (f->sym->attr.volatile_
2221           && a->expr->symtree->n.sym->attr.pointer
2222           && a->expr->symtree->n.sym->as
2223           && !(f->sym->as
2224                && (f->sym->as->type == AS_ASSUMED_SHAPE
2225                    || f->sym->attr.pointer)))
2226         {
2227           if (where)
2228             gfc_error ("Pointer-array actual argument at %L requires "
2229                        "an assumed-shape or pointer-array dummy "
2230                        "argument '%s' due to VOLATILE attribute",
2231                        &a->expr->where,f->sym->name);
2232           return 0;
2233         }
2234
2235     match:
2236       if (a == actual)
2237         na = i;
2238
2239       new_arg[i++] = a;
2240     }
2241
2242   /* Make sure missing actual arguments are optional.  */
2243   i = 0;
2244   for (f = formal; f; f = f->next, i++)
2245     {
2246       if (new_arg[i] != NULL)
2247         continue;
2248       if (f->sym == NULL)
2249         {
2250           if (where)
2251             gfc_error ("Missing alternate return spec in subroutine call "
2252                        "at %L", where);
2253           return 0;
2254         }
2255       if (!f->sym->attr.optional)
2256         {
2257           if (where)
2258             gfc_error ("Missing actual argument for argument '%s' at %L",
2259                        f->sym->name, where);
2260           return 0;
2261         }
2262     }
2263
2264   /* The argument lists are compatible.  We now relink a new actual
2265      argument list with null arguments in the right places.  The head
2266      of the list remains the head.  */
2267   for (i = 0; i < n; i++)
2268     if (new_arg[i] == NULL)
2269       new_arg[i] = gfc_get_actual_arglist ();
2270
2271   if (na != 0)
2272     {
2273       temp = *new_arg[0];
2274       *new_arg[0] = *actual;
2275       *actual = temp;
2276
2277       a = new_arg[0];
2278       new_arg[0] = new_arg[na];
2279       new_arg[na] = a;
2280     }
2281
2282   for (i = 0; i < n - 1; i++)
2283     new_arg[i]->next = new_arg[i + 1];
2284
2285   new_arg[i]->next = NULL;
2286
2287   if (*ap == NULL && n > 0)
2288     *ap = new_arg[0];
2289
2290   /* Note the types of omitted optional arguments.  */
2291   for (a = *ap, f = formal; a; a = a->next, f = f->next)
2292     if (a->expr == NULL && a->label == NULL)
2293       a->missing_arg_type = f->sym->ts.type;
2294
2295   return 1;
2296 }
2297
2298
2299 typedef struct
2300 {
2301   gfc_formal_arglist *f;
2302   gfc_actual_arglist *a;
2303 }
2304 argpair;
2305
2306 /* qsort comparison function for argument pairs, with the following
2307    order:
2308     - p->a->expr == NULL
2309     - p->a->expr->expr_type != EXPR_VARIABLE
2310     - growing p->a->expr->symbol.  */
2311
2312 static int
2313 pair_cmp (const void *p1, const void *p2)
2314 {
2315   const gfc_actual_arglist *a1, *a2;
2316
2317   /* *p1 and *p2 are elements of the to-be-sorted array.  */
2318   a1 = ((const argpair *) p1)->a;
2319   a2 = ((const argpair *) p2)->a;
2320   if (!a1->expr)
2321     {
2322       if (!a2->expr)
2323         return 0;
2324       return -1;
2325     }
2326   if (!a2->expr)
2327     return 1;
2328   if (a1->expr->expr_type != EXPR_VARIABLE)
2329     {
2330       if (a2->expr->expr_type != EXPR_VARIABLE)
2331         return 0;
2332       return -1;
2333     }
2334   if (a2->expr->expr_type != EXPR_VARIABLE)
2335     return 1;
2336   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2337 }
2338
2339
2340 /* Given two expressions from some actual arguments, test whether they
2341    refer to the same expression. The analysis is conservative.
2342    Returning FAILURE will produce no warning.  */
2343
2344 static gfc_try
2345 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2346 {
2347   const gfc_ref *r1, *r2;
2348
2349   if (!e1 || !e2
2350       || e1->expr_type != EXPR_VARIABLE
2351       || e2->expr_type != EXPR_VARIABLE
2352       || e1->symtree->n.sym != e2->symtree->n.sym)
2353     return FAILURE;
2354
2355   /* TODO: improve comparison, see expr.c:show_ref().  */
2356   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2357     {
2358       if (r1->type != r2->type)
2359         return FAILURE;
2360       switch (r1->type)
2361         {
2362         case REF_ARRAY:
2363           if (r1->u.ar.type != r2->u.ar.type)
2364             return FAILURE;
2365           /* TODO: At the moment, consider only full arrays;
2366              we could do better.  */
2367           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2368             return FAILURE;
2369           break;
2370
2371         case REF_COMPONENT:
2372           if (r1->u.c.component != r2->u.c.component)
2373             return FAILURE;
2374           break;
2375
2376         case REF_SUBSTRING:
2377           return FAILURE;
2378
2379         default:
2380           gfc_internal_error ("compare_actual_expr(): Bad component code");
2381         }
2382     }
2383   if (!r1 && !r2)
2384     return SUCCESS;
2385   return FAILURE;
2386 }
2387
2388
2389 /* Given formal and actual argument lists that correspond to one
2390    another, check that identical actual arguments aren't not
2391    associated with some incompatible INTENTs.  */
2392
2393 static gfc_try
2394 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2395 {
2396   sym_intent f1_intent, f2_intent;
2397   gfc_formal_arglist *f1;
2398   gfc_actual_arglist *a1;
2399   size_t n, i, j;
2400   argpair *p;
2401   gfc_try t = SUCCESS;
2402
2403   n = 0;
2404   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2405     {
2406       if (f1 == NULL && a1 == NULL)
2407         break;
2408       if (f1 == NULL || a1 == NULL)
2409         gfc_internal_error ("check_some_aliasing(): List mismatch");
2410       n++;
2411     }
2412   if (n == 0)
2413     return t;
2414   p = (argpair *) alloca (n * sizeof (argpair));
2415
2416   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2417     {
2418       p[i].f = f1;
2419       p[i].a = a1;
2420     }
2421
2422   qsort (p, n, sizeof (argpair), pair_cmp);
2423
2424   for (i = 0; i < n; i++)
2425     {
2426       if (!p[i].a->expr
2427           || p[i].a->expr->expr_type != EXPR_VARIABLE
2428           || p[i].a->expr->ts.type == BT_PROCEDURE)
2429         continue;
2430       f1_intent = p[i].f->sym->attr.intent;
2431       for (j = i + 1; j < n; j++)
2432         {
2433           /* Expected order after the sort.  */
2434           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2435             gfc_internal_error ("check_some_aliasing(): corrupted data");
2436
2437           /* Are the expression the same?  */
2438           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2439             break;
2440           f2_intent = p[j].f->sym->attr.intent;
2441           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2442               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2443             {
2444               gfc_warning ("Same actual argument associated with INTENT(%s) "
2445                            "argument '%s' and INTENT(%s) argument '%s' at %L",
2446                            gfc_intent_string (f1_intent), p[i].f->sym->name,
2447                            gfc_intent_string (f2_intent), p[j].f->sym->name,
2448                            &p[i].a->expr->where);
2449               t = FAILURE;
2450             }
2451         }
2452     }
2453
2454   return t;
2455 }
2456
2457
2458 /* Given a symbol of a formal argument list and an expression,
2459    return nonzero if their intents are compatible, zero otherwise.  */
2460
2461 static int
2462 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2463 {
2464   if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2465     return 1;
2466
2467   if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2468     return 1;
2469
2470   if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2471     return 0;
2472
2473   return 1;
2474 }
2475
2476
2477 /* Given formal and actual argument lists that correspond to one
2478    another, check that they are compatible in the sense that intents
2479    are not mismatched.  */
2480
2481 static gfc_try
2482 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2483 {
2484   sym_intent f_intent;
2485
2486   for (;; f = f->next, a = a->next)
2487     {
2488       if (f == NULL && a == NULL)
2489         break;
2490       if (f == NULL || a == NULL)
2491         gfc_internal_error ("check_intents(): List mismatch");
2492
2493       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2494         continue;
2495
2496       f_intent = f->sym->attr.intent;
2497
2498       if (!compare_parameter_intent(f->sym, a->expr))
2499         {
2500           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2501                      "specifies INTENT(%s)", &a->expr->where,
2502                      gfc_intent_string (f_intent));
2503           return FAILURE;
2504         }
2505
2506       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2507         {
2508           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2509             {
2510               gfc_error ("Procedure argument at %L is local to a PURE "
2511                          "procedure and is passed to an INTENT(%s) argument",
2512                          &a->expr->where, gfc_intent_string (f_intent));
2513               return FAILURE;
2514             }
2515
2516           if (f->sym->attr.pointer)
2517             {
2518               gfc_error ("Procedure argument at %L is local to a PURE "
2519                          "procedure and has the POINTER attribute",
2520                          &a->expr->where);
2521               return FAILURE;
2522             }
2523         }
2524
2525        /* Fortran 2008, C1283.  */
2526        if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
2527         {
2528           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2529             {
2530               gfc_error ("Coindexed actual argument at %L in PURE procedure "
2531                          "is passed to an INTENT(%s) argument",
2532                          &a->expr->where, gfc_intent_string (f_intent));
2533               return FAILURE;
2534             }
2535
2536           if (f->sym->attr.pointer)
2537             {
2538               gfc_error ("Coindexed actual argument at %L in PURE procedure "
2539                          "is passed to a POINTER dummy argument",
2540                          &a->expr->where);
2541               return FAILURE;
2542             }
2543         }
2544
2545        /* F2008, Section 12.5.2.4.  */
2546        if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
2547            && gfc_is_coindexed (a->expr))
2548          {
2549            gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2550                       "polymorphic dummy argument '%s'",
2551                          &a->expr->where, f->sym->name);
2552            return FAILURE;
2553          }
2554     }
2555
2556   return SUCCESS;
2557 }
2558
2559
2560 /* Check how a procedure is used against its interface.  If all goes
2561    well, the actual argument list will also end up being properly
2562    sorted.  */
2563
2564 void
2565 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2566 {
2567
2568   /* Warn about calls with an implicit interface.  Special case
2569      for calling a ISO_C_BINDING becase c_loc and c_funloc
2570      are pseudo-unknown.  Additionally, warn about procedures not
2571      explicitly declared at all if requested.  */
2572   if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2573     {
2574       if (gfc_option.warn_implicit_interface)
2575         gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2576                      sym->name, where);
2577       else if (gfc_option.warn_implicit_procedure
2578                && sym->attr.proc == PROC_UNKNOWN)
2579         gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2580                      sym->name, where);
2581     }
2582
2583   if (sym->attr.if_source == IFSRC_UNKNOWN)
2584     {
2585       gfc_actual_arglist *a;
2586       for (a = *ap; a; a = a->next)
2587         {
2588           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
2589           if (a->name != NULL && a->name[0] != '%')
2590             {
2591               gfc_error("Keyword argument requires explicit interface "
2592                         "for procedure '%s' at %L", sym->name, &a->expr->where);
2593               break;
2594             }
2595         }
2596
2597       return;
2598     }
2599
2600   if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2601     return;
2602
2603   check_intents (sym->formal, *ap);
2604   if (gfc_option.warn_aliasing)
2605     check_some_aliasing (sym->formal, *ap);
2606 }
2607
2608
2609 /* Check how a procedure pointer component is used against its interface.
2610    If all goes well, the actual argument list will also end up being properly
2611    sorted. Completely analogous to gfc_procedure_use.  */
2612
2613 void
2614 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2615 {
2616
2617   /* Warn about calls with an implicit interface.  Special case
2618      for calling a ISO_C_BINDING becase c_loc and c_funloc
2619      are pseudo-unknown.  */
2620   if (gfc_option.warn_implicit_interface
2621       && comp->attr.if_source == IFSRC_UNKNOWN
2622       && !comp->attr.is_iso_c)
2623     gfc_warning ("Procedure pointer component '%s' called with an implicit "
2624                  "interface at %L", comp->name, where);
2625
2626   if (comp->attr.if_source == IFSRC_UNKNOWN)
2627     {
2628       gfc_actual_arglist *a;
2629       for (a = *ap; a; a = a->next)
2630         {
2631           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
2632           if (a->name != NULL && a->name[0] != '%')
2633             {
2634               gfc_error("Keyword argument requires explicit interface "
2635                         "for procedure pointer component '%s' at %L",
2636                         comp->name, &a->expr->where);
2637               break;
2638             }
2639         }
2640
2641       return;
2642     }
2643
2644   if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2645     return;
2646
2647   check_intents (comp->formal, *ap);
2648   if (gfc_option.warn_aliasing)
2649     check_some_aliasing (comp->formal, *ap);
2650 }
2651
2652
2653 /* Try if an actual argument list matches the formal list of a symbol,
2654    respecting the symbol's attributes like ELEMENTAL.  This is used for
2655    GENERIC resolution.  */
2656
2657 bool
2658 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2659 {
2660   bool r;
2661
2662   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2663
2664   r = !sym->attr.elemental;
2665   if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2666     {
2667       check_intents (sym->formal, *args);
2668       if (gfc_option.warn_aliasing)
2669         check_some_aliasing (sym->formal, *args);
2670       return true;
2671     }
2672
2673   return false;
2674 }
2675
2676
2677 /* Given an interface pointer and an actual argument list, search for
2678    a formal argument list that matches the actual.  If found, returns
2679    a pointer to the symbol of the correct interface.  Returns NULL if
2680    not found.  */
2681
2682 gfc_symbol *
2683 gfc_search_interface (gfc_interface *intr, int sub_flag,
2684                       gfc_actual_arglist **ap)
2685 {
2686   gfc_symbol *elem_sym = NULL;
2687   for (; intr; intr = intr->next)
2688     {
2689       if (sub_flag && intr->sym->attr.function)
2690         continue;
2691       if (!sub_flag && intr->sym->attr.subroutine)
2692         continue;
2693
2694       if (gfc_arglist_matches_symbol (ap, intr->sym))
2695         {
2696           /* Satisfy 12.4.4.1 such that an elemental match has lower
2697              weight than a non-elemental match.  */ 
2698           if (intr->sym->attr.elemental)
2699             {
2700               elem_sym = intr->sym;
2701               continue;
2702             }
2703           return intr->sym;
2704         }
2705     }
2706
2707   return elem_sym ? elem_sym : NULL;
2708 }
2709
2710
2711 /* Do a brute force recursive search for a symbol.  */
2712
2713 static gfc_symtree *
2714 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2715 {
2716   gfc_symtree * st;
2717
2718   if (root->n.sym == sym)
2719     return root;
2720
2721   st = NULL;
2722   if (root->left)
2723     st = find_symtree0 (root->left, sym);
2724   if (root->right && ! st)
2725     st = find_symtree0 (root->right, sym);
2726   return st;
2727 }
2728
2729
2730 /* Find a symtree for a symbol.  */
2731
2732 gfc_symtree *
2733 gfc_find_sym_in_symtree (gfc_symbol *sym)
2734 {
2735   gfc_symtree *st;
2736   gfc_namespace *ns;
2737
2738   /* First try to find it by name.  */
2739   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2740   if (st && st->n.sym == sym)
2741     return st;
2742
2743   /* If it's been renamed, resort to a brute-force search.  */
2744   /* TODO: avoid having to do this search.  If the symbol doesn't exist
2745      in the symtree for the current namespace, it should probably be added.  */
2746   for (ns = gfc_current_ns; ns; ns = ns->parent)
2747     {
2748       st = find_symtree0 (ns->sym_root, sym);
2749       if (st)
2750         return st;
2751     }
2752   gfc_internal_error ("Unable to find symbol %s", sym->name);
2753   /* Not reached.  */
2754 }
2755
2756
2757 /* See if the arglist to an operator-call contains a derived-type argument
2758    with a matching type-bound operator.  If so, return the matching specific
2759    procedure defined as operator-target as well as the base-object to use
2760    (which is the found derived-type argument with operator).  */
2761
2762 static gfc_typebound_proc*
2763 matching_typebound_op (gfc_expr** tb_base,
2764                        gfc_actual_arglist* args,
2765                        gfc_intrinsic_op op, const char* uop)
2766 {
2767   gfc_actual_arglist* base;
2768
2769   for (base = args; base; base = base->next)
2770     if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
2771       {
2772         gfc_typebound_proc* tb;
2773         gfc_symbol* derived;
2774         gfc_try result;
2775
2776         if (base->expr->ts.type == BT_CLASS)
2777           derived = CLASS_DATA (base->expr)->ts.u.derived;
2778         else
2779           derived = base->expr->ts.u.derived;
2780
2781         if (op == INTRINSIC_USER)
2782           {
2783             gfc_symtree* tb_uop;
2784
2785             gcc_assert (uop);
2786             tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
2787                                                  false, NULL);
2788
2789             if (tb_uop)
2790               tb = tb_uop->n.tb;
2791             else
2792               tb = NULL;
2793           }
2794         else
2795           tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
2796                                                 false, NULL);
2797
2798         /* This means we hit a PRIVATE operator which is use-associated and
2799            should thus not be seen.  */
2800         if (result == FAILURE)
2801           tb = NULL;
2802
2803         /* Look through the super-type hierarchy for a matching specific
2804            binding.  */
2805         for (; tb; tb = tb->overridden)
2806           {
2807             gfc_tbp_generic* g;
2808
2809             gcc_assert (tb->is_generic);
2810             for (g = tb->u.generic; g; g = g->next)
2811               {
2812                 gfc_symbol* target;
2813                 gfc_actual_arglist* argcopy;
2814                 bool matches;
2815
2816                 gcc_assert (g->specific);
2817                 if (g->specific->error)
2818                   continue;
2819
2820                 target = g->specific->u.specific->n.sym;
2821
2822                 /* Check if this arglist matches the formal.  */
2823                 argcopy = gfc_copy_actual_arglist (args);
2824                 matches = gfc_arglist_matches_symbol (&argcopy, target);
2825                 gfc_free_actual_arglist (argcopy);
2826
2827                 /* Return if we found a match.  */
2828                 if (matches)
2829                   {
2830                     *tb_base = base->expr;
2831                     return g->specific;
2832                   }
2833               }
2834           }
2835       }
2836
2837   return NULL;
2838 }
2839
2840
2841 /* For the 'actual arglist' of an operator call and a specific typebound
2842    procedure that has been found the target of a type-bound operator, build the
2843    appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
2844    type-bound procedures rather than resolving type-bound operators 'directly'
2845    so that we can reuse the existing logic.  */
2846
2847 static void
2848 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
2849                              gfc_expr* base, gfc_typebound_proc* target)
2850 {
2851   e->expr_type = EXPR_COMPCALL;
2852   e->value.compcall.tbp = target;
2853   e->value.compcall.name = "operator"; /* Should not matter.  */
2854   e->value.compcall.actual = actual;
2855   e->value.compcall.base_object = base;
2856   e->value.compcall.ignore_pass = 1;
2857   e->value.compcall.assign = 0;
2858 }
2859
2860
2861 /* This subroutine is called when an expression is being resolved.
2862    The expression node in question is either a user defined operator
2863    or an intrinsic operator with arguments that aren't compatible
2864    with the operator.  This subroutine builds an actual argument list
2865    corresponding to the operands, then searches for a compatible
2866    interface.  If one is found, the expression node is replaced with
2867    the appropriate function call.
2868    real_error is an additional output argument that specifies if FAILURE
2869    is because of some real error and not because no match was found.  */
2870
2871 gfc_try
2872 gfc_extend_expr (gfc_expr *e, bool *real_error)
2873 {
2874   gfc_actual_arglist *actual;
2875   gfc_symbol *sym;
2876   gfc_namespace *ns;
2877   gfc_user_op *uop;
2878   gfc_intrinsic_op i;
2879
2880   sym = NULL;
2881
2882   actual = gfc_get_actual_arglist ();
2883   actual->expr = e->value.op.op1;
2884
2885   *real_error = false;
2886
2887   if (e->value.op.op2 != NULL)
2888     {
2889       actual->next = gfc_get_actual_arglist ();
2890       actual->next->expr = e->value.op.op2;
2891     }
2892
2893   i = fold_unary_intrinsic (e->value.op.op);
2894
2895   if (i == INTRINSIC_USER)
2896     {
2897       for (ns = gfc_current_ns; ns; ns = ns->parent)
2898         {
2899           uop = gfc_find_uop (e->value.op.uop->name, ns);
2900           if (uop == NULL)
2901             continue;
2902
2903           sym = gfc_search_interface (uop->op, 0, &actual);
2904           if (sym != NULL)
2905             break;
2906         }
2907     }
2908   else
2909     {
2910       for (ns = gfc_current_ns; ns; ns = ns->parent)
2911         {
2912           /* Due to the distinction between '==' and '.eq.' and friends, one has
2913              to check if either is defined.  */
2914           switch (i)
2915             {
2916 #define CHECK_OS_COMPARISON(comp) \
2917   case INTRINSIC_##comp: \
2918   case INTRINSIC_##comp##_OS: \
2919     sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2920     if (!sym) \
2921       sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2922     break;
2923               CHECK_OS_COMPARISON(EQ)
2924               CHECK_OS_COMPARISON(NE)
2925               CHECK_OS_COMPARISON(GT)
2926               CHECK_OS_COMPARISON(GE)
2927               CHECK_OS_COMPARISON(LT)
2928               CHECK_OS_COMPARISON(LE)
2929 #undef CHECK_OS_COMPARISON
2930
2931               default:
2932                 sym = gfc_search_interface (ns->op[i], 0, &actual);
2933             }
2934
2935           if (sym != NULL)
2936             break;
2937         }
2938     }
2939
2940   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2941      found rather than just taking the first one and not checking further.  */
2942
2943   if (sym == NULL)
2944     {
2945       gfc_typebound_proc* tbo;
2946       gfc_expr* tb_base;
2947
2948       /* See if we find a matching type-bound operator.  */
2949       if (i == INTRINSIC_USER)
2950         tbo = matching_typebound_op (&tb_base, actual,
2951                                      i, e->value.op.uop->name);
2952       else
2953         switch (i)
2954           {
2955 #define CHECK_OS_COMPARISON(comp) \
2956   case INTRINSIC_##comp: \
2957   case INTRINSIC_##comp##_OS: \
2958     tbo = matching_typebound_op (&tb_base, actual, \
2959                                  INTRINSIC_##comp, NULL); \
2960     if (!tbo) \
2961       tbo = matching_typebound_op (&tb_base, actual, \
2962                                    INTRINSIC_##comp##_OS, NULL); \
2963     break;
2964             CHECK_OS_COMPARISON(EQ)
2965             CHECK_OS_COMPARISON(NE)
2966             CHECK_OS_COMPARISON(GT)
2967             CHECK_OS_COMPARISON(GE)
2968             CHECK_OS_COMPARISON(LT)
2969             CHECK_OS_COMPARISON(LE)
2970 #undef CHECK_OS_COMPARISON
2971
2972             default:
2973               tbo = matching_typebound_op (&tb_base, actual, i, NULL);
2974               break;
2975           }
2976               
2977       /* If there is a matching typebound-operator, replace the expression with
2978          a call to it and succeed.  */
2979       if (tbo)
2980         {
2981           gfc_try result;
2982
2983           gcc_assert (tb_base);
2984           build_compcall_for_operator (e, actual, tb_base, tbo);
2985
2986           result = gfc_resolve_expr (e);
2987           if (result == FAILURE)
2988             *real_error = true;
2989
2990           return result;
2991         }
2992
2993       /* Don't use gfc_free_actual_arglist().  */
2994       if (actual->next != NULL)
2995         gfc_free (actual->next);
2996       gfc_free (actual);
2997
2998       return FAILURE;
2999     }
3000
3001   /* Change the expression node to a function call.  */
3002   e->expr_type = EXPR_FUNCTION;
3003   e->symtree = gfc_find_sym_in_symtree (sym);
3004   e->value.function.actual = actual;
3005   e->value.function.esym = NULL;
3006   e->value.function.isym = NULL;
3007   e->value.function.name = NULL;
3008   e->user_operator = 1;
3009
3010   if (gfc_resolve_expr (e) == FAILURE)
3011     {
3012       *real_error = true;
3013       return FAILURE;
3014     }
3015
3016   return SUCCESS;
3017 }
3018
3019
3020 /* Tries to replace an assignment code node with a subroutine call to
3021    the subroutine associated with the assignment operator.  Return
3022    SUCCESS if the node was replaced.  On FAILURE, no error is
3023    generated.  */
3024
3025 gfc_try
3026 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3027 {
3028   gfc_actual_arglist *actual;
3029   gfc_expr *lhs, *rhs;
3030   gfc_symbol *sym;
3031
3032   lhs = c->expr1;
3033   rhs = c->expr2;
3034
3035   /* Don't allow an intrinsic assignment to be replaced.  */
3036   if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3037       && (rhs->rank == 0 || rhs->rank == lhs->rank)
3038       && (lhs->ts.type == rhs->ts.type
3039           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3040     return FAILURE;
3041
3042   actual = gfc_get_actual_arglist ();
3043   actual->expr = lhs;
3044
3045   actual->next = gfc_get_actual_arglist ();
3046   actual->next->expr = rhs;
3047
3048   sym = NULL;
3049
3050   for (; ns; ns = ns->parent)
3051     {
3052       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3053       if (sym != NULL)
3054         break;
3055     }
3056
3057   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
3058
3059   if (sym == NULL)
3060     {
3061       gfc_typebound_proc* tbo;
3062       gfc_expr* tb_base;
3063
3064       /* See if we find a matching type-bound assignment.  */
3065       tbo = matching_typebound_op (&tb_base, actual,
3066                                    INTRINSIC_ASSIGN, NULL);
3067               
3068       /* If there is one, replace the expression with a call to it and
3069          succeed.  */
3070       if (tbo)
3071         {
3072           gcc_assert (tb_base);
3073           c->expr1 = gfc_get_expr ();
3074           build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
3075           c->expr1->value.compcall.assign = 1;
3076           c->expr2 = NULL;
3077           c->op = EXEC_COMPCALL;
3078
3079           /* c is resolved from the caller, so no need to do it here.  */
3080
3081           return SUCCESS;
3082         }
3083
3084       gfc_free (actual->next);
3085       gfc_free (actual);
3086       return FAILURE;
3087     }
3088
3089   /* Replace the assignment with the call.  */
3090   c->op = EXEC_ASSIGN_CALL;
3091   c->symtree = gfc_find_sym_in_symtree (sym);
3092   c->expr1 = NULL;
3093   c->expr2 = NULL;
3094   c->ext.actual = actual;
3095
3096   return SUCCESS;
3097 }
3098
3099
3100 /* Make sure that the interface just parsed is not already present in
3101    the given interface list.  Ambiguity isn't checked yet since module
3102    procedures can be present without interfaces.  */
3103
3104 static gfc_try
3105 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
3106 {
3107   gfc_interface *ip;
3108
3109   for (ip = base; ip; ip = ip->next)
3110     {
3111       if (ip->sym == new_sym)
3112         {
3113           gfc_error ("Entity '%s' at %C is already present in the interface",
3114                      new_sym->name);
3115           return FAILURE;
3116         }
3117     }
3118
3119   return SUCCESS;
3120 }
3121
3122
3123 /* Add a symbol to the current interface.  */
3124
3125 gfc_try
3126 gfc_add_interface (gfc_symbol *new_sym)
3127 {
3128   gfc_interface **head, *intr;
3129   gfc_namespace *ns;
3130   gfc_symbol *sym;
3131
3132   switch (current_interface.type)
3133     {
3134     case INTERFACE_NAMELESS:
3135     case INTERFACE_ABSTRACT:
3136       return SUCCESS;
3137
3138     case INTERFACE_INTRINSIC_OP:
3139       for (ns = current_interface.ns; ns; ns = ns->parent)
3140         switch (current_interface.op)
3141           {
3142             case INTRINSIC_EQ:
3143             case INTRINSIC_EQ_OS:
3144               if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
3145                   check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
3146                 return FAILURE;
3147               break;
3148
3149             case INTRINSIC_NE:
3150             case INTRINSIC_NE_OS:
3151               if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
3152                   check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
3153                 return FAILURE;
3154               break;
3155
3156             case INTRINSIC_GT:
3157             case INTRINSIC_GT_OS:
3158               if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
3159                   check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
3160                 return FAILURE;
3161               break;
3162
3163             case INTRINSIC_GE:
3164             case INTRINSIC_GE_OS:
3165               if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
3166                   check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
3167                 return FAILURE;
3168               break;
3169
3170             case INTRINSIC_LT:
3171             case INTRINSIC_LT_OS:
3172               if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
3173                   check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
3174                 return FAILURE;
3175               break;
3176
3177             case INTRINSIC_LE:
3178             case INTRINSIC_LE_OS:
3179               if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
3180                   check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
3181                 return FAILURE;
3182               break;
3183
3184             default:
3185               if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
3186                 return FAILURE;
3187           }
3188
3189       head = &current_interface.ns->op[current_interface.op];
3190       break;
3191
3192     case INTERFACE_GENERIC:
3193       for (ns = current_interface.ns; ns; ns = ns->parent)
3194         {
3195           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3196           if (sym == NULL)
3197             continue;
3198
3199           if (check_new_interface (sym->generic, new_sym) == FAILURE)
3200             return FAILURE;
3201         }
3202
3203       head = &current_interface.sym->generic;
3204       break;
3205
3206     case INTERFACE_USER_OP:
3207       if (check_new_interface (current_interface.uop->op, new_sym)
3208           == FAILURE)
3209         return FAILURE;
3210
3211       head = &current_interface.uop->op;
3212       break;
3213
3214     default:
3215       gfc_internal_error ("gfc_add_interface(): Bad interface type");
3216     }
3217
3218   intr = gfc_get_interface ();
3219   intr->sym = new_sym;
3220   intr->where = gfc_current_locus;
3221
3222   intr->next = *head;
3223   *head = intr;
3224
3225   return SUCCESS;
3226 }
3227
3228
3229 gfc_interface *
3230 gfc_current_interface_head (void)
3231 {
3232   switch (current_interface.type)
3233     {
3234       case INTERFACE_INTRINSIC_OP:
3235         return current_interface.ns->op[current_interface.op];
3236         break;
3237
3238       case INTERFACE_GENERIC:
3239         return current_interface.sym->generic;
3240         break;
3241
3242       case INTERFACE_USER_OP:
3243         return current_interface.uop->op;
3244         break;
3245
3246       default:
3247         gcc_unreachable ();
3248     }
3249 }
3250
3251
3252 void
3253 gfc_set_current_interface_head (gfc_interface *i)
3254 {
3255   switch (current_interface.type)
3256     {
3257       case INTERFACE_INTRINSIC_OP:
3258         current_interface.ns->op[current_interface.op] = i;
3259         break;
3260
3261       case INTERFACE_GENERIC:
3262         current_interface.sym->generic = i;
3263         break;
3264
3265       case INTERFACE_USER_OP:
3266         current_interface.uop->op = i;
3267         break;
3268
3269       default:
3270         gcc_unreachable ();
3271     }
3272 }
3273
3274
3275 /* Gets rid of a formal argument list.  We do not free symbols.
3276    Symbols are freed when a namespace is freed.  */
3277
3278 void
3279 gfc_free_formal_arglist (gfc_formal_arglist *p)
3280 {
3281   gfc_formal_arglist *q;
3282
3283   for (; p; p = q)
3284     {
3285       q = p->next;
3286       gfc_free (p);
3287     }
3288 }