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