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