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