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