OSDN Git Service

36c383a910b958d7b6bf2a298a2d5065c7ffdb9d
[pf3gnuchains/gcc-fork.git] / gcc / fortran / interface.c
1 /* Deal with interfaces.
2    Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation, Inc.
3    Contributed by Andy Vaught
4
5 This file is part of GCC.
6
7 GCC is free software; you can redistribute it and/or modify it under
8 the terms of the GNU General Public License as published by the Free
9 Software Foundation; either version 2, or (at your option) any later
10 version.
11
12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15 for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING.  If not, write to the Free
19 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
20 02110-1301, USA.  */
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
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 (gfc_intrinsic_op operator)
100 {
101
102   switch (operator)
103     {
104     case INTRINSIC_UPLUS:
105       operator = INTRINSIC_PLUS;
106       break;
107     case INTRINSIC_UMINUS:
108       operator = INTRINSIC_MINUS;
109       break;
110     default:
111       break;
112     }
113
114   return operator;
115 }
116
117
118 /* Match a generic specification.  Depending on which type of
119    interface is found, the 'name' or 'operator' pointers may be set.
120    This subroutine doesn't return MATCH_NO.  */
121
122 match
123 gfc_match_generic_spec (interface_type * type,
124                         char *name,
125                         gfc_intrinsic_op *operator)
126 {
127   char buffer[GFC_MAX_SYMBOL_LEN + 1];
128   match m;
129   gfc_intrinsic_op i;
130
131   if (gfc_match (" assignment ( = )") == MATCH_YES)
132     {
133       *type = INTERFACE_INTRINSIC_OP;
134       *operator = INTRINSIC_ASSIGN;
135       return MATCH_YES;
136     }
137
138   if (gfc_match (" operator ( %o )", &i) == MATCH_YES)
139     {                           /* Operator i/f */
140       *type = INTERFACE_INTRINSIC_OP;
141       *operator = fold_unary (i);
142       return MATCH_YES;
143     }
144
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 forms of an interface statement.  */
181
182 match
183 gfc_match_interface (void)
184 {
185   char name[GFC_MAX_SYMBOL_LEN + 1];
186   interface_type type;
187   gfc_symbol *sym;
188   gfc_intrinsic_op operator;
189   match m;
190
191   m = gfc_match_space ();
192
193   if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
194     return MATCH_ERROR;
195
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
201           && m != MATCH_YES))
202     {
203       gfc_error
204         ("Syntax error: Trailing garbage in INTERFACE statement at %C");
205       return MATCH_ERROR;
206     }
207
208   current_interface.type = type;
209
210   switch (type)
211     {
212     case INTERFACE_GENERIC:
213       if (gfc_get_symbol (name, NULL, &sym))
214         return MATCH_ERROR;
215
216       if (!sym->attr.generic 
217           && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
218         return MATCH_ERROR;
219
220       current_interface.sym = gfc_new_block = sym;
221       break;
222
223     case INTERFACE_USER_OP:
224       current_interface.uop = gfc_get_uop (name);
225       break;
226
227     case INTERFACE_INTRINSIC_OP:
228       current_interface.op = operator;
229       break;
230
231     case INTERFACE_NAMELESS:
232       break;
233     }
234
235   return MATCH_YES;
236 }
237
238
239 /* Match the different sort of generic-specs that can be present after
240    the END INTERFACE itself.  */
241
242 match
243 gfc_match_end_interface (void)
244 {
245   char name[GFC_MAX_SYMBOL_LEN + 1];
246   interface_type type;
247   gfc_intrinsic_op operator;
248   match m;
249
250   m = gfc_match_space ();
251
252   if (gfc_match_generic_spec (&type, name, &operator) == MATCH_ERROR)
253     return MATCH_ERROR;
254
255   /* If we're not looking at the end of the statement now, or if this
256      is not a nameless interface but we did not see a space, punt.  */
257   if (gfc_match_eos () != MATCH_YES
258       || (type != INTERFACE_NAMELESS
259           && m != MATCH_YES))
260     {
261       gfc_error
262         ("Syntax error: Trailing garbage in END INTERFACE statement at %C");
263       return MATCH_ERROR;
264     }
265
266   m = MATCH_YES;
267
268   switch (current_interface.type)
269     {
270     case INTERFACE_NAMELESS:
271       if (type != current_interface.type)
272         {
273           gfc_error ("Expected a nameless interface at %C");
274           m = MATCH_ERROR;
275         }
276
277       break;
278
279     case INTERFACE_INTRINSIC_OP:
280       if (type != current_interface.type || operator != current_interface.op)
281         {
282
283           if (current_interface.op == INTRINSIC_ASSIGN)
284             gfc_error ("Expected 'END INTERFACE ASSIGNMENT (=)' at %C");
285           else
286             gfc_error ("Expecting 'END INTERFACE OPERATOR (%s)' at %C",
287                        gfc_op2string (current_interface.op));
288
289           m = MATCH_ERROR;
290         }
291
292       break;
293
294     case INTERFACE_USER_OP:
295       /* Comparing the symbol node names is OK because only use-associated
296          symbols can be renamed.  */
297       if (type != current_interface.type
298           || strcmp (current_interface.sym->name, name) != 0)
299         {
300           gfc_error ("Expecting 'END INTERFACE OPERATOR (.%s.)' at %C",
301                      current_interface.sym->name);
302           m = MATCH_ERROR;
303         }
304
305       break;
306
307     case INTERFACE_GENERIC:
308       if (type != current_interface.type
309           || strcmp (current_interface.sym->name, name) != 0)
310         {
311           gfc_error ("Expecting 'END INTERFACE %s' at %C",
312                      current_interface.sym->name);
313           m = MATCH_ERROR;
314         }
315
316       break;
317     }
318
319   return m;
320 }
321
322
323 /* Compare two typespecs, recursively if necessary.  */
324
325 int
326 gfc_compare_types (gfc_typespec * ts1, gfc_typespec * ts2)
327 {
328   gfc_component *dt1, *dt2;
329
330   if (ts1->type != ts2->type)
331     return 0;
332   if (ts1->type != BT_DERIVED)
333     return (ts1->kind == ts2->kind);
334
335   /* Compare derived types.  */
336   if (ts1->derived == ts2->derived)
337     return 1;
338
339   /* Special case for comparing derived types across namespaces.  If the
340      true names and module names are the same and the module name is
341      nonnull, then they are equal.  */
342   if (strcmp (ts1->derived->name, ts2->derived->name) == 0
343       && ((ts1->derived->module == NULL && ts2->derived->module == NULL)
344           || (ts1->derived != NULL && ts2->derived != NULL
345               && strcmp (ts1->derived->module, ts2->derived->module) == 0)))
346     return 1;
347
348   /* Compare type via the rules of the standard.  Both types must have
349      the SEQUENCE attribute to be equal.  */
350
351   if (strcmp (ts1->derived->name, ts2->derived->name))
352     return 0;
353
354   dt1 = ts1->derived->components;
355   dt2 = ts2->derived->components;
356
357   if (ts1->derived->attr.sequence == 0 || ts2->derived->attr.sequence == 0)
358     return 0;
359
360   /* Since subtypes of SEQUENCE types must be SEQUENCE types as well, a
361      simple test can speed things up.  Otherwise, lots of things have to
362      match.  */
363   for (;;)
364     {
365       if (strcmp (dt1->name, dt2->name) != 0)
366         return 0;
367
368       if (dt1->pointer != dt2->pointer)
369         return 0;
370
371       if (dt1->dimension != dt2->dimension)
372         return 0;
373
374       if (dt1->dimension && gfc_compare_array_spec (dt1->as, dt2->as) == 0)
375         return 0;
376
377       if (gfc_compare_types (&dt1->ts, &dt2->ts) == 0)
378         return 0;
379
380       dt1 = dt1->next;
381       dt2 = dt2->next;
382
383       if (dt1 == NULL && dt2 == NULL)
384         break;
385       if (dt1 == NULL || dt2 == NULL)
386         return 0;
387     }
388
389   return 1;
390 }
391
392
393 /* Given two symbols that are formal arguments, compare their ranks
394    and types.  Returns nonzero if they have the same rank and type,
395    zero otherwise.  */
396
397 static int
398 compare_type_rank (gfc_symbol * s1, gfc_symbol * s2)
399 {
400   int r1, r2;
401
402   r1 = (s1->as != NULL) ? s1->as->rank : 0;
403   r2 = (s2->as != NULL) ? s2->as->rank : 0;
404
405   if (r1 != r2)
406     return 0;                   /* Ranks differ */
407
408   return gfc_compare_types (&s1->ts, &s2->ts);
409 }
410
411
412 static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
413
414 /* Given two symbols that are formal arguments, compare their types
415    and rank and their formal interfaces if they are both dummy
416    procedures.  Returns nonzero if the same, zero if different.  */
417
418 static int
419 compare_type_rank_if (gfc_symbol * s1, gfc_symbol * s2)
420 {
421
422   if (s1->attr.flavor != FL_PROCEDURE && s2->attr.flavor != FL_PROCEDURE)
423     return compare_type_rank (s1, s2);
424
425   if (s1->attr.flavor != FL_PROCEDURE || s2->attr.flavor != FL_PROCEDURE)
426     return 0;
427
428   /* At this point, both symbols are procedures.  */
429   if ((s1->attr.function == 0 && s1->attr.subroutine == 0)
430       || (s2->attr.function == 0 && s2->attr.subroutine == 0))
431     return 0;
432
433   if (s1->attr.function != s2->attr.function
434       || s1->attr.subroutine != s2->attr.subroutine)
435     return 0;
436
437   if (s1->attr.function && compare_type_rank (s1, s2) == 0)
438     return 0;
439
440   return compare_interfaces (s1, s2, 0);        /* Recurse! */
441 }
442
443
444 /* Given a formal argument list and a keyword name, search the list
445    for that keyword.  Returns the correct symbol node if found, NULL
446    if not found.  */
447
448 static gfc_symbol *
449 find_keyword_arg (const char *name, gfc_formal_arglist * f)
450 {
451
452   for (; f; f = f->next)
453     if (strcmp (f->sym->name, name) == 0)
454       return f->sym;
455
456   return NULL;
457 }
458
459
460 /******** Interface checking subroutines **********/
461
462
463 /* Given an operator interface and the operator, make sure that all
464    interfaces for that operator are legal.  */
465
466 static void
467 check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
468 {
469   gfc_formal_arglist *formal;
470   sym_intent i1, i2;
471   gfc_symbol *sym;
472   bt t1, t2;
473   int args;
474
475   if (intr == NULL)
476     return;
477
478   args = 0;
479   t1 = t2 = BT_UNKNOWN;
480   i1 = i2 = INTENT_UNKNOWN;
481
482   for (formal = intr->sym->formal; formal; formal = formal->next)
483     {
484       sym = formal->sym;
485
486       if (args == 0)
487         {
488           t1 = sym->ts.type;
489           i1 = sym->attr.intent;
490         }
491       if (args == 1)
492         {
493           t2 = sym->ts.type;
494           i2 = sym->attr.intent;
495         }
496       args++;
497     }
498
499   if (args == 0 || args > 2)
500     goto num_args;
501
502   sym = intr->sym;
503
504   if (operator == INTRINSIC_ASSIGN)
505     {
506       if (!sym->attr.subroutine)
507         {
508           gfc_error
509             ("Assignment operator interface at %L must be a SUBROUTINE",
510              &intr->where);
511           return;
512         }
513     }
514   else
515     {
516       if (!sym->attr.function)
517         {
518           gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
519                      &intr->where);
520           return;
521         }
522     }
523
524   switch (operator)
525     {
526     case INTRINSIC_PLUS:        /* Numeric unary or binary */
527     case INTRINSIC_MINUS:
528       if ((args == 1)
529           && (t1 == BT_INTEGER
530               || t1 == BT_REAL
531               || t1 == BT_COMPLEX))
532         goto bad_repl;
533
534       if ((args == 2)
535           && (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
536           && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
537         goto bad_repl;
538
539       break;
540
541     case INTRINSIC_POWER:       /* Binary numeric */
542     case INTRINSIC_TIMES:
543     case INTRINSIC_DIVIDE:
544
545     case INTRINSIC_EQ:
546     case INTRINSIC_NE:
547       if (args == 1)
548         goto num_args;
549
550       if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
551           && (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
552         goto bad_repl;
553
554       break;
555
556     case INTRINSIC_GE:          /* Binary numeric operators that do not support */
557     case INTRINSIC_LE:          /* complex numbers */
558     case INTRINSIC_LT:
559     case INTRINSIC_GT:
560       if (args == 1)
561         goto num_args;
562
563       if ((t1 == BT_INTEGER || t1 == BT_REAL)
564           && (t2 == BT_INTEGER || t2 == BT_REAL))
565         goto bad_repl;
566
567       break;
568
569     case INTRINSIC_OR:          /* Binary logical */
570     case INTRINSIC_AND:
571     case INTRINSIC_EQV:
572     case INTRINSIC_NEQV:
573       if (args == 1)
574         goto num_args;
575       if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
576         goto bad_repl;
577       break;
578
579     case INTRINSIC_NOT: /* Unary logical */
580       if (args != 1)
581         goto num_args;
582       if (t1 == BT_LOGICAL)
583         goto bad_repl;
584       break;
585
586     case INTRINSIC_CONCAT:      /* Binary string */
587       if (args != 2)
588         goto num_args;
589       if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
590         goto bad_repl;
591       break;
592
593     case INTRINSIC_ASSIGN:      /* Class by itself */
594       if (args != 2)
595         goto num_args;
596       break;
597     default:
598       gfc_internal_error ("check_operator_interface(): Bad operator");
599     }
600
601   /* Check intents on operator interfaces.  */
602   if (operator == INTRINSIC_ASSIGN)
603     {
604       if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
605         gfc_error ("First argument of defined assignment at %L must be "
606                    "INTENT(IN) or INTENT(INOUT)", &intr->where);
607
608       if (i2 != INTENT_IN)
609         gfc_error ("Second argument of defined assignment at %L must be "
610                    "INTENT(IN)", &intr->where);
611     }
612   else
613     {
614       if (i1 != INTENT_IN)
615         gfc_error ("First argument of operator interface at %L must be "
616                    "INTENT(IN)", &intr->where);
617
618       if (args == 2 && i2 != INTENT_IN)
619         gfc_error ("Second argument of operator interface at %L must be "
620                    "INTENT(IN)", &intr->where);
621     }
622
623   return;
624
625 bad_repl:
626   gfc_error ("Operator interface at %L conflicts with intrinsic interface",
627              &intr->where);
628   return;
629
630 num_args:
631   gfc_error ("Operator interface at %L has the wrong number of arguments",
632              &intr->where);
633   return;
634 }
635
636
637 /* Given a pair of formal argument lists, we see if the two lists can
638    be distinguished by counting the number of nonoptional arguments of
639    a given type/rank in f1 and seeing if there are less then that
640    number of those arguments in f2 (including optional arguments).
641    Since this test is asymmetric, it has to be called twice to make it
642    symmetric.  Returns nonzero if the argument lists are incompatible
643    by this test.  This subroutine implements rule 1 of section
644    14.1.2.3.  */
645
646 static int
647 count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
648 {
649   int rc, ac1, ac2, i, j, k, n1;
650   gfc_formal_arglist *f;
651
652   typedef struct
653   {
654     int flag;
655     gfc_symbol *sym;
656   }
657   arginfo;
658
659   arginfo *arg;
660
661   n1 = 0;
662
663   for (f = f1; f; f = f->next)
664     n1++;
665
666   /* Build an array of integers that gives the same integer to
667      arguments of the same type/rank.  */
668   arg = gfc_getmem (n1 * sizeof (arginfo));
669
670   f = f1;
671   for (i = 0; i < n1; i++, f = f->next)
672     {
673       arg[i].flag = -1;
674       arg[i].sym = f->sym;
675     }
676
677   k = 0;
678
679   for (i = 0; i < n1; i++)
680     {
681       if (arg[i].flag != -1)
682         continue;
683
684       if (arg[i].sym->attr.optional)
685         continue;               /* Skip optional arguments */
686
687       arg[i].flag = k;
688
689       /* Find other nonoptional arguments of the same type/rank.  */
690       for (j = i + 1; j < n1; j++)
691         if (!arg[j].sym->attr.optional
692             && compare_type_rank_if (arg[i].sym, arg[j].sym))
693           arg[j].flag = k;
694
695       k++;
696     }
697
698   /* Now loop over each distinct type found in f1.  */
699   k = 0;
700   rc = 0;
701
702   for (i = 0; i < n1; i++)
703     {
704       if (arg[i].flag != k)
705         continue;
706
707       ac1 = 1;
708       for (j = i + 1; j < n1; j++)
709         if (arg[j].flag == k)
710           ac1++;
711
712       /* Count the number of arguments in f2 with that type, including
713          those that are optional.  */
714       ac2 = 0;
715
716       for (f = f2; f; f = f->next)
717         if (compare_type_rank_if (arg[i].sym, f->sym))
718           ac2++;
719
720       if (ac1 > ac2)
721         {
722           rc = 1;
723           break;
724         }
725
726       k++;
727     }
728
729   gfc_free (arg);
730
731   return rc;
732 }
733
734
735 /* Perform the abbreviated correspondence test for operators.  The
736    arguments cannot be optional and are always ordered correctly,
737    which makes this test much easier than that for generic tests.
738
739    This subroutine is also used when comparing a formal and actual
740    argument list when an actual parameter is a dummy procedure.  At
741    that point, two formal interfaces must be compared for equality
742    which is what happens here.  */
743
744 static int
745 operator_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
746 {
747   for (;;)
748     {
749       if (f1 == NULL && f2 == NULL)
750         break;
751       if (f1 == NULL || f2 == NULL)
752         return 1;
753
754       if (!compare_type_rank (f1->sym, f2->sym))
755         return 1;
756
757       f1 = f1->next;
758       f2 = f2->next;
759     }
760
761   return 0;
762 }
763
764
765 /* Perform the correspondence test in rule 2 of section 14.1.2.3.
766    Returns zero if no argument is found that satisfies rule 2, nonzero
767    otherwise.
768
769    This test is also not symmetric in f1 and f2 and must be called
770    twice.  This test finds problems caused by sorting the actual
771    argument list with keywords.  For example:
772
773    INTERFACE FOO
774        SUBROUTINE F1(A, B)
775            INTEGER :: A ; REAL :: B
776        END SUBROUTINE F1
777
778        SUBROUTINE F2(B, A)
779            INTEGER :: A ; REAL :: B
780        END SUBROUTINE F1
781    END INTERFACE FOO
782
783    At this point, 'CALL FOO(A=1, B=1.0)' is ambiguous.  */
784
785 static int
786 generic_correspondence (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
787 {
788
789   gfc_formal_arglist *f2_save, *g;
790   gfc_symbol *sym;
791
792   f2_save = f2;
793
794   while (f1)
795     {
796       if (f1->sym->attr.optional)
797         goto next;
798
799       if (f2 != NULL && compare_type_rank (f1->sym, f2->sym))
800         goto next;
801
802       /* Now search for a disambiguating keyword argument starting at
803          the current non-match.  */
804       for (g = f1; g; g = g->next)
805         {
806           if (g->sym->attr.optional)
807             continue;
808
809           sym = find_keyword_arg (g->sym->name, f2_save);
810           if (sym == NULL || !compare_type_rank (g->sym, sym))
811             return 1;
812         }
813
814     next:
815       f1 = f1->next;
816       if (f2 != NULL)
817         f2 = f2->next;
818     }
819
820   return 0;
821 }
822
823
824 /* 'Compare' two formal interfaces associated with a pair of symbols.
825    We return nonzero if there exists an actual argument list that
826    would be ambiguous between the two interfaces, zero otherwise.  */
827
828 static int
829 compare_interfaces (gfc_symbol * s1, gfc_symbol * s2, int generic_flag)
830 {
831   gfc_formal_arglist *f1, *f2;
832
833   if (s1->attr.function != s2->attr.function
834       && s1->attr.subroutine != s2->attr.subroutine)
835     return 0;                   /* disagreement between function/subroutine */
836
837   f1 = s1->formal;
838   f2 = s2->formal;
839
840   if (f1 == NULL && f2 == NULL)
841     return 1;                   /* Special case */
842
843   if (count_types_test (f1, f2))
844     return 0;
845   if (count_types_test (f2, f1))
846     return 0;
847
848   if (generic_flag)
849     {
850       if (generic_correspondence (f1, f2))
851         return 0;
852       if (generic_correspondence (f2, f1))
853         return 0;
854     }
855   else
856     {
857       if (operator_correspondence (f1, f2))
858         return 0;
859     }
860
861   return 1;
862 }
863
864
865 /* Given a pointer to an interface pointer, remove duplicate
866    interfaces and make sure that all symbols are either functions or
867    subroutines.  Returns nonzero if something goes wrong.  */
868
869 static int
870 check_interface0 (gfc_interface * p, const char *interface_name)
871 {
872   gfc_interface *psave, *q, *qlast;
873
874   psave = p;
875   /* Make sure all symbols in the interface have been defined as
876      functions or subroutines.  */
877   for (; p; p = p->next)
878     if (!p->sym->attr.function && !p->sym->attr.subroutine)
879       {
880         gfc_error ("Procedure '%s' in %s at %L is neither function nor "
881                    "subroutine", p->sym->name, interface_name,
882                    &p->sym->declared_at);
883         return 1;
884       }
885   p = psave;
886
887   /* Remove duplicate interfaces in this interface list.  */
888   for (; p; p = p->next)
889     {
890       qlast = p;
891
892       for (q = p->next; q;)
893         {
894           if (p->sym != q->sym)
895             {
896               qlast = q;
897               q = q->next;
898
899             }
900           else
901             {
902               /* Duplicate interface */
903               qlast->next = q->next;
904               gfc_free (q);
905               q = qlast->next;
906             }
907         }
908     }
909
910   return 0;
911 }
912
913
914 /* Check lists of interfaces to make sure that no two interfaces are
915    ambiguous.  Duplicate interfaces (from the same symbol) are OK
916    here.  */
917
918 static int
919 check_interface1 (gfc_interface * p, gfc_interface * q,
920                   int generic_flag, const char *interface_name)
921 {
922
923   for (; p; p = p->next)
924     for (; q; q = q->next)
925       {
926         if (p->sym == q->sym)
927           continue;             /* Duplicates OK here */
928
929         if (strcmp (p->sym->name, q->sym->name) == 0
930             && strcmp (p->sym->module, q->sym->module) == 0)
931           continue;
932
933         if (compare_interfaces (p->sym, q->sym, generic_flag))
934           {
935             gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
936                        p->sym->name, q->sym->name, interface_name, &p->where);
937             return 1;
938           }
939       }
940
941   return 0;
942 }
943
944
945 /* Check the generic and operator interfaces of symbols to make sure
946    that none of the interfaces conflict.  The check has to be done
947    after all of the symbols are actually loaded.  */
948
949 static void
950 check_sym_interfaces (gfc_symbol * sym)
951 {
952   char interface_name[100];
953   gfc_symbol *s2;
954
955   if (sym->ns != gfc_current_ns)
956     return;
957
958   if (sym->generic != NULL)
959     {
960       sprintf (interface_name, "generic interface '%s'", sym->name);
961       if (check_interface0 (sym->generic, interface_name))
962         return;
963
964       s2 = sym;
965       while (s2 != NULL)
966         {
967           if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
968             return;
969
970           if (s2->ns->parent == NULL)
971             break;
972           if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
973             break;
974         }
975     }
976 }
977
978
979 static void
980 check_uop_interfaces (gfc_user_op * uop)
981 {
982   char interface_name[100];
983   gfc_user_op *uop2;
984   gfc_namespace *ns;
985
986   sprintf (interface_name, "operator interface '%s'", uop->name);
987   if (check_interface0 (uop->operator, interface_name))
988     return;
989
990   for (ns = gfc_current_ns; ns; ns = ns->parent)
991     {
992       uop2 = gfc_find_uop (uop->name, ns);
993       if (uop2 == NULL)
994         continue;
995
996       check_interface1 (uop->operator, uop2->operator, 0, interface_name);
997     }
998 }
999
1000
1001 /* For the namespace, check generic, user operator and intrinsic
1002    operator interfaces for consistency and to remove duplicate
1003    interfaces.  We traverse the whole namespace, counting on the fact
1004    that most symbols will not have generic or operator interfaces.  */
1005
1006 void
1007 gfc_check_interfaces (gfc_namespace * ns)
1008 {
1009   gfc_namespace *old_ns, *ns2;
1010   char interface_name[100];
1011   gfc_intrinsic_op i;
1012
1013   old_ns = gfc_current_ns;
1014   gfc_current_ns = ns;
1015
1016   gfc_traverse_ns (ns, check_sym_interfaces);
1017
1018   gfc_traverse_user_op (ns, check_uop_interfaces);
1019
1020   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1021     {
1022       if (i == INTRINSIC_USER)
1023         continue;
1024
1025       if (i == INTRINSIC_ASSIGN)
1026         strcpy (interface_name, "intrinsic assignment operator");
1027       else
1028         sprintf (interface_name, "intrinsic '%s' operator",
1029                  gfc_op2string (i));
1030
1031       if (check_interface0 (ns->operator[i], interface_name))
1032         continue;
1033
1034       check_operator_interface (ns->operator[i], i);
1035
1036       for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1037         if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1038                               interface_name))
1039           break;
1040     }
1041
1042   gfc_current_ns = old_ns;
1043 }
1044
1045
1046 static int
1047 symbol_rank (gfc_symbol * sym)
1048 {
1049
1050   return (sym->as == NULL) ? 0 : sym->as->rank;
1051 }
1052
1053
1054 /* Given a symbol of a formal argument list and an expression, if the
1055    formal argument is a pointer, see if the actual argument is a
1056    pointer. Returns nonzero if compatible, zero if not compatible.  */
1057
1058 static int
1059 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1060 {
1061   symbol_attribute attr;
1062
1063   if (formal->attr.pointer)
1064     {
1065       attr = gfc_expr_attr (actual);
1066       if (!attr.pointer)
1067         return 0;
1068     }
1069
1070   return 1;
1071 }
1072
1073
1074 /* Given a symbol of a formal argument list and an expression, see if
1075    the two are compatible as arguments.  Returns nonzero if
1076    compatible, zero if not compatible.  */
1077
1078 static int
1079 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1080                    int ranks_must_agree, int is_elemental)
1081 {
1082   gfc_ref *ref;
1083
1084   if (actual->ts.type == BT_PROCEDURE)
1085     {
1086       if (formal->attr.flavor != FL_PROCEDURE)
1087         return 0;
1088
1089       if (formal->attr.function
1090           && !compare_type_rank (formal, actual->symtree->n.sym))
1091         return 0;
1092
1093       if (formal->attr.if_source == IFSRC_UNKNOWN)
1094         return 1;               /* Assume match */
1095
1096       return compare_interfaces (formal, actual->symtree->n.sym, 0);
1097     }
1098
1099   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1100       && !gfc_compare_types (&formal->ts, &actual->ts))
1101     return 0;
1102
1103   if (symbol_rank (formal) == actual->rank)
1104     return 1;
1105
1106   /* At this point the ranks didn't agree.  */
1107   if (ranks_must_agree || formal->attr.pointer)
1108     return 0;
1109
1110   if (actual->rank != 0)
1111     return is_elemental || formal->attr.dimension;
1112
1113   /* At this point, we are considering a scalar passed to an array.
1114      This is legal if the scalar is an array element of the right sort.  */
1115   if (formal->as->type == AS_ASSUMED_SHAPE)
1116     return 0;
1117
1118   for (ref = actual->ref; ref; ref = ref->next)
1119     if (ref->type == REF_SUBSTRING)
1120       return 0;
1121
1122   for (ref = actual->ref; ref; ref = ref->next)
1123     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1124       break;
1125
1126   if (ref == NULL)
1127     return 0;                   /* Not an array element */
1128
1129   return 1;
1130 }
1131
1132
1133 /* Given formal and actual argument lists, see if they are compatible.
1134    If they are compatible, the actual argument list is sorted to
1135    correspond with the formal list, and elements for missing optional
1136    arguments are inserted. If WHERE pointer is nonnull, then we issue
1137    errors when things don't match instead of just returning the status
1138    code.  */
1139
1140 static int
1141 compare_actual_formal (gfc_actual_arglist ** ap,
1142                        gfc_formal_arglist * formal,
1143                        int ranks_must_agree, int is_elemental, locus * where)
1144 {
1145   gfc_actual_arglist **new, *a, *actual, temp;
1146   gfc_formal_arglist *f;
1147   int i, n, na;
1148
1149   actual = *ap;
1150
1151   if (actual == NULL && formal == NULL)
1152     return 1;
1153
1154   n = 0;
1155   for (f = formal; f; f = f->next)
1156     n++;
1157
1158   new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1159
1160   for (i = 0; i < n; i++)
1161     new[i] = NULL;
1162
1163   na = 0;
1164   f = formal;
1165   i = 0;
1166
1167   for (a = actual; a; a = a->next, f = f->next)
1168     {
1169       if (a->name != NULL)
1170         {
1171           i = 0;
1172           for (f = formal; f; f = f->next, i++)
1173             {
1174               if (f->sym == NULL)
1175                 continue;
1176               if (strcmp (f->sym->name, a->name) == 0)
1177                 break;
1178             }
1179
1180           if (f == NULL)
1181             {
1182               if (where)
1183                 gfc_error
1184                   ("Keyword argument '%s' at %L is not in the procedure",
1185                    a->name, &a->expr->where);
1186               return 0;
1187             }
1188
1189           if (new[i] != NULL)
1190             {
1191               if (where)
1192                 gfc_error
1193                   ("Keyword argument '%s' at %L is already associated "
1194                    "with another actual argument", a->name, &a->expr->where);
1195               return 0;
1196             }
1197         }
1198
1199       if (f == NULL)
1200         {
1201           if (where)
1202             gfc_error
1203               ("More actual than formal arguments in procedure call at %L",
1204                where);
1205
1206           return 0;
1207         }
1208
1209       if (f->sym == NULL && a->expr == NULL)
1210         goto match;
1211
1212       if (f->sym == NULL)
1213         {
1214           if (where)
1215             gfc_error
1216               ("Missing alternate return spec in subroutine call at %L",
1217                where);
1218           return 0;
1219         }
1220
1221       if (a->expr == NULL)
1222         {
1223           if (where)
1224             gfc_error
1225               ("Unexpected alternate return spec in subroutine call at %L",
1226                where);
1227           return 0;
1228         }
1229
1230       if (!compare_parameter
1231           (f->sym, a->expr, ranks_must_agree, is_elemental))
1232         {
1233           if (where)
1234             gfc_error ("Type/rank mismatch in argument '%s' at %L",
1235                        f->sym->name, &a->expr->where);
1236           return 0;
1237         }
1238
1239       if (a->expr->expr_type != EXPR_NULL
1240           && compare_pointer (f->sym, a->expr) == 0)
1241         {
1242           if (where)
1243             gfc_error ("Actual argument for '%s' must be a pointer at %L",
1244                        f->sym->name, &a->expr->where);
1245           return 0;
1246         }
1247
1248     match:
1249       if (a == actual)
1250         na = i;
1251
1252       new[i++] = a;
1253     }
1254
1255   /* Make sure missing actual arguments are optional.  */
1256   i = 0;
1257   for (f = formal; f; f = f->next, i++)
1258     {
1259       if (new[i] != NULL)
1260         continue;
1261       if (!f->sym->attr.optional)
1262         {
1263           if (where)
1264             gfc_error ("Missing actual argument for argument '%s' at %L",
1265                        f->sym->name, where);
1266           return 0;
1267         }
1268     }
1269
1270   /* The argument lists are compatible.  We now relink a new actual
1271      argument list with null arguments in the right places.  The head
1272      of the list remains the head.  */
1273   for (i = 0; i < n; i++)
1274     if (new[i] == NULL)
1275       new[i] = gfc_get_actual_arglist ();
1276
1277   if (na != 0)
1278     {
1279       temp = *new[0];
1280       *new[0] = *actual;
1281       *actual = temp;
1282
1283       a = new[0];
1284       new[0] = new[na];
1285       new[na] = a;
1286     }
1287
1288   for (i = 0; i < n - 1; i++)
1289     new[i]->next = new[i + 1];
1290
1291   new[i]->next = NULL;
1292
1293   if (*ap == NULL && n > 0)
1294     *ap = new[0];
1295
1296   /* Note the types of omitted optional arguments.  */
1297   for (a = actual, f = formal; a; a = a->next, f = f->next)
1298     if (a->expr == NULL && a->label == NULL)
1299       a->missing_arg_type = f->sym->ts.type;
1300
1301   return 1;
1302 }
1303
1304
1305 typedef struct
1306 {
1307   gfc_formal_arglist *f;
1308   gfc_actual_arglist *a;
1309 }
1310 argpair;
1311
1312 /* qsort comparison function for argument pairs, with the following
1313    order:
1314     - p->a->expr == NULL
1315     - p->a->expr->expr_type != EXPR_VARIABLE
1316     - growing p->a->expr->symbol.  */
1317
1318 static int
1319 pair_cmp (const void *p1, const void *p2)
1320 {
1321   const gfc_actual_arglist *a1, *a2;
1322
1323   /* *p1 and *p2 are elements of the to-be-sorted array.  */
1324   a1 = ((const argpair *) p1)->a;
1325   a2 = ((const argpair *) p2)->a;
1326   if (!a1->expr)
1327     {
1328       if (!a2->expr)
1329         return 0;
1330       return -1;
1331     }
1332   if (!a2->expr)
1333     return 1;
1334   if (a1->expr->expr_type != EXPR_VARIABLE)
1335     {
1336       if (a2->expr->expr_type != EXPR_VARIABLE)
1337         return 0;
1338       return -1;
1339     }
1340   if (a2->expr->expr_type != EXPR_VARIABLE)
1341     return 1;
1342   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1343 }
1344
1345
1346 /* Given two expressions from some actual arguments, test whether they
1347    refer to the same expression. The analysis is conservative.
1348    Returning FAILURE will produce no warning.  */
1349
1350 static try
1351 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1352 {
1353   const gfc_ref *r1, *r2;
1354
1355   if (!e1 || !e2
1356       || e1->expr_type != EXPR_VARIABLE
1357       || e2->expr_type != EXPR_VARIABLE
1358       || e1->symtree->n.sym != e2->symtree->n.sym)
1359     return FAILURE;
1360
1361   /* TODO: improve comparison, see expr.c:show_ref().  */
1362   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1363     {
1364       if (r1->type != r2->type)
1365         return FAILURE;
1366       switch (r1->type)
1367         {
1368         case REF_ARRAY:
1369           if (r1->u.ar.type != r2->u.ar.type)
1370             return FAILURE;
1371           /* TODO: At the moment, consider only full arrays;
1372              we could do better.  */
1373           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1374             return FAILURE;
1375           break;
1376
1377         case REF_COMPONENT:
1378           if (r1->u.c.component != r2->u.c.component)
1379             return FAILURE;
1380           break;
1381
1382         case REF_SUBSTRING:
1383           return FAILURE;
1384
1385         default:
1386           gfc_internal_error ("compare_actual_expr(): Bad component code");
1387         }
1388     }
1389   if (!r1 && !r2)
1390     return SUCCESS;
1391   return FAILURE;
1392 }
1393
1394 /* Given formal and actual argument lists that correspond to one
1395    another, check that identical actual arguments aren't not
1396    associated with some incompatible INTENTs.  */
1397
1398 static try
1399 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1400 {
1401   sym_intent f1_intent, f2_intent;
1402   gfc_formal_arglist *f1;
1403   gfc_actual_arglist *a1;
1404   size_t n, i, j;
1405   argpair *p;
1406   try t = SUCCESS;
1407
1408   n = 0;
1409   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1410     {
1411       if (f1 == NULL && a1 == NULL)
1412         break;
1413       if (f1 == NULL || a1 == NULL)
1414         gfc_internal_error ("check_some_aliasing(): List mismatch");
1415       n++;
1416     }
1417   if (n == 0)
1418     return t;
1419   p = (argpair *) alloca (n * sizeof (argpair));
1420
1421   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1422     {
1423       p[i].f = f1;
1424       p[i].a = a1;
1425     }
1426
1427   qsort (p, n, sizeof (argpair), pair_cmp);
1428
1429   for (i = 0; i < n; i++)
1430     {
1431       if (!p[i].a->expr
1432           || p[i].a->expr->expr_type != EXPR_VARIABLE
1433           || p[i].a->expr->ts.type == BT_PROCEDURE)
1434         continue;
1435       f1_intent = p[i].f->sym->attr.intent;
1436       for (j = i + 1; j < n; j++)
1437         {
1438           /* Expected order after the sort.  */
1439           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1440             gfc_internal_error ("check_some_aliasing(): corrupted data");
1441
1442           /* Are the expression the same?  */
1443           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1444             break;
1445           f2_intent = p[j].f->sym->attr.intent;
1446           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1447               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1448             {
1449               gfc_warning ("Same actual argument associated with INTENT(%s) "
1450                            "argument '%s' and INTENT(%s) argument '%s' at %L",
1451                            gfc_intent_string (f1_intent), p[i].f->sym->name,
1452                            gfc_intent_string (f2_intent), p[j].f->sym->name,
1453                            &p[i].a->expr->where);
1454               t = FAILURE;
1455             }
1456         }
1457     }
1458
1459   return t;
1460 }
1461
1462
1463 /* Given formal and actual argument lists that correspond to one
1464    another, check that they are compatible in the sense that intents
1465    are not mismatched.  */
1466
1467 static try
1468 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1469 {
1470   sym_intent a_intent, f_intent;
1471
1472   for (;; f = f->next, a = a->next)
1473     {
1474       if (f == NULL && a == NULL)
1475         break;
1476       if (f == NULL || a == NULL)
1477         gfc_internal_error ("check_intents(): List mismatch");
1478
1479       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1480         continue;
1481
1482       a_intent = a->expr->symtree->n.sym->attr.intent;
1483       f_intent = f->sym->attr.intent;
1484
1485       if (a_intent == INTENT_IN
1486           && (f_intent == INTENT_INOUT
1487               || f_intent == INTENT_OUT))
1488         {
1489
1490           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1491                      "specifies INTENT(%s)", &a->expr->where,
1492                      gfc_intent_string (f_intent));
1493           return FAILURE;
1494         }
1495
1496       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1497         {
1498           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1499             {
1500               gfc_error
1501                 ("Procedure argument at %L is local to a PURE procedure and "
1502                  "is passed to an INTENT(%s) argument", &a->expr->where,
1503                  gfc_intent_string (f_intent));
1504               return FAILURE;
1505             }
1506
1507           if (a->expr->symtree->n.sym->attr.pointer)
1508             {
1509               gfc_error
1510                 ("Procedure argument at %L is local to a PURE procedure and "
1511                  "has the POINTER attribute", &a->expr->where);
1512               return FAILURE;
1513             }
1514         }
1515     }
1516
1517   return SUCCESS;
1518 }
1519
1520
1521 /* Check how a procedure is used against its interface.  If all goes
1522    well, the actual argument list will also end up being properly
1523    sorted.  */
1524
1525 void
1526 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1527 {
1528   /* Warn about calls with an implicit interface.  */
1529   if (gfc_option.warn_implicit_interface
1530       && sym->attr.if_source == IFSRC_UNKNOWN)
1531     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1532                  sym->name, where);
1533
1534   if (sym->attr.if_source == IFSRC_UNKNOWN
1535       || !compare_actual_formal (ap, sym->formal, 0,
1536                                  sym->attr.elemental, where))
1537     return;
1538
1539   check_intents (sym->formal, *ap);
1540   if (gfc_option.warn_aliasing)
1541     check_some_aliasing (sym->formal, *ap);
1542 }
1543
1544
1545 /* Given an interface pointer and an actual argument list, search for
1546    a formal argument list that matches the actual.  If found, returns
1547    a pointer to the symbol of the correct interface.  Returns NULL if
1548    not found.  */
1549
1550 gfc_symbol *
1551 gfc_search_interface (gfc_interface * intr, int sub_flag,
1552                       gfc_actual_arglist ** ap)
1553 {
1554   int r;
1555
1556   for (; intr; intr = intr->next)
1557     {
1558       if (sub_flag && intr->sym->attr.function)
1559         continue;
1560       if (!sub_flag && intr->sym->attr.subroutine)
1561         continue;
1562
1563       r = !intr->sym->attr.elemental;
1564
1565       if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1566         {
1567           check_intents (intr->sym->formal, *ap);
1568           if (gfc_option.warn_aliasing)
1569             check_some_aliasing (intr->sym->formal, *ap);
1570           return intr->sym;
1571         }
1572     }
1573
1574   return NULL;
1575 }
1576
1577
1578 /* Do a brute force recursive search for a symbol.  */
1579
1580 static gfc_symtree *
1581 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1582 {
1583   gfc_symtree * st;
1584
1585   if (root->n.sym == sym)
1586     return root;
1587
1588   st = NULL;
1589   if (root->left)
1590     st = find_symtree0 (root->left, sym);
1591   if (root->right && ! st)
1592     st = find_symtree0 (root->right, sym);
1593   return st;
1594 }
1595
1596
1597 /* Find a symtree for a symbol.  */
1598
1599 static gfc_symtree *
1600 find_sym_in_symtree (gfc_symbol * sym)
1601 {
1602   gfc_symtree *st;
1603   gfc_namespace *ns;
1604
1605   /* First try to find it by name.  */
1606   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1607   if (st && st->n.sym == sym)
1608     return st;
1609
1610   /* if it's been renamed, resort to a brute-force search.  */
1611   /* TODO: avoid having to do this search.  If the symbol doesn't exist
1612      in the symtree for the current namespace, it should probably be added.  */
1613   for (ns = gfc_current_ns; ns; ns = ns->parent)
1614     {
1615       st = find_symtree0 (ns->sym_root, sym);
1616       if (st)
1617         return st;
1618     }
1619   gfc_internal_error ("Unable to find symbol %s", sym->name);
1620   /* Not reached */
1621 }
1622
1623
1624 /* This subroutine is called when an expression is being resolved.
1625    The expression node in question is either a user defined operator
1626    or an intrinsic operator with arguments that aren't compatible
1627    with the operator.  This subroutine builds an actual argument list
1628    corresponding to the operands, then searches for a compatible
1629    interface.  If one is found, the expression node is replaced with
1630    the appropriate function call.  */
1631
1632 try
1633 gfc_extend_expr (gfc_expr * e)
1634 {
1635   gfc_actual_arglist *actual;
1636   gfc_symbol *sym;
1637   gfc_namespace *ns;
1638   gfc_user_op *uop;
1639   gfc_intrinsic_op i;
1640
1641   sym = NULL;
1642
1643   actual = gfc_get_actual_arglist ();
1644   actual->expr = e->value.op.op1;
1645
1646   if (e->value.op.op2 != NULL)
1647     {
1648       actual->next = gfc_get_actual_arglist ();
1649       actual->next->expr = e->value.op.op2;
1650     }
1651
1652   i = fold_unary (e->value.op.operator);
1653
1654   if (i == INTRINSIC_USER)
1655     {
1656       for (ns = gfc_current_ns; ns; ns = ns->parent)
1657         {
1658           uop = gfc_find_uop (e->value.op.uop->name, ns);
1659           if (uop == NULL)
1660             continue;
1661
1662           sym = gfc_search_interface (uop->operator, 0, &actual);
1663           if (sym != NULL)
1664             break;
1665         }
1666     }
1667   else
1668     {
1669       for (ns = gfc_current_ns; ns; ns = ns->parent)
1670         {
1671           sym = gfc_search_interface (ns->operator[i], 0, &actual);
1672           if (sym != NULL)
1673             break;
1674         }
1675     }
1676
1677   if (sym == NULL)
1678     {
1679       /* Don't use gfc_free_actual_arglist() */
1680       if (actual->next != NULL)
1681         gfc_free (actual->next);
1682       gfc_free (actual);
1683
1684       return FAILURE;
1685     }
1686
1687   /* Change the expression node to a function call.  */
1688   e->expr_type = EXPR_FUNCTION;
1689   e->symtree = find_sym_in_symtree (sym);
1690   e->value.function.actual = actual;
1691   e->value.function.esym = NULL;
1692   e->value.function.isym = NULL;
1693
1694   if (gfc_pure (NULL) && !gfc_pure (sym))
1695     {
1696       gfc_error
1697         ("Function '%s' called in lieu of an operator at %L must be PURE",
1698          sym->name, &e->where);
1699       return FAILURE;
1700     }
1701
1702   if (gfc_resolve_expr (e) == FAILURE)
1703     return FAILURE;
1704
1705   return SUCCESS;
1706 }
1707
1708
1709 /* Tries to replace an assignment code node with a subroutine call to
1710    the subroutine associated with the assignment operator.  Return
1711    SUCCESS if the node was replaced.  On FAILURE, no error is
1712    generated.  */
1713
1714 try
1715 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1716 {
1717   gfc_actual_arglist *actual;
1718   gfc_expr *lhs, *rhs;
1719   gfc_symbol *sym;
1720
1721   lhs = c->expr;
1722   rhs = c->expr2;
1723
1724   /* Don't allow an intrinsic assignment to be replaced.  */
1725   if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1726       && (lhs->ts.type == rhs->ts.type
1727           || (gfc_numeric_ts (&lhs->ts)
1728               && gfc_numeric_ts (&rhs->ts))))
1729     return FAILURE;
1730
1731   actual = gfc_get_actual_arglist ();
1732   actual->expr = lhs;
1733
1734   actual->next = gfc_get_actual_arglist ();
1735   actual->next->expr = rhs;
1736
1737   sym = NULL;
1738
1739   for (; ns; ns = ns->parent)
1740     {
1741       sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1742       if (sym != NULL)
1743         break;
1744     }
1745
1746   if (sym == NULL)
1747     {
1748       gfc_free (actual->next);
1749       gfc_free (actual);
1750       return FAILURE;
1751     }
1752
1753   /* Replace the assignment with the call.  */
1754   c->op = EXEC_CALL;
1755   c->symtree = find_sym_in_symtree (sym);
1756   c->expr = NULL;
1757   c->expr2 = NULL;
1758   c->ext.actual = actual;
1759
1760   if (gfc_pure (NULL) && !gfc_pure (sym))
1761     {
1762       gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
1763                  "PURE", sym->name, &c->loc);
1764       return FAILURE;
1765     }
1766
1767   return SUCCESS;
1768 }
1769
1770
1771 /* Make sure that the interface just parsed is not already present in
1772    the given interface list.  Ambiguity isn't checked yet since module
1773    procedures can be present without interfaces.  */
1774
1775 static try
1776 check_new_interface (gfc_interface * base, gfc_symbol * new)
1777 {
1778   gfc_interface *ip;
1779
1780   for (ip = base; ip; ip = ip->next)
1781     {
1782       if (ip->sym == new)
1783         {
1784           gfc_error ("Entity '%s' at %C is already present in the interface",
1785                      new->name);
1786           return FAILURE;
1787         }
1788     }
1789
1790   return SUCCESS;
1791 }
1792
1793
1794 /* Add a symbol to the current interface.  */
1795
1796 try
1797 gfc_add_interface (gfc_symbol * new)
1798 {
1799   gfc_interface **head, *intr;
1800   gfc_namespace *ns;
1801   gfc_symbol *sym;
1802
1803   switch (current_interface.type)
1804     {
1805     case INTERFACE_NAMELESS:
1806       return SUCCESS;
1807
1808     case INTERFACE_INTRINSIC_OP:
1809       for (ns = current_interface.ns; ns; ns = ns->parent)
1810         if (check_new_interface (ns->operator[current_interface.op], new)
1811             == FAILURE)
1812           return FAILURE;
1813
1814       head = &current_interface.ns->operator[current_interface.op];
1815       break;
1816
1817     case INTERFACE_GENERIC:
1818       for (ns = current_interface.ns; ns; ns = ns->parent)
1819         {
1820           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1821           if (sym == NULL)
1822             continue;
1823
1824           if (check_new_interface (sym->generic, new) == FAILURE)
1825             return FAILURE;
1826         }
1827
1828       head = &current_interface.sym->generic;
1829       break;
1830
1831     case INTERFACE_USER_OP:
1832       if (check_new_interface (current_interface.uop->operator, new) ==
1833           FAILURE)
1834         return FAILURE;
1835
1836       head = &current_interface.uop->operator;
1837       break;
1838
1839     default:
1840       gfc_internal_error ("gfc_add_interface(): Bad interface type");
1841     }
1842
1843   intr = gfc_get_interface ();
1844   intr->sym = new;
1845   intr->where = gfc_current_locus;
1846
1847   intr->next = *head;
1848   *head = intr;
1849
1850   return SUCCESS;
1851 }
1852
1853
1854 /* Gets rid of a formal argument list.  We do not free symbols.
1855    Symbols are freed when a namespace is freed.  */
1856
1857 void
1858 gfc_free_formal_arglist (gfc_formal_arglist * p)
1859 {
1860   gfc_formal_arglist *q;
1861
1862   for (; p; p = q)
1863     {
1864       q = p->next;
1865       gfc_free (p);
1866     }
1867 }