gcc/fortran/intrinsic.c

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