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