gcc/fortran/intrinsic.c

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