OSDN Git Service

5024fe86bdf2c28dd88366c34aaf81720434f645
[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
1372       /* Fortran 2008 allows non-pointer actual arguments.  */
1373       if (!attr.pointer && attr.target && formal->attr.intent == INTENT_IN)
1374         return 2;
1375
1376       if (!attr.pointer)
1377         return 0;
1378     }
1379
1380   return 1;
1381 }
1382
1383
1384 /* Emit clear error messages for rank mismatch.  */
1385
1386 static void
1387 argument_rank_mismatch (const char *name, locus *where,
1388                         int rank1, int rank2)
1389 {
1390   if (rank1 == 0)
1391     {
1392       gfc_error ("Rank mismatch in argument '%s' at %L "
1393                  "(scalar and rank-%d)", name, where, rank2);
1394     }
1395   else if (rank2 == 0)
1396     {
1397       gfc_error ("Rank mismatch in argument '%s' at %L "
1398                  "(rank-%d and scalar)", name, where, rank1);
1399     }
1400   else
1401     {    
1402       gfc_error ("Rank mismatch in argument '%s' at %L "
1403                  "(rank-%d and rank-%d)", name, where, rank1, rank2);
1404     }
1405 }
1406
1407
1408 /* Given a symbol of a formal argument list and an expression, see if
1409    the two are compatible as arguments.  Returns nonzero if
1410    compatible, zero if not compatible.  */
1411
1412 static int
1413 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1414                    int ranks_must_agree, int is_elemental, locus *where)
1415 {
1416   gfc_ref *ref;
1417   bool rank_check;
1418
1419   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1420      procs c_f_pointer or c_f_procpointer, and we need to accept most
1421      pointers the user could give us.  This should allow that.  */
1422   if (formal->ts.type == BT_VOID)
1423     return 1;
1424
1425   if (formal->ts.type == BT_DERIVED
1426       && formal->ts.u.derived && formal->ts.u.derived->ts.is_iso_c
1427       && actual->ts.type == BT_DERIVED
1428       && actual->ts.u.derived && actual->ts.u.derived->ts.is_iso_c)
1429     return 1;
1430
1431   if (formal->ts.type == BT_CLASS && actual->ts.type == BT_DERIVED)
1432     /* Make sure the vtab symbol is present when
1433        the module variables are generated.  */
1434     gfc_find_derived_vtab (actual->ts.u.derived);
1435
1436   if (actual->ts.type == BT_PROCEDURE)
1437     {
1438       char err[200];
1439       gfc_symbol *act_sym = actual->symtree->n.sym;
1440
1441       if (formal->attr.flavor != FL_PROCEDURE)
1442         {
1443           if (where)
1444             gfc_error ("Invalid procedure argument at %L", &actual->where);
1445           return 0;
1446         }
1447
1448       if (!gfc_compare_interfaces (formal, act_sym, act_sym->name, 0, 1, err,
1449                                    sizeof(err)))
1450         {
1451           if (where)
1452             gfc_error ("Interface mismatch in dummy procedure '%s' at %L: %s",
1453                        formal->name, &actual->where, err);
1454           return 0;
1455         }
1456
1457       if (formal->attr.function && !act_sym->attr.function)
1458         {
1459           gfc_add_function (&act_sym->attr, act_sym->name,
1460           &act_sym->declared_at);
1461           if (act_sym->ts.type == BT_UNKNOWN
1462               && gfc_set_default_type (act_sym, 1, act_sym->ns) == FAILURE)
1463             return 0;
1464         }
1465       else if (formal->attr.subroutine && !act_sym->attr.subroutine)
1466         gfc_add_subroutine (&act_sym->attr, act_sym->name,
1467                             &act_sym->declared_at);
1468
1469       return 1;
1470     }
1471
1472   /* F2008, C1241.  */
1473   if (formal->attr.pointer && formal->attr.contiguous
1474       && !gfc_is_simply_contiguous (actual, true))
1475     {
1476       if (where)
1477         gfc_error ("Actual argument to contiguous pointer dummy '%s' at %L "
1478                    "must be simply contigous", formal->name, &actual->where);
1479       return 0;
1480     }
1481
1482   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1483       && actual->ts.type != BT_HOLLERITH
1484       && !gfc_compare_types (&formal->ts, &actual->ts))
1485     {
1486       if (where)
1487         gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s",
1488                    formal->name, &actual->where, gfc_typename (&actual->ts),
1489                    gfc_typename (&formal->ts));
1490       return 0;
1491     }
1492
1493   if (formal->attr.codimension)
1494     {
1495       gfc_ref *last = NULL;
1496
1497       if (actual->expr_type != EXPR_VARIABLE
1498           || (actual->ref == NULL
1499               && !actual->symtree->n.sym->attr.codimension))
1500         {
1501           if (where)
1502             gfc_error ("Actual argument to '%s' at %L must be a coarray",
1503                        formal->name, &actual->where);
1504           return 0;
1505         }
1506
1507       for (ref = actual->ref; ref; ref = ref->next)
1508         {
1509           if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0)
1510             {
1511               if (where)
1512                 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1513                            "and not coindexed", formal->name, &ref->u.ar.where);
1514               return 0;
1515             }
1516           if (ref->type == REF_ARRAY && ref->u.ar.as->corank
1517               && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0)
1518             {
1519               if (where)
1520                 gfc_error ("Actual argument to '%s' at %L must be a coarray "
1521                            "and thus shall not have an array designator",
1522                            formal->name, &ref->u.ar.where);
1523               return 0;
1524             }
1525           if (ref->type == REF_COMPONENT)
1526             last = ref;
1527         }
1528
1529       if (last && !last->u.c.component->attr.codimension)
1530         {
1531           if (where)
1532             gfc_error ("Actual argument to '%s' at %L must be a coarray",
1533                        formal->name, &actual->where);
1534           return 0;
1535         }
1536
1537       /* F2008, 12.5.2.6.  */
1538       if (formal->attr.allocatable &&
1539           ((last && last->u.c.component->as->corank != formal->as->corank)
1540            || (!last
1541                && actual->symtree->n.sym->as->corank != formal->as->corank)))
1542         {
1543           if (where)
1544             gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)",
1545                    formal->name, &actual->where, formal->as->corank,
1546                    last ? last->u.c.component->as->corank
1547                         : actual->symtree->n.sym->as->corank);
1548           return 0;
1549         }
1550
1551       /* F2008, 12.5.2.8.  */
1552       if (formal->attr.dimension
1553           && (formal->attr.contiguous || formal->as->type != AS_ASSUMED_SHAPE)
1554           && !gfc_is_simply_contiguous (actual, true))
1555         {
1556           if (where)
1557             gfc_error ("Actual argument to '%s' at %L must be simply "
1558                        "contiguous", formal->name, &actual->where);
1559           return 0;
1560         }
1561     }
1562
1563   /* F2008, C1239/C1240.  */
1564   if (actual->expr_type == EXPR_VARIABLE
1565       && (actual->symtree->n.sym->attr.asynchronous
1566          || actual->symtree->n.sym->attr.volatile_)
1567       &&  (formal->attr.asynchronous || formal->attr.volatile_)
1568       && actual->rank && !gfc_is_simply_contiguous (actual, true)
1569       && ((formal->as->type != AS_ASSUMED_SHAPE && !formal->attr.pointer)
1570           || formal->attr.contiguous))
1571     {
1572       if (where)
1573         gfc_error ("Dummy argument '%s' has to be a pointer or assumed-shape "
1574                    "array without CONTIGUOUS attribute - as actual argument at"
1575                    " %L is not simply contiguous and both are ASYNCHRONOUS "
1576                    "or VOLATILE", formal->name, &actual->where);
1577       return 0;
1578     }
1579
1580   if (symbol_rank (formal) == actual->rank)
1581     return 1;
1582
1583   rank_check = where != NULL && !is_elemental && formal->as
1584                && (formal->as->type == AS_ASSUMED_SHAPE
1585                    || formal->as->type == AS_DEFERRED)
1586                && actual->expr_type != EXPR_NULL;
1587
1588   /* Scalar & coindexed, see: F2008, Section 12.5.2.4.  */
1589   if (rank_check || ranks_must_agree
1590       || (formal->attr.pointer && actual->expr_type != EXPR_NULL)
1591       || (actual->rank != 0 && !(is_elemental || formal->attr.dimension))
1592       || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE
1593           && actual->expr_type != EXPR_NULL)
1594       || (actual->rank == 0 && formal->attr.dimension
1595           && gfc_is_coindexed (actual)))
1596     {
1597       if (where)
1598         argument_rank_mismatch (formal->name, &actual->where,
1599                                 symbol_rank (formal), actual->rank);
1600       return 0;
1601     }
1602   else if (actual->rank != 0 && (is_elemental || formal->attr.dimension))
1603     return 1;
1604
1605   /* At this point, we are considering a scalar passed to an array.   This
1606      is valid (cf. F95 12.4.1.1; F2003 12.4.1.2),
1607      - if the actual argument is (a substring of) an element of a
1608        non-assumed-shape/non-pointer array;
1609      - (F2003) if the actual argument is of type character.  */
1610
1611   for (ref = actual->ref; ref; ref = ref->next)
1612     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1613         && ref->u.ar.dimen > 0)
1614       break;
1615
1616   /* Not an array element.  */
1617   if (formal->ts.type == BT_CHARACTER
1618       && (ref == NULL
1619           || (actual->expr_type == EXPR_VARIABLE
1620               && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1621                   || actual->symtree->n.sym->attr.pointer))))
1622     {
1623       if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1624         {
1625           gfc_error ("Fortran 2003: Scalar CHARACTER actual argument with "
1626                      "array dummy argument '%s' at %L",
1627                      formal->name, &actual->where);
1628           return 0;
1629         }
1630       else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1631         return 0;
1632       else
1633         return 1;
1634     }
1635   else if (ref == NULL && actual->expr_type != EXPR_NULL)
1636     {
1637       if (where)
1638         argument_rank_mismatch (formal->name, &actual->where,
1639                                 symbol_rank (formal), actual->rank);
1640       return 0;
1641     }
1642
1643   if (actual->expr_type == EXPR_VARIABLE
1644       && actual->symtree->n.sym->as
1645       && (actual->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1646           || actual->symtree->n.sym->attr.pointer))
1647     {
1648       if (where)
1649         gfc_error ("Element of assumed-shaped array passed to dummy "
1650                    "argument '%s' at %L", formal->name, &actual->where);
1651       return 0;
1652     }
1653
1654   return 1;
1655 }
1656
1657
1658 /* Returns the storage size of a symbol (formal argument) or
1659    zero if it cannot be determined.  */
1660
1661 static unsigned long
1662 get_sym_storage_size (gfc_symbol *sym)
1663 {
1664   int i;
1665   unsigned long strlen, elements;
1666
1667   if (sym->ts.type == BT_CHARACTER)
1668     {
1669       if (sym->ts.u.cl && sym->ts.u.cl->length
1670           && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1671         strlen = mpz_get_ui (sym->ts.u.cl->length->value.integer);
1672       else
1673         return 0;
1674     }
1675   else
1676     strlen = 1; 
1677
1678   if (symbol_rank (sym) == 0)
1679     return strlen;
1680
1681   elements = 1;
1682   if (sym->as->type != AS_EXPLICIT)
1683     return 0;
1684   for (i = 0; i < sym->as->rank; i++)
1685     {
1686       if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1687           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1688         return 0;
1689
1690       elements *= mpz_get_si (sym->as->upper[i]->value.integer)
1691                   - mpz_get_si (sym->as->lower[i]->value.integer) + 1L;
1692     }
1693
1694   return strlen*elements;
1695 }
1696
1697
1698 /* Returns the storage size of an expression (actual argument) or
1699    zero if it cannot be determined. For an array element, it returns
1700    the remaining size as the element sequence consists of all storage
1701    units of the actual argument up to the end of the array.  */
1702
1703 static unsigned long
1704 get_expr_storage_size (gfc_expr *e)
1705 {
1706   int i;
1707   long int strlen, elements;
1708   long int substrlen = 0;
1709   bool is_str_storage = false;
1710   gfc_ref *ref;
1711
1712   if (e == NULL)
1713     return 0;
1714   
1715   if (e->ts.type == BT_CHARACTER)
1716     {
1717       if (e->ts.u.cl && e->ts.u.cl->length
1718           && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1719         strlen = mpz_get_si (e->ts.u.cl->length->value.integer);
1720       else if (e->expr_type == EXPR_CONSTANT
1721                && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
1722         strlen = e->value.character.length;
1723       else
1724         return 0;
1725     }
1726   else
1727     strlen = 1; /* Length per element.  */
1728
1729   if (e->rank == 0 && !e->ref)
1730     return strlen;
1731
1732   elements = 1;
1733   if (!e->ref)
1734     {
1735       if (!e->shape)
1736         return 0;
1737       for (i = 0; i < e->rank; i++)
1738         elements *= mpz_get_si (e->shape[i]);
1739       return elements*strlen;
1740     }
1741
1742   for (ref = e->ref; ref; ref = ref->next)
1743     {
1744       if (ref->type == REF_SUBSTRING && ref->u.ss.start
1745           && ref->u.ss.start->expr_type == EXPR_CONSTANT)
1746         {
1747           if (is_str_storage)
1748             {
1749               /* The string length is the substring length.
1750                  Set now to full string length.  */
1751               if (ref->u.ss.length == NULL
1752                   || ref->u.ss.length->length->expr_type != EXPR_CONSTANT)
1753                 return 0;
1754
1755               strlen = mpz_get_ui (ref->u.ss.length->length->value.integer);
1756             }
1757           substrlen = strlen - mpz_get_ui (ref->u.ss.start->value.integer) + 1;
1758           continue;
1759         }
1760
1761       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1762           && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1763           && ref->u.ar.as->upper)
1764         for (i = 0; i < ref->u.ar.dimen; i++)
1765           {
1766             long int start, end, stride;
1767             stride = 1;
1768
1769             if (ref->u.ar.stride[i])
1770               {
1771                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1772                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1773                 else
1774                   return 0;
1775               }
1776
1777             if (ref->u.ar.start[i])
1778               {
1779                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1780                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1781                 else
1782                   return 0;
1783               }
1784             else if (ref->u.ar.as->lower[i]
1785                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1786               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1787             else
1788               return 0;
1789
1790             if (ref->u.ar.end[i])
1791               {
1792                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1793                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1794                 else
1795                   return 0;
1796               }
1797             else if (ref->u.ar.as->upper[i]
1798                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1799               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1800             else
1801               return 0;
1802
1803             elements *= (end - start)/stride + 1L;
1804           }
1805       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1806                && ref->u.ar.as->lower && ref->u.ar.as->upper)
1807         for (i = 0; i < ref->u.ar.as->rank; i++)
1808           {
1809             if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1810                 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1811                 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1812               elements *= mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1813                           - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1814                           + 1L;
1815             else
1816               return 0;
1817           }
1818       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT
1819                && e->expr_type == EXPR_VARIABLE)
1820         {
1821           if (e->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1822               || e->symtree->n.sym->attr.pointer)
1823             {
1824               elements = 1;
1825               continue;
1826             }
1827
1828           /* Determine the number of remaining elements in the element
1829              sequence for array element designators.  */
1830           is_str_storage = true;
1831           for (i = ref->u.ar.dimen - 1; i >= 0; i--)
1832             {
1833               if (ref->u.ar.start[i] == NULL
1834                   || ref->u.ar.start[i]->expr_type != EXPR_CONSTANT
1835                   || ref->u.ar.as->upper[i] == NULL
1836                   || ref->u.ar.as->lower[i] == NULL
1837                   || ref->u.ar.as->upper[i]->expr_type != EXPR_CONSTANT
1838                   || ref->u.ar.as->lower[i]->expr_type != EXPR_CONSTANT)
1839                 return 0;
1840
1841               elements
1842                    = elements
1843                      * (mpz_get_si (ref->u.ar.as->upper[i]->value.integer)
1844                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer)
1845                         + 1L)
1846                      - (mpz_get_si (ref->u.ar.start[i]->value.integer)
1847                         - mpz_get_si (ref->u.ar.as->lower[i]->value.integer));
1848             }
1849         }
1850       else
1851         return 0;
1852     }
1853
1854   if (substrlen)
1855     return (is_str_storage) ? substrlen + (elements-1)*strlen
1856                             : elements*strlen;
1857   else
1858     return elements*strlen;
1859 }
1860
1861
1862 /* Given an expression, check whether it is an array section
1863    which has a vector subscript. If it has, one is returned,
1864    otherwise zero.  */
1865
1866 int
1867 gfc_has_vector_subscript (gfc_expr *e)
1868 {
1869   int i;
1870   gfc_ref *ref;
1871
1872   if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1873     return 0;
1874
1875   for (ref = e->ref; ref; ref = ref->next)
1876     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1877       for (i = 0; i < ref->u.ar.dimen; i++)
1878         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1879           return 1;
1880
1881   return 0;
1882 }
1883
1884
1885 /* Given formal and actual argument lists, see if they are compatible.
1886    If they are compatible, the actual argument list is sorted to
1887    correspond with the formal list, and elements for missing optional
1888    arguments are inserted. If WHERE pointer is nonnull, then we issue
1889    errors when things don't match instead of just returning the status
1890    code.  */
1891
1892 static int
1893 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1894                        int ranks_must_agree, int is_elemental, locus *where)
1895 {
1896   gfc_actual_arglist **new_arg, *a, *actual, temp;
1897   gfc_formal_arglist *f;
1898   int i, n, na;
1899   unsigned long actual_size, formal_size;
1900
1901   actual = *ap;
1902
1903   if (actual == NULL && formal == NULL)
1904     return 1;
1905
1906   n = 0;
1907   for (f = formal; f; f = f->next)
1908     n++;
1909
1910   new_arg = XALLOCAVEC (gfc_actual_arglist *, n);
1911
1912   for (i = 0; i < n; i++)
1913     new_arg[i] = NULL;
1914
1915   na = 0;
1916   f = formal;
1917   i = 0;
1918
1919   for (a = actual; a; a = a->next, f = f->next)
1920     {
1921       /* Look for keywords but ignore g77 extensions like %VAL.  */
1922       if (a->name != NULL && a->name[0] != '%')
1923         {
1924           i = 0;
1925           for (f = formal; f; f = f->next, i++)
1926             {
1927               if (f->sym == NULL)
1928                 continue;
1929               if (strcmp (f->sym->name, a->name) == 0)
1930                 break;
1931             }
1932
1933           if (f == NULL)
1934             {
1935               if (where)
1936                 gfc_error ("Keyword argument '%s' at %L is not in "
1937                            "the procedure", a->name, &a->expr->where);
1938               return 0;
1939             }
1940
1941           if (new_arg[i] != NULL)
1942             {
1943               if (where)
1944                 gfc_error ("Keyword argument '%s' at %L is already associated "
1945                            "with another actual argument", a->name,
1946                            &a->expr->where);
1947               return 0;
1948             }
1949         }
1950
1951       if (f == NULL)
1952         {
1953           if (where)
1954             gfc_error ("More actual than formal arguments in procedure "
1955                        "call at %L", where);
1956
1957           return 0;
1958         }
1959
1960       if (f->sym == NULL && a->expr == NULL)
1961         goto match;
1962
1963       if (f->sym == NULL)
1964         {
1965           if (where)
1966             gfc_error ("Missing alternate return spec in subroutine call "
1967                        "at %L", where);
1968           return 0;
1969         }
1970
1971       if (a->expr == NULL)
1972         {
1973           if (where)
1974             gfc_error ("Unexpected alternate return spec in subroutine "
1975                        "call at %L", where);
1976           return 0;
1977         }
1978
1979       if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
1980           && (f->sym->attr.allocatable || !f->sym->attr.optional
1981               || (gfc_option.allow_std & GFC_STD_F2008) == 0))
1982         {
1983           if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
1984             gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
1985                        where, f->sym->name);
1986           else if (where)
1987             gfc_error ("Fortran 2008: Null pointer at %L to non-pointer "
1988                        "dummy '%s'", where, f->sym->name);
1989
1990           return 0;
1991         }
1992       
1993       if (!compare_parameter (f->sym, a->expr, ranks_must_agree,
1994                               is_elemental, where))
1995         return 0;
1996
1997       /* Special case for character arguments.  For allocatable, pointer
1998          and assumed-shape dummies, the string length needs to match
1999          exactly.  */
2000       if (a->expr->ts.type == BT_CHARACTER
2001            && a->expr->ts.u.cl && a->expr->ts.u.cl->length
2002            && a->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT
2003            && f->sym->ts.u.cl && f->sym->ts.u.cl && f->sym->ts.u.cl->length
2004            && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2005            && (f->sym->attr.pointer || f->sym->attr.allocatable
2006                || (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2007            && (mpz_cmp (a->expr->ts.u.cl->length->value.integer,
2008                         f->sym->ts.u.cl->length->value.integer) != 0))
2009          {
2010            if (where && (f->sym->attr.pointer || f->sym->attr.allocatable))
2011              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2012                           "argument and pointer or allocatable dummy argument "
2013                           "'%s' at %L",
2014                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2015                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2016                           f->sym->name, &a->expr->where);
2017            else if (where)
2018              gfc_warning ("Character length mismatch (%ld/%ld) between actual "
2019                           "argument and assumed-shape dummy argument '%s' "
2020                           "at %L",
2021                           mpz_get_si (a->expr->ts.u.cl->length->value.integer),
2022                           mpz_get_si (f->sym->ts.u.cl->length->value.integer),
2023                           f->sym->name, &a->expr->where);
2024            return 0;
2025          }
2026
2027       actual_size = get_expr_storage_size (a->expr);
2028       formal_size = get_sym_storage_size (f->sym);
2029       if (actual_size != 0
2030             && actual_size < formal_size
2031             && a->expr->ts.type != BT_PROCEDURE)
2032         {
2033           if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
2034             gfc_warning ("Character length of actual argument shorter "
2035                         "than of dummy argument '%s' (%lu/%lu) at %L",
2036                         f->sym->name, actual_size, formal_size,
2037                         &a->expr->where);
2038           else if (where)
2039             gfc_warning ("Actual argument contains too few "
2040                         "elements for dummy argument '%s' (%lu/%lu) at %L",
2041                         f->sym->name, actual_size, formal_size,
2042                         &a->expr->where);
2043           return  0;
2044         }
2045
2046       /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument
2047          is provided for a procedure pointer formal argument.  */
2048       if (f->sym->attr.proc_pointer
2049           && !((a->expr->expr_type == EXPR_VARIABLE
2050                 && a->expr->symtree->n.sym->attr.proc_pointer)
2051                || (a->expr->expr_type == EXPR_FUNCTION
2052                    && a->expr->symtree->n.sym->result->attr.proc_pointer)
2053                || gfc_is_proc_ptr_comp (a->expr, NULL)))
2054         {
2055           if (where)
2056             gfc_error ("Expected a procedure pointer for argument '%s' at %L",
2057                        f->sym->name, &a->expr->where);
2058           return 0;
2059         }
2060
2061       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
2062          provided for a procedure formal argument.  */
2063       if (a->expr->ts.type != BT_PROCEDURE && !gfc_is_proc_ptr_comp (a->expr, NULL)
2064           && a->expr->expr_type == EXPR_VARIABLE
2065           && f->sym->attr.flavor == FL_PROCEDURE)
2066         {
2067           if (where)
2068             gfc_error ("Expected a procedure for argument '%s' at %L",
2069                        f->sym->name, &a->expr->where);
2070           return 0;
2071         }
2072
2073       if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
2074           && a->expr->ts.type == BT_PROCEDURE
2075           && !a->expr->symtree->n.sym->attr.pure)
2076         {
2077           if (where)
2078             gfc_error ("Expected a PURE procedure for argument '%s' at %L",
2079                        f->sym->name, &a->expr->where);
2080           return 0;
2081         }
2082
2083       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
2084           && a->expr->expr_type == EXPR_VARIABLE
2085           && a->expr->symtree->n.sym->as
2086           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
2087           && (a->expr->ref == NULL
2088               || (a->expr->ref->type == REF_ARRAY
2089                   && a->expr->ref->u.ar.type == AR_FULL)))
2090         {
2091           if (where)
2092             gfc_error ("Actual argument for '%s' cannot be an assumed-size"
2093                        " array at %L", f->sym->name, where);
2094           return 0;
2095         }
2096
2097       if (a->expr->expr_type != EXPR_NULL
2098           && compare_pointer (f->sym, a->expr) == 0)
2099         {
2100           if (where)
2101             gfc_error ("Actual argument for '%s' must be a pointer at %L",
2102                        f->sym->name, &a->expr->where);
2103           return 0;
2104         }
2105
2106       if (a->expr->expr_type != EXPR_NULL
2107           && (gfc_option.allow_std & GFC_STD_F2008) == 0
2108           && compare_pointer (f->sym, a->expr) == 2)
2109         {
2110           if (where)
2111             gfc_error ("Fortran 2008: Non-pointer actual argument at %L to "
2112                        "pointer dummy '%s'", &a->expr->where,f->sym->name);
2113           return 0;
2114         }
2115         
2116
2117       /* Fortran 2008, C1242.  */
2118       if (f->sym->attr.pointer && gfc_is_coindexed (a->expr))
2119         {
2120           if (where)
2121             gfc_error ("Coindexed actual argument at %L to pointer "
2122                        "dummy '%s'",
2123                        &a->expr->where, f->sym->name);
2124           return 0;
2125         }
2126
2127       /* Fortran 2008, 12.5.2.5 (no constraint).  */
2128       if (a->expr->expr_type == EXPR_VARIABLE
2129           && f->sym->attr.intent != INTENT_IN
2130           && f->sym->attr.allocatable
2131           && gfc_is_coindexed (a->expr))
2132         {
2133           if (where)
2134             gfc_error ("Coindexed actual argument at %L to allocatable "
2135                        "dummy '%s' requires INTENT(IN)",
2136                        &a->expr->where, f->sym->name);
2137           return 0;
2138         }
2139
2140       /* Fortran 2008, C1237.  */
2141       if (a->expr->expr_type == EXPR_VARIABLE
2142           && (f->sym->attr.asynchronous || f->sym->attr.volatile_)
2143           && gfc_is_coindexed (a->expr)
2144           && (a->expr->symtree->n.sym->attr.volatile_
2145               || a->expr->symtree->n.sym->attr.asynchronous))
2146         {
2147           if (where)
2148             gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at "
2149                        "at %L requires that dummy %s' has neither "
2150                        "ASYNCHRONOUS nor VOLATILE", &a->expr->where,
2151                        f->sym->name);
2152           return 0;
2153         }
2154
2155       /* Fortran 2008, 12.5.2.4 (no constraint).  */
2156       if (a->expr->expr_type == EXPR_VARIABLE
2157           && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value
2158           && gfc_is_coindexed (a->expr)
2159           && gfc_has_ultimate_allocatable (a->expr))
2160         {
2161           if (where)
2162             gfc_error ("Coindexed actual argument at %L with allocatable "
2163                        "ultimate component to dummy '%s' requires either VALUE "
2164                        "or INTENT(IN)", &a->expr->where, f->sym->name);
2165           return 0;
2166         }
2167
2168       if (a->expr->expr_type != EXPR_NULL
2169           && compare_allocatable (f->sym, a->expr) == 0)
2170         {
2171           if (where)
2172             gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
2173                        f->sym->name, &a->expr->where);
2174           return 0;
2175         }
2176
2177       /* Check intent = OUT/INOUT for definable actual argument.  */
2178       if ((f->sym->attr.intent == INTENT_OUT
2179           || f->sym->attr.intent == INTENT_INOUT))
2180         {
2181           const char* context = (where
2182                                  ? _("actual argument to INTENT = OUT/INOUT")
2183                                  : NULL);
2184
2185           if (f->sym->attr.pointer
2186               && gfc_check_vardef_context (a->expr, true, context)
2187                    == FAILURE)
2188             return 0;
2189           if (gfc_check_vardef_context (a->expr, false, context)
2190                 == FAILURE)
2191             return 0;
2192         }
2193
2194       if ((f->sym->attr.intent == INTENT_OUT
2195            || f->sym->attr.intent == INTENT_INOUT
2196            || f->sym->attr.volatile_
2197            || f->sym->attr.asynchronous)
2198           && gfc_has_vector_subscript (a->expr))
2199         {
2200           if (where)
2201             gfc_error ("Array-section actual argument with vector "
2202                        "subscripts at %L is incompatible with INTENT(OUT), "
2203                        "INTENT(INOUT), VOLATILE or ASYNCHRONOUS attribute "
2204                        "of the dummy argument '%s'",
2205                        &a->expr->where, f->sym->name);
2206           return 0;
2207         }
2208
2209       /* C1232 (R1221) For an actual argument which is an array section or
2210          an assumed-shape array, the dummy argument shall be an assumed-
2211          shape array, if the dummy argument has the VOLATILE attribute.  */
2212
2213       if (f->sym->attr.volatile_
2214           && a->expr->symtree->n.sym->as
2215           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
2216           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2217         {
2218           if (where)
2219             gfc_error ("Assumed-shape actual argument at %L is "
2220                        "incompatible with the non-assumed-shape "
2221                        "dummy argument '%s' due to VOLATILE attribute",
2222                        &a->expr->where,f->sym->name);
2223           return 0;
2224         }
2225
2226       if (f->sym->attr.volatile_
2227           && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
2228           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
2229         {
2230           if (where)
2231             gfc_error ("Array-section actual argument at %L is "
2232                        "incompatible with the non-assumed-shape "
2233                        "dummy argument '%s' due to VOLATILE attribute",
2234                        &a->expr->where,f->sym->name);
2235           return 0;
2236         }
2237
2238       /* C1233 (R1221) For an actual argument which is a pointer array, the
2239          dummy argument shall be an assumed-shape or pointer array, if the
2240          dummy argument has the VOLATILE attribute.  */
2241
2242       if (f->sym->attr.volatile_
2243           && a->expr->symtree->n.sym->attr.pointer
2244           && a->expr->symtree->n.sym->as
2245           && !(f->sym->as
2246                && (f->sym->as->type == AS_ASSUMED_SHAPE
2247                    || f->sym->attr.pointer)))
2248         {
2249           if (where)
2250             gfc_error ("Pointer-array actual argument at %L requires "
2251                        "an assumed-shape or pointer-array dummy "
2252                        "argument '%s' due to VOLATILE attribute",
2253                        &a->expr->where,f->sym->name);
2254           return 0;
2255         }
2256
2257     match:
2258       if (a == actual)
2259         na = i;
2260
2261       new_arg[i++] = a;
2262     }
2263
2264   /* Make sure missing actual arguments are optional.  */
2265   i = 0;
2266   for (f = formal; f; f = f->next, i++)
2267     {
2268       if (new_arg[i] != NULL)
2269         continue;
2270       if (f->sym == NULL)
2271         {
2272           if (where)
2273             gfc_error ("Missing alternate return spec in subroutine call "
2274                        "at %L", where);
2275           return 0;
2276         }
2277       if (!f->sym->attr.optional)
2278         {
2279           if (where)
2280             gfc_error ("Missing actual argument for argument '%s' at %L",
2281                        f->sym->name, where);
2282           return 0;
2283         }
2284     }
2285
2286   /* The argument lists are compatible.  We now relink a new actual
2287      argument list with null arguments in the right places.  The head
2288      of the list remains the head.  */
2289   for (i = 0; i < n; i++)
2290     if (new_arg[i] == NULL)
2291       new_arg[i] = gfc_get_actual_arglist ();
2292
2293   if (na != 0)
2294     {
2295       temp = *new_arg[0];
2296       *new_arg[0] = *actual;
2297       *actual = temp;
2298
2299       a = new_arg[0];
2300       new_arg[0] = new_arg[na];
2301       new_arg[na] = a;
2302     }
2303
2304   for (i = 0; i < n - 1; i++)
2305     new_arg[i]->next = new_arg[i + 1];
2306
2307   new_arg[i]->next = NULL;
2308
2309   if (*ap == NULL && n > 0)
2310     *ap = new_arg[0];
2311
2312   /* Note the types of omitted optional arguments.  */
2313   for (a = *ap, f = formal; a; a = a->next, f = f->next)
2314     if (a->expr == NULL && a->label == NULL)
2315       a->missing_arg_type = f->sym->ts.type;
2316
2317   return 1;
2318 }
2319
2320
2321 typedef struct
2322 {
2323   gfc_formal_arglist *f;
2324   gfc_actual_arglist *a;
2325 }
2326 argpair;
2327
2328 /* qsort comparison function for argument pairs, with the following
2329    order:
2330     - p->a->expr == NULL
2331     - p->a->expr->expr_type != EXPR_VARIABLE
2332     - growing p->a->expr->symbol.  */
2333
2334 static int
2335 pair_cmp (const void *p1, const void *p2)
2336 {
2337   const gfc_actual_arglist *a1, *a2;
2338
2339   /* *p1 and *p2 are elements of the to-be-sorted array.  */
2340   a1 = ((const argpair *) p1)->a;
2341   a2 = ((const argpair *) p2)->a;
2342   if (!a1->expr)
2343     {
2344       if (!a2->expr)
2345         return 0;
2346       return -1;
2347     }
2348   if (!a2->expr)
2349     return 1;
2350   if (a1->expr->expr_type != EXPR_VARIABLE)
2351     {
2352       if (a2->expr->expr_type != EXPR_VARIABLE)
2353         return 0;
2354       return -1;
2355     }
2356   if (a2->expr->expr_type != EXPR_VARIABLE)
2357     return 1;
2358   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
2359 }
2360
2361
2362 /* Given two expressions from some actual arguments, test whether they
2363    refer to the same expression. The analysis is conservative.
2364    Returning FAILURE will produce no warning.  */
2365
2366 static gfc_try
2367 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
2368 {
2369   const gfc_ref *r1, *r2;
2370
2371   if (!e1 || !e2
2372       || e1->expr_type != EXPR_VARIABLE
2373       || e2->expr_type != EXPR_VARIABLE
2374       || e1->symtree->n.sym != e2->symtree->n.sym)
2375     return FAILURE;
2376
2377   /* TODO: improve comparison, see expr.c:show_ref().  */
2378   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
2379     {
2380       if (r1->type != r2->type)
2381         return FAILURE;
2382       switch (r1->type)
2383         {
2384         case REF_ARRAY:
2385           if (r1->u.ar.type != r2->u.ar.type)
2386             return FAILURE;
2387           /* TODO: At the moment, consider only full arrays;
2388              we could do better.  */
2389           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
2390             return FAILURE;
2391           break;
2392
2393         case REF_COMPONENT:
2394           if (r1->u.c.component != r2->u.c.component)
2395             return FAILURE;
2396           break;
2397
2398         case REF_SUBSTRING:
2399           return FAILURE;
2400
2401         default:
2402           gfc_internal_error ("compare_actual_expr(): Bad component code");
2403         }
2404     }
2405   if (!r1 && !r2)
2406     return SUCCESS;
2407   return FAILURE;
2408 }
2409
2410
2411 /* Given formal and actual argument lists that correspond to one
2412    another, check that identical actual arguments aren't not
2413    associated with some incompatible INTENTs.  */
2414
2415 static gfc_try
2416 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
2417 {
2418   sym_intent f1_intent, f2_intent;
2419   gfc_formal_arglist *f1;
2420   gfc_actual_arglist *a1;
2421   size_t n, i, j;
2422   argpair *p;
2423   gfc_try t = SUCCESS;
2424
2425   n = 0;
2426   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2427     {
2428       if (f1 == NULL && a1 == NULL)
2429         break;
2430       if (f1 == NULL || a1 == NULL)
2431         gfc_internal_error ("check_some_aliasing(): List mismatch");
2432       n++;
2433     }
2434   if (n == 0)
2435     return t;
2436   p = XALLOCAVEC (argpair, n);
2437
2438   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2439     {
2440       p[i].f = f1;
2441       p[i].a = a1;
2442     }
2443
2444   qsort (p, n, sizeof (argpair), pair_cmp);
2445
2446   for (i = 0; i < n; i++)
2447     {
2448       if (!p[i].a->expr
2449           || p[i].a->expr->expr_type != EXPR_VARIABLE
2450           || p[i].a->expr->ts.type == BT_PROCEDURE)
2451         continue;
2452       f1_intent = p[i].f->sym->attr.intent;
2453       for (j = i + 1; j < n; j++)
2454         {
2455           /* Expected order after the sort.  */
2456           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2457             gfc_internal_error ("check_some_aliasing(): corrupted data");
2458
2459           /* Are the expression the same?  */
2460           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2461             break;
2462           f2_intent = p[j].f->sym->attr.intent;
2463           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2464               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2465             {
2466               gfc_warning ("Same actual argument associated with INTENT(%s) "
2467                            "argument '%s' and INTENT(%s) argument '%s' at %L",
2468                            gfc_intent_string (f1_intent), p[i].f->sym->name,
2469                            gfc_intent_string (f2_intent), p[j].f->sym->name,
2470                            &p[i].a->expr->where);
2471               t = FAILURE;
2472             }
2473         }
2474     }
2475
2476   return t;
2477 }
2478
2479
2480 /* Given a symbol of a formal argument list and an expression,
2481    return nonzero if their intents are compatible, zero otherwise.  */
2482
2483 static int
2484 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2485 {
2486   if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2487     return 1;
2488
2489   if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2490     return 1;
2491
2492   if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2493     return 0;
2494
2495   return 1;
2496 }
2497
2498
2499 /* Given formal and actual argument lists that correspond to one
2500    another, check that they are compatible in the sense that intents
2501    are not mismatched.  */
2502
2503 static gfc_try
2504 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2505 {
2506   sym_intent f_intent;
2507
2508   for (;; f = f->next, a = a->next)
2509     {
2510       if (f == NULL && a == NULL)
2511         break;
2512       if (f == NULL || a == NULL)
2513         gfc_internal_error ("check_intents(): List mismatch");
2514
2515       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2516         continue;
2517
2518       f_intent = f->sym->attr.intent;
2519
2520       if (!compare_parameter_intent(f->sym, a->expr))
2521         {
2522           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2523                      "specifies INTENT(%s)", &a->expr->where,
2524                      gfc_intent_string (f_intent));
2525           return FAILURE;
2526         }
2527
2528       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2529         {
2530           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2531             {
2532               gfc_error ("Procedure argument at %L is local to a PURE "
2533                          "procedure and is passed to an INTENT(%s) argument",
2534                          &a->expr->where, gfc_intent_string (f_intent));
2535               return FAILURE;
2536             }
2537
2538           if (f->sym->attr.pointer)
2539             {
2540               gfc_error ("Procedure argument at %L is local to a PURE "
2541                          "procedure and has the POINTER attribute",
2542                          &a->expr->where);
2543               return FAILURE;
2544             }
2545         }
2546
2547        /* Fortran 2008, C1283.  */
2548        if (gfc_pure (NULL) && gfc_is_coindexed (a->expr))
2549         {
2550           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2551             {
2552               gfc_error ("Coindexed actual argument at %L in PURE procedure "
2553                          "is passed to an INTENT(%s) argument",
2554                          &a->expr->where, gfc_intent_string (f_intent));
2555               return FAILURE;
2556             }
2557
2558           if (f->sym->attr.pointer)
2559             {
2560               gfc_error ("Coindexed actual argument at %L in PURE procedure "
2561                          "is passed to a POINTER dummy argument",
2562                          &a->expr->where);
2563               return FAILURE;
2564             }
2565         }
2566
2567        /* F2008, Section 12.5.2.4.  */
2568        if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS
2569            && gfc_is_coindexed (a->expr))
2570          {
2571            gfc_error ("Coindexed polymorphic actual argument at %L is passed "
2572                       "polymorphic dummy argument '%s'",
2573                          &a->expr->where, f->sym->name);
2574            return FAILURE;
2575          }
2576     }
2577
2578   return SUCCESS;
2579 }
2580
2581
2582 /* Check how a procedure is used against its interface.  If all goes
2583    well, the actual argument list will also end up being properly
2584    sorted.  */
2585
2586 void
2587 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2588 {
2589
2590   /* Warn about calls with an implicit interface.  Special case
2591      for calling a ISO_C_BINDING becase c_loc and c_funloc
2592      are pseudo-unknown.  Additionally, warn about procedures not
2593      explicitly declared at all if requested.  */
2594   if (sym->attr.if_source == IFSRC_UNKNOWN && ! sym->attr.is_iso_c)
2595     {
2596       if (gfc_option.warn_implicit_interface)
2597         gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2598                      sym->name, where);
2599       else if (gfc_option.warn_implicit_procedure
2600                && sym->attr.proc == PROC_UNKNOWN)
2601         gfc_warning ("Procedure '%s' called at %L is not explicitly declared",
2602                      sym->name, where);
2603     }
2604
2605   if (sym->attr.if_source == IFSRC_UNKNOWN)
2606     {
2607       gfc_actual_arglist *a;
2608       for (a = *ap; a; a = a->next)
2609         {
2610           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
2611           if (a->name != NULL && a->name[0] != '%')
2612             {
2613               gfc_error("Keyword argument requires explicit interface "
2614                         "for procedure '%s' at %L", sym->name, &a->expr->where);
2615               break;
2616             }
2617         }
2618
2619       return;
2620     }
2621
2622   if (!compare_actual_formal (ap, sym->formal, 0, sym->attr.elemental, where))
2623     return;
2624
2625   check_intents (sym->formal, *ap);
2626   if (gfc_option.warn_aliasing)
2627     check_some_aliasing (sym->formal, *ap);
2628 }
2629
2630
2631 /* Check how a procedure pointer component is used against its interface.
2632    If all goes well, the actual argument list will also end up being properly
2633    sorted. Completely analogous to gfc_procedure_use.  */
2634
2635 void
2636 gfc_ppc_use (gfc_component *comp, gfc_actual_arglist **ap, locus *where)
2637 {
2638
2639   /* Warn about calls with an implicit interface.  Special case
2640      for calling a ISO_C_BINDING becase c_loc and c_funloc
2641      are pseudo-unknown.  */
2642   if (gfc_option.warn_implicit_interface
2643       && comp->attr.if_source == IFSRC_UNKNOWN
2644       && !comp->attr.is_iso_c)
2645     gfc_warning ("Procedure pointer component '%s' called with an implicit "
2646                  "interface at %L", comp->name, where);
2647
2648   if (comp->attr.if_source == IFSRC_UNKNOWN)
2649     {
2650       gfc_actual_arglist *a;
2651       for (a = *ap; a; a = a->next)
2652         {
2653           /* Skip g77 keyword extensions like %VAL, %REF, %LOC.  */
2654           if (a->name != NULL && a->name[0] != '%')
2655             {
2656               gfc_error("Keyword argument requires explicit interface "
2657                         "for procedure pointer component '%s' at %L",
2658                         comp->name, &a->expr->where);
2659               break;
2660             }
2661         }
2662
2663       return;
2664     }
2665
2666   if (!compare_actual_formal (ap, comp->formal, 0, comp->attr.elemental, where))
2667     return;
2668
2669   check_intents (comp->formal, *ap);
2670   if (gfc_option.warn_aliasing)
2671     check_some_aliasing (comp->formal, *ap);
2672 }
2673
2674
2675 /* Try if an actual argument list matches the formal list of a symbol,
2676    respecting the symbol's attributes like ELEMENTAL.  This is used for
2677    GENERIC resolution.  */
2678
2679 bool
2680 gfc_arglist_matches_symbol (gfc_actual_arglist** args, gfc_symbol* sym)
2681 {
2682   bool r;
2683
2684   gcc_assert (sym->attr.flavor == FL_PROCEDURE);
2685
2686   r = !sym->attr.elemental;
2687   if (compare_actual_formal (args, sym->formal, r, !r, NULL))
2688     {
2689       check_intents (sym->formal, *args);
2690       if (gfc_option.warn_aliasing)
2691         check_some_aliasing (sym->formal, *args);
2692       return true;
2693     }
2694
2695   return false;
2696 }
2697
2698
2699 /* Given an interface pointer and an actual argument list, search for
2700    a formal argument list that matches the actual.  If found, returns
2701    a pointer to the symbol of the correct interface.  Returns NULL if
2702    not found.  */
2703
2704 gfc_symbol *
2705 gfc_search_interface (gfc_interface *intr, int sub_flag,
2706                       gfc_actual_arglist **ap)
2707 {
2708   gfc_symbol *elem_sym = NULL;
2709   for (; intr; intr = intr->next)
2710     {
2711       if (sub_flag && intr->sym->attr.function)
2712         continue;
2713       if (!sub_flag && intr->sym->attr.subroutine)
2714         continue;
2715
2716       if (gfc_arglist_matches_symbol (ap, intr->sym))
2717         {
2718           /* Satisfy 12.4.4.1 such that an elemental match has lower
2719              weight than a non-elemental match.  */ 
2720           if (intr->sym->attr.elemental)
2721             {
2722               elem_sym = intr->sym;
2723               continue;
2724             }
2725           return intr->sym;
2726         }
2727     }
2728
2729   return elem_sym ? elem_sym : NULL;
2730 }
2731
2732
2733 /* Do a brute force recursive search for a symbol.  */
2734
2735 static gfc_symtree *
2736 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2737 {
2738   gfc_symtree * st;
2739
2740   if (root->n.sym == sym)
2741     return root;
2742
2743   st = NULL;
2744   if (root->left)
2745     st = find_symtree0 (root->left, sym);
2746   if (root->right && ! st)
2747     st = find_symtree0 (root->right, sym);
2748   return st;
2749 }
2750
2751
2752 /* Find a symtree for a symbol.  */
2753
2754 gfc_symtree *
2755 gfc_find_sym_in_symtree (gfc_symbol *sym)
2756 {
2757   gfc_symtree *st;
2758   gfc_namespace *ns;
2759
2760   /* First try to find it by name.  */
2761   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2762   if (st && st->n.sym == sym)
2763     return st;
2764
2765   /* If it's been renamed, resort to a brute-force search.  */
2766   /* TODO: avoid having to do this search.  If the symbol doesn't exist
2767      in the symtree for the current namespace, it should probably be added.  */
2768   for (ns = gfc_current_ns; ns; ns = ns->parent)
2769     {
2770       st = find_symtree0 (ns->sym_root, sym);
2771       if (st)
2772         return st;
2773     }
2774   gfc_internal_error ("Unable to find symbol %s", sym->name);
2775   /* Not reached.  */
2776 }
2777
2778
2779 /* See if the arglist to an operator-call contains a derived-type argument
2780    with a matching type-bound operator.  If so, return the matching specific
2781    procedure defined as operator-target as well as the base-object to use
2782    (which is the found derived-type argument with operator).  The generic
2783    name, if any, is transmitted to the final expression via 'gname'.  */
2784
2785 static gfc_typebound_proc*
2786 matching_typebound_op (gfc_expr** tb_base,
2787                        gfc_actual_arglist* args,
2788                        gfc_intrinsic_op op, const char* uop,
2789                        const char ** gname)
2790 {
2791   gfc_actual_arglist* base;
2792
2793   for (base = args; base; base = base->next)
2794     if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
2795       {
2796         gfc_typebound_proc* tb;
2797         gfc_symbol* derived;
2798         gfc_try result;
2799
2800         if (base->expr->ts.type == BT_CLASS)
2801           derived = CLASS_DATA (base->expr)->ts.u.derived;
2802         else
2803           derived = base->expr->ts.u.derived;
2804
2805         if (op == INTRINSIC_USER)
2806           {
2807             gfc_symtree* tb_uop;
2808
2809             gcc_assert (uop);
2810             tb_uop = gfc_find_typebound_user_op (derived, &result, uop,
2811                                                  false, NULL);
2812
2813             if (tb_uop)
2814               tb = tb_uop->n.tb;
2815             else
2816               tb = NULL;
2817           }
2818         else
2819           tb = gfc_find_typebound_intrinsic_op (derived, &result, op,
2820                                                 false, NULL);
2821
2822         /* This means we hit a PRIVATE operator which is use-associated and
2823            should thus not be seen.  */
2824         if (result == FAILURE)
2825           tb = NULL;
2826
2827         /* Look through the super-type hierarchy for a matching specific
2828            binding.  */
2829         for (; tb; tb = tb->overridden)
2830           {
2831             gfc_tbp_generic* g;
2832
2833             gcc_assert (tb->is_generic);
2834             for (g = tb->u.generic; g; g = g->next)
2835               {
2836                 gfc_symbol* target;
2837                 gfc_actual_arglist* argcopy;
2838                 bool matches;
2839
2840                 gcc_assert (g->specific);
2841                 if (g->specific->error)
2842                   continue;
2843
2844                 target = g->specific->u.specific->n.sym;
2845
2846                 /* Check if this arglist matches the formal.  */
2847                 argcopy = gfc_copy_actual_arglist (args);
2848                 matches = gfc_arglist_matches_symbol (&argcopy, target);
2849                 gfc_free_actual_arglist (argcopy);
2850
2851                 /* Return if we found a match.  */
2852                 if (matches)
2853                   {
2854                     *tb_base = base->expr;
2855                     *gname = g->specific_st->name;
2856                     return g->specific;
2857                   }
2858               }
2859           }
2860       }
2861
2862   return NULL;
2863 }
2864
2865
2866 /* For the 'actual arglist' of an operator call and a specific typebound
2867    procedure that has been found the target of a type-bound operator, build the
2868    appropriate EXPR_COMPCALL and resolve it.  We take this indirection over
2869    type-bound procedures rather than resolving type-bound operators 'directly'
2870    so that we can reuse the existing logic.  */
2871
2872 static void
2873 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
2874                              gfc_expr* base, gfc_typebound_proc* target,
2875                              const char *gname)
2876 {
2877   e->expr_type = EXPR_COMPCALL;
2878   e->value.compcall.tbp = target;
2879   e->value.compcall.name = gname ? gname : "$op";
2880   e->value.compcall.actual = actual;
2881   e->value.compcall.base_object = base;
2882   e->value.compcall.ignore_pass = 1;
2883   e->value.compcall.assign = 0;
2884 }
2885
2886
2887 /* This subroutine is called when an expression is being resolved.
2888    The expression node in question is either a user defined operator
2889    or an intrinsic operator with arguments that aren't compatible
2890    with the operator.  This subroutine builds an actual argument list
2891    corresponding to the operands, then searches for a compatible
2892    interface.  If one is found, the expression node is replaced with
2893    the appropriate function call.
2894    real_error is an additional output argument that specifies if FAILURE
2895    is because of some real error and not because no match was found.  */
2896
2897 gfc_try
2898 gfc_extend_expr (gfc_expr *e, bool *real_error)
2899 {
2900   gfc_actual_arglist *actual;
2901   gfc_symbol *sym;
2902   gfc_namespace *ns;
2903   gfc_user_op *uop;
2904   gfc_intrinsic_op i;
2905   const char *gname;
2906
2907   sym = NULL;
2908
2909   actual = gfc_get_actual_arglist ();
2910   actual->expr = e->value.op.op1;
2911
2912   *real_error = false;
2913   gname = NULL;
2914
2915   if (e->value.op.op2 != NULL)
2916     {
2917       actual->next = gfc_get_actual_arglist ();
2918       actual->next->expr = e->value.op.op2;
2919     }
2920
2921   i = fold_unary_intrinsic (e->value.op.op);
2922
2923   if (i == INTRINSIC_USER)
2924     {
2925       for (ns = gfc_current_ns; ns; ns = ns->parent)
2926         {
2927           uop = gfc_find_uop (e->value.op.uop->name, ns);
2928           if (uop == NULL)
2929             continue;
2930
2931           sym = gfc_search_interface (uop->op, 0, &actual);
2932           if (sym != NULL)
2933             break;
2934         }
2935     }
2936   else
2937     {
2938       for (ns = gfc_current_ns; ns; ns = ns->parent)
2939         {
2940           /* Due to the distinction between '==' and '.eq.' and friends, one has
2941              to check if either is defined.  */
2942           switch (i)
2943             {
2944 #define CHECK_OS_COMPARISON(comp) \
2945   case INTRINSIC_##comp: \
2946   case INTRINSIC_##comp##_OS: \
2947     sym = gfc_search_interface (ns->op[INTRINSIC_##comp], 0, &actual); \
2948     if (!sym) \
2949       sym = gfc_search_interface (ns->op[INTRINSIC_##comp##_OS], 0, &actual); \
2950     break;
2951               CHECK_OS_COMPARISON(EQ)
2952               CHECK_OS_COMPARISON(NE)
2953               CHECK_OS_COMPARISON(GT)
2954               CHECK_OS_COMPARISON(GE)
2955               CHECK_OS_COMPARISON(LT)
2956               CHECK_OS_COMPARISON(LE)
2957 #undef CHECK_OS_COMPARISON
2958
2959               default:
2960                 sym = gfc_search_interface (ns->op[i], 0, &actual);
2961             }
2962
2963           if (sym != NULL)
2964             break;
2965         }
2966     }
2967
2968   /* TODO: Do an ambiguity-check and error if multiple matching interfaces are
2969      found rather than just taking the first one and not checking further.  */
2970
2971   if (sym == NULL)
2972     {
2973       gfc_typebound_proc* tbo;
2974       gfc_expr* tb_base;
2975
2976       /* See if we find a matching type-bound operator.  */
2977       if (i == INTRINSIC_USER)
2978         tbo = matching_typebound_op (&tb_base, actual,
2979                                      i, e->value.op.uop->name, &gname);
2980       else
2981         switch (i)
2982           {
2983 #define CHECK_OS_COMPARISON(comp) \
2984   case INTRINSIC_##comp: \
2985   case INTRINSIC_##comp##_OS: \
2986     tbo = matching_typebound_op (&tb_base, actual, \
2987                                  INTRINSIC_##comp, NULL, &gname); \
2988     if (!tbo) \
2989       tbo = matching_typebound_op (&tb_base, actual, \
2990                                    INTRINSIC_##comp##_OS, NULL, &gname); \
2991     break;
2992             CHECK_OS_COMPARISON(EQ)
2993             CHECK_OS_COMPARISON(NE)
2994             CHECK_OS_COMPARISON(GT)
2995             CHECK_OS_COMPARISON(GE)
2996             CHECK_OS_COMPARISON(LT)
2997             CHECK_OS_COMPARISON(LE)
2998 #undef CHECK_OS_COMPARISON
2999
3000             default:
3001               tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
3002               break;
3003           }
3004               
3005       /* If there is a matching typebound-operator, replace the expression with
3006          a call to it and succeed.  */
3007       if (tbo)
3008         {
3009           gfc_try result;
3010
3011           gcc_assert (tb_base);
3012           build_compcall_for_operator (e, actual, tb_base, tbo, gname);
3013
3014           result = gfc_resolve_expr (e);
3015           if (result == FAILURE)
3016             *real_error = true;
3017
3018           return result;
3019         }
3020
3021       /* Don't use gfc_free_actual_arglist().  */
3022       if (actual->next != NULL)
3023         gfc_free (actual->next);
3024       gfc_free (actual);
3025
3026       return FAILURE;
3027     }
3028
3029   /* Change the expression node to a function call.  */
3030   e->expr_type = EXPR_FUNCTION;
3031   e->symtree = gfc_find_sym_in_symtree (sym);
3032   e->value.function.actual = actual;
3033   e->value.function.esym = NULL;
3034   e->value.function.isym = NULL;
3035   e->value.function.name = NULL;
3036   e->user_operator = 1;
3037
3038   if (gfc_resolve_expr (e) == FAILURE)
3039     {
3040       *real_error = true;
3041       return FAILURE;
3042     }
3043
3044   return SUCCESS;
3045 }
3046
3047
3048 /* Tries to replace an assignment code node with a subroutine call to
3049    the subroutine associated with the assignment operator.  Return
3050    SUCCESS if the node was replaced.  On FAILURE, no error is
3051    generated.  */
3052
3053 gfc_try
3054 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
3055 {
3056   gfc_actual_arglist *actual;
3057   gfc_expr *lhs, *rhs;
3058   gfc_symbol *sym;
3059   const char *gname;
3060
3061   gname = NULL;
3062
3063   lhs = c->expr1;
3064   rhs = c->expr2;
3065
3066   /* Don't allow an intrinsic assignment to be replaced.  */
3067   if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
3068       && (rhs->rank == 0 || rhs->rank == lhs->rank)
3069       && (lhs->ts.type == rhs->ts.type
3070           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
3071     return FAILURE;
3072
3073   actual = gfc_get_actual_arglist ();
3074   actual->expr = lhs;
3075
3076   actual->next = gfc_get_actual_arglist ();
3077   actual->next->expr = rhs;
3078
3079   sym = NULL;
3080
3081   for (; ns; ns = ns->parent)
3082     {
3083       sym = gfc_search_interface (ns->op[INTRINSIC_ASSIGN], 1, &actual);
3084       if (sym != NULL)
3085         break;
3086     }
3087
3088   /* TODO: Ambiguity-check, see above for gfc_extend_expr.  */
3089
3090   if (sym == NULL)
3091     {
3092       gfc_typebound_proc* tbo;
3093       gfc_expr* tb_base;
3094
3095       /* See if we find a matching type-bound assignment.  */
3096       tbo = matching_typebound_op (&tb_base, actual,
3097                                    INTRINSIC_ASSIGN, NULL, &gname);
3098               
3099       /* If there is one, replace the expression with a call to it and
3100          succeed.  */
3101       if (tbo)
3102         {
3103           gcc_assert (tb_base);
3104           c->expr1 = gfc_get_expr ();
3105           build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
3106           c->expr1->value.compcall.assign = 1;
3107           c->expr2 = NULL;
3108           c->op = EXEC_COMPCALL;
3109
3110           /* c is resolved from the caller, so no need to do it here.  */
3111
3112           return SUCCESS;
3113         }
3114
3115       gfc_free (actual->next);
3116       gfc_free (actual);
3117       return FAILURE;
3118     }
3119
3120   /* Replace the assignment with the call.  */
3121   c->op = EXEC_ASSIGN_CALL;
3122   c->symtree = gfc_find_sym_in_symtree (sym);
3123   c->expr1 = NULL;
3124   c->expr2 = NULL;
3125   c->ext.actual = actual;
3126
3127   return SUCCESS;
3128 }
3129
3130
3131 /* Make sure that the interface just parsed is not already present in
3132    the given interface list.  Ambiguity isn't checked yet since module
3133    procedures can be present without interfaces.  */
3134
3135 static gfc_try
3136 check_new_interface (gfc_interface *base, gfc_symbol *new_sym)
3137 {
3138   gfc_interface *ip;
3139
3140   for (ip = base; ip; ip = ip->next)
3141     {
3142       if (ip->sym == new_sym)
3143         {
3144           gfc_error ("Entity '%s' at %C is already present in the interface",
3145                      new_sym->name);
3146           return FAILURE;
3147         }
3148     }
3149
3150   return SUCCESS;
3151 }
3152
3153
3154 /* Add a symbol to the current interface.  */
3155
3156 gfc_try
3157 gfc_add_interface (gfc_symbol *new_sym)
3158 {
3159   gfc_interface **head, *intr;
3160   gfc_namespace *ns;
3161   gfc_symbol *sym;
3162
3163   switch (current_interface.type)
3164     {
3165     case INTERFACE_NAMELESS:
3166     case INTERFACE_ABSTRACT:
3167       return SUCCESS;
3168
3169     case INTERFACE_INTRINSIC_OP:
3170       for (ns = current_interface.ns; ns; ns = ns->parent)
3171         switch (current_interface.op)
3172           {
3173             case INTRINSIC_EQ:
3174             case INTRINSIC_EQ_OS:
3175               if (check_new_interface (ns->op[INTRINSIC_EQ], new_sym) == FAILURE ||
3176                   check_new_interface (ns->op[INTRINSIC_EQ_OS], new_sym) == FAILURE)
3177                 return FAILURE;
3178               break;
3179
3180             case INTRINSIC_NE:
3181             case INTRINSIC_NE_OS:
3182               if (check_new_interface (ns->op[INTRINSIC_NE], new_sym) == FAILURE ||
3183                   check_new_interface (ns->op[INTRINSIC_NE_OS], new_sym) == FAILURE)
3184                 return FAILURE;
3185               break;
3186
3187             case INTRINSIC_GT:
3188             case INTRINSIC_GT_OS:
3189               if (check_new_interface (ns->op[INTRINSIC_GT], new_sym) == FAILURE ||
3190                   check_new_interface (ns->op[INTRINSIC_GT_OS], new_sym) == FAILURE)
3191                 return FAILURE;
3192               break;
3193
3194             case INTRINSIC_GE:
3195             case INTRINSIC_GE_OS:
3196               if (check_new_interface (ns->op[INTRINSIC_GE], new_sym) == FAILURE ||
3197                   check_new_interface (ns->op[INTRINSIC_GE_OS], new_sym) == FAILURE)
3198                 return FAILURE;
3199               break;
3200
3201             case INTRINSIC_LT:
3202             case INTRINSIC_LT_OS:
3203               if (check_new_interface (ns->op[INTRINSIC_LT], new_sym) == FAILURE ||
3204                   check_new_interface (ns->op[INTRINSIC_LT_OS], new_sym) == FAILURE)
3205                 return FAILURE;
3206               break;
3207
3208             case INTRINSIC_LE:
3209             case INTRINSIC_LE_OS:
3210               if (check_new_interface (ns->op[INTRINSIC_LE], new_sym) == FAILURE ||
3211                   check_new_interface (ns->op[INTRINSIC_LE_OS], new_sym) == FAILURE)
3212                 return FAILURE;
3213               break;
3214
3215             default:
3216               if (check_new_interface (ns->op[current_interface.op], new_sym) == FAILURE)
3217                 return FAILURE;
3218           }
3219
3220       head = &current_interface.ns->op[current_interface.op];
3221       break;
3222
3223     case INTERFACE_GENERIC:
3224       for (ns = current_interface.ns; ns; ns = ns->parent)
3225         {
3226           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
3227           if (sym == NULL)
3228             continue;
3229
3230           if (check_new_interface (sym->generic, new_sym) == FAILURE)
3231             return FAILURE;
3232         }
3233
3234       head = &current_interface.sym->generic;
3235       break;
3236
3237     case INTERFACE_USER_OP:
3238       if (check_new_interface (current_interface.uop->op, new_sym)
3239           == FAILURE)
3240         return FAILURE;
3241
3242       head = &current_interface.uop->op;
3243       break;
3244
3245     default:
3246       gfc_internal_error ("gfc_add_interface(): Bad interface type");
3247     }
3248
3249   intr = gfc_get_interface ();
3250   intr->sym = new_sym;
3251   intr->where = gfc_current_locus;
3252
3253   intr->next = *head;
3254   *head = intr;
3255
3256   return SUCCESS;
3257 }
3258
3259
3260 gfc_interface *
3261 gfc_current_interface_head (void)
3262 {
3263   switch (current_interface.type)
3264     {
3265       case INTERFACE_INTRINSIC_OP:
3266         return current_interface.ns->op[current_interface.op];
3267         break;
3268
3269       case INTERFACE_GENERIC:
3270         return current_interface.sym->generic;
3271         break;
3272
3273       case INTERFACE_USER_OP:
3274         return current_interface.uop->op;
3275         break;
3276
3277       default:
3278         gcc_unreachable ();
3279     }
3280 }
3281
3282
3283 void
3284 gfc_set_current_interface_head (gfc_interface *i)
3285 {
3286   switch (current_interface.type)
3287     {
3288       case INTERFACE_INTRINSIC_OP:
3289         current_interface.ns->op[current_interface.op] = i;
3290         break;
3291
3292       case INTERFACE_GENERIC:
3293         current_interface.sym->generic = i;
3294         break;
3295
3296       case INTERFACE_USER_OP:
3297         current_interface.uop->op = i;
3298         break;
3299
3300       default:
3301         gcc_unreachable ();
3302     }
3303 }
3304
3305
3306 /* Gets rid of a formal argument list.  We do not free symbols.
3307    Symbols are freed when a namespace is freed.  */
3308
3309 void
3310 gfc_free_formal_arglist (gfc_formal_arglist *p)
3311 {
3312   gfc_formal_arglist *q;
3313
3314   for (; p; p = q)
3315     {
3316       q = p->next;
3317       gfc_free (p);
3318     }
3319 }