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