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   if ((gfc_option.allow_std & GFC_STD_GNU) || gfc_option.flag_all_intrinsics)
2236     make_noreturn();
2237
2238   add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2239               gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2240               tm, BT_REAL, dr, REQUIRED);
2241
2242   /* More G77 compatibility garbage.  */
2243   add_sym_2s ("ctime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2244              gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
2245              tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
2246
2247   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2248               gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2249               tm, BT_REAL, dr, REQUIRED);
2250
2251   add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2252               gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2253               name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2254
2255   add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2256               gfc_check_date_and_time, NULL, NULL,
2257               dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2258               zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2259
2260   /* More G77 compatibility garbage.  */
2261   add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2262              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2263               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2264
2265   add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2266              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2267               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2268
2269   add_sym_1s ("fdate", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2270              gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
2271              dt, BT_CHARACTER, dc, REQUIRED);
2272
2273   add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2274               gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
2275               dc, REQUIRED);
2276
2277   add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2278           gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2279               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2280
2281   add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2282               NULL, NULL, NULL,
2283               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2284
2285   add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2286               NULL, NULL, gfc_resolve_getarg,
2287               c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2288
2289   add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2290               gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2291               dc, REQUIRED);
2292
2293   /* F2003 commandline routines.  */
2294
2295   add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2296               NULL, NULL, gfc_resolve_get_command,
2297               com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
2298               st, BT_INTEGER, di, OPTIONAL);
2299
2300   add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2301               NULL, NULL, gfc_resolve_get_command_argument,
2302               num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2303               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2304
2305   /* F2003 subroutine to get environment variables.  */
2306
2307   add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2308              NULL, NULL, gfc_resolve_get_environment_variable,
2309               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2310               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2311               trim_name, BT_LOGICAL, dl, OPTIONAL);
2312
2313   add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2314               gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2315               f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2316               ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2317               tp, BT_INTEGER, di, REQUIRED);
2318
2319   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2320               gfc_check_random_number, NULL, gfc_resolve_random_number,
2321               h, BT_REAL, dr, REQUIRED);
2322
2323   add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2324              gfc_check_random_seed, NULL, NULL,
2325               sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2326               gt, BT_INTEGER, di, OPTIONAL);
2327
2328   /* More G77 compatibility garbage.  */
2329   add_sym_3s ("alarm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2330               gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
2331               sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2332               st, BT_INTEGER, di, OPTIONAL);
2333
2334   add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU,
2335              gfc_check_srand, NULL, gfc_resolve_srand,
2336               c, BT_INTEGER, 4, REQUIRED);
2337
2338   add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2339              gfc_check_exit, NULL, gfc_resolve_exit,
2340               c, BT_INTEGER, di, OPTIONAL);
2341
2342   if ((gfc_option.allow_std & GFC_STD_GNU) || gfc_option.flag_all_intrinsics)
2343     make_noreturn();
2344
2345   add_sym_3s ("fgetc", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2346               gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
2347               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2348               st, BT_INTEGER, di, OPTIONAL);
2349
2350   add_sym_2s ("fget", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2351               gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
2352               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2353
2354   add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2355               gfc_check_flush, NULL, gfc_resolve_flush,
2356               c, BT_INTEGER, di, OPTIONAL);
2357
2358   add_sym_3s ("fputc", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2359               gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
2360               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2361               st, BT_INTEGER, di, OPTIONAL);
2362
2363   add_sym_2s ("fput", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2364               gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
2365               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2366
2367   add_sym_1s ("free", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
2368               NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
2369
2370   add_sym_2s ("ftell", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2371               gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
2372               ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
2373
2374   add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2375           gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2376               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2377
2378   add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2379               NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2380               val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2381
2382   add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2383               gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2384               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2385               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2386
2387   add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2388           gfc_check_perror, NULL, gfc_resolve_perror,
2389               c, BT_CHARACTER, dc, REQUIRED);
2390
2391   add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2392               gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2393               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2394               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2395
2396   add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2397               gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2398               val, BT_CHARACTER, dc, REQUIRED);
2399
2400   add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2401               gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2402               ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2403               st, BT_INTEGER, di, OPTIONAL);
2404
2405   add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2406               gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2407               name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2408               st, BT_INTEGER, di, OPTIONAL);
2409
2410   add_sym_3s ("signal", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2411               gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
2412               num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2413               st, BT_INTEGER, di, OPTIONAL);
2414
2415   add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2416               gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2417               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2418               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2419
2420   add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2421               NULL, NULL, gfc_resolve_system_sub,
2422               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2423
2424   add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2425              gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2426               c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2427               cm, BT_INTEGER, di, OPTIONAL);
2428
2429   add_sym_2s ("ttynam", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2430               gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
2431               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
2432
2433   add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2434           gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2435               val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2436
2437   add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2438           gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2439               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2440
2441 }
2442
2443
2444 /* Add a function to the list of conversion symbols.  */
2445
2446 static void
2447 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2448 {
2449
2450   gfc_typespec from, to;
2451   gfc_intrinsic_sym *sym;
2452
2453   if (sizing == SZ_CONVS)
2454     {
2455       nconv++;
2456       return;
2457     }
2458
2459   gfc_clear_ts (&from);
2460   from.type = from_type;
2461   from.kind = from_kind;
2462
2463   gfc_clear_ts (&to);
2464   to.type = to_type;
2465   to.kind = to_kind;
2466
2467   sym = conversion + nconv;
2468
2469   sym->name = conv_name (&from, &to);
2470   sym->lib_name = sym->name;
2471   sym->simplify.cc = gfc_convert_constant;
2472   sym->standard = standard;
2473   sym->elemental = 1;
2474   sym->ts = to;
2475   sym->generic_id = GFC_ISYM_CONVERSION;
2476
2477   nconv++;
2478 }
2479
2480
2481 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2482    functions by looping over the kind tables.  */
2483
2484 static void
2485 add_conversions (void)
2486 {
2487   int i, j;
2488
2489   /* Integer-Integer conversions.  */
2490   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2491     for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2492       {
2493         if (i == j)
2494           continue;
2495
2496         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2497                   BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2498       }
2499
2500   /* Integer-Real/Complex conversions.  */
2501   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2502     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2503       {
2504         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2505                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2506
2507         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2508                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2509
2510         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2511                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2512
2513         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2514                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2515       }
2516
2517   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2518     {
2519       /* Hollerith-Integer conversions.  */
2520       for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2521         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2522                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2523       /* Hollerith-Real conversions.  */
2524       for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2525         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2526                   BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2527       /* Hollerith-Complex conversions.  */
2528       for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2529         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2530                   BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2531
2532       /* Hollerith-Character conversions.  */
2533       add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2534                   gfc_default_character_kind, GFC_STD_LEGACY);
2535
2536       /* Hollerith-Logical conversions.  */
2537       for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
2538         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2539                   BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
2540     }
2541
2542   /* Real/Complex - Real/Complex conversions.  */
2543   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2544     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2545       {
2546         if (i != j)
2547           {
2548             add_conv (BT_REAL, gfc_real_kinds[i].kind,
2549                       BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2550
2551             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2552                       BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2553           }
2554
2555         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2556                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2557
2558         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2559                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2560       }
2561
2562   /* Logical/Logical kind conversion.  */
2563   for (i = 0; gfc_logical_kinds[i].kind; i++)
2564     for (j = 0; gfc_logical_kinds[j].kind; j++)
2565       {
2566         if (i == j)
2567           continue;
2568
2569         add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2570                   BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2571       }
2572
2573   /* Integer-Logical and Logical-Integer conversions.  */
2574   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2575     for (i=0; gfc_integer_kinds[i].kind; i++)
2576       for (j=0; gfc_logical_kinds[j].kind; j++)
2577         {
2578           add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2579                     BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2580           add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2581                     BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2582         }
2583 }
2584
2585
2586 /* Initialize the table of intrinsics.  */
2587 void
2588 gfc_intrinsic_init_1 (void)
2589 {
2590   int i;
2591
2592   nargs = nfunc = nsub = nconv = 0;
2593
2594   /* Create a namespace to hold the resolved intrinsic symbols.  */
2595   gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2596
2597   sizing = SZ_FUNCS;
2598   add_functions ();
2599   sizing = SZ_SUBS;
2600   add_subroutines ();
2601   sizing = SZ_CONVS;
2602   add_conversions ();
2603
2604   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2605                           + sizeof (gfc_intrinsic_arg) * nargs);
2606
2607   next_sym = functions;
2608   subroutines = functions + nfunc;
2609
2610   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2611
2612   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2613
2614   sizing = SZ_NOTHING;
2615   nconv = 0;
2616
2617   add_functions ();
2618   add_subroutines ();
2619   add_conversions ();
2620
2621   /* Set the pure flag.  All intrinsic functions are pure, and
2622      intrinsic subroutines are pure if they are elemental.  */
2623
2624   for (i = 0; i < nfunc; i++)
2625     functions[i].pure = 1;
2626
2627   for (i = 0; i < nsub; i++)
2628     subroutines[i].pure = subroutines[i].elemental;
2629 }
2630
2631
2632 void
2633 gfc_intrinsic_done_1 (void)
2634 {
2635   gfc_free (functions);
2636   gfc_free (conversion);
2637   gfc_free_namespace (gfc_intrinsic_namespace);
2638 }
2639
2640
2641 /******** Subroutines to check intrinsic interfaces ***********/
2642
2643 /* Given a formal argument list, remove any NULL arguments that may
2644    have been left behind by a sort against some formal argument list.  */
2645
2646 static void
2647 remove_nullargs (gfc_actual_arglist ** ap)
2648 {
2649   gfc_actual_arglist *head, *tail, *next;
2650
2651   tail = NULL;
2652
2653   for (head = *ap; head; head = next)
2654     {
2655       next = head->next;
2656
2657       if (head->expr == NULL)
2658         {
2659           head->next = NULL;
2660           gfc_free_actual_arglist (head);
2661         }
2662       else
2663         {
2664           if (tail == NULL)
2665             *ap = head;
2666           else
2667             tail->next = head;
2668
2669           tail = head;
2670           tail->next = NULL;
2671         }
2672     }
2673
2674   if (tail == NULL)
2675     *ap = NULL;
2676 }
2677
2678
2679 /* Given an actual arglist and a formal arglist, sort the actual
2680    arglist so that its arguments are in a one-to-one correspondence
2681    with the format arglist.  Arguments that are not present are given
2682    a blank gfc_actual_arglist structure.  If something is obviously
2683    wrong (say, a missing required argument) we abort sorting and
2684    return FAILURE.  */
2685
2686 static try
2687 sort_actual (const char *name, gfc_actual_arglist ** ap,
2688              gfc_intrinsic_arg * formal, locus * where)
2689 {
2690
2691   gfc_actual_arglist *actual, *a;
2692   gfc_intrinsic_arg *f;
2693
2694   remove_nullargs (ap);
2695   actual = *ap;
2696
2697   for (f = formal; f; f = f->next)
2698     f->actual = NULL;
2699
2700   f = formal;
2701   a = actual;
2702
2703   if (f == NULL && a == NULL)   /* No arguments */
2704     return SUCCESS;
2705
2706   for (;;)
2707     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2708       if (f == NULL)
2709         break;
2710       if (a == NULL)
2711         goto optional;
2712
2713       if (a->name != NULL)
2714         goto keywords;
2715
2716       f->actual = a;
2717
2718       f = f->next;
2719       a = a->next;
2720     }
2721
2722   if (a == NULL)
2723     goto do_sort;
2724
2725   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2726   return FAILURE;
2727
2728 keywords:
2729   /* Associate the remaining actual arguments, all of which have
2730      to be keyword arguments.  */
2731   for (; a; a = a->next)
2732     {
2733       for (f = formal; f; f = f->next)
2734         if (strcmp (a->name, f->name) == 0)
2735           break;
2736
2737       if (f == NULL)
2738         {
2739           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2740                      a->name, name, where);
2741           return FAILURE;
2742         }
2743
2744       if (f->actual != NULL)
2745         {
2746           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2747                      f->name, name, where);
2748           return FAILURE;
2749         }
2750
2751       f->actual = a;
2752     }
2753
2754 optional:
2755   /* At this point, all unmatched formal args must be optional.  */
2756   for (f = formal; f; f = f->next)
2757     {
2758       if (f->actual == NULL && f->optional == 0)
2759         {
2760           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2761                      f->name, name, where);
2762           return FAILURE;
2763         }
2764     }
2765
2766 do_sort:
2767   /* Using the formal argument list, string the actual argument list
2768      together in a way that corresponds with the formal list.  */
2769   actual = NULL;
2770
2771   for (f = formal; f; f = f->next)
2772     {
2773       if (f->actual == NULL)
2774         {
2775           a = gfc_get_actual_arglist ();
2776           a->missing_arg_type = f->ts.type;
2777         }
2778       else
2779         a = f->actual;
2780
2781       if (actual == NULL)
2782         *ap = a;
2783       else
2784         actual->next = a;
2785
2786       actual = a;
2787     }
2788   actual->next = NULL;          /* End the sorted argument list.  */
2789
2790   return SUCCESS;
2791 }
2792
2793
2794 /* Compare an actual argument list with an intrinsic's formal argument
2795    list.  The lists are checked for agreement of type.  We don't check
2796    for arrayness here.  */
2797
2798 static try
2799 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2800                int error_flag)
2801 {
2802   gfc_actual_arglist *actual;
2803   gfc_intrinsic_arg *formal;
2804   int i;
2805
2806   formal = sym->formal;
2807   actual = *ap;
2808
2809   i = 0;
2810   for (; formal; formal = formal->next, actual = actual->next, i++)
2811     {
2812       if (actual->expr == NULL)
2813         continue;
2814
2815       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2816         {
2817           if (error_flag)
2818             gfc_error
2819               ("Type of argument '%s' in call to '%s' at %L should be "
2820                "%s, not %s", gfc_current_intrinsic_arg[i],
2821                gfc_current_intrinsic, &actual->expr->where,
2822                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2823           return FAILURE;
2824         }
2825     }
2826
2827   return SUCCESS;
2828 }
2829
2830
2831 /* Given a pointer to an intrinsic symbol and an expression node that
2832    represent the function call to that subroutine, figure out the type
2833    of the result.  This may involve calling a resolution subroutine.  */
2834
2835 static void
2836 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2837 {
2838   gfc_expr *a1, *a2, *a3, *a4, *a5;
2839   gfc_actual_arglist *arg;
2840
2841   if (specific->resolve.f1 == NULL)
2842     {
2843       if (e->value.function.name == NULL)
2844         e->value.function.name = specific->lib_name;
2845
2846       if (e->ts.type == BT_UNKNOWN)
2847         e->ts = specific->ts;
2848       return;
2849     }
2850
2851   arg = e->value.function.actual;
2852
2853   /* Special case hacks for MIN and MAX.  */
2854   if (specific->resolve.f1m == gfc_resolve_max
2855       || specific->resolve.f1m == gfc_resolve_min)
2856     {
2857       (*specific->resolve.f1m) (e, arg);
2858       return;
2859     }
2860
2861   if (arg == NULL)
2862     {
2863       (*specific->resolve.f0) (e);
2864       return;
2865     }
2866
2867   a1 = arg->expr;
2868   arg = arg->next;
2869
2870   if (arg == NULL)
2871     {
2872       (*specific->resolve.f1) (e, a1);
2873       return;
2874     }
2875
2876   a2 = arg->expr;
2877   arg = arg->next;
2878
2879   if (arg == NULL)
2880     {
2881       (*specific->resolve.f2) (e, a1, a2);
2882       return;
2883     }
2884
2885   a3 = arg->expr;
2886   arg = arg->next;
2887
2888   if (arg == NULL)
2889     {
2890       (*specific->resolve.f3) (e, a1, a2, a3);
2891       return;
2892     }
2893
2894   a4 = arg->expr;
2895   arg = arg->next;
2896
2897   if (arg == NULL)
2898     {
2899       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2900       return;
2901     }
2902
2903   a5 = arg->expr;
2904   arg = arg->next;
2905
2906   if (arg == NULL)
2907     {
2908       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2909       return;
2910     }
2911
2912   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2913 }
2914
2915
2916 /* Given an intrinsic symbol node and an expression node, call the
2917    simplification function (if there is one), perhaps replacing the
2918    expression with something simpler.  We return FAILURE on an error
2919    of the simplification, SUCCESS if the simplification worked, even
2920    if nothing has changed in the expression itself.  */
2921
2922 static try
2923 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2924 {
2925   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2926   gfc_actual_arglist *arg;
2927
2928   /* Check the arguments if there are Hollerith constants. We deal with
2929      them at run-time.  */
2930   for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
2931     {
2932       if (arg->expr && arg->expr->from_H)
2933         {
2934           result = NULL;
2935           goto finish;
2936         }
2937     }
2938   /* Max and min require special handling due to the variable number
2939      of args.  */
2940   if (specific->simplify.f1 == gfc_simplify_min)
2941     {
2942       result = gfc_simplify_min (e);
2943       goto finish;
2944     }
2945
2946   if (specific->simplify.f1 == gfc_simplify_max)
2947     {
2948       result = gfc_simplify_max (e);
2949       goto finish;
2950     }
2951
2952   if (specific->simplify.f1 == NULL)
2953     {
2954       result = NULL;
2955       goto finish;
2956     }
2957
2958   arg = e->value.function.actual;
2959
2960   if (arg == NULL)
2961     {
2962       result = (*specific->simplify.f0) ();
2963       goto finish;
2964     }
2965
2966   a1 = arg->expr;
2967   arg = arg->next;
2968
2969   if (specific->simplify.cc == gfc_convert_constant)
2970     {
2971       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2972       goto finish;
2973     }
2974
2975   /* TODO: Warn if -pedantic and initialization expression and arg
2976      types not integer or character */
2977
2978   if (arg == NULL)
2979     result = (*specific->simplify.f1) (a1);
2980   else
2981     {
2982       a2 = arg->expr;
2983       arg = arg->next;
2984
2985       if (arg == NULL)
2986         result = (*specific->simplify.f2) (a1, a2);
2987       else
2988         {
2989           a3 = arg->expr;
2990           arg = arg->next;
2991
2992           if (arg == NULL)
2993             result = (*specific->simplify.f3) (a1, a2, a3);
2994           else
2995             {
2996               a4 = arg->expr;
2997               arg = arg->next;
2998
2999               if (arg == NULL)
3000                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
3001               else
3002                 {
3003                   a5 = arg->expr;
3004                   arg = arg->next;
3005
3006                   if (arg == NULL)
3007                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
3008                   else
3009                     gfc_internal_error
3010                       ("do_simplify(): Too many args for intrinsic");
3011                 }
3012             }
3013         }
3014     }
3015
3016 finish:
3017   if (result == &gfc_bad_expr)
3018     return FAILURE;
3019
3020   if (result == NULL)
3021     resolve_intrinsic (specific, e);    /* Must call at run-time */
3022   else
3023     {
3024       result->where = e->where;
3025       gfc_replace_expr (e, result);
3026     }
3027
3028   return SUCCESS;
3029 }
3030
3031
3032 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
3033    error messages.  This subroutine returns FAILURE if a subroutine
3034    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
3035    list cannot match any intrinsic.  */
3036
3037 static void
3038 init_arglist (gfc_intrinsic_sym * isym)
3039 {
3040   gfc_intrinsic_arg *formal;
3041   int i;
3042
3043   gfc_current_intrinsic = isym->name;
3044
3045   i = 0;
3046   for (formal = isym->formal; formal; formal = formal->next)
3047     {
3048       if (i >= MAX_INTRINSIC_ARGS)
3049         gfc_internal_error ("init_arglist(): too many arguments");
3050       gfc_current_intrinsic_arg[i++] = formal->name;
3051     }
3052 }
3053
3054
3055 /* Given a pointer to an intrinsic symbol and an expression consisting
3056    of a function call, see if the function call is consistent with the
3057    intrinsic's formal argument list.  Return SUCCESS if the expression
3058    and intrinsic match, FAILURE otherwise.  */
3059
3060 static try
3061 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
3062 {
3063   gfc_actual_arglist *arg, **ap;
3064   int r;
3065   try t;
3066
3067   ap = &expr->value.function.actual;
3068
3069   init_arglist (specific);
3070
3071   /* Don't attempt to sort the argument list for min or max.  */
3072   if (specific->check.f1m == gfc_check_min_max
3073       || specific->check.f1m == gfc_check_min_max_integer
3074       || specific->check.f1m == gfc_check_min_max_real
3075       || specific->check.f1m == gfc_check_min_max_double)
3076     return (*specific->check.f1m) (*ap);
3077
3078   if (sort_actual (specific->name, ap, specific->formal,
3079                    &expr->where) == FAILURE)
3080     return FAILURE;
3081
3082   if (specific->check.f3ml == gfc_check_minloc_maxloc)
3083     /* This is special because we might have to reorder the argument
3084        list.  */
3085     t = gfc_check_minloc_maxloc (*ap);
3086   else if (specific->check.f3red == gfc_check_minval_maxval)
3087     /* This is also special because we also might have to reorder the
3088        argument list.  */
3089     t = gfc_check_minval_maxval (*ap);
3090   else if (specific->check.f3red == gfc_check_product_sum)
3091     /* Same here. The difference to the previous case is that we allow a
3092        general numeric type.  */
3093     t = gfc_check_product_sum (*ap);
3094   else
3095      {
3096        if (specific->check.f1 == NULL)
3097          {
3098            t = check_arglist (ap, specific, error_flag);
3099            if (t == SUCCESS)
3100              expr->ts = specific->ts;
3101          }
3102        else
3103          t = do_check (specific, *ap);
3104      }
3105
3106   /* Check ranks for elemental intrinsics.  */
3107   if (t == SUCCESS && specific->elemental)
3108     {
3109       r = 0;
3110       for (arg = expr->value.function.actual; arg; arg = arg->next)
3111         {
3112           if (arg->expr == NULL || arg->expr->rank == 0)
3113             continue;
3114           if (r == 0)
3115             {
3116               r = arg->expr->rank;
3117               continue;
3118             }
3119
3120           if (arg->expr->rank != r)
3121             {
3122               gfc_error
3123                 ("Ranks of arguments to elemental intrinsic '%s' differ "
3124                  "at %L", specific->name, &arg->expr->where);
3125               return FAILURE;
3126             }
3127         }
3128     }
3129
3130   if (t == FAILURE)
3131     remove_nullargs (ap);
3132
3133   return t;
3134 }
3135
3136
3137 /* See if an intrinsic is one of the intrinsics we evaluate
3138    as an extension.  */
3139
3140 static int
3141 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
3142 {
3143   /* FIXME: This should be moved into the intrinsic definitions.  */
3144   static const char * const init_expr_extensions[] = {
3145     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
3146     "precision", "present", "radix", "range", "selected_real_kind",
3147     "tiny", NULL
3148   };
3149
3150   int i;
3151
3152   for (i = 0; init_expr_extensions[i]; i++)
3153     if (strcmp (init_expr_extensions[i], isym->name) == 0)
3154       return 0;
3155
3156   return 1;
3157 }
3158
3159
3160 /* Check whether an intrinsic belongs to whatever standard the user
3161    has chosen.  */
3162
3163 static void
3164 check_intrinsic_standard (const char *name, int standard, locus * where)
3165 {
3166   if (!gfc_option.warn_nonstd_intrinsics)
3167     return;
3168
3169   gfc_notify_std (standard, "Intrinsic '%s' at %L is not included "
3170                   "in the selected standard", name, where);
3171 }
3172
3173
3174 /* See if a function call corresponds to an intrinsic function call.
3175    We return:
3176
3177     MATCH_YES    if the call corresponds to an intrinsic, simplification
3178                  is done if possible.
3179
3180     MATCH_NO     if the call does not correspond to an intrinsic
3181
3182     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
3183                  error during the simplification process.
3184
3185    The error_flag parameter enables an error reporting.  */
3186
3187 match
3188 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
3189 {
3190   gfc_intrinsic_sym *isym, *specific;
3191   gfc_actual_arglist *actual;
3192   const char *name;
3193   int flag;
3194
3195   if (expr->value.function.isym != NULL)
3196     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3197       ? MATCH_ERROR : MATCH_YES;
3198
3199   gfc_suppress_error = !error_flag;
3200   flag = 0;
3201
3202   for (actual = expr->value.function.actual; actual; actual = actual->next)
3203     if (actual->expr != NULL)
3204       flag |= (actual->expr->ts.type != BT_INTEGER
3205                && actual->expr->ts.type != BT_CHARACTER);
3206
3207   name = expr->symtree->n.sym->name;
3208
3209   isym = specific = gfc_find_function (name);
3210   if (isym == NULL)
3211     {
3212       gfc_suppress_error = 0;
3213       return MATCH_NO;
3214     }
3215
3216   gfc_current_intrinsic_where = &expr->where;
3217
3218   /* Bypass the generic list for min and max.  */
3219   if (isym->check.f1m == gfc_check_min_max)
3220     {
3221       init_arglist (isym);
3222
3223       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3224         goto got_specific;
3225
3226       gfc_suppress_error = 0;
3227       return MATCH_NO;
3228     }
3229
3230   /* If the function is generic, check all of its specific
3231      incarnations.  If the generic name is also a specific, we check
3232      that name last, so that any error message will correspond to the
3233      specific.  */
3234   gfc_suppress_error = 1;
3235
3236   if (isym->generic)
3237     {
3238       for (specific = isym->specific_head; specific;
3239            specific = specific->next)
3240         {
3241           if (specific == isym)
3242             continue;
3243           if (check_specific (specific, expr, 0) == SUCCESS)
3244             goto got_specific;
3245         }
3246     }
3247
3248   gfc_suppress_error = !error_flag;
3249
3250   if (check_specific (isym, expr, error_flag) == FAILURE)
3251     {
3252       gfc_suppress_error = 0;
3253       return MATCH_NO;
3254     }
3255
3256   specific = isym;
3257
3258 got_specific:
3259   expr->value.function.isym = specific;
3260   gfc_intrinsic_symbol (expr->symtree->n.sym);
3261
3262   gfc_suppress_error = 0;
3263   if (do_simplify (specific, expr) == FAILURE)
3264     return MATCH_ERROR;
3265
3266   /* TODO: We should probably only allow elemental functions here.  */
3267   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3268
3269   if (pedantic && gfc_init_expr
3270       && flag && gfc_init_expr_extensions (specific))
3271     {
3272       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3273             "nonstandard initialization expression at %L", &expr->where)
3274           == FAILURE)
3275         {
3276           return MATCH_ERROR;
3277         }
3278     }
3279
3280   check_intrinsic_standard (name, isym->standard, &expr->where);
3281
3282   return MATCH_YES;
3283 }
3284
3285
3286 /* See if a CALL statement corresponds to an intrinsic subroutine.
3287    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3288    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3289    correspond).  */
3290
3291 match
3292 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3293 {
3294   gfc_intrinsic_sym *isym;
3295   const char *name;
3296
3297   name = c->symtree->n.sym->name;
3298
3299   isym = find_subroutine (name);
3300   if (isym == NULL)
3301     return MATCH_NO;
3302
3303   gfc_suppress_error = !error_flag;
3304
3305   init_arglist (isym);
3306
3307   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3308     goto fail;
3309
3310   if (isym->check.f1 != NULL)
3311     {
3312       if (do_check (isym, c->ext.actual) == FAILURE)
3313         goto fail;
3314     }
3315   else
3316     {
3317       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3318         goto fail;
3319     }
3320
3321   /* The subroutine corresponds to an intrinsic.  Allow errors to be
3322      seen at this point.  */
3323   gfc_suppress_error = 0;
3324
3325   if (isym->resolve.s1 != NULL)
3326     isym->resolve.s1 (c);
3327   else
3328     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3329
3330   if (gfc_pure (NULL) && !isym->elemental)
3331     {
3332       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3333                  &c->loc);
3334       return MATCH_ERROR;
3335     }
3336
3337   c->resolved_sym->attr.noreturn = isym->noreturn;
3338   check_intrinsic_standard (name, isym->standard, &c->loc);
3339
3340   return MATCH_YES;
3341
3342 fail:
3343   gfc_suppress_error = 0;
3344   return MATCH_NO;
3345 }
3346
3347
3348 /* Call gfc_convert_type() with warning enabled.  */
3349
3350 try
3351 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3352 {
3353   return gfc_convert_type_warn (expr, ts, eflag, 1);
3354 }
3355
3356
3357 /* Try to convert an expression (in place) from one type to another.
3358    'eflag' controls the behavior on error.
3359
3360    The possible values are:
3361
3362      1 Generate a gfc_error()
3363      2 Generate a gfc_internal_error().
3364
3365    'wflag' controls the warning related to conversion.  */
3366
3367 try
3368 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3369                        int wflag)
3370 {
3371   gfc_intrinsic_sym *sym;
3372   gfc_typespec from_ts;
3373   locus old_where;
3374   gfc_expr *new;
3375   int rank;
3376   mpz_t *shape;
3377
3378   from_ts = expr->ts;           /* expr->ts gets clobbered */
3379
3380   if (ts->type == BT_UNKNOWN)
3381     goto bad;
3382
3383   /* NULL and zero size arrays get their type here.  */
3384   if (expr->expr_type == EXPR_NULL
3385       || (expr->expr_type == EXPR_ARRAY
3386           && expr->value.constructor == NULL))
3387     {
3388       /* Sometimes the RHS acquire the type.  */
3389       expr->ts = *ts;
3390       return SUCCESS;
3391     }
3392
3393   if (expr->ts.type == BT_UNKNOWN)
3394     goto bad;
3395
3396   if (expr->ts.type == BT_DERIVED
3397       && ts->type == BT_DERIVED
3398       && gfc_compare_types (&expr->ts, ts))
3399     return SUCCESS;
3400
3401   sym = find_conv (&expr->ts, ts);
3402   if (sym == NULL)
3403     goto bad;
3404
3405   /* At this point, a conversion is necessary. A warning may be needed.  */
3406   if ((gfc_option.warn_std & sym->standard) != 0)
3407     gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3408                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3409   else if (wflag && gfc_option.warn_conversion)
3410     gfc_warning_now ("Conversion from %s to %s at %L",
3411                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3412
3413   /* Insert a pre-resolved function call to the right function.  */
3414   old_where = expr->where;
3415   rank = expr->rank;
3416   shape = expr->shape;
3417
3418   new = gfc_get_expr ();
3419   *new = *expr;
3420
3421   new = gfc_build_conversion (new);
3422   new->value.function.name = sym->lib_name;
3423   new->value.function.isym = sym;
3424   new->where = old_where;
3425   new->rank = rank;
3426   new->shape = gfc_copy_shape (shape, rank);
3427
3428   gfc_get_ha_sym_tree (sym->name, &new->symtree);
3429   new->symtree->n.sym->ts = *ts;
3430   new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
3431   new->symtree->n.sym->attr.function = 1;
3432   new->symtree->n.sym->attr.intrinsic = 1;
3433   new->symtree->n.sym->attr.elemental = 1;
3434   new->symtree->n.sym->attr.pure = 1;
3435   new->symtree->n.sym->attr.referenced = 1;
3436   gfc_intrinsic_symbol(new->symtree->n.sym);
3437   gfc_commit_symbol (new->symtree->n.sym);
3438
3439   *expr = *new;
3440
3441   gfc_free (new);
3442   expr->ts = *ts;
3443
3444   if (gfc_is_constant_expr (expr->value.function.actual->expr)
3445       && do_simplify (sym, expr) == FAILURE)
3446     {
3447
3448       if (eflag == 2)
3449         goto bad;
3450       return FAILURE;           /* Error already generated in do_simplify() */
3451     }
3452
3453   return SUCCESS;
3454
3455 bad:
3456   if (eflag == 1)
3457     {
3458       gfc_error ("Can't convert %s to %s at %L",
3459                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3460       return FAILURE;
3461     }
3462
3463   gfc_internal_error ("Can't convert %s to %s at %L",
3464                       gfc_typename (&from_ts), gfc_typename (ts),
3465                       &expr->where);
3466   /* Not reached */
3467 }