OSDN Git Service

293a54ad0aa7c63fdfae5714b84f50f296ae3a4c
[pf3gnuchains/gcc-fork.git] / gcc / fortran / interface.c
1 /* Deal with interfaces.
2    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22
23 /* Deal with interfaces.  An explicit interface is represented as a
24    singly linked list of formal argument structures attached to the
25    relevant symbols.  For an implicit interface, the arguments don't
26    point to symbols.  Explicit interfaces point to namespaces that
27    contain the symbols within that interface.
28
29    Implicit interfaces are linked together in a singly linked list
30    along the next_if member of symbol nodes.  Since a particular
31    symbol can only have a single explicit interface, the symbol cannot
32    be part of multiple lists and a single next-member suffices.
33
34    This is not the case for general classes, though.  An operator
35    definition is independent of just about all other uses and has it's
36    own head pointer.
37
38    Nameless interfaces:
39      Nameless interfaces create symbols with explicit interfaces within
40      the current namespace.  They are otherwise unlinked.
41
42    Generic interfaces:
43      The generic name points to a linked list of symbols.  Each symbol
44      has an explicit interface.  Each explicit interface has its own
45      namespace containing the arguments.  Module procedures are symbols in
46      which the interface is added later when the module procedure is parsed.
47
48    User operators:
49      User-defined operators are stored in a their own set of symtrees
50      separate from regular symbols.  The symtrees point to gfc_user_op
51      structures which in turn head up a list of relevant interfaces.
52
53    Extended intrinsics and assignment:
54      The head of these interface lists are stored in the containing namespace.
55
56    Implicit interfaces:
57      An implicit interface is represented as a singly linked list of
58      formal argument list structures that don't point to any symbol
59      nodes -- they just contain types.
60
61
62    When a subprogram is defined, the program unit's name points to an
63    interface as usual, but the link to the namespace is NULL and the
64    formal argument list points to symbols within the same namespace as
65    the program unit name.  */
66
67 #include "config.h"
68 #include "system.h"
69 #include "gfortran.h"
70 #include "match.h"
71
72 /* The current_interface structure holds information about the
73    interface currently being parsed.  This structure is saved and
74    restored during recursive interfaces.  */
75
76 gfc_interface_info current_interface;
77
78
79 /* Free a singly linked list of gfc_interface structures.  */
80
81 void
82 gfc_free_interface (gfc_interface *intr)
83 {
84   gfc_interface *next;
85
86   for (; intr; intr = next)
87     {
88       next = intr->next;
89       gfc_free (intr);
90     }
91 }
92
93
94 /* Change the operators unary plus and minus into binary plus and
95    minus respectively, leaving the rest unchanged.  */
96
97 static gfc_intrinsic_op
98 fold_unary (gfc_intrinsic_op operator)
99 {
100   switch (operator)
101     {
102     case INTRINSIC_UPLUS:
103       operator = INTRINSIC_PLUS;
104       break;
105     case INTRINSIC_UMINUS:
106       operator = INTRINSIC_MINUS;
107       break;
108     default:
109       break;
110     }
111
112   return operator;
113 }
114
115
116 /* Match a generic specification.  Depending on which type of
117    interface is found, the 'name' or 'operator' pointers may be set.
118    This subroutine doesn't return MATCH_NO.  */
119
120 match
121 gfc_match_generic_spec (interface_type *type,
122                         char *name,
123                         gfc_intrinsic_op *operator)
124 {
125   char buffer[GFC_MAX_SYMBOL_LEN + 1];
126   match m;
127   gfc_intrinsic_op i;
128
129   if (gfc_match (" assignment ( = )") == MATCH_YES)
130     {
131       *type = INTERFACE_INTRINSIC_OP;
132       *operator = INTRINSIC_ASSIGN;
133       return MATCH_YES;
134     }
135
136   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
137     {                           /* Operator i/f */
138       *type = INTERFACE_INTRINSIC_OP;
139       *operator = fold_unary (i);
140       return MATCH_YES;
141     }
142
143   if (gfc_match (" operator ( ") == MATCH_YES)
144     {
145       m = gfc_match_defined_op_name (buffer, 1);
146       if (m == MATCH_NO)
147         goto syntax;
148       if (m != MATCH_YES)
149         return MATCH_ERROR;
150
151       m = gfc_match_char (')');
152       if (m == MATCH_NO)
153         goto syntax;
154       if (m != MATCH_YES)
155         return MATCH_ERROR;
156
157       strcpy (name, buffer);
158       *type = INTERFACE_USER_OP;
159       return MATCH_YES;
160     }
161
162   if (gfc_match_name (buffer) == MATCH_YES)
163     {
164       strcpy (name, buffer);
165       *type = INTERFACE_GENERIC;
166       return MATCH_YES;
167     }
168
169   *type = INTERFACE_NAMELESS;
170   return MATCH_YES;
171
172 syntax:
173   gfc_error ("Syntax error in generic specification at %C");
174   return MATCH_ERROR;
175 }
176
177
178 /* Match one of the five forms of an interface statement.  */
179
180 match
181 gfc_match_interface (void)
182 {
183   char name[GFC_MAX_SYMBOL_LEN + 1];
184   interface_type type;
185   gfc_symbol *sym;
186   gfc_intrinsic_op operator;
187   match m;
188
189   m = gfc_match_space ();
190
191   if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
192     return MATCH_ERROR;
193
194   /* If we're not looking at the end of the statement now, or if this
195      is not a nameless interface but we did not see a space, punt.  */
196   if (gfc_match_eos () != MATCH_YES
197       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
198     {
199       gfc_error ("Syntax error: Trailing garbage in INTERFACE statement "
200                  "at %C");
201       return MATCH_ERROR;
202     }
203
204   current_interface.type = type;
205
206   switch (type)
207     {
208     case INTERFACE_GENERIC:
209       if (gfc_get_symbol (name, NULL, &sym))
210         return MATCH_ERROR;
211
212       if (!sym->attr.generic 
213           && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
214         return MATCH_ERROR;
215
216       if (sym->attr.dummy)
217         {
218           gfc_error ("Dummy procedure '%s' at %C cannot have a "
219                      "generic interface", sym->name);
220           return MATCH_ERROR;
221         }
222
223       current_interface.sym = gfc_new_block = sym;
224       break;
225
226     case INTERFACE_USER_OP:
227       current_interface.uop = gfc_get_uop (name);
228       break;
229
230     case INTERFACE_INTRINSIC_OP:
231       current_interface.op = operator;
232       break;
233
234     case INTERFACE_NAMELESS:
235       break;
236     }
237
238   return MATCH_YES;
239 }
240
241
242 /* Match the different sort of generic-specs that can be present after
243    the END INTERFACE itself.  */
244
245 match
246 gfc_match_end_interface (void)
247 {
248   char name[GFC_MAX_SYMBOL_LEN + 1];
249   interface_type type;
250   gfc_intrinsic_op operator;
251   match m;
252
253   m = gfc_match_space ();
254
255   if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
256     return MATCH_ERROR;
257
258   /* If we're not looking at the end of the statement now, or if this
259      is not a nameless interface but we did not see a space, punt.  */
260   if (gfc_match_eos () != MATCH_YES
261       || (type != INTERFACE_NAMELESS && m != MATCH_YES))
262     {
263       gfc_error ("Syntax error: Trailing garbage in END INTERFACE "
264                  "statement at %C");
265       return MATCH_ERROR;
266     }
267
268   m = MATCH_YES;
269
270   switch (current_interface.type)
271     {
272     case INTERFACE_NAMELESS:
273       if (type != current_interface.type)
274         {
275           gfc_error ("Expected a nameless interface at %C");
276           m = MATCH_ERROR;
277         }
278
279       break;
280
281     case INTERFACE_INTRINSIC_OP:
282       if (type != current_interface.type || operator != current_interface.op)
283         {
284
285           if (current_interface.op == INTRINSIC_ASSIGN)
286             gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
287           else
288             gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
289                        gfc_op2string (current_interface.op));
290
291           m = MATCH_ERROR;
292         }
293
294       break;
295
296     case INTERFACE_USER_OP:
297       /* Comparing the symbol node names is OK because only use-associated
298          symbols can be renamed.  */
299       if (type != current_interface.type
300           || strcmp (current_interface.uop->name, name) != 0)
301         {
302           gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
303                      current_interface.uop->name);
304           m = MATCH_ERROR;
305         }
306
307       break;
308
309     case INTERFACE_GENERIC:
310       if (type != current_interface.type
311           || strcmp (current_interface.sym->name, name) != 0)
312         {
313           gfc_error ("Expecting 'END INTERFACE %s' at %C",
314                      current_interface.sym->name);
315           m = MATCH_ERROR;
316         }
317
318       break;
319     }
320
321   return m;
322 }
323
324
325 /* Compare two derived types using the criteria in 4.4.2 of the standard,
326    recursing through gfc_compare_types for the components.  */
327
328 int
329 gfc_compare_derived_types (gfc_symbol *derived1, gfc_symbol *derived2)
330 {
331   gfc_component *dt1, *dt2;
332
333   /* Special case for comparing derived types across namespaces.  If the
334      true names and module names are the same and the module name is
335      nonnull, then they are equal.  */
336   if (derived1 != NULL && derived2 != NULL
337       && strcmp (derived1->name, derived2->name) == 0
338       && derived1->module != NULL && derived2->module != NULL
339       && strcmp (derived1->module, derived2->module) == 0)
340     return 1;
341
342   /* Compare type via the rules of the standard.  Both types must have
343      the SEQUENCE attribute to be equal.  */
344
345   if (strcmp (derived1->name, derived2->name))
346     return 0;
347
348   if (derived1->component_access == ACCESS_PRIVATE
349       || derived2->component_access == ACCESS_PRIVATE)
350     return 0;
351
352   if (derived1->attr.sequence == 0 || derived2->attr.sequence == 0)
353     return 0;
354
355   dt1 = derived1->components;
356   dt2 = derived2->components;
357
358   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
359      simple test can speed things up.  Otherwise, lots of things have to
360      match.  */
361   for (;;)
362     {
363       if (strcmp (dt1->name, dt2->name) != 0)
364         return 0;
365
366       if (dt1->access != dt2->access)
367         return 0;
368
369       if (dt1->pointer != dt2->pointer)
370         return 0;
371
372       if (dt1->dimension != dt2->dimension)
373         return 0;
374
375      if (dt1->allocatable != dt2->allocatable)
376         return 0;
377
378       if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
379         return 0;
380
381       if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
382         return 0;
383
384       dt1 = dt1->next;
385       dt2 = dt2->next;
386
387       if (dt1 == NULL && dt2 == NULL)
388         break;
389       if (dt1 == NULL || dt2 == NULL)
390         return 0;
391     }
392
393   return 1;
394 }
395
396
397 /* Compare two typespecs, recursively if necessary.  */
398
399 int
400 gfc_compare_types (gfc_typespec *ts1, gfc_typespec *ts2)
401 {
402   /* See if one of the typespecs is a BT_VOID, which is what is being used
403      to allow the funcs like c_f_pointer to accept any pointer type.
404      TODO: Possibly should narrow this to just the one typespec coming in
405      that is for the formal arg, but oh well.  */
406   if (ts1->type == BT_VOID || ts2->type == BT_VOID)
407     return 1;
408    
409   if (ts1->type != ts2->type)
410     return 0;
411   if (ts1->type != BT_DERIVED)
412     return (ts1->kind == ts2->kind);
413
414   /* Compare derived types.  */
415   if (ts1->derived == ts2->derived)
416     return 1;
417
418   return gfc_compare_derived_types (ts1->derived ,ts2->derived);
419 }
420
421
422 /* Given two symbols that are formal arguments, compare their ranks
423    and types.  Returns nonzero if they have the same rank and type,
424    zero otherwise.  */
425
426 static int
427 compare_type_rank (gfc_symbol *s1, gfc_symbol *s2)
428 {
429   int r1, r2;
430
431   r1 = (s1->as != NULL) ? s1->as->rank : 0;
432   r2 = (s2->as != NULL) ? s2->as->rank : 0;
433
434   if (r1 != r2)
435     return 0;                   /* Ranks differ.  */
436
437   return gfc_compare_types (&s1->ts, &s2->ts);
438 }
439
440
441 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
442
443 /* Given two symbols that are formal arguments, compare their types
444    and rank and their formal interfaces if they are both dummy
445    procedures.  Returns nonzero if the same, zero if different.  */
446
447 static int
448 compare_type_rank_if (gfc_symbol *s1, gfc_symbol *s2)
449 {
450   if (s1 == NULL || s2 == NULL)
451     return s1 == s2 ? 1 : 0;
452
453   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
454     return compare_type_rank (s1, s2);
455
456   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
457     return 0;
458
459   /* At this point, both symbols are procedures.  */
460   if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
461       || (s2->attr.function == 0 && s2->attr.subroutine == 0))
462     return 0;
463
464   if (s1->attr.function != s2->attr.function
465       || s1->attr.subroutine != s2->attr.subroutine)
466     return 0;
467
468   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
469     return 0;
470
471   /* Originally, gfortran recursed here to check the interfaces of passed
472      procedures.  This is explicitly not required by the standard.  */
473   return 1;
474 }
475
476
477 /* Given a formal argument list and a keyword name, search the list
478    for that keyword.  Returns the correct symbol node if found, NULL
479    if not found.  */
480
481 static gfc_symbol *
482 find_keyword_arg (const char *name, gfc_formal_arglist *f)
483 {
484   for (; f; f = f->next)
485     if (strcmp (f->sym->name, name) == 0)
486       return f->sym;
487
488   return NULL;
489 }
490
491
492 /******** Interface checking subroutines **********/
493
494
495 /* Given an operator interface and the operator, make sure that all
496    interfaces for that operator are legal.  */
497
498 static void
499 check_operator_interface (gfc_interface *intr, gfc_intrinsic_op operator)
500 {
501   gfc_formal_arglist *formal;
502   sym_intent i1, i2;
503   gfc_symbol *sym;
504   bt t1, t2;
505   int args, r1, r2, k1, k2;
506
507   if (intr == NULL)
508     return;
509
510   args = 0;
511   t1 = t2 = BT_UNKNOWN;
512   i1 = i2 = INTENT_UNKNOWN;
513   r1 = r2 = -1;
514   k1 = k2 = -1;
515
516   for (formal = intr->sym->formal; formal; formal = formal->next)
517     {
518       sym = formal->sym;
519       if (sym == NULL)
520         {
521           gfc_error ("Alternate return cannot appear in operator "
522                      "interface at %L", &intr->where);
523           return;
524         }
525       if (args == 0)
526         {
527           t1 = sym->ts.type;
528           i1 = sym->attr.intent;
529           r1 = (sym->as != NULL) ? sym->as->rank : 0;
530           k1 = sym->ts.kind;
531         }
532       if (args == 1)
533         {
534           t2 = sym->ts.type;
535           i2 = sym->attr.intent;
536           r2 = (sym->as != NULL) ? sym->as->rank : 0;
537           k2 = sym->ts.kind;
538         }
539       args++;
540     }
541
542   sym = intr->sym;
543
544   /* Only +, - and .not. can be unary operators.
545      .not. cannot be a binary operator.  */
546   if (args == 0 || args > 2 || (args == 1 && operator != INTRINSIC_PLUS
547                                 && operator != INTRINSIC_MINUS
548                                 && operator != INTRINSIC_NOT)
549       || (args == 2 && operator == INTRINSIC_NOT))
550     {
551       gfc_error ("Operator interface at %L has the wrong number of arguments",
552                  &intr->where);
553       return;
554     }
555
556   /* Check that intrinsics are mapped to functions, except
557      INTRINSIC_ASSIGN which should map to a subroutine.  */
558   if (operator == INTRINSIC_ASSIGN)
559     {
560       if (!sym->attr.subroutine)
561         {
562           gfc_error ("Assignment operator interface at %L must be "
563                      "a SUBROUTINE", &intr->where);
564           return;
565         }
566       if (args != 2)
567         {
568           gfc_error ("Assignment operator interface at %L must have "
569                      "two arguments", &intr->where);
570           return;
571         }
572       if (sym->formal->sym->ts.type != BT_DERIVED
573           && sym->formal->next->sym->ts.type != BT_DERIVED
574           && (sym->formal->sym->ts.type == sym->formal->next->sym->ts.type
575               || (gfc_numeric_ts (&sym->formal->sym->ts)
576                   && gfc_numeric_ts (&sym->formal->next->sym->ts))))
577         {
578           gfc_error ("Assignment operator interface at %L must not redefine "
579                      "an INTRINSIC type assignment", &intr->where);
580           return;
581         }
582     }
583   else
584     {
585       if (!sym->attr.function)
586         {
587           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
588                      &intr->where);
589           return;
590         }
591     }
592
593   /* Check intents on operator interfaces.  */
594   if (operator == INTRINSIC_ASSIGN)
595     {
596       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
597         gfc_error ("First argument of defined assignment at %L must be "
598                    "INTENT(IN) or INTENT(INOUT)", &intr->where);
599
600       if (i2 != INTENT_IN)
601         gfc_error ("Second argument of defined assignment at %L must be "
602                    "INTENT(IN)", &intr->where);
603     }
604   else
605     {
606       if (i1 != INTENT_IN)
607         gfc_error ("First argument of operator interface at %L must be "
608                    "INTENT(IN)", &intr->where);
609
610       if (args == 2 && i2 != INTENT_IN)
611         gfc_error ("Second argument of operator interface at %L must be "
612                    "INTENT(IN)", &intr->where);
613     }
614
615   /* From now on, all we have to do is check that the operator definition
616      doesn't conflict with an intrinsic operator. The rules for this
617      game are defined in 7.1.2 and 7.1.3 of both F95 and F2003 standards,
618      as well as 12.3.2.1.1 of Fortran 2003:
619
620      "If the operator is an intrinsic-operator (R310), the number of
621      function arguments shall be consistent with the intrinsic uses of
622      that operator, and the types, kind type parameters, or ranks of the
623      dummy arguments shall differ from those required for the intrinsic
624      operation (7.1.2)."  */
625
626 #define IS_NUMERIC_TYPE(t) \
627   ((t) == BT_INTEGER || (t) == BT_REAL || (t) == BT_COMPLEX)
628
629   /* Unary ops are easy, do them first.  */
630   if (operator == INTRINSIC_NOT)
631     {
632       if (t1 == BT_LOGICAL)
633         goto bad_repl;
634       else
635         return;
636     }
637
638   if (args == 1 && (operator == INTRINSIC_PLUS || operator == INTRINSIC_MINUS))
639     {
640       if (IS_NUMERIC_TYPE (t1))
641         goto bad_repl;
642       else
643         return;
644     }
645
646   /* Character intrinsic operators have same character kind, thus
647      operator definitions with operands of different character kinds
648      are always safe.  */
649   if (t1 == BT_CHARACTER && t2 == BT_CHARACTER && k1 != k2)
650     return;
651
652   /* Intrinsic operators always perform on arguments of same rank,
653      so different ranks is also always safe.  (rank == 0) is an exception
654      to that, because all intrinsic operators are elemental.  */
655   if (r1 != r2 && r1 != 0 && r2 != 0)
656     return;
657
658   switch (operator)
659   {
660     case INTRINSIC_EQ:
661     case INTRINSIC_EQ_OS:
662     case INTRINSIC_NE:
663     case INTRINSIC_NE_OS:
664       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
665         goto bad_repl;
666       /* Fall through.  */
667
668     case INTRINSIC_PLUS:
669     case INTRINSIC_MINUS:
670     case INTRINSIC_TIMES:
671     case INTRINSIC_DIVIDE:
672     case INTRINSIC_POWER:
673       if (IS_NUMERIC_TYPE (t1) && IS_NUMERIC_TYPE (t2))
674         goto bad_repl;
675       break;
676
677     case INTRINSIC_GT:
678     case INTRINSIC_GT_OS:
679     case INTRINSIC_GE:
680     case INTRINSIC_GE_OS:
681     case INTRINSIC_LT:
682     case INTRINSIC_LT_OS:
683     case INTRINSIC_LE:
684     case INTRINSIC_LE_OS:
685       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
686         goto bad_repl;
687       if ((t1 == BT_INTEGER || t1 == BT_REAL)
688           && (t2 == BT_INTEGER || t2 == BT_REAL))
689         goto bad_repl;
690       break;
691
692     case INTRINSIC_CONCAT:
693       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
694         goto bad_repl;
695       break;
696
697     case INTRINSIC_AND:
698     case INTRINSIC_OR:
699     case INTRINSIC_EQV:
700     case INTRINSIC_NEQV:
701       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
702         goto bad_repl;
703       break;
704
705     default:
706       break;
707   }
708
709   return;
710
711 #undef IS_NUMERIC_TYPE
712
713 bad_repl:
714   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
715              &intr->where);
716   return;
717 }
718
719
720 /* Given a pair of formal argument lists, we see if the two lists can
721    be distinguished by counting the number of nonoptional arguments of
722    a given type/rank in f1 and seeing if there are less then that
723    number of those arguments in f2 (including optional arguments).
724    Since this test is asymmetric, it has to be called twice to make it
725    symmetric.  Returns nonzero if the argument lists are incompatible
726    by this test.  This subroutine implements rule 1 of section
727    14.1.2.3.  */
728
729 static int
730 count_types_test (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
731 {
732   int rc, ac1, ac2, i, j, k, n1;
733   gfc_formal_arglist *f;
734
735   typedef struct
736   {
737     int flag;
738     gfc_symbol *sym;
739   }
740   arginfo;
741
742   arginfo *arg;
743
744   n1 = 0;
745
746   for (f = f1; f; f = f->next)
747     n1++;
748
749   /* Build an array of integers that gives the same integer to
750      arguments of the same type/rank.  */
751   arg = gfc_getmem (n1 * sizeof (arginfo));
752
753   f = f1;
754   for (i = 0; i < n1; i++, f = f->next)
755     {
756       arg[i].flag = -1;
757       arg[i].sym = f->sym;
758     }
759
760   k = 0;
761
762   for (i = 0; i < n1; i++)
763     {
764       if (arg[i].flag != -1)
765         continue;
766
767       if (arg[i].sym && arg[i].sym->attr.optional)
768         continue;               /* Skip optional arguments.  */
769
770       arg[i].flag = k;
771
772       /* Find other nonoptional arguments of the same type/rank.  */
773       for (j = i + 1; j < n1; j++)
774         if ((arg[j].sym == NULL || !arg[j].sym->attr.optional)
775             && compare_type_rank_if (arg[i].sym, arg[j].sym))
776           arg[j].flag = k;
777
778       k++;
779     }
780
781   /* Now loop over each distinct type found in f1.  */
782   k = 0;
783   rc = 0;
784
785   for (i = 0; i < n1; i++)
786     {
787       if (arg[i].flag != k)
788         continue;
789
790       ac1 = 1;
791       for (j = i + 1; j < n1; j++)
792         if (arg[j].flag == k)
793           ac1++;
794
795       /* Count the number of arguments in f2 with that type, including
796          those that are optional.  */
797       ac2 = 0;
798
799       for (f = f2; f; f = f->next)
800         if (compare_type_rank_if (arg[i].sym, f->sym))
801           ac2++;
802
803       if (ac1 > ac2)
804         {
805           rc = 1;
806           break;
807         }
808
809       k++;
810     }
811
812   gfc_free (arg);
813
814   return rc;
815 }
816
817
818 /* Perform the abbreviated correspondence test for operators.  The
819    arguments cannot be optional and are always ordered correctly,
820    which makes this test much easier than that for generic tests.
821
822    This subroutine is also used when comparing a formal and actual
823    argument list when an actual parameter is a dummy procedure.  At
824    that point, two formal interfaces must be compared for equality
825    which is what happens here.  */
826
827 static int
828 operator_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
829 {
830   for (;;)
831     {
832       if (f1 == NULL && f2 == NULL)
833         break;
834       if (f1 == NULL || f2 == NULL)
835         return 1;
836
837       if (!compare_type_rank (f1->sym, f2->sym))
838         return 1;
839
840       f1 = f1->next;
841       f2 = f2->next;
842     }
843
844   return 0;
845 }
846
847
848 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
849    Returns zero if no argument is found that satisfies rule 2, nonzero
850    otherwise.
851
852    This test is also not symmetric in f1 and f2 and must be called
853    twice.  This test finds problems caused by sorting the actual
854    argument list with keywords.  For example:
855
856    INTERFACE FOO
857        SUBROUTINE F1(A, B)
858            INTEGER :: A ; REAL :: B
859        END SUBROUTINE F1
860
861        SUBROUTINE F2(B, A)
862            INTEGER :: A ; REAL :: B
863        END SUBROUTINE F1
864    END INTERFACE FOO
865
866    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
867
868 static int
869 generic_correspondence (gfc_formal_arglist *f1, gfc_formal_arglist *f2)
870 {
871   gfc_formal_arglist *f2_save, *g;
872   gfc_symbol *sym;
873
874   f2_save = f2;
875
876   while (f1)
877     {
878       if (f1->sym->attr.optional)
879         goto next;
880
881       if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
882         goto next;
883
884       /* Now search for a disambiguating keyword argument starting at
885          the current non-match.  */
886       for (g = f1; g; g = g->next)
887         {
888           if (g->sym->attr.optional)
889             continue;
890
891           sym = find_keyword_arg (g->sym->name, f2_save);
892           if (sym == NULL || !compare_type_rank (g->sym, sym))
893             return 1;
894         }
895
896     next:
897       f1 = f1->next;
898       if (f2 != NULL)
899         f2 = f2->next;
900     }
901
902   return 0;
903 }
904
905
906 /* 'Compare' two formal interfaces associated with a pair of symbols.
907    We return nonzero if there exists an actual argument list that
908    would be ambiguous between the two interfaces, zero otherwise.  */
909
910 static int
911 compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
912 {
913   gfc_formal_arglist *f1, *f2;
914
915   if (s1->attr.function != s2->attr.function
916       && s1->attr.subroutine != s2->attr.subroutine)
917     return 0;           /* Disagreement between function/subroutine.  */
918
919   f1 = s1->formal;
920   f2 = s2->formal;
921
922   if (f1 == NULL && f2 == NULL)
923     return 1;                   /* Special case.  */
924
925   if (count_types_test (f1, f2))
926     return 0;
927   if (count_types_test (f2, f1))
928     return 0;
929
930   if (generic_flag)
931     {
932       if (generic_correspondence (f1, f2))
933         return 0;
934       if (generic_correspondence (f2, f1))
935         return 0;
936     }
937   else
938     {
939       if (operator_correspondence (f1, f2))
940         return 0;
941     }
942
943   return 1;
944 }
945
946
947 /* Given a pointer to an interface pointer, remove duplicate
948    interfaces and make sure that all symbols are either functions or
949    subroutines.  Returns nonzero if something goes wrong.  */
950
951 static int
952 check_interface0 (gfc_interface *p, const char *interface_name)
953 {
954   gfc_interface *psave, *q, *qlast;
955
956   psave = p;
957   /* Make sure all symbols in the interface have been defined as
958      functions or subroutines.  */
959   for (; p; p = p->next)
960     if (!p->sym->attr.function && !p->sym->attr.subroutine)
961       {
962         gfc_error ("Procedure '%s' in %s at %L is neither function nor "
963                    "subroutine", p->sym->name, interface_name,
964                    &p->sym->declared_at);
965         return 1;
966       }
967   p = psave;
968
969   /* Remove duplicate interfaces in this interface list.  */
970   for (; p; p = p->next)
971     {
972       qlast = p;
973
974       for (q = p->next; q;)
975         {
976           if (p->sym != q->sym)
977             {
978               qlast = q;
979               q = q->next;
980             }
981           else
982             {
983               /* Duplicate interface.  */
984               qlast->next = q->next;
985               gfc_free (q);
986               q = qlast->next;
987             }
988         }
989     }
990
991   return 0;
992 }
993
994
995 /* Check lists of interfaces to make sure that no two interfaces are
996    ambiguous.  Duplicate interfaces (from the same symbol) are OK here.  */
997
998 static int
999 check_interface1 (gfc_interface *p, gfc_interface *q0,
1000                   int generic_flag, const char *interface_name,
1001                   bool referenced)
1002 {
1003   gfc_interface *q;
1004   for (; p; p = p->next)
1005     for (q = q0; q; q = q->next)
1006       {
1007         if (p->sym == q->sym)
1008           continue;             /* Duplicates OK here.  */
1009
1010         if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
1011           continue;
1012
1013         if (compare_interfaces (p->sym, q->sym, generic_flag))
1014           {
1015             if (referenced)
1016               {
1017                 gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1018                            p->sym->name, q->sym->name, interface_name,
1019                            &p->where);
1020               }
1021
1022             if (!p->sym->attr.use_assoc && q->sym->attr.use_assoc)
1023               gfc_warning ("Ambiguous interfaces '%s' and '%s' in %s at %L",
1024                            p->sym->name, q->sym->name, interface_name,
1025                            &p->where);
1026             return 1;
1027           }
1028       }
1029   return 0;
1030 }
1031
1032
1033 /* Check the generic and operator interfaces of symbols to make sure
1034    that none of the interfaces conflict.  The check has to be done
1035    after all of the symbols are actually loaded.  */
1036
1037 static void
1038 check_sym_interfaces (gfc_symbol *sym)
1039 {
1040   char interface_name[100];
1041   bool k;
1042   gfc_interface *p;
1043
1044   if (sym->ns != gfc_current_ns)
1045     return;
1046
1047   if (sym->generic != NULL)
1048     {
1049       sprintf (interface_name, "generic interface '%s'", sym->name);
1050       if (check_interface0 (sym->generic, interface_name))
1051         return;
1052
1053       for (p = sym->generic; p; p = p->next)
1054         {
1055           if (!p->sym->attr.use_assoc && p->sym->attr.mod_proc
1056               && p->sym->attr.if_source != IFSRC_DECL)
1057             {
1058               gfc_error ("MODULE PROCEDURE '%s' at %L does not come "
1059                          "from a module", p->sym->name, &p->where);
1060               return;
1061             }
1062         }
1063
1064       /* Originally, this test was applied to host interfaces too;
1065          this is incorrect since host associated symbols, from any
1066          source, cannot be ambiguous with local symbols.  */
1067       k = sym->attr.referenced || !sym->attr.use_assoc;
1068       if (check_interface1 (sym->generic, sym->generic, 1, interface_name, k))
1069         sym->attr.ambiguous_interfaces = 1;
1070     }
1071 }
1072
1073
1074 static void
1075 check_uop_interfaces (gfc_user_op *uop)
1076 {
1077   char interface_name[100];
1078   gfc_user_op *uop2;
1079   gfc_namespace *ns;
1080
1081   sprintf (interface_name, "operator interface '%s'", uop->name);
1082   if (check_interface0 (uop->operator, interface_name))
1083     return;
1084
1085   for (ns = gfc_current_ns; ns; ns = ns->parent)
1086     {
1087       uop2 = gfc_find_uop (uop->name, ns);
1088       if (uop2 == NULL)
1089         continue;
1090
1091       check_interface1 (uop->operator, uop2->operator, 0,
1092                         interface_name, true);
1093     }
1094 }
1095
1096
1097 /* For the namespace, check generic, user operator and intrinsic
1098    operator interfaces for consistency and to remove duplicate
1099    interfaces.  We traverse the whole namespace, counting on the fact
1100    that most symbols will not have generic or operator interfaces.  */
1101
1102 void
1103 gfc_check_interfaces (gfc_namespace *ns)
1104 {
1105   gfc_namespace *old_ns, *ns2;
1106   char interface_name[100];
1107   gfc_intrinsic_op i;
1108
1109   old_ns = gfc_current_ns;
1110   gfc_current_ns = ns;
1111
1112   gfc_traverse_ns (ns, check_sym_interfaces);
1113
1114   gfc_traverse_user_op (ns, check_uop_interfaces);
1115
1116   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1117     {
1118       if (i == INTRINSIC_USER)
1119         continue;
1120
1121       if (i == INTRINSIC_ASSIGN)
1122         strcpy (interface_name, "intrinsic assignment operator");
1123       else
1124         sprintf (interface_name, "intrinsic '%s' operator",
1125                  gfc_op2string (i));
1126
1127       if (check_interface0 (ns->operator[i], interface_name))
1128         continue;
1129
1130       check_operator_interface (ns->operator[i], i);
1131
1132       for (ns2 = ns; ns2; ns2 = ns2->parent)
1133         {
1134           if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1135                                 interface_name, true))
1136             goto done;
1137
1138           switch (i)
1139             {
1140               case INTRINSIC_EQ:
1141                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ_OS],
1142                                       0, interface_name, true)) goto done;
1143                 break;
1144
1145               case INTRINSIC_EQ_OS:
1146                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_EQ],
1147                                       0, interface_name, true)) goto done;
1148                 break;
1149
1150               case INTRINSIC_NE:
1151                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE_OS],
1152                                       0, interface_name, true)) goto done;
1153                 break;
1154
1155               case INTRINSIC_NE_OS:
1156                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_NE],
1157                                       0, interface_name, true)) goto done;
1158                 break;
1159
1160               case INTRINSIC_GT:
1161                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT_OS],
1162                                       0, interface_name, true)) goto done;
1163                 break;
1164
1165               case INTRINSIC_GT_OS:
1166                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GT],
1167                                       0, interface_name, true)) goto done;
1168                 break;
1169
1170               case INTRINSIC_GE:
1171                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE_OS],
1172                                       0, interface_name, true)) goto done;
1173                 break;
1174
1175               case INTRINSIC_GE_OS:
1176                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_GE],
1177                                       0, interface_name, true)) goto done;
1178                 break;
1179
1180               case INTRINSIC_LT:
1181                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT_OS],
1182                                       0, interface_name, true)) goto done;
1183                 break;
1184
1185               case INTRINSIC_LT_OS:
1186                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LT],
1187                                       0, interface_name, true)) goto done;
1188                 break;
1189
1190               case INTRINSIC_LE:
1191                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE_OS],
1192                                       0, interface_name, true)) goto done;
1193                 break;
1194
1195               case INTRINSIC_LE_OS:
1196                 if (check_interface1 (ns->operator[i], ns2->operator[INTRINSIC_LE],
1197                                       0, interface_name, true)) goto done;
1198                 break;
1199
1200               default:
1201                 break;
1202             }
1203         }
1204     }
1205
1206 done:
1207   gfc_current_ns = old_ns;
1208 }
1209
1210
1211 static int
1212 symbol_rank (gfc_symbol *sym)
1213 {
1214   return (sym->as == NULL) ? 0 : sym->as->rank;
1215 }
1216
1217
1218 /* Given a symbol of a formal argument list and an expression, if the
1219    formal argument is allocatable, check that the actual argument is
1220    allocatable. Returns nonzero if compatible, zero if not compatible.  */
1221
1222 static int
1223 compare_allocatable (gfc_symbol *formal, gfc_expr *actual)
1224 {
1225   symbol_attribute attr;
1226
1227   if (formal->attr.allocatable)
1228     {
1229       attr = gfc_expr_attr (actual);
1230       if (!attr.allocatable)
1231         return 0;
1232     }
1233
1234   return 1;
1235 }
1236
1237
1238 /* Given a symbol of a formal argument list and an expression, if the
1239    formal argument is a pointer, see if the actual argument is a
1240    pointer. Returns nonzero if compatible, zero if not compatible.  */
1241
1242 static int
1243 compare_pointer (gfc_symbol *formal, gfc_expr *actual)
1244 {
1245   symbol_attribute attr;
1246
1247   if (formal->attr.pointer)
1248     {
1249       attr = gfc_expr_attr (actual);
1250       if (!attr.pointer)
1251         return 0;
1252     }
1253
1254   return 1;
1255 }
1256
1257
1258 /* Given a symbol of a formal argument list and an expression, see if
1259    the two are compatible as arguments.  Returns nonzero if
1260    compatible, zero if not compatible.  */
1261
1262 static int
1263 compare_parameter (gfc_symbol *formal, gfc_expr *actual,
1264                    int ranks_must_agree, int is_elemental)
1265 {
1266   gfc_ref *ref;
1267
1268   /* If the formal arg has type BT_VOID, it's to one of the iso_c_binding
1269      procs c_f_pointer or c_f_procpointer, and we need to accept most
1270      pointers the user could give us.  This should allow that.  */
1271   if (formal->ts.type == BT_VOID)
1272     return 1;
1273
1274   if (formal->ts.type == BT_DERIVED
1275       && formal->ts.derived && formal->ts.derived->ts.is_iso_c
1276       && actual->ts.type == BT_DERIVED
1277       && actual->ts.derived && actual->ts.derived->ts.is_iso_c)
1278     return 1;
1279
1280   if (actual->ts.type == BT_PROCEDURE)
1281     {
1282       if (formal->attr.flavor != FL_PROCEDURE)
1283         return 0;
1284
1285       if (formal->attr.function
1286           && !compare_type_rank (formal, actual->symtree->n.sym))
1287         return 0;
1288
1289       if (formal->attr.if_source == IFSRC_UNKNOWN
1290           || actual->symtree->n.sym->attr.external)
1291         return 1;               /* Assume match.  */
1292
1293       return compare_interfaces (formal, actual->symtree->n.sym, 0);
1294     }
1295
1296   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1297       && !gfc_compare_types (&formal->ts, &actual->ts))
1298     return 0;
1299
1300   if (symbol_rank (formal) == actual->rank)
1301     return 1;
1302
1303   /* At this point the ranks didn't agree.  */
1304   if (ranks_must_agree || formal->attr.pointer)
1305     return 0;
1306
1307   if (actual->rank != 0)
1308     return is_elemental || formal->attr.dimension;
1309
1310   /* At this point, we are considering a scalar passed to an array.
1311      This is legal if the scalar is an array element of the right sort.  */
1312   if (formal->as->type == AS_ASSUMED_SHAPE)
1313     return 0;
1314
1315   for (ref = actual->ref; ref; ref = ref->next)
1316     if (ref->type == REF_SUBSTRING)
1317       return 0;
1318
1319   for (ref = actual->ref; ref; ref = ref->next)
1320     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1321       break;
1322
1323   if (ref == NULL)
1324     return 0;                   /* Not an array element.  */
1325
1326   return 1;
1327 }
1328
1329
1330 /* Given a symbol of a formal argument list and an expression, see if
1331    the two are compatible as arguments.  Returns nonzero if
1332    compatible, zero if not compatible.  */
1333
1334 static int
1335 compare_parameter_protected (gfc_symbol *formal, gfc_expr *actual)
1336 {
1337   if (actual->expr_type != EXPR_VARIABLE)
1338     return 1;
1339
1340   if (!actual->symtree->n.sym->attr.protected)
1341     return 1;
1342
1343   if (!actual->symtree->n.sym->attr.use_assoc)
1344     return 1;
1345
1346   if (formal->attr.intent == INTENT_IN
1347       || formal->attr.intent == INTENT_UNKNOWN)
1348     return 1;
1349
1350   if (!actual->symtree->n.sym->attr.pointer)
1351     return 0;
1352
1353   if (actual->symtree->n.sym->attr.pointer && formal->attr.pointer)
1354     return 0;
1355
1356   return 1;
1357 }
1358
1359
1360 /* Returns the storage size of a symbol (formal argument) or
1361    zero if it cannot be determined.  */
1362
1363 static unsigned long
1364 get_sym_storage_size (gfc_symbol *sym)
1365 {
1366   int i;
1367   unsigned long strlen, elements;
1368
1369   if (sym->ts.type == BT_CHARACTER)
1370     {
1371       if (sym->ts.cl && sym->ts.cl->length
1372           && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1373         strlen = mpz_get_ui (sym->ts.cl->length->value.integer);
1374       else
1375         return 0;
1376     }
1377   else
1378     strlen = 1; 
1379
1380   if (symbol_rank (sym) == 0)
1381     return strlen;
1382
1383   elements = 1;
1384   if (sym->as->type != AS_EXPLICIT)
1385     return 0;
1386   for (i = 0; i < sym->as->rank; i++)
1387     {
1388       if (!sym->as || sym->as->upper[i]->expr_type != EXPR_CONSTANT
1389           || sym->as->lower[i]->expr_type != EXPR_CONSTANT)
1390         return 0;
1391
1392       elements *= mpz_get_ui (sym->as->upper[i]->value.integer)
1393                   - mpz_get_ui (sym->as->lower[i]->value.integer) + 1L;
1394     }
1395
1396   return strlen*elements;
1397 }
1398
1399
1400 /* Returns the storage size of an expression (actual argument) or
1401    zero if it cannot be determined. For an array element, it returns
1402    the remaining size as the element sequence consists of all storage
1403    units of the actual argument up to the end of the array.  */
1404
1405 static unsigned long
1406 get_expr_storage_size (gfc_expr *e)
1407 {
1408   int i;
1409   long int strlen, elements;
1410   gfc_ref *ref;
1411
1412   if (e == NULL)
1413     return 0;
1414   
1415   if (e->ts.type == BT_CHARACTER)
1416     {
1417       if (e->ts.cl && e->ts.cl->length
1418           && e->ts.cl->length->expr_type == EXPR_CONSTANT)
1419         strlen = mpz_get_si (e->ts.cl->length->value.integer);
1420       else if (e->expr_type == EXPR_CONSTANT
1421                && (e->ts.cl == NULL || e->ts.cl->length == NULL))
1422         strlen = e->value.character.length;
1423       else
1424         return 0;
1425     }
1426   else
1427     strlen = 1; /* Length per element.  */
1428
1429   if (e->rank == 0 && !e->ref)
1430     return strlen;
1431
1432   elements = 1;
1433   if (!e->ref)
1434     {
1435       if (!e->shape)
1436         return 0;
1437       for (i = 0; i < e->rank; i++)
1438         elements *= mpz_get_si (e->shape[i]);
1439       return elements*strlen;
1440     }
1441
1442   for (ref = e->ref; ref; ref = ref->next)
1443     {
1444       if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION
1445           && ref->u.ar.start && ref->u.ar.end && ref->u.ar.stride
1446           && ref->u.ar.as->upper)
1447         for (i = 0; i < ref->u.ar.dimen; i++)
1448           {
1449             long int start, end, stride;
1450             stride = 1;
1451
1452             if (ref->u.ar.stride[i])
1453               {
1454                 if (ref->u.ar.stride[i]->expr_type == EXPR_CONSTANT)
1455                   stride = mpz_get_si (ref->u.ar.stride[i]->value.integer);
1456                 else
1457                   return 0;
1458               }
1459
1460             if (ref->u.ar.start[i])
1461               {
1462                 if (ref->u.ar.start[i]->expr_type == EXPR_CONSTANT)
1463                   start = mpz_get_si (ref->u.ar.start[i]->value.integer);
1464                 else
1465                   return 0;
1466               }
1467             else if (ref->u.ar.as->lower[i]
1468                      && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT)
1469               start = mpz_get_si (ref->u.ar.as->lower[i]->value.integer);
1470             else
1471               return 0;
1472
1473             if (ref->u.ar.end[i])
1474               {
1475                 if (ref->u.ar.end[i]->expr_type == EXPR_CONSTANT)
1476                   end = mpz_get_si (ref->u.ar.end[i]->value.integer);
1477                 else
1478                   return 0;
1479               }
1480             else if (ref->u.ar.as->upper[i]
1481                      && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1482               end = mpz_get_si (ref->u.ar.as->upper[i]->value.integer);
1483             else
1484               return 0;
1485
1486             elements *= (end - start)/stride + 1L;
1487           }
1488       else if (ref->type == REF_ARRAY && ref->u.ar.type == AR_FULL
1489                && ref->u.ar.as->lower && ref->u.ar.as->upper)
1490         for (i = 0; i < ref->u.ar.as->rank; i++)
1491           {
1492             if (ref->u.ar.as->lower[i] && ref->u.ar.as->upper[i]
1493                 && ref->u.ar.as->lower[i]->expr_type == EXPR_CONSTANT
1494                 && ref->u.ar.as->upper[i]->expr_type == EXPR_CONSTANT)
1495               elements *= mpz_get_ui (ref->u.ar.as->upper[i]->value.integer)
1496                           - mpz_get_ui (ref->u.ar.as->lower[i]->value.integer)
1497                           + 1L;
1498             else
1499               return 0;
1500           }
1501       else
1502         /* TODO: Determine the number of remaining elements in the element
1503            sequence for array element designators.
1504            See also get_array_index in data.c.  */
1505         return 0;
1506     }
1507
1508   return elements*strlen;
1509 }
1510
1511
1512 /* Given an expression, check whether it is an array section
1513    which has a vector subscript. If it has, one is returned,
1514    otherwise zero.  */
1515
1516 static int
1517 has_vector_subscript (gfc_expr *e)
1518 {
1519   int i;
1520   gfc_ref *ref;
1521
1522   if (e == NULL || e->rank == 0 || e->expr_type != EXPR_VARIABLE)
1523     return 0;
1524
1525   for (ref = e->ref; ref; ref = ref->next)
1526     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
1527       for (i = 0; i < ref->u.ar.dimen; i++)
1528         if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
1529           return 1;
1530
1531   return 0;
1532 }
1533
1534
1535 /* Given formal and actual argument lists, see if they are compatible.
1536    If they are compatible, the actual argument list is sorted to
1537    correspond with the formal list, and elements for missing optional
1538    arguments are inserted. If WHERE pointer is nonnull, then we issue
1539    errors when things don't match instead of just returning the status
1540    code.  */
1541
1542 static int
1543 compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
1544                        int ranks_must_agree, int is_elemental, locus *where)
1545 {
1546   gfc_actual_arglist **new, *a, *actual, temp;
1547   gfc_formal_arglist *f;
1548   int i, n, na;
1549   bool rank_check;
1550   unsigned long actual_size, formal_size;
1551
1552   actual = *ap;
1553
1554   if (actual == NULL && formal == NULL)
1555     return 1;
1556
1557   n = 0;
1558   for (f = formal; f; f = f->next)
1559     n++;
1560
1561   new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1562
1563   for (i = 0; i < n; i++)
1564     new[i] = NULL;
1565
1566   na = 0;
1567   f = formal;
1568   i = 0;
1569
1570   for (a = actual; a; a = a->next, f = f->next)
1571     {
1572       /* Look for keywords but ignore g77 extensions like %VAL.  */
1573       if (a->name != NULL && a->name[0] != '%')
1574         {
1575           i = 0;
1576           for (f = formal; f; f = f->next, i++)
1577             {
1578               if (f->sym == NULL)
1579                 continue;
1580               if (strcmp (f->sym->name, a->name) == 0)
1581                 break;
1582             }
1583
1584           if (f == NULL)
1585             {
1586               if (where)
1587                 gfc_error ("Keyword argument '%s' at %L is not in "
1588                            "the procedure", a->name, &a->expr->where);
1589               return 0;
1590             }
1591
1592           if (new[i] != NULL)
1593             {
1594               if (where)
1595                 gfc_error ("Keyword argument '%s' at %L is already associated "
1596                            "with another actual argument", a->name,
1597                            &a->expr->where);
1598               return 0;
1599             }
1600         }
1601
1602       if (f == NULL)
1603         {
1604           if (where)
1605             gfc_error ("More actual than formal arguments in procedure "
1606                        "call at %L", where);
1607
1608           return 0;
1609         }
1610
1611       if (f->sym == NULL && a->expr == NULL)
1612         goto match;
1613
1614       if (f->sym == NULL)
1615         {
1616           if (where)
1617             gfc_error ("Missing alternate return spec in subroutine call "
1618                        "at %L", where);
1619           return 0;
1620         }
1621
1622       if (a->expr == NULL)
1623         {
1624           if (where)
1625             gfc_error ("Unexpected alternate return spec in subroutine "
1626                        "call at %L", where);
1627           return 0;
1628         }
1629
1630       rank_check = where != NULL && !is_elemental && f->sym->as
1631                    && (f->sym->as->type == AS_ASSUMED_SHAPE
1632                        || f->sym->as->type == AS_DEFERRED);
1633
1634       if (f->sym->ts.type == BT_CHARACTER && a->expr->ts.type == BT_CHARACTER
1635           && a->expr->rank == 0
1636           && f->sym->as && f->sym->as->type != AS_ASSUMED_SHAPE)
1637         {
1638           if (where && (gfc_option.allow_std & GFC_STD_F2003) == 0)
1639             {
1640               gfc_error ("Fortran 2003: Scalar CHARACTER actual argument "
1641                          "with array dummy argument '%s' at %L",
1642                          f->sym->name, &a->expr->where);
1643               return 0;
1644             }
1645           else if ((gfc_option.allow_std & GFC_STD_F2003) == 0)
1646             return 0;
1647
1648         }
1649       else if (!compare_parameter (f->sym, a->expr,
1650                                    ranks_must_agree || rank_check, is_elemental))
1651         {
1652           if (where)
1653             gfc_error ("Type/rank mismatch in argument '%s' at %L",
1654                        f->sym->name, &a->expr->where);
1655           return 0;
1656         }
1657
1658       if (a->expr->ts.type == BT_CHARACTER
1659            && a->expr->ts.cl && a->expr->ts.cl->length
1660            && a->expr->ts.cl->length->expr_type == EXPR_CONSTANT
1661            && f->sym->ts.cl && f->sym->ts.cl && f->sym->ts.cl->length
1662            && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
1663          {
1664            if ((f->sym->attr.pointer || f->sym->attr.allocatable)
1665                && (mpz_cmp (a->expr->ts.cl->length->value.integer,
1666                            f->sym->ts.cl->length->value.integer) != 0))
1667              {
1668                 if (where)
1669                   gfc_warning ("Character length mismatch between actual "
1670                                "argument and pointer or allocatable dummy "
1671                                "argument '%s' at %L",
1672                                f->sym->name, &a->expr->where);
1673                 return 0;
1674              }
1675          }
1676
1677       actual_size = get_expr_storage_size (a->expr);
1678       formal_size = get_sym_storage_size (f->sym);
1679       if (actual_size != 0 && actual_size < formal_size)
1680         {
1681           if (a->expr->ts.type == BT_CHARACTER && !f->sym->as && where)
1682             gfc_warning ("Character length of actual argument shorter "
1683                         "than of dummy argument '%s' (%d/%d) at %L",
1684                         f->sym->name, (int) actual_size,
1685                         (int) formal_size, &a->expr->where);
1686           else if (where)
1687             gfc_warning ("Actual argument contains too few "
1688                         "elements for dummy argument '%s' (%d/%d) at %L",
1689                         f->sym->name, (int) actual_size,
1690                         (int) formal_size, &a->expr->where);
1691           return  0;
1692         }
1693
1694       /* Satisfy 12.4.1.2 by ensuring that a procedure actual argument is
1695          provided for a procedure formal argument.  */
1696       if (a->expr->ts.type != BT_PROCEDURE
1697           && a->expr->expr_type == EXPR_VARIABLE
1698           && f->sym->attr.flavor == FL_PROCEDURE)
1699         {
1700           if (where)
1701             gfc_error ("Expected a procedure for argument '%s' at %L",
1702                        f->sym->name, &a->expr->where);
1703           return 0;
1704         }
1705
1706       if (f->sym->attr.flavor == FL_PROCEDURE && f->sym->attr.pure
1707           && a->expr->ts.type == BT_PROCEDURE
1708           && !a->expr->symtree->n.sym->attr.pure)
1709         {
1710           if (where)
1711             gfc_error ("Expected a PURE procedure for argument '%s' at %L",
1712                        f->sym->name, &a->expr->where);
1713           return 0;
1714         }
1715
1716       if (f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE
1717           && a->expr->expr_type == EXPR_VARIABLE
1718           && a->expr->symtree->n.sym->as
1719           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SIZE
1720           && (a->expr->ref == NULL
1721               || (a->expr->ref->type == REF_ARRAY
1722                   && a->expr->ref->u.ar.type == AR_FULL)))
1723         {
1724           if (where)
1725             gfc_error ("Actual argument for '%s' cannot be an assumed-size"
1726                        " array at %L", f->sym->name, where);
1727           return 0;
1728         }
1729
1730       if (a->expr->expr_type != EXPR_NULL
1731           && compare_pointer (f->sym, a->expr) == 0)
1732         {
1733           if (where)
1734             gfc_error ("Actual argument for '%s' must be a pointer at %L",
1735                        f->sym->name, &a->expr->where);
1736           return 0;
1737         }
1738
1739       if (a->expr->expr_type != EXPR_NULL
1740           && compare_allocatable (f->sym, a->expr) == 0)
1741         {
1742           if (where)
1743             gfc_error ("Actual argument for '%s' must be ALLOCATABLE at %L",
1744                        f->sym->name, &a->expr->where);
1745           return 0;
1746         }
1747
1748       /* Check intent = OUT/INOUT for definable actual argument.  */
1749       if (a->expr->expr_type != EXPR_VARIABLE
1750           && (f->sym->attr.intent == INTENT_OUT
1751               || f->sym->attr.intent == INTENT_INOUT))
1752         {
1753           if (where)
1754             gfc_error ("Actual argument at %L must be definable to "
1755                        "match dummy INTENT = OUT/INOUT", &a->expr->where);
1756           return 0;
1757         }
1758
1759       if (!compare_parameter_protected(f->sym, a->expr))
1760         {
1761           if (where)
1762             gfc_error ("Actual argument at %L is use-associated with "
1763                        "PROTECTED attribute and dummy argument '%s' is "
1764                        "INTENT = OUT/INOUT",
1765                        &a->expr->where,f->sym->name);
1766           return 0;
1767         }
1768
1769       if ((f->sym->attr.intent == INTENT_OUT
1770            || f->sym->attr.intent == INTENT_INOUT
1771            || f->sym->attr.volatile_)
1772           && has_vector_subscript (a->expr))
1773         {
1774           if (where)
1775             gfc_error ("Array-section actual argument with vector subscripts "
1776                        "at %L is incompatible with INTENT(IN), INTENT(INOUT) "
1777                        "or VOLATILE attribute of the dummy argument '%s'",
1778                        &a->expr->where, f->sym->name);
1779           return 0;
1780         }
1781
1782       /* C1232 (R1221) For an actual argument which is an array section or
1783          an assumed-shape array, the dummy argument shall be an assumed-
1784          shape array, if the dummy argument has the VOLATILE attribute.  */
1785
1786       if (f->sym->attr.volatile_
1787           && a->expr->symtree->n.sym->as
1788           && a->expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE
1789           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1790         {
1791           if (where)
1792             gfc_error ("Assumed-shape actual argument at %L is "
1793                        "incompatible with the non-assumed-shape "
1794                        "dummy argument '%s' due to VOLATILE attribute",
1795                        &a->expr->where,f->sym->name);
1796           return 0;
1797         }
1798
1799       if (f->sym->attr.volatile_
1800           && a->expr->ref && a->expr->ref->u.ar.type == AR_SECTION
1801           && !(f->sym->as && f->sym->as->type == AS_ASSUMED_SHAPE))
1802         {
1803           if (where)
1804             gfc_error ("Array-section actual argument at %L is "
1805                        "incompatible with the non-assumed-shape "
1806                        "dummy argument '%s' due to VOLATILE attribute",
1807                        &a->expr->where,f->sym->name);
1808           return 0;
1809         }
1810
1811       /* C1233 (R1221) For an actual argument which is a pointer array, the
1812          dummy argument shall be an assumed-shape or pointer array, if the
1813          dummy argument has the VOLATILE attribute.  */
1814
1815       if (f->sym->attr.volatile_
1816           && a->expr->symtree->n.sym->attr.pointer
1817           && a->expr->symtree->n.sym->as
1818           && !(f->sym->as
1819                && (f->sym->as->type == AS_ASSUMED_SHAPE
1820                    || f->sym->attr.pointer)))
1821         {
1822           if (where)
1823             gfc_error ("Pointer-array actual argument at %L requires "
1824                        "an assumed-shape or pointer-array dummy "
1825                        "argument '%s' due to VOLATILE attribute",
1826                        &a->expr->where,f->sym->name);
1827           return 0;
1828         }
1829
1830     match:
1831       if (a == actual)
1832         na = i;
1833
1834       new[i++] = a;
1835     }
1836
1837   /* Make sure missing actual arguments are optional.  */
1838   i = 0;
1839   for (f = formal; f; f = f->next, i++)
1840     {
1841       if (new[i] != NULL)
1842         continue;
1843       if (f->sym == NULL)
1844         {
1845           if (where)
1846             gfc_error ("Missing alternate return spec in subroutine call "
1847                        "at %L", where);
1848           return 0;
1849         }
1850       if (!f->sym->attr.optional)
1851         {
1852           if (where)
1853             gfc_error ("Missing actual argument for argument '%s' at %L",
1854                        f->sym->name, where);
1855           return 0;
1856         }
1857     }
1858
1859   /* The argument lists are compatible.  We now relink a new actual
1860      argument list with null arguments in the right places.  The head
1861      of the list remains the head.  */
1862   for (i = 0; i < n; i++)
1863     if (new[i] == NULL)
1864       new[i] = gfc_get_actual_arglist ();
1865
1866   if (na != 0)
1867     {
1868       temp = *new[0];
1869       *new[0] = *actual;
1870       *actual = temp;
1871
1872       a = new[0];
1873       new[0] = new[na];
1874       new[na] = a;
1875     }
1876
1877   for (i = 0; i < n - 1; i++)
1878     new[i]->next = new[i + 1];
1879
1880   new[i]->next = NULL;
1881
1882   if (*ap == NULL && n > 0)
1883     *ap = new[0];
1884
1885   /* Note the types of omitted optional arguments.  */
1886   for (a = actual, f = formal; a; a = a->next, f = f->next)
1887     if (a->expr == NULL && a->label == NULL)
1888       a->missing_arg_type = f->sym->ts.type;
1889
1890   return 1;
1891 }
1892
1893
1894 typedef struct
1895 {
1896   gfc_formal_arglist *f;
1897   gfc_actual_arglist *a;
1898 }
1899 argpair;
1900
1901 /* qsort comparison function for argument pairs, with the following
1902    order:
1903     - p->a->expr == NULL
1904     - p->a->expr->expr_type != EXPR_VARIABLE
1905     - growing p->a->expr->symbol.  */
1906
1907 static int
1908 pair_cmp (const void *p1, const void *p2)
1909 {
1910   const gfc_actual_arglist *a1, *a2;
1911
1912   /* *p1 and *p2 are elements of the to-be-sorted array.  */
1913   a1 = ((const argpair *) p1)->a;
1914   a2 = ((const argpair *) p2)->a;
1915   if (!a1->expr)
1916     {
1917       if (!a2->expr)
1918         return 0;
1919       return -1;
1920     }
1921   if (!a2->expr)
1922     return 1;
1923   if (a1->expr->expr_type != EXPR_VARIABLE)
1924     {
1925       if (a2->expr->expr_type != EXPR_VARIABLE)
1926         return 0;
1927       return -1;
1928     }
1929   if (a2->expr->expr_type != EXPR_VARIABLE)
1930     return 1;
1931   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1932 }
1933
1934
1935 /* Given two expressions from some actual arguments, test whether they
1936    refer to the same expression. The analysis is conservative.
1937    Returning FAILURE will produce no warning.  */
1938
1939 static try
1940 compare_actual_expr (gfc_expr *e1, gfc_expr *e2)
1941 {
1942   const gfc_ref *r1, *r2;
1943
1944   if (!e1 || !e2
1945       || e1->expr_type != EXPR_VARIABLE
1946       || e2->expr_type != EXPR_VARIABLE
1947       || e1->symtree->n.sym != e2->symtree->n.sym)
1948     return FAILURE;
1949
1950   /* TODO: improve comparison, see expr.c:show_ref().  */
1951   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1952     {
1953       if (r1->type != r2->type)
1954         return FAILURE;
1955       switch (r1->type)
1956         {
1957         case REF_ARRAY:
1958           if (r1->u.ar.type != r2->u.ar.type)
1959             return FAILURE;
1960           /* TODO: At the moment, consider only full arrays;
1961              we could do better.  */
1962           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1963             return FAILURE;
1964           break;
1965
1966         case REF_COMPONENT:
1967           if (r1->u.c.component != r2->u.c.component)
1968             return FAILURE;
1969           break;
1970
1971         case REF_SUBSTRING:
1972           return FAILURE;
1973
1974         default:
1975           gfc_internal_error ("compare_actual_expr(): Bad component code");
1976         }
1977     }
1978   if (!r1 && !r2)
1979     return SUCCESS;
1980   return FAILURE;
1981 }
1982
1983
1984 /* Given formal and actual argument lists that correspond to one
1985    another, check that identical actual arguments aren't not
1986    associated with some incompatible INTENTs.  */
1987
1988 static try
1989 check_some_aliasing (gfc_formal_arglist *f, gfc_actual_arglist *a)
1990 {
1991   sym_intent f1_intent, f2_intent;
1992   gfc_formal_arglist *f1;
1993   gfc_actual_arglist *a1;
1994   size_t n, i, j;
1995   argpair *p;
1996   try t = SUCCESS;
1997
1998   n = 0;
1999   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
2000     {
2001       if (f1 == NULL && a1 == NULL)
2002         break;
2003       if (f1 == NULL || a1 == NULL)
2004         gfc_internal_error ("check_some_aliasing(): List mismatch");
2005       n++;
2006     }
2007   if (n == 0)
2008     return t;
2009   p = (argpair *) alloca (n * sizeof (argpair));
2010
2011   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
2012     {
2013       p[i].f = f1;
2014       p[i].a = a1;
2015     }
2016
2017   qsort (p, n, sizeof (argpair), pair_cmp);
2018
2019   for (i = 0; i < n; i++)
2020     {
2021       if (!p[i].a->expr
2022           || p[i].a->expr->expr_type != EXPR_VARIABLE
2023           || p[i].a->expr->ts.type == BT_PROCEDURE)
2024         continue;
2025       f1_intent = p[i].f->sym->attr.intent;
2026       for (j = i + 1; j < n; j++)
2027         {
2028           /* Expected order after the sort.  */
2029           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
2030             gfc_internal_error ("check_some_aliasing(): corrupted data");
2031
2032           /* Are the expression the same?  */
2033           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
2034             break;
2035           f2_intent = p[j].f->sym->attr.intent;
2036           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
2037               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
2038             {
2039               gfc_warning ("Same actual argument associated with INTENT(%s) "
2040                            "argument '%s' and INTENT(%s) argument '%s' at %L",
2041                            gfc_intent_string (f1_intent), p[i].f->sym->name,
2042                            gfc_intent_string (f2_intent), p[j].f->sym->name,
2043                            &p[i].a->expr->where);
2044               t = FAILURE;
2045             }
2046         }
2047     }
2048
2049   return t;
2050 }
2051
2052
2053 /* Given a symbol of a formal argument list and an expression,
2054    return nonzero if their intents are compatible, zero otherwise.  */
2055
2056 static int
2057 compare_parameter_intent (gfc_symbol *formal, gfc_expr *actual)
2058 {
2059   if (actual->symtree->n.sym->attr.pointer && !formal->attr.pointer)
2060     return 1;
2061
2062   if (actual->symtree->n.sym->attr.intent != INTENT_IN)
2063     return 1;
2064
2065   if (formal->attr.intent == INTENT_INOUT || formal->attr.intent == INTENT_OUT)
2066     return 0;
2067
2068   return 1;
2069 }
2070
2071
2072 /* Given formal and actual argument lists that correspond to one
2073    another, check that they are compatible in the sense that intents
2074    are not mismatched.  */
2075
2076 static try
2077 check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a)
2078 {
2079   sym_intent f_intent;
2080
2081   for (;; f = f->next, a = a->next)
2082     {
2083       if (f == NULL && a == NULL)
2084         break;
2085       if (f == NULL || a == NULL)
2086         gfc_internal_error ("check_intents(): List mismatch");
2087
2088       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
2089         continue;
2090
2091       f_intent = f->sym->attr.intent;
2092
2093       if (!compare_parameter_intent(f->sym, a->expr))
2094         {
2095           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
2096                      "specifies INTENT(%s)", &a->expr->where,
2097                      gfc_intent_string (f_intent));
2098           return FAILURE;
2099         }
2100
2101       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
2102         {
2103           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
2104             {
2105               gfc_error ("Procedure argument at %L is local to a PURE "
2106                          "procedure and is passed to an INTENT(%s) argument",
2107                          &a->expr->where, gfc_intent_string (f_intent));
2108               return FAILURE;
2109             }
2110
2111           if (a->expr->symtree->n.sym->attr.pointer)
2112             {
2113               gfc_error ("Procedure argument at %L is local to a PURE "
2114                          "procedure and has the POINTER attribute",
2115                          &a->expr->where);
2116               return FAILURE;
2117             }
2118         }
2119     }
2120
2121   return SUCCESS;
2122 }
2123
2124
2125 /* Check how a procedure is used against its interface.  If all goes
2126    well, the actual argument list will also end up being properly
2127    sorted.  */
2128
2129 void
2130 gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
2131 {
2132
2133   /* Warn about calls with an implicit interface.  */
2134   if (gfc_option.warn_implicit_interface
2135       && sym->attr.if_source == IFSRC_UNKNOWN)
2136     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
2137                  sym->name, where);
2138
2139   if (sym->attr.if_source == IFSRC_UNKNOWN
2140       || !compare_actual_formal (ap, sym->formal, 0,
2141                                  sym->attr.elemental, where))
2142     return;
2143
2144   check_intents (sym->formal, *ap);
2145   if (gfc_option.warn_aliasing)
2146     check_some_aliasing (sym->formal, *ap);
2147 }
2148
2149
2150 /* Given an interface pointer and an actual argument list, search for
2151    a formal argument list that matches the actual.  If found, returns
2152    a pointer to the symbol of the correct interface.  Returns NULL if
2153    not found.  */
2154
2155 gfc_symbol *
2156 gfc_search_interface (gfc_interface *intr, int sub_flag,
2157                       gfc_actual_arglist **ap)
2158 {
2159   int r;
2160
2161   for (; intr; intr = intr->next)
2162     {
2163       if (sub_flag && intr->sym->attr.function)
2164         continue;
2165       if (!sub_flag && intr->sym->attr.subroutine)
2166         continue;
2167
2168       r = !intr->sym->attr.elemental;
2169
2170       if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
2171         {
2172           check_intents (intr->sym->formal, *ap);
2173           if (gfc_option.warn_aliasing)
2174             check_some_aliasing (intr->sym->formal, *ap);
2175           return intr->sym;
2176         }
2177     }
2178
2179   return NULL;
2180 }
2181
2182
2183 /* Do a brute force recursive search for a symbol.  */
2184
2185 static gfc_symtree *
2186 find_symtree0 (gfc_symtree *root, gfc_symbol *sym)
2187 {
2188   gfc_symtree * st;
2189
2190   if (root->n.sym == sym)
2191     return root;
2192
2193   st = NULL;
2194   if (root->left)
2195     st = find_symtree0 (root->left, sym);
2196   if (root->right && ! st)
2197     st = find_symtree0 (root->right, sym);
2198   return st;
2199 }
2200
2201
2202 /* Find a symtree for a symbol.  */
2203
2204 static gfc_symtree *
2205 find_sym_in_symtree (gfc_symbol *sym)
2206 {
2207   gfc_symtree *st;
2208   gfc_namespace *ns;
2209
2210   /* First try to find it by name.  */
2211   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
2212   if (st && st->n.sym == sym)
2213     return st;
2214
2215   /* If it's been renamed, resort to a brute-force search.  */
2216   /* TODO: avoid having to do this search.  If the symbol doesn't exist
2217      in the symtree for the current namespace, it should probably be added.  */
2218   for (ns = gfc_current_ns; ns; ns = ns->parent)
2219     {
2220       st = find_symtree0 (ns->sym_root, sym);
2221       if (st)
2222         return st;
2223     }
2224   gfc_internal_error ("Unable to find symbol %s", sym->name);
2225   /* Not reached.  */
2226 }
2227
2228
2229 /* This subroutine is called when an expression is being resolved.
2230    The expression node in question is either a user defined operator
2231    or an intrinsic operator with arguments that aren't compatible
2232    with the operator.  This subroutine builds an actual argument list
2233    corresponding to the operands, then searches for a compatible
2234    interface.  If one is found, the expression node is replaced with
2235    the appropriate function call.  */
2236
2237 try
2238 gfc_extend_expr (gfc_expr *e)
2239 {
2240   gfc_actual_arglist *actual;
2241   gfc_symbol *sym;
2242   gfc_namespace *ns;
2243   gfc_user_op *uop;
2244   gfc_intrinsic_op i;
2245
2246   sym = NULL;
2247
2248   actual = gfc_get_actual_arglist ();
2249   actual->expr = e->value.op.op1;
2250
2251   if (e->value.op.op2 != NULL)
2252     {
2253       actual->next = gfc_get_actual_arglist ();
2254       actual->next->expr = e->value.op.op2;
2255     }
2256
2257   i = fold_unary (e->value.op.operator);
2258
2259   if (i == INTRINSIC_USER)
2260     {
2261       for (ns = gfc_current_ns; ns; ns = ns->parent)
2262         {
2263           uop = gfc_find_uop (e->value.op.uop->name, ns);
2264           if (uop == NULL)
2265             continue;
2266
2267           sym = gfc_search_interface (uop->operator, 0, &actual);
2268           if (sym != NULL)
2269             break;
2270         }
2271     }
2272   else
2273     {
2274       for (ns = gfc_current_ns; ns; ns = ns->parent)
2275         {
2276           /* Due to the distinction between '==' and '.eq.' and friends, one has
2277              to check if either is defined.  */
2278           switch (i)
2279             {
2280               case INTRINSIC_EQ:
2281               case INTRINSIC_EQ_OS:
2282                 sym = gfc_search_interface (ns->operator[INTRINSIC_EQ], 0, &actual);
2283                 if (sym == NULL)
2284                   sym = gfc_search_interface (ns->operator[INTRINSIC_EQ_OS], 0, &actual);
2285                 break;
2286
2287               case INTRINSIC_NE:
2288               case INTRINSIC_NE_OS:
2289                 sym = gfc_search_interface (ns->operator[INTRINSIC_NE], 0, &actual);
2290                 if (sym == NULL)
2291                   sym = gfc_search_interface (ns->operator[INTRINSIC_NE_OS], 0, &actual);
2292                 break;
2293
2294               case INTRINSIC_GT:
2295               case INTRINSIC_GT_OS:
2296                 sym = gfc_search_interface (ns->operator[INTRINSIC_GT], 0, &actual);
2297                 if (sym == NULL)
2298                   sym = gfc_search_interface (ns->operator[INTRINSIC_GT_OS], 0, &actual);
2299                 break;
2300
2301               case INTRINSIC_GE:
2302               case INTRINSIC_GE_OS:
2303                 sym = gfc_search_interface (ns->operator[INTRINSIC_GE], 0, &actual);
2304                 if (sym == NULL)
2305                   sym = gfc_search_interface (ns->operator[INTRINSIC_GE_OS], 0, &actual);
2306                 break;
2307
2308               case INTRINSIC_LT:
2309               case INTRINSIC_LT_OS:
2310                 sym = gfc_search_interface (ns->operator[INTRINSIC_LT], 0, &actual);
2311                 if (sym == NULL)
2312                   sym = gfc_search_interface (ns->operator[INTRINSIC_LT_OS], 0, &actual);
2313                 break;
2314
2315               case INTRINSIC_LE:
2316               case INTRINSIC_LE_OS:
2317                 sym = gfc_search_interface (ns->operator[INTRINSIC_LE], 0, &actual);
2318                 if (sym == NULL)
2319                   sym = gfc_search_interface (ns->operator[INTRINSIC_LE_OS], 0, &actual);
2320                 break;
2321
2322               default:
2323                 sym = gfc_search_interface (ns->operator[i], 0, &actual);
2324             }
2325
2326           if (sym != NULL)
2327             break;
2328         }
2329     }
2330
2331   if (sym == NULL)
2332     {
2333       /* Don't use gfc_free_actual_arglist().  */
2334       if (actual->next != NULL)
2335         gfc_free (actual->next);
2336       gfc_free (actual);
2337
2338       return FAILURE;
2339     }
2340
2341   /* Change the expression node to a function call.  */
2342   e->expr_type = EXPR_FUNCTION;
2343   e->symtree = find_sym_in_symtree (sym);
2344   e->value.function.actual = actual;
2345   e->value.function.esym = NULL;
2346   e->value.function.isym = NULL;
2347   e->value.function.name = NULL;
2348
2349   if (gfc_pure (NULL) && !gfc_pure (sym))
2350     {
2351       gfc_error ("Function '%s' called in lieu of an operator at %L must "
2352                  "be PURE", sym->name, &e->where);
2353       return FAILURE;
2354     }
2355
2356   if (gfc_resolve_expr (e) == FAILURE)
2357     return FAILURE;
2358
2359   return SUCCESS;
2360 }
2361
2362
2363 /* Tries to replace an assignment code node with a subroutine call to
2364    the subroutine associated with the assignment operator.  Return
2365    SUCCESS if the node was replaced.  On FAILURE, no error is
2366    generated.  */
2367
2368 try
2369 gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
2370 {
2371   gfc_actual_arglist *actual;
2372   gfc_expr *lhs, *rhs;
2373   gfc_symbol *sym;
2374
2375   lhs = c->expr;
2376   rhs = c->expr2;
2377
2378   /* Don't allow an intrinsic assignment to be replaced.  */
2379   if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
2380       && (lhs->ts.type == rhs->ts.type
2381           || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))
2382     return FAILURE;
2383
2384   actual = gfc_get_actual_arglist ();
2385   actual->expr = lhs;
2386
2387   actual->next = gfc_get_actual_arglist ();
2388   actual->next->expr = rhs;
2389
2390   sym = NULL;
2391
2392   for (; ns; ns = ns->parent)
2393     {
2394       sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
2395       if (sym != NULL)
2396         break;
2397     }
2398
2399   if (sym == NULL)
2400     {
2401       gfc_free (actual->next);
2402       gfc_free (actual);
2403       return FAILURE;
2404     }
2405
2406   /* Replace the assignment with the call.  */
2407   c->op = EXEC_ASSIGN_CALL;
2408   c->symtree = find_sym_in_symtree (sym);
2409   c->expr = NULL;
2410   c->expr2 = NULL;
2411   c->ext.actual = actual;
2412
2413   return SUCCESS;
2414 }
2415
2416
2417 /* Make sure that the interface just parsed is not already present in
2418    the given interface list.  Ambiguity isn't checked yet since module
2419    procedures can be present without interfaces.  */
2420
2421 static try
2422 check_new_interface (gfc_interface *base, gfc_symbol *new)
2423 {
2424   gfc_interface *ip;
2425
2426   for (ip = base; ip; ip = ip->next)
2427     {
2428       if (ip->sym == new)
2429         {
2430           gfc_error ("Entity '%s' at %C is already present in the interface",
2431                      new->name);
2432           return FAILURE;
2433         }
2434     }
2435
2436   return SUCCESS;
2437 }
2438
2439
2440 /* Add a symbol to the current interface.  */
2441
2442 try
2443 gfc_add_interface (gfc_symbol *new)
2444 {
2445   gfc_interface **head, *intr;
2446   gfc_namespace *ns;
2447   gfc_symbol *sym;
2448
2449   switch (current_interface.type)
2450     {
2451     case INTERFACE_NAMELESS:
2452       return SUCCESS;
2453
2454     case INTERFACE_INTRINSIC_OP:
2455       for (ns = current_interface.ns; ns; ns = ns->parent)
2456         switch (current_interface.op)
2457           {
2458             case INTRINSIC_EQ:
2459             case INTRINSIC_EQ_OS:
2460               if (check_new_interface (ns->operator[INTRINSIC_EQ], new) == FAILURE ||
2461                   check_new_interface (ns->operator[INTRINSIC_EQ_OS], new) == FAILURE)
2462                 return FAILURE;
2463               break;
2464
2465             case INTRINSIC_NE:
2466             case INTRINSIC_NE_OS:
2467               if (check_new_interface (ns->operator[INTRINSIC_NE], new) == FAILURE ||
2468                   check_new_interface (ns->operator[INTRINSIC_NE_OS], new) == FAILURE)
2469                 return FAILURE;
2470               break;
2471
2472             case INTRINSIC_GT:
2473             case INTRINSIC_GT_OS:
2474               if (check_new_interface (ns->operator[INTRINSIC_GT], new) == FAILURE ||
2475                   check_new_interface (ns->operator[INTRINSIC_GT_OS], new) == FAILURE)
2476                 return FAILURE;
2477               break;
2478
2479             case INTRINSIC_GE:
2480             case INTRINSIC_GE_OS:
2481               if (check_new_interface (ns->operator[INTRINSIC_GE], new) == FAILURE ||
2482                   check_new_interface (ns->operator[INTRINSIC_GE_OS], new) == FAILURE)
2483                 return FAILURE;
2484               break;
2485
2486             case INTRINSIC_LT:
2487             case INTRINSIC_LT_OS:
2488               if (check_new_interface (ns->operator[INTRINSIC_LT], new) == FAILURE ||
2489                   check_new_interface (ns->operator[INTRINSIC_LT_OS], new) == FAILURE)
2490                 return FAILURE;
2491               break;
2492
2493             case INTRINSIC_LE:
2494             case INTRINSIC_LE_OS:
2495               if (check_new_interface (ns->operator[INTRINSIC_LE], new) == FAILURE ||
2496                   check_new_interface (ns->operator[INTRINSIC_LE_OS], new) == FAILURE)
2497                 return FAILURE;
2498               break;
2499
2500             default:
2501               if (check_new_interface (ns->operator[current_interface.op], new) == FAILURE)
2502                 return FAILURE;
2503           }
2504
2505       head = &current_interface.ns->operator[current_interface.op];
2506       break;
2507
2508     case INTERFACE_GENERIC:
2509       for (ns = current_interface.ns; ns; ns = ns->parent)
2510         {
2511           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
2512           if (sym == NULL)
2513             continue;
2514
2515           if (check_new_interface (sym->generic, new) == FAILURE)
2516             return FAILURE;
2517         }
2518
2519       head = &current_interface.sym->generic;
2520       break;
2521
2522     case INTERFACE_USER_OP:
2523       if (check_new_interface (current_interface.uop->operator, new)
2524           == FAILURE)
2525         return FAILURE;
2526
2527       head = &current_interface.uop->operator;
2528       break;
2529
2530     default:
2531       gfc_internal_error ("gfc_add_interface(): Bad interface type");
2532     }
2533
2534   intr = gfc_get_interface ();
2535   intr->sym = new;
2536   intr->where = gfc_current_locus;
2537
2538   intr->next = *head;
2539   *head = intr;
2540
2541   return SUCCESS;
2542 }
2543
2544
2545 /* Gets rid of a formal argument list.  We do not free symbols.
2546    Symbols are freed when a namespace is freed.  */
2547
2548 void
2549 gfc_free_formal_arglist (gfc_formal_arglist *p)
2550 {
2551   gfc_formal_arglist *q;
2552
2553   for (; p; p = q)
2554     {
2555       q = p->next;
2556       gfc_free (p);
2557     }
2558 }