gcc/fortran/intrinsic.c

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