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,
2231           gfc_expr * (*simplify) (gfc_expr *, bt, int))
2232 {
2233
2234   gfc_typespec from, to;
2235   gfc_intrinsic_sym *sym;
2236
2237   if (sizing == SZ_CONVS)
2238     {
2239       nconv++;
2240       return;
2241     }
2242
2243   gfc_clear_ts (&from);
2244   from.type = from_type;
2245   from.kind = from_kind;
2246
2247   gfc_clear_ts (&to);
2248   to.type = to_type;
2249   to.kind = to_kind;
2250
2251   sym = conversion + nconv;
2252
2253   sym->name =  conv_name (&from, &to);
2254   sym->lib_name = sym->name;
2255   sym->simplify.cc = simplify;
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_convert_constant);
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_convert_constant);
2289
2290         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2291                   BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
2292
2293         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2294                   BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2295
2296         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2297                   BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
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_convert_constant);
2308
2309             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2310                       BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2311           }
2312
2313         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2314                   BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2315
2316         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2317                   BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
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_convert_constant);
2329       }
2330 }
2331
2332
2333 /* Initialize the table of intrinsics.  */
2334 void
2335 gfc_intrinsic_init_1 (void)
2336 {
2337   int i;
2338
2339   nargs = nfunc = nsub = nconv = 0;
2340
2341   /* Create a namespace to hold the resolved intrinsic symbols.  */
2342   gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2343
2344   sizing = SZ_FUNCS;
2345   add_functions ();
2346   sizing = SZ_SUBS;
2347   add_subroutines ();
2348   sizing = SZ_CONVS;
2349   add_conversions ();
2350
2351   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2352                           + sizeof (gfc_intrinsic_arg) * nargs);
2353
2354   next_sym = functions;
2355   subroutines = functions + nfunc;
2356
2357   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2358
2359   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2360
2361   sizing = SZ_NOTHING;
2362   nconv = 0;
2363
2364   add_functions ();
2365   add_subroutines ();
2366   add_conversions ();
2367
2368   /* Set the pure flag.  All intrinsic functions are pure, and
2369      intrinsic subroutines are pure if they are elemental.  */
2370
2371   for (i = 0; i < nfunc; i++)
2372     functions[i].pure = 1;
2373
2374   for (i = 0; i < nsub; i++)
2375     subroutines[i].pure = subroutines[i].elemental;
2376 }
2377
2378
2379 void
2380 gfc_intrinsic_done_1 (void)
2381 {
2382   gfc_free (functions);
2383   gfc_free (conversion);
2384   gfc_free_namespace (gfc_intrinsic_namespace);
2385 }
2386
2387
2388 /******** Subroutines to check intrinsic interfaces ***********/
2389
2390 /* Given a formal argument list, remove any NULL arguments that may
2391    have been left behind by a sort against some formal argument list.  */
2392
2393 static void
2394 remove_nullargs (gfc_actual_arglist ** ap)
2395 {
2396   gfc_actual_arglist *head, *tail, *next;
2397
2398   tail = NULL;
2399
2400   for (head = *ap; head; head = next)
2401     {
2402       next = head->next;
2403
2404       if (head->expr == NULL)
2405         {
2406           head->next = NULL;
2407           gfc_free_actual_arglist (head);
2408         }
2409       else
2410         {
2411           if (tail == NULL)
2412             *ap = head;
2413           else
2414             tail->next = head;
2415
2416           tail = head;
2417           tail->next = NULL;
2418         }
2419     }
2420
2421   if (tail == NULL)
2422     *ap = NULL;
2423 }
2424
2425
2426 /* Given an actual arglist and a formal arglist, sort the actual
2427    arglist so that its arguments are in a one-to-one correspondence
2428    with the format arglist.  Arguments that are not present are given
2429    a blank gfc_actual_arglist structure.  If something is obviously
2430    wrong (say, a missing required argument) we abort sorting and
2431    return FAILURE.  */
2432
2433 static try
2434 sort_actual (const char *name, gfc_actual_arglist ** ap,
2435              gfc_intrinsic_arg * formal, locus * where)
2436 {
2437
2438   gfc_actual_arglist *actual, *a;
2439   gfc_intrinsic_arg *f;
2440
2441   remove_nullargs (ap);
2442   actual = *ap;
2443
2444   for (f = formal; f; f = f->next)
2445     f->actual = NULL;
2446
2447   f = formal;
2448   a = actual;
2449
2450   if (f == NULL && a == NULL)   /* No arguments */
2451     return SUCCESS;
2452
2453   for (;;)
2454     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2455       if (f == NULL)
2456         break;
2457       if (a == NULL)
2458         goto optional;
2459
2460       if (a->name != NULL)
2461         goto keywords;
2462
2463       f->actual = a;
2464
2465       f = f->next;
2466       a = a->next;
2467     }
2468
2469   if (a == NULL)
2470     goto do_sort;
2471
2472   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2473   return FAILURE;
2474
2475 keywords:
2476   /* Associate the remaining actual arguments, all of which have
2477      to be keyword arguments.  */
2478   for (; a; a = a->next)
2479     {
2480       for (f = formal; f; f = f->next)
2481         if (strcmp (a->name, f->name) == 0)
2482           break;
2483
2484       if (f == NULL)
2485         {
2486           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2487                      a->name, name, where);
2488           return FAILURE;
2489         }
2490
2491       if (f->actual != NULL)
2492         {
2493           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2494                      f->name, name, where);
2495           return FAILURE;
2496         }
2497
2498       f->actual = a;
2499     }
2500
2501 optional:
2502   /* At this point, all unmatched formal args must be optional.  */
2503   for (f = formal; f; f = f->next)
2504     {
2505       if (f->actual == NULL && f->optional == 0)
2506         {
2507           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2508                      f->name, name, where);
2509           return FAILURE;
2510         }
2511     }
2512
2513 do_sort:
2514   /* Using the formal argument list, string the actual argument list
2515      together in a way that corresponds with the formal list.  */
2516   actual = NULL;
2517
2518   for (f = formal; f; f = f->next)
2519     {
2520       if (f->actual == NULL)
2521         {
2522           a = gfc_get_actual_arglist ();
2523           a->missing_arg_type = f->ts.type;
2524         }
2525       else
2526         a = f->actual;
2527
2528       if (actual == NULL)
2529         *ap = a;
2530       else
2531         actual->next = a;
2532
2533       actual = a;
2534     }
2535   actual->next = NULL;          /* End the sorted argument list.  */
2536
2537   return SUCCESS;
2538 }
2539
2540
2541 /* Compare an actual argument list with an intrinsic's formal argument
2542    list.  The lists are checked for agreement of type.  We don't check
2543    for arrayness here.  */
2544
2545 static try
2546 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2547                int error_flag)
2548 {
2549   gfc_actual_arglist *actual;
2550   gfc_intrinsic_arg *formal;
2551   int i;
2552
2553   formal = sym->formal;
2554   actual = *ap;
2555
2556   i = 0;
2557   for (; formal; formal = formal->next, actual = actual->next, i++)
2558     {
2559       if (actual->expr == NULL)
2560         continue;
2561
2562       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2563         {
2564           if (error_flag)
2565             gfc_error
2566               ("Type of argument '%s' in call to '%s' at %L should be "
2567                "%s, not %s", gfc_current_intrinsic_arg[i],
2568                gfc_current_intrinsic, &actual->expr->where,
2569                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2570           return FAILURE;
2571         }
2572     }
2573
2574   return SUCCESS;
2575 }
2576
2577
2578 /* Given a pointer to an intrinsic symbol and an expression node that
2579    represent the function call to that subroutine, figure out the type
2580    of the result.  This may involve calling a resolution subroutine.  */
2581
2582 static void
2583 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2584 {
2585   gfc_expr *a1, *a2, *a3, *a4, *a5;
2586   gfc_actual_arglist *arg;
2587
2588   if (specific->resolve.f1 == NULL)
2589     {
2590       if (e->value.function.name == NULL)
2591         e->value.function.name = specific->lib_name;
2592
2593       if (e->ts.type == BT_UNKNOWN)
2594         e->ts = specific->ts;
2595       return;
2596     }
2597
2598   arg = e->value.function.actual;
2599
2600   /* Special case hacks for MIN and MAX.  */
2601   if (specific->resolve.f1m == gfc_resolve_max
2602       || specific->resolve.f1m == gfc_resolve_min)
2603     {
2604       (*specific->resolve.f1m) (e, arg);
2605       return;
2606     }
2607
2608   if (arg == NULL)
2609     {
2610       (*specific->resolve.f0) (e);
2611       return;
2612     }
2613
2614   a1 = arg->expr;
2615   arg = arg->next;
2616
2617   if (arg == NULL)
2618     {
2619       (*specific->resolve.f1) (e, a1);
2620       return;
2621     }
2622
2623   a2 = arg->expr;
2624   arg = arg->next;
2625
2626   if (arg == NULL)
2627     {
2628       (*specific->resolve.f2) (e, a1, a2);
2629       return;
2630     }
2631
2632   a3 = arg->expr;
2633   arg = arg->next;
2634
2635   if (arg == NULL)
2636     {
2637       (*specific->resolve.f3) (e, a1, a2, a3);
2638       return;
2639     }
2640
2641   a4 = arg->expr;
2642   arg = arg->next;
2643
2644   if (arg == NULL)
2645     {
2646       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2647       return;
2648     }
2649
2650   a5 = arg->expr;
2651   arg = arg->next;
2652
2653   if (arg == NULL)
2654     {
2655       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2656       return;
2657     }
2658
2659   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2660 }
2661
2662
2663 /* Given an intrinsic symbol node and an expression node, call the
2664    simplification function (if there is one), perhaps replacing the
2665    expression with something simpler.  We return FAILURE on an error
2666    of the simplification, SUCCESS if the simplification worked, even
2667    if nothing has changed in the expression itself.  */
2668
2669 static try
2670 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2671 {
2672   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2673   gfc_actual_arglist *arg;
2674
2675   /* Max and min require special handling due to the variable number
2676      of args.  */
2677   if (specific->simplify.f1 == gfc_simplify_min)
2678     {
2679       result = gfc_simplify_min (e);
2680       goto finish;
2681     }
2682
2683   if (specific->simplify.f1 == gfc_simplify_max)
2684     {
2685       result = gfc_simplify_max (e);
2686       goto finish;
2687     }
2688
2689   if (specific->simplify.f1 == NULL)
2690     {
2691       result = NULL;
2692       goto finish;
2693     }
2694
2695   arg = e->value.function.actual;
2696
2697   if (arg == NULL)
2698     {
2699       result = (*specific->simplify.f0) ();
2700       goto finish;
2701     }
2702
2703   a1 = arg->expr;
2704   arg = arg->next;
2705
2706   if (specific->simplify.cc == gfc_convert_constant)
2707     {
2708       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2709       goto finish;
2710     }
2711
2712   /* TODO: Warn if -pedantic and initialization expression and arg
2713      types not integer or character */
2714
2715   if (arg == NULL)
2716     result = (*specific->simplify.f1) (a1);
2717   else
2718     {
2719       a2 = arg->expr;
2720       arg = arg->next;
2721
2722       if (arg == NULL)
2723         result = (*specific->simplify.f2) (a1, a2);
2724       else
2725         {
2726           a3 = arg->expr;
2727           arg = arg->next;
2728
2729           if (arg == NULL)
2730             result = (*specific->simplify.f3) (a1, a2, a3);
2731           else
2732             {
2733               a4 = arg->expr;
2734               arg = arg->next;
2735
2736               if (arg == NULL)
2737                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2738               else
2739                 {
2740                   a5 = arg->expr;
2741                   arg = arg->next;
2742
2743                   if (arg == NULL)
2744                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2745                   else
2746                     gfc_internal_error
2747                       ("do_simplify(): Too many args for intrinsic");
2748                 }
2749             }
2750         }
2751     }
2752
2753 finish:
2754   if (result == &gfc_bad_expr)
2755     return FAILURE;
2756
2757   if (result == NULL)
2758     resolve_intrinsic (specific, e);    /* Must call at run-time */
2759   else
2760     {
2761       result->where = e->where;
2762       gfc_replace_expr (e, result);
2763     }
2764
2765   return SUCCESS;
2766 }
2767
2768
2769 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2770    error messages.  This subroutine returns FAILURE if a subroutine
2771    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2772    list cannot match any intrinsic.  */
2773
2774 static void
2775 init_arglist (gfc_intrinsic_sym * isym)
2776 {
2777   gfc_intrinsic_arg *formal;
2778   int i;
2779
2780   gfc_current_intrinsic = isym->name;
2781
2782   i = 0;
2783   for (formal = isym->formal; formal; formal = formal->next)
2784     {
2785       if (i >= MAX_INTRINSIC_ARGS)
2786         gfc_internal_error ("init_arglist(): too many arguments");
2787       gfc_current_intrinsic_arg[i++] = formal->name;
2788     }
2789 }
2790
2791
2792 /* Given a pointer to an intrinsic symbol and an expression consisting
2793    of a function call, see if the function call is consistent with the
2794    intrinsic's formal argument list.  Return SUCCESS if the expression
2795    and intrinsic match, FAILURE otherwise.  */
2796
2797 static try
2798 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2799 {
2800   gfc_actual_arglist *arg, **ap;
2801   int r;
2802   try t;
2803
2804   ap = &expr->value.function.actual;
2805
2806   init_arglist (specific);
2807
2808   /* Don't attempt to sort the argument list for min or max.  */
2809   if (specific->check.f1m == gfc_check_min_max
2810       || specific->check.f1m == gfc_check_min_max_integer
2811       || specific->check.f1m == gfc_check_min_max_real
2812       || specific->check.f1m == gfc_check_min_max_double)
2813     return (*specific->check.f1m) (*ap);
2814
2815   if (sort_actual (specific->name, ap, specific->formal,
2816                    &expr->where) == FAILURE)
2817     return FAILURE;
2818
2819   if (specific->check.f3ml == gfc_check_minloc_maxloc)
2820     /* This is special because we might have to reorder the argument
2821        list.  */
2822     t = gfc_check_minloc_maxloc (*ap);
2823   else if (specific->check.f3red == gfc_check_minval_maxval)
2824     /* This is also special because we also might have to reorder the
2825        argument list.  */
2826     t = gfc_check_minval_maxval (*ap);
2827   else if (specific->check.f3red == gfc_check_product_sum)
2828     /* Same here. The difference to the previous case is that we allow a
2829        general numeric type.  */
2830     t = gfc_check_product_sum (*ap);
2831   else
2832      {
2833        if (specific->check.f1 == NULL)
2834          {
2835            t = check_arglist (ap, specific, error_flag);
2836            if (t == SUCCESS)
2837              expr->ts = specific->ts;
2838          }
2839        else
2840          t = do_check (specific, *ap);
2841      }
2842
2843   /* Check ranks for elemental intrinsics.  */
2844   if (t == SUCCESS && specific->elemental)
2845     {
2846       r = 0;
2847       for (arg = expr->value.function.actual; arg; arg = arg->next)
2848         {
2849           if (arg->expr == NULL || arg->expr->rank == 0)
2850             continue;
2851           if (r == 0)
2852             {
2853               r = arg->expr->rank;
2854               continue;
2855             }
2856
2857           if (arg->expr->rank != r)
2858             {
2859               gfc_error
2860                 ("Ranks of arguments to elemental intrinsic '%s' differ "
2861                  "at %L", specific->name, &arg->expr->where);
2862               return FAILURE;
2863             }
2864         }
2865     }
2866
2867   if (t == FAILURE)
2868     remove_nullargs (ap);
2869
2870   return t;
2871 }
2872
2873
2874 /* See if an intrinsic is one of the intrinsics we evaluate
2875    as an extension.  */
2876
2877 static int
2878 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2879 {
2880   /* FIXME: This should be moved into the intrinsic definitions.  */
2881   static const char * const init_expr_extensions[] = {
2882     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2883     "precision", "present", "radix", "range", "selected_real_kind",
2884     "tiny", NULL
2885   };
2886
2887   int i;
2888
2889   for (i = 0; init_expr_extensions[i]; i++)
2890     if (strcmp (init_expr_extensions[i], isym->name) == 0)
2891       return 0;
2892
2893   return 1;
2894 }
2895
2896
2897 /* Check whether an intrinsic belongs to whatever standard the user
2898    has chosen.  */
2899
2900 static void
2901 check_intrinsic_standard (const char *name, int standard, locus * where)
2902 {
2903   if (!gfc_option.warn_nonstd_intrinsics)
2904     return;
2905
2906   gfc_notify_std (standard, "Intrinsic '%s' at %L is not included"
2907                   "in the selected standard", name, where);
2908 }
2909
2910
2911 /* See if a function call corresponds to an intrinsic function call.
2912    We return:
2913
2914     MATCH_YES    if the call corresponds to an intrinsic, simplification
2915                  is done if possible.
2916
2917     MATCH_NO     if the call does not correspond to an intrinsic
2918
2919     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
2920                  error during the simplification process.
2921
2922    The error_flag parameter enables an error reporting.  */
2923
2924 match
2925 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
2926 {
2927   gfc_intrinsic_sym *isym, *specific;
2928   gfc_actual_arglist *actual;
2929   const char *name;
2930   int flag;
2931
2932   if (expr->value.function.isym != NULL)
2933     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
2934       ? MATCH_ERROR : MATCH_YES;
2935
2936   gfc_suppress_error = !error_flag;
2937   flag = 0;
2938
2939   for (actual = expr->value.function.actual; actual; actual = actual->next)
2940     if (actual->expr != NULL)
2941       flag |= (actual->expr->ts.type != BT_INTEGER
2942                && actual->expr->ts.type != BT_CHARACTER);
2943
2944   name = expr->symtree->n.sym->name;
2945
2946   isym = specific = gfc_find_function (name);
2947   if (isym == NULL)
2948     {
2949       gfc_suppress_error = 0;
2950       return MATCH_NO;
2951     }
2952
2953   gfc_current_intrinsic_where = &expr->where;
2954
2955   /* Bypass the generic list for min and max.  */
2956   if (isym->check.f1m == gfc_check_min_max)
2957     {
2958       init_arglist (isym);
2959
2960       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
2961         goto got_specific;
2962
2963       gfc_suppress_error = 0;
2964       return MATCH_NO;
2965     }
2966
2967   /* If the function is generic, check all of its specific
2968      incarnations.  If the generic name is also a specific, we check
2969      that name last, so that any error message will correspond to the
2970      specific.  */
2971   gfc_suppress_error = 1;
2972
2973   if (isym->generic)
2974     {
2975       for (specific = isym->specific_head; specific;
2976            specific = specific->next)
2977         {
2978           if (specific == isym)
2979             continue;
2980           if (check_specific (specific, expr, 0) == SUCCESS)
2981             goto got_specific;
2982         }
2983     }
2984
2985   gfc_suppress_error = !error_flag;
2986
2987   if (check_specific (isym, expr, error_flag) == FAILURE)
2988     {
2989       gfc_suppress_error = 0;
2990       return MATCH_NO;
2991     }
2992
2993   specific = isym;
2994
2995 got_specific:
2996   expr->value.function.isym = specific;
2997   gfc_intrinsic_symbol (expr->symtree->n.sym);
2998
2999   if (do_simplify (specific, expr) == FAILURE)
3000     {
3001       gfc_suppress_error = 0;
3002       return MATCH_ERROR;
3003     }
3004
3005   /* TODO: We should probably only allow elemental functions here.  */
3006   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3007
3008   gfc_suppress_error = 0;
3009   if (pedantic && gfc_init_expr
3010       && flag && gfc_init_expr_extensions (specific))
3011     {
3012       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3013             "nonstandard initialization expression at %L", &expr->where)
3014           == FAILURE)
3015         {
3016           return MATCH_ERROR;
3017         }
3018     }
3019
3020   check_intrinsic_standard (name, isym->standard, &expr->where);
3021
3022   return MATCH_YES;
3023 }
3024
3025
3026 /* See if a CALL statement corresponds to an intrinsic subroutine.
3027    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3028    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3029    correspond).  */
3030
3031 match
3032 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3033 {
3034   gfc_intrinsic_sym *isym;
3035   const char *name;
3036
3037   name = c->symtree->n.sym->name;
3038
3039   isym = find_subroutine (name);
3040   if (isym == NULL)
3041     return MATCH_NO;
3042
3043   gfc_suppress_error = !error_flag;
3044
3045   init_arglist (isym);
3046
3047   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3048     goto fail;
3049
3050   if (isym->check.f1 != NULL)
3051     {
3052       if (do_check (isym, c->ext.actual) == FAILURE)
3053         goto fail;
3054     }
3055   else
3056     {
3057       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3058         goto fail;
3059     }
3060
3061   /* The subroutine corresponds to an intrinsic.  Allow errors to be
3062      seen at this point.  */
3063   gfc_suppress_error = 0;
3064
3065   if (isym->resolve.s1 != NULL)
3066     isym->resolve.s1 (c);
3067   else
3068     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3069
3070   if (gfc_pure (NULL) && !isym->elemental)
3071     {
3072       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3073                  &c->loc);
3074       return MATCH_ERROR;
3075     }
3076
3077   check_intrinsic_standard (name, isym->standard, &c->loc);
3078
3079   return MATCH_YES;
3080
3081 fail:
3082   gfc_suppress_error = 0;
3083   return MATCH_NO;
3084 }
3085
3086
3087 /* Call gfc_convert_type() with warning enabled.  */
3088
3089 try
3090 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3091 {
3092   return gfc_convert_type_warn (expr, ts, eflag, 1);
3093 }
3094
3095
3096 /* Try to convert an expression (in place) from one type to another.
3097    'eflag' controls the behavior on error.
3098
3099    The possible values are:
3100
3101      1 Generate a gfc_error()
3102      2 Generate a gfc_internal_error().
3103
3104    'wflag' controls the warning related to conversion.  */
3105
3106 try
3107 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3108                        int wflag)
3109 {
3110   gfc_intrinsic_sym *sym;
3111   gfc_typespec from_ts;
3112   locus old_where;
3113   gfc_expr *new;
3114   int rank;
3115   mpz_t *shape;
3116
3117   from_ts = expr->ts;           /* expr->ts gets clobbered */
3118
3119   if (ts->type == BT_UNKNOWN)
3120     goto bad;
3121
3122   /* NULL and zero size arrays get their type here.  */
3123   if (expr->expr_type == EXPR_NULL
3124       || (expr->expr_type == EXPR_ARRAY
3125           && expr->value.constructor == NULL))
3126     {
3127       /* Sometimes the RHS acquire the type.  */
3128       expr->ts = *ts;
3129       return SUCCESS;
3130     }
3131
3132   if (expr->ts.type == BT_UNKNOWN)
3133     goto bad;
3134
3135   if (expr->ts.type == BT_DERIVED
3136       && ts->type == BT_DERIVED
3137       && gfc_compare_types (&expr->ts, ts))
3138     return SUCCESS;
3139
3140   sym = find_conv (&expr->ts, ts);
3141   if (sym == NULL)
3142     goto bad;
3143
3144   /* At this point, a conversion is necessary. A warning may be needed.  */
3145   if (wflag && gfc_option.warn_conversion)
3146     gfc_warning_now ("Conversion from %s to %s at %L",
3147                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3148
3149   /* Insert a pre-resolved function call to the right function.  */
3150   old_where = expr->where;
3151   rank = expr->rank;
3152   shape = expr->shape;
3153
3154   new = gfc_get_expr ();
3155   *new = *expr;
3156
3157   new = gfc_build_conversion (new);
3158   new->value.function.name = sym->lib_name;
3159   new->value.function.isym = sym;
3160   new->where = old_where;
3161   new->rank = rank;
3162   new->shape = gfc_copy_shape (shape, rank);
3163
3164   *expr = *new;
3165
3166   gfc_free (new);
3167   expr->ts = *ts;
3168
3169   if (gfc_is_constant_expr (expr->value.function.actual->expr)
3170       && do_simplify (sym, expr) == FAILURE)
3171     {
3172
3173       if (eflag == 2)
3174         goto bad;
3175       return FAILURE;           /* Error already generated in do_simplify() */
3176     }
3177
3178   return SUCCESS;
3179
3180 bad:
3181   if (eflag == 1)
3182     {
3183       gfc_error ("Can't convert %s to %s at %L",
3184                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3185       return FAILURE;
3186     }
3187
3188   gfc_internal_error ("Can't convert %s to %s at %L",
3189                       gfc_typename (&from_ts), gfc_typename (ts),
3190                       &expr->where);
3191   /* Not reached */
3192 }