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";
 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_1 ("achar", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
 920              gfc_check_achar, gfc_simplify_achar, NULL,
 921              i, BT_INTEGER, di, REQUIRED);
 922
 923   make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
 924
 925   add_sym_1 ("acos", 1, 1, BT_REAL, dr, GFC_STD_F77,
 926              gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos,
 927              x, BT_REAL, dr, REQUIRED);
 928
 929   add_sym_1 ("dacos", 1, 1, BT_REAL, dd, GFC_STD_F77,
 930              NULL, gfc_simplify_acos, gfc_resolve_acos,
 931              x, BT_REAL, dd, REQUIRED);
 932
 933   make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
 934
 935   add_sym_1 ("acosh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
 936              gfc_check_fn_r, gfc_simplify_acosh, gfc_resolve_acosh,
 937              x, BT_REAL, dr, REQUIRED);
 938
 939   add_sym_1 ("dacosh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
 940              NULL, gfc_simplify_acosh, gfc_resolve_acosh,
 941              x, BT_REAL, dd, REQUIRED);
 942
 943   make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_GNU);
 944
 945   add_sym_1 ("adjustl", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
 946              NULL, gfc_simplify_adjustl, NULL,
 947              stg, BT_CHARACTER, dc, REQUIRED);
 948
 949   make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
 950
 951   add_sym_1 ("adjustr", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
 952              NULL, gfc_simplify_adjustr, NULL,
 953              stg, BT_CHARACTER, dc, REQUIRED);
 954
 955   make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
 956
 957   add_sym_1 ("aimag", 1, 1, BT_REAL, dr, GFC_STD_F77,
 958              gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
 959              z, BT_COMPLEX, dz, REQUIRED);
 960
 961   make_alias ("imag", GFC_STD_GNU);
 962   make_alias ("imagpart", GFC_STD_GNU);
 963
 964   add_sym_1 ("dimag", 1, 1, BT_REAL, dd, GFC_STD_GNU,
 965              NULL, gfc_simplify_aimag, gfc_resolve_aimag,
 966              z, BT_COMPLEX, dd, REQUIRED);
 967
 968
 969   make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
 970
 971   add_sym_2 ("aint", 1, 1, BT_REAL, dr, GFC_STD_F77,
 972              gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
 973              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 974
 975   add_sym_1 ("dint", 1, 1, BT_REAL, dd, GFC_STD_F77,
 976              NULL, gfc_simplify_dint, gfc_resolve_dint,
 977              a, BT_REAL, dd, REQUIRED);
 978
 979   make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
 980
 981   add_sym_2 ("all", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
 982              gfc_check_all_any, NULL, gfc_resolve_all,
 983              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
 984
 985   make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
 986
 987   add_sym_1 ("allocated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
 988              gfc_check_allocated, NULL, NULL,
 989              ar, BT_UNKNOWN, 0, REQUIRED);
 990
 991   make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
 992
 993   add_sym_2 ("anint", 1, 1, BT_REAL, dr, GFC_STD_F77,
 994              gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
 995              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
 996
 997   add_sym_1 ("dnint", 1, 1, BT_REAL, dd, GFC_STD_F77,
 998              NULL, gfc_simplify_dnint, gfc_resolve_dnint,
 999              a, BT_REAL, dd, REQUIRED);
1000
1001   make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
1002
1003   add_sym_2 ("any", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1004              gfc_check_all_any, NULL, gfc_resolve_any,
1005              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1006
1007   make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
1008
1009   add_sym_1 ("asin", 1, 1, BT_REAL, dr, GFC_STD_F77,
1010              gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin,
1011              x, BT_REAL, dr, REQUIRED);
1012
1013   add_sym_1 ("dasin", 1, 1, BT_REAL, dd, GFC_STD_F77,
1014              NULL, gfc_simplify_asin, gfc_resolve_asin,
1015              x, BT_REAL, dd, REQUIRED);
1016
1017   make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
1018
1019   add_sym_1 ("asinh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
1020              gfc_check_fn_r, gfc_simplify_asinh, gfc_resolve_asinh,
1021              x, BT_REAL, dr, REQUIRED);
1022
1023   add_sym_1 ("dasinh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
1024              NULL, gfc_simplify_asinh, gfc_resolve_asinh,
1025              x, BT_REAL, dd, REQUIRED);
1026
1027   make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_GNU);
1028
1029   add_sym_2 ("associated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1030              gfc_check_associated, NULL, NULL,
1031              pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
1032
1033   make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
1034
1035   add_sym_1 ("atan", 1, 1, BT_REAL, dr, GFC_STD_F77,
1036              gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan,
1037              x, BT_REAL, dr, REQUIRED);
1038
1039   add_sym_1 ("datan", 1, 1, BT_REAL, dd, GFC_STD_F77,
1040              NULL, gfc_simplify_atan, gfc_resolve_atan,
1041              x, BT_REAL, dd, REQUIRED);
1042
1043   make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
1044
1045   add_sym_1 ("atanh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
1046              gfc_check_fn_r, gfc_simplify_atanh, gfc_resolve_atanh,
1047              x, BT_REAL, dr, REQUIRED);
1048
1049   add_sym_1 ("datanh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
1050              NULL, gfc_simplify_atanh, gfc_resolve_atanh,
1051              x, BT_REAL, dd, REQUIRED);
1052
1053   make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_GNU);
1054
1055   add_sym_2 ("atan2", 1, 1, BT_REAL, dr, GFC_STD_F77,
1056              gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
1057              y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
1058
1059   add_sym_2 ("datan2", 1, 1, BT_REAL, dd, GFC_STD_F77,
1060              NULL, gfc_simplify_atan2, gfc_resolve_atan2,
1061              y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
1062
1063   make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
1064
1065   /* Bessel and Neumann functions for G77 compatibility.  */
1066   add_sym_1 ("besj0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1067              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1068              x, BT_REAL, dr, REQUIRED);
1069
1070   add_sym_1 ("dbesj0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1071              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1072              x, BT_REAL, dd, REQUIRED);
1073
1074   make_generic ("besj0", GFC_ISYM_J0, GFC_STD_GNU);
1075
1076   add_sym_1 ("besj1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1077              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1078              x, BT_REAL, dr, REQUIRED);
1079
1080   add_sym_1 ("dbesj1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1081              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1082              x, BT_REAL, dd, REQUIRED);
1083
1084   make_generic ("besj1", GFC_ISYM_J1, GFC_STD_GNU);
1085
1086   add_sym_2 ("besjn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1087              gfc_check_besn, NULL, gfc_resolve_besn,
1088              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1089
1090   add_sym_2 ("dbesjn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1091              gfc_check_besn, NULL, gfc_resolve_besn,
1092              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1093
1094   make_generic ("besjn", GFC_ISYM_JN, GFC_STD_GNU);
1095
1096   add_sym_1 ("besy0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1097              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1098              x, BT_REAL, dr, REQUIRED);
1099
1100   add_sym_1 ("dbesy0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1101              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1102              x, BT_REAL, dd, REQUIRED);
1103
1104   make_generic ("besy0", GFC_ISYM_Y0, GFC_STD_GNU);
1105
1106   add_sym_1 ("besy1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1107              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1108              x, BT_REAL, dr, REQUIRED);
1109
1110   add_sym_1 ("dbesy1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1111              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1112              x, BT_REAL, dd, REQUIRED);
1113
1114   make_generic ("besy1", GFC_ISYM_Y1, GFC_STD_GNU);
1115
1116   add_sym_2 ("besyn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1117              gfc_check_besn, NULL, gfc_resolve_besn,
1118              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1119
1120   add_sym_2 ("dbesyn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1121              gfc_check_besn, NULL, gfc_resolve_besn,
1122              n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1123
1124   make_generic ("besyn", GFC_ISYM_YN, GFC_STD_GNU);
1125
1126   add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1127              gfc_check_i, gfc_simplify_bit_size, NULL,
1128              i, BT_INTEGER, di, REQUIRED);
1129
1130   make_generic ("bit_size", GFC_ISYM_NONE, GFC_STD_F95);
1131
1132   add_sym_2 ("btest", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
1133              gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
1134              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1135
1136   make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
1137
1138   add_sym_2 ("ceiling", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1139              gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
1140              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1141
1142   make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
1143
1144   add_sym_2 ("char", 1, 0, BT_CHARACTER, dc, GFC_STD_F77,
1145              gfc_check_char, gfc_simplify_char, gfc_resolve_char,
1146              i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1147
1148   make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
1149
1150   add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1151              gfc_check_chdir, NULL, gfc_resolve_chdir,
1152              a, BT_CHARACTER, dc, REQUIRED);
1153
1154   make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
1155
1156   add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1157              gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
1158              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
1159              kind, BT_INTEGER, di, OPTIONAL);
1160
1161   make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
1162
1163   add_sym_2 ("complex", 1, 1, BT_COMPLEX, dz, GFC_STD_GNU,
1164              gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
1165              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1166
1167   make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);
1168
1169   /* Making dcmplx a specific of cmplx causes cmplx to return a double
1170      complex instead of the default complex.  */
1171
1172   add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1173              gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
1174              x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
1175
1176   make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
1177
1178   add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1179              gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
1180              z, BT_COMPLEX, dz, REQUIRED);
1181
1182   add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1183              NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1184              z, BT_COMPLEX, dd, REQUIRED);
1185
1186   make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
1187
1188   add_sym_1 ("cos", 1, 1, BT_REAL, dr, GFC_STD_F77,
1189              gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1190              x, BT_REAL, dr, REQUIRED);
1191
1192   add_sym_1 ("dcos", 1, 1, BT_REAL, dd, GFC_STD_F77,
1193              gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1194              x, BT_REAL, dd, REQUIRED);
1195
1196   add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1197              NULL, gfc_simplify_cos, gfc_resolve_cos,
1198              x, BT_COMPLEX, dz, REQUIRED);
1199
1200   add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1201              NULL, gfc_simplify_cos, gfc_resolve_cos,
1202              x, BT_COMPLEX, dd, REQUIRED);
1203
1204   make_alias ("cdcos", GFC_STD_GNU);
1205
1206   make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
1207
1208   add_sym_1 ("cosh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1209              gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh,
1210              x, BT_REAL, dr, REQUIRED);
1211
1212   add_sym_1 ("dcosh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1213              NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1214              x, BT_REAL, dd, REQUIRED);
1215
1216   make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
1217
1218   add_sym_2 ("count", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1219              gfc_check_count, NULL, gfc_resolve_count,
1220              msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1221
1222   make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
1223
1224   add_sym_3 ("cshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1225              gfc_check_cshift, NULL, gfc_resolve_cshift,
1226              ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1227              dm, BT_INTEGER, ii, OPTIONAL);
1228
1229   make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
1230
1231   add_sym_1 ("ctime", 0, 1, BT_CHARACTER, 0, GFC_STD_GNU,
1232               gfc_check_ctime, NULL, gfc_resolve_ctime,
1233               tm, BT_INTEGER, di, REQUIRED);
1234
1235   make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
1236
1237   add_sym_1 ("dble", 1, 1, BT_REAL, dd, GFC_STD_F77,
1238              gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1239              a, BT_REAL, dr, REQUIRED);
1240
1241   make_alias ("dfloat", GFC_STD_GNU);
1242
1243   make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
1244
1245   add_sym_1 ("digits", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1246              gfc_check_digits, gfc_simplify_digits, NULL,
1247              x, BT_UNKNOWN, dr, REQUIRED);
1248
1249   make_generic ("digits", GFC_ISYM_NONE, GFC_STD_F95);
1250
1251   add_sym_2 ("dim", 1, 1, BT_REAL, dr, GFC_STD_F77,
1252              gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1253              x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1254
1255   add_sym_2 ("idim", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1256              NULL, gfc_simplify_dim, gfc_resolve_dim,
1257              x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
1258
1259   add_sym_2 ("ddim", 1, 1, BT_REAL, dd, GFC_STD_F77,
1260              NULL, gfc_simplify_dim, gfc_resolve_dim,
1261              x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
1262
1263   make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
1264
1265   add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1266              gfc_check_dot_product, NULL, gfc_resolve_dot_product,
1267              va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
1268
1269   make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
1270
1271   add_sym_2 ("dprod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1272              NULL, gfc_simplify_dprod, gfc_resolve_dprod,
1273              x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1274
1275   make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
1276
1277   add_sym_1 ("dreal", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1278              NULL, NULL, NULL,
1279              a, BT_COMPLEX, dd, REQUIRED);
1280
1281   make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
1282
1283   add_sym_4 ("eoshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1284              gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1285              ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
1286              bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
1287
1288   make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
1289
1290   add_sym_1 ("epsilon", 0, 1, BT_REAL, dr, GFC_STD_F95,
1291              gfc_check_x, gfc_simplify_epsilon, NULL,
1292              x, BT_REAL, dr, REQUIRED);
1293
1294   make_generic ("epsilon", GFC_ISYM_NONE, GFC_STD_F95);
1295
1296   /* G77 compatibility for the ERF() and ERFC() functions.  */
1297   add_sym_1 ("erf", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1298              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1299              x, BT_REAL, dr, REQUIRED);
1300
1301   add_sym_1 ("derf", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1302              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1303              x, BT_REAL, dd, REQUIRED);
1304
1305   make_generic ("erf", GFC_ISYM_ERF, GFC_STD_GNU);
1306
1307   add_sym_1 ("erfc", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1308              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1309              x, BT_REAL, dr, REQUIRED);
1310
1311   add_sym_1 ("derfc", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1312              gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1313              x, BT_REAL, dd, REQUIRED);
1314
1315   make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_GNU);
1316
1317   /* G77 compatibility */
1318   add_sym_1 ("etime", 0, 1, BT_REAL, 4,  GFC_STD_GNU,
1319              gfc_check_etime, NULL, NULL,
1320              x, BT_REAL, 4, REQUIRED);
1321
1322   make_alias ("dtime", GFC_STD_GNU);
1323
1324   make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
1325
1326   add_sym_1 ("exp", 1, 1, BT_REAL, dr,  GFC_STD_F77,
1327              gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
1328              x, BT_REAL, dr, REQUIRED);
1329
1330   add_sym_1 ("dexp", 1, 1, BT_REAL, dd, GFC_STD_F77,
1331              NULL, gfc_simplify_exp, gfc_resolve_exp,
1332              x, BT_REAL, dd, REQUIRED);
1333
1334   add_sym_1 ("cexp", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1335              NULL, gfc_simplify_exp, gfc_resolve_exp,
1336              x, BT_COMPLEX, dz, REQUIRED);
1337
1338   add_sym_1 ("zexp", 1, 1, BT_COMPLEX, dd,  GFC_STD_GNU,
1339              NULL, gfc_simplify_exp, gfc_resolve_exp,
1340              x, BT_COMPLEX, dd, REQUIRED);
1341
1342   make_alias ("cdexp", GFC_STD_GNU);
1343
1344   make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
1345
1346   add_sym_1 ("exponent", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1347              gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1348              x, BT_REAL, dr, REQUIRED);
1349
1350   make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
1351
1352   add_sym_0 ("fdate", 1, 0, BT_CHARACTER, dc, GFC_STD_GNU,
1353              NULL, NULL, gfc_resolve_fdate);
1354
1355   make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
1356
1357   add_sym_2 ("floor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1358              gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1359              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1360
1361   make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1362
1363   /* G77 compatible fnum */
1364   add_sym_1 ("fnum", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1365              gfc_check_fnum, NULL, gfc_resolve_fnum,
1366              ut, BT_INTEGER, di, REQUIRED);
1367
1368   make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1369
1370   add_sym_1 ("fraction", 1, 1, BT_REAL, dr, GFC_STD_F95,
1371              gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1372              x, BT_REAL, dr, REQUIRED);
1373
1374   make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1375
1376   add_sym_2 ("fstat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1377              gfc_check_fstat, NULL, gfc_resolve_fstat,
1378              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1379
1380   make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1381
1382   add_sym_1 ("ftell", 0, 1, BT_INTEGER, ii, GFC_STD_GNU,
1383              gfc_check_ftell, NULL, gfc_resolve_ftell,
1384              ut, BT_INTEGER, di, REQUIRED);
1385
1386   make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
1387
1388   add_sym_2 ("fgetc", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1389              gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
1390              ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1391
1392   make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
1393
1394   add_sym_1 ("fget", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1395              gfc_check_fgetput, NULL, gfc_resolve_fget,
1396              c, BT_CHARACTER, dc, REQUIRED);
1397
1398   make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
1399
1400   add_sym_2 ("fputc", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1401              gfc_check_fgetputc, NULL, gfc_resolve_fputc,
1402              ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1403
1404   make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
1405
1406   add_sym_1 ("fput", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1407              gfc_check_fgetput, NULL, gfc_resolve_fput,
1408              c, BT_CHARACTER, dc, REQUIRED);
1409
1410   make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
1411
1412   /* Unix IDs (g77 compatibility)  */
1413   add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di,  GFC_STD_GNU,
1414              NULL, NULL, gfc_resolve_getcwd,
1415              c, BT_CHARACTER, dc, REQUIRED);
1416
1417   make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1418
1419   add_sym_0 ("getgid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1420              NULL, NULL, gfc_resolve_getgid);
1421
1422   make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1423
1424   add_sym_0 ("getpid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1425              NULL, NULL, gfc_resolve_getpid);
1426
1427   make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1428
1429   add_sym_0 ("getuid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1430              NULL, NULL, gfc_resolve_getuid);
1431
1432   make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1433
1434   add_sym_1 ("hostnm", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1435              gfc_check_hostnm, NULL, gfc_resolve_hostnm,
1436              a, BT_CHARACTER, dc, REQUIRED);
1437
1438   make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
1439
1440   add_sym_1 ("huge", 0, 1, BT_REAL, dr, GFC_STD_F95,
1441              gfc_check_huge, gfc_simplify_huge, NULL,
1442              x, BT_UNKNOWN, dr, REQUIRED);
1443
1444   make_generic ("huge", GFC_ISYM_NONE, GFC_STD_F95);
1445
1446   add_sym_1 ("iachar", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1447              gfc_check_ichar_iachar, gfc_simplify_iachar, NULL,
1448              c, BT_CHARACTER, dc, REQUIRED);
1449
1450   make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1451
1452   add_sym_2 ("iand", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1453              gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1454              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1455
1456   make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1457
1458   add_sym_2 ("and", 1, 0, BT_UNKNOWN, 0, GFC_STD_GNU,
1459              gfc_check_and, gfc_simplify_and, gfc_resolve_and,
1460              i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1461
1462   make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
1463
1464   add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1465              NULL, NULL, NULL);
1466
1467   make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
1468
1469   add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, GFC_STD_F2003,
1470              NULL, NULL, NULL);
1471
1472   make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
1473                 GFC_STD_F2003);
1474
1475   add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1476              gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1477              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1478
1479   make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
1480
1481   add_sym_3 ("ibits", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1482              gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1483              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
1484              ln, BT_INTEGER, di, REQUIRED);
1485
1486   make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
1487
1488   add_sym_2 ("ibset", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1489              gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1490              i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1491
1492   make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
1493
1494   add_sym_1 ("ichar", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1495              gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
1496              c, BT_CHARACTER, dc, REQUIRED);
1497
1498   make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
1499
1500   add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1501              gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1502              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1503
1504   make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
1505
1506   add_sym_2 ("xor", 1, 0, BT_UNKNOWN, 0, GFC_STD_GNU,
1507              gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
1508              i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1509
1510   make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
1511
1512   add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1513              NULL, NULL, gfc_resolve_ierrno);
1514
1515   make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
1516
1517   add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1518              gfc_check_index, gfc_simplify_index, NULL,
1519              stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
1520              bck, BT_LOGICAL, dl, OPTIONAL);
1521
1522   make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
1523
1524   add_sym_2 ("int", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1525              gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1526              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1527
1528   add_sym_1 ("ifix", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1529              NULL, gfc_simplify_ifix, NULL,
1530              a, BT_REAL, dr, REQUIRED);
1531
1532   add_sym_1 ("idint", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1533              NULL, gfc_simplify_idint, NULL,
1534              a, BT_REAL, dd, REQUIRED);
1535
1536   make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
1537
1538   add_sym_2 ("ior", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1539              gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1540              i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1541
1542   make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
1543
1544   add_sym_2 ("or", 1, 0, BT_UNKNOWN, 0, GFC_STD_GNU,
1545              gfc_check_and, gfc_simplify_or, gfc_resolve_or,
1546              i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1547
1548   make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
1549
1550   /* The following function is for G77 compatibility.  */
1551   add_sym_1 ("irand", 0, 1, BT_INTEGER, 4, GFC_STD_GNU,
1552              gfc_check_irand, NULL, NULL,
1553              i, BT_INTEGER, 4, OPTIONAL);
1554
1555   make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
1556
1557   add_sym_1 ("isatty", 0, 0, BT_LOGICAL, dl, GFC_STD_GNU,
1558              gfc_check_isatty, NULL, gfc_resolve_isatty,
1559              ut, BT_INTEGER, di, REQUIRED);
1560
1561   make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
1562
1563   add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1564              gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1565              i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1566
1567   make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
1568
1569   add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1570              gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1571              i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1572              sz, BT_INTEGER, di, OPTIONAL);
1573
1574   make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
1575
1576   add_sym_2 ("kill", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1577              gfc_check_kill, NULL, gfc_resolve_kill,
1578              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1579
1580   make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
1581
1582   add_sym_1 ("kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1583              gfc_check_kind, gfc_simplify_kind, NULL,
1584              x, BT_REAL, dr, REQUIRED);
1585
1586   make_generic ("kind", GFC_ISYM_NONE, GFC_STD_F95);
1587
1588   add_sym_2 ("lbound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1589              gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1590              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL);
1591
1592   make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
1593
1594   add_sym_1 ("len", 0, 1, BT_INTEGER, di, GFC_STD_F77,
1595              NULL, gfc_simplify_len, gfc_resolve_len,
1596              stg, BT_CHARACTER, dc, REQUIRED);
1597
1598   make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
1599
1600   add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1601              NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1602              stg, BT_CHARACTER, dc, REQUIRED);
1603
1604   make_alias ("lnblnk", GFC_STD_GNU);
1605
1606   make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
1607
1608   add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1609              NULL, gfc_simplify_lge, NULL,
1610              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1611
1612   make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
1613
1614   add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1615              NULL, gfc_simplify_lgt, NULL,
1616              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1617
1618   make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
1619
1620   add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1621              NULL, gfc_simplify_lle, NULL,
1622              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1623
1624   make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
1625
1626   add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1627              NULL, gfc_simplify_llt, NULL,
1628              sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1629
1630   make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
1631
1632   add_sym_2 ("link", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1633              gfc_check_link, NULL, gfc_resolve_link,
1634              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1635
1636   make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
1637
1638   add_sym_1 ("log", 1, 1, BT_REAL, dr, GFC_STD_F77,
1639              gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
1640              x, BT_REAL, dr, REQUIRED);
1641
1642   add_sym_1 ("alog", 1, 1, BT_REAL, dr, GFC_STD_F77,
1643              NULL, gfc_simplify_log, gfc_resolve_log,
1644              x, BT_REAL, dr, REQUIRED);
1645
1646   add_sym_1 ("dlog", 1, 1, BT_REAL, dd, GFC_STD_F77,
1647              NULL, gfc_simplify_log, gfc_resolve_log,
1648              x, BT_REAL, dd, REQUIRED);
1649
1650   add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1651              NULL, gfc_simplify_log, gfc_resolve_log,
1652              x, BT_COMPLEX, dz, REQUIRED);
1653
1654   add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd,  GFC_STD_GNU,
1655              NULL, gfc_simplify_log, gfc_resolve_log,
1656              x, BT_COMPLEX, dd, REQUIRED);
1657
1658   make_alias ("cdlog", GFC_STD_GNU);
1659
1660   make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
1661
1662   add_sym_1 ("log10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1663              gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
1664              x, BT_REAL, dr, REQUIRED);
1665
1666   add_sym_1 ("alog10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1667              NULL, gfc_simplify_log10, gfc_resolve_log10,
1668              x, BT_REAL, dr, REQUIRED);
1669
1670   add_sym_1 ("dlog10", 1, 1, BT_REAL, dd, GFC_STD_F77,
1671              NULL, gfc_simplify_log10, gfc_resolve_log10,
1672              x, BT_REAL, dd, REQUIRED);
1673
1674   make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
1675
1676   add_sym_2 ("logical", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
1677              gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1678              l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1679
1680   make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
1681
1682   add_sym_1 ("malloc", 0, 1, BT_INTEGER, ii, GFC_STD_GNU, gfc_check_malloc,
1683              NULL, gfc_resolve_malloc, a, BT_INTEGER, di, REQUIRED);
1684
1685   make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
1686
1687   add_sym_2 ("matmul", 0, 1, BT_REAL, dr, GFC_STD_F95,
1688              gfc_check_matmul, NULL, gfc_resolve_matmul,
1689              ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
1690
1691   make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
1692
1693   /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1694      int(max).  The max function must take at least two arguments.  */
1695
1696   add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1697              gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1698              a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
1699
1700   add_sym_1m ("max0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1701              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1702              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1703
1704   add_sym_1m ("amax0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1705              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1706              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1707
1708   add_sym_1m ("amax1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1709              gfc_check_min_max_real, gfc_simplify_max, NULL,
1710              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1711
1712   add_sym_1m ("max1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1713              gfc_check_min_max_real, gfc_simplify_max, NULL,
1714              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1715
1716   add_sym_1m ("dmax1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1717              gfc_check_min_max_double, gfc_simplify_max, NULL,
1718              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1719
1720   make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
1721
1722   add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1723              gfc_check_x, gfc_simplify_maxexponent, NULL,
1724              x, BT_UNKNOWN, dr, REQUIRED);
1725
1726   make_generic ("maxexponent", GFC_ISYM_NONE, GFC_STD_F95);
1727
1728   add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1729                gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1730                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1731                msk, BT_LOGICAL, dl, OPTIONAL);
1732
1733   make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
1734
1735   add_sym_3red ("maxval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1736                 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1737                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1738                 msk, BT_LOGICAL, dl, OPTIONAL);
1739
1740   make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
1741
1742   add_sym_3 ("merge", 1, 1, BT_REAL, dr, GFC_STD_F95,
1743              gfc_check_merge, NULL, gfc_resolve_merge,
1744              ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
1745              msk, BT_LOGICAL, dl, REQUIRED);
1746
1747   make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
1748
1749   /* Note: amin0 is equivalent to real(min), min1 is equivalent to
1750      int(min).  */
1751
1752   add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1753               gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1754              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1755
1756   add_sym_1m ("min0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1757               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1758              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1759
1760   add_sym_1m ("amin0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1761               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1762              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1763
1764   add_sym_1m ("amin1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1765               gfc_check_min_max_real, gfc_simplify_min, NULL,
1766              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1767
1768   add_sym_1m ("min1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1769               gfc_check_min_max_real, gfc_simplify_min, NULL,
1770              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1771
1772   add_sym_1m ("dmin1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1773               gfc_check_min_max_double, gfc_simplify_min, NULL,
1774              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1775
1776   make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
1777
1778   add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1779              gfc_check_x, gfc_simplify_minexponent, NULL,
1780              x, BT_UNKNOWN, dr, REQUIRED);
1781
1782   make_generic ("minexponent", GFC_ISYM_NONE, GFC_STD_F95);
1783
1784   add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1785                gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1786                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1787                msk, BT_LOGICAL, dl, OPTIONAL);
1788
1789   make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
1790
1791   add_sym_3red ("minval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1792                 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1793                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1794                 msk, BT_LOGICAL, dl, OPTIONAL);
1795
1796   make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
1797
1798   add_sym_2 ("mod", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1799              gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1800              a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
1801
1802   add_sym_2 ("amod", 1, 1, BT_REAL, dr, GFC_STD_F77,
1803              NULL, gfc_simplify_mod, gfc_resolve_mod,
1804              a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
1805
1806   add_sym_2 ("dmod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1807              NULL, gfc_simplify_mod, gfc_resolve_mod,
1808              a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
1809
1810   make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
1811
1812   add_sym_2 ("modulo", 1, 1, BT_REAL, di, GFC_STD_F95,
1813              gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1814              a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
1815
1816   make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
1817
1818   add_sym_2 ("nearest", 1, 1, BT_REAL, dr, GFC_STD_F95,
1819              gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1820              x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
1821
1822   make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
1823
1824   add_sym_2 ("nint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1825              gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1826              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1827
1828   add_sym_1 ("idnint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1829              gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1830              a, BT_REAL, dd, REQUIRED);
1831
1832   make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
1833
1834   add_sym_1 ("not", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1835              gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1836              i, BT_INTEGER, di, REQUIRED);
1837
1838   make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
1839
1840   add_sym_1 ("null", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1841              gfc_check_null, gfc_simplify_null, NULL,
1842              mo, BT_INTEGER, di, OPTIONAL);
1843
1844   make_generic ("null", GFC_ISYM_NONE, GFC_STD_F95);
1845
1846   add_sym_3 ("pack", 0, 1, BT_REAL, dr, GFC_STD_F95,
1847              gfc_check_pack, NULL, gfc_resolve_pack,
1848              ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1849              v, BT_REAL, dr, OPTIONAL);
1850
1851   make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
1852
1853   add_sym_1 ("precision", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1854              gfc_check_precision, gfc_simplify_precision, NULL,
1855              x, BT_UNKNOWN, 0, REQUIRED);
1856
1857   make_generic ("precision", GFC_ISYM_NONE, GFC_STD_F95);
1858
1859   add_sym_1 ("present", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1860              gfc_check_present, NULL, NULL,
1861              a, BT_REAL, dr, REQUIRED);
1862
1863   make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
1864
1865   add_sym_3red ("product", 0, 1, BT_REAL, dr, GFC_STD_F95,
1866                 gfc_check_product_sum, NULL, gfc_resolve_product,
1867                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1868                 msk, BT_LOGICAL, dl, OPTIONAL);
1869
1870   make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
1871
1872   add_sym_1 ("radix", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1873              gfc_check_radix, gfc_simplify_radix, NULL,
1874              x, BT_UNKNOWN, 0, REQUIRED);
1875
1876   make_generic ("radix", GFC_ISYM_NONE, GFC_STD_F95);
1877
1878   /* The following function is for G77 compatibility.  */
1879   add_sym_1 ("rand", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1880              gfc_check_rand, NULL, NULL,
1881              i, BT_INTEGER, 4, OPTIONAL);
1882
1883   /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and ran()
1884      use slightly different shoddy multiplicative congruential PRNG.  */
1885   make_alias ("ran", GFC_STD_GNU);
1886
1887   make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
1888
1889   add_sym_1 ("range", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1890              gfc_check_range, gfc_simplify_range, NULL,
1891              x, BT_REAL, dr, REQUIRED);
1892
1893   make_generic ("range", GFC_ISYM_NONE, GFC_STD_F95);
1894
1895   add_sym_2 ("real", 1, 0, BT_REAL, dr, GFC_STD_F77,
1896              gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1897              a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1898
1899   /* This provides compatibility with g77.  */
1900   add_sym_1 ("realpart", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1901              gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
1902              a, BT_UNKNOWN, dr, REQUIRED);
1903
1904   add_sym_1 ("float", 1, 0, BT_REAL, dr, GFC_STD_F77,
1905              gfc_check_i, gfc_simplify_float, NULL,
1906              a, BT_INTEGER, di, REQUIRED);
1907
1908   add_sym_1 ("sngl", 1, 0, BT_REAL, dr, GFC_STD_F77,
1909              NULL, gfc_simplify_sngl, NULL,
1910              a, BT_REAL, dd, REQUIRED);
1911
1912   make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
1913
1914   add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1915              gfc_check_rename, NULL, gfc_resolve_rename,
1916              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1917
1918   make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
1919
1920   add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
1921              gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1922              stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
1923
1924   make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
1925
1926   add_sym_4 ("reshape", 0, 1, BT_REAL, dr, GFC_STD_F95,
1927              gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1928              src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
1929              pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
1930
1931   make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
1932
1933   add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1934              gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1935              x, BT_REAL, dr, REQUIRED);
1936
1937   make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
1938
1939   add_sym_2 ("scale", 1, 1, BT_REAL, dr, GFC_STD_F95,
1940              gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1941              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1942
1943   make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
1944
1945   add_sym_3 ("scan", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1946              gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1947              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
1948              bck, BT_LOGICAL, dl, OPTIONAL);
1949
1950   make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
1951
1952   /* Added for G77 compatibility garbage.  */
1953   add_sym_0 ("second", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1954              NULL, NULL, NULL);
1955
1956   make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
1957
1958   /* Added for G77 compatibility.  */
1959   add_sym_1 ("secnds", 0, 1, BT_REAL, dr, GFC_STD_GNU,
1960              gfc_check_secnds, NULL, gfc_resolve_secnds,
1961              x, BT_REAL, dr, REQUIRED);
1962
1963   make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
1964
1965   add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1966              gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL,
1967              r, BT_INTEGER, di, REQUIRED);
1968
1969   make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
1970
1971   add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1972              gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1973              NULL,
1974              p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
1975
1976   make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
1977
1978   add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr, GFC_STD_F95,
1979              gfc_check_set_exponent, gfc_simplify_set_exponent,
1980              gfc_resolve_set_exponent,
1981              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1982
1983   make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
1984
1985   add_sym_1 ("shape", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1986              gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1987              src, BT_REAL, dr, REQUIRED);
1988
1989   make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
1990
1991   add_sym_2 ("sign", 1, 1, BT_REAL, dr, GFC_STD_F77,
1992              gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1993              a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
1994
1995   add_sym_2 ("isign", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1996              NULL, gfc_simplify_sign, gfc_resolve_sign,
1997              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1998
1999   add_sym_2 ("dsign", 1, 1, BT_REAL, dd, GFC_STD_F77,
2000              NULL, gfc_simplify_sign, gfc_resolve_sign,
2001              a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
2002
2003   make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
2004
2005   add_sym_2 ("signal", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
2006              gfc_check_signal, NULL, gfc_resolve_signal,
2007              num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
2008
2009   make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
2010
2011   add_sym_1 ("sin", 1, 1, BT_REAL, dr, GFC_STD_F77,
2012              gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
2013              x, BT_REAL, dr, REQUIRED);
2014
2015   add_sym_1 ("dsin", 1, 1, BT_REAL, dd, GFC_STD_F77,
2016              NULL, gfc_simplify_sin, gfc_resolve_sin,
2017              x, BT_REAL, dd, REQUIRED);
2018
2019   add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
2020              NULL, gfc_simplify_sin, gfc_resolve_sin,
2021              x, BT_COMPLEX, dz, REQUIRED);
2022
2023   add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
2024              NULL, gfc_simplify_sin, gfc_resolve_sin,
2025              x, BT_COMPLEX, dd, REQUIRED);
2026
2027   make_alias ("cdsin", GFC_STD_GNU);
2028
2029   make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
2030
2031   add_sym_1 ("sinh", 1, 1, BT_REAL, dr, GFC_STD_F77,
2032              gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh,
2033              x, BT_REAL, dr, REQUIRED);
2034
2035   add_sym_1 ("dsinh", 1, 1, BT_REAL, dd, GFC_STD_F77,
2036              NULL, gfc_simplify_sinh, gfc_resolve_sinh,
2037              x, BT_REAL, dd, REQUIRED);
2038
2039   make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
2040
2041   add_sym_2 ("size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
2042              gfc_check_size, gfc_simplify_size, NULL,
2043              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2044
2045   make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
2046
2047   add_sym_1 ("spacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
2048              gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
2049              x, BT_REAL, dr, REQUIRED);
2050
2051   make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
2052
2053   add_sym_3 ("spread", 0, 1, BT_REAL, dr, GFC_STD_F95,
2054              gfc_check_spread, NULL, gfc_resolve_spread,
2055              src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
2056              n, BT_INTEGER, di, REQUIRED);
2057
2058   make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
2059
2060   add_sym_1 ("sqrt", 1, 1, BT_REAL, dr, GFC_STD_F77,
2061              gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
2062              x, BT_REAL, dr, REQUIRED);
2063
2064   add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd, GFC_STD_F77,
2065              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2066              x, BT_REAL, dd, REQUIRED);
2067
2068   add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
2069              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2070              x, BT_COMPLEX, dz, REQUIRED);
2071
2072   add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
2073              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2074              x, BT_COMPLEX, dd, REQUIRED);
2075
2076   make_alias ("cdsqrt", GFC_STD_GNU);
2077
2078   make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
2079
2080   add_sym_2 ("stat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2081              gfc_check_stat, NULL, gfc_resolve_stat,
2082              a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2083
2084   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
2085
2086   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2087                 gfc_check_product_sum, NULL, gfc_resolve_sum,
2088                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2089                 msk, BT_LOGICAL, dl, OPTIONAL);
2090
2091   make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
2092
2093   add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2094              gfc_check_symlnk, NULL, gfc_resolve_symlnk,
2095              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
2096
2097   make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
2098
2099   add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
2100              NULL, NULL, NULL,
2101              c, BT_CHARACTER, dc, REQUIRED);
2102
2103   make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
2104
2105   add_sym_1 ("tan", 1, 1, BT_REAL, dr, GFC_STD_F77,
2106              gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
2107              x, BT_REAL, dr, REQUIRED);
2108
2109   add_sym_1 ("dtan", 1, 1, BT_REAL, dd, GFC_STD_F77,
2110              NULL, gfc_simplify_tan, gfc_resolve_tan,
2111              x, BT_REAL, dd, REQUIRED);
2112
2113   make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
2114
2115   add_sym_1 ("tanh", 1, 1, BT_REAL, dr, GFC_STD_F77,
2116              gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
2117              x, BT_REAL, dr, REQUIRED);
2118
2119   add_sym_1 ("dtanh", 1, 1, BT_REAL, dd, GFC_STD_F77,
2120              NULL, gfc_simplify_tanh, gfc_resolve_tanh,
2121              x, BT_REAL, dd, REQUIRED);
2122
2123   make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
2124
2125   add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
2126              NULL, NULL, gfc_resolve_time);
2127
2128   make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
2129
2130   add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
2131              NULL, NULL, gfc_resolve_time8);
2132
2133   make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
2134
2135   add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95,
2136              gfc_check_x, gfc_simplify_tiny, NULL,
2137              x, BT_REAL, dr, REQUIRED);
2138
2139   make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95);
2140
2141   add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95,
2142              gfc_check_transfer, NULL, gfc_resolve_transfer,
2143              src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
2144              sz, BT_INTEGER, di, OPTIONAL);
2145
2146   make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
2147
2148   add_sym_1 ("transpose", 0, 1, BT_REAL, dr, GFC_STD_F95,
2149              gfc_check_transpose, NULL, gfc_resolve_transpose,
2150              m, BT_REAL, dr, REQUIRED);
2151
2152   make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2153
2154   add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
2155              gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2156              stg, BT_CHARACTER, dc, REQUIRED);
2157
2158   make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2159
2160   add_sym_1 ("ttynam", 0, 1, BT_CHARACTER, 0, GFC_STD_GNU,
2161               gfc_check_ttynam, NULL, gfc_resolve_ttynam,
2162               ut, BT_INTEGER, di, REQUIRED);
2163
2164   make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
2165
2166   add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
2167              gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2168              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2169
2170   make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2171
2172   /* g77 compatibility for UMASK.  */
2173   add_sym_1 ("umask", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2174              gfc_check_umask, NULL, gfc_resolve_umask,
2175              a, BT_INTEGER, di, REQUIRED);
2176
2177   make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2178
2179   /* g77 compatibility for UNLINK.  */
2180   add_sym_1 ("unlink", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2181              gfc_check_unlink, NULL, gfc_resolve_unlink,
2182              a, BT_CHARACTER, dc, REQUIRED);
2183
2184   make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2185
2186   add_sym_3 ("unpack", 0, 1, BT_REAL, dr, GFC_STD_F95,
2187              gfc_check_unpack, NULL, gfc_resolve_unpack,
2188              v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2189              f, BT_REAL, dr, REQUIRED);
2190
2191   make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2192
2193   add_sym_3 ("verify", 1, 1, BT_INTEGER, di, GFC_STD_F95,
2194              gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2195              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2196              bck, BT_LOGICAL, dl, OPTIONAL);
2197
2198   make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2199
2200   add_sym_1 ("loc", 0, 1, BT_INTEGER, ii, GFC_STD_GNU,
2201             gfc_check_loc, NULL, gfc_resolve_loc,
2202             ar, BT_UNKNOWN, 0, REQUIRED);
2203
2204   make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
2205
2206 }
2207
2208
2209 /* Add intrinsic subroutines.  */
2210
2211 static void
2212 add_subroutines (void)
2213 {
2214   /* Argument names as in the standard (to be used as argument keywords).  */
2215   const char
2216     *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2217     *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2218     *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2219     *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2220     *com = "command", *length = "length", *st = "status",
2221     *val = "value", *num = "number", *name = "name",
2222     *trim_name = "trim_name", *ut = "unit", *han = "handler",
2223     *sec = "seconds", *res = "result", *of = "offset";
2224
2225   int di, dr, dc, dl, ii;
2226
2227   di = gfc_default_integer_kind;
2228   dr = gfc_default_real_kind;
2229   dc = gfc_default_character_kind;
2230   dl = gfc_default_logical_kind;
2231   ii = gfc_index_integer_kind;
2232
2233   add_sym_0s ("abort", 1, GFC_STD_GNU, NULL);
2234
2235   make_noreturn();
2236
2237   add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2238               gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2239               tm, BT_REAL, dr, REQUIRED);
2240
2241   /* More G77 compatibility garbage.  */
2242   add_sym_2s ("ctime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2243              gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
2244              tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
2245
2246   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2247               gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2248               tm, BT_REAL, dr, REQUIRED);
2249
2250   add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2251               gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2252               name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2253
2254   add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2255               gfc_check_date_and_time, NULL, NULL,
2256               dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2257               zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2258
2259   /* More G77 compatibility garbage.  */
2260   add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2261              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2262               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2263
2264   add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2265              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2266               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2267
2268   add_sym_1s ("fdate", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2269              gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
2270              dt, BT_CHARACTER, dc, REQUIRED);
2271
2272   add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2273               gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
2274               dc, REQUIRED);
2275
2276   add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2277           gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2278               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2279
2280   add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2281               NULL, NULL, NULL,
2282               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2283
2284   add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2285               NULL, NULL, gfc_resolve_getarg,
2286               c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2287
2288   add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2289               gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2290               dc, REQUIRED);
2291
2292   /* F2003 commandline routines.  */
2293
2294   add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2295               NULL, NULL, gfc_resolve_get_command,
2296               com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
2297               st, BT_INTEGER, di, OPTIONAL);
2298
2299   add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2300               NULL, NULL, gfc_resolve_get_command_argument,
2301               num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2302               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2303
2304   /* F2003 subroutine to get environment variables.  */
2305
2306   add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2307              NULL, NULL, gfc_resolve_get_environment_variable,
2308               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2309               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2310               trim_name, BT_LOGICAL, dl, OPTIONAL);
2311
2312   add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2313               gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2314               f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2315               ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2316               tp, BT_INTEGER, di, REQUIRED);
2317
2318   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2319               gfc_check_random_number, NULL, gfc_resolve_random_number,
2320               h, BT_REAL, dr, REQUIRED);
2321
2322   add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2323              gfc_check_random_seed, NULL, NULL,
2324               sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2325               gt, BT_INTEGER, di, OPTIONAL);
2326
2327   /* More G77 compatibility garbage.  */
2328   add_sym_3s ("alarm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2329               gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
2330               sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2331               st, BT_INTEGER, di, OPTIONAL);
2332
2333   add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU,
2334              gfc_check_srand, NULL, gfc_resolve_srand,
2335               c, BT_INTEGER, 4, REQUIRED);
2336
2337   add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2338              gfc_check_exit, NULL, gfc_resolve_exit,
2339               c, BT_INTEGER, di, OPTIONAL);
2340
2341   make_noreturn();
2342
2343   add_sym_3s ("fgetc", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2344               gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
2345               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2346               st, BT_INTEGER, di, OPTIONAL);
2347
2348   add_sym_2s ("fget", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2349               gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
2350               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2351
2352   add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2353               gfc_check_flush, NULL, gfc_resolve_flush,
2354               c, BT_INTEGER, di, OPTIONAL);
2355
2356   add_sym_3s ("fputc", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2357               gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
2358               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2359               st, BT_INTEGER, di, OPTIONAL);
2360
2361   add_sym_2s ("fput", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2362               gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
2363               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2364
2365   add_sym_1s ("free", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
2366               NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
2367
2368   add_sym_2s ("ftell", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2369               gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
2370               ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
2371
2372   add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2373           gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2374               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2375
2376   add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2377               NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2378               val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2379
2380   add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2381               gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2382               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2383               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2384
2385   add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2386           gfc_check_perror, NULL, gfc_resolve_perror,
2387               c, BT_CHARACTER, dc, REQUIRED);
2388
2389   add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2390               gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2391               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2392               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2393
2394   add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2395               gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2396               val, BT_CHARACTER, dc, REQUIRED);
2397
2398   add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2399               gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2400               ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2401               st, BT_INTEGER, di, OPTIONAL);
2402
2403   add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2404               gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2405               name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2406               st, BT_INTEGER, di, OPTIONAL);
2407
2408   add_sym_3s ("signal", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2409               gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
2410               num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2411               st, BT_INTEGER, di, OPTIONAL);
2412
2413   add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2414               gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2415               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2416               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2417
2418   add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2419               NULL, NULL, gfc_resolve_system_sub,
2420               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2421
2422   add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2423              gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2424               c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2425               cm, BT_INTEGER, di, OPTIONAL);
2426
2427   add_sym_2s ("ttynam", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2428               gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
2429               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
2430
2431   add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2432           gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2433               val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2434
2435   add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2436           gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2437               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2438
2439 }
2440
2441
2442 /* Add a function to the list of conversion symbols.  */
2443
2444 static void
2445 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2446 {
2447
2448   gfc_typespec from, to;
2449   gfc_intrinsic_sym *sym;
2450
2451   if (sizing == SZ_CONVS)
2452     {
2453       nconv++;
2454       return;
2455     }
2456
2457   gfc_clear_ts (&from);
2458   from.type = from_type;
2459   from.kind = from_kind;
2460
2461   gfc_clear_ts (&to);
2462   to.type = to_type;
2463   to.kind = to_kind;
2464
2465   sym = conversion + nconv;
2466
2467   sym->name = conv_name (&from, &to);
2468   sym->lib_name = sym->name;
2469   sym->simplify.cc = gfc_convert_constant;
2470   sym->standard = standard;
2471   sym->elemental = 1;
2472   sym->ts = to;
2473   sym->generic_id = GFC_ISYM_CONVERSION;
2474
2475   nconv++;
2476 }
2477
2478
2479 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2480    functions by looping over the kind tables.  */
2481
2482 static void
2483 add_conversions (void)
2484 {
2485   int i, j;
2486
2487   /* Integer-Integer conversions.  */
2488   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2489     for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2490       {
2491         if (i == j)
2492           continue;
2493
2494         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2495                   BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2496       }
2497
2498   /* Integer-Real/Complex conversions.  */
2499   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2500     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2501       {
2502         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2503                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2504
2505         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2506                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2507
2508         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2509                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2510
2511         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2512                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2513       }
2514
2515   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2516     {
2517       /* Hollerith-Integer conversions.  */
2518       for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2519         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2520                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2521       /* Hollerith-Real conversions.  */
2522       for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2523         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2524                   BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2525       /* Hollerith-Complex conversions.  */
2526       for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2527         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2528                   BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2529
2530       /* Hollerith-Character conversions.  */
2531       add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2532                   gfc_default_character_kind, GFC_STD_LEGACY);
2533
2534       /* Hollerith-Logical conversions.  */
2535       for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
2536         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2537                   BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
2538     }
2539
2540   /* Real/Complex - Real/Complex conversions.  */
2541   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2542     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2543       {
2544         if (i != j)
2545           {
2546             add_conv (BT_REAL, gfc_real_kinds[i].kind,
2547                       BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2548
2549             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2550                       BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2551           }
2552
2553         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2554                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2555
2556         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2557                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2558       }
2559
2560   /* Logical/Logical kind conversion.  */
2561   for (i = 0; gfc_logical_kinds[i].kind; i++)
2562     for (j = 0; gfc_logical_kinds[j].kind; j++)
2563       {
2564         if (i == j)
2565           continue;
2566
2567         add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2568                   BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2569       }
2570
2571   /* Integer-Logical and Logical-Integer conversions.  */
2572   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2573     for (i=0; gfc_integer_kinds[i].kind; i++)
2574       for (j=0; gfc_logical_kinds[j].kind; j++)
2575         {
2576           add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2577                     BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2578           add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2579                     BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2580         }
2581 }
2582
2583
2584 /* Initialize the table of intrinsics.  */
2585 void
2586 gfc_intrinsic_init_1 (void)
2587 {
2588   int i;
2589
2590   nargs = nfunc = nsub = nconv = 0;
2591
2592   /* Create a namespace to hold the resolved intrinsic symbols.  */
2593   gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2594
2595   sizing = SZ_FUNCS;
2596   add_functions ();
2597   sizing = SZ_SUBS;
2598   add_subroutines ();
2599   sizing = SZ_CONVS;
2600   add_conversions ();
2601
2602   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2603                           + sizeof (gfc_intrinsic_arg) * nargs);
2604
2605   next_sym = functions;
2606   subroutines = functions + nfunc;
2607
2608   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2609
2610   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2611
2612   sizing = SZ_NOTHING;
2613   nconv = 0;
2614
2615   add_functions ();
2616   add_subroutines ();
2617   add_conversions ();
2618
2619   /* Set the pure flag.  All intrinsic functions are pure, and
2620      intrinsic subroutines are pure if they are elemental.  */
2621
2622   for (i = 0; i < nfunc; i++)
2623     functions[i].pure = 1;
2624
2625   for (i = 0; i < nsub; i++)
2626     subroutines[i].pure = subroutines[i].elemental;
2627 }
2628
2629
2630 void
2631 gfc_intrinsic_done_1 (void)
2632 {
2633   gfc_free (functions);
2634   gfc_free (conversion);
2635   gfc_free_namespace (gfc_intrinsic_namespace);
2636 }
2637
2638
2639 /******** Subroutines to check intrinsic interfaces ***********/
2640
2641 /* Given a formal argument list, remove any NULL arguments that may
2642    have been left behind by a sort against some formal argument list.  */
2643
2644 static void
2645 remove_nullargs (gfc_actual_arglist ** ap)
2646 {
2647   gfc_actual_arglist *head, *tail, *next;
2648
2649   tail = NULL;
2650
2651   for (head = *ap; head; head = next)
2652     {
2653       next = head->next;
2654
2655       if (head->expr == NULL)
2656         {
2657           head->next = NULL;
2658           gfc_free_actual_arglist (head);
2659         }
2660       else
2661         {
2662           if (tail == NULL)
2663             *ap = head;
2664           else
2665             tail->next = head;
2666
2667           tail = head;
2668           tail->next = NULL;
2669         }
2670     }
2671
2672   if (tail == NULL)
2673     *ap = NULL;
2674 }
2675
2676
2677 /* Given an actual arglist and a formal arglist, sort the actual
2678    arglist so that its arguments are in a one-to-one correspondence
2679    with the format arglist.  Arguments that are not present are given
2680    a blank gfc_actual_arglist structure.  If something is obviously
2681    wrong (say, a missing required argument) we abort sorting and
2682    return FAILURE.  */
2683
2684 static try
2685 sort_actual (const char *name, gfc_actual_arglist ** ap,
2686              gfc_intrinsic_arg * formal, locus * where)
2687 {
2688
2689   gfc_actual_arglist *actual, *a;
2690   gfc_intrinsic_arg *f;
2691
2692   remove_nullargs (ap);
2693   actual = *ap;
2694
2695   for (f = formal; f; f = f->next)
2696     f->actual = NULL;
2697
2698   f = formal;
2699   a = actual;
2700
2701   if (f == NULL && a == NULL)   /* No arguments */
2702     return SUCCESS;
2703
2704   for (;;)
2705     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2706       if (f == NULL)
2707         break;
2708       if (a == NULL)
2709         goto optional;
2710
2711       if (a->name != NULL)
2712         goto keywords;
2713
2714       f->actual = a;
2715
2716       f = f->next;
2717       a = a->next;
2718     }
2719
2720   if (a == NULL)
2721     goto do_sort;
2722
2723   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2724   return FAILURE;
2725
2726 keywords:
2727   /* Associate the remaining actual arguments, all of which have
2728      to be keyword arguments.  */
2729   for (; a; a = a->next)
2730     {
2731       for (f = formal; f; f = f->next)
2732         if (strcmp (a->name, f->name) == 0)
2733           break;
2734
2735       if (f == NULL)
2736         {
2737           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2738                      a->name, name, where);
2739           return FAILURE;
2740         }
2741
2742       if (f->actual != NULL)
2743         {
2744           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2745                      f->name, name, where);
2746           return FAILURE;
2747         }
2748
2749       f->actual = a;
2750     }
2751
2752 optional:
2753   /* At this point, all unmatched formal args must be optional.  */
2754   for (f = formal; f; f = f->next)
2755     {
2756       if (f->actual == NULL && f->optional == 0)
2757         {
2758           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2759                      f->name, name, where);
2760           return FAILURE;
2761         }
2762     }
2763
2764 do_sort:
2765   /* Using the formal argument list, string the actual argument list
2766      together in a way that corresponds with the formal list.  */
2767   actual = NULL;
2768
2769   for (f = formal; f; f = f->next)
2770     {
2771       if (f->actual == NULL)
2772         {
2773           a = gfc_get_actual_arglist ();
2774           a->missing_arg_type = f->ts.type;
2775         }
2776       else
2777         a = f->actual;
2778
2779       if (actual == NULL)
2780         *ap = a;
2781       else
2782         actual->next = a;
2783
2784       actual = a;
2785     }
2786   actual->next = NULL;          /* End the sorted argument list.  */
2787
2788   return SUCCESS;
2789 }
2790
2791
2792 /* Compare an actual argument list with an intrinsic's formal argument
2793    list.  The lists are checked for agreement of type.  We don't check
2794    for arrayness here.  */
2795
2796 static try
2797 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2798                int error_flag)
2799 {
2800   gfc_actual_arglist *actual;
2801   gfc_intrinsic_arg *formal;
2802   int i;
2803
2804   formal = sym->formal;
2805   actual = *ap;
2806
2807   i = 0;
2808   for (; formal; formal = formal->next, actual = actual->next, i++)
2809     {
2810       if (actual->expr == NULL)
2811         continue;
2812
2813       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2814         {
2815           if (error_flag)
2816             gfc_error
2817               ("Type of argument '%s' in call to '%s' at %L should be "
2818                "%s, not %s", gfc_current_intrinsic_arg[i],
2819                gfc_current_intrinsic, &actual->expr->where,
2820                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2821           return FAILURE;
2822         }
2823     }
2824
2825   return SUCCESS;
2826 }
2827
2828
2829 /* Given a pointer to an intrinsic symbol and an expression node that
2830    represent the function call to that subroutine, figure out the type
2831    of the result.  This may involve calling a resolution subroutine.  */
2832
2833 static void
2834 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2835 {
2836   gfc_expr *a1, *a2, *a3, *a4, *a5;
2837   gfc_actual_arglist *arg;
2838
2839   if (specific->resolve.f1 == NULL)
2840     {
2841       if (e->value.function.name == NULL)
2842         e->value.function.name = specific->lib_name;
2843
2844       if (e->ts.type == BT_UNKNOWN)
2845         e->ts = specific->ts;
2846       return;
2847     }
2848
2849   arg = e->value.function.actual;
2850
2851   /* Special case hacks for MIN and MAX.  */
2852   if (specific->resolve.f1m == gfc_resolve_max
2853       || specific->resolve.f1m == gfc_resolve_min)
2854     {
2855       (*specific->resolve.f1m) (e, arg);
2856       return;
2857     }
2858
2859   if (arg == NULL)
2860     {
2861       (*specific->resolve.f0) (e);
2862       return;
2863     }
2864
2865   a1 = arg->expr;
2866   arg = arg->next;
2867
2868   if (arg == NULL)
2869     {
2870       (*specific->resolve.f1) (e, a1);
2871       return;
2872     }
2873
2874   a2 = arg->expr;
2875   arg = arg->next;
2876
2877   if (arg == NULL)
2878     {
2879       (*specific->resolve.f2) (e, a1, a2);
2880       return;
2881     }
2882
2883   a3 = arg->expr;
2884   arg = arg->next;
2885
2886   if (arg == NULL)
2887     {
2888       (*specific->resolve.f3) (e, a1, a2, a3);
2889       return;
2890     }
2891
2892   a4 = arg->expr;
2893   arg = arg->next;
2894
2895   if (arg == NULL)
2896     {
2897       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2898       return;
2899     }
2900
2901   a5 = arg->expr;
2902   arg = arg->next;
2903
2904   if (arg == NULL)
2905     {
2906       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2907       return;
2908     }
2909
2910   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2911 }
2912
2913
2914 /* Given an intrinsic symbol node and an expression node, call the
2915    simplification function (if there is one), perhaps replacing the
2916    expression with something simpler.  We return FAILURE on an error
2917    of the simplification, SUCCESS if the simplification worked, even
2918    if nothing has changed in the expression itself.  */
2919
2920 static try
2921 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2922 {
2923   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2924   gfc_actual_arglist *arg;
2925
2926   /* Check the arguments if there are Hollerith constants. We deal with
2927      them at run-time.  */
2928   for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
2929     {
2930       if (arg->expr && arg->expr->from_H)
2931         {
2932           result = NULL;
2933           goto finish;
2934         }
2935     }
2936   /* Max and min require special handling due to the variable number
2937      of args.  */
2938   if (specific->simplify.f1 == gfc_simplify_min)
2939     {
2940       result = gfc_simplify_min (e);
2941       goto finish;
2942     }
2943
2944   if (specific->simplify.f1 == gfc_simplify_max)
2945     {
2946       result = gfc_simplify_max (e);
2947       goto finish;
2948     }
2949
2950   if (specific->simplify.f1 == NULL)
2951     {
2952       result = NULL;
2953       goto finish;
2954     }
2955
2956   arg = e->value.function.actual;
2957
2958   if (arg == NULL)
2959     {
2960       result = (*specific->simplify.f0) ();
2961       goto finish;
2962     }
2963
2964   a1 = arg->expr;
2965   arg = arg->next;
2966
2967   if (specific->simplify.cc == gfc_convert_constant)
2968     {
2969       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2970       goto finish;
2971     }
2972
2973   /* TODO: Warn if -pedantic and initialization expression and arg
2974      types not integer or character */
2975
2976   if (arg == NULL)
2977     result = (*specific->simplify.f1) (a1);
2978   else
2979     {
2980       a2 = arg->expr;
2981       arg = arg->next;
2982
2983       if (arg == NULL)
2984         result = (*specific->simplify.f2) (a1, a2);
2985       else
2986         {
2987           a3 = arg->expr;
2988           arg = arg->next;
2989
2990           if (arg == NULL)
2991             result = (*specific->simplify.f3) (a1, a2, a3);
2992           else
2993             {
2994               a4 = arg->expr;
2995               arg = arg->next;
2996
2997               if (arg == NULL)
2998                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2999               else
3000                 {
3001                   a5 = arg->expr;
3002                   arg = arg->next;
3003
3004                   if (arg == NULL)
3005                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
3006                   else
3007                     gfc_internal_error
3008                       ("do_simplify(): Too many args for intrinsic");
3009                 }
3010             }
3011         }
3012     }
3013
3014 finish:
3015   if (result == &gfc_bad_expr)
3016     return FAILURE;
3017
3018   if (result == NULL)
3019     resolve_intrinsic (specific, e);    /* Must call at run-time */
3020   else
3021     {
3022       result->where = e->where;
3023       gfc_replace_expr (e, result);
3024     }
3025
3026   return SUCCESS;
3027 }
3028
3029
3030 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
3031    error messages.  This subroutine returns FAILURE if a subroutine
3032    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
3033    list cannot match any intrinsic.  */
3034
3035 static void
3036 init_arglist (gfc_intrinsic_sym * isym)
3037 {
3038   gfc_intrinsic_arg *formal;
3039   int i;
3040
3041   gfc_current_intrinsic = isym->name;
3042
3043   i = 0;
3044   for (formal = isym->formal; formal; formal = formal->next)
3045     {
3046       if (i >= MAX_INTRINSIC_ARGS)
3047         gfc_internal_error ("init_arglist(): too many arguments");
3048       gfc_current_intrinsic_arg[i++] = formal->name;
3049     }
3050 }
3051
3052
3053 /* Given a pointer to an intrinsic symbol and an expression consisting
3054    of a function call, see if the function call is consistent with the
3055    intrinsic's formal argument list.  Return SUCCESS if the expression
3056    and intrinsic match, FAILURE otherwise.  */
3057
3058 static try
3059 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
3060 {
3061   gfc_actual_arglist *arg, **ap;
3062   int r;
3063   try t;
3064
3065   ap = &expr->value.function.actual;
3066
3067   init_arglist (specific);
3068
3069   /* Don't attempt to sort the argument list for min or max.  */
3070   if (specific->check.f1m == gfc_check_min_max
3071       || specific->check.f1m == gfc_check_min_max_integer
3072       || specific->check.f1m == gfc_check_min_max_real
3073       || specific->check.f1m == gfc_check_min_max_double)
3074     return (*specific->check.f1m) (*ap);
3075
3076   if (sort_actual (specific->name, ap, specific->formal,
3077                    &expr->where) == FAILURE)
3078     return FAILURE;
3079
3080   if (specific->check.f3ml == gfc_check_minloc_maxloc)
3081     /* This is special because we might have to reorder the argument
3082        list.  */
3083     t = gfc_check_minloc_maxloc (*ap);
3084   else if (specific->check.f3red == gfc_check_minval_maxval)
3085     /* This is also special because we also might have to reorder the
3086        argument list.  */
3087     t = gfc_check_minval_maxval (*ap);
3088   else if (specific->check.f3red == gfc_check_product_sum)
3089     /* Same here. The difference to the previous case is that we allow a
3090        general numeric type.  */
3091     t = gfc_check_product_sum (*ap);
3092   else
3093      {
3094        if (specific->check.f1 == NULL)
3095          {
3096            t = check_arglist (ap, specific, error_flag);
3097            if (t == SUCCESS)
3098              expr->ts = specific->ts;
3099          }
3100        else
3101          t = do_check (specific, *ap);
3102      }
3103
3104   /* Check ranks for elemental intrinsics.  */
3105   if (t == SUCCESS && specific->elemental)
3106     {
3107       r = 0;
3108       for (arg = expr->value.function.actual; arg; arg = arg->next)
3109         {
3110           if (arg->expr == NULL || arg->expr->rank == 0)
3111             continue;
3112           if (r == 0)
3113             {
3114               r = arg->expr->rank;
3115               continue;
3116             }
3117
3118           if (arg->expr->rank != r)
3119             {
3120               gfc_error
3121                 ("Ranks of arguments to elemental intrinsic '%s' differ "
3122                  "at %L", specific->name, &arg->expr->where);
3123               return FAILURE;
3124             }
3125         }
3126     }
3127
3128   if (t == FAILURE)
3129     remove_nullargs (ap);
3130
3131   return t;
3132 }
3133
3134
3135 /* See if an intrinsic is one of the intrinsics we evaluate
3136    as an extension.  */
3137
3138 static int
3139 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
3140 {
3141   /* FIXME: This should be moved into the intrinsic definitions.  */
3142   static const char * const init_expr_extensions[] = {
3143     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
3144     "precision", "present", "radix", "range", "selected_real_kind",
3145     "tiny", NULL
3146   };
3147
3148   int i;
3149
3150   for (i = 0; init_expr_extensions[i]; i++)
3151     if (strcmp (init_expr_extensions[i], isym->name) == 0)
3152       return 0;
3153
3154   return 1;
3155 }
3156
3157
3158 /* Check whether an intrinsic belongs to whatever standard the user
3159    has chosen.  */
3160
3161 static void
3162 check_intrinsic_standard (const char *name, int standard, locus * where)
3163 {
3164   if (!gfc_option.warn_nonstd_intrinsics)
3165     return;
3166
3167   gfc_notify_std (standard, "Intrinsic '%s' at %L is not included "
3168                   "in the selected standard", name, where);
3169 }
3170
3171
3172 /* See if a function call corresponds to an intrinsic function call.
3173    We return:
3174
3175     MATCH_YES    if the call corresponds to an intrinsic, simplification
3176                  is done if possible.
3177
3178     MATCH_NO     if the call does not correspond to an intrinsic
3179
3180     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
3181                  error during the simplification process.
3182
3183    The error_flag parameter enables an error reporting.  */
3184
3185 match
3186 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
3187 {
3188   gfc_intrinsic_sym *isym, *specific;
3189   gfc_actual_arglist *actual;
3190   const char *name;
3191   int flag;
3192
3193   if (expr->value.function.isym != NULL)
3194     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3195       ? MATCH_ERROR : MATCH_YES;
3196
3197   gfc_suppress_error = !error_flag;
3198   flag = 0;
3199
3200   for (actual = expr->value.function.actual; actual; actual = actual->next)
3201     if (actual->expr != NULL)
3202       flag |= (actual->expr->ts.type != BT_INTEGER
3203                && actual->expr->ts.type != BT_CHARACTER);
3204
3205   name = expr->symtree->n.sym->name;
3206
3207   isym = specific = gfc_find_function (name);
3208   if (isym == NULL)
3209     {
3210       gfc_suppress_error = 0;
3211       return MATCH_NO;
3212     }
3213
3214   gfc_current_intrinsic_where = &expr->where;
3215
3216   /* Bypass the generic list for min and max.  */
3217   if (isym->check.f1m == gfc_check_min_max)
3218     {
3219       init_arglist (isym);
3220
3221       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3222         goto got_specific;
3223
3224       gfc_suppress_error = 0;
3225       return MATCH_NO;
3226     }
3227
3228   /* If the function is generic, check all of its specific
3229      incarnations.  If the generic name is also a specific, we check
3230      that name last, so that any error message will correspond to the
3231      specific.  */
3232   gfc_suppress_error = 1;
3233
3234   if (isym->generic)
3235     {
3236       for (specific = isym->specific_head; specific;
3237            specific = specific->next)
3238         {
3239           if (specific == isym)
3240             continue;
3241           if (check_specific (specific, expr, 0) == SUCCESS)
3242             goto got_specific;
3243         }
3244     }
3245
3246   gfc_suppress_error = !error_flag;
3247
3248   if (check_specific (isym, expr, error_flag) == FAILURE)
3249     {
3250       gfc_suppress_error = 0;
3251       return MATCH_NO;
3252     }
3253
3254   specific = isym;
3255
3256 got_specific:
3257   expr->value.function.isym = specific;
3258   gfc_intrinsic_symbol (expr->symtree->n.sym);
3259
3260   gfc_suppress_error = 0;
3261   if (do_simplify (specific, expr) == FAILURE)
3262     return MATCH_ERROR;
3263
3264   /* TODO: We should probably only allow elemental functions here.  */
3265   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3266
3267   if (pedantic && gfc_init_expr
3268       && flag && gfc_init_expr_extensions (specific))
3269     {
3270       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3271             "nonstandard initialization expression at %L", &expr->where)
3272           == FAILURE)
3273         {
3274           return MATCH_ERROR;
3275         }
3276     }
3277
3278   check_intrinsic_standard (name, isym->standard, &expr->where);
3279
3280   return MATCH_YES;
3281 }
3282
3283
3284 /* See if a CALL statement corresponds to an intrinsic subroutine.
3285    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3286    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3287    correspond).  */
3288
3289 match
3290 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3291 {
3292   gfc_intrinsic_sym *isym;
3293   const char *name;
3294
3295   name = c->symtree->n.sym->name;
3296
3297   isym = find_subroutine (name);
3298   if (isym == NULL)
3299     return MATCH_NO;
3300
3301   gfc_suppress_error = !error_flag;
3302
3303   init_arglist (isym);
3304
3305   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3306     goto fail;
3307
3308   if (isym->check.f1 != NULL)
3309     {
3310       if (do_check (isym, c->ext.actual) == FAILURE)
3311         goto fail;
3312     }
3313   else
3314     {
3315       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3316         goto fail;
3317     }
3318
3319   /* The subroutine corresponds to an intrinsic.  Allow errors to be
3320      seen at this point.  */
3321   gfc_suppress_error = 0;
3322
3323   if (isym->resolve.s1 != NULL)
3324     isym->resolve.s1 (c);
3325   else
3326     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3327
3328   if (gfc_pure (NULL) && !isym->elemental)
3329     {
3330       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3331                  &c->loc);
3332       return MATCH_ERROR;
3333     }
3334
3335   c->resolved_sym->attr.noreturn = isym->noreturn;
3336   check_intrinsic_standard (name, isym->standard, &c->loc);
3337
3338   return MATCH_YES;
3339
3340 fail:
3341   gfc_suppress_error = 0;
3342   return MATCH_NO;
3343 }
3344
3345
3346 /* Call gfc_convert_type() with warning enabled.  */
3347
3348 try
3349 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3350 {
3351   return gfc_convert_type_warn (expr, ts, eflag, 1);
3352 }
3353
3354
3355 /* Try to convert an expression (in place) from one type to another.
3356    'eflag' controls the behavior on error.
3357
3358    The possible values are:
3359
3360      1 Generate a gfc_error()
3361      2 Generate a gfc_internal_error().
3362
3363    'wflag' controls the warning related to conversion.  */
3364
3365 try
3366 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3367                        int wflag)
3368 {
3369   gfc_intrinsic_sym *sym;
3370   gfc_typespec from_ts;
3371   locus old_where;
3372   gfc_expr *new;
3373   int rank;
3374   mpz_t *shape;
3375
3376   from_ts = expr->ts;           /* expr->ts gets clobbered */
3377
3378   if (ts->type == BT_UNKNOWN)
3379     goto bad;
3380
3381   /* NULL and zero size arrays get their type here.  */
3382   if (expr->expr_type == EXPR_NULL
3383       || (expr->expr_type == EXPR_ARRAY
3384           && expr->value.constructor == NULL))
3385     {
3386       /* Sometimes the RHS acquire the type.  */
3387       expr->ts = *ts;
3388       return SUCCESS;
3389     }
3390
3391   if (expr->ts.type == BT_UNKNOWN)
3392     goto bad;
3393
3394   if (expr->ts.type == BT_DERIVED
3395       && ts->type == BT_DERIVED
3396       && gfc_compare_types (&expr->ts, ts))
3397     return SUCCESS;
3398
3399   sym = find_conv (&expr->ts, ts);
3400   if (sym == NULL)
3401     goto bad;
3402
3403   /* At this point, a conversion is necessary. A warning may be needed.  */
3404   if ((gfc_option.warn_std & sym->standard) != 0)
3405     gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3406                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3407   else if (wflag && gfc_option.warn_conversion)
3408     gfc_warning_now ("Conversion from %s to %s at %L",
3409                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3410
3411   /* Insert a pre-resolved function call to the right function.  */
3412   old_where = expr->where;
3413   rank = expr->rank;
3414   shape = expr->shape;
3415
3416   new = gfc_get_expr ();
3417   *new = *expr;
3418
3419   new = gfc_build_conversion (new);
3420   new->value.function.name = sym->lib_name;
3421   new->value.function.isym = sym;
3422   new->where = old_where;
3423   new->rank = rank;
3424   new->shape = gfc_copy_shape (shape, rank);
3425
3426   gfc_get_ha_sym_tree (sym->name, &new->symtree);
3427   new->symtree->n.sym->ts = *ts;
3428   new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
3429   new->symtree->n.sym->attr.function = 1;
3430   new->symtree->n.sym->attr.intrinsic = 1;
3431   new->symtree->n.sym->attr.elemental = 1;
3432   new->symtree->n.sym->attr.pure = 1;
3433   new->symtree->n.sym->attr.referenced = 1;
3434   gfc_intrinsic_symbol(new->symtree->n.sym);
3435   gfc_commit_symbol (new->symtree->n.sym);
3436
3437   *expr = *new;
3438
3439   gfc_free (new);
3440   expr->ts = *ts;
3441
3442   if (gfc_is_constant_expr (expr->value.function.actual->expr)
3443       && do_simplify (sym, expr) == FAILURE)
3444     {
3445
3446       if (eflag == 2)
3447         goto bad;
3448       return FAILURE;           /* Error already generated in do_simplify() */
3449     }
3450
3451   return SUCCESS;
3452
3453 bad:
3454   if (eflag == 1)
3455     {
3456       gfc_error ("Can't convert %s to %s at %L",
3457                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3458       return FAILURE;
3459     }
3460
3461   gfc_internal_error ("Can't convert %s to %s at %L",
3462                       gfc_typename (&from_ts), gfc_typename (ts),
3463                       &expr->where);
3464   /* Not reached */
3465 }