OSDN Git Service

PR fortran/24005
[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 (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
930           continue;
931
932         if (compare_interfaces (p->sym, q->sym, generic_flag))
933           {
934             gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
935                        p->sym->name, q->sym->name, interface_name, &p->where);
936             return 1;
937           }
938       }
939
940   return 0;
941 }
942
943
944 /* Check the generic and operator interfaces of symbols to make sure
945    that none of the interfaces conflict.  The check has to be done
946    after all of the symbols are actually loaded.  */
947
948 static void
949 check_sym_interfaces (gfc_symbol * sym)
950 {
951   char interface_name[100];
952   gfc_symbol *s2;
953
954   if (sym->ns != gfc_current_ns)
955     return;
956
957   if (sym->generic != NULL)
958     {
959       sprintf (interface_name, "generic interface '%s'", sym->name);
960       if (check_interface0 (sym->generic, interface_name))
961         return;
962
963       s2 = sym;
964       while (s2 != NULL)
965         {
966           if (check_interface1 (sym->generic, s2->generic, 1, interface_name))
967             return;
968
969           if (s2->ns->parent == NULL)
970             break;
971           if (gfc_find_symbol (sym->name, s2->ns->parent, 1, &s2))
972             break;
973         }
974     }
975 }
976
977
978 static void
979 check_uop_interfaces (gfc_user_op * uop)
980 {
981   char interface_name[100];
982   gfc_user_op *uop2;
983   gfc_namespace *ns;
984
985   sprintf (interface_name, "operator interface '%s'", uop->name);
986   if (check_interface0 (uop->operator, interface_name))
987     return;
988
989   for (ns = gfc_current_ns; ns; ns = ns->parent)
990     {
991       uop2 = gfc_find_uop (uop->name, ns);
992       if (uop2 == NULL)
993         continue;
994
995       check_interface1 (uop->operator, uop2->operator, 0, interface_name);
996     }
997 }
998
999
1000 /* For the namespace, check generic, user operator and intrinsic
1001    operator interfaces for consistency and to remove duplicate
1002    interfaces.  We traverse the whole namespace, counting on the fact
1003    that most symbols will not have generic or operator interfaces.  */
1004
1005 void
1006 gfc_check_interfaces (gfc_namespace * ns)
1007 {
1008   gfc_namespace *old_ns, *ns2;
1009   char interface_name[100];
1010   gfc_intrinsic_op i;
1011
1012   old_ns = gfc_current_ns;
1013   gfc_current_ns = ns;
1014
1015   gfc_traverse_ns (ns, check_sym_interfaces);
1016
1017   gfc_traverse_user_op (ns, check_uop_interfaces);
1018
1019   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
1020     {
1021       if (i == INTRINSIC_USER)
1022         continue;
1023
1024       if (i == INTRINSIC_ASSIGN)
1025         strcpy (interface_name, "intrinsic assignment operator");
1026       else
1027         sprintf (interface_name, "intrinsic '%s' operator",
1028                  gfc_op2string (i));
1029
1030       if (check_interface0 (ns->operator[i], interface_name))
1031         continue;
1032
1033       check_operator_interface (ns->operator[i], i);
1034
1035       for (ns2 = ns->parent; ns2; ns2 = ns2->parent)
1036         if (check_interface1 (ns->operator[i], ns2->operator[i], 0,
1037                               interface_name))
1038           break;
1039     }
1040
1041   gfc_current_ns = old_ns;
1042 }
1043
1044
1045 static int
1046 symbol_rank (gfc_symbol * sym)
1047 {
1048
1049   return (sym->as == NULL) ? 0 : sym->as->rank;
1050 }
1051
1052
1053 /* Given a symbol of a formal argument list and an expression, if the
1054    formal argument is a pointer, see if the actual argument is a
1055    pointer. Returns nonzero if compatible, zero if not compatible.  */
1056
1057 static int
1058 compare_pointer (gfc_symbol * formal, gfc_expr * actual)
1059 {
1060   symbol_attribute attr;
1061
1062   if (formal->attr.pointer)
1063     {
1064       attr = gfc_expr_attr (actual);
1065       if (!attr.pointer)
1066         return 0;
1067     }
1068
1069   return 1;
1070 }
1071
1072
1073 /* Given a symbol of a formal argument list and an expression, see if
1074    the two are compatible as arguments.  Returns nonzero if
1075    compatible, zero if not compatible.  */
1076
1077 static int
1078 compare_parameter (gfc_symbol * formal, gfc_expr * actual,
1079                    int ranks_must_agree, int is_elemental)
1080 {
1081   gfc_ref *ref;
1082
1083   if (actual->ts.type == BT_PROCEDURE)
1084     {
1085       if (formal->attr.flavor != FL_PROCEDURE)
1086         return 0;
1087
1088       if (formal->attr.function
1089           && !compare_type_rank (formal, actual->symtree->n.sym))
1090         return 0;
1091
1092       if (formal->attr.if_source == IFSRC_UNKNOWN)
1093         return 1;               /* Assume match */
1094
1095       return compare_interfaces (formal, actual->symtree->n.sym, 0);
1096     }
1097
1098   if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN)
1099       && !gfc_compare_types (&formal->ts, &actual->ts))
1100     return 0;
1101
1102   if (symbol_rank (formal) == actual->rank)
1103     return 1;
1104
1105   /* At this point the ranks didn't agree.  */
1106   if (ranks_must_agree || formal->attr.pointer)
1107     return 0;
1108
1109   if (actual->rank != 0)
1110     return is_elemental || formal->attr.dimension;
1111
1112   /* At this point, we are considering a scalar passed to an array.
1113      This is legal if the scalar is an array element of the right sort.  */
1114   if (formal->as->type == AS_ASSUMED_SHAPE)
1115     return 0;
1116
1117   for (ref = actual->ref; ref; ref = ref->next)
1118     if (ref->type == REF_SUBSTRING)
1119       return 0;
1120
1121   for (ref = actual->ref; ref; ref = ref->next)
1122     if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT)
1123       break;
1124
1125   if (ref == NULL)
1126     return 0;                   /* Not an array element */
1127
1128   return 1;
1129 }
1130
1131
1132 /* Given formal and actual argument lists, see if they are compatible.
1133    If they are compatible, the actual argument list is sorted to
1134    correspond with the formal list, and elements for missing optional
1135    arguments are inserted. If WHERE pointer is nonnull, then we issue
1136    errors when things don't match instead of just returning the status
1137    code.  */
1138
1139 static int
1140 compare_actual_formal (gfc_actual_arglist ** ap,
1141                        gfc_formal_arglist * formal,
1142                        int ranks_must_agree, int is_elemental, locus * where)
1143 {
1144   gfc_actual_arglist **new, *a, *actual, temp;
1145   gfc_formal_arglist *f;
1146   int i, n, na;
1147
1148   actual = *ap;
1149
1150   if (actual == NULL && formal == NULL)
1151     return 1;
1152
1153   n = 0;
1154   for (f = formal; f; f = f->next)
1155     n++;
1156
1157   new = (gfc_actual_arglist **) alloca (n * sizeof (gfc_actual_arglist *));
1158
1159   for (i = 0; i < n; i++)
1160     new[i] = NULL;
1161
1162   na = 0;
1163   f = formal;
1164   i = 0;
1165
1166   for (a = actual; a; a = a->next, f = f->next)
1167     {
1168       if (a->name != NULL)
1169         {
1170           i = 0;
1171           for (f = formal; f; f = f->next, i++)
1172             {
1173               if (f->sym == NULL)
1174                 continue;
1175               if (strcmp (f->sym->name, a->name) == 0)
1176                 break;
1177             }
1178
1179           if (f == NULL)
1180             {
1181               if (where)
1182                 gfc_error
1183                   ("Keyword argument '%s' at %L is not in the procedure",
1184                    a->name, &a->expr->where);
1185               return 0;
1186             }
1187
1188           if (new[i] != NULL)
1189             {
1190               if (where)
1191                 gfc_error
1192                   ("Keyword argument '%s' at %L is already associated "
1193                    "with another actual argument", a->name, &a->expr->where);
1194               return 0;
1195             }
1196         }
1197
1198       if (f == NULL)
1199         {
1200           if (where)
1201             gfc_error
1202               ("More actual than formal arguments in procedure call at %L",
1203                where);
1204
1205           return 0;
1206         }
1207
1208       if (f->sym == NULL && a->expr == NULL)
1209         goto match;
1210
1211       if (f->sym == NULL)
1212         {
1213           if (where)
1214             gfc_error
1215               ("Missing alternate return spec in subroutine call at %L",
1216                where);
1217           return 0;
1218         }
1219
1220       if (a->expr == NULL)
1221         {
1222           if (where)
1223             gfc_error
1224               ("Unexpected alternate return spec in subroutine call at %L",
1225                where);
1226           return 0;
1227         }
1228
1229       if (!compare_parameter
1230           (f->sym, a->expr, ranks_must_agree, is_elemental))
1231         {
1232           if (where)
1233             gfc_error ("Type/rank mismatch in argument '%s' at %L",
1234                        f->sym->name, &a->expr->where);
1235           return 0;
1236         }
1237
1238       if (a->expr->expr_type != EXPR_NULL
1239           && compare_pointer (f->sym, a->expr) == 0)
1240         {
1241           if (where)
1242             gfc_error ("Actual argument for '%s' must be a pointer at %L",
1243                        f->sym->name, &a->expr->where);
1244           return 0;
1245         }
1246
1247     match:
1248       if (a == actual)
1249         na = i;
1250
1251       new[i++] = a;
1252     }
1253
1254   /* Make sure missing actual arguments are optional.  */
1255   i = 0;
1256   for (f = formal; f; f = f->next, i++)
1257     {
1258       if (new[i] != NULL)
1259         continue;
1260       if (!f->sym->attr.optional)
1261         {
1262           if (where)
1263             gfc_error ("Missing actual argument for argument '%s' at %L",
1264                        f->sym->name, where);
1265           return 0;
1266         }
1267     }
1268
1269   /* The argument lists are compatible.  We now relink a new actual
1270      argument list with null arguments in the right places.  The head
1271      of the list remains the head.  */
1272   for (i = 0; i < n; i++)
1273     if (new[i] == NULL)
1274       new[i] = gfc_get_actual_arglist ();
1275
1276   if (na != 0)
1277     {
1278       temp = *new[0];
1279       *new[0] = *actual;
1280       *actual = temp;
1281
1282       a = new[0];
1283       new[0] = new[na];
1284       new[na] = a;
1285     }
1286
1287   for (i = 0; i < n - 1; i++)
1288     new[i]->next = new[i + 1];
1289
1290   new[i]->next = NULL;
1291
1292   if (*ap == NULL && n > 0)
1293     *ap = new[0];
1294
1295   /* Note the types of omitted optional arguments.  */
1296   for (a = actual, f = formal; a; a = a->next, f = f->next)
1297     if (a->expr == NULL && a->label == NULL)
1298       a->missing_arg_type = f->sym->ts.type;
1299
1300   return 1;
1301 }
1302
1303
1304 typedef struct
1305 {
1306   gfc_formal_arglist *f;
1307   gfc_actual_arglist *a;
1308 }
1309 argpair;
1310
1311 /* qsort comparison function for argument pairs, with the following
1312    order:
1313     - p->a->expr == NULL
1314     - p->a->expr->expr_type != EXPR_VARIABLE
1315     - growing p->a->expr->symbol.  */
1316
1317 static int
1318 pair_cmp (const void *p1, const void *p2)
1319 {
1320   const gfc_actual_arglist *a1, *a2;
1321
1322   /* *p1 and *p2 are elements of the to-be-sorted array.  */
1323   a1 = ((const argpair *) p1)->a;
1324   a2 = ((const argpair *) p2)->a;
1325   if (!a1->expr)
1326     {
1327       if (!a2->expr)
1328         return 0;
1329       return -1;
1330     }
1331   if (!a2->expr)
1332     return 1;
1333   if (a1->expr->expr_type != EXPR_VARIABLE)
1334     {
1335       if (a2->expr->expr_type != EXPR_VARIABLE)
1336         return 0;
1337       return -1;
1338     }
1339   if (a2->expr->expr_type != EXPR_VARIABLE)
1340     return 1;
1341   return a1->expr->symtree->n.sym < a2->expr->symtree->n.sym;
1342 }
1343
1344
1345 /* Given two expressions from some actual arguments, test whether they
1346    refer to the same expression. The analysis is conservative.
1347    Returning FAILURE will produce no warning.  */
1348
1349 static try
1350 compare_actual_expr (gfc_expr * e1, gfc_expr * e2)
1351 {
1352   const gfc_ref *r1, *r2;
1353
1354   if (!e1 || !e2
1355       || e1->expr_type != EXPR_VARIABLE
1356       || e2->expr_type != EXPR_VARIABLE
1357       || e1->symtree->n.sym != e2->symtree->n.sym)
1358     return FAILURE;
1359
1360   /* TODO: improve comparison, see expr.c:show_ref().  */
1361   for (r1 = e1->ref, r2 = e2->ref; r1 && r2; r1 = r1->next, r2 = r2->next)
1362     {
1363       if (r1->type != r2->type)
1364         return FAILURE;
1365       switch (r1->type)
1366         {
1367         case REF_ARRAY:
1368           if (r1->u.ar.type != r2->u.ar.type)
1369             return FAILURE;
1370           /* TODO: At the moment, consider only full arrays;
1371              we could do better.  */
1372           if (r1->u.ar.type != AR_FULL || r2->u.ar.type != AR_FULL)
1373             return FAILURE;
1374           break;
1375
1376         case REF_COMPONENT:
1377           if (r1->u.c.component != r2->u.c.component)
1378             return FAILURE;
1379           break;
1380
1381         case REF_SUBSTRING:
1382           return FAILURE;
1383
1384         default:
1385           gfc_internal_error ("compare_actual_expr(): Bad component code");
1386         }
1387     }
1388   if (!r1 && !r2)
1389     return SUCCESS;
1390   return FAILURE;
1391 }
1392
1393 /* Given formal and actual argument lists that correspond to one
1394    another, check that identical actual arguments aren't not
1395    associated with some incompatible INTENTs.  */
1396
1397 static try
1398 check_some_aliasing (gfc_formal_arglist * f, gfc_actual_arglist * a)
1399 {
1400   sym_intent f1_intent, f2_intent;
1401   gfc_formal_arglist *f1;
1402   gfc_actual_arglist *a1;
1403   size_t n, i, j;
1404   argpair *p;
1405   try t = SUCCESS;
1406
1407   n = 0;
1408   for (f1 = f, a1 = a;; f1 = f1->next, a1 = a1->next)
1409     {
1410       if (f1 == NULL && a1 == NULL)
1411         break;
1412       if (f1 == NULL || a1 == NULL)
1413         gfc_internal_error ("check_some_aliasing(): List mismatch");
1414       n++;
1415     }
1416   if (n == 0)
1417     return t;
1418   p = (argpair *) alloca (n * sizeof (argpair));
1419
1420   for (i = 0, f1 = f, a1 = a; i < n; i++, f1 = f1->next, a1 = a1->next)
1421     {
1422       p[i].f = f1;
1423       p[i].a = a1;
1424     }
1425
1426   qsort (p, n, sizeof (argpair), pair_cmp);
1427
1428   for (i = 0; i < n; i++)
1429     {
1430       if (!p[i].a->expr
1431           || p[i].a->expr->expr_type != EXPR_VARIABLE
1432           || p[i].a->expr->ts.type == BT_PROCEDURE)
1433         continue;
1434       f1_intent = p[i].f->sym->attr.intent;
1435       for (j = i + 1; j < n; j++)
1436         {
1437           /* Expected order after the sort.  */
1438           if (!p[j].a->expr || p[j].a->expr->expr_type != EXPR_VARIABLE)
1439             gfc_internal_error ("check_some_aliasing(): corrupted data");
1440
1441           /* Are the expression the same?  */
1442           if (compare_actual_expr (p[i].a->expr, p[j].a->expr) == FAILURE)
1443             break;
1444           f2_intent = p[j].f->sym->attr.intent;
1445           if ((f1_intent == INTENT_IN && f2_intent == INTENT_OUT)
1446               || (f1_intent == INTENT_OUT && f2_intent == INTENT_IN))
1447             {
1448               gfc_warning ("Same actual argument associated with INTENT(%s) "
1449                            "argument '%s' and INTENT(%s) argument '%s' at %L",
1450                            gfc_intent_string (f1_intent), p[i].f->sym->name,
1451                            gfc_intent_string (f2_intent), p[j].f->sym->name,
1452                            &p[i].a->expr->where);
1453               t = FAILURE;
1454             }
1455         }
1456     }
1457
1458   return t;
1459 }
1460
1461
1462 /* Given formal and actual argument lists that correspond to one
1463    another, check that they are compatible in the sense that intents
1464    are not mismatched.  */
1465
1466 static try
1467 check_intents (gfc_formal_arglist * f, gfc_actual_arglist * a)
1468 {
1469   sym_intent a_intent, f_intent;
1470
1471   for (;; f = f->next, a = a->next)
1472     {
1473       if (f == NULL && a == NULL)
1474         break;
1475       if (f == NULL || a == NULL)
1476         gfc_internal_error ("check_intents(): List mismatch");
1477
1478       if (a->expr == NULL || a->expr->expr_type != EXPR_VARIABLE)
1479         continue;
1480
1481       a_intent = a->expr->symtree->n.sym->attr.intent;
1482       f_intent = f->sym->attr.intent;
1483
1484       if (a_intent == INTENT_IN
1485           && (f_intent == INTENT_INOUT
1486               || f_intent == INTENT_OUT))
1487         {
1488
1489           gfc_error ("Procedure argument at %L is INTENT(IN) while interface "
1490                      "specifies INTENT(%s)", &a->expr->where,
1491                      gfc_intent_string (f_intent));
1492           return FAILURE;
1493         }
1494
1495       if (gfc_pure (NULL) && gfc_impure_variable (a->expr->symtree->n.sym))
1496         {
1497           if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT)
1498             {
1499               gfc_error
1500                 ("Procedure argument at %L is local to a PURE procedure and "
1501                  "is passed to an INTENT(%s) argument", &a->expr->where,
1502                  gfc_intent_string (f_intent));
1503               return FAILURE;
1504             }
1505
1506           if (a->expr->symtree->n.sym->attr.pointer)
1507             {
1508               gfc_error
1509                 ("Procedure argument at %L is local to a PURE procedure and "
1510                  "has the POINTER attribute", &a->expr->where);
1511               return FAILURE;
1512             }
1513         }
1514     }
1515
1516   return SUCCESS;
1517 }
1518
1519
1520 /* Check how a procedure is used against its interface.  If all goes
1521    well, the actual argument list will also end up being properly
1522    sorted.  */
1523
1524 void
1525 gfc_procedure_use (gfc_symbol * sym, gfc_actual_arglist ** ap, locus * where)
1526 {
1527   /* Warn about calls with an implicit interface.  */
1528   if (gfc_option.warn_implicit_interface
1529       && sym->attr.if_source == IFSRC_UNKNOWN)
1530     gfc_warning ("Procedure '%s' called with an implicit interface at %L",
1531                  sym->name, where);
1532
1533   if (sym->attr.if_source == IFSRC_UNKNOWN
1534       || !compare_actual_formal (ap, sym->formal, 0,
1535                                  sym->attr.elemental, where))
1536     return;
1537
1538   check_intents (sym->formal, *ap);
1539   if (gfc_option.warn_aliasing)
1540     check_some_aliasing (sym->formal, *ap);
1541 }
1542
1543
1544 /* Given an interface pointer and an actual argument list, search for
1545    a formal argument list that matches the actual.  If found, returns
1546    a pointer to the symbol of the correct interface.  Returns NULL if
1547    not found.  */
1548
1549 gfc_symbol *
1550 gfc_search_interface (gfc_interface * intr, int sub_flag,
1551                       gfc_actual_arglist ** ap)
1552 {
1553   int r;
1554
1555   for (; intr; intr = intr->next)
1556     {
1557       if (sub_flag && intr->sym->attr.function)
1558         continue;
1559       if (!sub_flag && intr->sym->attr.subroutine)
1560         continue;
1561
1562       r = !intr->sym->attr.elemental;
1563
1564       if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
1565         {
1566           check_intents (intr->sym->formal, *ap);
1567           if (gfc_option.warn_aliasing)
1568             check_some_aliasing (intr->sym->formal, *ap);
1569           return intr->sym;
1570         }
1571     }
1572
1573   return NULL;
1574 }
1575
1576
1577 /* Do a brute force recursive search for a symbol.  */
1578
1579 static gfc_symtree *
1580 find_symtree0 (gfc_symtree * root, gfc_symbol * sym)
1581 {
1582   gfc_symtree * st;
1583
1584   if (root->n.sym == sym)
1585     return root;
1586
1587   st = NULL;
1588   if (root->left)
1589     st = find_symtree0 (root->left, sym);
1590   if (root->right && ! st)
1591     st = find_symtree0 (root->right, sym);
1592   return st;
1593 }
1594
1595
1596 /* Find a symtree for a symbol.  */
1597
1598 static gfc_symtree *
1599 find_sym_in_symtree (gfc_symbol * sym)
1600 {
1601   gfc_symtree *st;
1602   gfc_namespace *ns;
1603
1604   /* First try to find it by name.  */
1605   gfc_find_sym_tree (sym->name, gfc_current_ns, 1, &st);
1606   if (st && st->n.sym == sym)
1607     return st;
1608
1609   /* if it's been renamed, resort to a brute-force search.  */
1610   /* TODO: avoid having to do this search.  If the symbol doesn't exist
1611      in the symtree for the current namespace, it should probably be added.  */
1612   for (ns = gfc_current_ns; ns; ns = ns->parent)
1613     {
1614       st = find_symtree0 (ns->sym_root, sym);
1615       if (st)
1616         return st;
1617     }
1618   gfc_internal_error ("Unable to find symbol %s", sym->name);
1619   /* Not reached */
1620 }
1621
1622
1623 /* This subroutine is called when an expression is being resolved.
1624    The expression node in question is either a user defined operator
1625    or an intrinsic operator with arguments that aren't compatible
1626    with the operator.  This subroutine builds an actual argument list
1627    corresponding to the operands, then searches for a compatible
1628    interface.  If one is found, the expression node is replaced with
1629    the appropriate function call.  */
1630
1631 try
1632 gfc_extend_expr (gfc_expr * e)
1633 {
1634   gfc_actual_arglist *actual;
1635   gfc_symbol *sym;
1636   gfc_namespace *ns;
1637   gfc_user_op *uop;
1638   gfc_intrinsic_op i;
1639
1640   sym = NULL;
1641
1642   actual = gfc_get_actual_arglist ();
1643   actual->expr = e->value.op.op1;
1644
1645   if (e->value.op.op2 != NULL)
1646     {
1647       actual->next = gfc_get_actual_arglist ();
1648       actual->next->expr = e->value.op.op2;
1649     }
1650
1651   i = fold_unary (e->value.op.operator);
1652
1653   if (i == INTRINSIC_USER)
1654     {
1655       for (ns = gfc_current_ns; ns; ns = ns->parent)
1656         {
1657           uop = gfc_find_uop (e->value.op.uop->name, ns);
1658           if (uop == NULL)
1659             continue;
1660
1661           sym = gfc_search_interface (uop->operator, 0, &actual);
1662           if (sym != NULL)
1663             break;
1664         }
1665     }
1666   else
1667     {
1668       for (ns = gfc_current_ns; ns; ns = ns->parent)
1669         {
1670           sym = gfc_search_interface (ns->operator[i], 0, &actual);
1671           if (sym != NULL)
1672             break;
1673         }
1674     }
1675
1676   if (sym == NULL)
1677     {
1678       /* Don't use gfc_free_actual_arglist() */
1679       if (actual->next != NULL)
1680         gfc_free (actual->next);
1681       gfc_free (actual);
1682
1683       return FAILURE;
1684     }
1685
1686   /* Change the expression node to a function call.  */
1687   e->expr_type = EXPR_FUNCTION;
1688   e->symtree = find_sym_in_symtree (sym);
1689   e->value.function.actual = actual;
1690   e->value.function.esym = NULL;
1691   e->value.function.isym = NULL;
1692
1693   if (gfc_pure (NULL) && !gfc_pure (sym))
1694     {
1695       gfc_error
1696         ("Function '%s' called in lieu of an operator at %L must be PURE",
1697          sym->name, &e->where);
1698       return FAILURE;
1699     }
1700
1701   if (gfc_resolve_expr (e) == FAILURE)
1702     return FAILURE;
1703
1704   return SUCCESS;
1705 }
1706
1707
1708 /* Tries to replace an assignment code node with a subroutine call to
1709    the subroutine associated with the assignment operator.  Return
1710    SUCCESS if the node was replaced.  On FAILURE, no error is
1711    generated.  */
1712
1713 try
1714 gfc_extend_assign (gfc_code * c, gfc_namespace * ns)
1715 {
1716   gfc_actual_arglist *actual;
1717   gfc_expr *lhs, *rhs;
1718   gfc_symbol *sym;
1719
1720   lhs = c->expr;
1721   rhs = c->expr2;
1722
1723   /* Don't allow an intrinsic assignment to be replaced.  */
1724   if (lhs->ts.type != BT_DERIVED && rhs->ts.type != BT_DERIVED
1725       && (lhs->ts.type == rhs->ts.type
1726           || (gfc_numeric_ts (&lhs->ts)
1727               && gfc_numeric_ts (&rhs->ts))))
1728     return FAILURE;
1729
1730   actual = gfc_get_actual_arglist ();
1731   actual->expr = lhs;
1732
1733   actual->next = gfc_get_actual_arglist ();
1734   actual->next->expr = rhs;
1735
1736   sym = NULL;
1737
1738   for (; ns; ns = ns->parent)
1739     {
1740       sym = gfc_search_interface (ns->operator[INTRINSIC_ASSIGN], 1, &actual);
1741       if (sym != NULL)
1742         break;
1743     }
1744
1745   if (sym == NULL)
1746     {
1747       gfc_free (actual->next);
1748       gfc_free (actual);
1749       return FAILURE;
1750     }
1751
1752   /* Replace the assignment with the call.  */
1753   c->op = EXEC_CALL;
1754   c->symtree = find_sym_in_symtree (sym);
1755   c->expr = NULL;
1756   c->expr2 = NULL;
1757   c->ext.actual = actual;
1758
1759   if (gfc_pure (NULL) && !gfc_pure (sym))
1760     {
1761       gfc_error ("Subroutine '%s' called in lieu of assignment at %L must be "
1762                  "PURE", sym->name, &c->loc);
1763       return FAILURE;
1764     }
1765
1766   return SUCCESS;
1767 }
1768
1769
1770 /* Make sure that the interface just parsed is not already present in
1771    the given interface list.  Ambiguity isn't checked yet since module
1772    procedures can be present without interfaces.  */
1773
1774 static try
1775 check_new_interface (gfc_interface * base, gfc_symbol * new)
1776 {
1777   gfc_interface *ip;
1778
1779   for (ip = base; ip; ip = ip->next)
1780     {
1781       if (ip->sym == new)
1782         {
1783           gfc_error ("Entity '%s' at %C is already present in the interface",
1784                      new->name);
1785           return FAILURE;
1786         }
1787     }
1788
1789   return SUCCESS;
1790 }
1791
1792
1793 /* Add a symbol to the current interface.  */
1794
1795 try
1796 gfc_add_interface (gfc_symbol * new)
1797 {
1798   gfc_interface **head, *intr;
1799   gfc_namespace *ns;
1800   gfc_symbol *sym;
1801
1802   switch (current_interface.type)
1803     {
1804     case INTERFACE_NAMELESS:
1805       return SUCCESS;
1806
1807     case INTERFACE_INTRINSIC_OP:
1808       for (ns = current_interface.ns; ns; ns = ns->parent)
1809         if (check_new_interface (ns->operator[current_interface.op], new)
1810             == FAILURE)
1811           return FAILURE;
1812
1813       head = &current_interface.ns->operator[current_interface.op];
1814       break;
1815
1816     case INTERFACE_GENERIC:
1817       for (ns = current_interface.ns; ns; ns = ns->parent)
1818         {
1819           gfc_find_symbol (current_interface.sym->name, ns, 0, &sym);
1820           if (sym == NULL)
1821             continue;
1822
1823           if (check_new_interface (sym->generic, new) == FAILURE)
1824             return FAILURE;
1825         }
1826
1827       head = &current_interface.sym->generic;
1828       break;
1829
1830     case INTERFACE_USER_OP:
1831       if (check_new_interface (current_interface.uop->operator, new) ==
1832           FAILURE)
1833         return FAILURE;
1834
1835       head = &current_interface.uop->operator;
1836       break;
1837
1838     default:
1839       gfc_internal_error ("gfc_add_interface(): Bad interface type");
1840     }
1841
1842   intr = gfc_get_interface ();
1843   intr->sym = new;
1844   intr->where = gfc_current_locus;
1845
1846   intr->next = *head;
1847   *head = intr;
1848
1849   return SUCCESS;
1850 }
1851
1852
1853 /* Gets rid of a formal argument list.  We do not free symbols.
1854    Symbols are freed when a namespace is freed.  */
1855
1856 void
1857 gfc_free_formal_arglist (gfc_formal_arglist * p)
1858 {
1859   gfc_formal_arglist *q;
1860
1861   for (; p; p = q)
1862     {
1863       q = p->next;
1864       gfc_free (p);
1865     }
1866 }