gcc/fortran/intrinsic.c

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