OSDN Git Service

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