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_2 ("matmul", 0, 1, BT_REAL, dr, GFC_STD_F95,
1610              gfc_check_matmul, NULL, gfc_resolve_matmul,
1611              ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
1612
1613   make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
1614
1615   /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1616      int(max).  The max function must take at least two arguments.  */
1617
1618   add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1619              gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1620              a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
1621
1622   add_sym_1m ("max0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1623              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1624              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1625
1626   add_sym_1m ("amax0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1627              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1628              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1629
1630   add_sym_1m ("amax1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1631              gfc_check_min_max_real, gfc_simplify_max, NULL,
1632              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1633
1634   add_sym_1m ("max1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1635              gfc_check_min_max_real, gfc_simplify_max, NULL,
1636              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1637
1638   add_sym_1m ("dmax1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1639              gfc_check_min_max_double, gfc_simplify_max, NULL,
1640              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1641
1642   make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
1643
1644   add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1645              gfc_check_x, gfc_simplify_maxexponent, NULL,
1646              x, BT_UNKNOWN, dr, REQUIRED);
1647
1648   make_generic ("maxexponent", GFC_ISYM_NONE, GFC_STD_F95);
1649
1650   add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1651                gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1652                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1653                msk, BT_LOGICAL, dl, OPTIONAL);
1654
1655   make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
1656
1657   add_sym_3red ("maxval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1658                 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1659                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1660                 msk, BT_LOGICAL, dl, OPTIONAL);
1661
1662   make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
1663
1664   add_sym_3 ("merge", 1, 1, BT_REAL, dr, GFC_STD_F95,
1665              gfc_check_merge, NULL, gfc_resolve_merge,
1666              ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
1667              msk, BT_LOGICAL, dl, REQUIRED);
1668
1669   make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
1670
1671   /* Note: amin0 is equivalent to real(min), min1 is equivalent to
1672      int(min).  */
1673
1674   add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1675               gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1676              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1677
1678   add_sym_1m ("min0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1679               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1680              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1681
1682   add_sym_1m ("amin0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1683               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1684              a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1685
1686   add_sym_1m ("amin1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1687               gfc_check_min_max_real, gfc_simplify_min, NULL,
1688              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1689
1690   add_sym_1m ("min1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1691               gfc_check_min_max_real, gfc_simplify_min, NULL,
1692              a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1693
1694   add_sym_1m ("dmin1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1695               gfc_check_min_max_double, gfc_simplify_min, NULL,
1696              a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1697
1698   make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
1699
1700   add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1701              gfc_check_x, gfc_simplify_minexponent, NULL,
1702              x, BT_UNKNOWN, dr, REQUIRED);
1703
1704   make_generic ("minexponent", GFC_ISYM_NONE, GFC_STD_F95);
1705
1706   add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1707                gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1708                ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1709                msk, BT_LOGICAL, dl, OPTIONAL);
1710
1711   make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
1712
1713   add_sym_3red ("minval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1714                 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1715                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1716                 msk, BT_LOGICAL, dl, OPTIONAL);
1717
1718   make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
1719
1720   add_sym_2 ("mod", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1721              gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1722              a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
1723
1724   add_sym_2 ("amod", 1, 1, BT_REAL, dr, GFC_STD_F77,
1725              NULL, gfc_simplify_mod, gfc_resolve_mod,
1726              a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
1727
1728   add_sym_2 ("dmod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1729              NULL, gfc_simplify_mod, gfc_resolve_mod,
1730              a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
1731
1732   make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
1733
1734   add_sym_2 ("modulo", 1, 1, BT_REAL, di, GFC_STD_F95,
1735              gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1736              a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
1737
1738   make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
1739
1740   add_sym_2 ("nearest", 1, 1, BT_REAL, dr, GFC_STD_F95,
1741              gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1742              x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
1743
1744   make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
1745
1746   add_sym_2 ("nint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1747              gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1748              a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1749
1750   add_sym_1 ("idnint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1751              gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1752              a, BT_REAL, dd, REQUIRED);
1753
1754   make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
1755
1756   add_sym_1 ("not", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1757              gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1758              i, BT_INTEGER, di, REQUIRED);
1759
1760   make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
1761
1762   add_sym_1 ("null", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1763              gfc_check_null, gfc_simplify_null, NULL,
1764              mo, BT_INTEGER, di, OPTIONAL);
1765
1766   make_generic ("null", GFC_ISYM_NONE, GFC_STD_F95);
1767
1768   add_sym_3 ("pack", 0, 1, BT_REAL, dr, GFC_STD_F95,
1769              gfc_check_pack, NULL, gfc_resolve_pack,
1770              ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1771              v, BT_REAL, dr, OPTIONAL);
1772
1773   make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
1774
1775   add_sym_1 ("precision", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1776              gfc_check_precision, gfc_simplify_precision, NULL,
1777              x, BT_UNKNOWN, 0, REQUIRED);
1778
1779   make_generic ("precision", GFC_ISYM_NONE, GFC_STD_F95);
1780
1781   add_sym_1 ("present", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1782              gfc_check_present, NULL, NULL,
1783              a, BT_REAL, dr, REQUIRED);
1784
1785   make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
1786
1787   add_sym_3red ("product", 0, 1, BT_REAL, dr, GFC_STD_F95,
1788                 gfc_check_product_sum, NULL, gfc_resolve_product,
1789                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1790                 msk, BT_LOGICAL, dl, OPTIONAL);
1791
1792   make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
1793
1794   add_sym_1 ("radix", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1795              gfc_check_radix, gfc_simplify_radix, NULL,
1796              x, BT_UNKNOWN, 0, REQUIRED);
1797
1798   make_generic ("radix", GFC_ISYM_NONE, GFC_STD_F95);
1799
1800   /* The following function is for G77 compatibility.  */
1801   add_sym_1 ("rand", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1802              gfc_check_rand, NULL, NULL,
1803              i, BT_INTEGER, 4, OPTIONAL);
1804
1805   /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and ran()
1806      use slightly different shoddy multiplicative congruential PRNG.  */
1807   make_alias ("ran", GFC_STD_GNU);
1808
1809   make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
1810
1811   add_sym_1 ("range", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1812              gfc_check_range, gfc_simplify_range, NULL,
1813              x, BT_REAL, dr, REQUIRED);
1814
1815   make_generic ("range", GFC_ISYM_NONE, GFC_STD_F95);
1816
1817   add_sym_2 ("real", 1, 0, BT_REAL, dr, GFC_STD_F77,
1818              gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1819              a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1820
1821   /* This provides compatibility with g77.  */
1822   add_sym_1 ("realpart", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1823              gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
1824              a, BT_UNKNOWN, dr, REQUIRED);
1825
1826   add_sym_1 ("float", 1, 0, BT_REAL, dr, GFC_STD_F77,
1827              NULL, gfc_simplify_float, NULL,
1828              a, BT_INTEGER, di, REQUIRED);
1829
1830   add_sym_1 ("sngl", 1, 0, BT_REAL, dr, GFC_STD_F77,
1831              NULL, gfc_simplify_sngl, NULL,
1832              a, BT_REAL, dd, REQUIRED);
1833
1834   make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
1835
1836   add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1837              gfc_check_rename, NULL, gfc_resolve_rename,
1838              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1839
1840   make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
1841
1842   add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
1843              gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1844              stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
1845
1846   make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
1847
1848   add_sym_4 ("reshape", 0, 1, BT_REAL, dr, GFC_STD_F95,
1849              gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1850              src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
1851              pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
1852
1853   make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
1854
1855   add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1856              gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1857              x, BT_REAL, dr, REQUIRED);
1858
1859   make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
1860
1861   add_sym_2 ("scale", 1, 1, BT_REAL, dr, GFC_STD_F95,
1862              gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1863              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1864
1865   make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
1866
1867   add_sym_3 ("scan", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1868              gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1869              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
1870              bck, BT_LOGICAL, dl, OPTIONAL);
1871
1872   make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
1873
1874   /* Added for G77 compatibility garbage.  */
1875   add_sym_0 ("second", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1876              NULL, NULL, NULL);
1877
1878   make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
1879
1880   add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1881              gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL,
1882              r, BT_INTEGER, di, REQUIRED);
1883
1884   make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
1885
1886   add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di,  GFC_STD_F95,
1887              gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1888              NULL,
1889              p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
1890
1891   make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
1892
1893   add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr, GFC_STD_F95,
1894              gfc_check_set_exponent, gfc_simplify_set_exponent,
1895              gfc_resolve_set_exponent,
1896              x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1897
1898   make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
1899
1900   add_sym_1 ("shape", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1901              gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1902              src, BT_REAL, dr, REQUIRED);
1903
1904   make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
1905
1906   add_sym_2 ("sign", 1, 1, BT_REAL, dr, GFC_STD_F77,
1907              gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1908              a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
1909
1910   add_sym_2 ("isign", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1911              NULL, gfc_simplify_sign, gfc_resolve_sign,
1912              a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1913
1914   add_sym_2 ("dsign", 1, 1, BT_REAL, dd, GFC_STD_F77,
1915              NULL, gfc_simplify_sign, gfc_resolve_sign,
1916              a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
1917
1918   make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
1919
1920   add_sym_2 ("signal", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1921              gfc_check_signal, NULL, gfc_resolve_signal,
1922              num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
1923
1924   make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
1925
1926   add_sym_1 ("sin", 1, 1, BT_REAL, dr, GFC_STD_F77,
1927              gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
1928              x, BT_REAL, dr, REQUIRED);
1929
1930   add_sym_1 ("dsin", 1, 1, BT_REAL, dd, GFC_STD_F77,
1931              NULL, gfc_simplify_sin, gfc_resolve_sin,
1932              x, BT_REAL, dd, REQUIRED);
1933
1934   add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1935              NULL, gfc_simplify_sin, gfc_resolve_sin,
1936              x, BT_COMPLEX, dz, REQUIRED);
1937
1938   add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1939              NULL, gfc_simplify_sin, gfc_resolve_sin,
1940              x, BT_COMPLEX, dd, REQUIRED);
1941
1942   make_alias ("cdsin", GFC_STD_GNU);
1943
1944   make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
1945
1946   add_sym_1 ("sinh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1947              gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh,
1948              x, BT_REAL, dr, REQUIRED);
1949
1950   add_sym_1 ("dsinh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1951              NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1952              x, BT_REAL, dd, REQUIRED);
1953
1954   make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
1955
1956   add_sym_2 ("size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1957              gfc_check_size, gfc_simplify_size, NULL,
1958              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1959
1960   make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
1961
1962   add_sym_1 ("spacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1963              gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
1964              x, BT_REAL, dr, REQUIRED);
1965
1966   make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
1967
1968   add_sym_3 ("spread", 0, 1, BT_REAL, dr, GFC_STD_F95,
1969              gfc_check_spread, NULL, gfc_resolve_spread,
1970              src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
1971              n, BT_INTEGER, di, REQUIRED);
1972
1973   make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
1974
1975   add_sym_1 ("sqrt", 1, 1, BT_REAL, dr, GFC_STD_F77,
1976              gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
1977              x, BT_REAL, dr, REQUIRED);
1978
1979   add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd, GFC_STD_F77,
1980              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1981              x, BT_REAL, dd, REQUIRED);
1982
1983   add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1984              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1985              x, BT_COMPLEX, dz, REQUIRED);
1986
1987   add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1988              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1989              x, BT_COMPLEX, dd, REQUIRED);
1990
1991   make_alias ("cdsqrt", GFC_STD_GNU);
1992
1993   make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
1994
1995   add_sym_2 ("stat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1996              gfc_check_stat, NULL, gfc_resolve_stat,
1997              a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1998
1999   make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
2000
2001   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2002                 gfc_check_product_sum, NULL, gfc_resolve_sum,
2003                 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2004                 msk, BT_LOGICAL, dl, OPTIONAL);
2005
2006   make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
2007
2008   add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2009              gfc_check_symlnk, NULL, gfc_resolve_symlnk,
2010              a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
2011
2012   make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
2013
2014   add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
2015              NULL, NULL, NULL,
2016              c, BT_CHARACTER, dc, REQUIRED);
2017
2018   make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
2019
2020   add_sym_1 ("tan", 1, 1, BT_REAL, dr, GFC_STD_F77,
2021              gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
2022              x, BT_REAL, dr, REQUIRED);
2023
2024   add_sym_1 ("dtan", 1, 1, BT_REAL, dd, GFC_STD_F77,
2025              NULL, gfc_simplify_tan, gfc_resolve_tan,
2026              x, BT_REAL, dd, REQUIRED);
2027
2028   make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
2029
2030   add_sym_1 ("tanh", 1, 1, BT_REAL, dr, GFC_STD_F77,
2031              gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
2032              x, BT_REAL, dr, REQUIRED);
2033
2034   add_sym_1 ("dtanh", 1, 1, BT_REAL, dd, GFC_STD_F77,
2035              NULL, gfc_simplify_tanh, gfc_resolve_tanh,
2036              x, BT_REAL, dd, REQUIRED);
2037
2038   make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
2039
2040   add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
2041              NULL, NULL, gfc_resolve_time);
2042
2043   make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
2044
2045   add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
2046              NULL, NULL, gfc_resolve_time8);
2047
2048   make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
2049
2050   add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95,
2051              gfc_check_x, gfc_simplify_tiny, NULL,
2052              x, BT_REAL, dr, REQUIRED);
2053
2054   make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95);
2055
2056   add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95,
2057              gfc_check_transfer, NULL, gfc_resolve_transfer,
2058              src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
2059              sz, BT_INTEGER, di, OPTIONAL);
2060
2061   make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
2062
2063   add_sym_1 ("transpose", 0, 1, BT_REAL, dr, GFC_STD_F95,
2064              gfc_check_transpose, NULL, gfc_resolve_transpose,
2065              m, BT_REAL, dr, REQUIRED);
2066
2067   make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2068
2069   add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
2070              gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2071              stg, BT_CHARACTER, dc, REQUIRED);
2072
2073   make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2074
2075   add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
2076              gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2077              ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2078
2079   make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2080
2081   /* g77 compatibility for UMASK.  */
2082   add_sym_1 ("umask", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2083              gfc_check_umask, NULL, gfc_resolve_umask,
2084              a, BT_INTEGER, di, REQUIRED);
2085
2086   make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2087
2088   /* g77 compatibility for UNLINK.  */
2089   add_sym_1 ("unlink", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2090              gfc_check_unlink, NULL, gfc_resolve_unlink,
2091              a, BT_CHARACTER, dc, REQUIRED);
2092
2093   make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2094
2095   add_sym_3 ("unpack", 0, 1, BT_REAL, dr, GFC_STD_F95,
2096              gfc_check_unpack, NULL, gfc_resolve_unpack,
2097              v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2098              f, BT_REAL, dr, REQUIRED);
2099
2100   make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2101
2102   add_sym_3 ("verify", 1, 1, BT_INTEGER, di, GFC_STD_F95,
2103              gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2104              stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2105              bck, BT_LOGICAL, dl, OPTIONAL);
2106
2107   make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2108
2109   add_sym_1 ("loc", 0, 1, BT_INTEGER, ii, GFC_STD_GNU,
2110             gfc_check_loc, NULL, gfc_resolve_loc,
2111             ar, BT_UNKNOWN, 0, REQUIRED);
2112
2113   make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
2114
2115 }
2116
2117
2118 /* Add intrinsic subroutines.  */
2119
2120 static void
2121 add_subroutines (void)
2122 {
2123   /* Argument names as in the standard (to be used as argument keywords).  */
2124   const char
2125     *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2126     *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2127     *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2128     *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2129     *com = "command", *length = "length", *st = "status",
2130     *val = "value", *num = "number", *name = "name",
2131     *trim_name = "trim_name", *ut = "unit", *han = "handler",
2132     *sec = "seconds";
2133
2134   int di, dr, dc, dl;
2135
2136   di = gfc_default_integer_kind;
2137   dr = gfc_default_real_kind;
2138   dc = gfc_default_character_kind;
2139   dl = gfc_default_logical_kind;
2140
2141   add_sym_0s ("abort", 1, GFC_STD_GNU, NULL);
2142
2143   make_noreturn();
2144
2145   add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2146               gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2147               tm, BT_REAL, dr, REQUIRED);
2148
2149   /* More G77 compatibility garbage.  */
2150   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2151               gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2152               tm, BT_REAL, dr, REQUIRED);
2153
2154   add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2155               gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2156               name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2157
2158   add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2159               gfc_check_date_and_time, NULL, NULL,
2160               dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2161               zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2162
2163   /* More G77 compatibility garbage.  */
2164   add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2165              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2166               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2167
2168   add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2169              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2170               vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2171
2172   add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2173               gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
2174               dc, REQUIRED);
2175
2176   add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2177           gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2178               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2179
2180   add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2181               NULL, NULL, NULL,
2182               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2183
2184   add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2185               NULL, NULL, gfc_resolve_getarg,
2186               c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2187
2188   add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2189               gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2190               dc, REQUIRED);
2191
2192   /* F2003 commandline routines.  */
2193
2194   add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2195               NULL, NULL, gfc_resolve_get_command,
2196               com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
2197               st, BT_INTEGER, di, OPTIONAL);
2198
2199   add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2200               NULL, NULL, gfc_resolve_get_command_argument,
2201               num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2202               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2203
2204   /* F2003 subroutine to get environment variables.  */
2205
2206   add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2207              NULL, NULL, gfc_resolve_get_environment_variable,
2208               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2209               length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2210               trim_name, BT_LOGICAL, dl, OPTIONAL);
2211
2212   add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2213               gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2214               f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2215               ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2216               tp, BT_INTEGER, di, REQUIRED);
2217
2218   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2219               gfc_check_random_number, NULL, gfc_resolve_random_number,
2220               h, BT_REAL, dr, REQUIRED);
2221
2222   add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2223              gfc_check_random_seed, NULL, NULL,
2224               sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2225               gt, BT_INTEGER, di, OPTIONAL);
2226
2227   /* More G77 compatibility garbage.  */
2228   add_sym_3s ("alarm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2229               gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
2230               sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2231               st, BT_INTEGER, di, OPTIONAL);
2232
2233   add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU,
2234              gfc_check_srand, NULL, gfc_resolve_srand,
2235               c, BT_INTEGER, 4, REQUIRED);
2236
2237   add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2238              gfc_check_exit, NULL, gfc_resolve_exit,
2239               c, BT_INTEGER, di, OPTIONAL);
2240
2241   make_noreturn();
2242
2243   add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2244               gfc_check_flush, NULL, gfc_resolve_flush,
2245               c, BT_INTEGER, di, OPTIONAL);
2246
2247   add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2248           gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2249               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2250
2251   add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2252               NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2253               val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2254
2255   add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2256               gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2257               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2258               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2259
2260   add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2261           gfc_check_perror, NULL, gfc_resolve_perror,
2262               c, BT_CHARACTER, dc, REQUIRED);
2263
2264   add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2265               gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2266               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2267               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2268
2269   add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2270               gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2271               val, BT_CHARACTER, dc, REQUIRED);
2272
2273   add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2274               gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2275               ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2276               st, BT_INTEGER, di, OPTIONAL);
2277
2278   add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2279               gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2280               name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2281               st, BT_INTEGER, di, OPTIONAL);
2282
2283   add_sym_3s ("signal", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2284               gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
2285               num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2286               st, BT_INTEGER, di, OPTIONAL);
2287
2288   add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2289               gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2290               name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2291               dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2292
2293   add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2294               NULL, NULL, gfc_resolve_system_sub,
2295               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2296
2297   add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2298              gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2299               c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2300               cm, BT_INTEGER, di, OPTIONAL);
2301
2302   add_sym_2s ("ttynam", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2303               gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
2304               ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
2305
2306   add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2307           gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2308               val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2309
2310   add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2311           gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2312               c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2313
2314 }
2315
2316
2317 /* Add a function to the list of conversion symbols.  */
2318
2319 static void
2320 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2321 {
2322
2323   gfc_typespec from, to;
2324   gfc_intrinsic_sym *sym;
2325
2326   if (sizing == SZ_CONVS)
2327     {
2328       nconv++;
2329       return;
2330     }
2331
2332   gfc_clear_ts (&from);
2333   from.type = from_type;
2334   from.kind = from_kind;
2335
2336   gfc_clear_ts (&to);
2337   to.type = to_type;
2338   to.kind = to_kind;
2339
2340   sym = conversion + nconv;
2341
2342   sym->name = conv_name (&from, &to);
2343   sym->lib_name = sym->name;
2344   sym->simplify.cc = gfc_convert_constant;
2345   sym->standard = standard;
2346   sym->elemental = 1;
2347   sym->ts = to;
2348   sym->generic_id = GFC_ISYM_CONVERSION;
2349
2350   nconv++;
2351 }
2352
2353
2354 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2355    functions by looping over the kind tables.  */
2356
2357 static void
2358 add_conversions (void)
2359 {
2360   int i, j;
2361
2362   /* Integer-Integer conversions.  */
2363   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2364     for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2365       {
2366         if (i == j)
2367           continue;
2368
2369         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2370                   BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2371       }
2372
2373   /* Integer-Real/Complex conversions.  */
2374   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2375     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2376       {
2377         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2378                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2379
2380         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2381                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2382
2383         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2384                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2385
2386         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2387                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2388       }
2389
2390   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2391     {
2392       /* Hollerith-Integer conversions.  */
2393       for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2394         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2395                   BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2396       /* Hollerith-Real conversions.  */
2397       for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2398         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2399                   BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2400       /* Hollerith-Complex conversions.  */
2401       for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2402         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2403                   BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2404
2405       /* Hollerith-Character conversions.  */
2406       add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2407                   gfc_default_character_kind, GFC_STD_LEGACY);
2408
2409       /* Hollerith-Logical conversions.  */
2410       for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
2411         add_conv (BT_HOLLERITH, gfc_default_character_kind,
2412                   BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
2413     }
2414
2415   /* Real/Complex - Real/Complex conversions.  */
2416   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2417     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2418       {
2419         if (i != j)
2420           {
2421             add_conv (BT_REAL, gfc_real_kinds[i].kind,
2422                       BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2423
2424             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2425                       BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2426           }
2427
2428         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2429                   BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2430
2431         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2432                   BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2433       }
2434
2435   /* Logical/Logical kind conversion.  */
2436   for (i = 0; gfc_logical_kinds[i].kind; i++)
2437     for (j = 0; gfc_logical_kinds[j].kind; j++)
2438       {
2439         if (i == j)
2440           continue;
2441
2442         add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2443                   BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2444       }
2445
2446   /* Integer-Logical and Logical-Integer conversions.  */
2447   if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2448     for (i=0; gfc_integer_kinds[i].kind; i++)
2449       for (j=0; gfc_logical_kinds[j].kind; j++)
2450         {
2451           add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2452                     BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2453           add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2454                     BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2455         }
2456 }
2457
2458
2459 /* Initialize the table of intrinsics.  */
2460 void
2461 gfc_intrinsic_init_1 (void)
2462 {
2463   int i;
2464
2465   nargs = nfunc = nsub = nconv = 0;
2466
2467   /* Create a namespace to hold the resolved intrinsic symbols.  */
2468   gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2469
2470   sizing = SZ_FUNCS;
2471   add_functions ();
2472   sizing = SZ_SUBS;
2473   add_subroutines ();
2474   sizing = SZ_CONVS;
2475   add_conversions ();
2476
2477   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2478                           + sizeof (gfc_intrinsic_arg) * nargs);
2479
2480   next_sym = functions;
2481   subroutines = functions + nfunc;
2482
2483   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2484
2485   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2486
2487   sizing = SZ_NOTHING;
2488   nconv = 0;
2489
2490   add_functions ();
2491   add_subroutines ();
2492   add_conversions ();
2493
2494   /* Set the pure flag.  All intrinsic functions are pure, and
2495      intrinsic subroutines are pure if they are elemental.  */
2496
2497   for (i = 0; i < nfunc; i++)
2498     functions[i].pure = 1;
2499
2500   for (i = 0; i < nsub; i++)
2501     subroutines[i].pure = subroutines[i].elemental;
2502 }
2503
2504
2505 void
2506 gfc_intrinsic_done_1 (void)
2507 {
2508   gfc_free (functions);
2509   gfc_free (conversion);
2510   gfc_free_namespace (gfc_intrinsic_namespace);
2511 }
2512
2513
2514 /******** Subroutines to check intrinsic interfaces ***********/
2515
2516 /* Given a formal argument list, remove any NULL arguments that may
2517    have been left behind by a sort against some formal argument list.  */
2518
2519 static void
2520 remove_nullargs (gfc_actual_arglist ** ap)
2521 {
2522   gfc_actual_arglist *head, *tail, *next;
2523
2524   tail = NULL;
2525
2526   for (head = *ap; head; head = next)
2527     {
2528       next = head->next;
2529
2530       if (head->expr == NULL)
2531         {
2532           head->next = NULL;
2533           gfc_free_actual_arglist (head);
2534         }
2535       else
2536         {
2537           if (tail == NULL)
2538             *ap = head;
2539           else
2540             tail->next = head;
2541
2542           tail = head;
2543           tail->next = NULL;
2544         }
2545     }
2546
2547   if (tail == NULL)
2548     *ap = NULL;
2549 }
2550
2551
2552 /* Given an actual arglist and a formal arglist, sort the actual
2553    arglist so that its arguments are in a one-to-one correspondence
2554    with the format arglist.  Arguments that are not present are given
2555    a blank gfc_actual_arglist structure.  If something is obviously
2556    wrong (say, a missing required argument) we abort sorting and
2557    return FAILURE.  */
2558
2559 static try
2560 sort_actual (const char *name, gfc_actual_arglist ** ap,
2561              gfc_intrinsic_arg * formal, locus * where)
2562 {
2563
2564   gfc_actual_arglist *actual, *a;
2565   gfc_intrinsic_arg *f;
2566
2567   remove_nullargs (ap);
2568   actual = *ap;
2569
2570   for (f = formal; f; f = f->next)
2571     f->actual = NULL;
2572
2573   f = formal;
2574   a = actual;
2575
2576   if (f == NULL && a == NULL)   /* No arguments */
2577     return SUCCESS;
2578
2579   for (;;)
2580     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2581       if (f == NULL)
2582         break;
2583       if (a == NULL)
2584         goto optional;
2585
2586       if (a->name != NULL)
2587         goto keywords;
2588
2589       f->actual = a;
2590
2591       f = f->next;
2592       a = a->next;
2593     }
2594
2595   if (a == NULL)
2596     goto do_sort;
2597
2598   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2599   return FAILURE;
2600
2601 keywords:
2602   /* Associate the remaining actual arguments, all of which have
2603      to be keyword arguments.  */
2604   for (; a; a = a->next)
2605     {
2606       for (f = formal; f; f = f->next)
2607         if (strcmp (a->name, f->name) == 0)
2608           break;
2609
2610       if (f == NULL)
2611         {
2612           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2613                      a->name, name, where);
2614           return FAILURE;
2615         }
2616
2617       if (f->actual != NULL)
2618         {
2619           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2620                      f->name, name, where);
2621           return FAILURE;
2622         }
2623
2624       f->actual = a;
2625     }
2626
2627 optional:
2628   /* At this point, all unmatched formal args must be optional.  */
2629   for (f = formal; f; f = f->next)
2630     {
2631       if (f->actual == NULL && f->optional == 0)
2632         {
2633           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2634                      f->name, name, where);
2635           return FAILURE;
2636         }
2637     }
2638
2639 do_sort:
2640   /* Using the formal argument list, string the actual argument list
2641      together in a way that corresponds with the formal list.  */
2642   actual = NULL;
2643
2644   for (f = formal; f; f = f->next)
2645     {
2646       if (f->actual == NULL)
2647         {
2648           a = gfc_get_actual_arglist ();
2649           a->missing_arg_type = f->ts.type;
2650         }
2651       else
2652         a = f->actual;
2653
2654       if (actual == NULL)
2655         *ap = a;
2656       else
2657         actual->next = a;
2658
2659       actual = a;
2660     }
2661   actual->next = NULL;          /* End the sorted argument list.  */
2662
2663   return SUCCESS;
2664 }
2665
2666
2667 /* Compare an actual argument list with an intrinsic's formal argument
2668    list.  The lists are checked for agreement of type.  We don't check
2669    for arrayness here.  */
2670
2671 static try
2672 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2673                int error_flag)
2674 {
2675   gfc_actual_arglist *actual;
2676   gfc_intrinsic_arg *formal;
2677   int i;
2678
2679   formal = sym->formal;
2680   actual = *ap;
2681
2682   i = 0;
2683   for (; formal; formal = formal->next, actual = actual->next, i++)
2684     {
2685       if (actual->expr == NULL)
2686         continue;
2687
2688       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2689         {
2690           if (error_flag)
2691             gfc_error
2692               ("Type of argument '%s' in call to '%s' at %L should be "
2693                "%s, not %s", gfc_current_intrinsic_arg[i],
2694                gfc_current_intrinsic, &actual->expr->where,
2695                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2696           return FAILURE;
2697         }
2698     }
2699
2700   return SUCCESS;
2701 }
2702
2703
2704 /* Given a pointer to an intrinsic symbol and an expression node that
2705    represent the function call to that subroutine, figure out the type
2706    of the result.  This may involve calling a resolution subroutine.  */
2707
2708 static void
2709 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2710 {
2711   gfc_expr *a1, *a2, *a3, *a4, *a5;
2712   gfc_actual_arglist *arg;
2713
2714   if (specific->resolve.f1 == NULL)
2715     {
2716       if (e->value.function.name == NULL)
2717         e->value.function.name = specific->lib_name;
2718
2719       if (e->ts.type == BT_UNKNOWN)
2720         e->ts = specific->ts;
2721       return;
2722     }
2723
2724   arg = e->value.function.actual;
2725
2726   /* Special case hacks for MIN and MAX.  */
2727   if (specific->resolve.f1m == gfc_resolve_max
2728       || specific->resolve.f1m == gfc_resolve_min)
2729     {
2730       (*specific->resolve.f1m) (e, arg);
2731       return;
2732     }
2733
2734   if (arg == NULL)
2735     {
2736       (*specific->resolve.f0) (e);
2737       return;
2738     }
2739
2740   a1 = arg->expr;
2741   arg = arg->next;
2742
2743   if (arg == NULL)
2744     {
2745       (*specific->resolve.f1) (e, a1);
2746       return;
2747     }
2748
2749   a2 = arg->expr;
2750   arg = arg->next;
2751
2752   if (arg == NULL)
2753     {
2754       (*specific->resolve.f2) (e, a1, a2);
2755       return;
2756     }
2757
2758   a3 = arg->expr;
2759   arg = arg->next;
2760
2761   if (arg == NULL)
2762     {
2763       (*specific->resolve.f3) (e, a1, a2, a3);
2764       return;
2765     }
2766
2767   a4 = arg->expr;
2768   arg = arg->next;
2769
2770   if (arg == NULL)
2771     {
2772       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2773       return;
2774     }
2775
2776   a5 = arg->expr;
2777   arg = arg->next;
2778
2779   if (arg == NULL)
2780     {
2781       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2782       return;
2783     }
2784
2785   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2786 }
2787
2788
2789 /* Given an intrinsic symbol node and an expression node, call the
2790    simplification function (if there is one), perhaps replacing the
2791    expression with something simpler.  We return FAILURE on an error
2792    of the simplification, SUCCESS if the simplification worked, even
2793    if nothing has changed in the expression itself.  */
2794
2795 static try
2796 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2797 {
2798   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2799   gfc_actual_arglist *arg;
2800
2801   /* Check the arguments if there are Hollerith constants. We deal with
2802      them at run-time.  */
2803   for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
2804     {
2805       if (arg->expr && arg->expr->from_H)
2806         {
2807           result = NULL;
2808           goto finish;
2809         }
2810     }
2811   /* Max and min require special handling due to the variable number
2812      of args.  */
2813   if (specific->simplify.f1 == gfc_simplify_min)
2814     {
2815       result = gfc_simplify_min (e);
2816       goto finish;
2817     }
2818
2819   if (specific->simplify.f1 == gfc_simplify_max)
2820     {
2821       result = gfc_simplify_max (e);
2822       goto finish;
2823     }
2824
2825   if (specific->simplify.f1 == NULL)
2826     {
2827       result = NULL;
2828       goto finish;
2829     }
2830
2831   arg = e->value.function.actual;
2832
2833   if (arg == NULL)
2834     {
2835       result = (*specific->simplify.f0) ();
2836       goto finish;
2837     }
2838
2839   a1 = arg->expr;
2840   arg = arg->next;
2841
2842   if (specific->simplify.cc == gfc_convert_constant)
2843     {
2844       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2845       goto finish;
2846     }
2847
2848   /* TODO: Warn if -pedantic and initialization expression and arg
2849      types not integer or character */
2850
2851   if (arg == NULL)
2852     result = (*specific->simplify.f1) (a1);
2853   else
2854     {
2855       a2 = arg->expr;
2856       arg = arg->next;
2857
2858       if (arg == NULL)
2859         result = (*specific->simplify.f2) (a1, a2);
2860       else
2861         {
2862           a3 = arg->expr;
2863           arg = arg->next;
2864
2865           if (arg == NULL)
2866             result = (*specific->simplify.f3) (a1, a2, a3);
2867           else
2868             {
2869               a4 = arg->expr;
2870               arg = arg->next;
2871
2872               if (arg == NULL)
2873                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2874               else
2875                 {
2876                   a5 = arg->expr;
2877                   arg = arg->next;
2878
2879                   if (arg == NULL)
2880                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2881                   else
2882                     gfc_internal_error
2883                       ("do_simplify(): Too many args for intrinsic");
2884                 }
2885             }
2886         }
2887     }
2888
2889 finish:
2890   if (result == &gfc_bad_expr)
2891     return FAILURE;
2892
2893   if (result == NULL)
2894     resolve_intrinsic (specific, e);    /* Must call at run-time */
2895   else
2896     {
2897       result->where = e->where;
2898       gfc_replace_expr (e, result);
2899     }
2900
2901   return SUCCESS;
2902 }
2903
2904
2905 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2906    error messages.  This subroutine returns FAILURE if a subroutine
2907    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2908    list cannot match any intrinsic.  */
2909
2910 static void
2911 init_arglist (gfc_intrinsic_sym * isym)
2912 {
2913   gfc_intrinsic_arg *formal;
2914   int i;
2915
2916   gfc_current_intrinsic = isym->name;
2917
2918   i = 0;
2919   for (formal = isym->formal; formal; formal = formal->next)
2920     {
2921       if (i >= MAX_INTRINSIC_ARGS)
2922         gfc_internal_error ("init_arglist(): too many arguments");
2923       gfc_current_intrinsic_arg[i++] = formal->name;
2924     }
2925 }
2926
2927
2928 /* Given a pointer to an intrinsic symbol and an expression consisting
2929    of a function call, see if the function call is consistent with the
2930    intrinsic's formal argument list.  Return SUCCESS if the expression
2931    and intrinsic match, FAILURE otherwise.  */
2932
2933 static try
2934 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2935 {
2936   gfc_actual_arglist *arg, **ap;
2937   int r;
2938   try t;
2939
2940   ap = &expr->value.function.actual;
2941
2942   init_arglist (specific);
2943
2944   /* Don't attempt to sort the argument list for min or max.  */
2945   if (specific->check.f1m == gfc_check_min_max
2946       || specific->check.f1m == gfc_check_min_max_integer
2947       || specific->check.f1m == gfc_check_min_max_real
2948       || specific->check.f1m == gfc_check_min_max_double)
2949     return (*specific->check.f1m) (*ap);
2950
2951   if (sort_actual (specific->name, ap, specific->formal,
2952                    &expr->where) == FAILURE)
2953     return FAILURE;
2954
2955   if (specific->check.f3ml == gfc_check_minloc_maxloc)
2956     /* This is special because we might have to reorder the argument
2957        list.  */
2958     t = gfc_check_minloc_maxloc (*ap);
2959   else if (specific->check.f3red == gfc_check_minval_maxval)
2960     /* This is also special because we also might have to reorder the
2961        argument list.  */
2962     t = gfc_check_minval_maxval (*ap);
2963   else if (specific->check.f3red == gfc_check_product_sum)
2964     /* Same here. The difference to the previous case is that we allow a
2965        general numeric type.  */
2966     t = gfc_check_product_sum (*ap);
2967   else
2968      {
2969        if (specific->check.f1 == NULL)
2970          {
2971            t = check_arglist (ap, specific, error_flag);
2972            if (t == SUCCESS)
2973              expr->ts = specific->ts;
2974          }
2975        else
2976          t = do_check (specific, *ap);
2977      }
2978
2979   /* Check ranks for elemental intrinsics.  */
2980   if (t == SUCCESS && specific->elemental)
2981     {
2982       r = 0;
2983       for (arg = expr->value.function.actual; arg; arg = arg->next)
2984         {
2985           if (arg->expr == NULL || arg->expr->rank == 0)
2986             continue;
2987           if (r == 0)
2988             {
2989               r = arg->expr->rank;
2990               continue;
2991             }
2992
2993           if (arg->expr->rank != r)
2994             {
2995               gfc_error
2996                 ("Ranks of arguments to elemental intrinsic '%s' differ "
2997                  "at %L", specific->name, &arg->expr->where);
2998               return FAILURE;
2999             }
3000         }
3001     }
3002
3003   if (t == FAILURE)
3004     remove_nullargs (ap);
3005
3006   return t;
3007 }
3008
3009
3010 /* See if an intrinsic is one of the intrinsics we evaluate
3011    as an extension.  */
3012
3013 static int
3014 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
3015 {
3016   /* FIXME: This should be moved into the intrinsic definitions.  */
3017   static const char * const init_expr_extensions[] = {
3018     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
3019     "precision", "present", "radix", "range", "selected_real_kind",
3020     "tiny", NULL
3021   };
3022
3023   int i;
3024
3025   for (i = 0; init_expr_extensions[i]; i++)
3026     if (strcmp (init_expr_extensions[i], isym->name) == 0)
3027       return 0;
3028
3029   return 1;
3030 }
3031
3032
3033 /* Check whether an intrinsic belongs to whatever standard the user
3034    has chosen.  */
3035
3036 static void
3037 check_intrinsic_standard (const char *name, int standard, locus * where)
3038 {
3039   if (!gfc_option.warn_nonstd_intrinsics)
3040     return;
3041
3042   gfc_notify_std (standard, "Intrinsic '%s' at %L is not included "
3043                   "in the selected standard", name, where);
3044 }
3045
3046
3047 /* See if a function call corresponds to an intrinsic function call.
3048    We return:
3049
3050     MATCH_YES    if the call corresponds to an intrinsic, simplification
3051                  is done if possible.
3052
3053     MATCH_NO     if the call does not correspond to an intrinsic
3054
3055     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
3056                  error during the simplification process.
3057
3058    The error_flag parameter enables an error reporting.  */
3059
3060 match
3061 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
3062 {
3063   gfc_intrinsic_sym *isym, *specific;
3064   gfc_actual_arglist *actual;
3065   const char *name;
3066   int flag;
3067
3068   if (expr->value.function.isym != NULL)
3069     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3070       ? MATCH_ERROR : MATCH_YES;
3071
3072   gfc_suppress_error = !error_flag;
3073   flag = 0;
3074
3075   for (actual = expr->value.function.actual; actual; actual = actual->next)
3076     if (actual->expr != NULL)
3077       flag |= (actual->expr->ts.type != BT_INTEGER
3078                && actual->expr->ts.type != BT_CHARACTER);
3079
3080   name = expr->symtree->n.sym->name;
3081
3082   isym = specific = gfc_find_function (name);
3083   if (isym == NULL)
3084     {
3085       gfc_suppress_error = 0;
3086       return MATCH_NO;
3087     }
3088
3089   gfc_current_intrinsic_where = &expr->where;
3090
3091   /* Bypass the generic list for min and max.  */
3092   if (isym->check.f1m == gfc_check_min_max)
3093     {
3094       init_arglist (isym);
3095
3096       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3097         goto got_specific;
3098
3099       gfc_suppress_error = 0;
3100       return MATCH_NO;
3101     }
3102
3103   /* If the function is generic, check all of its specific
3104      incarnations.  If the generic name is also a specific, we check
3105      that name last, so that any error message will correspond to the
3106      specific.  */
3107   gfc_suppress_error = 1;
3108
3109   if (isym->generic)
3110     {
3111       for (specific = isym->specific_head; specific;
3112            specific = specific->next)
3113         {
3114           if (specific == isym)
3115             continue;
3116           if (check_specific (specific, expr, 0) == SUCCESS)
3117             goto got_specific;
3118         }
3119     }
3120
3121   gfc_suppress_error = !error_flag;
3122
3123   if (check_specific (isym, expr, error_flag) == FAILURE)
3124     {
3125       gfc_suppress_error = 0;
3126       return MATCH_NO;
3127     }
3128
3129   specific = isym;
3130
3131 got_specific:
3132   expr->value.function.isym = specific;
3133   gfc_intrinsic_symbol (expr->symtree->n.sym);
3134
3135   gfc_suppress_error = 0;
3136   if (do_simplify (specific, expr) == FAILURE)
3137     return MATCH_ERROR;
3138
3139   /* TODO: We should probably only allow elemental functions here.  */
3140   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3141
3142   if (pedantic && gfc_init_expr
3143       && flag && gfc_init_expr_extensions (specific))
3144     {
3145       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3146             "nonstandard initialization expression at %L", &expr->where)
3147           == FAILURE)
3148         {
3149           return MATCH_ERROR;
3150         }
3151     }
3152
3153   check_intrinsic_standard (name, isym->standard, &expr->where);
3154
3155   return MATCH_YES;
3156 }
3157
3158
3159 /* See if a CALL statement corresponds to an intrinsic subroutine.
3160    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3161    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3162    correspond).  */
3163
3164 match
3165 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3166 {
3167   gfc_intrinsic_sym *isym;
3168   const char *name;
3169
3170   name = c->symtree->n.sym->name;
3171
3172   isym = find_subroutine (name);
3173   if (isym == NULL)
3174     return MATCH_NO;
3175
3176   gfc_suppress_error = !error_flag;
3177
3178   init_arglist (isym);
3179
3180   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3181     goto fail;
3182
3183   if (isym->check.f1 != NULL)
3184     {
3185       if (do_check (isym, c->ext.actual) == FAILURE)
3186         goto fail;
3187     }
3188   else
3189     {
3190       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3191         goto fail;
3192     }
3193
3194   /* The subroutine corresponds to an intrinsic.  Allow errors to be
3195      seen at this point.  */
3196   gfc_suppress_error = 0;
3197
3198   if (isym->resolve.s1 != NULL)
3199     isym->resolve.s1 (c);
3200   else
3201     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3202
3203   if (gfc_pure (NULL) && !isym->elemental)
3204     {
3205       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3206                  &c->loc);
3207       return MATCH_ERROR;
3208     }
3209
3210   c->resolved_sym->attr.noreturn = isym->noreturn;
3211   check_intrinsic_standard (name, isym->standard, &c->loc);
3212
3213   return MATCH_YES;
3214
3215 fail:
3216   gfc_suppress_error = 0;
3217   return MATCH_NO;
3218 }
3219
3220
3221 /* Call gfc_convert_type() with warning enabled.  */
3222
3223 try
3224 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3225 {
3226   return gfc_convert_type_warn (expr, ts, eflag, 1);
3227 }
3228
3229
3230 /* Try to convert an expression (in place) from one type to another.
3231    'eflag' controls the behavior on error.
3232
3233    The possible values are:
3234
3235      1 Generate a gfc_error()
3236      2 Generate a gfc_internal_error().
3237
3238    'wflag' controls the warning related to conversion.  */
3239
3240 try
3241 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3242                        int wflag)
3243 {
3244   gfc_intrinsic_sym *sym;
3245   gfc_typespec from_ts;
3246   locus old_where;
3247   gfc_expr *new;
3248   int rank;
3249   mpz_t *shape;
3250
3251   from_ts = expr->ts;           /* expr->ts gets clobbered */
3252
3253   if (ts->type == BT_UNKNOWN)
3254     goto bad;
3255
3256   /* NULL and zero size arrays get their type here.  */
3257   if (expr->expr_type == EXPR_NULL
3258       || (expr->expr_type == EXPR_ARRAY
3259           && expr->value.constructor == NULL))
3260     {
3261       /* Sometimes the RHS acquire the type.  */
3262       expr->ts = *ts;
3263       return SUCCESS;
3264     }
3265
3266   if (expr->ts.type == BT_UNKNOWN)
3267     goto bad;
3268
3269   if (expr->ts.type == BT_DERIVED
3270       && ts->type == BT_DERIVED
3271       && gfc_compare_types (&expr->ts, ts))
3272     return SUCCESS;
3273
3274   sym = find_conv (&expr->ts, ts);
3275   if (sym == NULL)
3276     goto bad;
3277
3278   /* At this point, a conversion is necessary. A warning may be needed.  */
3279   if ((gfc_option.warn_std & sym->standard) != 0)
3280     gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3281                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3282   else if (wflag && gfc_option.warn_conversion)
3283     gfc_warning_now ("Conversion from %s to %s at %L",
3284                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3285
3286   /* Insert a pre-resolved function call to the right function.  */
3287   old_where = expr->where;
3288   rank = expr->rank;
3289   shape = expr->shape;
3290
3291   new = gfc_get_expr ();
3292   *new = *expr;
3293
3294   new = gfc_build_conversion (new);
3295   new->value.function.name = sym->lib_name;
3296   new->value.function.isym = sym;
3297   new->where = old_where;
3298   new->rank = rank;
3299   new->shape = gfc_copy_shape (shape, rank);
3300
3301   *expr = *new;
3302
3303   gfc_free (new);
3304   expr->ts = *ts;
3305
3306   if (gfc_is_constant_expr (expr->value.function.actual->expr)
3307       && do_simplify (sym, expr) == FAILURE)
3308     {
3309
3310       if (eflag == 2)
3311         goto bad;
3312       return FAILURE;           /* Error already generated in do_simplify() */
3313     }
3314
3315   return SUCCESS;
3316
3317 bad:
3318   if (eflag == 1)
3319     {
3320       gfc_error ("Can't convert %s to %s at %L",
3321                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3322       return FAILURE;
3323     }
3324
3325   gfc_internal_error ("Can't convert %s to %s at %L",
3326                       gfc_typename (&from_ts), gfc_typename (ts),
3327                       &expr->where);
3328   /* Not reached */
3329 }