OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [intrinsic.c] - Blame information for rev 300

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

Line No. Rev Author Line
1 285 jeremybenn
/* Build up a list of intrinsic subroutines and functions for the
2
   name-resolution stage.
3
   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4
   2009, 2010
5
   Free Software Foundation, Inc.
6
   Contributed by Andy Vaught & Katherine Holcomb
7
 
8
This file is part of GCC.
9
 
10
GCC is free software; you can redistribute it and/or modify it under
11
the terms of the GNU General Public License as published by the Free
12
Software Foundation; either version 3, or (at your option) any later
13
version.
14
 
15
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16
WARRANTY; without even the implied warranty of MERCHANTABILITY or
17
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
18
for more details.
19
 
20
You should have received a copy of the GNU General Public License
21
along with GCC; see the file COPYING3.  If not see
22
<http://www.gnu.org/licenses/>.  */
23
 
24
#include "config.h"
25
#include "system.h"
26
#include "flags.h"
27
#include "gfortran.h"
28
#include "intrinsic.h"
29
 
30
/* Namespace to hold the resolved symbols for intrinsic subroutines.  */
31
static gfc_namespace *gfc_intrinsic_namespace;
32
 
33
int gfc_init_expr = 0;
34
 
35
/* Pointers to an intrinsic function and its argument names that are being
36
   checked.  */
37
 
38
const char *gfc_current_intrinsic;
39
const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
40
locus *gfc_current_intrinsic_where;
41
 
42
static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
43
static gfc_intrinsic_sym *char_conversions;
44
static gfc_intrinsic_arg *next_arg;
45
 
46
static int nfunc, nsub, nargs, nconv, ncharconv;
47
 
48
static enum
49
{ SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
50
sizing;
51
 
52
enum klass
53
{ NO_CLASS = 0, CLASS_ELEMENTAL, CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
54
 
55
#define ACTUAL_NO       0
56
#define ACTUAL_YES      1
57
 
58
#define REQUIRED        0
59
#define OPTIONAL        1
60
 
61
 
62
/* Return a letter based on the passed type.  Used to construct the
63
   name of a type-dependent subroutine.  */
64
 
65
char
66
gfc_type_letter (bt type)
67
{
68
  char c;
69
 
70
  switch (type)
71
    {
72
    case BT_LOGICAL:
73
      c = 'l';
74
      break;
75
    case BT_CHARACTER:
76
      c = 's';
77
      break;
78
    case BT_INTEGER:
79
      c = 'i';
80
      break;
81
    case BT_REAL:
82
      c = 'r';
83
      break;
84
    case BT_COMPLEX:
85
      c = 'c';
86
      break;
87
 
88
    case BT_HOLLERITH:
89
      c = 'h';
90
      break;
91
 
92
    default:
93
      c = 'u';
94
      break;
95
    }
96
 
97
  return c;
98
}
99
 
100
 
101
/* Get a symbol for a resolved name. Note, if needed be, the elemental
102
   attribute has be added afterwards.  */
103
 
104
gfc_symbol *
105
gfc_get_intrinsic_sub_symbol (const char *name)
106
{
107
  gfc_symbol *sym;
108
 
109
  gfc_get_symbol (name, gfc_intrinsic_namespace, &sym);
110
  sym->attr.always_explicit = 1;
111
  sym->attr.subroutine = 1;
112
  sym->attr.flavor = FL_PROCEDURE;
113
  sym->attr.proc = PROC_INTRINSIC;
114
 
115
  return sym;
116
}
117
 
118
 
119
/* Return a pointer to the name of a conversion function given two
120
   typespecs.  */
121
 
122
static const char *
123
conv_name (gfc_typespec *from, gfc_typespec *to)
124
{
125
  return gfc_get_string ("__convert_%c%d_%c%d",
126
                         gfc_type_letter (from->type), from->kind,
127
                         gfc_type_letter (to->type), to->kind);
128
}
129
 
130
 
131
/* Given a pair of typespecs, find the gfc_intrinsic_sym node that
132
   corresponds to the conversion.  Returns NULL if the conversion
133
   isn't found.  */
134
 
135
static gfc_intrinsic_sym *
136
find_conv (gfc_typespec *from, gfc_typespec *to)
137
{
138
  gfc_intrinsic_sym *sym;
139
  const char *target;
140
  int i;
141
 
142
  target = conv_name (from, to);
143
  sym = conversion;
144
 
145
  for (i = 0; i < nconv; i++, sym++)
146
    if (target == sym->name)
147
      return sym;
148
 
149
  return NULL;
150
}
151
 
152
 
153
/* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node
154
   that corresponds to the conversion.  Returns NULL if the conversion
155
   isn't found.  */
156
 
157
static gfc_intrinsic_sym *
158
find_char_conv (gfc_typespec *from, gfc_typespec *to)
159
{
160
  gfc_intrinsic_sym *sym;
161
  const char *target;
162
  int i;
163
 
164
  target = conv_name (from, to);
165
  sym = char_conversions;
166
 
167
  for (i = 0; i < ncharconv; i++, sym++)
168
    if (target == sym->name)
169
      return sym;
170
 
171
  return NULL;
172
}
173
 
174
 
175
/* Interface to the check functions.  We break apart an argument list
176
   and call the proper check function rather than forcing each
177
   function to manipulate the argument list.  */
178
 
179
static gfc_try
180
do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg)
181
{
182
  gfc_expr *a1, *a2, *a3, *a4, *a5;
183
 
184
  if (arg == NULL)
185
    return (*specific->check.f0) ();
186
 
187
  a1 = arg->expr;
188
  arg = arg->next;
189
  if (arg == NULL)
190
    return (*specific->check.f1) (a1);
191
 
192
  a2 = arg->expr;
193
  arg = arg->next;
194
  if (arg == NULL)
195
    return (*specific->check.f2) (a1, a2);
196
 
197
  a3 = arg->expr;
198
  arg = arg->next;
199
  if (arg == NULL)
200
    return (*specific->check.f3) (a1, a2, a3);
201
 
202
  a4 = arg->expr;
203
  arg = arg->next;
204
  if (arg == NULL)
205
    return (*specific->check.f4) (a1, a2, a3, a4);
206
 
207
  a5 = arg->expr;
208
  arg = arg->next;
209
  if (arg == NULL)
210
    return (*specific->check.f5) (a1, a2, a3, a4, a5);
211
 
212
  gfc_internal_error ("do_check(): too many args");
213
}
214
 
215
 
216
/*********** Subroutines to build the intrinsic list ****************/
217
 
218
/* Add a single intrinsic symbol to the current list.
219
 
220
   Argument list:
221
      char *     name of function
222
      int       whether function is elemental
223
      int       If the function can be used as an actual argument [1]
224
      bt         return type of function
225
      int       kind of return type of function
226
      int       Fortran standard version
227
      check      pointer to check function
228
      simplify   pointer to simplification function
229
      resolve    pointer to resolution function
230
 
231
   Optional arguments come in multiples of five:
232
      char *      name of argument
233
      bt          type of argument
234
      int         kind of argument
235
      int         arg optional flag (1=optional, 0=required)
236
      sym_intent  intent of argument
237
 
238
   The sequence is terminated by a NULL name.
239
 
240
 
241
 [1] Whether a function can or cannot be used as an actual argument is
242
     determined by its presence on the 13.6 list in Fortran 2003.  The
243
     following intrinsics, which are GNU extensions, are considered allowed
244
     as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG
245
     ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT.  */
246
 
247
static void
248
add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind,
249
         int standard, gfc_check_f check, gfc_simplify_f simplify,
250
         gfc_resolve_f resolve, ...)
251
{
252
  char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0'  */
253
  int optional, first_flag;
254
  sym_intent intent;
255
  va_list argp;
256
 
257
  switch (sizing)
258
    {
259
    case SZ_SUBS:
260
      nsub++;
261
      break;
262
 
263
    case SZ_FUNCS:
264
      nfunc++;
265
      break;
266
 
267
    case SZ_NOTHING:
268
      next_sym->name = gfc_get_string (name);
269
 
270
      strcpy (buf, "_gfortran_");
271
      strcat (buf, name);
272
      next_sym->lib_name = gfc_get_string (buf);
273
 
274
      next_sym->elemental = (cl == CLASS_ELEMENTAL);
275
      next_sym->inquiry = (cl == CLASS_INQUIRY);
276
      next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL);
277
      next_sym->actual_ok = actual_ok;
278
      next_sym->ts.type = type;
279
      next_sym->ts.kind = kind;
280
      next_sym->standard = standard;
281
      next_sym->simplify = simplify;
282
      next_sym->check = check;
283
      next_sym->resolve = resolve;
284
      next_sym->specific = 0;
285
      next_sym->generic = 0;
286
      next_sym->conversion = 0;
287
      next_sym->id = id;
288
      break;
289
 
290
    default:
291
      gfc_internal_error ("add_sym(): Bad sizing mode");
292
    }
293
 
294
  va_start (argp, resolve);
295
 
296
  first_flag = 1;
297
 
298
  for (;;)
299
    {
300
      name = va_arg (argp, char *);
301
      if (name == NULL)
302
        break;
303
 
304
      type = (bt) va_arg (argp, int);
305
      kind = va_arg (argp, int);
306
      optional = va_arg (argp, int);
307
      intent = (sym_intent) va_arg (argp, int);
308
 
309
      if (sizing != SZ_NOTHING)
310
        nargs++;
311
      else
312
        {
313
          next_arg++;
314
 
315
          if (first_flag)
316
            next_sym->formal = next_arg;
317
          else
318
            (next_arg - 1)->next = next_arg;
319
 
320
          first_flag = 0;
321
 
322
          strcpy (next_arg->name, name);
323
          next_arg->ts.type = type;
324
          next_arg->ts.kind = kind;
325
          next_arg->optional = optional;
326
          next_arg->intent = intent;
327
        }
328
    }
329
 
330
  va_end (argp);
331
 
332
  next_sym++;
333
}
334
 
335
 
336
/* Add a symbol to the function list where the function takes
337
 
338
 
339
static void
340
add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
341
           int kind, int standard,
342
           gfc_try (*check) (void),
343
           gfc_expr *(*simplify) (void),
344
           void (*resolve) (gfc_expr *))
345
{
346
  gfc_simplify_f sf;
347
  gfc_check_f cf;
348
  gfc_resolve_f rf;
349
 
350
  cf.f0 = check;
351
  sf.f0 = simplify;
352
  rf.f0 = resolve;
353
 
354
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
355
           (void *) 0);
356
}
357
 
358
 
359
/* Add a symbol to the subroutine list where the subroutine takes
360
 
361
 
362
static void
363
add_sym_0s (const char *name, gfc_isym_id id, int standard, void (*resolve) (gfc_code *))
364
{
365
  gfc_check_f cf;
366
  gfc_simplify_f sf;
367
  gfc_resolve_f rf;
368
 
369
  cf.f1 = NULL;
370
  sf.f1 = NULL;
371
  rf.s1 = resolve;
372
 
373
  add_sym (name, id, NO_CLASS, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, rf,
374
           (void *) 0);
375
}
376
 
377
 
378
/* Add a symbol to the function list where the function takes
379
   1 arguments.  */
380
 
381
static void
382
add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
383
           int kind, int standard,
384
           gfc_try (*check) (gfc_expr *),
385
           gfc_expr *(*simplify) (gfc_expr *),
386
           void (*resolve) (gfc_expr *, gfc_expr *),
387
           const char *a1, bt type1, int kind1, int optional1)
388
{
389
  gfc_check_f cf;
390
  gfc_simplify_f sf;
391
  gfc_resolve_f rf;
392
 
393
  cf.f1 = check;
394
  sf.f1 = simplify;
395
  rf.f1 = resolve;
396
 
397
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
398
           a1, type1, kind1, optional1, INTENT_IN,
399
           (void *) 0);
400
}
401
 
402
 
403
/* Add a symbol to the subroutine list where the subroutine takes
404
   1 arguments.  */
405
 
406
static void
407
add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
408
            gfc_try (*check) (gfc_expr *),
409
            gfc_expr *(*simplify) (gfc_expr *),
410
            void (*resolve) (gfc_code *),
411
            const char *a1, bt type1, int kind1, int optional1)
412
{
413
  gfc_check_f cf;
414
  gfc_simplify_f sf;
415
  gfc_resolve_f rf;
416
 
417
  cf.f1 = check;
418
  sf.f1 = simplify;
419
  rf.s1 = resolve;
420
 
421
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
422
           a1, type1, kind1, optional1, INTENT_IN,
423
           (void *) 0);
424
}
425
 
426
 
427
/* Add a symbol to the function list where the function takes
428
   1 arguments, specifying the intent of the argument.  */
429
 
430
static void
431
add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl,
432
                  int actual_ok, bt type, int kind, int standard,
433
                  gfc_try (*check) (gfc_expr *),
434
                  gfc_expr *(*simplify) (gfc_expr *),
435
                  void (*resolve) (gfc_expr *, gfc_expr *),
436
                  const char *a1, bt type1, int kind1, int optional1,
437
                  sym_intent intent1)
438
{
439
  gfc_check_f cf;
440
  gfc_simplify_f sf;
441
  gfc_resolve_f rf;
442
 
443
  cf.f1 = check;
444
  sf.f1 = simplify;
445
  rf.f1 = resolve;
446
 
447
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
448
           a1, type1, kind1, optional1, intent1,
449
           (void *) 0);
450
}
451
 
452
 
453
/* Add a symbol to the subroutine list where the subroutine takes
454
   1 arguments, specifying the intent of the argument.  */
455
 
456
static void
457
add_sym_1s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type,
458
                   int kind, int standard,
459
                   gfc_try (*check) (gfc_expr *),
460
                   gfc_expr *(*simplify) (gfc_expr *),
461
                   void (*resolve) (gfc_code *),
462
                   const char *a1, bt type1, int kind1, int optional1,
463
                   sym_intent intent1)
464
{
465
  gfc_check_f cf;
466
  gfc_simplify_f sf;
467
  gfc_resolve_f rf;
468
 
469
  cf.f1 = check;
470
  sf.f1 = simplify;
471
  rf.s1 = resolve;
472
 
473
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
474
           a1, type1, kind1, optional1, intent1,
475
           (void *) 0);
476
}
477
 
478
 
479
/* Add a symbol from the MAX/MIN family of intrinsic functions to the
480
   function.  MAX et al take 2 or more arguments.  */
481
 
482
static void
483
add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
484
            int kind, int standard,
485
            gfc_try (*check) (gfc_actual_arglist *),
486
            gfc_expr *(*simplify) (gfc_expr *),
487
            void (*resolve) (gfc_expr *, gfc_actual_arglist *),
488
            const char *a1, bt type1, int kind1, int optional1,
489
            const char *a2, bt type2, int kind2, int optional2)
490
{
491
  gfc_check_f cf;
492
  gfc_simplify_f sf;
493
  gfc_resolve_f rf;
494
 
495
  cf.f1m = check;
496
  sf.f1 = simplify;
497
  rf.f1m = resolve;
498
 
499
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
500
           a1, type1, kind1, optional1, INTENT_IN,
501
           a2, type2, kind2, optional2, INTENT_IN,
502
           (void *) 0);
503
}
504
 
505
 
506
/* Add a symbol to the function list where the function takes
507
   2 arguments.  */
508
 
509
static void
510
add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
511
           int kind, int standard,
512
           gfc_try (*check) (gfc_expr *, gfc_expr *),
513
           gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
514
           void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *),
515
           const char *a1, bt type1, int kind1, int optional1,
516
           const char *a2, bt type2, int kind2, int optional2)
517
{
518
  gfc_check_f cf;
519
  gfc_simplify_f sf;
520
  gfc_resolve_f rf;
521
 
522
  cf.f2 = check;
523
  sf.f2 = simplify;
524
  rf.f2 = resolve;
525
 
526
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
527
           a1, type1, kind1, optional1, INTENT_IN,
528
           a2, type2, kind2, optional2, INTENT_IN,
529
           (void *) 0);
530
}
531
 
532
 
533
/* Add a symbol to the subroutine list where the subroutine takes
534
   2 arguments.  */
535
 
536
static void
537
add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
538
            gfc_try (*check) (gfc_expr *, gfc_expr *),
539
            gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
540
            void (*resolve) (gfc_code *),
541
            const char *a1, bt type1, int kind1, int optional1,
542
            const char *a2, bt type2, int kind2, int optional2)
543
{
544
  gfc_check_f cf;
545
  gfc_simplify_f sf;
546
  gfc_resolve_f rf;
547
 
548
  cf.f2 = check;
549
  sf.f2 = simplify;
550
  rf.s1 = resolve;
551
 
552
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
553
           a1, type1, kind1, optional1, INTENT_IN,
554
           a2, type2, kind2, optional2, INTENT_IN,
555
           (void *) 0);
556
}
557
 
558
 
559
/* Add a symbol to the subroutine list where the subroutine takes
560
   2 arguments, specifying the intent of the arguments.  */
561
 
562
static void
563
add_sym_2s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type,
564
                   int kind, int standard,
565
                   gfc_try (*check) (gfc_expr *, gfc_expr *),
566
                   gfc_expr *(*simplify) (gfc_expr *, gfc_expr *),
567
                   void (*resolve) (gfc_code *),
568
                   const char *a1, bt type1, int kind1, int optional1,
569
                   sym_intent intent1, const char *a2, bt type2, int kind2,
570
                   int optional2, sym_intent intent2)
571
{
572
  gfc_check_f cf;
573
  gfc_simplify_f sf;
574
  gfc_resolve_f rf;
575
 
576
  cf.f2 = check;
577
  sf.f2 = simplify;
578
  rf.s1 = resolve;
579
 
580
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
581
           a1, type1, kind1, optional1, intent1,
582
           a2, type2, kind2, optional2, intent2,
583
           (void *) 0);
584
}
585
 
586
 
587
/* Add a symbol to the function list where the function takes
588
   3 arguments.  */
589
 
590
static void
591
add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
592
           int kind, int standard,
593
           gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
594
           gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
595
           void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
596
           const char *a1, bt type1, int kind1, int optional1,
597
           const char *a2, bt type2, int kind2, int optional2,
598
           const char *a3, bt type3, int kind3, int optional3)
599
{
600
  gfc_check_f cf;
601
  gfc_simplify_f sf;
602
  gfc_resolve_f rf;
603
 
604
  cf.f3 = check;
605
  sf.f3 = simplify;
606
  rf.f3 = resolve;
607
 
608
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
609
           a1, type1, kind1, optional1, INTENT_IN,
610
           a2, type2, kind2, optional2, INTENT_IN,
611
           a3, type3, kind3, optional3, INTENT_IN,
612
           (void *) 0);
613
}
614
 
615
 
616
/* MINLOC and MAXLOC get special treatment because their argument
617
   might have to be reordered.  */
618
 
619
static void
620
add_sym_3ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
621
             int kind, int standard,
622
             gfc_try (*check) (gfc_actual_arglist *),
623
             gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
624
             void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
625
             const char *a1, bt type1, int kind1, int optional1,
626
             const char *a2, bt type2, int kind2, int optional2,
627
             const char *a3, bt type3, int kind3, int optional3)
628
{
629
  gfc_check_f cf;
630
  gfc_simplify_f sf;
631
  gfc_resolve_f rf;
632
 
633
  cf.f3ml = check;
634
  sf.f3 = simplify;
635
  rf.f3 = resolve;
636
 
637
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
638
           a1, type1, kind1, optional1, INTENT_IN,
639
           a2, type2, kind2, optional2, INTENT_IN,
640
           a3, type3, kind3, optional3, INTENT_IN,
641
           (void *) 0);
642
}
643
 
644
 
645
/* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
646
   their argument also might have to be reordered.  */
647
 
648
static void
649
add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
650
              int kind, int standard,
651
              gfc_try (*check) (gfc_actual_arglist *),
652
              gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
653
              void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
654
              const char *a1, bt type1, int kind1, int optional1,
655
              const char *a2, bt type2, int kind2, int optional2,
656
              const char *a3, bt type3, int kind3, int optional3)
657
{
658
  gfc_check_f cf;
659
  gfc_simplify_f sf;
660
  gfc_resolve_f rf;
661
 
662
  cf.f3red = check;
663
  sf.f3 = simplify;
664
  rf.f3 = resolve;
665
 
666
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
667
           a1, type1, kind1, optional1, INTENT_IN,
668
           a2, type2, kind2, optional2, INTENT_IN,
669
           a3, type3, kind3, optional3, INTENT_IN,
670
           (void *) 0);
671
}
672
 
673
 
674
/* Add a symbol to the subroutine list where the subroutine takes
675
   3 arguments.  */
676
 
677
static void
678
add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, int standard,
679
            gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
680
            gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
681
            void (*resolve) (gfc_code *),
682
            const char *a1, bt type1, int kind1, int optional1,
683
            const char *a2, bt type2, int kind2, int optional2,
684
            const char *a3, bt type3, int kind3, int optional3)
685
{
686
  gfc_check_f cf;
687
  gfc_simplify_f sf;
688
  gfc_resolve_f rf;
689
 
690
  cf.f3 = check;
691
  sf.f3 = simplify;
692
  rf.s1 = resolve;
693
 
694
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
695
           a1, type1, kind1, optional1, INTENT_IN,
696
           a2, type2, kind2, optional2, INTENT_IN,
697
           a3, type3, kind3, optional3, INTENT_IN,
698
           (void *) 0);
699
}
700
 
701
 
702
/* Add a symbol to the subroutine list where the subroutine takes
703
   3 arguments, specifying the intent of the arguments.  */
704
 
705
static void
706
add_sym_3s_intent (const char *name, gfc_isym_id id, enum klass cl, bt type,
707
                   int kind, int standard,
708
                   gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *),
709
                   gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *),
710
                   void (*resolve) (gfc_code *),
711
                   const char *a1, bt type1, int kind1, int optional1,
712
                   sym_intent intent1, const char *a2, bt type2, int kind2,
713
                   int optional2, sym_intent intent2, const char *a3, bt type3,
714
                   int kind3, int optional3, sym_intent intent3)
715
{
716
  gfc_check_f cf;
717
  gfc_simplify_f sf;
718
  gfc_resolve_f rf;
719
 
720
  cf.f3 = check;
721
  sf.f3 = simplify;
722
  rf.s1 = resolve;
723
 
724
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
725
           a1, type1, kind1, optional1, intent1,
726
           a2, type2, kind2, optional2, intent2,
727
           a3, type3, kind3, optional3, intent3,
728
           (void *) 0);
729
}
730
 
731
 
732
/* Add a symbol to the function list where the function takes
733
   4 arguments.  */
734
 
735
static void
736
add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type,
737
           int kind, int standard,
738
           gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
739
           gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
740
                                  gfc_expr *),
741
           void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
742
                            gfc_expr *),
743
           const char *a1, bt type1, int kind1, int optional1,
744
           const char *a2, bt type2, int kind2, int optional2,
745
           const char *a3, bt type3, int kind3, int optional3,
746
           const char *a4, bt type4, int kind4, int optional4 )
747
{
748
  gfc_check_f cf;
749
  gfc_simplify_f sf;
750
  gfc_resolve_f rf;
751
 
752
  cf.f4 = check;
753
  sf.f4 = simplify;
754
  rf.f4 = resolve;
755
 
756
  add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf,
757
           a1, type1, kind1, optional1, INTENT_IN,
758
           a2, type2, kind2, optional2, INTENT_IN,
759
           a3, type3, kind3, optional3, INTENT_IN,
760
           a4, type4, kind4, optional4, INTENT_IN,
761
           (void *) 0);
762
}
763
 
764
 
765
/* Add a symbol to the subroutine list where the subroutine takes
766
   4 arguments.  */
767
 
768
static void
769
add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
770
            int standard,
771
            gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *),
772
            gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
773
                                   gfc_expr *),
774
            void (*resolve) (gfc_code *),
775
            const char *a1, bt type1, int kind1, int optional1,
776
            sym_intent intent1, const char *a2, bt type2, int kind2,
777
            int optional2, sym_intent intent2, const char *a3, bt type3,
778
            int kind3, int optional3, sym_intent intent3, const char *a4,
779
            bt type4, int kind4, int optional4, sym_intent intent4)
780
{
781
  gfc_check_f cf;
782
  gfc_simplify_f sf;
783
  gfc_resolve_f rf;
784
 
785
  cf.f4 = check;
786
  sf.f4 = simplify;
787
  rf.s1 = resolve;
788
 
789
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
790
           a1, type1, kind1, optional1, intent1,
791
           a2, type2, kind2, optional2, intent2,
792
           a3, type3, kind3, optional3, intent3,
793
           a4, type4, kind4, optional4, intent4,
794
           (void *) 0);
795
}
796
 
797
 
798
/* Add a symbol to the subroutine list where the subroutine takes
799
   5 arguments.  */
800
 
801
static void
802
add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind,
803
            int standard,
804
            gfc_try (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
805
                          gfc_expr *),
806
            gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *,
807
                                   gfc_expr *, gfc_expr *),
808
            void (*resolve) (gfc_code *),
809
            const char *a1, bt type1, int kind1, int optional1,
810
            sym_intent intent1, const char *a2, bt type2, int kind2,
811
            int optional2, sym_intent intent2, const char *a3, bt type3,
812
            int kind3, int optional3, sym_intent intent3, const char *a4,
813
            bt type4, int kind4, int optional4, sym_intent intent4,
814
            const char *a5, bt type5, int kind5, int optional5,
815
            sym_intent intent5)
816
{
817
  gfc_check_f cf;
818
  gfc_simplify_f sf;
819
  gfc_resolve_f rf;
820
 
821
  cf.f5 = check;
822
  sf.f5 = simplify;
823
  rf.s1 = resolve;
824
 
825
  add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf,
826
           a1, type1, kind1, optional1, intent1,
827
           a2, type2, kind2, optional2, intent2,
828
           a3, type3, kind3, optional3, intent3,
829
           a4, type4, kind4, optional4, intent4,
830
           a5, type5, kind5, optional5, intent5,
831
           (void *) 0);
832
}
833
 
834
 
835
/* Locate an intrinsic symbol given a base pointer, number of elements
836
   in the table and a pointer to a name.  Returns the NULL pointer if
837
   a name is not found.  */
838
 
839
static gfc_intrinsic_sym *
840
find_sym (gfc_intrinsic_sym *start, int n, const char *name)
841
{
842
  /* name may be a user-supplied string, so we must first make sure
843
     that we're comparing against a pointer into the global string
844
     table.  */
845
  const char *p = gfc_get_string (name);
846
 
847
  while (n > 0)
848
    {
849
      if (p == start->name)
850
        return start;
851
 
852
      start++;
853
      n--;
854
    }
855
 
856
  return NULL;
857
}
858
 
859
 
860
/* Given a name, find a function in the intrinsic function table.
861
   Returns NULL if not found.  */
862
 
863
gfc_intrinsic_sym *
864
gfc_find_function (const char *name)
865
{
866
  gfc_intrinsic_sym *sym;
867
 
868
  sym = find_sym (functions, nfunc, name);
869
  if (!sym)
870
    sym = find_sym (conversion, nconv, name);
871
 
872
  return sym;
873
}
874
 
875
 
876
/* Given a name, find a function in the intrinsic subroutine table.
877
   Returns NULL if not found.  */
878
 
879
gfc_intrinsic_sym *
880
gfc_find_subroutine (const char *name)
881
{
882
  return find_sym (subroutines, nsub, name);
883
}
884
 
885
 
886
/* Given a string, figure out if it is the name of a generic intrinsic
887
   function or not.  */
888
 
889
int
890
gfc_generic_intrinsic (const char *name)
891
{
892
  gfc_intrinsic_sym *sym;
893
 
894
  sym = gfc_find_function (name);
895
  return (sym == NULL) ? 0 : sym->generic;
896
}
897
 
898
 
899
/* Given a string, figure out if it is the name of a specific
900
   intrinsic function or not.  */
901
 
902
int
903
gfc_specific_intrinsic (const char *name)
904
{
905
  gfc_intrinsic_sym *sym;
906
 
907
  sym = gfc_find_function (name);
908
  return (sym == NULL) ? 0 : sym->specific;
909
}
910
 
911
 
912
/* Given a string, figure out if it is the name of an intrinsic function
913
   or subroutine allowed as an actual argument or not.  */
914
int
915
gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag)
916
{
917
  gfc_intrinsic_sym *sym;
918
 
919
  /* Intrinsic subroutines are not allowed as actual arguments.  */
920
  if (subroutine_flag)
921
    return 0;
922
  else
923
    {
924
      sym = gfc_find_function (name);
925
      return (sym == NULL) ? 0 : sym->actual_ok;
926
    }
927
}
928
 
929
 
930
/* Given a symbol, find out if it is (and is to be treated) an intrinsic.  If
931
   it's name refers to an intrinsic but this intrinsic is not included in the
932
   selected standard, this returns FALSE and sets the symbol's external
933
   attribute.  */
934
 
935
bool
936
gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc)
937
{
938
  gfc_intrinsic_sym* isym;
939
  const char* symstd;
940
 
941
  /* If INTRINSIC/EXTERNAL state is already known, return.  */
942
  if (sym->attr.intrinsic)
943
    return true;
944
  if (sym->attr.external)
945
    return false;
946
 
947
  if (subroutine_flag)
948
    isym = gfc_find_subroutine (sym->name);
949
  else
950
    isym = gfc_find_function (sym->name);
951
 
952
  /* No such intrinsic available at all?  */
953
  if (!isym)
954
    return false;
955
 
956
  /* See if this intrinsic is allowed in the current standard.  */
957
  if (gfc_check_intrinsic_standard (isym, &symstd, false, loc) == FAILURE)
958
    {
959
      if (sym->attr.proc == PROC_UNKNOWN
960
          && gfc_option.warn_intrinsics_std)
961
        gfc_warning_now ("The intrinsic '%s' at %L is not included in the"
962
                         " selected standard but %s and '%s' will be"
963
                         " treated as if declared EXTERNAL.  Use an"
964
                         " appropriate -std=* option or define"
965
                         " -fall-intrinsics to allow this intrinsic.",
966
                         sym->name, &loc, symstd, sym->name);
967
 
968
      return false;
969
    }
970
 
971
  return true;
972
}
973
 
974
 
975
/* Collect a set of intrinsic functions into a generic collection.
976
   The first argument is the name of the generic function, which is
977
   also the name of a specific function.  The rest of the specifics
978
   currently in the table are placed into the list of specific
979
   functions associated with that generic.
980
 
981
   PR fortran/32778
982
   FIXME: Remove the argument STANDARD if no regressions are
983
          encountered. Change all callers (approx. 360).
984
*/
985
 
986
static void
987
make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED)
988
{
989
  gfc_intrinsic_sym *g;
990
 
991
  if (sizing != SZ_NOTHING)
992
    return;
993
 
994
  g = gfc_find_function (name);
995
  if (g == NULL)
996
    gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
997
                        name);
998
 
999
  gcc_assert (g->id == id);
1000
 
1001
  g->generic = 1;
1002
  g->specific = 1;
1003
  if ((g + 1)->name != NULL)
1004
    g->specific_head = g + 1;
1005
  g++;
1006
 
1007
  while (g->name != NULL)
1008
    {
1009
      g->next = g + 1;
1010
      g->specific = 1;
1011
      g++;
1012
    }
1013
 
1014
  g--;
1015
  g->next = NULL;
1016
}
1017
 
1018
 
1019
/* Create a duplicate intrinsic function entry for the current
1020
   function, the only differences being the alternate name and
1021
   a different standard if necessary. Note that we use argument
1022
   lists more than once, but all argument lists are freed as a
1023
   single block.  */
1024
 
1025
static void
1026
make_alias (const char *name, int standard)
1027
{
1028
  switch (sizing)
1029
    {
1030
    case SZ_FUNCS:
1031
      nfunc++;
1032
      break;
1033
 
1034
    case SZ_SUBS:
1035
      nsub++;
1036
      break;
1037
 
1038
    case SZ_NOTHING:
1039
      next_sym[0] = next_sym[-1];
1040
      next_sym->name = gfc_get_string (name);
1041
      next_sym->standard = standard;
1042
      next_sym++;
1043
      break;
1044
 
1045
    default:
1046
      break;
1047
    }
1048
}
1049
 
1050
 
1051
/* Make the current subroutine noreturn.  */
1052
 
1053
static void
1054
make_noreturn (void)
1055
{
1056
  if (sizing == SZ_NOTHING)
1057
    next_sym[-1].noreturn = 1;
1058
}
1059
 
1060
 
1061
/* Add intrinsic functions.  */
1062
 
1063
static void
1064
add_functions (void)
1065
{
1066
  /* Argument names as in the standard (to be used as argument keywords).  */
1067
  const char
1068
    *a = "a", *f = "field", *pt = "pointer", *tg = "target",
1069
    *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
1070
    *c = "c", *n = "n", *ncopies= "ncopies", *pos = "pos", *bck = "back",
1071
    *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
1072
    *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
1073
    *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
1074
    *p = "p", *ar = "array", *shp = "shape", *src = "source",
1075
    *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
1076
    *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
1077
    *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
1078
    *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
1079
    *z = "z", *ln = "len", *ut = "unit", *han = "handler",
1080
    *num = "number", *tm = "time", *nm = "name", *md = "mode",
1081
    *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command";
1082
 
1083
  int di, dr, dd, dl, dc, dz, ii;
1084
 
1085
  di = gfc_default_integer_kind;
1086
  dr = gfc_default_real_kind;
1087
  dd = gfc_default_double_kind;
1088
  dl = gfc_default_logical_kind;
1089
  dc = gfc_default_character_kind;
1090
  dz = gfc_default_complex_kind;
1091
  ii = gfc_index_integer_kind;
1092
 
1093
  add_sym_1 ("abs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1094
             gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
1095
             a, BT_REAL, dr, REQUIRED);
1096
 
1097
  add_sym_1 ("iabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1098
             NULL, gfc_simplify_abs, gfc_resolve_abs,
1099
             a, BT_INTEGER, di, REQUIRED);
1100
 
1101
  add_sym_1 ("dabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1102
             gfc_check_fn_d, gfc_simplify_abs, gfc_resolve_abs,
1103
             a, BT_REAL, dd, REQUIRED);
1104
 
1105
  add_sym_1 ("cabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1106
             NULL, gfc_simplify_abs, gfc_resolve_abs,
1107
             a, BT_COMPLEX, dz, REQUIRED);
1108
 
1109
  add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1110
             NULL, gfc_simplify_abs, gfc_resolve_abs,
1111
             a, BT_COMPLEX, dd, REQUIRED);
1112
 
1113
  make_alias ("cdabs", GFC_STD_GNU);
1114
 
1115
  make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77);
1116
 
1117
  /* The checking function for ACCESS is called gfc_check_access_func
1118
     because the name gfc_check_access is already used in module.c.  */
1119
  add_sym_2 ("access", GFC_ISYM_ACCESS, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1120
             gfc_check_access_func, NULL, gfc_resolve_access,
1121
             nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
1122
 
1123
  make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU);
1124
 
1125
  add_sym_2 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
1126
             BT_CHARACTER, dc, GFC_STD_F95,
1127
             gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar,
1128
             i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1129
 
1130
  make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
1131
 
1132
  add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1133
             gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos,
1134
             x, BT_REAL, dr, REQUIRED);
1135
 
1136
  add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1137
             gfc_check_fn_d, gfc_simplify_acos, gfc_resolve_acos,
1138
             x, BT_REAL, dd, REQUIRED);
1139
 
1140
  make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
1141
 
1142
  add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
1143
             GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh,
1144
             gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED);
1145
 
1146
  add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1147
             gfc_check_fn_d, gfc_simplify_acosh, gfc_resolve_acosh,
1148
             x, BT_REAL, dd, REQUIRED);
1149
 
1150
  make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008);
1151
 
1152
  add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO,
1153
             BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl,
1154
             gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED);
1155
 
1156
  make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
1157
 
1158
  add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO,
1159
             BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr,
1160
             gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED);
1161
 
1162
  make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
1163
 
1164
  add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1165
             gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
1166
             z, BT_COMPLEX, dz, REQUIRED);
1167
 
1168
  make_alias ("imag", GFC_STD_GNU);
1169
  make_alias ("imagpart", GFC_STD_GNU);
1170
 
1171
  add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1172
             NULL, gfc_simplify_aimag, gfc_resolve_aimag,
1173
             z, BT_COMPLEX, dd, REQUIRED);
1174
 
1175
  make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
1176
 
1177
  add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1178
             gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
1179
             a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1180
 
1181
  add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1182
             NULL, gfc_simplify_dint, gfc_resolve_dint,
1183
             a, BT_REAL, dd, REQUIRED);
1184
 
1185
  make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
1186
 
1187
  add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1188
             gfc_check_all_any, gfc_simplify_all, gfc_resolve_all,
1189
             msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1190
 
1191
  make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
1192
 
1193
  add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1194
             gfc_check_allocated, NULL, NULL,
1195
             ar, BT_UNKNOWN, 0, REQUIRED);
1196
 
1197
  make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
1198
 
1199
  add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1200
             gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
1201
             a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1202
 
1203
  add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1204
             NULL, gfc_simplify_dnint, gfc_resolve_dnint,
1205
             a, BT_REAL, dd, REQUIRED);
1206
 
1207
  make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
1208
 
1209
  add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1210
             gfc_check_all_any, gfc_simplify_any, gfc_resolve_any,
1211
             msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1212
 
1213
  make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
1214
 
1215
  add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1216
             gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin,
1217
             x, BT_REAL, dr, REQUIRED);
1218
 
1219
  add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1220
             gfc_check_fn_d, gfc_simplify_asin, gfc_resolve_asin,
1221
             x, BT_REAL, dd, REQUIRED);
1222
 
1223
  make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
1224
 
1225
  add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
1226
             GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh,
1227
             gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED);
1228
 
1229
  add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1230
             gfc_check_fn_d, gfc_simplify_asinh, gfc_resolve_asinh,
1231
             x, BT_REAL, dd, REQUIRED);
1232
 
1233
  make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_F2008);
1234
 
1235
  add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl,
1236
             GFC_STD_F95, gfc_check_associated, NULL, NULL,
1237
             pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
1238
 
1239
  make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
1240
 
1241
  add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1242
             gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan,
1243
             x, BT_REAL, dr, REQUIRED);
1244
 
1245
  add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1246
             gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan,
1247
             x, BT_REAL, dd, REQUIRED);
1248
 
1249
  /* Two-argument version of atan, equivalent to atan2.  */
1250
  add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008,
1251
             gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2,
1252
             y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
1253
 
1254
  make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
1255
 
1256
  add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,
1257
             GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh,
1258
             gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED);
1259
 
1260
  add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1261
             gfc_check_fn_d, gfc_simplify_atanh, gfc_resolve_atanh,
1262
             x, BT_REAL, dd, REQUIRED);
1263
 
1264
  make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_F2008);
1265
 
1266
  add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1267
             gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
1268
             y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
1269
 
1270
  add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1271
             gfc_check_datan2, gfc_simplify_atan2, gfc_resolve_atan2,
1272
             y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
1273
 
1274
  make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
1275
 
1276
  /* Bessel and Neumann functions for G77 compatibility.  */
1277
  add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1278
             gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
1279
             x, BT_REAL, dr, REQUIRED);
1280
 
1281
  make_alias ("bessel_j0", GFC_STD_F2008);
1282
 
1283
  add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1284
             gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1,
1285
             x, BT_REAL, dd, REQUIRED);
1286
 
1287
  make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008);
1288
 
1289
  add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1290
             gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
1291
             x, BT_REAL, dr, REQUIRED);
1292
 
1293
  make_alias ("bessel_j1", GFC_STD_F2008);
1294
 
1295
  add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1296
             gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1,
1297
             x, BT_REAL, dd, REQUIRED);
1298
 
1299
  make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008);
1300
 
1301
  add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1302
             gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
1303
             n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1304
 
1305
  make_alias ("bessel_jn", GFC_STD_F2008);
1306
 
1307
  add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1308
             gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn,
1309
             n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1310
 
1311
  make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008);
1312
 
1313
  add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1314
             gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
1315
             x, BT_REAL, dr, REQUIRED);
1316
 
1317
  make_alias ("bessel_y0", GFC_STD_F2008);
1318
 
1319
  add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1320
             gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1,
1321
             x, BT_REAL, dd, REQUIRED);
1322
 
1323
  make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008);
1324
 
1325
  add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1326
             gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
1327
             x, BT_REAL, dr, REQUIRED);
1328
 
1329
  make_alias ("bessel_y1", GFC_STD_F2008);
1330
 
1331
  add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1332
             gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1,
1333
             x, BT_REAL, dd, REQUIRED);
1334
 
1335
  make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008);
1336
 
1337
  add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1338
             gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
1339
             n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1340
 
1341
  make_alias ("bessel_yn", GFC_STD_F2008);
1342
 
1343
  add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1344
             gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn,
1345
             n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1346
 
1347
  make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008);
1348
 
1349
  add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1350
             gfc_check_i, gfc_simplify_bit_size, NULL,
1351
             i, BT_INTEGER, di, REQUIRED);
1352
 
1353
  make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
1354
 
1355
  add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1356
             gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest,
1357
             i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1358
 
1359
  make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
1360
 
1361
  add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1362
             gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
1363
             a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1364
 
1365
  make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
1366
 
1367
  add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77,
1368
             gfc_check_char, gfc_simplify_char, gfc_resolve_char,
1369
             i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1370
 
1371
  make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
1372
 
1373
  add_sym_1 ("chdir", GFC_ISYM_CHDIR, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
1374
             GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir,
1375
             nm, BT_CHARACTER, dc, REQUIRED);
1376
 
1377
  make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
1378
 
1379
  add_sym_2 ("chmod", GFC_ISYM_CHMOD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1380
             gfc_check_chmod, NULL, gfc_resolve_chmod,
1381
             nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
1382
 
1383
  make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU);
1384
 
1385
  add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77,
1386
             gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
1387
             x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
1388
             kind, BT_INTEGER, di, OPTIONAL);
1389
 
1390
  make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
1391
 
1392
  add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY,
1393
             ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL);
1394
 
1395
  make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
1396
                GFC_STD_F2003);
1397
 
1398
  add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU,
1399
             gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
1400
             x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1401
 
1402
  make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);
1403
 
1404
  /* Making dcmplx a specific of cmplx causes cmplx to return a double
1405
     complex instead of the default complex.  */
1406
 
1407
  add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU,
1408
             gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
1409
             x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
1410
 
1411
  make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
1412
 
1413
  add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1414
             gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
1415
             z, BT_COMPLEX, dz, REQUIRED);
1416
 
1417
  add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
1418
             NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1419
             z, BT_COMPLEX, dd, REQUIRED);
1420
 
1421
  make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
1422
 
1423
  add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1424
             gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1425
             x, BT_REAL, dr, REQUIRED);
1426
 
1427
  add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1428
             gfc_check_fn_d, gfc_simplify_cos, gfc_resolve_cos,
1429
             x, BT_REAL, dd, REQUIRED);
1430
 
1431
  add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1432
             NULL, gfc_simplify_cos, gfc_resolve_cos,
1433
             x, BT_COMPLEX, dz, REQUIRED);
1434
 
1435
  add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
1436
             NULL, gfc_simplify_cos, gfc_resolve_cos,
1437
             x, BT_COMPLEX, dd, REQUIRED);
1438
 
1439
  make_alias ("cdcos", GFC_STD_GNU);
1440
 
1441
  make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
1442
 
1443
  add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1444
             gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh,
1445
             x, BT_REAL, dr, REQUIRED);
1446
 
1447
  add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1448
             gfc_check_fn_d, gfc_simplify_cosh, gfc_resolve_cosh,
1449
             x, BT_REAL, dd, REQUIRED);
1450
 
1451
  make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
1452
 
1453
  add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO,
1454
             BT_INTEGER, di, GFC_STD_F95,
1455
             gfc_check_count, gfc_simplify_count, gfc_resolve_count,
1456
             msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1457
             kind, BT_INTEGER, di, OPTIONAL);
1458
 
1459
  make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
1460
 
1461
  add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1462
             gfc_check_cshift, NULL, gfc_resolve_cshift,
1463
             ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1464
             dm, BT_INTEGER, ii, OPTIONAL);
1465
 
1466
  make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
1467
 
1468
  add_sym_1 ("ctime", GFC_ISYM_CTIME, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
1469
              gfc_check_ctime, NULL, gfc_resolve_ctime,
1470
              tm, BT_INTEGER, di, REQUIRED);
1471
 
1472
  make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
1473
 
1474
  add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
1475
             gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1476
             a, BT_REAL, dr, REQUIRED);
1477
 
1478
  make_alias ("dfloat", GFC_STD_GNU);
1479
 
1480
  make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
1481
 
1482
  add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1483
             gfc_check_digits, gfc_simplify_digits, NULL,
1484
             x, BT_UNKNOWN, dr, REQUIRED);
1485
 
1486
  make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95);
1487
 
1488
  add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1489
             gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1490
             x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1491
 
1492
  add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1493
             NULL, gfc_simplify_dim, gfc_resolve_dim,
1494
             x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
1495
 
1496
  add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1497
             gfc_check_x_yd, gfc_simplify_dim, gfc_resolve_dim,
1498
             x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
1499
 
1500
  make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
1501
 
1502
  add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
1503
             GFC_STD_F95, gfc_check_dot_product, gfc_simplify_dot_product, gfc_resolve_dot_product,
1504
             va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
1505
 
1506
  make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
1507
 
1508
  add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1509
             gfc_check_dprod, gfc_simplify_dprod, gfc_resolve_dprod,
1510
             x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1511
 
1512
  make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
1513
 
1514
  add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1515
             NULL, NULL, NULL,
1516
             a, BT_COMPLEX, dd, REQUIRED);
1517
 
1518
  make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
1519
 
1520
  add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1521
             gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1522
             ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
1523
             bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
1524
 
1525
  make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
1526
 
1527
  add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1528
             gfc_check_x, gfc_simplify_epsilon, NULL,
1529
             x, BT_REAL, dr, REQUIRED);
1530
 
1531
  make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95);
1532
 
1533
  /* G77 compatibility for the ERF() and ERFC() functions.  */
1534
  add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
1535
             GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erf,
1536
             gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
1537
 
1538
  add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd,
1539
             GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erf,
1540
             gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED);
1541
 
1542
  make_generic ("erf", GFC_ISYM_ERF, GFC_STD_F2008);
1543
 
1544
  add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
1545
             GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erfc,
1546
             gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED);
1547
 
1548
  add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd,
1549
             GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erfc,
1550
             gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED);
1551
 
1552
  make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008);
1553
 
1554
  add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO,
1555
             BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r,
1556
             gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL,
1557
             dr, REQUIRED);
1558
 
1559
  make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008);
1560
 
1561
  /* G77 compatibility */
1562
  add_sym_1 ("dtime", GFC_ISYM_DTIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4,  GFC_STD_GNU,
1563
             gfc_check_dtime_etime, NULL, NULL,
1564
             x, BT_REAL, 4, REQUIRED);
1565
 
1566
  make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU);
1567
 
1568
  add_sym_1 ("etime", GFC_ISYM_ETIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4,  GFC_STD_GNU,
1569
             gfc_check_dtime_etime, NULL, NULL,
1570
             x, BT_REAL, 4, REQUIRED);
1571
 
1572
  make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
1573
 
1574
  add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr,  GFC_STD_F77,
1575
             gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
1576
             x, BT_REAL, dr, REQUIRED);
1577
 
1578
  add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1579
             gfc_check_fn_d, gfc_simplify_exp, gfc_resolve_exp,
1580
             x, BT_REAL, dd, REQUIRED);
1581
 
1582
  add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1583
             NULL, gfc_simplify_exp, gfc_resolve_exp,
1584
             x, BT_COMPLEX, dz, REQUIRED);
1585
 
1586
  add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd,  GFC_STD_GNU,
1587
             NULL, gfc_simplify_exp, gfc_resolve_exp,
1588
             x, BT_COMPLEX, dd, REQUIRED);
1589
 
1590
  make_alias ("cdexp", GFC_STD_GNU);
1591
 
1592
  make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
1593
 
1594
  add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1595
             gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1596
             x, BT_REAL, dr, REQUIRED);
1597
 
1598
  make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
1599
 
1600
  add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY,
1601
             ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
1602
             gfc_check_same_type_as, NULL, gfc_resolve_extends_type_of,
1603
             a, BT_UNKNOWN, 0, REQUIRED,
1604
             mo, BT_UNKNOWN, 0, REQUIRED);
1605
 
1606
  add_sym_0 ("fdate",  GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU,
1607
             NULL, NULL, gfc_resolve_fdate);
1608
 
1609
  make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
1610
 
1611
  add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1612
             gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1613
             a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1614
 
1615
  make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1616
 
1617
  /* G77 compatible fnum */
1618
  add_sym_1 ("fnum", GFC_ISYM_FNUM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1619
             gfc_check_fnum, NULL, gfc_resolve_fnum,
1620
             ut, BT_INTEGER, di, REQUIRED);
1621
 
1622
  make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1623
 
1624
  add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1625
             gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1626
             x, BT_REAL, dr, REQUIRED);
1627
 
1628
  make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1629
 
1630
  add_sym_2 ("fstat", GFC_ISYM_FSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
1631
             GFC_STD_GNU, gfc_check_fstat, NULL, gfc_resolve_fstat,
1632
             ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
1633
 
1634
  make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1635
 
1636
  add_sym_1 ("ftell", GFC_ISYM_FTELL, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
1637
             gfc_check_ftell, NULL, gfc_resolve_ftell,
1638
             ut, BT_INTEGER, di, REQUIRED);
1639
 
1640
  make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
1641
 
1642
  add_sym_2 ("fgetc", GFC_ISYM_FGETC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1643
             gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
1644
             ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1645
 
1646
  make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
1647
 
1648
  add_sym_1 ("fget", GFC_ISYM_FGET, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1649
             gfc_check_fgetput, NULL, gfc_resolve_fget,
1650
             c, BT_CHARACTER, dc, REQUIRED);
1651
 
1652
  make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
1653
 
1654
  add_sym_2 ("fputc", GFC_ISYM_FPUTC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1655
             gfc_check_fgetputc, NULL, gfc_resolve_fputc,
1656
             ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1657
 
1658
  make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
1659
 
1660
  add_sym_1 ("fput", GFC_ISYM_FPUT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1661
             gfc_check_fgetput, NULL, gfc_resolve_fput,
1662
             c, BT_CHARACTER, dc, REQUIRED);
1663
 
1664
  make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
1665
 
1666
  add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
1667
             GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma,
1668
             gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED);
1669
 
1670
  add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1671
             gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma,
1672
             x, BT_REAL, dr, REQUIRED);
1673
 
1674
  make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008);
1675
 
1676
  /* Unix IDs (g77 compatibility)  */
1677
  add_sym_1 ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,  GFC_STD_GNU,
1678
             NULL, NULL, gfc_resolve_getcwd,
1679
             c, BT_CHARACTER, dc, REQUIRED);
1680
 
1681
  make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1682
 
1683
  add_sym_0 ("getgid", GFC_ISYM_GETGID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1684
             NULL, NULL, gfc_resolve_getgid);
1685
 
1686
  make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1687
 
1688
  add_sym_0 ("getpid", GFC_ISYM_GETPID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1689
             NULL, NULL, gfc_resolve_getpid);
1690
 
1691
  make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1692
 
1693
  add_sym_0 ("getuid", GFC_ISYM_GETUID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1694
             NULL, NULL, gfc_resolve_getuid);
1695
 
1696
  make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1697
 
1698
  add_sym_1 ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1699
             gfc_check_hostnm, NULL, gfc_resolve_hostnm,
1700
             a, BT_CHARACTER, dc, REQUIRED);
1701
 
1702
  make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
1703
 
1704
  add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1705
             gfc_check_huge, gfc_simplify_huge, NULL,
1706
             x, BT_UNKNOWN, dr, REQUIRED);
1707
 
1708
  make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95);
1709
 
1710
  add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO,
1711
             BT_REAL, dr, GFC_STD_F2008,
1712
             gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot,
1713
             x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1714
 
1715
  make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008);
1716
 
1717
  add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
1718
             BT_INTEGER, di, GFC_STD_F95,
1719
             gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar,
1720
             c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1721
 
1722
  make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1723
 
1724
  add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1725
             gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1726
             i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1727
 
1728
  make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1729
 
1730
  add_sym_2 ("and", GFC_ISYM_AND, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1731
             gfc_check_and, gfc_simplify_and, gfc_resolve_and,
1732
             i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1733
 
1734
  make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
1735
 
1736
  add_sym_0 ("iargc", GFC_ISYM_IARGC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1737
             NULL, NULL, NULL);
1738
 
1739
  make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
1740
 
1741
  add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1742
             gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr,
1743
             i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1744
 
1745
  make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
1746
 
1747
  add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1748
             gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1749
             i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
1750
             ln, BT_INTEGER, di, REQUIRED);
1751
 
1752
  make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
1753
 
1754
  add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1755
             gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset,
1756
             i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1757
 
1758
  make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
1759
 
1760
  add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO,
1761
             BT_INTEGER, di, GFC_STD_F77,
1762
             gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
1763
             c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1764
 
1765
  make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
1766
 
1767
  add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1768
             gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1769
             i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1770
 
1771
  make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
1772
 
1773
  add_sym_2 ("xor", GFC_ISYM_XOR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1774
             gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
1775
             i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1776
 
1777
  make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
1778
 
1779
  add_sym_0 ("ierrno", GFC_ISYM_IERRNO, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1780
             NULL, NULL, gfc_resolve_ierrno);
1781
 
1782
  make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
1783
 
1784
  /* The resolution function for INDEX is called gfc_resolve_index_func
1785
     because the name gfc_resolve_index is already used in resolve.c.  */
1786
  add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
1787
             BT_INTEGER, di, GFC_STD_F77,
1788
             gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
1789
             stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
1790
             bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
1791
 
1792
  make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
1793
 
1794
  add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1795
             gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1796
             a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1797
 
1798
  add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1799
             NULL, gfc_simplify_ifix, NULL,
1800
             a, BT_REAL, dr, REQUIRED);
1801
 
1802
  add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1803
             NULL, gfc_simplify_idint, NULL,
1804
             a, BT_REAL, dd, REQUIRED);
1805
 
1806
  make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
1807
 
1808
  add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1809
             gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2,
1810
             a, BT_REAL, dr, REQUIRED);
1811
 
1812
  make_alias ("short", GFC_STD_GNU);
1813
 
1814
  make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU);
1815
 
1816
  add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1817
             gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8,
1818
             a, BT_REAL, dr, REQUIRED);
1819
 
1820
  make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU);
1821
 
1822
  add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1823
             gfc_check_intconv, gfc_simplify_long, gfc_resolve_long,
1824
             a, BT_REAL, dr, REQUIRED);
1825
 
1826
  make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
1827
 
1828
  add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1829
             gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1830
             i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1831
 
1832
  make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
1833
 
1834
  add_sym_2 ("or", GFC_ISYM_OR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1835
             gfc_check_and, gfc_simplify_or, gfc_resolve_or,
1836
             i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1837
 
1838
  make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
1839
 
1840
  /* The following function is for G77 compatibility.  */
1841
  add_sym_1 ("irand", GFC_ISYM_IRAND, NO_CLASS, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU,
1842
             gfc_check_irand, NULL, NULL,
1843
             i, BT_INTEGER, 4, OPTIONAL);
1844
 
1845
  make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
1846
 
1847
  add_sym_1 ("isatty", GFC_ISYM_ISATTY, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1848
             gfc_check_isatty, NULL, gfc_resolve_isatty,
1849
             ut, BT_INTEGER, di, REQUIRED);
1850
 
1851
  make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
1852
 
1853
  add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END,
1854
             CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
1855
             gfc_check_i, gfc_simplify_is_iostat_end, NULL,
1856
             i, BT_INTEGER, 0, REQUIRED);
1857
 
1858
  make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003);
1859
 
1860
  add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR,
1861
             CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
1862
             gfc_check_i, gfc_simplify_is_iostat_eor, NULL,
1863
             i, BT_INTEGER, 0, REQUIRED);
1864
 
1865
  make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003);
1866
 
1867
  add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO,
1868
             BT_LOGICAL, dl, GFC_STD_GNU,
1869
             gfc_check_isnan, gfc_simplify_isnan, NULL,
1870
             x, BT_REAL, 0, REQUIRED);
1871
 
1872
  make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU);
1873
 
1874
  add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1875
             gfc_check_ishft, NULL, gfc_resolve_rshift,
1876
             i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1877
 
1878
  make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU);
1879
 
1880
  add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1881
             gfc_check_ishft, NULL, gfc_resolve_lshift,
1882
             i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1883
 
1884
  make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU);
1885
 
1886
  add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1887
             gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1888
             i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1889
 
1890
  make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
1891
 
1892
  add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1893
             gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1894
             i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1895
             sz, BT_INTEGER, di, OPTIONAL);
1896
 
1897
  make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
1898
 
1899
  add_sym_2 ("kill", GFC_ISYM_KILL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1900
             gfc_check_kill, NULL, gfc_resolve_kill,
1901
             a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1902
 
1903
  make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
1904
 
1905
  add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1906
             gfc_check_kind, gfc_simplify_kind, NULL,
1907
             x, BT_REAL, dr, REQUIRED);
1908
 
1909
  make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95);
1910
 
1911
  add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO,
1912
             BT_INTEGER, di, GFC_STD_F95,
1913
             gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1914
             ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL,
1915
             kind, BT_INTEGER, di, OPTIONAL);
1916
 
1917
  make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
1918
 
1919
  add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
1920
             BT_INTEGER, di, GFC_STD_F2008,
1921
             gfc_check_i, gfc_simplify_leadz, NULL,
1922
             i, BT_INTEGER, di, REQUIRED);
1923
 
1924
  make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008);
1925
 
1926
  add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES,
1927
             BT_INTEGER, di, GFC_STD_F77,
1928
             gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len,
1929
             stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1930
 
1931
  make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
1932
 
1933
  add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO,
1934
             BT_INTEGER, di, GFC_STD_F95,
1935
             gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim,
1936
             stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1937
 
1938
  make_alias ("lnblnk", GFC_STD_GNU);
1939
 
1940
  make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
1941
 
1942
  add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL,
1943
             dr, GFC_STD_GNU,
1944
             gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
1945
             x, BT_REAL, dr, REQUIRED);
1946
 
1947
  make_alias ("log_gamma", GFC_STD_F2008);
1948
 
1949
  add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1950
             gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
1951
             x, BT_REAL, dr, REQUIRED);
1952
 
1953
  add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1954
             gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma,
1955
             x, BT_REAL, dr, REQUIRED);
1956
 
1957
  make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008);
1958
 
1959
 
1960
  add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
1961
             GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL,
1962
             sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1963
 
1964
  make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
1965
 
1966
  add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
1967
             GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL,
1968
             sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1969
 
1970
  make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
1971
 
1972
  add_sym_2 ("lle",GFC_ISYM_LLE,  CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
1973
             GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL,
1974
             sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1975
 
1976
  make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
1977
 
1978
  add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
1979
             GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL,
1980
             sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1981
 
1982
  make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
1983
 
1984
  add_sym_2 ("link", GFC_ISYM_LINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
1985
             GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link,
1986
             p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
1987
 
1988
  make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
1989
 
1990
  add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1991
             gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
1992
             x, BT_REAL, dr, REQUIRED);
1993
 
1994
  add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1995
             NULL, gfc_simplify_log, gfc_resolve_log,
1996
             x, BT_REAL, dr, REQUIRED);
1997
 
1998
  add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1999
             gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log,
2000
             x, BT_REAL, dd, REQUIRED);
2001
 
2002
  add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2003
             NULL, gfc_simplify_log, gfc_resolve_log,
2004
             x, BT_COMPLEX, dz, REQUIRED);
2005
 
2006
  add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd,  GFC_STD_GNU,
2007
             NULL, gfc_simplify_log, gfc_resolve_log,
2008
             x, BT_COMPLEX, dd, REQUIRED);
2009
 
2010
  make_alias ("cdlog", GFC_STD_GNU);
2011
 
2012
  make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
2013
 
2014
  add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2015
             gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
2016
             x, BT_REAL, dr, REQUIRED);
2017
 
2018
  add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2019
             NULL, gfc_simplify_log10, gfc_resolve_log10,
2020
             x, BT_REAL, dr, REQUIRED);
2021
 
2022
  add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2023
             gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10,
2024
             x, BT_REAL, dd, REQUIRED);
2025
 
2026
  make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
2027
 
2028
  add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
2029
             gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
2030
             l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2031
 
2032
  make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
2033
 
2034
  add_sym_2 ("lstat", GFC_ISYM_LSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2035
             GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_lstat,
2036
             nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2037
 
2038
  make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
2039
 
2040
  add_sym_1 ("malloc", GFC_ISYM_MALLOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
2041
             GFC_STD_GNU, gfc_check_malloc, NULL, gfc_resolve_malloc,
2042
             sz, BT_INTEGER, di, REQUIRED);
2043
 
2044
  make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
2045
 
2046
  add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2047
             gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul,
2048
             ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
2049
 
2050
  make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
2051
 
2052
  /* Note: amax0 is equivalent to real(max), max1 is equivalent to
2053
     int(max).  The max function must take at least two arguments.  */
2054
 
2055
  add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
2056
             gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
2057
             a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
2058
 
2059
  add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2060
             gfc_check_min_max_integer, gfc_simplify_max, NULL,
2061
             a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2062
 
2063
  add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2064
             gfc_check_min_max_integer, gfc_simplify_max, NULL,
2065
             a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2066
 
2067
  add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2068
             gfc_check_min_max_real, gfc_simplify_max, NULL,
2069
             a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2070
 
2071
  add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2072
             gfc_check_min_max_real, gfc_simplify_max, NULL,
2073
             a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2074
 
2075
  add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
2076
             gfc_check_min_max_double, gfc_simplify_max, NULL,
2077
             a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
2078
 
2079
  make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
2080
 
2081
  add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
2082
             GFC_STD_F95, gfc_check_x, gfc_simplify_maxexponent, NULL,
2083
             x, BT_UNKNOWN, dr, REQUIRED);
2084
 
2085
  make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
2086
 
2087
  add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2088
               gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
2089
               ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2090
               msk, BT_LOGICAL, dl, OPTIONAL);
2091
 
2092
  make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
2093
 
2094
  add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2095
                gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,
2096
                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2097
                msk, BT_LOGICAL, dl, OPTIONAL);
2098
 
2099
  make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
2100
 
2101
  add_sym_0 ("mclock", GFC_ISYM_MCLOCK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2102
             GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock);
2103
 
2104
  make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
2105
 
2106
  add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2107
             GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
2108
 
2109
  make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
2110
 
2111
  add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2112
             gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge,
2113
             ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
2114
             msk, BT_LOGICAL, dl, REQUIRED);
2115
 
2116
  make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
2117
 
2118
  /* Note: amin0 is equivalent to real(min), min1 is equivalent to
2119
     int(min).  */
2120
 
2121
  add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
2122
              gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
2123
              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2124
 
2125
  add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2126
              gfc_check_min_max_integer, gfc_simplify_min, NULL,
2127
              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2128
 
2129
  add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2130
              gfc_check_min_max_integer, gfc_simplify_min, NULL,
2131
              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2132
 
2133
  add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2134
              gfc_check_min_max_real, gfc_simplify_min, NULL,
2135
              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2136
 
2137
  add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2138
              gfc_check_min_max_real, gfc_simplify_min, NULL,
2139
              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2140
 
2141
  add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
2142
              gfc_check_min_max_double, gfc_simplify_min, NULL,
2143
              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
2144
 
2145
  make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
2146
 
2147
  add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
2148
             GFC_STD_F95, gfc_check_x, gfc_simplify_minexponent, NULL,
2149
             x, BT_UNKNOWN, dr, REQUIRED);
2150
 
2151
  make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
2152
 
2153
  add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2154
               gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
2155
               ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2156
               msk, BT_LOGICAL, dl, OPTIONAL);
2157
 
2158
  make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
2159
 
2160
  add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2161
                gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval,
2162
                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2163
                msk, BT_LOGICAL, dl, OPTIONAL);
2164
 
2165
  make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
2166
 
2167
  add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2168
             gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
2169
             a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
2170
 
2171
  add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2172
             NULL, gfc_simplify_mod, gfc_resolve_mod,
2173
             a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
2174
 
2175
  add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2176
             gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod,
2177
             a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
2178
 
2179
  make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
2180
 
2181
  add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95,
2182
             gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
2183
             a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
2184
 
2185
  make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
2186
 
2187
  add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2188
             gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
2189
             x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
2190
 
2191
  make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
2192
 
2193
  add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc,
2194
             GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
2195
             a, BT_CHARACTER, dc, REQUIRED);
2196
 
2197
  make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003);
2198
 
2199
  add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2200
             gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
2201
             a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2202
 
2203
  add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2204
             gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
2205
             a, BT_REAL, dd, REQUIRED);
2206
 
2207
  make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
2208
 
2209
  add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2210
             gfc_check_i, gfc_simplify_not, gfc_resolve_not,
2211
             i, BT_INTEGER, di, REQUIRED);
2212
 
2213
  make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
2214
 
2215
  add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2216
             gfc_check_null, gfc_simplify_null, NULL,
2217
             mo, BT_INTEGER, di, OPTIONAL);
2218
 
2219
  make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
2220
 
2221
  add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2222
             gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
2223
             ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2224
             v, BT_REAL, dr, OPTIONAL);
2225
 
2226
  make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
2227
 
2228
  add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2229
             gfc_check_precision, gfc_simplify_precision, NULL,
2230
             x, BT_UNKNOWN, 0, REQUIRED);
2231
 
2232
  make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
2233
 
2234
  add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO,
2235
                    BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL,
2236
                    a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN);
2237
 
2238
  make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
2239
 
2240
  add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2241
                gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product,
2242
                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2243
                msk, BT_LOGICAL, dl, OPTIONAL);
2244
 
2245
  make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
2246
 
2247
  add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2248
             gfc_check_radix, gfc_simplify_radix, NULL,
2249
             x, BT_UNKNOWN, 0, REQUIRED);
2250
 
2251
  make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95);
2252
 
2253
  /* The following function is for G77 compatibility.  */
2254
  add_sym_1 ("rand", GFC_ISYM_RAND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
2255
             gfc_check_rand, NULL, NULL,
2256
             i, BT_INTEGER, 4, OPTIONAL);
2257
 
2258
  /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and ran()
2259
     use slightly different shoddy multiplicative congruential PRNG.  */
2260
  make_alias ("ran", GFC_STD_GNU);
2261
 
2262
  make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
2263
 
2264
  add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2265
             gfc_check_range, gfc_simplify_range, NULL,
2266
             x, BT_REAL, dr, REQUIRED);
2267
 
2268
  make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
2269
 
2270
  add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2271
             gfc_check_real, gfc_simplify_real, gfc_resolve_real,
2272
             a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2273
 
2274
  /* This provides compatibility with g77.  */
2275
  add_sym_1 ("realpart", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
2276
             gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
2277
             a, BT_UNKNOWN, dr, REQUIRED);
2278
 
2279
  add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2280
             gfc_check_i, gfc_simplify_float, NULL,
2281
             a, BT_INTEGER, di, REQUIRED);
2282
 
2283
  add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2284
             NULL, gfc_simplify_sngl, NULL,
2285
             a, BT_REAL, dd, REQUIRED);
2286
 
2287
  make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
2288
 
2289
  add_sym_2 ("rename", GFC_ISYM_RENAME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2290
             GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename,
2291
             p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
2292
 
2293
  make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
2294
 
2295
  add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
2296
             gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
2297
             stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
2298
 
2299
  make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
2300
 
2301
  add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2302
             gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
2303
             src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
2304
             pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
2305
 
2306
  make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
2307
 
2308
  add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2309
             gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
2310
             x, BT_REAL, dr, REQUIRED);
2311
 
2312
  make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
2313
 
2314
  add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
2315
             BT_LOGICAL, dl, GFC_STD_F2003,
2316
             gfc_check_same_type_as, NULL, NULL,
2317
             a, BT_UNKNOWN, 0, REQUIRED,
2318
             b, BT_UNKNOWN, 0, REQUIRED);
2319
 
2320
  add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2321
             gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
2322
             x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
2323
 
2324
  make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
2325
 
2326
  add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO,
2327
             BT_INTEGER, di, GFC_STD_F95,
2328
             gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
2329
             stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2330
             bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
2331
 
2332
  make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
2333
 
2334
  /* Added for G77 compatibility garbage.  */
2335
  add_sym_0 ("second", GFC_ISYM_SECOND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
2336
             NULL, NULL, NULL);
2337
 
2338
  make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
2339
 
2340
  /* Added for G77 compatibility.  */
2341
  add_sym_1 ("secnds", GFC_ISYM_SECNDS, NO_CLASS, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
2342
             gfc_check_secnds, NULL, gfc_resolve_secnds,
2343
             x, BT_REAL, dr, REQUIRED);
2344
 
2345
  make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
2346
 
2347
  add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL,
2348
             ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003,
2349
             gfc_check_selected_char_kind, gfc_simplify_selected_char_kind,
2350
             NULL, nm, BT_CHARACTER, dc, REQUIRED);
2351
 
2352
  make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003);
2353
 
2354
  add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
2355
             GFC_STD_F95, gfc_check_selected_int_kind,
2356
             gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
2357
 
2358
  make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
2359
 
2360
  add_sym_2 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
2361
             GFC_STD_F95, gfc_check_selected_real_kind,
2362
             gfc_simplify_selected_real_kind, NULL,
2363
             p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
2364
 
2365
  make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
2366
 
2367
  add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2368
             gfc_check_set_exponent, gfc_simplify_set_exponent,
2369
             gfc_resolve_set_exponent,
2370
             x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
2371
 
2372
  make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
2373
 
2374
  add_sym_1 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2375
             gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
2376
             src, BT_REAL, dr, REQUIRED);
2377
 
2378
  make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
2379
 
2380
  add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2381
             gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
2382
             a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
2383
 
2384
  add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2385
             NULL, gfc_simplify_sign, gfc_resolve_sign,
2386
             a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2387
 
2388
  add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2389
             gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign,
2390
             a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
2391
 
2392
  make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
2393
 
2394
  add_sym_2 ("signal", GFC_ISYM_SIGNAL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2395
             gfc_check_signal, NULL, gfc_resolve_signal,
2396
             num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
2397
 
2398
  make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
2399
 
2400
  add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2401
             gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
2402
             x, BT_REAL, dr, REQUIRED);
2403
 
2404
  add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2405
             gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin,
2406
             x, BT_REAL, dd, REQUIRED);
2407
 
2408
  add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2409
             NULL, gfc_simplify_sin, gfc_resolve_sin,
2410
             x, BT_COMPLEX, dz, REQUIRED);
2411
 
2412
  add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2413
             NULL, gfc_simplify_sin, gfc_resolve_sin,
2414
             x, BT_COMPLEX, dd, REQUIRED);
2415
 
2416
  make_alias ("cdsin", GFC_STD_GNU);
2417
 
2418
  make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
2419
 
2420
  add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2421
             gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh,
2422
             x, BT_REAL, dr, REQUIRED);
2423
 
2424
  add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2425
             gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh,
2426
             x, BT_REAL, dd, REQUIRED);
2427
 
2428
  make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
2429
 
2430
  add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO,
2431
             BT_INTEGER, di, GFC_STD_F95,
2432
             gfc_check_size, gfc_simplify_size, gfc_resolve_size,
2433
             ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2434
             kind, BT_INTEGER, di, OPTIONAL);
2435
 
2436
  make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
2437
 
2438
  add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
2439
             GFC_STD_GNU, gfc_check_sizeof, NULL, NULL,
2440
             x, BT_UNKNOWN, 0, REQUIRED);
2441
 
2442
  make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
2443
  make_alias ("c_sizeof", GFC_STD_F2008);
2444
 
2445
  add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2446
             gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
2447
             x, BT_REAL, dr, REQUIRED);
2448
 
2449
  make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
2450
 
2451
  add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2452
             gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread,
2453
             src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
2454
             ncopies, BT_INTEGER, di, REQUIRED);
2455
 
2456
  make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
2457
 
2458
  add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2459
             gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
2460
             x, BT_REAL, dr, REQUIRED);
2461
 
2462
  add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2463
             gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt,
2464
             x, BT_REAL, dd, REQUIRED);
2465
 
2466
  add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2467
             NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2468
             x, BT_COMPLEX, dz, REQUIRED);
2469
 
2470
  add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2471
             NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2472
             x, BT_COMPLEX, dd, REQUIRED);
2473
 
2474
  make_alias ("cdsqrt", GFC_STD_GNU);
2475
 
2476
  make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
2477
 
2478
  add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2479
             GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_stat,
2480
             nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2481
 
2482
  make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
2483
 
2484
  add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2485
                gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
2486
                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2487
                msk, BT_LOGICAL, dl, OPTIONAL);
2488
 
2489
  make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
2490
 
2491
  add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2492
             GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk,
2493
             p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
2494
 
2495
  make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
2496
 
2497
  add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2498
             GFC_STD_GNU, NULL, NULL, NULL,
2499
             com, BT_CHARACTER, dc, REQUIRED);
2500
 
2501
  make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
2502
 
2503
  add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2504
             gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan,
2505
             x, BT_REAL, dr, REQUIRED);
2506
 
2507
  add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2508
             gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan,
2509
             x, BT_REAL, dd, REQUIRED);
2510
 
2511
  make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
2512
 
2513
  add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2514
             gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh,
2515
             x, BT_REAL, dr, REQUIRED);
2516
 
2517
  add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2518
             gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh,
2519
             x, BT_REAL, dd, REQUIRED);
2520
 
2521
  make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
2522
 
2523
  add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2524
             NULL, NULL, gfc_resolve_time);
2525
 
2526
  make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
2527
 
2528
  add_sym_0 ("time8", GFC_ISYM_TIME8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2529
             NULL, NULL, gfc_resolve_time8);
2530
 
2531
  make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
2532
 
2533
  add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2534
             gfc_check_x, gfc_simplify_tiny, NULL,
2535
             x, BT_REAL, dr, REQUIRED);
2536
 
2537
  make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
2538
 
2539
  add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO,
2540
             BT_INTEGER, di, GFC_STD_F2008,
2541
             gfc_check_i, gfc_simplify_trailz, NULL,
2542
             i, BT_INTEGER, di, REQUIRED);
2543
 
2544
  make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008);
2545
 
2546
  add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2547
             gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
2548
             src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
2549
             sz, BT_INTEGER, di, OPTIONAL);
2550
 
2551
  make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
2552
 
2553
  add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2554
             gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose,
2555
             m, BT_REAL, dr, REQUIRED);
2556
 
2557
  make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2558
 
2559
  add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
2560
             gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2561
             stg, BT_CHARACTER, dc, REQUIRED);
2562
 
2563
  make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2564
 
2565
  add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
2566
             gfc_check_ttynam, NULL, gfc_resolve_ttynam,
2567
             ut, BT_INTEGER, di, REQUIRED);
2568
 
2569
  make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
2570
 
2571
  add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO,
2572
             BT_INTEGER, di, GFC_STD_F95,
2573
             gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2574
             ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2575
             kind, BT_INTEGER, di, OPTIONAL);
2576
 
2577
  make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2578
 
2579
  /* g77 compatibility for UMASK.  */
2580
  add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
2581
             GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
2582
             msk, BT_INTEGER, di, REQUIRED);
2583
 
2584
  make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2585
 
2586
  /* g77 compatibility for UNLINK.  */
2587
  add_sym_1 ("unlink", GFC_ISYM_UNLINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2588
             gfc_check_unlink, NULL, gfc_resolve_unlink,
2589
             "path", BT_CHARACTER, dc, REQUIRED);
2590
 
2591
  make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2592
 
2593
  add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2594
             gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack,
2595
             v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2596
             f, BT_REAL, dr, REQUIRED);
2597
 
2598
  make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2599
 
2600
  add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO,
2601
             BT_INTEGER, di, GFC_STD_F95,
2602
             gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2603
             stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2604
             bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
2605
 
2606
  make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2607
 
2608
  add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
2609
             GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
2610
             x, BT_UNKNOWN, 0, REQUIRED);
2611
 
2612
  make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
2613
}
2614
 
2615
 
2616
/* Add intrinsic subroutines.  */
2617
 
2618
static void
2619
add_subroutines (void)
2620
{
2621
  /* Argument names as in the standard (to be used as argument keywords).  */
2622
  const char
2623
    *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2624
    *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2625
    *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2626
    *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2627
    *com = "command", *length = "length", *st = "status",
2628
    *val = "value", *num = "number", *name = "name",
2629
    *trim_name = "trim_name", *ut = "unit", *han = "handler",
2630
    *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
2631
    *whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
2632
    *p2 = "path2", *msk = "mask", *old = "old";
2633
 
2634
  int di, dr, dc, dl, ii;
2635
 
2636
  di = gfc_default_integer_kind;
2637
  dr = gfc_default_real_kind;
2638
  dc = gfc_default_character_kind;
2639
  dl = gfc_default_logical_kind;
2640
  ii = gfc_index_integer_kind;
2641
 
2642
  add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL);
2643
 
2644
  make_noreturn();
2645
 
2646
  add_sym_1s_intent ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0,
2647
                     GFC_STD_F95, gfc_check_cpu_time, NULL,
2648
                     gfc_resolve_cpu_time,
2649
                     tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
2650
 
2651
  /* More G77 compatibility garbage.  */
2652
  add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2653
              gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
2654
              tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
2655
 
2656
  add_sym_1s ("idate", GFC_ISYM_IDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2657
              gfc_check_itime_idate, NULL, gfc_resolve_idate,
2658
              vl, BT_INTEGER, 4, REQUIRED);
2659
 
2660
  add_sym_1s ("itime", GFC_ISYM_ITIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2661
              gfc_check_itime_idate, NULL, gfc_resolve_itime,
2662
              vl, BT_INTEGER, 4, REQUIRED);
2663
 
2664
  add_sym_2s ("ltime", GFC_ISYM_LTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2665
              gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
2666
              tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2667
 
2668
  add_sym_2s ("gmtime", GFC_ISYM_GMTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2669
              gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
2670
              tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2671
 
2672
  add_sym_1s ("second", GFC_ISYM_SECOND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2673
              gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2674
              tm, BT_REAL, dr, REQUIRED);
2675
 
2676
  add_sym_2s ("chdir", GFC_ISYM_CHDIR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2677
              gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2678
              name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2679
 
2680
  add_sym_3s ("chmod", GFC_ISYM_CHMOD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2681
              gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
2682
              name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
2683
              st, BT_INTEGER, di, OPTIONAL);
2684
 
2685
  add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0,
2686
              GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
2687
              dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
2688
              tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
2689
              zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
2690
              vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
2691
 
2692
  /* More G77 compatibility garbage.  */
2693
  add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2694
              gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub,
2695
              vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2696
 
2697
  add_sym_2s ("dtime", GFC_ISYM_DTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2698
              gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub,
2699
              vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2700
 
2701
  add_sym_1s ("fdate", GFC_ISYM_FDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2702
              gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
2703
              dt, BT_CHARACTER, dc, REQUIRED);
2704
 
2705
  add_sym_1s ("gerror", GFC_ISYM_GERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2706
              gfc_check_gerror, NULL, gfc_resolve_gerror, res, BT_CHARACTER,
2707
              dc, REQUIRED);
2708
 
2709
  add_sym_2s ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2710
              gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2711
              c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2712
 
2713
  add_sym_2s ("getenv", GFC_ISYM_GETENV, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2714
              NULL, NULL, NULL,
2715
              name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc,
2716
              REQUIRED);
2717
 
2718
  add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2719
              gfc_check_getarg, NULL, gfc_resolve_getarg,
2720
              pos, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2721
 
2722
  add_sym_1s ("getlog", GFC_ISYM_GETLOG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2723
              gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2724
              dc, REQUIRED);
2725
 
2726
  /* F2003 commandline routines.  */
2727
 
2728
  add_sym_3s_intent ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN,
2729
                     0, GFC_STD_F2003, NULL, NULL, gfc_resolve_get_command,
2730
                     com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
2731
                     length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2732
                     st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
2733
 
2734
  add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS,
2735
              BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
2736
              gfc_resolve_get_command_argument,
2737
              num, BT_INTEGER, di, REQUIRED, INTENT_IN,
2738
              val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
2739
              length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2740
              st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
2741
 
2742
  /* F2003 subroutine to get environment variables.  */
2743
 
2744
  add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
2745
              NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2746
              NULL, NULL, gfc_resolve_get_environment_variable,
2747
              name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
2748
              val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
2749
              length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2750
              st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2751
              trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
2752
 
2753
  add_sym_2s_intent ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0,
2754
                     GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL,
2755
                     f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
2756
                     t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
2757
 
2758
  add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0,
2759
              GFC_STD_F95, gfc_check_mvbits, gfc_simplify_mvbits,
2760
              gfc_resolve_mvbits,
2761
              f, BT_INTEGER, di, REQUIRED, INTENT_IN,
2762
              fp, BT_INTEGER, di, REQUIRED, INTENT_IN,
2763
              ln, BT_INTEGER, di, REQUIRED, INTENT_IN,
2764
              t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
2765
              tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
2766
 
2767
  add_sym_1s_intent ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS,
2768
                     BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_random_number, NULL,
2769
                     gfc_resolve_random_number,
2770
                     h, BT_REAL, dr, REQUIRED, INTENT_OUT);
2771
 
2772
  add_sym_3s_intent ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
2773
                     BT_UNKNOWN, 0, GFC_STD_F95,
2774
                     gfc_check_random_seed, NULL, gfc_resolve_random_seed,
2775
                     sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2776
                     pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
2777
                     gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
2778
 
2779
  /* More G77 compatibility garbage.  */
2780
  add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2781
              gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
2782
              sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2783
              st, BT_INTEGER, di, OPTIONAL);
2784
 
2785
  add_sym_1s ("srand", GFC_ISYM_SRAND, NO_CLASS, BT_UNKNOWN, di, GFC_STD_GNU,
2786
              gfc_check_srand, NULL, gfc_resolve_srand,
2787
              "seed", BT_INTEGER, 4, REQUIRED);
2788
 
2789
  add_sym_1s ("exit", GFC_ISYM_EXIT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2790
              gfc_check_exit, NULL, gfc_resolve_exit,
2791
              st, BT_INTEGER, di, OPTIONAL);
2792
 
2793
  make_noreturn();
2794
 
2795
  add_sym_3s ("fgetc", GFC_ISYM_FGETC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2796
              gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
2797
              ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2798
              st, BT_INTEGER, di, OPTIONAL);
2799
 
2800
  add_sym_2s ("fget", GFC_ISYM_FGET, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2801
              gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
2802
              c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2803
 
2804
  add_sym_1s ("flush", GFC_ISYM_FLUSH, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2805
              gfc_check_flush, NULL, gfc_resolve_flush,
2806
              ut, BT_INTEGER, di, OPTIONAL);
2807
 
2808
  add_sym_3s ("fputc", GFC_ISYM_FPUTC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2809
              gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
2810
              ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2811
              st, BT_INTEGER, di, OPTIONAL);
2812
 
2813
  add_sym_2s ("fput", GFC_ISYM_FPUT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2814
              gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
2815
              c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2816
 
2817
  add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2818
              gfc_check_free, NULL, gfc_resolve_free,
2819
              ptr, BT_INTEGER, ii, REQUIRED);
2820
 
2821
  add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2822
              gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
2823
              ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
2824
              of, BT_INTEGER, di, REQUIRED, INTENT_IN,
2825
              whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
2826
              st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
2827
 
2828
  add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2829
              gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
2830
              ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
2831
 
2832
  add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2833
              gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2834
              c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2835
 
2836
  add_sym_3s ("kill", GFC_ISYM_KILL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2837
              NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2838
              val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2839
 
2840
  add_sym_3s ("link", GFC_ISYM_LINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2841
              gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2842
              p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
2843
              dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2844
 
2845
  add_sym_1s ("perror", GFC_ISYM_PERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2846
              gfc_check_perror, NULL, gfc_resolve_perror,
2847
              "string", BT_CHARACTER, dc, REQUIRED);
2848
 
2849
  add_sym_3s ("rename", GFC_ISYM_RENAME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2850
              gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2851
              p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
2852
              dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2853
 
2854
  add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2855
              gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2856
              sec, BT_INTEGER, di, REQUIRED);
2857
 
2858
  add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2859
              gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2860
              ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2861
              st, BT_INTEGER, di, OPTIONAL);
2862
 
2863
  add_sym_3s ("lstat", GFC_ISYM_LSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2864
              gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
2865
              name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2866
              st, BT_INTEGER, di, OPTIONAL);
2867
 
2868
  add_sym_3s ("stat", GFC_ISYM_STAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2869
              gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2870
              name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2871
              st, BT_INTEGER, di, OPTIONAL);
2872
 
2873
  add_sym_3s ("signal", GFC_ISYM_SIGNAL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2874
              gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
2875
              num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2876
              st, BT_INTEGER, di, OPTIONAL);
2877
 
2878
  add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2879
              gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2880
              p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
2881
              dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2882
 
2883
  add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2884
              NULL, NULL, gfc_resolve_system_sub,
2885
              com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2886
 
2887
  add_sym_3s_intent ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS,
2888
                     BT_UNKNOWN, 0, GFC_STD_F95,
2889
                     gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2890
                     c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2891
                     cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
2892
                     cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
2893
 
2894
  add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2895
              gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
2896
              ut, BT_INTEGER, di, REQUIRED, name, BT_CHARACTER, dc, REQUIRED);
2897
 
2898
  add_sym_2s ("umask", GFC_ISYM_UMASK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2899
              gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2900
              msk, BT_INTEGER, di, REQUIRED, old, BT_INTEGER, di, OPTIONAL);
2901
 
2902
  add_sym_2s ("unlink", GFC_ISYM_UNLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2903
              gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2904
              "path", BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2905
}
2906
 
2907
 
2908
/* Add a function to the list of conversion symbols.  */
2909
 
2910
static void
2911
add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2912
{
2913
  gfc_typespec from, to;
2914
  gfc_intrinsic_sym *sym;
2915
 
2916
  if (sizing == SZ_CONVS)
2917
    {
2918
      nconv++;
2919
      return;
2920
    }
2921
 
2922
  gfc_clear_ts (&from);
2923
  from.type = from_type;
2924
  from.kind = from_kind;
2925
 
2926
  gfc_clear_ts (&to);
2927
  to.type = to_type;
2928
  to.kind = to_kind;
2929
 
2930
  sym = conversion + nconv;
2931
 
2932
  sym->name = conv_name (&from, &to);
2933
  sym->lib_name = sym->name;
2934
  sym->simplify.cc = gfc_convert_constant;
2935
  sym->standard = standard;
2936
  sym->elemental = 1;
2937
  sym->conversion = 1;
2938
  sym->ts = to;
2939
  sym->id = GFC_ISYM_CONVERSION;
2940
 
2941
  nconv++;
2942
}
2943
 
2944
 
2945
/* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2946
   functions by looping over the kind tables.  */
2947
 
2948
static void
2949
add_conversions (void)
2950
{
2951
  int i, j;
2952
 
2953
  /* Integer-Integer conversions.  */
2954
  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2955
    for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2956
      {
2957
        if (i == j)
2958
          continue;
2959
 
2960
        add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2961
                  BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2962
      }
2963
 
2964
  /* Integer-Real/Complex conversions.  */
2965
  for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2966
    for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2967
      {
2968
        add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2969
                  BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2970
 
2971
        add_conv (BT_REAL, gfc_real_kinds[j].kind,
2972
                  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2973
 
2974
        add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2975
                  BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2976
 
2977
        add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2978
                  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2979
      }
2980
 
2981
  if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2982
    {
2983
      /* Hollerith-Integer conversions.  */
2984
      for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2985
        add_conv (BT_HOLLERITH, gfc_default_character_kind,
2986
                  BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2987
      /* Hollerith-Real conversions.  */
2988
      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2989
        add_conv (BT_HOLLERITH, gfc_default_character_kind,
2990
                  BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2991
      /* Hollerith-Complex conversions.  */
2992
      for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2993
        add_conv (BT_HOLLERITH, gfc_default_character_kind,
2994
                  BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2995
 
2996
      /* Hollerith-Character conversions.  */
2997
      add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2998
                  gfc_default_character_kind, GFC_STD_LEGACY);
2999
 
3000
      /* Hollerith-Logical conversions.  */
3001
      for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
3002
        add_conv (BT_HOLLERITH, gfc_default_character_kind,
3003
                  BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
3004
    }
3005
 
3006
  /* Real/Complex - Real/Complex conversions.  */
3007
  for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3008
    for (j = 0; gfc_real_kinds[j].kind != 0; j++)
3009
      {
3010
        if (i != j)
3011
          {
3012
            add_conv (BT_REAL, gfc_real_kinds[i].kind,
3013
                      BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
3014
 
3015
            add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
3016
                      BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
3017
          }
3018
 
3019
        add_conv (BT_REAL, gfc_real_kinds[i].kind,
3020
                  BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
3021
 
3022
        add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
3023
                  BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
3024
      }
3025
 
3026
  /* Logical/Logical kind conversion.  */
3027
  for (i = 0; gfc_logical_kinds[i].kind; i++)
3028
    for (j = 0; gfc_logical_kinds[j].kind; j++)
3029
      {
3030
        if (i == j)
3031
          continue;
3032
 
3033
        add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
3034
                  BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
3035
      }
3036
 
3037
  /* Integer-Logical and Logical-Integer conversions.  */
3038
  if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
3039
    for (i=0; gfc_integer_kinds[i].kind; i++)
3040
      for (j=0; gfc_logical_kinds[j].kind; j++)
3041
        {
3042
          add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
3043
                    BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
3044
          add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
3045
                    BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
3046
        }
3047
}
3048
 
3049
 
3050
static void
3051
add_char_conversions (void)
3052
{
3053
  int n, i, j;
3054
 
3055
  /* Count possible conversions.  */
3056
  for (i = 0; gfc_character_kinds[i].kind != 0; i++)
3057
    for (j = 0; gfc_character_kinds[j].kind != 0; j++)
3058
      if (i != j)
3059
        ncharconv++;
3060
 
3061
  /* Allocate memory.  */
3062
  char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv);
3063
 
3064
  /* Add the conversions themselves.  */
3065
  n = 0;
3066
  for (i = 0; gfc_character_kinds[i].kind != 0; i++)
3067
    for (j = 0; gfc_character_kinds[j].kind != 0; j++)
3068
      {
3069
        gfc_typespec from, to;
3070
 
3071
        if (i == j)
3072
          continue;
3073
 
3074
        gfc_clear_ts (&from);
3075
        from.type = BT_CHARACTER;
3076
        from.kind = gfc_character_kinds[i].kind;
3077
 
3078
        gfc_clear_ts (&to);
3079
        to.type = BT_CHARACTER;
3080
        to.kind = gfc_character_kinds[j].kind;
3081
 
3082
        char_conversions[n].name = conv_name (&from, &to);
3083
        char_conversions[n].lib_name = char_conversions[n].name;
3084
        char_conversions[n].simplify.cc = gfc_convert_char_constant;
3085
        char_conversions[n].standard = GFC_STD_F2003;
3086
        char_conversions[n].elemental = 1;
3087
        char_conversions[n].conversion = 0;
3088
        char_conversions[n].ts = to;
3089
        char_conversions[n].id = GFC_ISYM_CONVERSION;
3090
 
3091
        n++;
3092
      }
3093
}
3094
 
3095
 
3096
/* Initialize the table of intrinsics.  */
3097
void
3098
gfc_intrinsic_init_1 (void)
3099
{
3100
  int i;
3101
 
3102
  nargs = nfunc = nsub = nconv = 0;
3103
 
3104
  /* Create a namespace to hold the resolved intrinsic symbols.  */
3105
  gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
3106
 
3107
  sizing = SZ_FUNCS;
3108
  add_functions ();
3109
  sizing = SZ_SUBS;
3110
  add_subroutines ();
3111
  sizing = SZ_CONVS;
3112
  add_conversions ();
3113
 
3114
  functions = XCNEWVAR (struct gfc_intrinsic_sym,
3115
                        sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
3116
                        + sizeof (gfc_intrinsic_arg) * nargs);
3117
 
3118
  next_sym = functions;
3119
  subroutines = functions + nfunc;
3120
 
3121
  conversion = XCNEWVEC (gfc_intrinsic_sym, nconv);
3122
 
3123
  next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
3124
 
3125
  sizing = SZ_NOTHING;
3126
  nconv = 0;
3127
 
3128
  add_functions ();
3129
  add_subroutines ();
3130
  add_conversions ();
3131
 
3132
  /* Character conversion intrinsics need to be treated separately.  */
3133
  add_char_conversions ();
3134
 
3135
  /* Set the pure flag.  All intrinsic functions are pure, and
3136
     intrinsic subroutines are pure if they are elemental.  */
3137
 
3138
  for (i = 0; i < nfunc; i++)
3139
    functions[i].pure = 1;
3140
 
3141
  for (i = 0; i < nsub; i++)
3142
    subroutines[i].pure = subroutines[i].elemental;
3143
}
3144
 
3145
 
3146
void
3147
gfc_intrinsic_done_1 (void)
3148
{
3149
  gfc_free (functions);
3150
  gfc_free (conversion);
3151
  gfc_free (char_conversions);
3152
  gfc_free_namespace (gfc_intrinsic_namespace);
3153
}
3154
 
3155
 
3156
/******** Subroutines to check intrinsic interfaces ***********/
3157
 
3158
/* Given a formal argument list, remove any NULL arguments that may
3159
   have been left behind by a sort against some formal argument list.  */
3160
 
3161
static void
3162
remove_nullargs (gfc_actual_arglist **ap)
3163
{
3164
  gfc_actual_arglist *head, *tail, *next;
3165
 
3166
  tail = NULL;
3167
 
3168
  for (head = *ap; head; head = next)
3169
    {
3170
      next = head->next;
3171
 
3172
      if (head->expr == NULL && !head->label)
3173
        {
3174
          head->next = NULL;
3175
          gfc_free_actual_arglist (head);
3176
        }
3177
      else
3178
        {
3179
          if (tail == NULL)
3180
            *ap = head;
3181
          else
3182
            tail->next = head;
3183
 
3184
          tail = head;
3185
          tail->next = NULL;
3186
        }
3187
    }
3188
 
3189
  if (tail == NULL)
3190
    *ap = NULL;
3191
}
3192
 
3193
 
3194
/* Given an actual arglist and a formal arglist, sort the actual
3195
   arglist so that its arguments are in a one-to-one correspondence
3196
   with the format arglist.  Arguments that are not present are given
3197
   a blank gfc_actual_arglist structure.  If something is obviously
3198
   wrong (say, a missing required argument) we abort sorting and
3199
   return FAILURE.  */
3200
 
3201
static gfc_try
3202
sort_actual (const char *name, gfc_actual_arglist **ap,
3203
             gfc_intrinsic_arg *formal, locus *where)
3204
{
3205
  gfc_actual_arglist *actual, *a;
3206
  gfc_intrinsic_arg *f;
3207
 
3208
  remove_nullargs (ap);
3209
  actual = *ap;
3210
 
3211
  for (f = formal; f; f = f->next)
3212
    f->actual = NULL;
3213
 
3214
  f = formal;
3215
  a = actual;
3216
 
3217
  if (f == NULL && a == NULL)   /* No arguments */
3218
    return SUCCESS;
3219
 
3220
  for (;;)
3221
    {           /* Put the nonkeyword arguments in a 1:1 correspondence */
3222
      if (f == NULL)
3223
        break;
3224
      if (a == NULL)
3225
        goto optional;
3226
 
3227
      if (a->name != NULL)
3228
        goto keywords;
3229
 
3230
      f->actual = a;
3231
 
3232
      f = f->next;
3233
      a = a->next;
3234
    }
3235
 
3236
  if (a == NULL)
3237
    goto do_sort;
3238
 
3239
  gfc_error ("Too many arguments in call to '%s' at %L", name, where);
3240
  return FAILURE;
3241
 
3242
keywords:
3243
  /* Associate the remaining actual arguments, all of which have
3244
     to be keyword arguments.  */
3245
  for (; a; a = a->next)
3246
    {
3247
      for (f = formal; f; f = f->next)
3248
        if (strcmp (a->name, f->name) == 0)
3249
          break;
3250
 
3251
      if (f == NULL)
3252
        {
3253
          if (a->name[0] == '%')
3254
            gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
3255
                       "are not allowed in this context at %L", where);
3256
          else
3257
            gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
3258
                       a->name, name, where);
3259
          return FAILURE;
3260
        }
3261
 
3262
      if (f->actual != NULL)
3263
        {
3264
          gfc_error ("Argument '%s' appears twice in call to '%s' at %L",
3265
                     f->name, name, where);
3266
          return FAILURE;
3267
        }
3268
 
3269
      f->actual = a;
3270
    }
3271
 
3272
optional:
3273
  /* At this point, all unmatched formal args must be optional.  */
3274
  for (f = formal; f; f = f->next)
3275
    {
3276
      if (f->actual == NULL && f->optional == 0)
3277
        {
3278
          gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
3279
                     f->name, name, where);
3280
          return FAILURE;
3281
        }
3282
    }
3283
 
3284
do_sort:
3285
  /* Using the formal argument list, string the actual argument list
3286
     together in a way that corresponds with the formal list.  */
3287
  actual = NULL;
3288
 
3289
  for (f = formal; f; f = f->next)
3290
    {
3291
      if (f->actual && f->actual->label != NULL && f->ts.type)
3292
        {
3293
          gfc_error ("ALTERNATE RETURN not permitted at %L", where);
3294
          return FAILURE;
3295
        }
3296
 
3297
      if (f->actual == NULL)
3298
        {
3299
          a = gfc_get_actual_arglist ();
3300
          a->missing_arg_type = f->ts.type;
3301
        }
3302
      else
3303
        a = f->actual;
3304
 
3305
      if (actual == NULL)
3306
        *ap = a;
3307
      else
3308
        actual->next = a;
3309
 
3310
      actual = a;
3311
    }
3312
  actual->next = NULL;          /* End the sorted argument list.  */
3313
 
3314
  return SUCCESS;
3315
}
3316
 
3317
 
3318
/* Compare an actual argument list with an intrinsic's formal argument
3319
   list.  The lists are checked for agreement of type.  We don't check
3320
   for arrayness here.  */
3321
 
3322
static gfc_try
3323
check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
3324
               int error_flag)
3325
{
3326
  gfc_actual_arglist *actual;
3327
  gfc_intrinsic_arg *formal;
3328
  int i;
3329
 
3330
  formal = sym->formal;
3331
  actual = *ap;
3332
 
3333
  i = 0;
3334
  for (; formal; formal = formal->next, actual = actual->next, i++)
3335
    {
3336
      gfc_typespec ts;
3337
 
3338
      if (actual->expr == NULL)
3339
        continue;
3340
 
3341
      ts = formal->ts;
3342
 
3343
      /* A kind of 0 means we don't check for kind.  */
3344
      if (ts.kind == 0)
3345
        ts.kind = actual->expr->ts.kind;
3346
 
3347
      if (!gfc_compare_types (&ts, &actual->expr->ts))
3348
        {
3349
          if (error_flag)
3350
            gfc_error ("Type of argument '%s' in call to '%s' at %L should "
3351
                       "be %s, not %s", gfc_current_intrinsic_arg[i],
3352
                       gfc_current_intrinsic, &actual->expr->where,
3353
                       gfc_typename (&formal->ts),
3354
                       gfc_typename (&actual->expr->ts));
3355
          return FAILURE;
3356
        }
3357
    }
3358
 
3359
  return SUCCESS;
3360
}
3361
 
3362
 
3363
/* Given a pointer to an intrinsic symbol and an expression node that
3364
   represent the function call to that subroutine, figure out the type
3365
   of the result.  This may involve calling a resolution subroutine.  */
3366
 
3367
static void
3368
resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
3369
{
3370
  gfc_expr *a1, *a2, *a3, *a4, *a5;
3371
  gfc_actual_arglist *arg;
3372
 
3373
  if (specific->resolve.f1 == NULL)
3374
    {
3375
      if (e->value.function.name == NULL)
3376
        e->value.function.name = specific->lib_name;
3377
 
3378
      if (e->ts.type == BT_UNKNOWN)
3379
        e->ts = specific->ts;
3380
      return;
3381
    }
3382
 
3383
  arg = e->value.function.actual;
3384
 
3385
  /* Special case hacks for MIN and MAX.  */
3386
  if (specific->resolve.f1m == gfc_resolve_max
3387
      || specific->resolve.f1m == gfc_resolve_min)
3388
    {
3389
      (*specific->resolve.f1m) (e, arg);
3390
      return;
3391
    }
3392
 
3393
  if (arg == NULL)
3394
    {
3395
      (*specific->resolve.f0) (e);
3396
      return;
3397
    }
3398
 
3399
  a1 = arg->expr;
3400
  arg = arg->next;
3401
 
3402
  if (arg == NULL)
3403
    {
3404
      (*specific->resolve.f1) (e, a1);
3405
      return;
3406
    }
3407
 
3408
  a2 = arg->expr;
3409
  arg = arg->next;
3410
 
3411
  if (arg == NULL)
3412
    {
3413
      (*specific->resolve.f2) (e, a1, a2);
3414
      return;
3415
    }
3416
 
3417
  a3 = arg->expr;
3418
  arg = arg->next;
3419
 
3420
  if (arg == NULL)
3421
    {
3422
      (*specific->resolve.f3) (e, a1, a2, a3);
3423
      return;
3424
    }
3425
 
3426
  a4 = arg->expr;
3427
  arg = arg->next;
3428
 
3429
  if (arg == NULL)
3430
    {
3431
      (*specific->resolve.f4) (e, a1, a2, a3, a4);
3432
      return;
3433
    }
3434
 
3435
  a5 = arg->expr;
3436
  arg = arg->next;
3437
 
3438
  if (arg == NULL)
3439
    {
3440
      (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
3441
      return;
3442
    }
3443
 
3444
  gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
3445
}
3446
 
3447
 
3448
/* Given an intrinsic symbol node and an expression node, call the
3449
   simplification function (if there is one), perhaps replacing the
3450
   expression with something simpler.  We return FAILURE on an error
3451
   of the simplification, SUCCESS if the simplification worked, even
3452
   if nothing has changed in the expression itself.  */
3453
 
3454
static gfc_try
3455
do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
3456
{
3457
  gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
3458
  gfc_actual_arglist *arg;
3459
 
3460
  /* Max and min require special handling due to the variable number
3461
     of args.  */
3462
  if (specific->simplify.f1 == gfc_simplify_min)
3463
    {
3464
      result = gfc_simplify_min (e);
3465
      goto finish;
3466
    }
3467
 
3468
  if (specific->simplify.f1 == gfc_simplify_max)
3469
    {
3470
      result = gfc_simplify_max (e);
3471
      goto finish;
3472
    }
3473
 
3474
  if (specific->simplify.f1 == NULL)
3475
    {
3476
      result = NULL;
3477
      goto finish;
3478
    }
3479
 
3480
  arg = e->value.function.actual;
3481
 
3482
  if (arg == NULL)
3483
    {
3484
      result = (*specific->simplify.f0) ();
3485
      goto finish;
3486
    }
3487
 
3488
  a1 = arg->expr;
3489
  arg = arg->next;
3490
 
3491
  if (specific->simplify.cc == gfc_convert_constant
3492
      || specific->simplify.cc == gfc_convert_char_constant)
3493
    {
3494
      result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind);
3495
      goto finish;
3496
    }
3497
 
3498
  if (arg == NULL)
3499
    result = (*specific->simplify.f1) (a1);
3500
  else
3501
    {
3502
      a2 = arg->expr;
3503
      arg = arg->next;
3504
 
3505
      if (arg == NULL)
3506
        result = (*specific->simplify.f2) (a1, a2);
3507
      else
3508
        {
3509
          a3 = arg->expr;
3510
          arg = arg->next;
3511
 
3512
          if (arg == NULL)
3513
            result = (*specific->simplify.f3) (a1, a2, a3);
3514
          else
3515
            {
3516
              a4 = arg->expr;
3517
              arg = arg->next;
3518
 
3519
              if (arg == NULL)
3520
                result = (*specific->simplify.f4) (a1, a2, a3, a4);
3521
              else
3522
                {
3523
                  a5 = arg->expr;
3524
                  arg = arg->next;
3525
 
3526
                  if (arg == NULL)
3527
                    result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
3528
                  else
3529
                    gfc_internal_error
3530
                      ("do_simplify(): Too many args for intrinsic");
3531
                }
3532
            }
3533
        }
3534
    }
3535
 
3536
finish:
3537
  if (result == &gfc_bad_expr)
3538
    return FAILURE;
3539
 
3540
  if (result == NULL)
3541
    resolve_intrinsic (specific, e);    /* Must call at run-time */
3542
  else
3543
    {
3544
      result->where = e->where;
3545
      gfc_replace_expr (e, result);
3546
    }
3547
 
3548
  return SUCCESS;
3549
}
3550
 
3551
 
3552
/* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
3553
   error messages.  This subroutine returns FAILURE if a subroutine
3554
   has more than MAX_INTRINSIC_ARGS, in which case the actual argument
3555
   list cannot match any intrinsic.  */
3556
 
3557
static void
3558
init_arglist (gfc_intrinsic_sym *isym)
3559
{
3560
  gfc_intrinsic_arg *formal;
3561
  int i;
3562
 
3563
  gfc_current_intrinsic = isym->name;
3564
 
3565
  i = 0;
3566
  for (formal = isym->formal; formal; formal = formal->next)
3567
    {
3568
      if (i >= MAX_INTRINSIC_ARGS)
3569
        gfc_internal_error ("init_arglist(): too many arguments");
3570
      gfc_current_intrinsic_arg[i++] = formal->name;
3571
    }
3572
}
3573
 
3574
 
3575
/* Given a pointer to an intrinsic symbol and an expression consisting
3576
   of a function call, see if the function call is consistent with the
3577
   intrinsic's formal argument list.  Return SUCCESS if the expression
3578
   and intrinsic match, FAILURE otherwise.  */
3579
 
3580
static gfc_try
3581
check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
3582
{
3583
  gfc_actual_arglist *arg, **ap;
3584
  gfc_try t;
3585
 
3586
  ap = &expr->value.function.actual;
3587
 
3588
  init_arglist (specific);
3589
 
3590
  /* Don't attempt to sort the argument list for min or max.  */
3591
  if (specific->check.f1m == gfc_check_min_max
3592
      || specific->check.f1m == gfc_check_min_max_integer
3593
      || specific->check.f1m == gfc_check_min_max_real
3594
      || specific->check.f1m == gfc_check_min_max_double)
3595
    return (*specific->check.f1m) (*ap);
3596
 
3597
  if (sort_actual (specific->name, ap, specific->formal,
3598
                   &expr->where) == FAILURE)
3599
    return FAILURE;
3600
 
3601
  if (specific->check.f3ml == gfc_check_minloc_maxloc)
3602
    /* This is special because we might have to reorder the argument list.  */
3603
    t = gfc_check_minloc_maxloc (*ap);
3604
  else if (specific->check.f3red == gfc_check_minval_maxval)
3605
    /* This is also special because we also might have to reorder the
3606
       argument list.  */
3607
    t = gfc_check_minval_maxval (*ap);
3608
  else if (specific->check.f3red == gfc_check_product_sum)
3609
    /* Same here. The difference to the previous case is that we allow a
3610
       general numeric type.  */
3611
    t = gfc_check_product_sum (*ap);
3612
  else
3613
     {
3614
       if (specific->check.f1 == NULL)
3615
         {
3616
           t = check_arglist (ap, specific, error_flag);
3617
           if (t == SUCCESS)
3618
             expr->ts = specific->ts;
3619
         }
3620
       else
3621
         t = do_check (specific, *ap);
3622
     }
3623
 
3624
  /* Check conformance of elemental intrinsics.  */
3625
  if (t == SUCCESS && specific->elemental)
3626
    {
3627
      int n = 0;
3628
      gfc_expr *first_expr;
3629
      arg = expr->value.function.actual;
3630
 
3631
      /* There is no elemental intrinsic without arguments.  */
3632
      gcc_assert(arg != NULL);
3633
      first_expr = arg->expr;
3634
 
3635
      for ( ; arg && arg->expr; arg = arg->next, n++)
3636
        if (gfc_check_conformance (first_expr, arg->expr,
3637
                                   "arguments '%s' and '%s' for "
3638
                                   "intrinsic '%s'",
3639
                                   gfc_current_intrinsic_arg[0],
3640
                                   gfc_current_intrinsic_arg[n],
3641
                                   gfc_current_intrinsic) == FAILURE)
3642
          return FAILURE;
3643
    }
3644
 
3645
  if (t == FAILURE)
3646
    remove_nullargs (ap);
3647
 
3648
  return t;
3649
}
3650
 
3651
 
3652
/* Check whether an intrinsic belongs to whatever standard the user
3653
   has chosen, taking also into account -fall-intrinsics.  Here, no
3654
   warning/error is emitted; but if symstd is not NULL, it is pointed to a
3655
   textual representation of the symbols standard status (like
3656
   "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that
3657
   can be used to construct a detailed warning/error message in case of
3658
   a FAILURE.  */
3659
 
3660
gfc_try
3661
gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
3662
                              const char** symstd, bool silent, locus where)
3663
{
3664
  const char* symstd_msg;
3665
 
3666
  /* For -fall-intrinsics, just succeed.  */
3667
  if (gfc_option.flag_all_intrinsics)
3668
    return SUCCESS;
3669
 
3670
  /* Find the symbol's standard message for later usage.  */
3671
  switch (isym->standard)
3672
    {
3673
    case GFC_STD_F77:
3674
      symstd_msg = "available since Fortran 77";
3675
      break;
3676
 
3677
    case GFC_STD_F95_OBS:
3678
      symstd_msg = "obsolescent in Fortran 95";
3679
      break;
3680
 
3681
    case GFC_STD_F95_DEL:
3682
      symstd_msg = "deleted in Fortran 95";
3683
      break;
3684
 
3685
    case GFC_STD_F95:
3686
      symstd_msg = "new in Fortran 95";
3687
      break;
3688
 
3689
    case GFC_STD_F2003:
3690
      symstd_msg = "new in Fortran 2003";
3691
      break;
3692
 
3693
    case GFC_STD_F2008:
3694
      symstd_msg = "new in Fortran 2008";
3695
      break;
3696
 
3697
    case GFC_STD_GNU:
3698
      symstd_msg = "a GNU Fortran extension";
3699
      break;
3700
 
3701
    case GFC_STD_LEGACY:
3702
      symstd_msg = "for backward compatibility";
3703
      break;
3704
 
3705
    default:
3706
      gfc_internal_error ("Invalid standard code on intrinsic '%s' (%d)",
3707
                          isym->name, isym->standard);
3708
    }
3709
 
3710
  /* If warning about the standard, warn and succeed.  */
3711
  if (gfc_option.warn_std & isym->standard)
3712
    {
3713
      /* Do only print a warning if not a GNU extension.  */
3714
      if (!silent && isym->standard != GFC_STD_GNU)
3715
        gfc_warning ("Intrinsic '%s' (is %s) is used at %L",
3716
                     isym->name, _(symstd_msg), &where);
3717
 
3718
      return SUCCESS;
3719
    }
3720
 
3721
  /* If allowing the symbol's standard, succeed, too.  */
3722
  if (gfc_option.allow_std & isym->standard)
3723
    return SUCCESS;
3724
 
3725
  /* Otherwise, fail.  */
3726
  if (symstd)
3727
    *symstd = _(symstd_msg);
3728
  return FAILURE;
3729
}
3730
 
3731
 
3732
/* See if a function call corresponds to an intrinsic function call.
3733
   We return:
3734
 
3735
    MATCH_YES    if the call corresponds to an intrinsic, simplification
3736
                 is done if possible.
3737
 
3738
    MATCH_NO     if the call does not correspond to an intrinsic
3739
 
3740
    MATCH_ERROR  if the call corresponds to an intrinsic but there was an
3741
                 error during the simplification process.
3742
 
3743
   The error_flag parameter enables an error reporting.  */
3744
 
3745
match
3746
gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
3747
{
3748
  gfc_intrinsic_sym *isym, *specific;
3749
  gfc_actual_arglist *actual;
3750
  const char *name;
3751
  int flag;
3752
 
3753
  if (expr->value.function.isym != NULL)
3754
    return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3755
           ? MATCH_ERROR : MATCH_YES;
3756
 
3757
  if (!error_flag)
3758
    gfc_push_suppress_errors ();
3759
  flag = 0;
3760
 
3761
  for (actual = expr->value.function.actual; actual; actual = actual->next)
3762
    if (actual->expr != NULL)
3763
      flag |= (actual->expr->ts.type != BT_INTEGER
3764
               && actual->expr->ts.type != BT_CHARACTER);
3765
 
3766
  name = expr->symtree->n.sym->name;
3767
 
3768
  isym = specific = gfc_find_function (name);
3769
  if (isym == NULL)
3770
    {
3771
      if (!error_flag)
3772
        gfc_pop_suppress_errors ();
3773
      return MATCH_NO;
3774
    }
3775
 
3776
  if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
3777
       || isym->id == GFC_ISYM_CMPLX)
3778
      && gfc_init_expr
3779
      && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' "
3780
                         "as initialization expression at %L", name,
3781
                         &expr->where) == FAILURE)
3782
    {
3783
      if (!error_flag)
3784
        gfc_pop_suppress_errors ();
3785
      return MATCH_ERROR;
3786
    }
3787
 
3788
  gfc_current_intrinsic_where = &expr->where;
3789
 
3790
  /* Bypass the generic list for min and max.  */
3791
  if (isym->check.f1m == gfc_check_min_max)
3792
    {
3793
      init_arglist (isym);
3794
 
3795
      if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3796
        goto got_specific;
3797
 
3798
      if (!error_flag)
3799
        gfc_pop_suppress_errors ();
3800
      return MATCH_NO;
3801
    }
3802
 
3803
  /* If the function is generic, check all of its specific
3804
     incarnations.  If the generic name is also a specific, we check
3805
     that name last, so that any error message will correspond to the
3806
     specific.  */
3807
  gfc_push_suppress_errors ();
3808
 
3809
  if (isym->generic)
3810
    {
3811
      for (specific = isym->specific_head; specific;
3812
           specific = specific->next)
3813
        {
3814
          if (specific == isym)
3815
            continue;
3816
          if (check_specific (specific, expr, 0) == SUCCESS)
3817
            {
3818
              gfc_pop_suppress_errors ();
3819
              goto got_specific;
3820
            }
3821
        }
3822
    }
3823
 
3824
  gfc_pop_suppress_errors ();
3825
 
3826
  if (check_specific (isym, expr, error_flag) == FAILURE)
3827
    {
3828
      if (!error_flag)
3829
        gfc_pop_suppress_errors ();
3830
      return MATCH_NO;
3831
    }
3832
 
3833
  specific = isym;
3834
 
3835
got_specific:
3836
  expr->value.function.isym = specific;
3837
  gfc_intrinsic_symbol (expr->symtree->n.sym);
3838
 
3839
  if (!error_flag)
3840
    gfc_pop_suppress_errors ();
3841
 
3842
  if (do_simplify (specific, expr) == FAILURE)
3843
    return MATCH_ERROR;
3844
 
3845
  /* F95, 7.1.6.1, Initialization expressions
3846
     (4) An elemental intrinsic function reference of type integer or
3847
         character where each argument is an initialization expression
3848
         of type integer or character
3849
 
3850
     F2003, 7.1.7 Initialization expression
3851
     (4)   A reference to an elemental standard intrinsic function,
3852
           where each argument is an initialization expression  */
3853
 
3854
  if (gfc_init_expr && isym->elemental && flag
3855
      && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Elemental function "
3856
                        "as initialization expression with non-integer/non-"
3857
                        "character arguments at %L", &expr->where) == FAILURE)
3858
    return MATCH_ERROR;
3859
 
3860
  return MATCH_YES;
3861
}
3862
 
3863
 
3864
/* See if a CALL statement corresponds to an intrinsic subroutine.
3865
   Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3866
   MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3867
   correspond).  */
3868
 
3869
match
3870
gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
3871
{
3872
  gfc_intrinsic_sym *isym;
3873
  const char *name;
3874
 
3875
  name = c->symtree->n.sym->name;
3876
 
3877
  isym = gfc_find_subroutine (name);
3878
  if (isym == NULL)
3879
    return MATCH_NO;
3880
 
3881
  if (!error_flag)
3882
    gfc_push_suppress_errors ();
3883
 
3884
  init_arglist (isym);
3885
 
3886
  if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3887
    goto fail;
3888
 
3889
  if (isym->check.f1 != NULL)
3890
    {
3891
      if (do_check (isym, c->ext.actual) == FAILURE)
3892
        goto fail;
3893
    }
3894
  else
3895
    {
3896
      if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3897
        goto fail;
3898
    }
3899
 
3900
  /* The subroutine corresponds to an intrinsic.  Allow errors to be
3901
     seen at this point.  */
3902
  if (!error_flag)
3903
    gfc_pop_suppress_errors ();
3904
 
3905
  c->resolved_isym = isym;
3906
  if (isym->resolve.s1 != NULL)
3907
    isym->resolve.s1 (c);
3908
  else
3909
    {
3910
      c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3911
      c->resolved_sym->attr.elemental = isym->elemental;
3912
    }
3913
 
3914
  if (gfc_pure (NULL) && !isym->elemental)
3915
    {
3916
      gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3917
                 &c->loc);
3918
      return MATCH_ERROR;
3919
    }
3920
 
3921
  c->resolved_sym->attr.noreturn = isym->noreturn;
3922
 
3923
  return MATCH_YES;
3924
 
3925
fail:
3926
  if (!error_flag)
3927
    gfc_pop_suppress_errors ();
3928
  return MATCH_NO;
3929
}
3930
 
3931
 
3932
/* Call gfc_convert_type() with warning enabled.  */
3933
 
3934
gfc_try
3935
gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
3936
{
3937
  return gfc_convert_type_warn (expr, ts, eflag, 1);
3938
}
3939
 
3940
 
3941
/* Try to convert an expression (in place) from one type to another.
3942
   'eflag' controls the behavior on error.
3943
 
3944
   The possible values are:
3945
 
3946
     1 Generate a gfc_error()
3947
     2 Generate a gfc_internal_error().
3948
 
3949
   'wflag' controls the warning related to conversion.  */
3950
 
3951
gfc_try
3952
gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
3953
{
3954
  gfc_intrinsic_sym *sym;
3955
  gfc_typespec from_ts;
3956
  locus old_where;
3957
  gfc_expr *new_expr;
3958
  int rank;
3959
  mpz_t *shape;
3960
 
3961
  from_ts = expr->ts;           /* expr->ts gets clobbered */
3962
 
3963
  if (ts->type == BT_UNKNOWN)
3964
    goto bad;
3965
 
3966
  /* NULL and zero size arrays get their type here.  */
3967
  if (expr->expr_type == EXPR_NULL
3968
      || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
3969
    {
3970
      /* Sometimes the RHS acquire the type.  */
3971
      expr->ts = *ts;
3972
      return SUCCESS;
3973
    }
3974
 
3975
  if (expr->ts.type == BT_UNKNOWN)
3976
    goto bad;
3977
 
3978
  if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
3979
      && gfc_compare_types (&expr->ts, ts))
3980
    return SUCCESS;
3981
 
3982
  sym = find_conv (&expr->ts, ts);
3983
  if (sym == NULL)
3984
    goto bad;
3985
 
3986
  /* At this point, a conversion is necessary. A warning may be needed.  */
3987
  if ((gfc_option.warn_std & sym->standard) != 0)
3988
    gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3989
                     gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3990
  else if (wflag && gfc_option.warn_conversion)
3991
    gfc_warning_now ("Conversion from %s to %s at %L",
3992
                     gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3993
 
3994
  /* Insert a pre-resolved function call to the right function.  */
3995
  old_where = expr->where;
3996
  rank = expr->rank;
3997
  shape = expr->shape;
3998
 
3999
  new_expr = gfc_get_expr ();
4000
  *new_expr = *expr;
4001
 
4002
  new_expr = gfc_build_conversion (new_expr);
4003
  new_expr->value.function.name = sym->lib_name;
4004
  new_expr->value.function.isym = sym;
4005
  new_expr->where = old_where;
4006
  new_expr->rank = rank;
4007
  new_expr->shape = gfc_copy_shape (shape, rank);
4008
 
4009
  gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
4010
  new_expr->symtree->n.sym->result = new_expr->symtree->n.sym;
4011
  new_expr->symtree->n.sym->ts = *ts;
4012
  new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4013
  new_expr->symtree->n.sym->attr.function = 1;
4014
  new_expr->symtree->n.sym->attr.elemental = 1;
4015
  new_expr->symtree->n.sym->attr.pure = 1;
4016
  new_expr->symtree->n.sym->attr.referenced = 1;
4017
  gfc_intrinsic_symbol(new_expr->symtree->n.sym);
4018
  gfc_commit_symbol (new_expr->symtree->n.sym);
4019
 
4020
  *expr = *new_expr;
4021
 
4022
  gfc_free (new_expr);
4023
  expr->ts = *ts;
4024
 
4025
  if (gfc_is_constant_expr (expr->value.function.actual->expr)
4026
      && do_simplify (sym, expr) == FAILURE)
4027
    {
4028
 
4029
      if (eflag == 2)
4030
        goto bad;
4031
      return FAILURE;           /* Error already generated in do_simplify() */
4032
    }
4033
 
4034
  return SUCCESS;
4035
 
4036
bad:
4037
  if (eflag == 1)
4038
    {
4039
      gfc_error ("Can't convert %s to %s at %L",
4040
                 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
4041
      return FAILURE;
4042
    }
4043
 
4044
  gfc_internal_error ("Can't convert %s to %s at %L",
4045
                      gfc_typename (&from_ts), gfc_typename (ts),
4046
                      &expr->where);
4047
  /* Not reached */
4048
}
4049
 
4050
 
4051
gfc_try
4052
gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
4053
{
4054
  gfc_intrinsic_sym *sym;
4055
  locus old_where;
4056
  gfc_expr *new_expr;
4057
  int rank;
4058
  mpz_t *shape;
4059
 
4060
  gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
4061
 
4062
  sym = find_char_conv (&expr->ts, ts);
4063
  gcc_assert (sym);
4064
 
4065
  /* Insert a pre-resolved function call to the right function.  */
4066
  old_where = expr->where;
4067
  rank = expr->rank;
4068
  shape = expr->shape;
4069
 
4070
  new_expr = gfc_get_expr ();
4071
  *new_expr = *expr;
4072
 
4073
  new_expr = gfc_build_conversion (new_expr);
4074
  new_expr->value.function.name = sym->lib_name;
4075
  new_expr->value.function.isym = sym;
4076
  new_expr->where = old_where;
4077
  new_expr->rank = rank;
4078
  new_expr->shape = gfc_copy_shape (shape, rank);
4079
 
4080
  gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
4081
  new_expr->symtree->n.sym->ts = *ts;
4082
  new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
4083
  new_expr->symtree->n.sym->attr.function = 1;
4084
  new_expr->symtree->n.sym->attr.elemental = 1;
4085
  new_expr->symtree->n.sym->attr.referenced = 1;
4086
  gfc_intrinsic_symbol(new_expr->symtree->n.sym);
4087
  gfc_commit_symbol (new_expr->symtree->n.sym);
4088
 
4089
  *expr = *new_expr;
4090
 
4091
  gfc_free (new_expr);
4092
  expr->ts = *ts;
4093
 
4094
  if (gfc_is_constant_expr (expr->value.function.actual->expr)
4095
      && do_simplify (sym, expr) == FAILURE)
4096
    {
4097
      /* Error already generated in do_simplify() */
4098
      return FAILURE;
4099
    }
4100
 
4101
  return SUCCESS;
4102
}
4103
 
4104
 
4105
/* Check if the passed name is name of an intrinsic (taking into account the
4106
   current -std=* and -fall-intrinsic settings).  If it is, see if we should
4107
   warn about this as a user-procedure having the same name as an intrinsic
4108
   (-Wintrinsic-shadow enabled) and do so if we should.  */
4109
 
4110
void
4111
gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func)
4112
{
4113
  gfc_intrinsic_sym* isym;
4114
 
4115
  /* If the warning is disabled, do nothing at all.  */
4116
  if (!gfc_option.warn_intrinsic_shadow)
4117
    return;
4118
 
4119
  /* Try to find an intrinsic of the same name.  */
4120
  if (func)
4121
    isym = gfc_find_function (sym->name);
4122
  else
4123
    isym = gfc_find_subroutine (sym->name);
4124
 
4125
  /* If no intrinsic was found with this name or it's not included in the
4126
     selected standard, everything's fine.  */
4127
  if (!isym || gfc_check_intrinsic_standard (isym, NULL, true,
4128
                                             sym->declared_at) == FAILURE)
4129
    return;
4130
 
4131
  /* Emit the warning.  */
4132
  if (in_module)
4133
    gfc_warning ("'%s' declared at %L may shadow the intrinsic of the same"
4134
                 " name.  In order to call the intrinsic, explicit INTRINSIC"
4135
                 " declarations may be required.",
4136
                 sym->name, &sym->declared_at);
4137
  else
4138
    gfc_warning ("'%s' declared at %L is also the name of an intrinsic.  It can"
4139
                 " only be called via an explicit interface or if declared"
4140
                 " EXTERNAL.", sym->name, &sym->declared_at);
4141
}

powered by: WebSVN 2.1.0

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