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