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 /* Nanespace 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_0 ("getgid", 1, 0, BT_INTEGER, di, NULL, NULL, gfc_resolve_getgid);
1245   make_generic ("getgid", GFC_ISYM_GETGID);
1246
1247   add_sym_0 ("getpid", 1, 0, BT_INTEGER, di, NULL, NULL, gfc_resolve_getpid);
1248   make_generic ("getpid", GFC_ISYM_GETPID);
1249
1250   add_sym_0 ("getuid", 1, 0, BT_INTEGER, di, NULL, NULL, gfc_resolve_getuid);
1251   make_generic ("getuid", GFC_ISYM_GETUID);
1252
1253   add_sym_1 ("huge", 0, 1, BT_REAL, dr,
1254              gfc_check_huge, gfc_simplify_huge, NULL,
1255              x, BT_UNKNOWN, dr, 0);
1256
1257   make_generic ("huge", GFC_ISYM_NONE);
1258
1259   add_sym_1 ("iachar", 1, 1, BT_INTEGER, di,
1260              NULL, gfc_simplify_iachar, NULL, c, BT_CHARACTER, dc, 0);
1261
1262   make_generic ("iachar", GFC_ISYM_IACHAR);
1263
1264   add_sym_2 ("iand", 1, 1, BT_INTEGER, di,
1265              gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1266              i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0);
1267
1268   make_generic ("iand", GFC_ISYM_IAND);
1269
1270   add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, NULL, NULL, NULL);  /* Extension, takes no arguments */
1271   make_generic ("iargc", GFC_ISYM_IARGC);
1272
1273   add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, NULL, NULL, NULL);
1274   make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT);
1275
1276   add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di,
1277              gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1278              i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0);
1279
1280   make_generic ("ibclr", GFC_ISYM_IBCLR);
1281
1282   add_sym_3 ("ibits", 1, 1, BT_INTEGER, di,
1283              gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1284              i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0,
1285              ln, BT_INTEGER, di, 0);
1286
1287   make_generic ("ibits", GFC_ISYM_IBITS);
1288
1289   add_sym_2 ("ibset", 1, 1, BT_INTEGER, di,
1290              gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1291              i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0);
1292
1293   make_generic ("ibset", GFC_ISYM_IBSET);
1294
1295   add_sym_1 ("ichar", 1, 0, BT_INTEGER, di,
1296              NULL, gfc_simplify_ichar, gfc_resolve_ichar,
1297              c, BT_CHARACTER, dc, 0);
1298
1299   make_generic ("ichar", GFC_ISYM_ICHAR);
1300
1301   add_sym_2 ("ieor", 1, 1, BT_INTEGER, di,
1302              gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1303              i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0);
1304
1305   make_generic ("ieor", GFC_ISYM_IEOR);
1306
1307   add_sym_3 ("index", 1, 1, BT_INTEGER, di,
1308              gfc_check_index, gfc_simplify_index, NULL,
1309              stg, BT_CHARACTER, dc, 0, ssg, BT_CHARACTER, dc, 0,
1310              bck, BT_LOGICAL, dl, 1);
1311
1312   make_generic ("index", GFC_ISYM_INDEX);
1313
1314   add_sym_2 ("int", 1, 1, BT_INTEGER, di,
1315              gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1316              a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
1317
1318   add_sym_1 ("ifix", 1, 0, BT_INTEGER, di,
1319              NULL, gfc_simplify_ifix, NULL, a, BT_REAL, dr, 0);
1320
1321   add_sym_1 ("idint", 1, 0, BT_INTEGER, di,
1322              NULL, gfc_simplify_idint, NULL, a, BT_REAL, dd, 0);
1323
1324   make_generic ("int", GFC_ISYM_INT);
1325
1326   add_sym_2 ("ior", 1, 1, BT_INTEGER, di,
1327              gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1328              i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0);
1329
1330   make_generic ("ior", GFC_ISYM_IOR);
1331
1332   /* The following function is for G77 compatibility.  */
1333   add_sym_1 ("irand", 0, 1, BT_INTEGER, 4,
1334              gfc_check_irand, NULL, NULL,
1335              i, BT_INTEGER, 4, 0);
1336
1337   make_generic ("irand", GFC_ISYM_IRAND);
1338
1339   add_sym_2 ("ishft", 1, 1, BT_INTEGER, di,
1340              gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1341              i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0);
1342
1343   make_generic ("ishft", GFC_ISYM_ISHFT);
1344
1345   add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di,
1346              gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1347              i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0,
1348              sz, BT_INTEGER, di, 1);
1349
1350   make_generic ("ishftc", GFC_ISYM_ISHFTC);
1351
1352   add_sym_1 ("kind", 0, 1, BT_INTEGER, di,
1353              gfc_check_kind, gfc_simplify_kind, NULL, x, BT_REAL, dr, 0);
1354
1355   make_generic ("kind", GFC_ISYM_NONE);
1356
1357   add_sym_2 ("lbound", 0, 1, BT_INTEGER, di,
1358              gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1359              ar, BT_REAL, dr, 0, dm, BT_INTEGER, di, 1);
1360
1361   make_generic ("lbound", GFC_ISYM_LBOUND);
1362
1363   add_sym_1 ("len", 0, 1, BT_INTEGER, di,
1364              NULL, gfc_simplify_len, gfc_resolve_len,
1365              stg, BT_CHARACTER, dc, 0);
1366
1367   make_generic ("len", GFC_ISYM_LEN);
1368
1369   add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di,
1370              NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1371              stg, BT_CHARACTER, dc, 0);
1372
1373   make_generic ("len_trim", GFC_ISYM_LEN_TRIM);
1374
1375   add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl,
1376              NULL, gfc_simplify_lge, NULL,
1377              sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1378
1379   make_generic ("lge", GFC_ISYM_LGE);
1380
1381   add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl,
1382              NULL, gfc_simplify_lgt, NULL,
1383              sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1384
1385   make_generic ("lgt", GFC_ISYM_LGT);
1386
1387   add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl,
1388              NULL, gfc_simplify_lle, NULL,
1389              sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1390
1391   make_generic ("lle", GFC_ISYM_LLE);
1392
1393   add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl,
1394              NULL, gfc_simplify_llt, NULL,
1395              sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1396
1397   make_generic ("llt", GFC_ISYM_LLT);
1398
1399   add_sym_1 ("log", 1, 1, BT_REAL, dr,
1400              NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, 0);
1401
1402   add_sym_1 ("alog", 1, 1, BT_REAL, dr,
1403              NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, 0);
1404
1405   add_sym_1 ("dlog", 1, 1, BT_REAL, dd,
1406              NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dd, 0);
1407
1408   add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz,
1409              NULL, gfc_simplify_log, gfc_resolve_log,
1410              x, BT_COMPLEX, dz, 0);
1411
1412   add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_log, gfc_resolve_log, x, BT_COMPLEX, dd, 0);      /* Extension */
1413
1414   make_alias ("cdlog");
1415
1416   make_generic ("log", GFC_ISYM_LOG);
1417
1418   add_sym_1 ("log10", 1, 1, BT_REAL, dr,
1419              NULL, gfc_simplify_log10, gfc_resolve_log10,
1420              x, BT_REAL, dr, 0);
1421
1422   add_sym_1 ("alog10", 1, 1, BT_REAL, dr,
1423              NULL, gfc_simplify_log10, gfc_resolve_log10,
1424              x, BT_REAL, dr, 0);
1425
1426   add_sym_1 ("dlog10", 1, 1, BT_REAL, dd,
1427              NULL, gfc_simplify_log10, gfc_resolve_log10,
1428              x, BT_REAL, dd, 0);
1429
1430   make_generic ("log10", GFC_ISYM_LOG10);
1431
1432   add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl,
1433              gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1434              l, BT_LOGICAL, dl, 0, kind, BT_INTEGER, di, 1);
1435
1436   make_generic ("logical", GFC_ISYM_LOGICAL);
1437
1438   add_sym_2 ("matmul", 0, 1, BT_REAL, dr,
1439              gfc_check_matmul, NULL, gfc_resolve_matmul,
1440              ma, BT_REAL, dr, 0, mb, BT_REAL, dr, 0);
1441
1442   make_generic ("matmul", GFC_ISYM_MATMUL);
1443
1444   /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1445      int(max).  The max function must take at least two arguments.  */
1446
1447   add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0,
1448              gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1449              a1, BT_UNKNOWN, dr, 0, a2, BT_UNKNOWN, dr, 0);
1450
1451   add_sym_1m ("max0", 1, 0, BT_INTEGER, di,
1452              gfc_check_min_max_integer, gfc_simplify_max, NULL,
1453              a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0);
1454
1455   add_sym_1m ("amax0", 1, 0, BT_REAL, dr,
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 ("amax1", 1, 0, BT_REAL, dr,
1460              gfc_check_min_max_real, gfc_simplify_max, NULL,
1461              a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1462
1463   add_sym_1m ("max1", 1, 0, BT_INTEGER, di,
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 ("dmax1", 1, 0, BT_REAL, dd,
1468              gfc_check_min_max_double, gfc_simplify_max, NULL,
1469              a1, BT_REAL, dd, 0, a2, BT_REAL, dd, 0);
1470
1471   make_generic ("max", GFC_ISYM_MAX);
1472
1473   add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di,
1474              gfc_check_x, gfc_simplify_maxexponent, NULL,
1475              x, BT_UNKNOWN, dr, 0);
1476
1477   make_generic ("maxexponent", GFC_ISYM_NONE);
1478
1479   add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di,
1480                gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1481                ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1482                msk, BT_LOGICAL, dl, 1);
1483
1484   make_generic ("maxloc", GFC_ISYM_MAXLOC);
1485
1486   add_sym_3red ("maxval", 0, 1, BT_REAL, dr,
1487                 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1488                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1489                 msk, BT_LOGICAL, dl, 1);
1490
1491   make_generic ("maxval", GFC_ISYM_MAXVAL);
1492
1493   add_sym_3 ("merge", 1, 1, BT_REAL, dr,
1494              gfc_check_merge, NULL, gfc_resolve_merge,
1495              ts, BT_REAL, dr, 0, fs, BT_REAL, dr, 0,
1496              msk, BT_LOGICAL, dl, 0);
1497
1498   make_generic ("merge", GFC_ISYM_MERGE);
1499
1500   /* Note: amin0 is equivalent to real(min), min1 is equivalent to int(min).  */
1501
1502   add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0,
1503               gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1504               a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1505
1506   add_sym_1m ("min0", 1, 0, BT_INTEGER, di,
1507               gfc_check_min_max_integer, gfc_simplify_min, NULL,
1508               a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0);
1509
1510   add_sym_1m ("amin0", 1, 0, BT_REAL, dr,
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 ("amin1", 1, 0, BT_REAL, dr,
1515               gfc_check_min_max_real, gfc_simplify_min, NULL,
1516               a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1517
1518   add_sym_1m ("min1", 1, 0, BT_INTEGER, di,
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 ("dmin1", 1, 0, BT_REAL, dd,
1523               gfc_check_min_max_double, gfc_simplify_min, NULL,
1524               a1, BT_REAL, dd, 0, a2, BT_REAL, dd, 0);
1525
1526   make_generic ("min", GFC_ISYM_MIN);
1527
1528   add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di,
1529              gfc_check_x, gfc_simplify_minexponent, NULL,
1530              x, BT_UNKNOWN, dr, 0);
1531
1532   make_generic ("minexponent", GFC_ISYM_NONE);
1533
1534   add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di,
1535                gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1536                ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1537                msk, BT_LOGICAL, dl, 1);
1538
1539   make_generic ("minloc", GFC_ISYM_MINLOC);
1540
1541   add_sym_3red ("minval", 0, 1, BT_REAL, dr,
1542                 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1543                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1544                 msk, BT_LOGICAL, dl, 1);
1545
1546   make_generic ("minval", GFC_ISYM_MINVAL);
1547
1548   add_sym_2 ("mod", 1, 1, BT_INTEGER, di,
1549              gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1550              a, BT_INTEGER, di, 0, p, BT_INTEGER, di, 0);
1551
1552   add_sym_2 ("amod", 1, 1, BT_REAL, dr,
1553              NULL, gfc_simplify_mod, gfc_resolve_mod,
1554              a, BT_REAL, dr, 0, p, BT_REAL, dr, 0);
1555
1556   add_sym_2 ("dmod", 1, 1, BT_REAL, dd,
1557              NULL, gfc_simplify_mod, gfc_resolve_mod,
1558              a, BT_REAL, dd, 0, p, BT_REAL, dd, 0);
1559
1560   make_generic ("mod", GFC_ISYM_MOD);
1561
1562   add_sym_2 ("modulo", 1, 1, BT_REAL, di,
1563              gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1564              a, BT_REAL, di, 0, p, BT_REAL, di, 0);
1565
1566   make_generic ("modulo", GFC_ISYM_MODULO);
1567
1568   add_sym_2 ("nearest", 1, 1, BT_REAL, dr,
1569              gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1570              x, BT_REAL, dr, 0, s, BT_REAL, dr, 0);
1571
1572   make_generic ("nearest", GFC_ISYM_NEAREST);
1573
1574   add_sym_2 ("nint", 1, 1, BT_INTEGER, di,
1575              gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1576              a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
1577
1578   add_sym_1 ("idnint", 1, 1, BT_INTEGER, di,
1579              gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1580              a, BT_REAL, dd, 0);
1581
1582   make_generic ("nint", GFC_ISYM_NINT);
1583
1584   add_sym_1 ("not", 1, 1, BT_INTEGER, di,
1585              gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1586              i, BT_INTEGER, di, 0);
1587
1588   make_generic ("not", GFC_ISYM_NOT);
1589
1590   add_sym_1 ("null", 0, 1, BT_INTEGER, di,
1591              gfc_check_null, gfc_simplify_null, NULL,
1592              mo, BT_INTEGER, di, 1);
1593
1594   make_generic ("null", GFC_ISYM_NONE);
1595
1596   add_sym_3 ("pack", 0, 1, BT_REAL, dr,
1597              gfc_check_pack, NULL, gfc_resolve_pack,
1598              ar, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0,
1599              v, BT_REAL, dr, 1);
1600
1601   make_generic ("pack", GFC_ISYM_PACK);
1602
1603   add_sym_1 ("precision", 0, 1, BT_INTEGER, di,
1604              gfc_check_precision, gfc_simplify_precision, NULL,
1605              x, BT_UNKNOWN, 0, 0);
1606
1607   make_generic ("precision", GFC_ISYM_NONE);
1608
1609   add_sym_1 ("present", 0, 1, BT_LOGICAL, dl,
1610              gfc_check_present, NULL, NULL, a, BT_REAL, dr, 0);
1611
1612   make_generic ("present", GFC_ISYM_PRESENT);
1613
1614   add_sym_3red ("product", 0, 1, BT_REAL, dr,
1615                 gfc_check_product_sum, NULL, gfc_resolve_product,
1616                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1617                 msk, BT_LOGICAL, dl, 1);
1618
1619   make_generic ("product", GFC_ISYM_PRODUCT);
1620
1621   add_sym_1 ("radix", 0, 1, BT_INTEGER, di,
1622              gfc_check_radix, gfc_simplify_radix, NULL,
1623              x, BT_UNKNOWN, 0, 0);
1624
1625   make_generic ("radix", GFC_ISYM_NONE);
1626
1627   /* The following function is for G77 compatibility.  */
1628   add_sym_1 ("rand", 0, 1, BT_REAL, 4,
1629              gfc_check_rand, NULL, NULL,
1630              i, BT_INTEGER, 4, 0);
1631
1632   /* Compatibility with HP FORTRAN 77/iX Reference.  Note, rand() and
1633      ran() use slightly different shoddy multiplicative congruential
1634      PRNG.  */
1635   make_alias ("ran");
1636
1637   make_generic ("rand", GFC_ISYM_RAND);
1638
1639   add_sym_1 ("range", 0, 1, BT_INTEGER, di,
1640              gfc_check_range, gfc_simplify_range, NULL,
1641              x, BT_REAL, dr, 0);
1642
1643   make_generic ("range", GFC_ISYM_NONE);
1644
1645   add_sym_2 ("real", 1, 0, BT_REAL, dr,
1646              gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1647              a, BT_UNKNOWN, dr, 0, kind, BT_INTEGER, di, 1);
1648
1649   add_sym_1 ("float", 1, 0, BT_REAL, dr,
1650              NULL, gfc_simplify_float, NULL, a, BT_INTEGER, di, 0);
1651
1652   add_sym_1 ("sngl", 1, 0, BT_REAL, dr,
1653              NULL, gfc_simplify_sngl, NULL, a, BT_REAL, dd, 0);
1654
1655   make_generic ("real", GFC_ISYM_REAL);
1656
1657   add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc,
1658              gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1659              stg, BT_CHARACTER, dc, 0, n, BT_INTEGER, di, 0);
1660
1661   make_generic ("repeat", GFC_ISYM_REPEAT);
1662
1663   add_sym_4 ("reshape", 0, 1, BT_REAL, dr,
1664              gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1665              src, BT_REAL, dr, 0, shp, BT_INTEGER, ii, 0,
1666              pad, BT_REAL, dr, 1, ord, BT_INTEGER, ii, 1);
1667
1668   make_generic ("reshape", GFC_ISYM_RESHAPE);
1669
1670   add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr,
1671              gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1672              x, BT_REAL, dr, 0);
1673
1674   make_generic ("rrspacing", GFC_ISYM_RRSPACING);
1675
1676   add_sym_2 ("scale", 1, 1, BT_REAL, dr,
1677              gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1678              x, BT_REAL, dr, 0, i, BT_INTEGER, di, 0);
1679
1680   make_generic ("scale", GFC_ISYM_SCALE);
1681
1682   add_sym_3 ("scan", 1, 1, BT_INTEGER, di,
1683              gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1684              stg, BT_CHARACTER, dc, 0, set, BT_CHARACTER, dc, 0,
1685              bck, BT_LOGICAL, dl, 1);
1686
1687   make_generic ("scan", GFC_ISYM_SCAN);
1688
1689   /* Added for G77 compatibility garbage. */
1690   add_sym_0 ("second", 0, 1, BT_REAL, 4, NULL, NULL, NULL);
1691
1692   make_generic ("second", GFC_ISYM_SECOND);
1693
1694   add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,
1695              NULL, gfc_simplify_selected_int_kind, NULL,
1696              r, BT_INTEGER, di, 0);
1697
1698   make_generic ("selected_int_kind", GFC_ISYM_SI_KIND);
1699
1700   add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di,
1701              gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1702              NULL, p, BT_INTEGER, di, 1, r, BT_INTEGER, di, 1);
1703
1704   make_generic ("selected_real_kind", GFC_ISYM_SR_KIND);
1705
1706   add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr,
1707              gfc_check_set_exponent, gfc_simplify_set_exponent,
1708              gfc_resolve_set_exponent,
1709              x, BT_REAL, dr, 0, i, BT_INTEGER, di, 0);
1710
1711   make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT);
1712
1713   add_sym_1 ("shape", 0, 1, BT_INTEGER, di,
1714              gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1715              src, BT_REAL, dr, 0);
1716
1717   make_generic ("shape", GFC_ISYM_SHAPE);
1718
1719   add_sym_2 ("sign", 1, 1, BT_REAL, dr,
1720              gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1721              a, BT_REAL, dr, 0, b, BT_REAL, dr, 0);
1722
1723   add_sym_2 ("isign", 1, 1, BT_INTEGER, di,
1724              NULL, gfc_simplify_sign, gfc_resolve_sign,
1725              a, BT_INTEGER, di, 0, b, BT_INTEGER, di, 0);
1726
1727   add_sym_2 ("dsign", 1, 1, BT_REAL, dd,
1728              NULL, gfc_simplify_sign, gfc_resolve_sign,
1729              a, BT_REAL, dd, 0, b, BT_REAL, dd, 0);
1730
1731   make_generic ("sign", GFC_ISYM_SIGN);
1732
1733   add_sym_1 ("sin", 1, 1, BT_REAL, dr,
1734              NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dr, 0);
1735
1736   add_sym_1 ("dsin", 1, 1, BT_REAL, dd,
1737              NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dd, 0);
1738
1739   add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz,
1740              NULL, gfc_simplify_sin, gfc_resolve_sin,
1741            x, BT_COMPLEX, dz, 0);
1742
1743   add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_COMPLEX, dd, 0);      /* Extension */
1744
1745   make_alias ("cdsin");
1746
1747   make_generic ("sin", GFC_ISYM_SIN);
1748
1749   add_sym_1 ("sinh", 1, 1, BT_REAL, dr,
1750              NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1751              x, BT_REAL, dr, 0);
1752
1753   add_sym_1 ("dsinh", 1, 1, BT_REAL, dd,
1754              NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1755              x, BT_REAL, dd, 0);
1756
1757   make_generic ("sinh", GFC_ISYM_SINH);
1758
1759   add_sym_2 ("size", 0, 1, BT_INTEGER, di,
1760              gfc_check_size, gfc_simplify_size, NULL,
1761              ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1);
1762
1763   make_generic ("size", GFC_ISYM_SIZE);
1764
1765   add_sym_1 ("spacing", 1, 1, BT_REAL, dr,
1766              gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
1767              x, BT_REAL, dr, 0);
1768
1769   make_generic ("spacing", GFC_ISYM_SPACING);
1770
1771   add_sym_3 ("spread", 0, 1, BT_REAL, dr,
1772              gfc_check_spread, NULL, gfc_resolve_spread,
1773              src, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 0,
1774              n, BT_INTEGER, di, 0);
1775
1776   make_generic ("spread", GFC_ISYM_SPREAD);
1777
1778   add_sym_1 ("sqrt", 1, 1, BT_REAL, dr,
1779              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1780              x, BT_REAL, dr, 0);
1781
1782   add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd,
1783              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1784              x, BT_REAL, dd, 0);
1785
1786   add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz,
1787              NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1788              x, BT_COMPLEX, dz, 0);
1789
1790   add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, x, BT_COMPLEX, dd, 0);   /* Extension */
1791
1792   make_alias ("cdsqrt");
1793
1794   make_generic ("sqrt", GFC_ISYM_SQRT);
1795
1796   add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0,
1797                 gfc_check_product_sum, NULL, gfc_resolve_sum,
1798                 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1799                 msk, BT_LOGICAL, dl, 1);
1800
1801   make_generic ("sum", GFC_ISYM_SUM);
1802
1803   add_sym_1 ("tan", 1, 1, BT_REAL, dr,
1804              NULL, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dr, 0);
1805
1806   add_sym_1 ("dtan", 1, 1, BT_REAL, dd,
1807              NULL, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dd, 0);
1808
1809   make_generic ("tan", GFC_ISYM_TAN);
1810
1811   add_sym_1 ("tanh", 1, 1, BT_REAL, dr,
1812              NULL, gfc_simplify_tanh, gfc_resolve_tanh,
1813              x, BT_REAL, dr, 0);
1814
1815   add_sym_1 ("dtanh", 1, 1, BT_REAL, dd,
1816              NULL, gfc_simplify_tanh, gfc_resolve_tanh,
1817              x, BT_REAL, dd, 0);
1818
1819   make_generic ("tanh", GFC_ISYM_TANH);
1820
1821   add_sym_1 ("tiny", 0, 1, BT_REAL, dr,
1822              gfc_check_x, gfc_simplify_tiny, NULL, x, BT_REAL, dr, 0);
1823
1824   make_generic ("tiny", GFC_ISYM_NONE);
1825
1826   add_sym_3 ("transfer", 0, 1, BT_REAL, dr,
1827              gfc_check_transfer, NULL, gfc_resolve_transfer,
1828              src, BT_REAL, dr, 0, mo, BT_REAL, dr, 0,
1829              sz, BT_INTEGER, di, 1);
1830
1831   make_generic ("transfer", GFC_ISYM_TRANSFER);
1832
1833   add_sym_1 ("transpose", 0, 1, BT_REAL, dr,
1834              gfc_check_transpose, NULL, gfc_resolve_transpose,
1835              m, BT_REAL, dr, 0);
1836
1837   make_generic ("transpose", GFC_ISYM_TRANSPOSE);
1838
1839   add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc,
1840              gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
1841              stg, BT_CHARACTER, dc, 0);
1842
1843   make_generic ("trim", GFC_ISYM_TRIM);
1844
1845   add_sym_2 ("ubound", 0, 1, BT_INTEGER, di,
1846              gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
1847              ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1);
1848
1849   make_generic ("ubound", GFC_ISYM_UBOUND);
1850
1851   add_sym_3 ("unpack", 0, 1, BT_REAL, dr,
1852              gfc_check_unpack, NULL, gfc_resolve_unpack,
1853              v, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0,
1854              f, BT_REAL, dr, 0);
1855
1856   make_generic ("unpack", GFC_ISYM_UNPACK);
1857
1858   add_sym_3 ("verify", 1, 1, BT_INTEGER, di,
1859              gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
1860              stg, BT_CHARACTER, dc, 0, set, BT_CHARACTER, dc, 0,
1861              bck, BT_LOGICAL, dl, 1);
1862
1863   make_generic ("verify", GFC_ISYM_VERIFY);
1864
1865
1866 }
1867
1868
1869
1870 /* Add intrinsic subroutines.  */
1871
1872 static void
1873 add_subroutines (void)
1874 {
1875   /* Argument names as in the standard (to be used as argument keywords).  */
1876   const char
1877     *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
1878     *c = "count", *tm = "time", *tp = "topos", *gt = "get",
1879     *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
1880     *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
1881     *com = "command", *length = "length", *st = "status",
1882     *val = "value", *num = "number", *name = "name",
1883     *trim_name = "trim_name";
1884
1885   int di, dr, dc, dl;
1886
1887   di = gfc_default_integer_kind;
1888   dr = gfc_default_real_kind;
1889   dc = gfc_default_character_kind;
1890   dl = gfc_default_logical_kind;
1891
1892   add_sym_0s ("abort", 1, NULL);
1893
1894   add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0,
1895               gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
1896               tm, BT_REAL, dr, 0);
1897
1898   /* More G77 compatibility garbage. */
1899   add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0,
1900               gfc_check_second_sub, NULL, gfc_resolve_second_sub,
1901               tm, BT_REAL, dr, 0);
1902
1903   add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0,
1904               gfc_check_date_and_time, NULL, NULL,
1905               dt, BT_CHARACTER, dc, 1, tm, BT_CHARACTER, dc, 1,
1906               zn, BT_CHARACTER, dc, 1, vl, BT_INTEGER, di, 1);
1907
1908   /* More G77 compatibility garbage. */
1909   add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0,
1910              gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
1911              vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
1912
1913   add_sym_2s ("dtime", 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 ("getenv", 0, 1, BT_UNKNOWN, 0,
1918               NULL, NULL, NULL,
1919               name, BT_CHARACTER, dc, 0,
1920               val, BT_CHARACTER, dc, 0);
1921
1922   add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0,
1923               NULL, NULL, gfc_resolve_getarg,
1924               c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0);
1925
1926   /* F2003 commandline routines.  */
1927
1928   add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0,
1929               NULL, NULL, gfc_resolve_get_command,
1930               com, BT_CHARACTER, dc, 1,
1931               length, BT_INTEGER, di, 1,
1932               st, BT_INTEGER, di, 1);
1933
1934   add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0,
1935               NULL, NULL, gfc_resolve_get_command_argument,
1936               num, BT_INTEGER, di, 0,
1937               val, BT_CHARACTER, dc, 1,
1938               length, BT_INTEGER, di, 1,
1939               st, BT_INTEGER, di, 1);
1940
1941
1942   /* F2003 subroutine to get environment variables. */
1943
1944   add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0,
1945              NULL, NULL, gfc_resolve_get_environment_variable,
1946              name, BT_CHARACTER, dc, 0,
1947              val, BT_CHARACTER, dc, 1,
1948              length, BT_INTEGER, di, 1,
1949              st, BT_INTEGER, di, 1,
1950              trim_name, BT_LOGICAL, dl, 1);
1951
1952
1953   /* This needs changing to add_sym_5s if it gets a resolution function.  */
1954   add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN, 0,
1955              gfc_check_mvbits, gfc_simplify_mvbits, NULL,
1956              f, BT_INTEGER, di, 0, fp, BT_INTEGER, di, 0,
1957              ln, BT_INTEGER, di, 0, t, BT_INTEGER, di, 0,
1958              tp, BT_INTEGER, di, 0);
1959
1960   add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0,
1961               gfc_check_random_number, NULL, gfc_resolve_random_number,
1962               h, BT_REAL, dr, 0);
1963
1964   add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0,
1965              gfc_check_random_seed, NULL, NULL,
1966              sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1,
1967              gt, BT_INTEGER, di, 1);
1968
1969   /* More G77 compatibility garbage. */
1970   add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di,
1971              gfc_check_srand, NULL, gfc_resolve_srand,
1972              c, BT_INTEGER, 4, 0);
1973
1974   add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0,
1975              gfc_check_system_clock, NULL, gfc_resolve_system_clock,
1976              c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1,
1977              cm, BT_INTEGER, di, 1);
1978 }
1979
1980
1981 /* Add a function to the list of conversion symbols.  */
1982
1983 static void
1984 add_conv (bt from_type, int from_kind, bt to_type, int to_kind,
1985           gfc_expr * (*simplify) (gfc_expr *, bt, int))
1986 {
1987
1988   gfc_typespec from, to;
1989   gfc_intrinsic_sym *sym;
1990
1991   if (sizing == SZ_CONVS)
1992     {
1993       nconv++;
1994       return;
1995     }
1996
1997   gfc_clear_ts (&from);
1998   from.type = from_type;
1999   from.kind = from_kind;
2000
2001   gfc_clear_ts (&to);
2002   to.type = to_type;
2003   to.kind = to_kind;
2004
2005   sym = conversion + nconv;
2006
2007   strcpy (sym->name, conv_name (&from, &to));
2008   strcpy (sym->lib_name, sym->name);
2009   sym->simplify.cc = simplify;
2010   sym->elemental = 1;
2011   sym->ts = to;
2012   sym->generic_id = GFC_ISYM_CONVERSION;
2013
2014   nconv++;
2015 }
2016
2017
2018 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2019    functions by looping over the kind tables.  */
2020
2021 static void
2022 add_conversions (void)
2023 {
2024   int i, j;
2025
2026   /* Integer-Integer conversions.  */
2027   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2028     for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2029       {
2030         if (i == j)
2031           continue;
2032
2033         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2034                   BT_INTEGER, gfc_integer_kinds[j].kind, gfc_convert_constant);
2035       }
2036
2037   /* Integer-Real/Complex conversions.  */
2038   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2039     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2040       {
2041         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2042                   BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
2043
2044         add_conv (BT_REAL, gfc_real_kinds[j].kind,
2045                   BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
2046
2047         add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2048                   BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2049
2050         add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2051                   BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
2052       }
2053
2054   /* Real/Complex - Real/Complex conversions.  */
2055   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2056     for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2057       {
2058         if (i != j)
2059           {
2060             add_conv (BT_REAL, gfc_real_kinds[i].kind,
2061                       BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
2062
2063             add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2064                       BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2065           }
2066
2067         add_conv (BT_REAL, gfc_real_kinds[i].kind,
2068                   BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2069
2070         add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2071                   BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
2072       }
2073
2074   /* Logical/Logical kind conversion.  */
2075   for (i = 0; gfc_logical_kinds[i].kind; i++)
2076     for (j = 0; gfc_logical_kinds[j].kind; j++)
2077       {
2078         if (i == j)
2079           continue;
2080
2081         add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2082                   BT_LOGICAL, gfc_logical_kinds[j].kind, gfc_convert_constant);
2083       }
2084 }
2085
2086
2087 /* Initialize the table of intrinsics.  */
2088 void
2089 gfc_intrinsic_init_1 (void)
2090 {
2091   int i;
2092
2093   nargs = nfunc = nsub = nconv = 0;
2094
2095   /* Create a namespace to hold the resolved intrinsic symbols.  */
2096   gfc_intrinsic_namespace = gfc_get_namespace (NULL);
2097
2098   sizing = SZ_FUNCS;
2099   add_functions ();
2100   sizing = SZ_SUBS;
2101   add_subroutines ();
2102   sizing = SZ_CONVS;
2103   add_conversions ();
2104
2105   functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2106                           + sizeof (gfc_intrinsic_arg) * nargs);
2107
2108   next_sym = functions;
2109   subroutines = functions + nfunc;
2110
2111   conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2112
2113   next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2114
2115   sizing = SZ_NOTHING;
2116   nconv = 0;
2117
2118   add_functions ();
2119   add_subroutines ();
2120   add_conversions ();
2121
2122   /* Set the pure flag.  All intrinsic functions are pure, and
2123      intrinsic subroutines are pure if they are elemental. */
2124
2125   for (i = 0; i < nfunc; i++)
2126     functions[i].pure = 1;
2127
2128   for (i = 0; i < nsub; i++)
2129     subroutines[i].pure = subroutines[i].elemental;
2130 }
2131
2132
2133 void
2134 gfc_intrinsic_done_1 (void)
2135 {
2136   gfc_free (functions);
2137   gfc_free (conversion);
2138   gfc_free_namespace (gfc_intrinsic_namespace);
2139 }
2140
2141
2142 /******** Subroutines to check intrinsic interfaces ***********/
2143
2144 /* Given a formal argument list, remove any NULL arguments that may
2145    have been left behind by a sort against some formal argument list.  */
2146
2147 static void
2148 remove_nullargs (gfc_actual_arglist ** ap)
2149 {
2150   gfc_actual_arglist *head, *tail, *next;
2151
2152   tail = NULL;
2153
2154   for (head = *ap; head; head = next)
2155     {
2156       next = head->next;
2157
2158       if (head->expr == NULL)
2159         {
2160           head->next = NULL;
2161           gfc_free_actual_arglist (head);
2162         }
2163       else
2164         {
2165           if (tail == NULL)
2166             *ap = head;
2167           else
2168             tail->next = head;
2169
2170           tail = head;
2171           tail->next = NULL;
2172         }
2173     }
2174
2175   if (tail == NULL)
2176     *ap = NULL;
2177 }
2178
2179
2180 /* Given an actual arglist and a formal arglist, sort the actual
2181    arglist so that its arguments are in a one-to-one correspondence
2182    with the format arglist.  Arguments that are not present are given
2183    a blank gfc_actual_arglist structure.  If something is obviously
2184    wrong (say, a missing required argument) we abort sorting and
2185    return FAILURE.  */
2186
2187 static try
2188 sort_actual (const char *name, gfc_actual_arglist ** ap,
2189              gfc_intrinsic_arg * formal, locus * where)
2190 {
2191
2192   gfc_actual_arglist *actual, *a;
2193   gfc_intrinsic_arg *f;
2194
2195   remove_nullargs (ap);
2196   actual = *ap;
2197
2198   for (f = formal; f; f = f->next)
2199     f->actual = NULL;
2200
2201   f = formal;
2202   a = actual;
2203
2204   if (f == NULL && a == NULL)   /* No arguments */
2205     return SUCCESS;
2206
2207   for (;;)
2208     {                           /* Put the nonkeyword arguments in a 1:1 correspondence */
2209       if (f == NULL)
2210         break;
2211       if (a == NULL)
2212         goto optional;
2213
2214       if (a->name[0] != '\0')
2215         goto keywords;
2216
2217       f->actual = a;
2218
2219       f = f->next;
2220       a = a->next;
2221     }
2222
2223   if (a == NULL)
2224     goto do_sort;
2225
2226   gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2227   return FAILURE;
2228
2229 keywords:
2230   /* Associate the remaining actual arguments, all of which have
2231      to be keyword arguments.  */
2232   for (; a; a = a->next)
2233     {
2234       for (f = formal; f; f = f->next)
2235         if (strcmp (a->name, f->name) == 0)
2236           break;
2237
2238       if (f == NULL)
2239         {
2240           gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2241                      a->name, name, where);
2242           return FAILURE;
2243         }
2244
2245       if (f->actual != NULL)
2246         {
2247           gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2248                      f->name, name, where);
2249           return FAILURE;
2250         }
2251
2252       f->actual = a;
2253     }
2254
2255 optional:
2256   /* At this point, all unmatched formal args must be optional.  */
2257   for (f = formal; f; f = f->next)
2258     {
2259       if (f->actual == NULL && f->optional == 0)
2260         {
2261           gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2262                      f->name, name, where);
2263           return FAILURE;
2264         }
2265     }
2266
2267 do_sort:
2268   /* Using the formal argument list, string the actual argument list
2269      together in a way that corresponds with the formal list.  */
2270   actual = NULL;
2271
2272   for (f = formal; f; f = f->next)
2273     {
2274       if (f->actual == NULL)
2275         {
2276           a = gfc_get_actual_arglist ();
2277           a->missing_arg_type = f->ts.type;
2278         }
2279       else
2280         a = f->actual;
2281
2282       if (actual == NULL)
2283         *ap = a;
2284       else
2285         actual->next = a;
2286
2287       actual = a;
2288     }
2289   actual->next = NULL;          /* End the sorted argument list. */
2290
2291   return SUCCESS;
2292 }
2293
2294
2295 /* Compare an actual argument list with an intrinsic's formal argument
2296    list.  The lists are checked for agreement of type.  We don't check
2297    for arrayness here.  */
2298
2299 static try
2300 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2301                int error_flag)
2302 {
2303   gfc_actual_arglist *actual;
2304   gfc_intrinsic_arg *formal;
2305   int i;
2306
2307   formal = sym->formal;
2308   actual = *ap;
2309
2310   i = 0;
2311   for (; formal; formal = formal->next, actual = actual->next, i++)
2312     {
2313       if (actual->expr == NULL)
2314         continue;
2315
2316       if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2317         {
2318           if (error_flag)
2319             gfc_error
2320               ("Type of argument '%s' in call to '%s' at %L should be "
2321                "%s, not %s", gfc_current_intrinsic_arg[i],
2322                gfc_current_intrinsic, &actual->expr->where,
2323                gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2324           return FAILURE;
2325         }
2326     }
2327
2328   return SUCCESS;
2329 }
2330
2331
2332 /* Given a pointer to an intrinsic symbol and an expression node that
2333    represent the function call to that subroutine, figure out the type
2334    of the result.  This may involve calling a resolution subroutine.  */
2335
2336 static void
2337 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2338 {
2339   gfc_expr *a1, *a2, *a3, *a4, *a5;
2340   gfc_actual_arglist *arg;
2341
2342   if (specific->resolve.f1 == NULL)
2343     {
2344       if (e->value.function.name == NULL)
2345         e->value.function.name = specific->lib_name;
2346
2347       if (e->ts.type == BT_UNKNOWN)
2348         e->ts = specific->ts;
2349       return;
2350     }
2351
2352   arg = e->value.function.actual;
2353
2354   /* Special case hacks for MIN and MAX.  */
2355   if (specific->resolve.f1m == gfc_resolve_max
2356       || specific->resolve.f1m == gfc_resolve_min)
2357     {
2358       (*specific->resolve.f1m) (e, arg);
2359       return;
2360     }
2361
2362   if (arg == NULL)
2363     {
2364       (*specific->resolve.f0) (e);
2365       return;
2366     }
2367
2368   a1 = arg->expr;
2369   arg = arg->next;
2370
2371   if (arg == NULL)
2372     {
2373       (*specific->resolve.f1) (e, a1);
2374       return;
2375     }
2376
2377   a2 = arg->expr;
2378   arg = arg->next;
2379
2380   if (arg == NULL)
2381     {
2382       (*specific->resolve.f2) (e, a1, a2);
2383       return;
2384     }
2385
2386   a3 = arg->expr;
2387   arg = arg->next;
2388
2389   if (arg == NULL)
2390     {
2391       (*specific->resolve.f3) (e, a1, a2, a3);
2392       return;
2393     }
2394
2395   a4 = arg->expr;
2396   arg = arg->next;
2397
2398   if (arg == NULL)
2399     {
2400       (*specific->resolve.f4) (e, a1, a2, a3, a4);
2401       return;
2402     }
2403
2404   a5 = arg->expr;
2405   arg = arg->next;
2406
2407   if (arg == NULL)
2408     {
2409       (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2410       return;
2411     }
2412
2413   gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2414 }
2415
2416
2417 /* Given an intrinsic symbol node and an expression node, call the
2418    simplification function (if there is one), perhaps replacing the
2419    expression with something simpler.  We return FAILURE on an error
2420    of the simplification, SUCCESS if the simplification worked, even
2421    if nothing has changed in the expression itself.  */
2422
2423 static try
2424 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2425 {
2426   gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2427   gfc_actual_arglist *arg;
2428
2429   /* Max and min require special handling due to the variable number
2430      of args.  */
2431   if (specific->simplify.f1 == gfc_simplify_min)
2432     {
2433       result = gfc_simplify_min (e);
2434       goto finish;
2435     }
2436
2437   if (specific->simplify.f1 == gfc_simplify_max)
2438     {
2439       result = gfc_simplify_max (e);
2440       goto finish;
2441     }
2442
2443   if (specific->simplify.f1 == NULL)
2444     {
2445       result = NULL;
2446       goto finish;
2447     }
2448
2449   arg = e->value.function.actual;
2450
2451   if (arg == NULL)
2452     {
2453       result = (*specific->simplify.f0) ();
2454       goto finish;
2455     }
2456
2457   a1 = arg->expr;
2458   arg = arg->next;
2459
2460   if (specific->simplify.cc == gfc_convert_constant)
2461     {
2462       result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2463       goto finish;
2464     }
2465
2466   /* TODO: Warn if -pedantic and initialization expression and arg
2467      types not integer or character */
2468
2469   if (arg == NULL)
2470     result = (*specific->simplify.f1) (a1);
2471   else
2472     {
2473       a2 = arg->expr;
2474       arg = arg->next;
2475
2476       if (arg == NULL)
2477         result = (*specific->simplify.f2) (a1, a2);
2478       else
2479         {
2480           a3 = arg->expr;
2481           arg = arg->next;
2482
2483           if (arg == NULL)
2484             result = (*specific->simplify.f3) (a1, a2, a3);
2485           else
2486             {
2487               a4 = arg->expr;
2488               arg = arg->next;
2489
2490               if (arg == NULL)
2491                 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2492               else
2493                 {
2494                   a5 = arg->expr;
2495                   arg = arg->next;
2496
2497                   if (arg == NULL)
2498                     result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2499                   else
2500                     gfc_internal_error
2501                       ("do_simplify(): Too many args for intrinsic");
2502                 }
2503             }
2504         }
2505     }
2506
2507 finish:
2508   if (result == &gfc_bad_expr)
2509     return FAILURE;
2510
2511   if (result == NULL)
2512     resolve_intrinsic (specific, e);    /* Must call at run-time */
2513   else
2514     {
2515       result->where = e->where;
2516       gfc_replace_expr (e, result);
2517     }
2518
2519   return SUCCESS;
2520 }
2521
2522
2523 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2524    error messages.  This subroutine returns FAILURE if a subroutine
2525    has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2526    list cannot match any intrinsic.  */
2527
2528 static void
2529 init_arglist (gfc_intrinsic_sym * isym)
2530 {
2531   gfc_intrinsic_arg *formal;
2532   int i;
2533
2534   gfc_current_intrinsic = isym->name;
2535
2536   i = 0;
2537   for (formal = isym->formal; formal; formal = formal->next)
2538     {
2539       if (i >= MAX_INTRINSIC_ARGS)
2540         gfc_internal_error ("init_arglist(): too many arguments");
2541       gfc_current_intrinsic_arg[i++] = formal->name;
2542     }
2543 }
2544
2545
2546 /* Given a pointer to an intrinsic symbol and an expression consisting
2547    of a function call, see if the function call is consistent with the
2548    intrinsic's formal argument list.  Return SUCCESS if the expression
2549    and intrinsic match, FAILURE otherwise.  */
2550
2551 static try
2552 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2553 {
2554   gfc_actual_arglist *arg, **ap;
2555   int r;
2556   try t;
2557
2558   ap = &expr->value.function.actual;
2559
2560   init_arglist (specific);
2561
2562   /* Don't attempt to sort the argument list for min or max.  */
2563   if (specific->check.f1m == gfc_check_min_max
2564       || specific->check.f1m == gfc_check_min_max_integer
2565       || specific->check.f1m == gfc_check_min_max_real
2566       || specific->check.f1m == gfc_check_min_max_double)
2567     return (*specific->check.f1m) (*ap);
2568
2569   if (sort_actual (specific->name, ap, specific->formal,
2570                    &expr->where) == FAILURE)
2571     return FAILURE;
2572
2573   if (specific->check.f3ml == gfc_check_minloc_maxloc)
2574     /* This is special because we might have to reorder the argument
2575        list.  */
2576     t = gfc_check_minloc_maxloc (*ap);
2577   else if (specific->check.f3red == gfc_check_minval_maxval)
2578     /* This is also special because we also might have to reorder the
2579        argument list.  */
2580     t = gfc_check_minval_maxval (*ap);
2581   else if (specific->check.f3red == gfc_check_product_sum)
2582     /* Same here. The difference to the previous case is that we allow a
2583        general numeric type.  */
2584     t = gfc_check_product_sum (*ap);
2585   else
2586      {
2587        if (specific->check.f1 == NULL)
2588          {
2589            t = check_arglist (ap, specific, error_flag);
2590            if (t == SUCCESS)
2591              expr->ts = specific->ts;
2592          }
2593        else
2594          t = do_check (specific, *ap);
2595      }
2596
2597   /* Check ranks for elemental intrinsics.  */
2598   if (t == SUCCESS && specific->elemental)
2599     {
2600       r = 0;
2601       for (arg = expr->value.function.actual; arg; arg = arg->next)
2602         {
2603           if (arg->expr == NULL || arg->expr->rank == 0)
2604             continue;
2605           if (r == 0)
2606             {
2607               r = arg->expr->rank;
2608               continue;
2609             }
2610
2611           if (arg->expr->rank != r)
2612             {
2613               gfc_error
2614                 ("Ranks of arguments to elemental intrinsic '%s' differ "
2615                  "at %L", specific->name, &arg->expr->where);
2616               return FAILURE;
2617             }
2618         }
2619     }
2620
2621   if (t == FAILURE)
2622     remove_nullargs (ap);
2623
2624   return t;
2625 }
2626
2627
2628 /* See if an intrinsic is one of the intrinsics we evaluate
2629    as an extension.  */
2630
2631 static int
2632 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2633 {
2634   /* FIXME: This should be moved into the intrinsic definitions.  */
2635   static const char * const init_expr_extensions[] = {
2636     "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2637     "precision", "present", "radix", "range", "selected_real_kind",
2638     "tiny", NULL
2639   };
2640
2641   int i;
2642
2643   for (i = 0; init_expr_extensions[i]; i++)
2644     if (strcmp (init_expr_extensions[i], isym->name) == 0)
2645       return 0;
2646
2647   return 1;
2648 }
2649
2650
2651 /* See if a function call corresponds to an intrinsic function call.
2652    We return:
2653
2654     MATCH_YES    if the call corresponds to an intrinsic, simplification
2655                  is done if possible.
2656
2657     MATCH_NO     if the call does not correspond to an intrinsic
2658
2659     MATCH_ERROR  if the call corresponds to an intrinsic but there was an
2660                  error during the simplification process.
2661
2662    The error_flag parameter enables an error reporting.  */
2663
2664 match
2665 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
2666 {
2667   gfc_intrinsic_sym *isym, *specific;
2668   gfc_actual_arglist *actual;
2669   const char *name;
2670   int flag;
2671
2672   if (expr->value.function.isym != NULL)
2673     return (do_simplify (expr->value.function.isym, expr) == FAILURE)
2674       ? MATCH_ERROR : MATCH_YES;
2675
2676   gfc_suppress_error = !error_flag;
2677   flag = 0;
2678
2679   for (actual = expr->value.function.actual; actual; actual = actual->next)
2680     if (actual->expr != NULL)
2681       flag |= (actual->expr->ts.type != BT_INTEGER
2682                && actual->expr->ts.type != BT_CHARACTER);
2683
2684   name = expr->symtree->n.sym->name;
2685
2686   isym = specific = gfc_find_function (name);
2687   if (isym == NULL)
2688     {
2689       gfc_suppress_error = 0;
2690       return MATCH_NO;
2691     }
2692
2693   gfc_current_intrinsic_where = &expr->where;
2694
2695   /* Bypass the generic list for min and max.  */
2696   if (isym->check.f1m == gfc_check_min_max)
2697     {
2698       init_arglist (isym);
2699
2700       if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
2701         goto got_specific;
2702
2703       gfc_suppress_error = 0;
2704       return MATCH_NO;
2705     }
2706
2707   /* If the function is generic, check all of its specific
2708      incarnations.  If the generic name is also a specific, we check
2709      that name last, so that any error message will correspond to the
2710      specific.  */
2711   gfc_suppress_error = 1;
2712
2713   if (isym->generic)
2714     {
2715       for (specific = isym->specific_head; specific;
2716            specific = specific->next)
2717         {
2718           if (specific == isym)
2719             continue;
2720           if (check_specific (specific, expr, 0) == SUCCESS)
2721             goto got_specific;
2722         }
2723     }
2724
2725   gfc_suppress_error = !error_flag;
2726
2727   if (check_specific (isym, expr, error_flag) == FAILURE)
2728     {
2729       gfc_suppress_error = 0;
2730       return MATCH_NO;
2731     }
2732
2733   specific = isym;
2734
2735 got_specific:
2736   expr->value.function.isym = specific;
2737   gfc_intrinsic_symbol (expr->symtree->n.sym);
2738
2739   if (do_simplify (specific, expr) == FAILURE)
2740     {
2741       gfc_suppress_error = 0;
2742       return MATCH_ERROR;
2743     }
2744
2745   /* TODO: We should probably only allow elemental functions here.  */
2746   flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
2747
2748   gfc_suppress_error = 0;
2749   if (pedantic && gfc_init_expr
2750       && flag && gfc_init_expr_extensions (specific))
2751     {
2752       if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
2753             "nonstandard initialization expression at %L", &expr->where)
2754           == FAILURE)
2755         {
2756           return MATCH_ERROR;
2757         }
2758     }
2759
2760   return MATCH_YES;
2761 }
2762
2763
2764 /* See if a CALL statement corresponds to an intrinsic subroutine.
2765    Returns MATCH_YES if the subroutine corresponds to an intrinsic,
2766    MATCH_NO if not, and MATCH_ERROR if there was an error (but did
2767    correspond).  */
2768
2769 match
2770 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
2771 {
2772   gfc_intrinsic_sym *isym;
2773   const char *name;
2774
2775   name = c->symtree->n.sym->name;
2776
2777   isym = find_subroutine (name);
2778   if (isym == NULL)
2779     return MATCH_NO;
2780
2781   gfc_suppress_error = !error_flag;
2782
2783   init_arglist (isym);
2784
2785   if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
2786     goto fail;
2787
2788   if (isym->check.f1 != NULL)
2789     {
2790       if (do_check (isym, c->ext.actual) == FAILURE)
2791         goto fail;
2792     }
2793   else
2794     {
2795       if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
2796         goto fail;
2797     }
2798
2799   /* The subroutine corresponds to an intrinsic.  Allow errors to be
2800      seen at this point. */
2801   gfc_suppress_error = 0;
2802
2803   if (isym->resolve.s1 != NULL)
2804     isym->resolve.s1 (c);
2805   else
2806     c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
2807
2808   if (gfc_pure (NULL) && !isym->elemental)
2809     {
2810       gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
2811                  &c->loc);
2812       return MATCH_ERROR;
2813     }
2814
2815   return MATCH_YES;
2816
2817 fail:
2818   gfc_suppress_error = 0;
2819   return MATCH_NO;
2820 }
2821
2822
2823 /* Call gfc_convert_type() with warning enabled.  */
2824
2825 try
2826 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
2827 {
2828   return gfc_convert_type_warn (expr, ts, eflag, 1);
2829 }
2830
2831
2832 /* Try to convert an expression (in place) from one type to another.
2833    'eflag' controls the behavior on error.
2834
2835    The possible values are:
2836
2837      1 Generate a gfc_error()
2838      2 Generate a gfc_internal_error().
2839
2840    'wflag' controls the warning related to conversion.  */
2841
2842 try
2843 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
2844                        int wflag)
2845 {
2846   gfc_intrinsic_sym *sym;
2847   gfc_typespec from_ts;
2848   locus old_where;
2849   gfc_expr *new;
2850   int rank;
2851
2852   from_ts = expr->ts;           /* expr->ts gets clobbered */
2853
2854   if (ts->type == BT_UNKNOWN)
2855     goto bad;
2856
2857   /* NULL and zero size arrays get their type here.  */
2858   if (expr->expr_type == EXPR_NULL
2859       || (expr->expr_type == EXPR_ARRAY
2860           && expr->value.constructor == NULL))
2861     {
2862       /* Sometimes the RHS acquire the type.  */
2863       expr->ts = *ts;
2864       return SUCCESS;
2865     }
2866
2867   if (expr->ts.type == BT_UNKNOWN)
2868     goto bad;
2869
2870   if (expr->ts.type == BT_DERIVED
2871       && ts->type == BT_DERIVED
2872       && gfc_compare_types (&expr->ts, ts))
2873     return SUCCESS;
2874
2875   sym = find_conv (&expr->ts, ts);
2876   if (sym == NULL)
2877     goto bad;
2878
2879   /* At this point, a conversion is necessary. A warning may be needed.  */
2880   if (wflag && gfc_option.warn_conversion)
2881     gfc_warning_now ("Conversion from %s to %s at %L",
2882                      gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
2883
2884   /* Insert a pre-resolved function call to the right function.  */
2885   old_where = expr->where;
2886   rank = expr->rank;
2887   new = gfc_get_expr ();
2888   *new = *expr;
2889
2890   new = gfc_build_conversion (new);
2891   new->value.function.name = sym->lib_name;
2892   new->value.function.isym = sym;
2893   new->where = old_where;
2894   new->rank = rank;
2895
2896   *expr = *new;
2897
2898   gfc_free (new);
2899   expr->ts = *ts;
2900
2901   if (gfc_is_constant_expr (expr->value.function.actual->expr)
2902       && do_simplify (sym, expr) == FAILURE)
2903     {
2904
2905       if (eflag == 2)
2906         goto bad;
2907       return FAILURE;           /* Error already generated in do_simplify() */
2908     }
2909
2910   return SUCCESS;
2911
2912 bad:
2913   if (eflag == 1)
2914     {
2915       gfc_error ("Can't convert %s to %s at %L",
2916                  gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
2917       return FAILURE;
2918     }
2919
2920   gfc_internal_error ("Can't convert %s to %s at %L",
2921                       gfc_typename (&from_ts), gfc_typename (ts),
2922                       &expr->where);
2923   /* Not reached */
2924 }