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