gcc/fortran/intrinsic.c

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