OSDN Git Service

e4563d73fabab6727f7879345ec48e1e1863d3df
[pf3gnuchains/gcc-fork.git] / gcc / fortran / f95-lang.c
1 /* G95 Backend interface
2    Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
3    Inc.
4    Contributed by Paul Brook.
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.  */
22
23 /* f95-lang.c-- GCC backend interface stuff */
24
25 /* declare required prototypes: */
26
27 #include "config.h"
28 #include "ansidecl.h"
29 #include "system.h"
30 #include "coretypes.h"
31 #include "tree.h"
32 #include "tree-gimple.h"
33 #include "flags.h"
34 #include "langhooks.h"
35 #include "langhooks-def.h"
36 #include "timevar.h"
37 #include "tm.h"
38 #include "function.h"
39 #include "ggc.h"
40 #include "toplev.h"
41 #include "target.h"
42 #include "debug.h"
43 #include "diagnostic.h"
44 #include "tree-dump.h"
45 #include "cgraph.h"
46
47 #include "gfortran.h"
48 #include "trans.h"
49 #include "trans-types.h"
50 #include "trans-const.h"
51
52 #include <assert.h>
53 #include <stdio.h>
54
55 /* Language-dependent contents of an identifier.  */
56
57 struct lang_identifier
58 GTY(())
59 {
60   struct tree_identifier common;
61 };
62
63 /* The resulting tree type.  */
64
65 union lang_tree_node
66 GTY((desc ("TREE_CODE (&%h.generic) == IDENTIFIER_NODE")))
67 {
68   union tree_node GTY((tag ("0"),
69                        desc ("tree_node_structure (&%h)"))) generic;
70   struct lang_identifier GTY((tag ("1"))) identifier;
71 };
72
73 /* Save and restore the variables in this file and elsewhere
74    that keep track of the progress of compilation of the current function.
75    Used for nested functions.  */
76
77 struct language_function
78 GTY(())
79 {
80   /* struct gfc_language_function base; */
81   tree named_labels;
82   tree shadowed_labels;
83   int returns_value;
84   int returns_abnormally;
85   int warn_about_return_type;
86   int extern_inline;
87   struct binding_level *binding_level;
88 };
89
90 /* We don't have a lex/yacc lexer/parser, but toplev expects these to
91    exist anyway.  */
92 void yyerror (const char *str);
93 int yylex (void);
94
95 static void gfc_init_decl_processing (void);
96 static void gfc_init_builtin_functions (void);
97
98 /* Each front end provides its own.  */
99 static bool gfc_init (void);
100 static void gfc_finish (void);
101 static void gfc_print_identifier (FILE *, tree, int);
102 static bool gfc_mark_addressable (tree);
103 void do_function_end (void);
104 int global_bindings_p (void);
105 void insert_block (tree);
106 void set_block (tree);
107 static void gfc_be_parse_file (int);
108 static void gfc_expand_function (tree);
109
110 #undef LANG_HOOKS_NAME
111 #undef LANG_HOOKS_INIT
112 #undef LANG_HOOKS_FINISH
113 #undef LANG_HOOKS_INIT_OPTIONS
114 #undef LANG_HOOKS_HANDLE_OPTION
115 #undef LANG_HOOKS_POST_OPTIONS
116 #undef LANG_HOOKS_PRINT_IDENTIFIER
117 #undef LANG_HOOKS_PARSE_FILE
118 #undef LANG_HOOKS_TRUTHVALUE_CONVERSION
119 #undef LANG_HOOKS_MARK_ADDRESSABLE
120 #undef LANG_HOOKS_TYPE_FOR_MODE
121 #undef LANG_HOOKS_TYPE_FOR_SIZE
122 #undef LANG_HOOKS_UNSIGNED_TYPE
123 #undef LANG_HOOKS_SIGNED_TYPE
124 #undef LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE
125 #undef LANG_HOOKS_GIMPLE_BEFORE_INLINING
126 #undef LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION
127
128 /* Define lang hooks.  */
129 #define LANG_HOOKS_NAME                 "GNU F95"
130 #define LANG_HOOKS_INIT                 gfc_init
131 #define LANG_HOOKS_FINISH               gfc_finish
132 #define LANG_HOOKS_INIT_OPTIONS         gfc_init_options
133 #define LANG_HOOKS_HANDLE_OPTION        gfc_handle_option
134 #define LANG_HOOKS_POST_OPTIONS         gfc_post_options
135 #define LANG_HOOKS_PRINT_IDENTIFIER     gfc_print_identifier
136 #define LANG_HOOKS_PARSE_FILE           gfc_be_parse_file
137 #define LANG_HOOKS_TRUTHVALUE_CONVERSION   gfc_truthvalue_conversion
138 #define LANG_HOOKS_MARK_ADDRESSABLE        gfc_mark_addressable
139 #define LANG_HOOKS_TYPE_FOR_MODE           gfc_type_for_mode
140 #define LANG_HOOKS_TYPE_FOR_SIZE           gfc_type_for_size
141 #define LANG_HOOKS_UNSIGNED_TYPE           gfc_unsigned_type
142 #define LANG_HOOKS_SIGNED_TYPE             gfc_signed_type
143 #define LANG_HOOKS_SIGNED_OR_UNSIGNED_TYPE gfc_signed_or_unsigned_type
144 #define LANG_HOOKS_GIMPLE_BEFORE_INLINING false
145 #define LANG_HOOKS_CALLGRAPH_EXPAND_FUNCTION gfc_expand_function
146
147 const struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
148
149 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
150    that have names.  Here so we can clear out their names' definitions
151    at the end of the function.  */
152
153 /* Tree code classes.  */
154
155 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) TYPE,
156
157 const char tree_code_type[] = {
158 #include "tree.def"
159 };
160 #undef DEFTREECODE
161
162 /* Table indexed by tree code giving number of expression
163    operands beyond the fixed part of the node structure.
164    Not used for types or decls.  */
165
166 #define DEFTREECODE(SYM, NAME, TYPE, LENGTH) LENGTH,
167
168 const unsigned char tree_code_length[] = {
169 #include "tree.def"
170 };
171 #undef DEFTREECODE
172
173 /* Names of tree components.
174    Used for printing out the tree and error messages.  */
175 #define DEFTREECODE(SYM, NAME, TYPE, LEN) NAME,
176
177 const char *const tree_code_name[] = {
178 #include "tree.def"
179 };
180 #undef DEFTREECODE
181
182 static tree named_labels;
183
184 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
185
186 /* A chain of binding_level structures awaiting reuse.  */
187
188 static GTY(()) struct binding_level *free_binding_level;
189
190 /* The elements of `ridpointers' are identifier nodes
191    for the reserved type names and storage classes.
192    It is indexed by a RID_... value.  */
193 tree *ridpointers = NULL;
194
195 /* language-specific flags.  */
196
197 static void
198 gfc_expand_function (tree fndecl)
199 {
200   tree_rest_of_compilation (fndecl, 0);
201 }
202 \f
203
204 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
205    or validate its data type for an `if' or `while' statement or ?..: exp.
206
207    This preparation consists of taking the ordinary
208    representation of an expression expr and producing a valid tree
209    boolean expression describing whether expr is nonzero.  We could
210    simply always do build_binary_op (NE_EXPR, expr, boolean_false_node, 1),
211    but we optimize comparisons, &&, ||, and !.
212
213    The resulting type should always be `boolean_type_node'.
214    This is much simpler than the corresponding C version because we have a
215    distinct boolean type.  */
216
217 tree
218 gfc_truthvalue_conversion (tree expr)
219 {
220   switch (TREE_CODE (TREE_TYPE (expr)))
221     {
222     case BOOLEAN_TYPE:
223       if (TREE_TYPE (expr) == boolean_type_node)
224         return expr;
225       else if (TREE_CODE_CLASS (TREE_CODE (expr)) == '<')
226         {
227           TREE_TYPE (expr) = boolean_type_node;
228           return expr;
229         }
230       else if (TREE_CODE (expr) == NOP_EXPR)
231         return build1 (NOP_EXPR, boolean_type_node,
232                        TREE_OPERAND (expr, 0));
233       else
234         return build1 (NOP_EXPR, boolean_type_node, expr);
235
236     case INTEGER_TYPE:
237       if (TREE_CODE (expr) == INTEGER_CST)
238         return integer_zerop (expr) ? boolean_false_node : boolean_true_node;
239       else
240         return build (NE_EXPR, boolean_type_node, expr, integer_zero_node);
241
242     default:
243       internal_error ("Unexpected type in truthvalue_conversion");
244     }
245 }
246
247 static void
248 gfc_create_decls (void)
249 {
250   /* GCC builtins.  */
251   gfc_init_builtin_functions ();
252
253   /* Runtime/IO library functions.  */
254   gfc_build_builtin_function_decls ();
255
256   gfc_init_constants ();
257 }
258
259 static void
260 gfc_be_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
261 {
262   int errors;
263   int warnings;
264
265   gfc_create_decls ();
266   gfc_parse_file ();
267   gfc_generate_constructors ();
268
269   cgraph_finalize_compilation_unit ();
270   cgraph_optimize ();
271
272   /* Tell the frontent about any errors.  */
273   gfc_get_errors (&warnings, &errors);
274   errorcount += errors;
275   warningcount += warnings;
276 }
277 \f
278 /* Initialize everything.  */
279
280 static bool
281 gfc_init (void)
282 {
283   /* First initialize the backend.  */
284   gfc_init_decl_processing ();
285   gfc_static_ctors = NULL_TREE;
286
287   /* Then the frontend.  */
288   gfc_init_1 ();
289
290   if (gfc_new_file (gfc_option.source, gfc_option.source_form) != SUCCESS)
291     fatal_error ("can't open input file: %s", gfc_option.source);
292   return true;
293 }
294
295
296 static void
297 gfc_finish (void)
298 {
299   gfc_done_1 ();
300   gfc_release_include_path ();
301   return;
302 }
303
304 static void
305 gfc_print_identifier (FILE * file ATTRIBUTE_UNUSED,
306                       tree node ATTRIBUTE_UNUSED,
307                       int indent ATTRIBUTE_UNUSED)
308 {
309   return;
310 }
311 \f
312
313 /* These functions and variables deal with binding contours.  We only
314    need these functions for the list of PARM_DECLs, but we leave the
315    functions more general; these are a simplified version of the
316    functions from GNAT.  */
317
318 /* For each binding contour we allocate a binding_level structure which records
319    the entities defined or declared in that contour. Contours include:
320
321         the global one
322         one for each subprogram definition
323         one for each compound statement (declare block)
324
325    Binding contours are used to create GCC tree BLOCK nodes.  */
326
327 struct binding_level
328 GTY(())
329 {
330   /* A chain of ..._DECL nodes for all variables, constants, functions,
331      parameters and type declarations.  These ..._DECL nodes are chained
332      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
333      in the reverse of the order supplied to be compatible with the
334      back-end.  */
335   tree names;
336   /* For each level (except the global one), a chain of BLOCK nodes for all
337      the levels that were entered and exited one level down from this one.  */
338   tree blocks;
339   /* The back end may need, for its own internal processing, to create a BLOCK
340      node. This field is set aside for this purpose. If this field is non-null
341      when the level is popped, i.e. when poplevel is invoked, we will use such
342      block instead of creating a new one from the 'names' field, that is the
343      ..._DECL nodes accumulated so far.  Typically the routine 'pushlevel'
344      will be called before setting this field, so that if the front-end had
345      inserted ..._DECL nodes in the current block they will not be lost.   */
346   tree block_created_by_back_end;
347   /* The binding level containing this one (the enclosing binding level). */
348   struct binding_level *level_chain;
349 };
350
351 /* The binding level currently in effect.  */
352 static GTY(()) struct binding_level *current_binding_level = NULL;
353
354 /* The outermost binding level. This binding level is created when the
355    compiler is started and it will exist through the entire compilation.  */
356 static GTY(()) struct binding_level *global_binding_level;
357
358 /* Binding level structures are initialized by copying this one.  */
359 static struct binding_level clear_binding_level = { NULL, NULL, NULL, NULL };
360 \f
361 /* Return non-zero if we are currently in the global binding level.  */
362
363 int
364 global_bindings_p (void)
365 {
366   return current_binding_level == global_binding_level ? -1 : 0;
367 }
368
369 tree
370 getdecls (void)
371 {
372   return current_binding_level->names;
373 }
374
375 /* Enter a new binding level. The input parameter is ignored, but has to be
376    specified for back-end compatibility.  */
377
378 void
379 pushlevel (int ignore ATTRIBUTE_UNUSED)
380 {
381   struct binding_level *newlevel
382     = (struct binding_level *) ggc_alloc (sizeof (struct binding_level));
383
384   *newlevel = clear_binding_level;
385
386   /* Add this level to the front of the chain (stack) of levels that are
387      active.  */
388   newlevel->level_chain = current_binding_level;
389   current_binding_level = newlevel;
390 }
391
392 /* Exit a binding level.
393    Pop the level off, and restore the state of the identifier-decl mappings
394    that were in effect when this level was entered.
395
396    If KEEP is nonzero, this level had explicit declarations, so
397    and create a "block" (a BLOCK node) for the level
398    to record its declarations and subblocks for symbol table output.
399
400    If FUNCTIONBODY is nonzero, this level is the body of a function,
401    so create a block as if KEEP were set and also clear out all
402    label names.
403
404    If REVERSE is nonzero, reverse the order of decls before putting
405    them into the BLOCK.  */
406
407 tree
408 poplevel (int keep, int reverse, int functionbody)
409 {
410   /* Points to a BLOCK tree node. This is the BLOCK node construted for the
411      binding level that we are about to exit and which is returned by this
412      routine.  */
413   tree block_node = NULL_TREE;
414   tree decl_chain;
415   tree subblock_chain = current_binding_level->blocks;
416   tree subblock_node;
417   tree block_created_by_back_end;
418
419   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
420      nodes chained through the `names' field of current_binding_level are in
421      reverse order except for PARM_DECL node, which are explicitely stored in
422      the right order.  */
423   decl_chain = (reverse) ? nreverse (current_binding_level->names)
424     : current_binding_level->names;
425
426   block_created_by_back_end =
427     current_binding_level->block_created_by_back_end;
428   if (block_created_by_back_end != 0)
429     {
430       block_node = block_created_by_back_end;
431
432       /* Check if we are about to discard some information that was gathered
433          by the front-end. Nameley check if the back-end created a new block
434          without calling pushlevel first. To understand why things are lost
435          just look at the next case (i.e. no block created by back-end.  */
436       if ((keep || functionbody) && (decl_chain || subblock_chain))
437         abort ();
438     }
439
440   /* If there were any declarations in the current binding level, or if this
441      binding level is a function body, or if there are any nested blocks then
442      create a BLOCK node to record them for the life of this function.  */
443   else if (keep || functionbody)
444     block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0);
445
446   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
447   for (subblock_node = subblock_chain; subblock_node;
448        subblock_node = TREE_CHAIN (subblock_node))
449     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
450
451   /* Clear out the meanings of the local variables of this level.  */
452
453   for (subblock_node = decl_chain; subblock_node;
454        subblock_node = TREE_CHAIN (subblock_node))
455     if (DECL_NAME (subblock_node) != 0)
456       /* If the identifier was used or addressed via a local extern decl,
457          don't forget that fact.   */
458       if (DECL_EXTERNAL (subblock_node))
459         {
460           if (TREE_USED (subblock_node))
461             TREE_USED (DECL_NAME (subblock_node)) = 1;
462           if (TREE_ADDRESSABLE (subblock_node))
463             TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
464         }
465
466   /* Pop the current level.  */
467   current_binding_level = current_binding_level->level_chain;
468
469   if (functionbody)
470     {
471       /* This is the top level block of a function. The ..._DECL chain stored
472          in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
473          leave them in the BLOCK because they are found in the FUNCTION_DECL
474          instead.  */
475       DECL_INITIAL (current_function_decl) = block_node;
476       BLOCK_VARS (block_node) = 0;
477     }
478   else if (block_node)
479     {
480       if (block_created_by_back_end == NULL)
481         current_binding_level->blocks
482           = chainon (current_binding_level->blocks, block_node);
483     }
484
485   /* If we did not make a block for the level just exited, any blocks made for
486      inner levels (since they cannot be recorded as subblocks in that level)
487      must be carried forward so they will later become subblocks of something
488      else.  */
489   else if (subblock_chain)
490     current_binding_level->blocks
491       = chainon (current_binding_level->blocks, subblock_chain);
492   if (block_node)
493     TREE_USED (block_node) = 1;
494
495   return block_node;
496 }
497 \f
498 /* Insert BLOCK at the end of the list of subblocks of the
499    current binding level.  This is used when a BIND_EXPR is expanded,
500    to handle the BLOCK node inside the BIND_EXPR.  */
501
502 void
503 insert_block (tree block)
504 {
505   TREE_USED (block) = 1;
506   current_binding_level->blocks
507     = chainon (current_binding_level->blocks, block);
508 }
509
510 /* Set the BLOCK node for the innermost scope
511    (the one we are currently in).  */
512
513 void
514 set_block (tree block)
515 {
516   current_binding_level->block_created_by_back_end = block;
517 }
518
519 /* Records a ..._DECL node DECL as belonging to the current lexical scope.
520    Returns the ..._DECL node. */
521
522 tree
523 pushdecl (tree decl)
524 {
525   /* External objects aren't nested, other objects may be.  */
526   if ((DECL_EXTERNAL (decl)) || (decl == current_function_decl))
527     DECL_CONTEXT (decl) = 0;
528   else
529     DECL_CONTEXT (decl) = current_function_decl;
530
531   /* Put the declaration on the list.  The list of declarations is in reverse
532      order. The list will be reversed later if necessary.  This needs to be
533      this way for compatibility with the back-end.  */
534
535   TREE_CHAIN (decl) = current_binding_level->names;
536   current_binding_level->names = decl;
537
538   /* For the declartion of a type, set its name if it is not already set. */
539
540   if (TREE_CODE (decl) == TYPE_DECL && TYPE_NAME (TREE_TYPE (decl)) == 0)
541     {
542       if (DECL_SOURCE_LINE (decl) == 0)
543         TYPE_NAME (TREE_TYPE (decl)) = decl;
544       else
545         TYPE_NAME (TREE_TYPE (decl)) = DECL_NAME (decl);
546     }
547
548   return decl;
549 }
550
551
552 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL.  */
553
554 tree
555 pushdecl_top_level (tree x)
556 {
557   tree t;
558   struct binding_level *b = current_binding_level;
559
560   current_binding_level = global_binding_level;
561   t = pushdecl (x);
562   current_binding_level = b;
563   return t;
564 }
565
566
567 #ifndef CHAR_TYPE_SIZE
568 #define CHAR_TYPE_SIZE BITS_PER_UNIT
569 #endif
570
571 #ifndef INT_TYPE_SIZE
572 #define INT_TYPE_SIZE BITS_PER_WORD
573 #endif
574
575 #undef SIZE_TYPE
576 #define SIZE_TYPE "long unsigned int"
577
578 /* Create tree nodes for the basic scalar types of Fortran 95,
579    and some nodes representing standard constants (0, 1, (void *) 0).
580    Initialize the global binding level.
581    Make definitions for built-in primitive functions.  */
582 static void
583 gfc_init_decl_processing (void)
584 {
585   current_function_decl = NULL;
586   named_labels = NULL;
587   current_binding_level = NULL_BINDING_LEVEL;
588   free_binding_level = NULL_BINDING_LEVEL;
589
590   /* Make the binding_level structure for global names. We move all
591      variables that are in a COMMON block to this binding level.  */
592   pushlevel (0);
593   global_binding_level = current_binding_level;
594
595   /* Build common tree nodes. char_type_node is unsigned because we
596      only use it for actual characters, not for INTEGER(1). Also, we
597      want double_type_node to actually have double precision.   */
598   build_common_tree_nodes (0);
599   set_sizetype (long_unsigned_type_node);
600   build_common_tree_nodes_2 (0);
601
602   /* Set up F95 type nodes.  */
603   gfc_init_types ();
604 }
605
606 /* Mark EXP saying that we need to be able to take the
607    address of it; it should not be allocated in a register.
608    In Fortran 95 this is only the case for variables with
609    the TARGET attribute, but we implement it here for a
610    likely future Cray pointer extension.
611    Value is 1 if successful.  */
612 /* TODO: Check/fix mark_addressable.  */
613 bool
614 gfc_mark_addressable (tree exp)
615 {
616   register tree x = exp;
617   while (1)
618     switch (TREE_CODE (x))
619       {
620       case COMPONENT_REF:
621       case ADDR_EXPR:
622       case ARRAY_REF:
623       case REALPART_EXPR:
624       case IMAGPART_EXPR:
625         x = TREE_OPERAND (x, 0);
626         break;
627
628       case CONSTRUCTOR:
629         TREE_ADDRESSABLE (x) = 1;
630         return true;
631
632       case VAR_DECL:
633       case CONST_DECL:
634       case PARM_DECL:
635       case RESULT_DECL:
636         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x) && DECL_NONLOCAL (x))
637           {
638             if (TREE_PUBLIC (x))
639               {
640                 error
641                   ("global register variable `%s' used in nested function",
642                    IDENTIFIER_POINTER (DECL_NAME (x)));
643                 return false;
644               }
645             pedwarn ("register variable `%s' used in nested function",
646                      IDENTIFIER_POINTER (DECL_NAME (x)));
647           }
648         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
649           {
650             if (TREE_PUBLIC (x))
651               {
652                 error ("address of global register variable `%s' requested",
653                        IDENTIFIER_POINTER (DECL_NAME (x)));
654                 return true;
655               }
656
657 #if 0
658             /* If we are making this addressable due to its having
659                volatile components, give a different error message.  Also
660                handle the case of an unnamed parameter by not trying
661                to give the name.  */
662
663             else if (C_TYPE_FIELDS_VOLATILE (TREE_TYPE (x)))
664               {
665                 error ("cannot put object with volatile field into register");
666                 return false;
667               }
668 #endif
669
670             pedwarn ("address of register variable `%s' requested",
671                      IDENTIFIER_POINTER (DECL_NAME (x)));
672           }
673         put_var_into_stack (x, /*rescan=*/true);
674
675         /* drops in */
676       case FUNCTION_DECL:
677         TREE_ADDRESSABLE (x) = 1;
678
679       default:
680         return true;
681       }
682 }
683
684 /* press the big red button - garbage (ggc) collection is on */
685
686 int ggc_p = 1;
687
688 /* Builtin function initialisation.  */
689
690 /* Return a definition for a builtin function named NAME and whose data type
691    is TYPE.  TYPE should be a function type with argument types.
692    FUNCTION_CODE tells later passes how to compile calls to this function.
693    See tree.h for its possible values.
694
695    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
696    the name to be called if we can't opencode the function.  If
697    ATTRS is nonzero, use that for the function's attribute list.  */
698
699 tree
700 builtin_function (const char *name,
701                   tree type,
702                   int function_code,
703                   enum built_in_class class,
704                   const char *library_name,
705                   tree attrs ATTRIBUTE_UNUSED)
706 {
707   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
708   DECL_EXTERNAL (decl) = 1;
709   TREE_PUBLIC (decl) = 1;
710   if (library_name)
711     SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
712   make_decl_rtl (decl, NULL);
713   pushdecl (decl);
714   DECL_BUILT_IN_CLASS (decl) = class;
715   DECL_FUNCTION_CODE (decl) = function_code;
716   return decl;
717 }
718
719
720 static void
721 gfc_define_builtin (const char * name,
722                     tree type,
723                     int code,
724                     const char * library_name,
725                     bool const_p)
726 {
727   tree decl;
728
729   decl = builtin_function (name, type, code, BUILT_IN_NORMAL,
730                            library_name, NULL_TREE);
731   if (const_p)
732     TREE_READONLY (decl) = 1;
733
734   built_in_decls[code] = decl;
735   implicit_built_in_decls[code] = decl;
736 }
737
738
739 #define DEFINE_MATH_BUILTIN(code, name, nargs) \
740     gfc_define_builtin ("__builtin_" name, mfunc_double[nargs-1], \
741                         BUILT_IN_ ## code, name, true); \
742     gfc_define_builtin ("__builtin_" name "f", mfunc_float[nargs-1], \
743                         BUILT_IN_ ## code ## F, name "f", true);
744
745 /* Initialisation of builtin function nodes.  */
746 static void
747 gfc_init_builtin_functions (void)
748 {
749   tree mfunc_float[2];
750   tree mfunc_double[2];
751   tree ftype;
752   tree tmp;
753   tree voidchain;
754
755   voidchain = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
756
757   tmp = tree_cons (NULL_TREE, float_type_node, voidchain);
758   mfunc_float[0] = build_function_type (float_type_node, tmp);
759   tmp = tree_cons (NULL_TREE, float_type_node, tmp);
760   mfunc_float[1] = build_function_type (float_type_node, tmp);
761
762   tmp = tree_cons (NULL_TREE, double_type_node, voidchain);
763   mfunc_double[0] = build_function_type (double_type_node, tmp);
764   tmp = tree_cons (NULL_TREE, double_type_node, tmp);
765   mfunc_double[1] = build_function_type (double_type_node, tmp);
766
767 #include "mathbuiltins.def"
768
769   /* We define these seperately as the fortran versions have different
770      semantics (they return an integer type) */
771   gfc_define_builtin ("__builtin_floor", mfunc_double[0], 
772                       BUILT_IN_FLOOR, "floor", true);
773   gfc_define_builtin ("__builtin_floorf", mfunc_float[0], 
774                       BUILT_IN_FLOORF, "floorf", true);
775   gfc_define_builtin ("__builtin_round", mfunc_double[0], 
776                       BUILT_IN_ROUND, "round", true);
777   gfc_define_builtin ("__builtin_roundf", mfunc_float[0], 
778                       BUILT_IN_ROUNDF, "roundf", true);
779
780   /* Other builtin functions we use.  */
781
782   tmp = tree_cons (NULL_TREE, long_integer_type_node, voidchain);
783   tmp = tree_cons (NULL_TREE, long_integer_type_node, tmp);
784   ftype = build_function_type (long_integer_type_node, tmp);
785   gfc_define_builtin ("__builtin_expect", ftype, BUILT_IN_EXPECT,
786                       "__builtin_expect", true);
787
788   tmp = tree_cons (NULL_TREE, size_type_node, voidchain);
789   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
790   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
791   ftype = build_function_type (pvoid_type_node, tmp);
792   gfc_define_builtin ("__builtin_memcpy", ftype, BUILT_IN_MEMCPY,
793                       "memcpy", false);
794
795   tmp = tree_cons (NULL_TREE, integer_type_node, voidchain);
796   ftype = build_function_type (integer_type_node, tmp);
797   gfc_define_builtin ("__builtin_clz", ftype, BUILT_IN_CLZ, "clz", true);
798
799   tmp = tree_cons (NULL_TREE, long_integer_type_node, voidchain);
800   ftype = build_function_type (integer_type_node, tmp);
801   gfc_define_builtin ("__builtin_clzl", ftype, BUILT_IN_CLZL, "clzl", true);
802
803   tmp = tree_cons (NULL_TREE, long_long_integer_type_node, voidchain);
804   ftype = build_function_type (integer_type_node, tmp);
805   gfc_define_builtin ("__builtin_clzll", ftype, BUILT_IN_CLZLL, "clzll", true);
806
807   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
808   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
809   tmp = tree_cons (NULL_TREE, pvoid_type_node, tmp);
810   ftype = build_function_type (void_type_node, tmp);
811   gfc_define_builtin ("__builtin_init_trampoline", ftype,
812                       BUILT_IN_INIT_TRAMPOLINE, "init_trampoline", false);
813
814   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
815   ftype = build_function_type (pvoid_type_node, tmp);
816   gfc_define_builtin ("__builtin_adjust_trampoline", ftype,
817                       BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true);
818
819   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
820   tmp = tree_cons (NULL_TREE, size_type_node, voidchain);
821   ftype = build_function_type (pvoid_type_node, tmp);
822   gfc_define_builtin ("__builtin_stack_alloc", ftype, BUILT_IN_STACK_ALLOC,
823                       "stack_alloc", false);
824
825   /* The stack_save and stack_restore builtins aren't used directly.  They
826      are inserted during gimplification to implement stack_alloc calls.  */
827   ftype = build_function_type (pvoid_type_node, voidchain);
828   gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE,
829                       "stack_save", false);
830   tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
831   ftype = build_function_type (void_type_node, tmp);
832   gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE,
833                       "stack_restore", false);
834 }
835
836 #undef DEFINE_MATH_BUILTIN
837
838 #include "gt-fortran-f95-lang.h"
839 #include "gtype-fortran.h"