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_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1096              gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
1097              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
1098              kind, BT_INTEGER, di, OPTIONAL);
1099
1100   make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
1101
1102   /* Making dcmplx a specific of cmplx causes cmplx to return a double
1103      complex instead of the default complex.  */
1104
1105   add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1106              gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
1107              x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
1108
1109   make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
1110
1111   add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1112              gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
1113              z, BT_COMPLEX, dz, REQUIRED);
1114
1115   add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1116              NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1117              z, BT_COMPLEX, dd, REQUIRED);
1118
1119   make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
1120
1121   add_sym_1 ("cos", 1, 1, BT_REAL, dr, GFC_STD_F77,
1122              gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1123              x, BT_REAL, dr, REQUIRED);
1124
1125   add_sym_1 ("dcos", 1, 1, BT_REAL, dd, GFC_STD_F77,
1126              gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1127              x, BT_REAL, dd, REQUIRED);
1128
1129   add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1130              NULL, gfc_simplify_cos, gfc_resolve_cos,
1131              x, BT_COMPLEX, dz, REQUIRED);
1132
1133   add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1134              NULL, gfc_simplify_cos, gfc_resolve_cos,
1135              x, BT_COMPLEX, dd, REQUIRED);
1136
1137   make_alias ("cdcos", GFC_STD_GNU);
1138
1139   make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
1140
1141   add_sym_1 ("cosh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1142              gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh,
1143              x, BT_REAL, dr, REQUIRED);
1144
1145   add_sym_1 ("dcosh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1146              NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1147              x, BT_REAL, dd, REQUIRED);
1148
1149   make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
1150
1151   add_sym_2 ("count", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1152              gfc_check_count, NULL, gfc_resolve_count,
1153              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1154
1155   make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
1156
1157   add_sym_3 ("cshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1158              gfc_check_cshift, NULL, gfc_resolve_cshift,
1159              ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1160              dm, BT_INTEGER, ii, OPTIONAL);
1161
1162   make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
1163
1164   add_sym_1 ("dble", 1, 1, BT_REAL, dd, GFC_STD_F77,
1165              gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1166              a, BT_REAL, dr, REQUIRED);
1167
1168   make_alias ("dfloat", GFC_STD_GNU);
1169
1170   make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
1171
1172   add_sym_1 ("digits", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1173              gfc_check_digits, gfc_simplify_digits, NULL,
1174              x, BT_UNKNOWN, dr, REQUIRED);
1175
1176   make_generic ("digits", GFC_ISYM_NONE, GFC_STD_F95);
1177
1178   add_sym_2 ("dim", 1, 1, BT_REAL, dr, GFC_STD_F77,
1179              gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1180              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1181
1182   add_sym_2 ("idim", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1183              NULL, gfc_simplify_dim, gfc_resolve_dim,
1184              x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
1185
1186   add_sym_2 ("ddim", 1, 1, BT_REAL, dd, GFC_STD_F77,
1187              NULL, gfc_simplify_dim, gfc_resolve_dim,
1188              x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
1189
1190   make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
1191
1192   add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1193              gfc_check_dot_product, NULL, gfc_resolve_dot_product,
1194              va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
1195
1196   make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
1197
1198   add_sym_2 ("dprod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1199              NULL, gfc_simplify_dprod, gfc_resolve_dprod,
1200              x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1201
1202   make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
1203
1204   add_sym_1 ("dreal", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1205              NULL, NULL, NULL,
1206              a, BT_COMPLEX, dd, REQUIRED);
1207
1208   make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
1209
1210   add_sym_4 ("eoshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1211              gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1212              ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
1213              bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
1214
1215   make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
1216
1217   add_sym_1 ("epsilon", 0, 1, BT_REAL, dr, GFC_STD_F95,
1218              gfc_check_x, gfc_simplify_epsilon, NULL,
1219              x, BT_REAL, dr, REQUIRED);
1220
1221   make_generic ("epsilon", GFC_ISYM_NONE, GFC_STD_F95);
1222
1223   /* G77 compatibility for the ERF() and ERFC() functions.  */
1224   add_sym_1 ("erf", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1225              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1226              x, BT_REAL, dr, REQUIRED);
1227
1228   add_sym_1 ("derf", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1229              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1230              x, BT_REAL, dd, REQUIRED);
1231
1232   make_generic ("erf", GFC_ISYM_ERF, GFC_STD_GNU);
1233
1234   add_sym_1 ("erfc", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1235              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1236              x, BT_REAL, dr, REQUIRED);
1237
1238   add_sym_1 ("derfc", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1239              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1240              x, BT_REAL, dd, REQUIRED);
1241
1242   make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_GNU);
1243
1244   /* G77 compatibility */
1245   add_sym_1 ("etime", 0, 1, BT_REAL, 4,  GFC_STD_GNU,
1246              gfc_check_etime, NULL, NULL,
1247              x, BT_REAL, 4, REQUIRED);
1248
1249   make_alias ("dtime", GFC_STD_GNU);
1250
1251   make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
1252
1253   add_sym_1 ("exp", 1, 1, BT_REAL, dr,  GFC_STD_F77,
1254              gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
1255              x, BT_REAL, dr, REQUIRED);
1256
1257   add_sym_1 ("dexp", 1, 1, BT_REAL, dd, GFC_STD_F77,
1258              NULL, gfc_simplify_exp, gfc_resolve_exp,
1259              x, BT_REAL, dd, REQUIRED);
1260
1261   add_sym_1 ("cexp", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1262              NULL, gfc_simplify_exp, gfc_resolve_exp,
1263              x, BT_COMPLEX, dz, REQUIRED);
1264
1265   add_sym_1 ("zexp", 1, 1, BT_COMPLEX, dd,  GFC_STD_GNU,
1266              NULL, gfc_simplify_exp, gfc_resolve_exp,
1267              x, BT_COMPLEX, dd, REQUIRED);
1268
1269   make_alias ("cdexp", GFC_STD_GNU);
1270
1271   make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
1272
1273   add_sym_1 ("exponent", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1274              gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1275              x, BT_REAL, dr, REQUIRED);
1276
1277   make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
1278
1279   add_sym_2 ("floor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1280              gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1281              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1282
1283   make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1284
1285   /* G77 compatible fnum */
1286   add_sym_1 ("fnum", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1287              gfc_check_fnum, NULL, gfc_resolve_fnum,
1288              ut, BT_INTEGER, di, REQUIRED);
1289
1290   make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1291
1292   add_sym_1 ("fraction", 1, 1, BT_REAL, dr, GFC_STD_F95,
1293              gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1294              x, BT_REAL, dr, REQUIRED);
1295
1296   make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1297
1298   add_sym_2 ("fstat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1299              gfc_check_fstat, NULL, gfc_resolve_fstat,
1300              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1301
1302   make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1303
1304   /* Unix IDs (g77 compatibility)  */
1305   add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di,  GFC_STD_GNU,
1306              NULL, NULL, gfc_resolve_getcwd,
1307              c, BT_CHARACTER, dc, REQUIRED);
1308
1309   make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1310
1311   add_sym_0 ("getgid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1312              NULL, NULL, gfc_resolve_getgid);
1313
1314   make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1315
1316   add_sym_0 ("getpid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1317              NULL, NULL, gfc_resolve_getpid);
1318
1319   make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1320
1321   add_sym_0 ("getuid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1322              NULL, NULL, gfc_resolve_getuid);
1323
1324   make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1325
1326   add_sym_1 ("huge", 0, 1, BT_REAL, dr, GFC_STD_F95,
1327              gfc_check_huge, gfc_simplify_huge, NULL,
1328              x, BT_UNKNOWN, dr, REQUIRED);
1329
1330   make_generic ("huge", GFC_ISYM_NONE, GFC_STD_F95);
1331
1332   add_sym_1 ("iachar", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1333              NULL, gfc_simplify_iachar, NULL,
1334              c, BT_CHARACTER, dc, REQUIRED);
1335
1336   make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1337
1338   add_sym_2 ("iand", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1339              gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1340              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1341
1342   make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1343
1344   add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1345              NULL, NULL, NULL);
1346
1347   make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
1348
1349   add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, GFC_STD_F2003,
1350              NULL, NULL, NULL);
1351
1352   make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
1353                 GFC_STD_F2003);
1354
1355   add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1356              gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1357              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1358
1359   make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
1360
1361   add_sym_3 ("ibits", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1362              gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1363              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
1364              ln, BT_INTEGER, di, REQUIRED);
1365
1366   make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
1367
1368   add_sym_2 ("ibset", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1369              gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1370              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1371
1372   make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
1373
1374   add_sym_1 ("ichar", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1375              NULL, gfc_simplify_ichar, gfc_resolve_ichar,
1376              c, BT_CHARACTER, dc, REQUIRED);
1377
1378   make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
1379
1380   add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1381              gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1382              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1383
1384   make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
1385
1386   add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1387              gfc_check_index, gfc_simplify_index, NULL,
1388              stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
1389              bck, BT_LOGICAL, dl, OPTIONAL);
1390
1391   make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
1392
1393   add_sym_2 ("int", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1394              gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1395              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1396
1397   add_sym_1 ("ifix", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1398              NULL, gfc_simplify_ifix, NULL,
1399              a, BT_REAL, dr, REQUIRED);
1400
1401   add_sym_1 ("idint", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1402              NULL, gfc_simplify_idint, NULL,
1403              a, BT_REAL, dd, REQUIRED);
1404
1405   make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
1406
1407   add_sym_2 ("ior", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1408              gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1409              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1410
1411   make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
1412
1413   /* The following function is for G77 compatibility.  */
1414   add_sym_1 ("irand", 0, 1, BT_INTEGER, 4, GFC_STD_GNU,
1415              gfc_check_irand, NULL, NULL,
1416              i, BT_INTEGER, 4, OPTIONAL);
1417
1418   make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
1419
1420   add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1421              gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1422              i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1423
1424   make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
1425
1426   add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1427              gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1428              i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1429              sz, BT_INTEGER, di, OPTIONAL);
1430
1431   make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
1432
1433   add_sym_1 ("kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1434              gfc_check_kind, gfc_simplify_kind, NULL,
1435              x, BT_REAL, dr, REQUIRED);
1436
1437   make_generic ("kind", GFC_ISYM_NONE, GFC_STD_F95);
1438
1439   add_sym_2 ("lbound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1440              gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1441              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL);
1442
1443   make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
1444
1445   add_sym_1 ("len", 0, 1, BT_INTEGER, di, GFC_STD_F77,
1446              NULL, gfc_simplify_len, gfc_resolve_len,
1447              stg, BT_CHARACTER, dc, REQUIRED);
1448
1449   make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
1450
1451   add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1452              NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1453              stg, BT_CHARACTER, dc, REQUIRED);
1454
1455   make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
1456
1457   add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1458              NULL, gfc_simplify_lge, NULL,
1459              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1460
1461   make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
1462
1463   add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1464              NULL, gfc_simplify_lgt, NULL,
1465              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1466
1467   make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
1468
1469   add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1470              NULL, gfc_simplify_lle, NULL,
1471              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1472
1473   make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
1474
1475   add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1476              NULL, gfc_simplify_llt, NULL,
1477              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1478
1479   make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
1480
1481   add_sym_1 ("log", 1, 1, BT_REAL, dr, GFC_STD_F77,
1482              gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
1483              x, BT_REAL, dr, REQUIRED);
1484
1485   add_sym_1 ("alog", 1, 1, BT_REAL, dr, GFC_STD_F77,
1486              NULL, gfc_simplify_log, gfc_resolve_log,
1487              x, BT_REAL, dr, REQUIRED);
1488
1489   add_sym_1 ("dlog", 1, 1, BT_REAL, dd, GFC_STD_F77,
1490              NULL, gfc_simplify_log, gfc_resolve_log,
1491              x, BT_REAL, dd, REQUIRED);
1492
1493   add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1494              NULL, gfc_simplify_log, gfc_resolve_log,
1495              x, BT_COMPLEX, dz, REQUIRED);
1496
1497   add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd,  GFC_STD_GNU,
1498              NULL, gfc_simplify_log, gfc_resolve_log,
1499              x, BT_COMPLEX, dd, REQUIRED);
1500
1501   make_alias ("cdlog", GFC_STD_GNU);
1502
1503   make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
1504
1505   add_sym_1 ("log10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1506              gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
1507              x, BT_REAL, dr, REQUIRED);
1508
1509   add_sym_1 ("alog10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1510              NULL, gfc_simplify_log10, gfc_resolve_log10,
1511              x, BT_REAL, dr, REQUIRED);
1512
1513   add_sym_1 ("dlog10", 1, 1, BT_REAL, dd, GFC_STD_F77,
1514              NULL, gfc_simplify_log10, gfc_resolve_log10,
1515              x, BT_REAL, dd, REQUIRED);
1516
1517   make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
1518
1519   add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1520              gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1521              l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1522
1523   make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
1524
1525   add_sym_2 ("matmul", 0, 1, BT_REAL, dr, GFC_STD_F95,
1526              gfc_check_matmul, NULL, gfc_resolve_matmul,
1527              ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
1528
1529   make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
1530
1531   /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1532      int(max).  The max function must take at least two arguments.  */
1533
1534   add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1535              gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1536              a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
1537
1538   add_sym_1m ("max0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1539              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1540              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1541
1542   add_sym_1m ("amax0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1543              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1544              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1545
1546   add_sym_1m ("amax1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1547              gfc_check_min_max_real, gfc_simplify_max, NULL,
1548              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1549
1550   add_sym_1m ("max1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1551              gfc_check_min_max_real, gfc_simplify_max, NULL,
1552              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1553
1554   add_sym_1m ("dmax1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1555              gfc_check_min_max_double, gfc_simplify_max, NULL,
1556              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1557
1558   make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
1559
1560   add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1561              gfc_check_x, gfc_simplify_maxexponent, NULL,
1562              x, BT_UNKNOWN, dr, REQUIRED);
1563
1564   make_generic ("maxexponent", GFC_ISYM_NONE, GFC_STD_F95);
1565
1566   add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1567                gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1568                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1569                msk, BT_LOGICAL, dl, OPTIONAL);
1570
1571   make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
1572
1573   add_sym_3red ("maxval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1574                 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1575                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1576                 msk, BT_LOGICAL, dl, OPTIONAL);
1577
1578   make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
1579
1580   add_sym_3 ("merge", 1, 1, BT_REAL, dr, GFC_STD_F95,
1581              gfc_check_merge, NULL, gfc_resolve_merge,
1582              ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
1583              msk, BT_LOGICAL, dl, REQUIRED);
1584
1585   make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
1586
1587   /* Note: amin0 is equivalent to real(min), min1 is equivalent to
1588      int(min).  */
1589
1590   add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1591               gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1592              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1593
1594   add_sym_1m ("min0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1595               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1596              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1597
1598   add_sym_1m ("amin0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1599               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1600              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1601
1602   add_sym_1m ("amin1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1603               gfc_check_min_max_real, gfc_simplify_min, NULL,
1604              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1605
1606   add_sym_1m ("min1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1607               gfc_check_min_max_real, gfc_simplify_min, NULL,
1608              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1609
1610   add_sym_1m ("dmin1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1611               gfc_check_min_max_double, gfc_simplify_min, NULL,
1612              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1613
1614   make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
1615
1616   add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1617              gfc_check_x, gfc_simplify_minexponent, NULL,
1618              x, BT_UNKNOWN, dr, REQUIRED);
1619
1620   make_generic ("minexponent", GFC_ISYM_NONE, GFC_STD_F95);
1621
1622   add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1623                gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1624                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1625                msk, BT_LOGICAL, dl, OPTIONAL);
1626
1627   make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
1628
1629   add_sym_3red ("minval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1630                 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1631                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1632                 msk, BT_LOGICAL, dl, OPTIONAL);
1633
1634   make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
1635
1636   add_sym_2 ("mod", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1637              gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1638              a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
1639
1640   add_sym_2 ("amod", 1, 1, BT_REAL, dr, GFC_STD_F77,
1641              NULL, gfc_simplify_mod, gfc_resolve_mod,
1642              a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
1643
1644   add_sym_2 ("dmod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1645              NULL, gfc_simplify_mod, gfc_resolve_mod,
1646              a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
1647
1648   make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
1649
1650   add_sym_2 ("modulo", 1, 1, BT_REAL, di, GFC_STD_F95,
1651              gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1652              a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
1653
1654   make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
1655
1656   add_sym_2 ("nearest", 1, 1, BT_REAL, dr, GFC_STD_F95,
1657              gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1658              x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
1659
1660   make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
1661
1662   add_sym_2 ("nint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1663              gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1664              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1665
1666   add_sym_1 ("idnint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1667              gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1668              a, BT_REAL, dd, REQUIRED);
1669
1670   make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
1671
1672   add_sym_1 ("not", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1673              gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1674              i, BT_INTEGER, di, REQUIRED);
1675
1676   make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
1677
1678   add_sym_1 ("null", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1679              gfc_check_null, gfc_simplify_null, NULL,
1680              mo, BT_INTEGER, di, OPTIONAL);
1681
1682   make_generic ("null", GFC_ISYM_NONE, GFC_STD_F95);
1683
1684   add_sym_3 ("pack", 0, 1, BT_REAL, dr, GFC_STD_F95,
1685              gfc_check_pack, NULL, gfc_resolve_pack,
1686              ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1687              v, BT_REAL, dr, OPTIONAL);
1688
1689   make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
1690
1691   add_sym_1 ("precision", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1692              gfc_check_precision, gfc_simplify_precision, NULL,
1693              x, BT_UNKNOWN, 0, REQUIRED);
1694
1695   make_generic ("precision", GFC_ISYM_NONE, GFC_STD_F95);
1696
1697   add_sym_1 ("present", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1698              gfc_check_present, NULL, NULL,
1699              a, BT_REAL, dr, REQUIRED);
1700
1701   make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
1702
1703   add_sym_3red ("product", 0, 1, BT_REAL, dr, GFC_STD_F95,
1704                 gfc_check_product_sum, NULL, gfc_resolve_product,
1705                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1706                 msk, BT_LOGICAL, dl, OPTIONAL);
1707
1708   make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
1709
1710   add_sym_1 ("radix", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1711              gfc_check_radix, gfc_simplify_radix, NULL,
1712              x, BT_UNKNOWN, 0, REQUIRED);
1713
1714   make_generic ("radix", GFC_ISYM_NONE, GFC_STD_F95);
1715
1716   /* The following function is for G77 compatibility.  */
1717   add_sym_1 ("rand", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1718              gfc_check_rand, NULL, NULL,
1719              i, BT_INTEGER, 4, OPTIONAL);
1720
1721   /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and ran()
1722      use slightly different shoddy multiplicative congruential PRNG.  */
1723   make_alias ("ran", GFC_STD_GNU);
1724
1725   make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
1726
1727   add_sym_1 ("range", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1728              gfc_check_range, gfc_simplify_range, NULL,
1729              x, BT_REAL, dr, REQUIRED);
1730
1731   make_generic ("range", GFC_ISYM_NONE, GFC_STD_F95);
1732
1733   add_sym_2 ("real", 1, 0, BT_REAL, dr, GFC_STD_F77,
1734              gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1735              a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1736
1737   add_sym_1 ("float", 1, 0, BT_REAL, dr, GFC_STD_F77,
1738              NULL, gfc_simplify_float, NULL,
1739              a, BT_INTEGER, di, REQUIRED);
1740
1741   add_sym_1 ("sngl", 1, 0, BT_REAL, dr, GFC_STD_F77,
1742              NULL, gfc_simplify_sngl, NULL,
1743              a, BT_REAL, dd, REQUIRED);
1744
1745   make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
1746
1747   add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
1748              gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1749              stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
1750
1751   make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
1752
1753   add_sym_4 ("reshape", 0, 1, BT_REAL, dr, GFC_STD_F95,
1754              gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1755              src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
1756              pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
1757
1758   make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
1759
1760   add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1761              gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1762              x, BT_REAL, dr, REQUIRED);
1763
1764   make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
1765
1766   add_sym_2 ("scale", 1, 1, BT_REAL, dr, GFC_STD_F95,
1767              gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1768              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1769
1770   make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
1771
1772   add_sym_3 ("scan", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1773              gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1774              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
1775              bck, BT_LOGICAL, dl, OPTIONAL);
1776
1777   make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
1778
1779   /* Added for G77 compatibility garbage.  */
1780   add_sym_0 ("second", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1781              NULL, NULL, NULL);
1782
1783   make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
1784
1785   add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1786              gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL,
1787              r, BT_INTEGER, di, REQUIRED);
1788
1789   make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
1790
1791   add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1792              gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1793              NULL,
1794              p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
1795
1796   make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
1797
1798   add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr, GFC_STD_F95,
1799              gfc_check_set_exponent, gfc_simplify_set_exponent,
1800              gfc_resolve_set_exponent,
1801              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1802
1803   make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
1804
1805   add_sym_1 ("shape", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1806              gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1807              src, BT_REAL, dr, REQUIRED);
1808
1809   make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
1810
1811   add_sym_2 ("sign", 1, 1, BT_REAL, dr, GFC_STD_F77,
1812              gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1813              a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
1814
1815   add_sym_2 ("isign", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1816              NULL, gfc_simplify_sign, gfc_resolve_sign,
1817              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1818
1819   add_sym_2 ("dsign", 1, 1, BT_REAL, dd, GFC_STD_F77,
1820              NULL, gfc_simplify_sign, gfc_resolve_sign,
1821              a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
1822
1823   make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
1824
1825   add_sym_1 ("sin", 1, 1, BT_REAL, dr, GFC_STD_F77,
1826              gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
1827              x, BT_REAL, dr, REQUIRED);
1828
1829   add_sym_1 ("dsin", 1, 1, BT_REAL, dd, GFC_STD_F77,
1830              NULL, gfc_simplify_sin, gfc_resolve_sin,
1831              x, BT_REAL, dd, REQUIRED);
1832
1833   add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1834              NULL, gfc_simplify_sin, gfc_resolve_sin,
1835              x, BT_COMPLEX, dz, REQUIRED);
1836
1837   add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1838              NULL, gfc_simplify_sin, gfc_resolve_sin,
1839              x, BT_COMPLEX, dd, REQUIRED);
1840
1841   make_alias ("cdsin", GFC_STD_GNU);
1842
1843   make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
1844
1845   add_sym_1 ("sinh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1846              gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh,
1847              x, BT_REAL, dr, REQUIRED);
1848
1849   add_sym_1 ("dsinh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1850              NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1851              x, BT_REAL, dd, REQUIRED);
1852
1853   make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
1854
1855   add_sym_2 ("size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1856              gfc_check_size, gfc_simplify_size, NULL,
1857              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1858
1859   make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
1860
1861   add_sym_1 ("spacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1862              gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
1863              x, BT_REAL, dr, REQUIRED);
1864
1865   make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
1866
1867   add_sym_3 ("spread", 0, 1, BT_REAL, dr, GFC_STD_F95,
1868              gfc_check_spread, NULL, gfc_resolve_spread,
1869              src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
1870              n, BT_INTEGER, di, REQUIRED);
1871
1872   make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
1873
1874   add_sym_1 ("sqrt", 1, 1, BT_REAL, dr, GFC_STD_F77,
1875              gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
1876              x, BT_REAL, dr, REQUIRED);
1877
1878   add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd, GFC_STD_F77,
1879              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1880              x, BT_REAL, dd, REQUIRED);
1881
1882   add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1883              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1884              x, BT_COMPLEX, dz, REQUIRED);
1885
1886   add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1887              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1888              x, BT_COMPLEX, dd, REQUIRED);
1889
1890   make_alias ("cdsqrt", GFC_STD_GNU);
1891
1892   make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
1893
1894   add_sym_2 ("stat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1895              gfc_check_stat, NULL, gfc_resolve_stat,
1896              a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1897
1898   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
1899
1900   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1901                 gfc_check_product_sum, NULL, gfc_resolve_sum,
1902                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1903                 msk, BT_LOGICAL, dl, OPTIONAL);
1904
1905   make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
1906
1907   add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1908              NULL, NULL, NULL,
1909              c, BT_CHARACTER, dc, REQUIRED);
1910
1911   make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
1912
1913   add_sym_1 ("tan", 1, 1, BT_REAL, dr, GFC_STD_F77,
1914              gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
1915              x, BT_REAL, dr, REQUIRED);
1916
1917   add_sym_1 ("dtan", 1, 1, BT_REAL, dd, GFC_STD_F77,
1918              NULL, gfc_simplify_tan, gfc_resolve_tan,
1919              x, BT_REAL, dd, REQUIRED);
1920
1921   make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
1922
1923   add_sym_1 ("tanh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1924              gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
1925              x, BT_REAL, dr, REQUIRED);
1926
1927   add_sym_1 ("dtanh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1928              NULL, gfc_simplify_tanh, gfc_resolve_tanh,
1929              x, BT_REAL, dd, REQUIRED);
1930
1931   make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
1932
1933   add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95,
1934              gfc_check_x, gfc_simplify_tiny, NULL,
1935              x, BT_REAL, dr, REQUIRED);
1936
1937   make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95);
1938
1939   add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95,
1940              gfc_check_transfer, NULL, gfc_resolve_transfer,
1941              src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
1942              sz, BT_INTEGER, di, OPTIONAL);
1943
1944   make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
1945
1946   add_sym_1 ("transpose", 0, 1, BT_REAL, dr, GFC_STD_F95,
1947              gfc_check_transpose, NULL, gfc_resolve_transpose,
1948              m, BT_REAL, dr, REQUIRED);
1949
1950   make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
1951
1952   add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
1953              gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
1954              stg, BT_CHARACTER, dc, REQUIRED);
1955
1956   make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
1957
1958   add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1959              gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
1960              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1961
1962   make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
1963
1964   /* g77 compatibility for UMASK.  */
1965   add_sym_1 ("umask", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1966              gfc_check_umask, NULL, gfc_resolve_umask,
1967              a, BT_INTEGER, di, REQUIRED);
1968
1969   make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
1970
1971   /* g77 compatibility for UNLINK.  */
1972   add_sym_1 ("unlink", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1973              gfc_check_unlink, NULL, gfc_resolve_unlink,
1974              a, BT_CHARACTER, dc, REQUIRED);
1975
1976   make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
1977
1978   add_sym_3 ("unpack", 0, 1, BT_REAL, dr, GFC_STD_F95,
1979              gfc_check_unpack, NULL, gfc_resolve_unpack,
1980              v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1981              f, BT_REAL, dr, REQUIRED);
1982
1983   make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
1984
1985   add_sym_3 ("verify", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1986              gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
1987              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
1988              bck, BT_LOGICAL, dl, OPTIONAL);
1989
1990   make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
1991 }
1992
1993
1994 /* Add intrinsic subroutines.  */
1995
1996 static void
1997 add_subroutines (void)
1998 {
1999   /* Argument names as in the standard (to be used as argument keywords).  */
2000   const char
2001     *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2002     *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2003     *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2004     *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2005     *com = "command", *length = "length", *st = "status",
2006     *val = "value", *num = "number", *name = "name",
2007     *trim_name = "trim_name", *ut = "unit";
2008
2009   int di, dr, dc, dl;
2010
2011   di = gfc_default_integer_kind;
2012   dr = gfc_default_real_kind;
2013   dc = gfc_default_character_kind;
2014   dl = gfc_default_logical_kind;
2015
2016   add_sym_0s ("abort", 1, GFC_STD_GNU, NULL);
2017
2018   add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2019               gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2020               tm, BT_REAL, dr, REQUIRED);
2021
2022   /* More G77 compatibility garbage.  */
2023   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2024               gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2025               tm, BT_REAL, dr, REQUIRED);
2026
2027   add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2028               gfc_check_date_and_time, NULL, NULL,
2029               dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2030               zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2031
2032   /* More G77 compatibility garbage.  */
2033   add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2034              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2035               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2036
2037   add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2038              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2039               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2040
2041   add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2042           gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2043               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2044
2045   add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2046               NULL, NULL, NULL,
2047               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2048
2049   add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2050               NULL, NULL, gfc_resolve_getarg,
2051               c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2052
2053   /* F2003 commandline routines.  */
2054
2055   add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2056               NULL, NULL, gfc_resolve_get_command,
2057               com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
2058               st, BT_INTEGER, di, OPTIONAL);
2059
2060   add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2061               NULL, NULL, gfc_resolve_get_command_argument,
2062               num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2063               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2064
2065   /* F2003 subroutine to get environment variables.  */
2066
2067   add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2068              NULL, NULL, gfc_resolve_get_environment_variable,
2069               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2070               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2071               trim_name, BT_LOGICAL, dl, OPTIONAL);
2072
2073   add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2074               gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2075               f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2076               ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2077               tp, BT_INTEGER, di, REQUIRED);
2078
2079   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2080               gfc_check_random_number, NULL, gfc_resolve_random_number,
2081               h, BT_REAL, dr, REQUIRED);
2082
2083   add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2084              gfc_check_random_seed, NULL, NULL,
2085               sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2086               gt, BT_INTEGER, di, OPTIONAL);
2087
2088   /* More G77 compatibility garbage.  */
2089   add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU,
2090              gfc_check_srand, NULL, gfc_resolve_srand,
2091               c, BT_INTEGER, 4, REQUIRED);
2092
2093   add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2094              gfc_check_exit, NULL, gfc_resolve_exit,
2095               c, BT_INTEGER, di, OPTIONAL);
2096
2097   add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2098               gfc_check_flush, NULL, gfc_resolve_flush,
2099               c, BT_INTEGER, di, OPTIONAL);
2100
2101   add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2102               gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2103               ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2104               st, BT_INTEGER, di, OPTIONAL);
2105
2106   add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2107               gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2108               name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2109               st, BT_INTEGER, di, OPTIONAL);
2110
2111   add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2112               NULL, NULL, gfc_resolve_system_sub,
2113               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2114
2115   add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2116              gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2117               c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2118               cm, BT_INTEGER, di, OPTIONAL);
2119
2120   add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2121           gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2122               val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2123
2124   add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2125           gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2126               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2127
2128 }
2129
2130
2131 /* Add a function to the list of conversion symbols.  */
2132
2133 static void
2134 add_conv (bt from_type, int from_kind, bt to_type, int to_kind,
2135           gfc_expr * (*simplify) (gfc_expr *, bt, int))
2136 {
2137
2138   gfc_typespec from, to;
2139   gfc_intrinsic_sym *sym;
2140
2141   if (sizing == SZ_CONVS)
2142     {
2143       nconv++;
2144       return;
2145     }
2146
2147   gfc_clear_ts (&from);
2148   from.type = from_type;
2149   from.kind = from_kind;
2150
2151   gfc_clear_ts (&to);
2152   to.type = to_type;
2153   to.kind = to_kind;
2154
2155   sym = conversion + nconv;
2156
2157   sym->name =  conv_name (&from, &to);
2158   sym->lib_name = sym->name;
2159   sym->simplify.cc = simplify;
2160   sym->elemental = 1;
2161   sym->ts = to;
2162   sym->generic_id = GFC_ISYM_CONVERSION;
2163
2164   nconv++;
2165 }
2166
2167
2168 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2169    functions by looping over the kind tables.  */
2170
2171 static void
2172 add_conversions (void)
2173 {
2174   int i, j;
2175
2176   /* Integer-Integer conversions.  */
2177   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2178     for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2179       {
2180         if (i == j)
2181           continue;
2182
2183         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2184                   BT_INTEGER, gfc_integer_kinds[j].kind, gfc_convert_constant);
2185       }
2186
2187   /* Integer-Real/Complex conversions.  */
2188   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2189     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2190       {
2191         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2192                   BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
2193
2194         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2195                   BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
2196
2197         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2198                   BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2199
2200         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2201                   BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
2202       }
2203
2204   /* Real/Complex - Real/Complex conversions.  */
2205   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2206     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2207       {
2208         if (i != j)
2209           {
2210             add_conv (BT_REAL, gfc_real_kinds[i].kind,
2211                       BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
2212
2213             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2214                       BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2215           }
2216
2217         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2218                   BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2219
2220         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2221                   BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
2222       }
2223
2224   /* Logical/Logical kind conversion.  */
2225   for (i = 0; gfc_logical_kinds[i].kind; i++)
2226     for (j = 0; gfc_logical_kinds[j].kind; j++)
2227       {
2228         if (i == j)
2229           continue;
2230
2231         add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2232                   BT_LOGICAL, gfc_logical_kinds[j].kind, gfc_convert_constant);
2233       }
2234 }
2235
2236
2237 /* Initialize the table of intrinsics.  */
2238 void
2239 gfc_intrinsic_init_1 (void)
2240 {
2241   int i;
2242
2243   nargs = nfunc = nsub = nconv = 0;
2244
2245   /* Create a namespace to hold the resolved intrinsic symbols.  */
2246   gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2247
2248   sizing = SZ_FUNCS;
2249   add_functions ();
2250   sizing = SZ_SUBS;
2251   add_subroutines ();
2252   sizing = SZ_CONVS;
2253   add_conversions ();
2254
2255   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2256                           + sizeof (gfc_intrinsic_arg) * nargs);
2257
2258   next_sym = functions;
2259   subroutines = functions + nfunc;
2260
2261   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2262
2263   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2264
2265   sizing = SZ_NOTHING;
2266   nconv = 0;
2267
2268   add_functions ();
2269   add_subroutines ();
2270   add_conversions ();
2271
2272   /* Set the pure flag.  All intrinsic functions are pure, and
2273      intrinsic subroutines are pure if they are elemental.  */
2274
2275   for (i = 0; i < nfunc; i++)
2276     functions[i].pure = 1;
2277
2278   for (i = 0; i < nsub; i++)
2279     subroutines[i].pure = subroutines[i].elemental;
2280 }
2281
2282
2283 void
2284 gfc_intrinsic_done_1 (void)
2285 {
2286   gfc_free (functions);
2287   gfc_free (conversion);
2288   gfc_free_namespace (gfc_intrinsic_namespace);
2289 }
2290
2291
2292 /******** Subroutines to check intrinsic interfaces ***********/
2293
2294 /* Given a formal argument list, remove any NULL arguments that may
2295    have been left behind by a sort against some formal argument list.  */
2296
2297 static void
2298 remove_nullargs (gfc_actual_arglist ** ap)
2299 {
2300   gfc_actual_arglist *head, *tail, *next;
2301
2302   tail = NULL;
2303
2304   for (head = *ap; head; head = next)
2305     {
2306       next = head->next;
2307
2308       if (head->expr == NULL)
2309         {
2310           head->next = NULL;
2311           gfc_free_actual_arglist (head);
2312         }
2313       else
2314         {
2315           if (tail == NULL)
2316             *ap = head;
2317           else
2318             tail->next = head;
2319
2320           tail = head;
2321           tail->next = NULL;
2322         }
2323     }
2324
2325   if (tail == NULL)
2326     *ap = NULL;
2327 }
2328
2329
2330 /* Given an actual arglist and a formal arglist, sort the actual
2331    arglist so that its arguments are in a one-to-one correspondence
2332    with the format arglist.  Arguments that are not present are given
2333    a blank gfc_actual_arglist structure.  If something is obviously
2334    wrong (say, a missing required argument) we abort sorting and
2335    return FAILURE.  */
2336
2337 static try
2338 sort_actual (const char *name, gfc_actual_arglist ** ap,
2339              gfc_intrinsic_arg * formal, locus * where)
2340 {
2341
2342   gfc_actual_arglist *actual, *a;
2343   gfc_intrinsic_arg *f;
2344
2345   remove_nullargs (ap);
2346   actual = *ap;
2347
2348   for (f = formal; f; f = f->next)
2349     f->actual = NULL;
2350
2351   f = formal;
2352   a = actual;
2353
2354   if (f == NULL && a == NULL)   /* No arguments */
2355     return SUCCESS;
2356
2357   for (;;)
2358     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2359       if (f == NULL)
2360         break;
2361       if (a == NULL)
2362         goto optional;
2363
2364       if (a->name != NULL)
2365         goto keywords;
2366
2367       f->actual = a;
2368
2369       f = f->next;
2370       a = a->next;
2371     }
2372
2373   if (a == NULL)
2374     goto do_sort;
2375
2376   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2377   return FAILURE;
2378
2379 keywords:
2380   /* Associate the remaining actual arguments, all of which have
2381      to be keyword arguments.  */
2382   for (; a; a = a->next)
2383     {
2384       for (f = formal; f; f = f->next)
2385         if (strcmp (a->name, f->name) == 0)
2386           break;
2387
2388       if (f == NULL)
2389         {
2390           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2391                      a->name, name, where);
2392           return FAILURE;
2393         }
2394
2395       if (f->actual != NULL)
2396         {
2397           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2398                      f->name, name, where);
2399           return FAILURE;
2400         }
2401
2402       f->actual = a;
2403     }
2404
2405 optional:
2406   /* At this point, all unmatched formal args must be optional.  */
2407   for (f = formal; f; f = f->next)
2408     {
2409       if (f->actual == NULL && f->optional == 0)
2410         {
2411           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2412                      f->name, name, where);
2413           return FAILURE;
2414         }
2415     }
2416
2417 do_sort:
2418   /* Using the formal argument list, string the actual argument list
2419      together in a way that corresponds with the formal list.  */
2420   actual = NULL;
2421
2422   for (f = formal; f; f = f->next)
2423     {
2424       if (f->actual == NULL)
2425         {
2426           a = gfc_get_actual_arglist ();
2427           a->missing_arg_type = f->ts.type;
2428         }
2429       else
2430         a = f->actual;
2431
2432       if (actual == NULL)
2433         *ap = a;
2434       else
2435         actual->next = a;
2436
2437       actual = a;
2438     }
2439   actual->next = NULL;          /* End the sorted argument list.  */
2440
2441   return SUCCESS;
2442 }
2443
2444
2445 /* Compare an actual argument list with an intrinsic's formal argument
2446    list.  The lists are checked for agreement of type.  We don't check
2447    for arrayness here.  */
2448
2449 static try
2450 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2451                int error_flag)
2452 {
2453   gfc_actual_arglist *actual;
2454   gfc_intrinsic_arg *formal;
2455   int i;
2456
2457   formal = sym->formal;
2458   actual = *ap;
2459
2460   i = 0;
2461   for (; formal; formal = formal->next, actual = actual->next, i++)
2462     {
2463       if (actual->expr == NULL)
2464         continue;
2465
2466       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2467         {
2468           if (error_flag)
2469             gfc_error
2470               ("Type of argument '%s' in call to '%s' at %L should be "
2471                "%s, not %s", gfc_current_intrinsic_arg[i],
2472                gfc_current_intrinsic, &actual->expr->where,
2473                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2474           return FAILURE;
2475         }
2476     }
2477
2478   return SUCCESS;
2479 }
2480
2481
2482 /* Given a pointer to an intrinsic symbol and an expression node that
2483    represent the function call to that subroutine, figure out the type
2484    of the result.  This may involve calling a resolution subroutine.  */
2485
2486 static void
2487 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2488 {
2489   gfc_expr *a1, *a2, *a3, *a4, *a5;
2490   gfc_actual_arglist *arg;
2491
2492   if (specific->resolve.f1 == NULL)
2493     {
2494       if (e->value.function.name == NULL)
2495         e->value.function.name = specific->lib_name;
2496
2497       if (e->ts.type == BT_UNKNOWN)
2498         e->ts = specific->ts;
2499       return;
2500     }
2501
2502   arg = e->value.function.actual;
2503
2504   /* Special case hacks for MIN and MAX.  */
2505   if (specific->resolve.f1m == gfc_resolve_max
2506       || specific->resolve.f1m == gfc_resolve_min)
2507     {
2508       (*specific->resolve.f1m) (e, arg);
2509       return;
2510     }
2511
2512   if (arg == NULL)
2513     {
2514       (*specific->resolve.f0) (e);
2515       return;
2516     }
2517
2518   a1 = arg->expr;
2519   arg = arg->next;
2520
2521   if (arg == NULL)
2522     {
2523       (*specific->resolve.f1) (e, a1);
2524       return;
2525     }
2526
2527   a2 = arg->expr;
2528   arg = arg->next;
2529
2530   if (arg == NULL)
2531     {
2532       (*specific->resolve.f2) (e, a1, a2);
2533       return;
2534     }
2535
2536   a3 = arg->expr;
2537   arg = arg->next;
2538
2539   if (arg == NULL)
2540     {
2541       (*specific->resolve.f3) (e, a1, a2, a3);
2542       return;
2543     }
2544
2545   a4 = arg->expr;
2546   arg = arg->next;
2547
2548   if (arg == NULL)
2549     {
2550       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2551       return;
2552     }
2553
2554   a5 = arg->expr;
2555   arg = arg->next;
2556
2557   if (arg == NULL)
2558     {
2559       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2560       return;
2561     }
2562
2563   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2564 }
2565
2566
2567 /* Given an intrinsic symbol node and an expression node, call the
2568    simplification function (if there is one), perhaps replacing the
2569    expression with something simpler.  We return FAILURE on an error
2570    of the simplification, SUCCESS if the simplification worked, even
2571    if nothing has changed in the expression itself.  */
2572
2573 static try
2574 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2575 {
2576   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2577   gfc_actual_arglist *arg;
2578
2579   /* Max and min require special handling due to the variable number
2580      of args.  */
2581   if (specific->simplify.f1 == gfc_simplify_min)
2582     {
2583       result = gfc_simplify_min (e);
2584       goto finish;
2585     }
2586
2587   if (specific->simplify.f1 == gfc_simplify_max)
2588     {
2589       result = gfc_simplify_max (e);
2590       goto finish;
2591     }
2592
2593   if (specific->simplify.f1 == NULL)
2594     {
2595       result = NULL;
2596       goto finish;
2597     }
2598
2599   arg = e->value.function.actual;
2600
2601   if (arg == NULL)
2602     {
2603       result = (*specific->simplify.f0) ();
2604       goto finish;
2605     }
2606
2607   a1 = arg->expr;
2608   arg = arg->next;
2609
2610   if (specific->simplify.cc == gfc_convert_constant)
2611     {
2612       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2613       goto finish;
2614     }
2615
2616   /* TODO: Warn if -pedantic and initialization expression and arg
2617      types not integer or character */
2618
2619   if (arg == NULL)
2620     result = (*specific->simplify.f1) (a1);
2621   else
2622     {
2623       a2 = arg->expr;
2624       arg = arg->next;
2625
2626       if (arg == NULL)
2627         result = (*specific->simplify.f2) (a1, a2);
2628       else
2629         {
2630           a3 = arg->expr;
2631           arg = arg->next;
2632
2633           if (arg == NULL)
2634             result = (*specific->simplify.f3) (a1, a2, a3);
2635           else
2636             {
2637               a4 = arg->expr;
2638               arg = arg->next;
2639
2640               if (arg == NULL)
2641                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2642               else
2643                 {
2644                   a5 = arg->expr;
2645                   arg = arg->next;
2646
2647                   if (arg == NULL)
2648                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2649                   else
2650                     gfc_internal_error
2651                       ("do_simplify(): Too many args for intrinsic");
2652                 }
2653             }
2654         }
2655     }
2656
2657 finish:
2658   if (result == &gfc_bad_expr)
2659     return FAILURE;
2660
2661   if (result == NULL)
2662     resolve_intrinsic (specific, e);    /* Must call at run-time */
2663   else
2664     {
2665       result->where = e->where;
2666       gfc_replace_expr (e, result);
2667     }
2668
2669   return SUCCESS;
2670 }
2671
2672
2673 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2674    error messages.  This subroutine returns FAILURE if a subroutine
2675    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2676    list cannot match any intrinsic.  */
2677
2678 static void
2679 init_arglist (gfc_intrinsic_sym * isym)
2680 {
2681   gfc_intrinsic_arg *formal;
2682   int i;
2683
2684   gfc_current_intrinsic = isym->name;
2685
2686   i = 0;
2687   for (formal = isym->formal; formal; formal = formal->next)
2688     {
2689       if (i >= MAX_INTRINSIC_ARGS)
2690         gfc_internal_error ("init_arglist(): too many arguments");
2691       gfc_current_intrinsic_arg[i++] = formal->name;
2692     }
2693 }
2694
2695
2696 /* Given a pointer to an intrinsic symbol and an expression consisting
2697    of a function call, see if the function call is consistent with the
2698    intrinsic's formal argument list.  Return SUCCESS if the expression
2699    and intrinsic match, FAILURE otherwise.  */
2700
2701 static try
2702 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2703 {
2704   gfc_actual_arglist *arg, **ap;
2705   int r;
2706   try t;
2707
2708   ap = &expr->value.function.actual;
2709
2710   init_arglist (specific);
2711
2712   /* Don't attempt to sort the argument list for min or max.  */
2713   if (specific->check.f1m == gfc_check_min_max
2714       || specific->check.f1m == gfc_check_min_max_integer
2715       || specific->check.f1m == gfc_check_min_max_real
2716       || specific->check.f1m == gfc_check_min_max_double)
2717     return (*specific->check.f1m) (*ap);
2718
2719   if (sort_actual (specific->name, ap, specific->formal,
2720                    &expr->where) == FAILURE)
2721     return FAILURE;
2722
2723   if (specific->check.f3ml == gfc_check_minloc_maxloc)
2724     /* This is special because we might have to reorder the argument
2725        list.  */
2726     t = gfc_check_minloc_maxloc (*ap);
2727   else if (specific->check.f3red == gfc_check_minval_maxval)
2728     /* This is also special because we also might have to reorder the
2729        argument list.  */
2730     t = gfc_check_minval_maxval (*ap);
2731   else if (specific->check.f3red == gfc_check_product_sum)
2732     /* Same here. The difference to the previous case is that we allow a
2733        general numeric type.  */
2734     t = gfc_check_product_sum (*ap);
2735   else
2736      {
2737        if (specific->check.f1 == NULL)
2738          {
2739            t = check_arglist (ap, specific, error_flag);
2740            if (t == SUCCESS)
2741              expr->ts = specific->ts;
2742          }
2743        else
2744          t = do_check (specific, *ap);
2745      }
2746
2747   /* Check ranks for elemental intrinsics.  */
2748   if (t == SUCCESS && specific->elemental)
2749     {
2750       r = 0;
2751       for (arg = expr->value.function.actual; arg; arg = arg->next)
2752         {
2753           if (arg->expr == NULL || arg->expr->rank == 0)
2754             continue;
2755           if (r == 0)
2756             {
2757               r = arg->expr->rank;
2758               continue;
2759             }
2760
2761           if (arg->expr->rank != r)
2762             {
2763               gfc_error
2764                 ("Ranks of arguments to elemental intrinsic '%s' differ "
2765                  "at %L", specific->name, &arg->expr->where);
2766               return FAILURE;
2767             }
2768         }
2769     }
2770
2771   if (t == FAILURE)
2772     remove_nullargs (ap);
2773
2774   return t;
2775 }
2776
2777
2778 /* See if an intrinsic is one of the intrinsics we evaluate
2779    as an extension.  */
2780
2781 static int
2782 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2783 {
2784   /* FIXME: This should be moved into the intrinsic definitions.  */
2785   static const char * const init_expr_extensions[] = {
2786     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2787     "precision", "present", "radix", "range", "selected_real_kind",
2788     "tiny", NULL
2789   };
2790
2791   int i;
2792
2793   for (i = 0; init_expr_extensions[i]; i++)
2794     if (strcmp (init_expr_extensions[i], isym->name) == 0)
2795       return 0;
2796
2797   return 1;
2798 }
2799
2800
2801 /* Check whether an intrinsic belongs to whatever standard the user
2802    has chosen.  */
2803
2804 static void
2805 check_intrinsic_standard (const char *name, int standard, locus * where)
2806 {
2807   if (!gfc_option.warn_nonstd_intrinsics)
2808     return;
2809
2810   gfc_notify_std (standard, "Intrinsic '%s' at %L is not included"
2811                   "in the selected standard", name, where);
2812 }
2813
2814
2815 /* See if a function call corresponds to an intrinsic function call.
2816    We return:
2817
2818     MATCH_YES    if the call corresponds to an intrinsic, simplification
2819                  is done if possible.
2820
2821     MATCH_NO     if the call does not correspond to an intrinsic
2822
2823     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
2824                  error during the simplification process.
2825
2826    The error_flag parameter enables an error reporting.  */
2827
2828 match
2829 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
2830 {
2831   gfc_intrinsic_sym *isym, *specific;
2832   gfc_actual_arglist *actual;
2833   const char *name;
2834   int flag;
2835
2836   if (expr->value.function.isym != NULL)
2837     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
2838       ? MATCH_ERROR : MATCH_YES;
2839
2840   gfc_suppress_error = !error_flag;
2841   flag = 0;
2842
2843   for (actual = expr->value.function.actual; actual; actual = actual->next)
2844     if (actual->expr != NULL)
2845       flag |= (actual->expr->ts.type != BT_INTEGER
2846                && actual->expr->ts.type != BT_CHARACTER);
2847
2848   name = expr->symtree->n.sym->name;
2849
2850   isym = specific = gfc_find_function (name);
2851   if (isym == NULL)
2852     {
2853       gfc_suppress_error = 0;
2854       return MATCH_NO;
2855     }
2856
2857   gfc_current_intrinsic_where = &expr->where;
2858
2859   /* Bypass the generic list for min and max.  */
2860   if (isym->check.f1m == gfc_check_min_max)
2861     {
2862       init_arglist (isym);
2863
2864       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
2865         goto got_specific;
2866
2867       gfc_suppress_error = 0;
2868       return MATCH_NO;
2869     }
2870
2871   /* If the function is generic, check all of its specific
2872      incarnations.  If the generic name is also a specific, we check
2873      that name last, so that any error message will correspond to the
2874      specific.  */
2875   gfc_suppress_error = 1;
2876
2877   if (isym->generic)
2878     {
2879       for (specific = isym->specific_head; specific;
2880            specific = specific->next)
2881         {
2882           if (specific == isym)
2883             continue;
2884           if (check_specific (specific, expr, 0) == SUCCESS)
2885             goto got_specific;
2886         }
2887     }
2888
2889   gfc_suppress_error = !error_flag;
2890
2891   if (check_specific (isym, expr, error_flag) == FAILURE)
2892     {
2893       gfc_suppress_error = 0;
2894       return MATCH_NO;
2895     }
2896
2897   specific = isym;
2898
2899 got_specific:
2900   expr->value.function.isym = specific;
2901   gfc_intrinsic_symbol (expr->symtree->n.sym);
2902
2903   if (do_simplify (specific, expr) == FAILURE)
2904     {
2905       gfc_suppress_error = 0;
2906       return MATCH_ERROR;
2907     }
2908
2909   /* TODO: We should probably only allow elemental functions here.  */
2910   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
2911
2912   gfc_suppress_error = 0;
2913   if (pedantic && gfc_init_expr
2914       && flag && gfc_init_expr_extensions (specific))
2915     {
2916       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
2917             "nonstandard initialization expression at %L", &expr->where)
2918           == FAILURE)
2919         {
2920           return MATCH_ERROR;
2921         }
2922     }
2923
2924   check_intrinsic_standard (name, isym->standard, &expr->where);
2925
2926   return MATCH_YES;
2927 }
2928
2929
2930 /* See if a CALL statement corresponds to an intrinsic subroutine.
2931    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
2932    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
2933    correspond).  */
2934
2935 match
2936 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
2937 {
2938   gfc_intrinsic_sym *isym;
2939   const char *name;
2940
2941   name = c->symtree->n.sym->name;
2942
2943   isym = find_subroutine (name);
2944   if (isym == NULL)
2945     return MATCH_NO;
2946
2947   gfc_suppress_error = !error_flag;
2948
2949   init_arglist (isym);
2950
2951   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
2952     goto fail;
2953
2954   if (isym->check.f1 != NULL)
2955     {
2956       if (do_check (isym, c->ext.actual) == FAILURE)
2957         goto fail;
2958     }
2959   else
2960     {
2961       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
2962         goto fail;
2963     }
2964
2965   /* The subroutine corresponds to an intrinsic.  Allow errors to be
2966      seen at this point.  */
2967   gfc_suppress_error = 0;
2968
2969   if (isym->resolve.s1 != NULL)
2970     isym->resolve.s1 (c);
2971   else
2972     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
2973
2974   if (gfc_pure (NULL) && !isym->elemental)
2975     {
2976       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
2977                  &c->loc);
2978       return MATCH_ERROR;
2979     }
2980
2981   check_intrinsic_standard (name, isym->standard, &c->loc);
2982
2983   return MATCH_YES;
2984
2985 fail:
2986   gfc_suppress_error = 0;
2987   return MATCH_NO;
2988 }
2989
2990
2991 /* Call gfc_convert_type() with warning enabled.  */
2992
2993 try
2994 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
2995 {
2996   return gfc_convert_type_warn (expr, ts, eflag, 1);
2997 }
2998
2999
3000 /* Try to convert an expression (in place) from one type to another.
3001    'eflag' controls the behavior on error.
3002
3003    The possible values are:
3004
3005      1 Generate a gfc_error()
3006      2 Generate a gfc_internal_error().
3007
3008    'wflag' controls the warning related to conversion.  */
3009
3010 try
3011 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3012                        int wflag)
3013 {
3014   gfc_intrinsic_sym *sym;
3015   gfc_typespec from_ts;
3016   locus old_where;
3017   gfc_expr *new;
3018   int rank;
3019   mpz_t *shape;
3020
3021   from_ts = expr->ts;           /* expr->ts gets clobbered */
3022
3023   if (ts->type == BT_UNKNOWN)
3024     goto bad;
3025
3026   /* NULL and zero size arrays get their type here.  */
3027   if (expr->expr_type == EXPR_NULL
3028       || (expr->expr_type == EXPR_ARRAY
3029           && expr->value.constructor == NULL))
3030     {
3031       /* Sometimes the RHS acquire the type.  */
3032       expr->ts = *ts;
3033       return SUCCESS;
3034     }
3035
3036   if (expr->ts.type == BT_UNKNOWN)
3037     goto bad;
3038
3039   if (expr->ts.type == BT_DERIVED
3040       && ts->type == BT_DERIVED
3041       && gfc_compare_types (&expr->ts, ts))
3042     return SUCCESS;
3043
3044   sym = find_conv (&expr->ts, ts);
3045   if (sym == NULL)
3046     goto bad;
3047
3048   /* At this point, a conversion is necessary. A warning may be needed.  */
3049   if (wflag && gfc_option.warn_conversion)
3050     gfc_warning_now ("Conversion from %s to %s at %L",
3051                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3052
3053   /* Insert a pre-resolved function call to the right function.  */
3054   old_where = expr->where;
3055   rank = expr->rank;
3056   shape = expr->shape;
3057
3058   new = gfc_get_expr ();
3059   *new = *expr;
3060
3061   new = gfc_build_conversion (new);
3062   new->value.function.name = sym->lib_name;
3063   new->value.function.isym = sym;
3064   new->where = old_where;
3065   new->rank = rank;
3066   new->shape = gfc_copy_shape (shape, rank);
3067
3068   *expr = *new;
3069
3070   gfc_free (new);
3071   expr->ts = *ts;
3072
3073   if (gfc_is_constant_expr (expr->value.function.actual->expr)
3074       && do_simplify (sym, expr) == FAILURE)
3075     {
3076
3077       if (eflag == 2)
3078         goto bad;
3079       return FAILURE;           /* Error already generated in do_simplify() */
3080     }
3081
3082   return SUCCESS;
3083
3084 bad:
3085   if (eflag == 1)
3086     {
3087       gfc_error ("Can't convert %s to %s at %L",
3088                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3089       return FAILURE;
3090     }
3091
3092   gfc_internal_error ("Can't convert %s to %s at %L",
3093                       gfc_typename (&from_ts), gfc_typename (ts),
3094                       &expr->where);
3095   /* Not reached */
3096 }