OSDN Git Service

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