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