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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [fortran/] [intrinsic.c] - Blame information for rev 754

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

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

powered by: WebSVN 2.1.0

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