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