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