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