gcc/fortran/intrinsic.c

   1 /* Build up a list of intrinsic subroutines and functions for the
   2    name-resolution stage.
   3    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
   4    Inc.
   5    Contributed by Andy Vaught & Katherine Holcomb
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 2, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING.  If not, write to the Free
  21 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  22 02111-1307, USA.  */
  23
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "flags.h"
  28 #include "gfortran.h"
  29 #include "intrinsic.h"
  30
  31
  32 /* Namespace to hold the resolved symbols for intrinsic subroutines.  */
  33 static gfc_namespace *gfc_intrinsic_namespace;
  34
  35 int gfc_init_expr = 0;
  36
  37 /* Pointers to an intrinsic function and its argument names that are being
  38    checked.  */
  39
  40 const char *gfc_current_intrinsic;
  41 const char *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
  42 locus *gfc_current_intrinsic_where;
  43
  44 static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
  45 static gfc_intrinsic_arg *next_arg;
  46
  47 static int nfunc, nsub, nargs, nconv;
  48
  49 static enum
  50 { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
  51 sizing;
  52
  53 #define REQUIRED        0
  54 #define OPTIONAL        1
  55
  56 /* Return a letter based on the passed type.  Used to construct the
  57    name of a type-dependent subroutine.  */
  58
  59 char
  60 gfc_type_letter (bt type)
  61 {
  62   char c;
  63
  64   switch (type)
  65     {
  66     case BT_LOGICAL:
  67       c = 'l';
  68       break;
  69     case BT_CHARACTER:
  70       c = 's';
  71       break;
  72     case BT_INTEGER:
  73       c = 'i';
  74       break;
  75     case BT_REAL:
  76       c = 'r';
  77       break;
  78     case BT_COMPLEX:
  79       c = 'c';
  80       break;
  81
  82     default:
  83       c = 'u';
  84       break;
  85     }
  86
  87   return c;
  88 }
  89
  90
  91 /* Get a symbol for a resolved name.  */
  92
  93 gfc_symbol *
  94 gfc_get_intrinsic_sub_symbol (const char * name)
  95 {
  96   gfc_symbol *sym;
  97
  98   gfc_get_symbol (name, gfc_intrinsic_namespace, &sym);
  99   sym->attr.always_explicit = 1;
 100   sym->attr.subroutine = 1;
 101   sym->attr.flavor = FL_PROCEDURE;
 102   sym->attr.proc = PROC_INTRINSIC;
 103
 104   return sym;
 105 }
 106
 107
 108 /* Return a pointer to the name of a conversion function given two
 109    typespecs.  */
 110
 111 static const char *
 112 conv_name (gfc_typespec * from, gfc_typespec * to)
 113 {
 114   static char name[30];
 115
 116   sprintf (name, "__convert_%c%d_%c%d", gfc_type_letter (from->type),
 117            from->kind, gfc_type_letter (to->type), to->kind);
 118
 119   return gfc_get_string (name);
 120 }
 121
 122
 123 /* Given a pair of typespecs, find the gfc_intrinsic_sym node that
 124    corresponds to the conversion.  Returns NULL if the conversion
 125    isn't found.  */
 126
 127 static gfc_intrinsic_sym *
 128 find_conv (gfc_typespec * from, gfc_typespec * to)
 129 {
 130   gfc_intrinsic_sym *sym;
 131   const char *target;
 132   int i;
 133
 134   target = conv_name (from, to);
 135   sym = conversion;
 136
 137   for (i = 0; i < nconv; i++, sym++)
 138     if (strcmp (target, sym->name) == 0)
 139       return sym;
 140
 141   return NULL;
 142 }
 143
 144
 145 /* Interface to the check functions.  We break apart an argument list
 146    and call the proper check function rather than forcing each
 147    function to manipulate the argument list.  */
 148
 149 static try
 150 do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
 151 {
 152   gfc_expr *a1, *a2, *a3, *a4, *a5;
 153
 154   if (arg == NULL)
 155     return (*specific->check.f0) ();
 156
 157   a1 = arg->expr;
 158   arg = arg->next;
 159   if (arg == NULL)
 160     return (*specific->check.f1) (a1);
 161
 162   a2 = arg->expr;
 163   arg = arg->next;
 164   if (arg == NULL)
 165     return (*specific->check.f2) (a1, a2);
 166
 167   a3 = arg->expr;
 168   arg = arg->next;
 169   if (arg == NULL)
 170     return (*specific->check.f3) (a1, a2, a3);
 171
 172   a4 = arg->expr;
 173   arg = arg->next;
 174   if (arg == NULL)
 175     return (*specific->check.f4) (a1, a2, a3, a4);
 176
 177   a5 = arg->expr;
 178   arg = arg->next;
 179   if (arg == NULL)
 180     return (*specific->check.f5) (a1, a2, a3, a4, a5);
 181
 182   gfc_internal_error ("do_check(): too many args");
 183 }
 184
 185
 186 /*********** Subroutines to build the intrinsic list ****************/
 187
 188 /* Add a single intrinsic symbol to the current list.
 189
 190    Argument list:
 191       char *     name of function
 192       int        whether function is elemental
 193       int        If the function can be used as an actual argument
 194       bt         return type of function
 195       int        kind of return type of function
 196       int        Fortran standard version
 197       check      pointer to check function
 198       simplify   pointer to simplification function
 199       resolve    pointer to resolution function
 200
 201    Optional arguments come in multiples of four:
 202       char *    name of argument
 203       bt        type of argument
 204       int       kind of argument
 205       int       arg optional flag (1=optional, 0=required)
 206
 207    The sequence is terminated by a NULL name.
 208
 209    TODO: Are checks on actual_ok implemented elsewhere, or is that just
 210    missing here?  */
 211
 212 static void
 213 add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED,
 214          bt type, int kind, int standard, gfc_check_f check,
 215          gfc_simplify_f simplify, gfc_resolve_f resolve, ...)
 216 {
 217   char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0'  */
 218   int optional, first_flag;
 219   va_list argp;
 220
 221   /* First check that the intrinsic belongs to the selected standard.
 222      If not, don't add it to the symbol list.  */
 223   if (!(gfc_option.allow_std & standard))
 224     return;
 225
 226   switch (sizing)
 227     {
 228     case SZ_SUBS:
 229       nsub++;
 230       break;
 231
 232     case SZ_FUNCS:
 233       nfunc++;
 234       break;
 235
 236     case SZ_NOTHING:
 237       next_sym->name = gfc_get_string (name);
 238
 239       strcpy (buf, "_gfortran_");
 240       strcat (buf, name);
 241       next_sym->lib_name = gfc_get_string (buf);
 242
 243       next_sym->elemental = elemental;
 244       next_sym->ts.type = type;
 245       next_sym->ts.kind = kind;
 246       next_sym->standard = standard;
 247       next_sym->simplify = simplify;
 248       next_sym->check = check;
 249       next_sym->resolve = resolve;
 250       next_sym->specific = 0;
 251       next_sym->generic = 0;
 252       break;
 253
 254     default:
 255       gfc_internal_error ("add_sym(): Bad sizing mode");
 256     }
 257
 258   va_start (argp, resolve);
 259
 260   first_flag = 1;
 261
 262   for (;;)
 263     {
 264       name = va_arg (argp, char *);
 265       if (name == NULL)
 266         break;
 267
 268       type = (bt) va_arg (argp, int);
 269       kind = va_arg (argp, int);
 270       optional = va_arg (argp, int);
 271
 272       if (sizing != SZ_NOTHING)
 273         nargs++;
 274       else
 275         {
 276           next_arg++;
 277
 278           if (first_flag)
 279             next_sym->formal = next_arg;
 280           else
 281             (next_arg - 1)->next = next_arg;
 282
 283           first_flag = 0;
 284
 285           strcpy (next_arg->name, name);
 286           next_arg->ts.type = type;
 287           next_arg->ts.kind = kind;
 288           next_arg->optional = optional;
 289         }
 290     }
 291
 292   va_end (argp);
 293
 294   next_sym++;
 295 }
 296
 297
 298 /* Add a symbol to the function list where the function takes
 299    0 arguments.  */
 300
 301 static void
 302 add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
 303                        int kind, int standard,
 304                        try (*check)(void),
 305                        gfc_expr *(*simplify)(void),
 306            void (*resolve)(gfc_expr *))
 307 {
 308   gfc_simplify_f sf;
 309   gfc_check_f cf;
 310   gfc_resolve_f rf;
 311
 312   cf.f0 = check;
 313   sf.f0 = simplify;
 314   rf.f0 = resolve;
 315
 316   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 317            (void*)0);
 318 }
 319
 320
 321 /* Add a symbol to the subroutine list where the subroutine takes
 322    0 arguments.  */
 323
 324 static void
 325 add_sym_0s (const char * name, int actual_ok, int standard,
 326             void (*resolve)(gfc_code *))
 327 {
 328   gfc_check_f cf;
 329   gfc_simplify_f sf;
 330   gfc_resolve_f rf;
 331
 332   cf.f1 = NULL;
 333   sf.f1 = NULL;
 334   rf.s1 = resolve;
 335
 336   add_sym (name, 1, actual_ok, BT_UNKNOWN, 0, standard, cf, sf, rf,
 337            (void*)0);
 338 }
 339
 340
 341 /* Add a symbol to the function list where the function takes
 342    1 arguments.  */
 343
 344 static void
 345 add_sym_1 (const char *name, int elemental, int actual_ok, bt type,
 346            int kind, int standard,
 347            try (*check)(gfc_expr *),
 348            gfc_expr *(*simplify)(gfc_expr *),
 349            void (*resolve)(gfc_expr *,gfc_expr *),
 350            const char* a1, bt type1, int kind1, int optional1)
 351 {
 352   gfc_check_f cf;
 353   gfc_simplify_f sf;
 354   gfc_resolve_f rf;
 355
 356   cf.f1 = check;
 357   sf.f1 = simplify;
 358   rf.f1 = resolve;
 359
 360   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 361            a1, type1, kind1, optional1,
 362            (void*)0);
 363 }
 364
 365
 366 /* Add a symbol to the subroutine list where the subroutine takes
 367    1 arguments.  */
 368
 369 static void
 370 add_sym_1s (const char *name, int elemental, int actual_ok, bt type,
 371                         int kind, int standard,
 372                         try (*check)(gfc_expr *),
 373                         gfc_expr *(*simplify)(gfc_expr *),
 374                         void (*resolve)(gfc_code *),
 375             const char* a1, bt type1, int kind1, int optional1)
 376 {
 377   gfc_check_f cf;
 378   gfc_simplify_f sf;
 379   gfc_resolve_f rf;
 380
 381   cf.f1 = check;
 382   sf.f1 = simplify;
 383   rf.s1 = resolve;
 384
 385   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 386            a1, type1, kind1, optional1,
 387            (void*)0);
 388 }
 389
 390
 391 /* Add a symbol from the MAX/MIN family of intrinsic functions to the
 392    function.  MAX et al take 2 or more arguments.  */
 393
 394 static void
 395 add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
 396                         int kind, int standard,
 397                         try (*check)(gfc_actual_arglist *),
 398                         gfc_expr *(*simplify)(gfc_expr *),
 399                         void (*resolve)(gfc_expr *,gfc_actual_arglist *),
 400                         const char* a1, bt type1, int kind1, int optional1,
 401             const char* a2, bt type2, int kind2, int optional2)
 402 {
 403   gfc_check_f cf;
 404   gfc_simplify_f sf;
 405   gfc_resolve_f rf;
 406
 407   cf.f1m = check;
 408   sf.f1 = simplify;
 409   rf.f1m = resolve;
 410
 411   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 412            a1, type1, kind1, optional1,
 413            a2, type2, kind2, optional2,
 414            (void*)0);
 415 }
 416
 417
 418 /* Add a symbol to the function list where the function takes
 419    2 arguments.  */
 420
 421 static void
 422 add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
 423                        int kind, int standard,
 424                        try (*check)(gfc_expr *,gfc_expr *),
 425                        gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
 426                        void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *),
 427                        const char* a1, bt type1, int kind1, int optional1,
 428            const char* a2, bt type2, int kind2, int optional2)
 429 {
 430   gfc_check_f cf;
 431   gfc_simplify_f sf;
 432   gfc_resolve_f rf;
 433
 434   cf.f2 = check;
 435   sf.f2 = simplify;
 436   rf.f2 = resolve;
 437
 438   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 439            a1, type1, kind1, optional1,
 440            a2, type2, kind2, optional2,
 441            (void*)0);
 442 }
 443
 444
 445 /* Add a symbol to the subroutine list where the subroutine takes
 446    2 arguments.  */
 447
 448 static void
 449 add_sym_2s (const char *name, int elemental, int actual_ok, bt type,
 450                         int kind, int standard,
 451                        try (*check)(gfc_expr *,gfc_expr *),
 452                        gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
 453                        void (*resolve)(gfc_code *),
 454                        const char* a1, bt type1, int kind1, int optional1,
 455             const char* a2, bt type2, int kind2, int optional2)
 456 {
 457   gfc_check_f cf;
 458   gfc_simplify_f sf;
 459   gfc_resolve_f rf;
 460
 461   cf.f2 = check;
 462   sf.f2 = simplify;
 463   rf.s1 = resolve;
 464
 465   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 466            a1, type1, kind1, optional1,
 467            a2, type2, kind2, optional2,
 468            (void*)0);
 469 }
 470
 471
 472 /* Add a symbol to the function list where the function takes
 473    3 arguments.  */
 474
 475 static void
 476 add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
 477                        int kind, int standard,
 478                        try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
 479                        gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
 480                        void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 481                        const char* a1, bt type1, int kind1, int optional1,
 482                        const char* a2, bt type2, int kind2, int optional2,
 483            const char* a3, bt type3, int kind3, int optional3)
 484 {
 485   gfc_check_f cf;
 486   gfc_simplify_f sf;
 487   gfc_resolve_f rf;
 488
 489   cf.f3 = check;
 490   sf.f3 = simplify;
 491   rf.f3 = resolve;
 492
 493   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 494            a1, type1, kind1, optional1,
 495            a2, type2, kind2, optional2,
 496            a3, type3, kind3, optional3,
 497            (void*)0);
 498 }
 499
 500
 501 /* MINLOC and MAXLOC get special treatment because their argument
 502    might have to be reordered.  */
 503
 504 static void
 505 add_sym_3ml (const char *name, int elemental,
 506                          int actual_ok, bt type, int kind, int standard,
 507                          try (*check)(gfc_actual_arglist *),
 508                          gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
 509                          void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 510                          const char* a1, bt type1, int kind1, int optional1,
 511                          const char* a2, bt type2, int kind2, int optional2,
 512              const char* a3, bt type3, int kind3, int optional3)
 513 {
 514   gfc_check_f cf;
 515   gfc_simplify_f sf;
 516   gfc_resolve_f rf;
 517
 518   cf.f3ml = check;
 519   sf.f3 = simplify;
 520   rf.f3 = resolve;
 521
 522   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 523            a1, type1, kind1, optional1,
 524            a2, type2, kind2, optional2,
 525            a3, type3, kind3, optional3,
 526            (void*)0);
 527 }
 528
 529
 530 /* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because
 531    their argument also might have to be reordered.  */
 532
 533 static void
 534 add_sym_3red (const char *name, int elemental,
 535                           int actual_ok, bt type, int kind, int standard,
 536                           try (*check)(gfc_actual_arglist *),
 537                           gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
 538                           void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 539                           const char* a1, bt type1, int kind1, int optional1,
 540                           const char* a2, bt type2, int kind2, int optional2,
 541               const char* a3, bt type3, int kind3, int optional3)
 542 {
 543   gfc_check_f cf;
 544   gfc_simplify_f sf;
 545   gfc_resolve_f rf;
 546
 547   cf.f3red = check;
 548   sf.f3 = simplify;
 549   rf.f3 = resolve;
 550
 551   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 552            a1, type1, kind1, optional1,
 553            a2, type2, kind2, optional2,
 554            a3, type3, kind3, optional3,
 555            (void*)0);
 556 }
 557
 558
 559 /* Add a symbol to the subroutine list where the subroutine takes
 560    3 arguments.  */
 561
 562 static void
 563 add_sym_3s (const char *name, int elemental, int actual_ok, bt type,
 564                         int kind, int standard,
 565                        try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
 566                        gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
 567                        void (*resolve)(gfc_code *),
 568                        const char* a1, bt type1, int kind1, int optional1,
 569                        const char* a2, bt type2, int kind2, int optional2,
 570             const char* a3, bt type3, int kind3, int optional3)
 571 {
 572   gfc_check_f cf;
 573   gfc_simplify_f sf;
 574   gfc_resolve_f rf;
 575
 576   cf.f3 = check;
 577   sf.f3 = simplify;
 578   rf.s1 = resolve;
 579
 580   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 581            a1, type1, kind1, optional1,
 582            a2, type2, kind2, optional2,
 583            a3, type3, kind3, optional3,
 584            (void*)0);
 585 }
 586
 587
 588 /* Add a symbol to the function list where the function takes
 589    4 arguments.  */
 590
 591 static void
 592 add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
 593                        int kind, int standard,
 594                        try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 595                        gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 596                        void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 597                        const char* a1, bt type1, int kind1, int optional1,
 598                        const char* a2, bt type2, int kind2, int optional2,
 599                        const char* a3, bt type3, int kind3, int optional3,
 600            const char* a4, bt type4, int kind4, int optional4 )
 601 {
 602   gfc_check_f cf;
 603   gfc_simplify_f sf;
 604   gfc_resolve_f rf;
 605
 606   cf.f4 = check;
 607   sf.f4 = simplify;
 608   rf.f4 = resolve;
 609
 610   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 611            a1, type1, kind1, optional1,
 612            a2, type2, kind2, optional2,
 613            a3, type3, kind3, optional3,
 614            a4, type4, kind4, optional4,
 615            (void*)0);
 616 }
 617
 618
 619 /* Add a symbol to the subroutine list where the subroutine takes
 620    4 arguments.  */
 621
 622 static void
 623 add_sym_4s (const char *name, int elemental, int actual_ok,
 624                         bt type, int kind, int standard,
 625     try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 626     gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 627     void (*resolve)(gfc_code *),
 628     const char* a1, bt type1, int kind1, int optional1,
 629     const char* a2, bt type2, int kind2, int optional2,
 630     const char* a3, bt type3, int kind3, int optional3,
 631     const char* a4, bt type4, int kind4, int optional4)
 632 {
 633   gfc_check_f cf;
 634   gfc_simplify_f sf;
 635   gfc_resolve_f rf;
 636
 637   cf.f4 = check;
 638   sf.f4 = simplify;
 639   rf.s1 = resolve;
 640
 641   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 642            a1, type1, kind1, optional1,
 643            a2, type2, kind2, optional2,
 644            a3, type3, kind3, optional3,
 645            a4, type4, kind4, optional4,
 646            (void*)0);
 647 }
 648
 649
 650 /* Add a symbol to the subroutine list where the subroutine takes
 651    5 arguments.  */
 652
 653 static void
 654 add_sym_5s (const char *name, int elemental, int actual_ok,
 655  bt type, int kind, int standard,
 656  try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 657  gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
 658  void (*resolve)(gfc_code *),
 659  const char* a1, bt type1, int kind1, int optional1,
 660  const char* a2, bt type2, int kind2, int optional2,
 661  const char* a3, bt type3, int kind3, int optional3,
 662  const char* a4, bt type4, int kind4, int optional4,
 663  const char* a5, bt type5, int kind5, int optional5)
 664 {
 665   gfc_check_f cf;
 666   gfc_simplify_f sf;
 667   gfc_resolve_f rf;
 668
 669   cf.f5 = check;
 670   sf.f5 = simplify;
 671   rf.s1 = resolve;
 672
 673   add_sym (name, elemental, actual_ok, type, kind, standard, cf, sf, rf,
 674            a1, type1, kind1, optional1,
 675            a2, type2, kind2, optional2,
 676            a3, type3, kind3, optional3,
 677            a4, type4, kind4, optional4,
 678            a5, type5, kind5, optional5,
 679            (void*)0);
 680 }
 681
 682
 683 /* Locate an intrinsic symbol given a base pointer, number of elements
 684    in the table and a pointer to a name.  Returns the NULL pointer if
 685    a name is not found.  */
 686
 687 static gfc_intrinsic_sym *
 688 find_sym (gfc_intrinsic_sym * start, int n, const char *name)
 689 {
 690
 691   while (n > 0)
 692     {
 693       if (strcmp (name, start->name) == 0)
 694         return start;
 695
 696       start++;
 697       n--;
 698     }
 699
 700   return NULL;
 701 }
 702
 703
 704 /* Given a name, find a function in the intrinsic function table.
 705    Returns NULL if not found.  */
 706
 707 gfc_intrinsic_sym *
 708 gfc_find_function (const char *name)
 709 {
 710
 711   return find_sym (functions, nfunc, name);
 712 }
 713
 714
 715 /* Given a name, find a function in the intrinsic subroutine table.
 716    Returns NULL if not found.  */
 717
 718 static gfc_intrinsic_sym *
 719 find_subroutine (const char *name)
 720 {
 721
 722   return find_sym (subroutines, nsub, name);
 723 }
 724
 725
 726 /* Given a string, figure out if it is the name of a generic intrinsic
 727    function or not.  */
 728
 729 int
 730 gfc_generic_intrinsic (const char *name)
 731 {
 732   gfc_intrinsic_sym *sym;
 733
 734   sym = gfc_find_function (name);
 735   return (sym == NULL) ? 0 : sym->generic;
 736 }
 737
 738
 739 /* Given a string, figure out if it is the name of a specific
 740    intrinsic function or not.  */
 741
 742 int
 743 gfc_specific_intrinsic (const char *name)
 744 {
 745   gfc_intrinsic_sym *sym;
 746
 747   sym = gfc_find_function (name);
 748   return (sym == NULL) ? 0 : sym->specific;
 749 }
 750
 751
 752 /* Given a string, figure out if it is the name of an intrinsic
 753    subroutine or function.  There are no generic intrinsic
 754    subroutines, they are all specific.  */
 755
 756 int
 757 gfc_intrinsic_name (const char *name, int subroutine_flag)
 758 {
 759
 760   return subroutine_flag ?
 761     find_subroutine (name) != NULL : gfc_find_function (name) != NULL;
 762 }
 763
 764
 765 /* Collect a set of intrinsic functions into a generic collection.
 766    The first argument is the name of the generic function, which is
 767    also the name of a specific function.  The rest of the specifics
 768    currently in the table are placed into the list of specific
 769    functions associated with that generic.  */
 770
 771 static void
 772 make_generic (const char *name, gfc_generic_isym_id generic_id, int standard)
 773 {
 774   gfc_intrinsic_sym *g;
 775
 776   if (!(gfc_option.allow_std & standard))
 777     return;
 778
 779   if (sizing != SZ_NOTHING)
 780     return;
 781
 782   g = gfc_find_function (name);
 783   if (g == NULL)
 784     gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
 785                         name);
 786
 787   g->generic = 1;
 788   g->specific = 1;
 789   g->generic_id = generic_id;
 790   if ((g + 1)->name != NULL)
 791     g->specific_head = g + 1;
 792   g++;
 793
 794   while (g->name != NULL)
 795     {
 796       g->next = g + 1;
 797       g->specific = 1;
 798       g->generic_id = generic_id;
 799       g++;
 800     }
 801
 802   g--;
 803   g->next = NULL;
 804 }
 805
 806
 807 /* Create a duplicate intrinsic function entry for the current
 808    function, the only difference being the alternate name.  Note that
 809    we use argument lists more than once, but all argument lists are
 810    freed as a single block.  */
 811
 812 static void
 813 make_alias (const char *name, int standard)
 814 {
 815
 816   /* First check that the intrinsic belongs to the selected standard.
 817      If not, don't add it to the symbol list.  */
 818   if (!(gfc_option.allow_std & standard))
 819     return;
 820
 821   switch (sizing)
 822     {
 823     case SZ_FUNCS:
 824       nfunc++;
 825       break;
 826
 827     case SZ_SUBS:
 828       nsub++;
 829       break;
 830
 831     case SZ_NOTHING:
 832       next_sym[0] = next_sym[-1];
 833       next_sym->name = gfc_get_string (name);
 834       next_sym++;
 835       break;
 836
 837     default:
 838       break;
 839     }
 840 }
 841
 842
 843 /* Add intrinsic functions.  */
 844
 845 static void
 846 add_functions (void)
 847 {
 848
 849   /* Argument names as in the standard (to be used as argument keywords).  */
 850   const char
 851     *a = "a", *f = "field", *pt = "pointer", *tg = "target",
 852     *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
 853     *c = "c", *n = "ncopies", *pos = "pos", *bck = "back",
 854     *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
 855     *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
 856     *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
 857     *p = "p", *ar = "array", *shp = "shape", *src = "source",
 858     *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
 859     *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
 860     *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
 861     *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
 862     *z = "z", *ln = "len", *ut = "unit";
 863
 864   int di, dr, dd, dl, dc, dz, ii;
 865
 866   di = gfc_default_integer_kind;
 867   dr = gfc_default_real_kind;
 868   dd = gfc_default_double_kind;
 869   dl = gfc_default_logical_kind;
 870   dc = gfc_default_character_kind;
 871   dz = gfc_default_complex_kind;
 872   ii = gfc_index_integer_kind;
 873
 874   add_sym_1 ("abs", 1, 1, BT_REAL, dr, GFC_STD_F77,
 875              gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
 876              a, BT_REAL, dr, REQUIRED);
 877
 878   add_sym_1 ("iabs", 1, 1, BT_INTEGER, di, GFC_STD_F77,
 879              NULL, gfc_simplify_abs, gfc_resolve_abs,
 880              a, BT_INTEGER, di, REQUIRED);
 881
 882   add_sym_1 ("dabs", 1, 1, BT_REAL, dd, GFC_STD_F77,
 883              NULL, gfc_simplify_abs, gfc_resolve_abs,
 884              a, BT_REAL, dd, REQUIRED);
 885
 886   add_sym_1 ("cabs", 1, 1, BT_REAL, dr, GFC_STD_F77,
 887              NULL, gfc_simplify_abs, gfc_resolve_abs,
 888              a, BT_COMPLEX, dz, REQUIRED);
 889
 890   add_sym_1 ("zabs", 1, 1, BT_REAL, dd, GFC_STD_GNU,
 891              NULL, gfc_simplify_abs, gfc_resolve_abs,
 892              a, BT_COMPLEX, dd, REQUIRED);
 893
 894   make_alias ("cdabs", GFC_STD_GNU);
 895
 896   make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77);
 897
 898   add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
 899              gfc_check_achar, gfc_simplify_achar, NULL,
 900              i, BT_INTEGER, di, REQUIRED);
 901
 902   make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
 903
 904   add_sym_1 ("acos", 1, 1, BT_REAL, dr, GFC_STD_F77,
 905              gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos,
 906              x, BT_REAL, dr, REQUIRED);
 907
 908   add_sym_1 ("dacos", 1, 1, BT_REAL, dd, GFC_STD_F77,
 909              NULL, gfc_simplify_acos, gfc_resolve_acos,
 910              x, BT_REAL, dd, REQUIRED);
 911
 912   make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
 913
 914   add_sym_1 ("adjustl", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
 915              NULL, gfc_simplify_adjustl, NULL,
 916              stg, BT_CHARACTER, dc, REQUIRED);
 917
 918   make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
 919
 920   add_sym_1 ("adjustr", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
 921              NULL, gfc_simplify_adjustr, NULL,
 922              stg, BT_CHARACTER, dc, REQUIRED);
 923
 924   make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
 925
 926   add_sym_1 ("aimag", 1, 1, BT_REAL, dr, GFC_STD_F77,
 927              gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
 928              z, BT_COMPLEX, dz, REQUIRED);
 929
 930   add_sym_1 ("dimag", 1, 1, BT_REAL, dd, GFC_STD_GNU,
 931              NULL, gfc_simplify_aimag, gfc_resolve_aimag,
 932              z, BT_COMPLEX, dd, REQUIRED);
 933
 934   make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
 935
 936   add_sym_2 ("aint", 1, 1, BT_REAL, dr, GFC_STD_F77,
 937              gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
 938              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 939
 940   add_sym_1 ("dint", 1, 1, BT_REAL, dd, GFC_STD_F77,
 941              NULL, gfc_simplify_dint, gfc_resolve_dint,
 942              a, BT_REAL, dd, REQUIRED);
 943
 944   make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
 945
 946   add_sym_2 ("all", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
 947              gfc_check_all_any, NULL, gfc_resolve_all,
 948              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 949
 950   make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
 951
 952   add_sym_1 ("allocated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
 953              gfc_check_allocated, NULL, NULL,
 954              ar, BT_UNKNOWN, 0, REQUIRED);
 955
 956   make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
 957
 958   add_sym_2 ("anint", 1, 1, BT_REAL, dr, GFC_STD_F77,
 959              gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
 960              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 961
 962   add_sym_1 ("dnint", 1, 1, BT_REAL, dd, GFC_STD_F77,
 963              NULL, gfc_simplify_dnint, gfc_resolve_dnint,
 964              a, BT_REAL, dd, REQUIRED);
 965
 966   make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
 967
 968   add_sym_2 ("any", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
 969              gfc_check_all_any, NULL, gfc_resolve_any,
 970              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 971
 972   make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
 973
 974   add_sym_1 ("asin", 1, 1, BT_REAL, dr, GFC_STD_F77,
 975              gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin,
 976              x, BT_REAL, dr, REQUIRED);
 977
 978   add_sym_1 ("dasin", 1, 1, BT_REAL, dd, GFC_STD_F77,
 979              NULL, gfc_simplify_asin, gfc_resolve_asin,
 980              x, BT_REAL, dd, REQUIRED);
 981
 982   make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
 983
 984   add_sym_2 ("associated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
 985              gfc_check_associated, NULL, NULL,
 986              pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
 987
 988   make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
 989
 990   add_sym_1 ("atan", 1, 1, BT_REAL, dr, GFC_STD_F77,
 991              gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan,
 992              x, BT_REAL, dr, REQUIRED);
 993
 994   add_sym_1 ("datan", 1, 1, BT_REAL, dd, GFC_STD_F77,
 995              NULL, gfc_simplify_atan, gfc_resolve_atan,
 996              x, BT_REAL, dd, REQUIRED);
 997
 998   make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
 999
1000   add_sym_2 ("atan2", 1, 1, BT_REAL, dr, GFC_STD_F77,
1001              gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
1002              y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
1003
1004   add_sym_2 ("datan2", 1, 1, BT_REAL, dd, GFC_STD_F77,
1005              NULL, gfc_simplify_atan2, gfc_resolve_atan2,
1006              y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
1007
1008   make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
1009
1010   /* Bessel and Neumann functions for G77 compatibility.  */
1011   add_sym_1 ("besj0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1012              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1013              x, BT_REAL, dr, REQUIRED);
1014
1015   add_sym_1 ("dbesj0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1016              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1017              x, BT_REAL, dd, REQUIRED);
1018
1019   make_generic ("besj0", GFC_ISYM_J0, GFC_STD_GNU);
1020
1021   add_sym_1 ("besj1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1022              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1023              x, BT_REAL, dr, REQUIRED);
1024
1025   add_sym_1 ("dbesj1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1026              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1027              x, BT_REAL, dd, REQUIRED);
1028
1029   make_generic ("besj1", GFC_ISYM_J1, GFC_STD_GNU);
1030
1031   add_sym_2 ("besjn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1032              gfc_check_besn, NULL, gfc_resolve_besn,
1033              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1034
1035   add_sym_2 ("dbesjn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1036              gfc_check_besn, NULL, gfc_resolve_besn,
1037              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1038
1039   make_generic ("besjn", GFC_ISYM_JN, GFC_STD_GNU);
1040
1041   add_sym_1 ("besy0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1042              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1043              x, BT_REAL, dr, REQUIRED);
1044
1045   add_sym_1 ("dbesy0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1046              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1047              x, BT_REAL, dd, REQUIRED);
1048
1049   make_generic ("besy0", GFC_ISYM_Y0, GFC_STD_GNU);
1050
1051   add_sym_1 ("besy1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1052              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1053              x, BT_REAL, dr, REQUIRED);
1054
1055   add_sym_1 ("dbesy1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1056              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1057              x, BT_REAL, dd, REQUIRED);
1058
1059   make_generic ("besy1", GFC_ISYM_Y1, GFC_STD_GNU);
1060
1061   add_sym_2 ("besyn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1062              gfc_check_besn, NULL, gfc_resolve_besn,
1063              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1064
1065   add_sym_2 ("dbesyn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1066              gfc_check_besn, NULL, gfc_resolve_besn,
1067              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1068
1069   make_generic ("besyn", GFC_ISYM_YN, GFC_STD_GNU);
1070
1071   add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1072              gfc_check_i, gfc_simplify_bit_size, NULL,
1073              i, BT_INTEGER, di, REQUIRED);
1074
1075   make_generic ("bit_size", GFC_ISYM_NONE, GFC_STD_F95);
1076
1077   add_sym_2 ("btest", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
1078              gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
1079              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1080
1081   make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
1082
1083   add_sym_2 ("ceiling", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1084              gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
1085              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1086
1087   make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
1088
1089   add_sym_2 ("char", 1, 0, BT_CHARACTER, dc, GFC_STD_F77,
1090              gfc_check_char, gfc_simplify_char, gfc_resolve_char,
1091              i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1092
1093   make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
1094
1095   add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1096              gfc_check_chdir, NULL, gfc_resolve_chdir,
1097              a, BT_CHARACTER, dc, REQUIRED);
1098
1099   make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
1100
1101   add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1102              gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
1103              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
1104              kind, BT_INTEGER, di, OPTIONAL);
1105
1106   make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
1107
1108   /* Making dcmplx a specific of cmplx causes cmplx to return a double
1109      complex instead of the default complex.  */
1110
1111   add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1112              gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
1113              x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
1114
1115   make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
1116
1117   add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1118              gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
1119              z, BT_COMPLEX, dz, REQUIRED);
1120
1121   add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1122              NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1123              z, BT_COMPLEX, dd, REQUIRED);
1124
1125   make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
1126
1127   add_sym_1 ("cos", 1, 1, BT_REAL, dr, GFC_STD_F77,
1128              gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1129              x, BT_REAL, dr, REQUIRED);
1130
1131   add_sym_1 ("dcos", 1, 1, BT_REAL, dd, GFC_STD_F77,
1132              gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1133              x, BT_REAL, dd, REQUIRED);
1134
1135   add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1136              NULL, gfc_simplify_cos, gfc_resolve_cos,
1137              x, BT_COMPLEX, dz, REQUIRED);
1138
1139   add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1140              NULL, gfc_simplify_cos, gfc_resolve_cos,
1141              x, BT_COMPLEX, dd, REQUIRED);
1142
1143   make_alias ("cdcos", GFC_STD_GNU);
1144
1145   make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
1146
1147   add_sym_1 ("cosh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1148              gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh,
1149              x, BT_REAL, dr, REQUIRED);
1150
1151   add_sym_1 ("dcosh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1152              NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1153              x, BT_REAL, dd, REQUIRED);
1154
1155   make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
1156
1157   add_sym_2 ("count", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1158              gfc_check_count, NULL, gfc_resolve_count,
1159              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1160
1161   make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
1162
1163   add_sym_3 ("cshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1164              gfc_check_cshift, NULL, gfc_resolve_cshift,
1165              ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1166              dm, BT_INTEGER, ii, OPTIONAL);
1167
1168   make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
1169
1170   add_sym_1 ("dble", 1, 1, BT_REAL, dd, GFC_STD_F77,
1171              gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1172              a, BT_REAL, dr, REQUIRED);
1173
1174   make_alias ("dfloat", GFC_STD_GNU);
1175
1176   make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
1177
1178   add_sym_1 ("digits", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1179              gfc_check_digits, gfc_simplify_digits, NULL,
1180              x, BT_UNKNOWN, dr, REQUIRED);
1181
1182   make_generic ("digits", GFC_ISYM_NONE, GFC_STD_F95);
1183
1184   add_sym_2 ("dim", 1, 1, BT_REAL, dr, GFC_STD_F77,
1185              gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1186              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1187
1188   add_sym_2 ("idim", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1189              NULL, gfc_simplify_dim, gfc_resolve_dim,
1190              x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
1191
1192   add_sym_2 ("ddim", 1, 1, BT_REAL, dd, GFC_STD_F77,
1193              NULL, gfc_simplify_dim, gfc_resolve_dim,
1194              x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
1195
1196   make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
1197
1198   add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1199              gfc_check_dot_product, NULL, gfc_resolve_dot_product,
1200              va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
1201
1202   make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
1203
1204   add_sym_2 ("dprod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1205              NULL, gfc_simplify_dprod, gfc_resolve_dprod,
1206              x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1207
1208   make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
1209
1210   add_sym_1 ("dreal", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1211              NULL, NULL, NULL,
1212              a, BT_COMPLEX, dd, REQUIRED);
1213
1214   make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
1215
1216   add_sym_4 ("eoshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1217              gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1218              ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
1219              bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
1220
1221   make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
1222
1223   add_sym_1 ("epsilon", 0, 1, BT_REAL, dr, GFC_STD_F95,
1224              gfc_check_x, gfc_simplify_epsilon, NULL,
1225              x, BT_REAL, dr, REQUIRED);
1226
1227   make_generic ("epsilon", GFC_ISYM_NONE, GFC_STD_F95);
1228
1229   /* G77 compatibility for the ERF() and ERFC() functions.  */
1230   add_sym_1 ("erf", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1231              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1232              x, BT_REAL, dr, REQUIRED);
1233
1234   add_sym_1 ("derf", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1235              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1236              x, BT_REAL, dd, REQUIRED);
1237
1238   make_generic ("erf", GFC_ISYM_ERF, GFC_STD_GNU);
1239
1240   add_sym_1 ("erfc", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1241              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1242              x, BT_REAL, dr, REQUIRED);
1243
1244   add_sym_1 ("derfc", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1245              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1246              x, BT_REAL, dd, REQUIRED);
1247
1248   make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_GNU);
1249
1250   /* G77 compatibility */
1251   add_sym_1 ("etime", 0, 1, BT_REAL, 4,  GFC_STD_GNU,
1252              gfc_check_etime, NULL, NULL,
1253              x, BT_REAL, 4, REQUIRED);
1254
1255   make_alias ("dtime", GFC_STD_GNU);
1256
1257   make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
1258
1259   add_sym_1 ("exp", 1, 1, BT_REAL, dr,  GFC_STD_F77,
1260              gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
1261              x, BT_REAL, dr, REQUIRED);
1262
1263   add_sym_1 ("dexp", 1, 1, BT_REAL, dd, GFC_STD_F77,
1264              NULL, gfc_simplify_exp, gfc_resolve_exp,
1265              x, BT_REAL, dd, REQUIRED);
1266
1267   add_sym_1 ("cexp", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1268              NULL, gfc_simplify_exp, gfc_resolve_exp,
1269              x, BT_COMPLEX, dz, REQUIRED);
1270
1271   add_sym_1 ("zexp", 1, 1, BT_COMPLEX, dd,  GFC_STD_GNU,
1272              NULL, gfc_simplify_exp, gfc_resolve_exp,
1273              x, BT_COMPLEX, dd, REQUIRED);
1274
1275   make_alias ("cdexp", GFC_STD_GNU);
1276
1277   make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
1278
1279   add_sym_1 ("exponent", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1280              gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1281              x, BT_REAL, dr, REQUIRED);
1282
1283   make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
1284
1285   add_sym_2 ("floor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1286              gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1287              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1288
1289   make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1290
1291   /* G77 compatible fnum */
1292   add_sym_1 ("fnum", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1293              gfc_check_fnum, NULL, gfc_resolve_fnum,
1294              ut, BT_INTEGER, di, REQUIRED);
1295
1296   make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1297
1298   add_sym_1 ("fraction", 1, 1, BT_REAL, dr, GFC_STD_F95,
1299              gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1300              x, BT_REAL, dr, REQUIRED);
1301
1302   make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1303
1304   add_sym_2 ("fstat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1305              gfc_check_fstat, NULL, gfc_resolve_fstat,
1306              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1307
1308   make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1309
1310   /* Unix IDs (g77 compatibility)  */
1311   add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di,  GFC_STD_GNU,
1312              NULL, NULL, gfc_resolve_getcwd,
1313              c, BT_CHARACTER, dc, REQUIRED);
1314
1315   make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1316
1317   add_sym_0 ("getgid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1318              NULL, NULL, gfc_resolve_getgid);
1319
1320   make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1321
1322   add_sym_0 ("getpid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1323              NULL, NULL, gfc_resolve_getpid);
1324
1325   make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1326
1327   add_sym_0 ("getuid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1328              NULL, NULL, gfc_resolve_getuid);
1329
1330   make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1331
1332   add_sym_1 ("hostnm", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1333              gfc_check_hostnm, NULL, gfc_resolve_hostnm,
1334              a, BT_CHARACTER, dc, REQUIRED);
1335
1336   make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
1337
1338   add_sym_1 ("huge", 0, 1, BT_REAL, dr, GFC_STD_F95,
1339              gfc_check_huge, gfc_simplify_huge, NULL,
1340              x, BT_UNKNOWN, dr, REQUIRED);
1341
1342   make_generic ("huge", GFC_ISYM_NONE, GFC_STD_F95);
1343
1344   add_sym_1 ("iachar", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1345              gfc_check_ichar_iachar, gfc_simplify_iachar, NULL,
1346              c, BT_CHARACTER, dc, REQUIRED);
1347
1348   make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1349
1350   add_sym_2 ("iand", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1351              gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1352              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1353
1354   make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1355
1356   add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1357              NULL, NULL, NULL);
1358
1359   make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
1360
1361   add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, GFC_STD_F2003,
1362              NULL, NULL, NULL);
1363
1364   make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
1365                 GFC_STD_F2003);
1366
1367   add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1368              gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1369              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1370
1371   make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
1372
1373   add_sym_3 ("ibits", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1374              gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1375              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
1376              ln, BT_INTEGER, di, REQUIRED);
1377
1378   make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
1379
1380   add_sym_2 ("ibset", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1381              gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1382              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1383
1384   make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
1385
1386   add_sym_1 ("ichar", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1387              gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
1388              c, BT_CHARACTER, dc, REQUIRED);
1389
1390   make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
1391
1392   add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1393              gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1394              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1395
1396   make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
1397
1398   add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1399              NULL, NULL, gfc_resolve_ierrno);
1400
1401   make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
1402
1403   add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1404              gfc_check_index, gfc_simplify_index, NULL,
1405              stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
1406              bck, BT_LOGICAL, dl, OPTIONAL);
1407
1408   make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
1409
1410   add_sym_2 ("int", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1411              gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1412              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1413
1414   add_sym_1 ("ifix", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1415              NULL, gfc_simplify_ifix, NULL,
1416              a, BT_REAL, dr, REQUIRED);
1417
1418   add_sym_1 ("idint", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1419              NULL, gfc_simplify_idint, NULL,
1420              a, BT_REAL, dd, REQUIRED);
1421
1422   make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
1423
1424   add_sym_2 ("ior", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1425              gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1426              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1427
1428   make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
1429
1430   /* The following function is for G77 compatibility.  */
1431   add_sym_1 ("irand", 0, 1, BT_INTEGER, 4, GFC_STD_GNU,
1432              gfc_check_irand, NULL, NULL,
1433              i, BT_INTEGER, 4, OPTIONAL);
1434
1435   make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
1436
1437   add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1438              gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1439              i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1440
1441   make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
1442
1443   add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1444              gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1445              i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1446              sz, BT_INTEGER, di, OPTIONAL);
1447
1448   make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
1449
1450   add_sym_2 ("kill", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1451              gfc_check_kill, NULL, gfc_resolve_kill,
1452              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1453
1454   make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
1455
1456   add_sym_1 ("kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1457              gfc_check_kind, gfc_simplify_kind, NULL,
1458              x, BT_REAL, dr, REQUIRED);
1459
1460   make_generic ("kind", GFC_ISYM_NONE, GFC_STD_F95);
1461
1462   add_sym_2 ("lbound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1463              gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1464              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL);
1465
1466   make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
1467
1468   add_sym_1 ("len", 0, 1, BT_INTEGER, di, GFC_STD_F77,
1469              NULL, gfc_simplify_len, gfc_resolve_len,
1470              stg, BT_CHARACTER, dc, REQUIRED);
1471
1472   make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
1473
1474   add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1475              NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1476              stg, BT_CHARACTER, dc, REQUIRED);
1477
1478   make_alias ("lnblnk", GFC_STD_GNU);
1479
1480   make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
1481
1482   add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1483              NULL, gfc_simplify_lge, NULL,
1484              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1485
1486   make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
1487
1488   add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1489              NULL, gfc_simplify_lgt, NULL,
1490              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1491
1492   make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
1493
1494   add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1495              NULL, gfc_simplify_lle, NULL,
1496              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1497
1498   make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
1499
1500   add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1501              NULL, gfc_simplify_llt, NULL,
1502              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1503
1504   make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
1505
1506   add_sym_2 ("link", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1507              gfc_check_link, NULL, gfc_resolve_link,
1508              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1509
1510   make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
1511
1512   add_sym_1 ("log", 1, 1, BT_REAL, dr, GFC_STD_F77,
1513              gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
1514              x, BT_REAL, dr, REQUIRED);
1515
1516   add_sym_1 ("alog", 1, 1, BT_REAL, dr, GFC_STD_F77,
1517              NULL, gfc_simplify_log, gfc_resolve_log,
1518              x, BT_REAL, dr, REQUIRED);
1519
1520   add_sym_1 ("dlog", 1, 1, BT_REAL, dd, GFC_STD_F77,
1521              NULL, gfc_simplify_log, gfc_resolve_log,
1522              x, BT_REAL, dd, REQUIRED);
1523
1524   add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1525              NULL, gfc_simplify_log, gfc_resolve_log,
1526              x, BT_COMPLEX, dz, REQUIRED);
1527
1528   add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd,  GFC_STD_GNU,
1529              NULL, gfc_simplify_log, gfc_resolve_log,
1530              x, BT_COMPLEX, dd, REQUIRED);
1531
1532   make_alias ("cdlog", GFC_STD_GNU);
1533
1534   make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
1535
1536   add_sym_1 ("log10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1537              gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
1538              x, BT_REAL, dr, REQUIRED);
1539
1540   add_sym_1 ("alog10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1541              NULL, gfc_simplify_log10, gfc_resolve_log10,
1542              x, BT_REAL, dr, REQUIRED);
1543
1544   add_sym_1 ("dlog10", 1, 1, BT_REAL, dd, GFC_STD_F77,
1545              NULL, gfc_simplify_log10, gfc_resolve_log10,
1546              x, BT_REAL, dd, REQUIRED);
1547
1548   make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
1549
1550   add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1551              gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1552              l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1553
1554   make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
1555
1556   add_sym_2 ("matmul", 0, 1, BT_REAL, dr, GFC_STD_F95,
1557              gfc_check_matmul, NULL, gfc_resolve_matmul,
1558              ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
1559
1560   make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
1561
1562   /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1563      int(max).  The max function must take at least two arguments.  */
1564
1565   add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1566              gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1567              a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
1568
1569   add_sym_1m ("max0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1570              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1571              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1572
1573   add_sym_1m ("amax0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1574              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1575              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1576
1577   add_sym_1m ("amax1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1578              gfc_check_min_max_real, gfc_simplify_max, NULL,
1579              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1580
1581   add_sym_1m ("max1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1582              gfc_check_min_max_real, gfc_simplify_max, NULL,
1583              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1584
1585   add_sym_1m ("dmax1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1586              gfc_check_min_max_double, gfc_simplify_max, NULL,
1587              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1588
1589   make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
1590
1591   add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1592              gfc_check_x, gfc_simplify_maxexponent, NULL,
1593              x, BT_UNKNOWN, dr, REQUIRED);
1594
1595   make_generic ("maxexponent", GFC_ISYM_NONE, GFC_STD_F95);
1596
1597   add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1598                gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1599                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1600                msk, BT_LOGICAL, dl, OPTIONAL);
1601
1602   make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
1603
1604   add_sym_3red ("maxval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1605                 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1606                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1607                 msk, BT_LOGICAL, dl, OPTIONAL);
1608
1609   make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
1610
1611   add_sym_3 ("merge", 1, 1, BT_REAL, dr, GFC_STD_F95,
1612              gfc_check_merge, NULL, gfc_resolve_merge,
1613              ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
1614              msk, BT_LOGICAL, dl, REQUIRED);
1615
1616   make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
1617
1618   /* Note: amin0 is equivalent to real(min), min1 is equivalent to
1619      int(min).  */
1620
1621   add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1622               gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1623              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1624
1625   add_sym_1m ("min0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1626               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1627              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1628
1629   add_sym_1m ("amin0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1630               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1631              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1632
1633   add_sym_1m ("amin1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1634               gfc_check_min_max_real, gfc_simplify_min, NULL,
1635              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1636
1637   add_sym_1m ("min1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1638               gfc_check_min_max_real, gfc_simplify_min, NULL,
1639              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1640
1641   add_sym_1m ("dmin1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1642               gfc_check_min_max_double, gfc_simplify_min, NULL,
1643              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1644
1645   make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
1646
1647   add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1648              gfc_check_x, gfc_simplify_minexponent, NULL,
1649              x, BT_UNKNOWN, dr, REQUIRED);
1650
1651   make_generic ("minexponent", GFC_ISYM_NONE, GFC_STD_F95);
1652
1653   add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1654                gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1655                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1656                msk, BT_LOGICAL, dl, OPTIONAL);
1657
1658   make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
1659
1660   add_sym_3red ("minval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1661                 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1662                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1663                 msk, BT_LOGICAL, dl, OPTIONAL);
1664
1665   make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
1666
1667   add_sym_2 ("mod", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1668              gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1669              a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
1670
1671   add_sym_2 ("amod", 1, 1, BT_REAL, dr, GFC_STD_F77,
1672              NULL, gfc_simplify_mod, gfc_resolve_mod,
1673              a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
1674
1675   add_sym_2 ("dmod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1676              NULL, gfc_simplify_mod, gfc_resolve_mod,
1677              a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
1678
1679   make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
1680
1681   add_sym_2 ("modulo", 1, 1, BT_REAL, di, GFC_STD_F95,
1682              gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1683              a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
1684
1685   make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
1686
1687   add_sym_2 ("nearest", 1, 1, BT_REAL, dr, GFC_STD_F95,
1688              gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1689              x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
1690
1691   make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
1692
1693   add_sym_2 ("nint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1694              gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1695              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1696
1697   add_sym_1 ("idnint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1698              gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1699              a, BT_REAL, dd, REQUIRED);
1700
1701   make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
1702
1703   add_sym_1 ("not", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1704              gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1705              i, BT_INTEGER, di, REQUIRED);
1706
1707   make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
1708
1709   add_sym_1 ("null", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1710              gfc_check_null, gfc_simplify_null, NULL,
1711              mo, BT_INTEGER, di, OPTIONAL);
1712
1713   make_generic ("null", GFC_ISYM_NONE, GFC_STD_F95);
1714
1715   add_sym_3 ("pack", 0, 1, BT_REAL, dr, GFC_STD_F95,
1716              gfc_check_pack, NULL, gfc_resolve_pack,
1717              ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1718              v, BT_REAL, dr, OPTIONAL);
1719
1720   make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
1721
1722   add_sym_1 ("precision", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1723              gfc_check_precision, gfc_simplify_precision, NULL,
1724              x, BT_UNKNOWN, 0, REQUIRED);
1725
1726   make_generic ("precision", GFC_ISYM_NONE, GFC_STD_F95);
1727
1728   add_sym_1 ("present", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1729              gfc_check_present, NULL, NULL,
1730              a, BT_REAL, dr, REQUIRED);
1731
1732   make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
1733
1734   add_sym_3red ("product", 0, 1, BT_REAL, dr, GFC_STD_F95,
1735                 gfc_check_product_sum, NULL, gfc_resolve_product,
1736                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1737                 msk, BT_LOGICAL, dl, OPTIONAL);
1738
1739   make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
1740
1741   add_sym_1 ("radix", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1742              gfc_check_radix, gfc_simplify_radix, NULL,
1743              x, BT_UNKNOWN, 0, REQUIRED);
1744
1745   make_generic ("radix", GFC_ISYM_NONE, GFC_STD_F95);
1746
1747   /* The following function is for G77 compatibility.  */
1748   add_sym_1 ("rand", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1749              gfc_check_rand, NULL, NULL,
1750              i, BT_INTEGER, 4, OPTIONAL);
1751
1752   /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and ran()
1753      use slightly different shoddy multiplicative congruential PRNG.  */
1754   make_alias ("ran", GFC_STD_GNU);
1755
1756   make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
1757
1758   add_sym_1 ("range", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1759              gfc_check_range, gfc_simplify_range, NULL,
1760              x, BT_REAL, dr, REQUIRED);
1761
1762   make_generic ("range", GFC_ISYM_NONE, GFC_STD_F95);
1763
1764   add_sym_2 ("real", 1, 0, BT_REAL, dr, GFC_STD_F77,
1765              gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1766              a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1767
1768   add_sym_1 ("float", 1, 0, BT_REAL, dr, GFC_STD_F77,
1769              NULL, gfc_simplify_float, NULL,
1770              a, BT_INTEGER, di, REQUIRED);
1771
1772   add_sym_1 ("sngl", 1, 0, BT_REAL, dr, GFC_STD_F77,
1773              NULL, gfc_simplify_sngl, NULL,
1774              a, BT_REAL, dd, REQUIRED);
1775
1776   make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
1777
1778   add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1779              gfc_check_rename, NULL, gfc_resolve_rename,
1780              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1781
1782   make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
1783
1784   add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
1785              gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1786              stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
1787
1788   make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
1789
1790   add_sym_4 ("reshape", 0, 1, BT_REAL, dr, GFC_STD_F95,
1791              gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1792              src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
1793              pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
1794
1795   make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
1796
1797   add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1798              gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1799              x, BT_REAL, dr, REQUIRED);
1800
1801   make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
1802
1803   add_sym_2 ("scale", 1, 1, BT_REAL, dr, GFC_STD_F95,
1804              gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1805              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1806
1807   make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
1808
1809   add_sym_3 ("scan", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1810              gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1811              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
1812              bck, BT_LOGICAL, dl, OPTIONAL);
1813
1814   make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
1815
1816   /* Added for G77 compatibility garbage.  */
1817   add_sym_0 ("second", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1818              NULL, NULL, NULL);
1819
1820   make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
1821
1822   add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1823              gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL,
1824              r, BT_INTEGER, di, REQUIRED);
1825
1826   make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
1827
1828   add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1829              gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1830              NULL,
1831              p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
1832
1833   make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
1834
1835   add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr, GFC_STD_F95,
1836              gfc_check_set_exponent, gfc_simplify_set_exponent,
1837              gfc_resolve_set_exponent,
1838              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1839
1840   make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
1841
1842   add_sym_1 ("shape", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1843              gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1844              src, BT_REAL, dr, REQUIRED);
1845
1846   make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
1847
1848   add_sym_2 ("sign", 1, 1, BT_REAL, dr, GFC_STD_F77,
1849              gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1850              a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
1851
1852   add_sym_2 ("isign", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1853              NULL, gfc_simplify_sign, gfc_resolve_sign,
1854              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1855
1856   add_sym_2 ("dsign", 1, 1, BT_REAL, dd, GFC_STD_F77,
1857              NULL, gfc_simplify_sign, gfc_resolve_sign,
1858              a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
1859
1860   make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
1861
1862   add_sym_1 ("sin", 1, 1, BT_REAL, dr, GFC_STD_F77,
1863              gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
1864              x, BT_REAL, dr, REQUIRED);
1865
1866   add_sym_1 ("dsin", 1, 1, BT_REAL, dd, GFC_STD_F77,
1867              NULL, gfc_simplify_sin, gfc_resolve_sin,
1868              x, BT_REAL, dd, REQUIRED);
1869
1870   add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1871              NULL, gfc_simplify_sin, gfc_resolve_sin,
1872              x, BT_COMPLEX, dz, REQUIRED);
1873
1874   add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1875              NULL, gfc_simplify_sin, gfc_resolve_sin,
1876              x, BT_COMPLEX, dd, REQUIRED);
1877
1878   make_alias ("cdsin", GFC_STD_GNU);
1879
1880   make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
1881
1882   add_sym_1 ("sinh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1883              gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh,
1884              x, BT_REAL, dr, REQUIRED);
1885
1886   add_sym_1 ("dsinh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1887              NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1888              x, BT_REAL, dd, REQUIRED);
1889
1890   make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
1891
1892   add_sym_2 ("size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1893              gfc_check_size, gfc_simplify_size, NULL,
1894              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1895
1896   make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
1897
1898   add_sym_1 ("spacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1899              gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
1900              x, BT_REAL, dr, REQUIRED);
1901
1902   make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
1903
1904   add_sym_3 ("spread", 0, 1, BT_REAL, dr, GFC_STD_F95,
1905              gfc_check_spread, NULL, gfc_resolve_spread,
1906              src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
1907              n, BT_INTEGER, di, REQUIRED);
1908
1909   make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
1910
1911   add_sym_1 ("sqrt", 1, 1, BT_REAL, dr, GFC_STD_F77,
1912              gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
1913              x, BT_REAL, dr, REQUIRED);
1914
1915   add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd, GFC_STD_F77,
1916              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1917              x, BT_REAL, dd, REQUIRED);
1918
1919   add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1920              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1921              x, BT_COMPLEX, dz, REQUIRED);
1922
1923   add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1924              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1925              x, BT_COMPLEX, dd, REQUIRED);
1926
1927   make_alias ("cdsqrt", GFC_STD_GNU);
1928
1929   make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
1930
1931   add_sym_2 ("stat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1932              gfc_check_stat, NULL, gfc_resolve_stat,
1933              a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1934
1935   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
1936
1937   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1938                 gfc_check_product_sum, NULL, gfc_resolve_sum,
1939                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1940                 msk, BT_LOGICAL, dl, OPTIONAL);
1941
1942   make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
1943
1944   add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1945              gfc_check_symlnk, NULL, gfc_resolve_symlnk,
1946              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1947
1948   make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
1949
1950   add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1951              NULL, NULL, NULL,
1952              c, BT_CHARACTER, dc, REQUIRED);
1953
1954   make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
1955
1956   add_sym_1 ("tan", 1, 1, BT_REAL, dr, GFC_STD_F77,
1957              gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
1958              x, BT_REAL, dr, REQUIRED);
1959
1960   add_sym_1 ("dtan", 1, 1, BT_REAL, dd, GFC_STD_F77,
1961              NULL, gfc_simplify_tan, gfc_resolve_tan,
1962              x, BT_REAL, dd, REQUIRED);
1963
1964   make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
1965
1966   add_sym_1 ("tanh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1967              gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
1968              x, BT_REAL, dr, REQUIRED);
1969
1970   add_sym_1 ("dtanh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1971              NULL, gfc_simplify_tanh, gfc_resolve_tanh,
1972              x, BT_REAL, dd, REQUIRED);
1973
1974   make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
1975
1976   add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1977              NULL, NULL, gfc_resolve_time);
1978
1979   make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
1980
1981   add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1982              NULL, NULL, gfc_resolve_time8);
1983
1984   make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
1985
1986   add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95,
1987              gfc_check_x, gfc_simplify_tiny, NULL,
1988              x, BT_REAL, dr, REQUIRED);
1989
1990   make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95);
1991
1992   add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95,
1993              gfc_check_transfer, NULL, gfc_resolve_transfer,
1994              src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
1995              sz, BT_INTEGER, di, OPTIONAL);
1996
1997   make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
1998
1999   add_sym_1 ("transpose", 0, 1, BT_REAL, dr, GFC_STD_F95,
2000              gfc_check_transpose, NULL, gfc_resolve_transpose,
2001              m, BT_REAL, dr, REQUIRED);
2002
2003   make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2004
2005   add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
2006              gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2007              stg, BT_CHARACTER, dc, REQUIRED);
2008
2009   make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2010
2011   add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
2012              gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2013              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2014
2015   make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2016
2017   /* g77 compatibility for UMASK.  */
2018   add_sym_1 ("umask", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2019              gfc_check_umask, NULL, gfc_resolve_umask,
2020              a, BT_INTEGER, di, REQUIRED);
2021
2022   make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2023
2024   /* g77 compatibility for UNLINK.  */
2025   add_sym_1 ("unlink", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2026              gfc_check_unlink, NULL, gfc_resolve_unlink,
2027              a, BT_CHARACTER, dc, REQUIRED);
2028
2029   make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2030
2031   add_sym_3 ("unpack", 0, 1, BT_REAL, dr, GFC_STD_F95,
2032              gfc_check_unpack, NULL, gfc_resolve_unpack,
2033              v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2034              f, BT_REAL, dr, REQUIRED);
2035
2036   make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2037
2038   add_sym_3 ("verify", 1, 1, BT_INTEGER, di, GFC_STD_F95,
2039              gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2040              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2041              bck, BT_LOGICAL, dl, OPTIONAL);
2042
2043   make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2044 }
2045
2046
2047 /* Add intrinsic subroutines.  */
2048
2049 static void
2050 add_subroutines (void)
2051 {
2052   /* Argument names as in the standard (to be used as argument keywords).  */
2053   const char
2054     *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2055     *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2056     *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2057     *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2058     *com = "command", *length = "length", *st = "status",
2059     *val = "value", *num = "number", *name = "name",
2060     *trim_name = "trim_name", *ut = "unit";
2061
2062   int di, dr, dc, dl;
2063
2064   di = gfc_default_integer_kind;
2065   dr = gfc_default_real_kind;
2066   dc = gfc_default_character_kind;
2067   dl = gfc_default_logical_kind;
2068
2069   add_sym_0s ("abort", 1, GFC_STD_GNU, NULL);
2070
2071   add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2072               gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2073               tm, BT_REAL, dr, REQUIRED);
2074
2075   /* More G77 compatibility garbage.  */
2076   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2077               gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2078               tm, BT_REAL, dr, REQUIRED);
2079
2080   add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2081               gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2082               name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2083
2084   add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2085               gfc_check_date_and_time, NULL, NULL,
2086               dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2087               zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2088
2089   /* More G77 compatibility garbage.  */
2090   add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2091              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2092               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2093
2094   add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2095              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2096               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2097
2098   add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2099               gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
2100               dc, REQUIRED);
2101
2102   add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2103           gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2104               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2105
2106   add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2107               NULL, NULL, NULL,
2108               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2109
2110   add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2111               NULL, NULL, gfc_resolve_getarg,
2112               c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2113
2114   add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2115               gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2116               dc, REQUIRED);
2117
2118   /* F2003 commandline routines.  */
2119
2120   add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2121               NULL, NULL, gfc_resolve_get_command,
2122               com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
2123               st, BT_INTEGER, di, OPTIONAL);
2124
2125   add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2126               NULL, NULL, gfc_resolve_get_command_argument,
2127               num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2128               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2129
2130   /* F2003 subroutine to get environment variables.  */
2131
2132   add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2133              NULL, NULL, gfc_resolve_get_environment_variable,
2134               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2135               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2136               trim_name, BT_LOGICAL, dl, OPTIONAL);
2137
2138   add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2139               gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2140               f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2141               ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2142               tp, BT_INTEGER, di, REQUIRED);
2143
2144   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2145               gfc_check_random_number, NULL, gfc_resolve_random_number,
2146               h, BT_REAL, dr, REQUIRED);
2147
2148   add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2149              gfc_check_random_seed, NULL, NULL,
2150               sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2151               gt, BT_INTEGER, di, OPTIONAL);
2152
2153   /* More G77 compatibility garbage.  */
2154   add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU,
2155              gfc_check_srand, NULL, gfc_resolve_srand,
2156               c, BT_INTEGER, 4, REQUIRED);
2157
2158   add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2159              gfc_check_exit, NULL, gfc_resolve_exit,
2160               c, BT_INTEGER, di, OPTIONAL);
2161
2162   add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2163               gfc_check_flush, NULL, gfc_resolve_flush,
2164               c, BT_INTEGER, di, OPTIONAL);
2165
2166   add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2167           gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2168               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2169
2170   add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2171               NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2172               val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2173
2174   add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2175               gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2176               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2177               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2178
2179   add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2180           gfc_check_perror, NULL, gfc_resolve_perror,
2181               c, BT_CHARACTER, dc, REQUIRED);
2182
2183   add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2184               gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2185               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2186               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2187
2188   add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2189               gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2190               val, BT_CHARACTER, dc, REQUIRED);
2191
2192   add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2193               gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2194               ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2195               st, BT_INTEGER, di, OPTIONAL);
2196
2197   add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2198               gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2199               name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2200               st, BT_INTEGER, di, OPTIONAL);
2201
2202   add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2203               gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2204               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2205               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2206
2207   add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2208               NULL, NULL, gfc_resolve_system_sub,
2209               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2210
2211   add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2212              gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2213               c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2214               cm, BT_INTEGER, di, OPTIONAL);
2215
2216   add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2217           gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2218               val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2219
2220   add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2221           gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2222               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2223
2224 }
2225
2226
2227 /* Add a function to the list of conversion symbols.  */
2228
2229 static void
2230 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2231 {
2232
2233   gfc_typespec from, to;
2234   gfc_intrinsic_sym *sym;
2235
2236   if (sizing == SZ_CONVS)
2237     {
2238       nconv++;
2239       return;
2240     }
2241
2242   gfc_clear_ts (&from);
2243   from.type = from_type;
2244   from.kind = from_kind;
2245
2246   gfc_clear_ts (&to);
2247   to.type = to_type;
2248   to.kind = to_kind;
2249
2250   sym = conversion + nconv;
2251
2252   sym->name = conv_name (&from, &to);
2253   sym->lib_name = sym->name;
2254   sym->simplify.cc = gfc_convert_constant;
2255   sym->standard = standard;
2256   sym->elemental = 1;
2257   sym->ts = to;
2258   sym->generic_id = GFC_ISYM_CONVERSION;
2259
2260   nconv++;
2261 }
2262
2263
2264 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2265    functions by looping over the kind tables.  */
2266
2267 static void
2268 add_conversions (void)
2269 {
2270   int i, j;
2271
2272   /* Integer-Integer conversions.  */
2273   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2274     for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2275       {
2276         if (i == j)
2277           continue;
2278
2279         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2280                   BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2281       }
2282
2283   /* Integer-Real/Complex conversions.  */
2284   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2285     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2286       {
2287         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2288                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2289
2290         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2291                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2292
2293         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2294                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2295
2296         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2297                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2298       }
2299
2300   /* Real/Complex - Real/Complex conversions.  */
2301   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2302     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2303       {
2304         if (i != j)
2305           {
2306             add_conv (BT_REAL, gfc_real_kinds[i].kind,
2307                       BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2308
2309             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2310                       BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2311           }
2312
2313         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2314                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2315
2316         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2317                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2318       }
2319
2320   /* Logical/Logical kind conversion.  */
2321   for (i = 0; gfc_logical_kinds[i].kind; i++)
2322     for (j = 0; gfc_logical_kinds[j].kind; j++)
2323       {
2324         if (i == j)
2325           continue;
2326
2327         add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2328                   BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2329       }
2330
2331   /* Integer-Logical and Logical-Integer conversions.  */
2332   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2333     for (i=0; gfc_integer_kinds[i].kind; i++)
2334       for (j=0; gfc_logical_kinds[j].kind; j++)
2335         {
2336           add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2337                     BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2338           add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2339                     BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2340         }
2341 }
2342
2343
2344 /* Initialize the table of intrinsics.  */
2345 void
2346 gfc_intrinsic_init_1 (void)
2347 {
2348   int i;
2349
2350   nargs = nfunc = nsub = nconv = 0;
2351
2352   /* Create a namespace to hold the resolved intrinsic symbols.  */
2353   gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2354
2355   sizing = SZ_FUNCS;
2356   add_functions ();
2357   sizing = SZ_SUBS;
2358   add_subroutines ();
2359   sizing = SZ_CONVS;
2360   add_conversions ();
2361
2362   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2363                           + sizeof (gfc_intrinsic_arg) * nargs);
2364
2365   next_sym = functions;
2366   subroutines = functions + nfunc;
2367
2368   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2369
2370   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2371
2372   sizing = SZ_NOTHING;
2373   nconv = 0;
2374
2375   add_functions ();
2376   add_subroutines ();
2377   add_conversions ();
2378
2379   /* Set the pure flag.  All intrinsic functions are pure, and
2380      intrinsic subroutines are pure if they are elemental.  */
2381
2382   for (i = 0; i < nfunc; i++)
2383     functions[i].pure = 1;
2384
2385   for (i = 0; i < nsub; i++)
2386     subroutines[i].pure = subroutines[i].elemental;
2387 }
2388
2389
2390 void
2391 gfc_intrinsic_done_1 (void)
2392 {
2393   gfc_free (functions);
2394   gfc_free (conversion);
2395   gfc_free_namespace (gfc_intrinsic_namespace);
2396 }
2397
2398
2399 /******** Subroutines to check intrinsic interfaces ***********/
2400
2401 /* Given a formal argument list, remove any NULL arguments that may
2402    have been left behind by a sort against some formal argument list.  */
2403
2404 static void
2405 remove_nullargs (gfc_actual_arglist ** ap)
2406 {
2407   gfc_actual_arglist *head, *tail, *next;
2408
2409   tail = NULL;
2410
2411   for (head = *ap; head; head = next)
2412     {
2413       next = head->next;
2414
2415       if (head->expr == NULL)
2416         {
2417           head->next = NULL;
2418           gfc_free_actual_arglist (head);
2419         }
2420       else
2421         {
2422           if (tail == NULL)
2423             *ap = head;
2424           else
2425             tail->next = head;
2426
2427           tail = head;
2428           tail->next = NULL;
2429         }
2430     }
2431
2432   if (tail == NULL)
2433     *ap = NULL;
2434 }
2435
2436
2437 /* Given an actual arglist and a formal arglist, sort the actual
2438    arglist so that its arguments are in a one-to-one correspondence
2439    with the format arglist.  Arguments that are not present are given
2440    a blank gfc_actual_arglist structure.  If something is obviously
2441    wrong (say, a missing required argument) we abort sorting and
2442    return FAILURE.  */
2443
2444 static try
2445 sort_actual (const char *name, gfc_actual_arglist ** ap,
2446              gfc_intrinsic_arg * formal, locus * where)
2447 {
2448
2449   gfc_actual_arglist *actual, *a;
2450   gfc_intrinsic_arg *f;
2451
2452   remove_nullargs (ap);
2453   actual = *ap;
2454
2455   for (f = formal; f; f = f->next)
2456     f->actual = NULL;
2457
2458   f = formal;
2459   a = actual;
2460
2461   if (f == NULL && a == NULL)   /* No arguments */
2462     return SUCCESS;
2463
2464   for (;;)
2465     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2466       if (f == NULL)
2467         break;
2468       if (a == NULL)
2469         goto optional;
2470
2471       if (a->name != NULL)
2472         goto keywords;
2473
2474       f->actual = a;
2475
2476       f = f->next;
2477       a = a->next;
2478     }
2479
2480   if (a == NULL)
2481     goto do_sort;
2482
2483   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2484   return FAILURE;
2485
2486 keywords:
2487   /* Associate the remaining actual arguments, all of which have
2488      to be keyword arguments.  */
2489   for (; a; a = a->next)
2490     {
2491       for (f = formal; f; f = f->next)
2492         if (strcmp (a->name, f->name) == 0)
2493           break;
2494
2495       if (f == NULL)
2496         {
2497           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2498                      a->name, name, where);
2499           return FAILURE;
2500         }
2501
2502       if (f->actual != NULL)
2503         {
2504           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2505                      f->name, name, where);
2506           return FAILURE;
2507         }
2508
2509       f->actual = a;
2510     }
2511
2512 optional:
2513   /* At this point, all unmatched formal args must be optional.  */
2514   for (f = formal; f; f = f->next)
2515     {
2516       if (f->actual == NULL && f->optional == 0)
2517         {
2518           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2519                      f->name, name, where);
2520           return FAILURE;
2521         }
2522     }
2523
2524 do_sort:
2525   /* Using the formal argument list, string the actual argument list
2526      together in a way that corresponds with the formal list.  */
2527   actual = NULL;
2528
2529   for (f = formal; f; f = f->next)
2530     {
2531       if (f->actual == NULL)
2532         {
2533           a = gfc_get_actual_arglist ();
2534           a->missing_arg_type = f->ts.type;
2535         }
2536       else
2537         a = f->actual;
2538
2539       if (actual == NULL)
2540         *ap = a;
2541       else
2542         actual->next = a;
2543
2544       actual = a;
2545     }
2546   actual->next = NULL;          /* End the sorted argument list.  */
2547
2548   return SUCCESS;
2549 }
2550
2551
2552 /* Compare an actual argument list with an intrinsic's formal argument
2553    list.  The lists are checked for agreement of type.  We don't check
2554    for arrayness here.  */
2555
2556 static try
2557 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2558                int error_flag)
2559 {
2560   gfc_actual_arglist *actual;
2561   gfc_intrinsic_arg *formal;
2562   int i;
2563
2564   formal = sym->formal;
2565   actual = *ap;
2566
2567   i = 0;
2568   for (; formal; formal = formal->next, actual = actual->next, i++)
2569     {
2570       if (actual->expr == NULL)
2571         continue;
2572
2573       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2574         {
2575           if (error_flag)
2576             gfc_error
2577               ("Type of argument '%s' in call to '%s' at %L should be "
2578                "%s, not %s", gfc_current_intrinsic_arg[i],
2579                gfc_current_intrinsic, &actual->expr->where,
2580                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2581           return FAILURE;
2582         }
2583     }
2584
2585   return SUCCESS;
2586 }
2587
2588
2589 /* Given a pointer to an intrinsic symbol and an expression node that
2590    represent the function call to that subroutine, figure out the type
2591    of the result.  This may involve calling a resolution subroutine.  */
2592
2593 static void
2594 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2595 {
2596   gfc_expr *a1, *a2, *a3, *a4, *a5;
2597   gfc_actual_arglist *arg;
2598
2599   if (specific->resolve.f1 == NULL)
2600     {
2601       if (e->value.function.name == NULL)
2602         e->value.function.name = specific->lib_name;
2603
2604       if (e->ts.type == BT_UNKNOWN)
2605         e->ts = specific->ts;
2606       return;
2607     }
2608
2609   arg = e->value.function.actual;
2610
2611   /* Special case hacks for MIN and MAX.  */
2612   if (specific->resolve.f1m == gfc_resolve_max
2613       || specific->resolve.f1m == gfc_resolve_min)
2614     {
2615       (*specific->resolve.f1m) (e, arg);
2616       return;
2617     }
2618
2619   if (arg == NULL)
2620     {
2621       (*specific->resolve.f0) (e);
2622       return;
2623     }
2624
2625   a1 = arg->expr;
2626   arg = arg->next;
2627
2628   if (arg == NULL)
2629     {
2630       (*specific->resolve.f1) (e, a1);
2631       return;
2632     }
2633
2634   a2 = arg->expr;
2635   arg = arg->next;
2636
2637   if (arg == NULL)
2638     {
2639       (*specific->resolve.f2) (e, a1, a2);
2640       return;
2641     }
2642
2643   a3 = arg->expr;
2644   arg = arg->next;
2645
2646   if (arg == NULL)
2647     {
2648       (*specific->resolve.f3) (e, a1, a2, a3);
2649       return;
2650     }
2651
2652   a4 = arg->expr;
2653   arg = arg->next;
2654
2655   if (arg == NULL)
2656     {
2657       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2658       return;
2659     }
2660
2661   a5 = arg->expr;
2662   arg = arg->next;
2663
2664   if (arg == NULL)
2665     {
2666       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2667       return;
2668     }
2669
2670   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2671 }
2672
2673
2674 /* Given an intrinsic symbol node and an expression node, call the
2675    simplification function (if there is one), perhaps replacing the
2676    expression with something simpler.  We return FAILURE on an error
2677    of the simplification, SUCCESS if the simplification worked, even
2678    if nothing has changed in the expression itself.  */
2679
2680 static try
2681 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2682 {
2683   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2684   gfc_actual_arglist *arg;
2685
2686   /* Max and min require special handling due to the variable number
2687      of args.  */
2688   if (specific->simplify.f1 == gfc_simplify_min)
2689     {
2690       result = gfc_simplify_min (e);
2691       goto finish;
2692     }
2693
2694   if (specific->simplify.f1 == gfc_simplify_max)
2695     {
2696       result = gfc_simplify_max (e);
2697       goto finish;
2698     }
2699
2700   if (specific->simplify.f1 == NULL)
2701     {
2702       result = NULL;
2703       goto finish;
2704     }
2705
2706   arg = e->value.function.actual;
2707
2708   if (arg == NULL)
2709     {
2710       result = (*specific->simplify.f0) ();
2711       goto finish;
2712     }
2713
2714   a1 = arg->expr;
2715   arg = arg->next;
2716
2717   if (specific->simplify.cc == gfc_convert_constant)
2718     {
2719       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2720       goto finish;
2721     }
2722
2723   /* TODO: Warn if -pedantic and initialization expression and arg
2724      types not integer or character */
2725
2726   if (arg == NULL)
2727     result = (*specific->simplify.f1) (a1);
2728   else
2729     {
2730       a2 = arg->expr;
2731       arg = arg->next;
2732
2733       if (arg == NULL)
2734         result = (*specific->simplify.f2) (a1, a2);
2735       else
2736         {
2737           a3 = arg->expr;
2738           arg = arg->next;
2739
2740           if (arg == NULL)
2741             result = (*specific->simplify.f3) (a1, a2, a3);
2742           else
2743             {
2744               a4 = arg->expr;
2745               arg = arg->next;
2746
2747               if (arg == NULL)
2748                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2749               else
2750                 {
2751                   a5 = arg->expr;
2752                   arg = arg->next;
2753
2754                   if (arg == NULL)
2755                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2756                   else
2757                     gfc_internal_error
2758                       ("do_simplify(): Too many args for intrinsic");
2759                 }
2760             }
2761         }
2762     }
2763
2764 finish:
2765   if (result == &gfc_bad_expr)
2766     return FAILURE;
2767
2768   if (result == NULL)
2769     resolve_intrinsic (specific, e);    /* Must call at run-time */
2770   else
2771     {
2772       result->where = e->where;
2773       gfc_replace_expr (e, result);
2774     }
2775
2776   return SUCCESS;
2777 }
2778
2779
2780 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2781    error messages.  This subroutine returns FAILURE if a subroutine
2782    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2783    list cannot match any intrinsic.  */
2784
2785 static void
2786 init_arglist (gfc_intrinsic_sym * isym)
2787 {
2788   gfc_intrinsic_arg *formal;
2789   int i;
2790
2791   gfc_current_intrinsic = isym->name;
2792
2793   i = 0;
2794   for (formal = isym->formal; formal; formal = formal->next)
2795     {
2796       if (i >= MAX_INTRINSIC_ARGS)
2797         gfc_internal_error ("init_arglist(): too many arguments");
2798       gfc_current_intrinsic_arg[i++] = formal->name;
2799     }
2800 }
2801
2802
2803 /* Given a pointer to an intrinsic symbol and an expression consisting
2804    of a function call, see if the function call is consistent with the
2805    intrinsic's formal argument list.  Return SUCCESS if the expression
2806    and intrinsic match, FAILURE otherwise.  */
2807
2808 static try
2809 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2810 {
2811   gfc_actual_arglist *arg, **ap;
2812   int r;
2813   try t;
2814
2815   ap = &expr->value.function.actual;
2816
2817   init_arglist (specific);
2818
2819   /* Don't attempt to sort the argument list for min or max.  */
2820   if (specific->check.f1m == gfc_check_min_max
2821       || specific->check.f1m == gfc_check_min_max_integer
2822       || specific->check.f1m == gfc_check_min_max_real
2823       || specific->check.f1m == gfc_check_min_max_double)
2824     return (*specific->check.f1m) (*ap);
2825
2826   if (sort_actual (specific->name, ap, specific->formal,
2827                    &expr->where) == FAILURE)
2828     return FAILURE;
2829
2830   if (specific->check.f3ml == gfc_check_minloc_maxloc)
2831     /* This is special because we might have to reorder the argument
2832        list.  */
2833     t = gfc_check_minloc_maxloc (*ap);
2834   else if (specific->check.f3red == gfc_check_minval_maxval)
2835     /* This is also special because we also might have to reorder the
2836        argument list.  */
2837     t = gfc_check_minval_maxval (*ap);
2838   else if (specific->check.f3red == gfc_check_product_sum)
2839     /* Same here. The difference to the previous case is that we allow a
2840        general numeric type.  */
2841     t = gfc_check_product_sum (*ap);
2842   else
2843      {
2844        if (specific->check.f1 == NULL)
2845          {
2846            t = check_arglist (ap, specific, error_flag);
2847            if (t == SUCCESS)
2848              expr->ts = specific->ts;
2849          }
2850        else
2851          t = do_check (specific, *ap);
2852      }
2853
2854   /* Check ranks for elemental intrinsics.  */
2855   if (t == SUCCESS && specific->elemental)
2856     {
2857       r = 0;
2858       for (arg = expr->value.function.actual; arg; arg = arg->next)
2859         {
2860           if (arg->expr == NULL || arg->expr->rank == 0)
2861             continue;
2862           if (r == 0)
2863             {
2864               r = arg->expr->rank;
2865               continue;
2866             }
2867
2868           if (arg->expr->rank != r)
2869             {
2870               gfc_error
2871                 ("Ranks of arguments to elemental intrinsic '%s' differ "
2872                  "at %L", specific->name, &arg->expr->where);
2873               return FAILURE;
2874             }
2875         }
2876     }
2877
2878   if (t == FAILURE)
2879     remove_nullargs (ap);
2880
2881   return t;
2882 }
2883
2884
2885 /* See if an intrinsic is one of the intrinsics we evaluate
2886    as an extension.  */
2887
2888 static int
2889 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2890 {
2891   /* FIXME: This should be moved into the intrinsic definitions.  */
2892   static const char * const init_expr_extensions[] = {
2893     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2894     "precision", "present", "radix", "range", "selected_real_kind",
2895     "tiny", NULL
2896   };
2897
2898   int i;
2899
2900   for (i = 0; init_expr_extensions[i]; i++)
2901     if (strcmp (init_expr_extensions[i], isym->name) == 0)
2902       return 0;
2903
2904   return 1;
2905 }
2906
2907
2908 /* Check whether an intrinsic belongs to whatever standard the user
2909    has chosen.  */
2910
2911 static void
2912 check_intrinsic_standard (const char *name, int standard, locus * where)
2913 {
2914   if (!gfc_option.warn_nonstd_intrinsics)
2915     return;
2916
2917   gfc_notify_std (standard, "Intrinsic '%s' at %L is not included"
2918                   "in the selected standard", name, where);
2919 }
2920
2921
2922 /* See if a function call corresponds to an intrinsic function call.
2923    We return:
2924
2925     MATCH_YES    if the call corresponds to an intrinsic, simplification
2926                  is done if possible.
2927
2928     MATCH_NO     if the call does not correspond to an intrinsic
2929
2930     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
2931                  error during the simplification process.
2932
2933    The error_flag parameter enables an error reporting.  */
2934
2935 match
2936 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
2937 {
2938   gfc_intrinsic_sym *isym, *specific;
2939   gfc_actual_arglist *actual;
2940   const char *name;
2941   int flag;
2942
2943   if (expr->value.function.isym != NULL)
2944     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
2945       ? MATCH_ERROR : MATCH_YES;
2946
2947   gfc_suppress_error = !error_flag;
2948   flag = 0;
2949
2950   for (actual = expr->value.function.actual; actual; actual = actual->next)
2951     if (actual->expr != NULL)
2952       flag |= (actual->expr->ts.type != BT_INTEGER
2953                && actual->expr->ts.type != BT_CHARACTER);
2954
2955   name = expr->symtree->n.sym->name;
2956
2957   isym = specific = gfc_find_function (name);
2958   if (isym == NULL)
2959     {
2960       gfc_suppress_error = 0;
2961       return MATCH_NO;
2962     }
2963
2964   gfc_current_intrinsic_where = &expr->where;
2965
2966   /* Bypass the generic list for min and max.  */
2967   if (isym->check.f1m == gfc_check_min_max)
2968     {
2969       init_arglist (isym);
2970
2971       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
2972         goto got_specific;
2973
2974       gfc_suppress_error = 0;
2975       return MATCH_NO;
2976     }
2977
2978   /* If the function is generic, check all of its specific
2979      incarnations.  If the generic name is also a specific, we check
2980      that name last, so that any error message will correspond to the
2981      specific.  */
2982   gfc_suppress_error = 1;
2983
2984   if (isym->generic)
2985     {
2986       for (specific = isym->specific_head; specific;
2987            specific = specific->next)
2988         {
2989           if (specific == isym)
2990             continue;
2991           if (check_specific (specific, expr, 0) == SUCCESS)
2992             goto got_specific;
2993         }
2994     }
2995
2996   gfc_suppress_error = !error_flag;
2997
2998   if (check_specific (isym, expr, error_flag) == FAILURE)
2999     {
3000       gfc_suppress_error = 0;
3001       return MATCH_NO;
3002     }
3003
3004   specific = isym;
3005
3006 got_specific:
3007   expr->value.function.isym = specific;
3008   gfc_intrinsic_symbol (expr->symtree->n.sym);
3009
3010   if (do_simplify (specific, expr) == FAILURE)
3011     {
3012       gfc_suppress_error = 0;
3013       return MATCH_ERROR;
3014     }
3015
3016   /* TODO: We should probably only allow elemental functions here.  */
3017   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3018
3019   gfc_suppress_error = 0;
3020   if (pedantic && gfc_init_expr
3021       && flag && gfc_init_expr_extensions (specific))
3022     {
3023       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3024             "nonstandard initialization expression at %L", &expr->where)
3025           == FAILURE)
3026         {
3027           return MATCH_ERROR;
3028         }
3029     }
3030
3031   check_intrinsic_standard (name, isym->standard, &expr->where);
3032
3033   return MATCH_YES;
3034 }
3035
3036
3037 /* See if a CALL statement corresponds to an intrinsic subroutine.
3038    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3039    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3040    correspond).  */
3041
3042 match
3043 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3044 {
3045   gfc_intrinsic_sym *isym;
3046   const char *name;
3047
3048   name = c->symtree->n.sym->name;
3049
3050   isym = find_subroutine (name);
3051   if (isym == NULL)
3052     return MATCH_NO;
3053
3054   gfc_suppress_error = !error_flag;
3055
3056   init_arglist (isym);
3057
3058   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3059     goto fail;
3060
3061   if (isym->check.f1 != NULL)
3062     {
3063       if (do_check (isym, c->ext.actual) == FAILURE)
3064         goto fail;
3065     }
3066   else
3067     {
3068       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3069         goto fail;
3070     }
3071
3072   /* The subroutine corresponds to an intrinsic.  Allow errors to be
3073      seen at this point.  */
3074   gfc_suppress_error = 0;
3075
3076   if (isym->resolve.s1 != NULL)
3077     isym->resolve.s1 (c);
3078   else
3079     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3080
3081   if (gfc_pure (NULL) && !isym->elemental)
3082     {
3083       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3084                  &c->loc);
3085       return MATCH_ERROR;
3086     }
3087
3088   check_intrinsic_standard (name, isym->standard, &c->loc);
3089
3090   return MATCH_YES;
3091
3092 fail:
3093   gfc_suppress_error = 0;
3094   return MATCH_NO;
3095 }
3096
3097
3098 /* Call gfc_convert_type() with warning enabled.  */
3099
3100 try
3101 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3102 {
3103   return gfc_convert_type_warn (expr, ts, eflag, 1);
3104 }
3105
3106
3107 /* Try to convert an expression (in place) from one type to another.
3108    'eflag' controls the behavior on error.
3109
3110    The possible values are:
3111
3112      1 Generate a gfc_error()
3113      2 Generate a gfc_internal_error().
3114
3115    'wflag' controls the warning related to conversion.  */
3116
3117 try
3118 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3119                        int wflag)
3120 {
3121   gfc_intrinsic_sym *sym;
3122   gfc_typespec from_ts;
3123   locus old_where;
3124   gfc_expr *new;
3125   int rank;
3126   mpz_t *shape;
3127
3128   from_ts = expr->ts;           /* expr->ts gets clobbered */
3129
3130   if (ts->type == BT_UNKNOWN)
3131     goto bad;
3132
3133   /* NULL and zero size arrays get their type here.  */
3134   if (expr->expr_type == EXPR_NULL
3135       || (expr->expr_type == EXPR_ARRAY
3136           && expr->value.constructor == NULL))
3137     {
3138       /* Sometimes the RHS acquire the type.  */
3139       expr->ts = *ts;
3140       return SUCCESS;
3141     }
3142
3143   if (expr->ts.type == BT_UNKNOWN)
3144     goto bad;
3145
3146   if (expr->ts.type == BT_DERIVED
3147       && ts->type == BT_DERIVED
3148       && gfc_compare_types (&expr->ts, ts))
3149     return SUCCESS;
3150
3151   sym = find_conv (&expr->ts, ts);
3152   if (sym == NULL)
3153     goto bad;
3154
3155   /* At this point, a conversion is necessary. A warning may be needed.  */
3156   if ((gfc_option.warn_std & sym->standard) != 0)
3157     gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3158                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3159   else if (wflag && gfc_option.warn_conversion)
3160     gfc_warning_now ("Conversion from %s to %s at %L",
3161                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3162
3163   /* Insert a pre-resolved function call to the right function.  */
3164   old_where = expr->where;
3165   rank = expr->rank;
3166   shape = expr->shape;
3167
3168   new = gfc_get_expr ();
3169   *new = *expr;
3170
3171   new = gfc_build_conversion (new);
3172   new->value.function.name = sym->lib_name;
3173   new->value.function.isym = sym;
3174   new->where = old_where;
3175   new->rank = rank;
3176   new->shape = gfc_copy_shape (shape, rank);
3177
3178   *expr = *new;
3179
3180   gfc_free (new);
3181   expr->ts = *ts;
3182
3183   if (gfc_is_constant_expr (expr->value.function.actual->expr)
3184       && do_simplify (sym, expr) == FAILURE)
3185     {
3186
3187       if (eflag == 2)
3188         goto bad;
3189       return FAILURE;           /* Error already generated in do_simplify() */
3190     }
3191
3192   return SUCCESS;
3193
3194 bad:
3195   if (eflag == 1)
3196     {
3197       gfc_error ("Can't convert %s to %s at %L",
3198                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3199       return FAILURE;
3200     }
3201
3202   gfc_internal_error ("Can't convert %s to %s at %L",
3203                       gfc_typename (&from_ts), gfc_typename (ts),
3204                       &expr->where);
3205   /* Not reached */
3206 }