OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [fortran/] [interface.c] - Blame information for rev 856

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.