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