home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / a-trans3.c < prev    next >
C/C++ Source or Header  |  1996-09-28  |  63KB  |  1,907 lines
  1. /****************************************************************************/
  2. /*                                                                          */
  3. /*                         GNAT COMPILER COMPONENTS                         */
  4. /*                                                                          */
  5. /*                             A - T R A N S 3                              */
  6. /*                                                                          */
  7. /*                          C Implementation File                           */
  8. /*                                                                          */
  9. /*                            $Revision: 1.122 $                             */
  10. /*                                                                          */
  11. /*           Copyright (c) 1992,1993,1994 NYU, All Rights Reserved          */
  12. /*                                                                          */
  13. /* GNAT is free software;  you can  redistribute it  and/or modify it under */
  14. /* terms of the  GNU General Public License as published  by the Free Soft- */
  15. /* ware  Foundation;  either version 2,  or (at your option) any later ver- */
  16. /* sion.  GNAT is distributed in the hope that it will be useful, but WITH- */
  17. /* OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY */
  18. /* or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License */
  19. /* for  more details.  You should have  received  a copy of the GNU General */
  20. /* Public License  distributed with GNAT;  see file COPYING.  If not, write */
  21. /* to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
  22. /*                                                                          */
  23. /****************************************************************************/
  24.  
  25. #include "config.h"
  26. #include "tree.h"
  27. #include "flags.h"
  28. #include "a-ada.h"
  29. #include "a-types.h"
  30. #include "a-atree.h"
  31. #include "a-nlists.h"
  32. #include "a-elists.h"
  33. #include "a-sinfo.h"
  34. #include "a-einfo.h"
  35. #include "a-namet.h"
  36. #include "a-string.h"
  37. #include "a-uintp.h"
  38. #include "a-trans.h"
  39. #include "a-gtran3.h"
  40. #include "a-trans3.h"
  41. #include "a-trans4.h"
  42. #include "a-misc.h"
  43. #include "a-rtree.h"
  44. #include "convert.h"
  45.  
  46. #undef  NULL
  47. #define NULL 0
  48.  
  49. /* If nonzero, pretend we are allocating at global level.  */
  50.  
  51. int force_global;
  52.  
  53. /* Global Variables for the various types we create.  */ 
  54.  
  55. tree error_mark_node;
  56. tree integer_type_node;
  57. tree unsigned_type_node;
  58. tree char_type_node;
  59. tree longest_float_type_node;
  60. tree void_type_node;
  61. tree void_type_decl_node;
  62. tree ptr_void_type_node;
  63. tree void_ftype;
  64. tree ptr_void_ftype;
  65.  
  66. tree except_type_node;
  67. tree malloc_decl;
  68. tree free_decl;
  69. tree jmpbuf_type;
  70. tree jmpbuf_ptr_type;
  71. tree get_jmpbuf_decl;
  72. tree set_jmpbuf_decl;
  73. tree get_excptr_decl;
  74. tree raise_decl;
  75. tree raise_nodefer_decl;
  76. tree setjmp_decl;
  77. tree raise_constraint_error_decl;
  78. tree raise_program_error_decl;
  79. tree unchecked_union_node;
  80.  
  81. tree integer_zero_node;
  82. tree integer_one_node;
  83. tree null_pointer_node;
  84.  
  85. tree current_function_decl = NULL;
  86.  
  87. static int contains_placeholder_except_p PROTO((tree, tree));
  88.  
  89. /* Routines to Associate and Retrieve GCC Nodes with Gnat Nodes: */
  90.  
  91. /* Associates a GNAT tree node to a GCC tree node. It is used in
  92.    `save_gnu_tree', `get_gnu_tree' and `present_gnu_tree'. See documentation
  93.    of `save_gnu_tree' for more info.  */
  94. static tree *associate_gnat_to_gnu;
  95.  
  96. /* This listhead is used to record any global objects that need elaboration.
  97.    TREE_PURPOSE is the variable to be elaborated and TREE_VALUE is the
  98.    initial value to assign.  */
  99.  
  100. static tree pending_elaborations;
  101.  
  102. /* This stack allows us to momentarily switch to generating elaboration
  103.    lists for an inner context.  */
  104.  
  105. static struct e_stack {struct e_stack *next; tree elab_list; } *elist_stack;
  106.  
  107. extern struct obstack *saveable_obstack;
  108.  
  109. /* Initialize the association of GNAT nodes to GCC trees.  */
  110.  
  111. void
  112. init_gnat_to_gnu ()
  113. {
  114.   Node_Id gnat_node;
  115.  
  116.   associate_gnat_to_gnu   = (tree *) xmalloc (max_gnat_nodes * sizeof (tree));
  117.  
  118.   for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
  119.     associate_gnat_to_gnu [gnat_node]   = NULL_TREE;
  120.  
  121.   associate_gnat_to_gnu   -= First_Node_Id;
  122.  
  123.   pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
  124. }
  125.  
  126. /* GNAT_ENTITY is a GNAT tree node for an entity.   GNU_DECL is the GCC tree
  127.    which is to be associated with GNAT_ENTITY. Such GCC tree node is always
  128.    a ..._DECL node.  If NO_CHECK is nonzero, the latter check is suppressed.
  129.  
  130.    If GNU_DECL is zero, a previous association is to be reset.  */
  131.  
  132. void
  133. save_gnu_tree (gnat_entity, gnu_decl, no_check)
  134.      Entity_Id gnat_entity;
  135.      tree gnu_decl;
  136.      int no_check;
  137. {
  138.   if (gnu_decl
  139.       && (associate_gnat_to_gnu [gnat_entity]
  140.       || (! no_check && TREE_CODE_CLASS (TREE_CODE (gnu_decl)) != 'd')))
  141.     gigi_abort (401);
  142.  
  143.   associate_gnat_to_gnu [gnat_entity] = gnu_decl;
  144. }
  145.  
  146. /* GNAT_ENTITY is a GNAT tree node for a defining identifier.
  147.    Return the ..._DECL node that was associated with it.  If there is no tree
  148.    node associated with GNAT_ENTITY, abort.  */
  149.  
  150. tree
  151. get_gnu_tree (gnat_entity)
  152.      Entity_Id gnat_entity;
  153. {
  154.   if (! associate_gnat_to_gnu [gnat_entity])
  155.     gigi_abort (402);
  156.  
  157.   return associate_gnat_to_gnu [gnat_entity];
  158. }
  159.  
  160. /* Return nonzero if a GCC tree has been associated with GNAT_ENTITY.  */
  161.  
  162. int
  163. present_gnu_tree (gnat_entity)
  164.      Entity_Id gnat_entity;
  165. {
  166.   return (associate_gnat_to_gnu [gnat_entity] != NULL_TREE);
  167. }
  168.  
  169. /* For each binding contour we allocate a binding_level structure which records
  170.    the entities defined or declared in that contour. Contours include:
  171.  
  172.     the global one
  173.     one for each subprogram definition
  174.     one for each compound statement (declare block)
  175.  
  176.    Binding contours are used to create GCC tree BLOCK nodes.  */
  177.  
  178. struct binding_level
  179. {
  180.   /* A chain of ..._DECL nodes for all variables, constants, functions,
  181.      parameters and type declarations.  These ..._DECL nodes are chained
  182.      through the TREE_CHAIN field. Note that these ..._DECL nodes are stored
  183.      in the reverse of the order supplied to be compatible with the
  184.      back-end.  */
  185.   tree names;
  186.   /* For each level (except the global one), a chain of BLOCK nodes for all
  187.      the levels that were entered and exited one level down from this one.  */
  188.   tree blocks;
  189.   /* The back end may need, for its own internal processing, to create a BLOCK
  190.      node. This field is set aside for this purpose. If this field is non-null
  191.      when the level is popped, i.e. when poplevel is invoked, we will use such
  192.      block instead of creating a new one from the 'names' field, that is the
  193.      ..._DECL nodes accumulated so far.  Typically the routine 'pushlevel'
  194.      will be called before setting this field, so that if the front-end had
  195.      inserted ..._DECL nodes in the current block they will not be lost.   */
  196.   tree block_created_by_back_end;
  197.   /* The binding level containing this one (the enclosing binding level). */
  198.   struct binding_level *level_chain;
  199. };
  200.  
  201. /* The binding level currently in effect.  */
  202. static struct binding_level *current_binding_level = NULL;
  203.  
  204. /* A chain of binding_level structures awaiting reuse.  */
  205. static struct binding_level *free_binding_level = NULL;
  206.  
  207. /* The outermost binding level. This binding level is created when the
  208.    compiler is started and it will exist through the entire compilation.  */
  209. static struct binding_level *global_binding_level;
  210.  
  211. /* Binding level structures are initialized by copying this one.  */
  212. static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL};
  213.  
  214. /* Return non-zero if we are currently in the global binding level.  */
  215.  
  216. int
  217. global_bindings_p ()
  218. {
  219.   return (force_global != 0 || current_binding_level == global_binding_level
  220.       ? -1 : 0);
  221. }
  222.  
  223. /* Return the list of declarations in the current level. Note that this list
  224.    is in reverse order (it has to be so for back-end compatibility).  */
  225.  
  226. tree
  227. getdecls ()
  228. {
  229.   return current_binding_level->names;
  230. }
  231.  
  232. /* Nonzero if the current level needs to have a BLOCK made.  */
  233.  
  234. int
  235. kept_level_p ()
  236. {
  237.   return (current_binding_level->names != 0);
  238. }
  239.  
  240. /* Enter a new binding level. The input parameter is ignored, but has to be
  241.    specified for back-end compatibility.  */
  242.  
  243. void
  244. pushlevel (ignore)
  245.      int ignore;
  246. {
  247.   struct binding_level *newlevel = NULL;
  248.  
  249.   /* Reuse a struct for this binding level, if there is one.  */
  250.   if (free_binding_level)
  251.     {
  252.       newlevel = free_binding_level;
  253.       free_binding_level = free_binding_level->level_chain;
  254.     }
  255.   else
  256.     newlevel =
  257.       (struct binding_level *) xmalloc (sizeof (struct binding_level));
  258.  
  259.   *newlevel = clear_binding_level;
  260.  
  261.   /* Add this level to the front of the chain (stack) of levels that are
  262.      active.  */
  263.   newlevel->level_chain = current_binding_level;
  264.   current_binding_level = newlevel;
  265. }
  266.  
  267. /* Exit a binding level.
  268.    Pop the level off, and restore the state of the identifier-decl mappings
  269.    that were in effect when this level was entered.
  270.  
  271.    If KEEP is nonzero, this level had explicit declarations, so
  272.    and create a "block" (a BLOCK node) for the level
  273.    to record its declarations and subblocks for symbol table output.
  274.  
  275.    If FUNCTIONBODY is nonzero, this level is the body of a function,
  276.    so create a block as if KEEP were set and also clear out all
  277.    label names.
  278.  
  279.    If REVERSE is nonzero, reverse the order of decls before putting
  280.    them into the BLOCK.  */
  281.  
  282. tree
  283. poplevel (keep, reverse, functionbody)
  284.      int keep;
  285.      int reverse;
  286.      int functionbody;
  287. {
  288.   /* Points to a GCC BLOCK tree node. This is the BLOCK node construted for the
  289.      binding level that we are about to exit and which is returned by this
  290.      routine.  */
  291.   tree block_node = NULL_TREE;
  292.   tree decl_chain;
  293.   tree decl_node;
  294.   tree subblock_chain = current_binding_level->blocks;
  295.   tree subblock_node;
  296.   tree block_created_by_back_end;
  297.  
  298.   /* Reverse the list of XXXX_DECL nodes if desired.  Note that the ..._DECL
  299.      nodes chained through the `names' field of current_binding_level are in
  300.      reverse order except for PARM_DECL node, which are explicitely stored in
  301.      the right order.  */
  302.   decl_chain = (reverse) ? nreverse (current_binding_level->names)
  303.                          : current_binding_level->names;
  304.  
  305.   /* Output any nested inline functions within this block which must be
  306.      compiled because their address is needed. */
  307.   for (decl_node = decl_chain; decl_node; decl_node = TREE_CHAIN (decl_node))
  308.     if ((TREE_CODE (decl_node) == FUNCTION_DECL)
  309.     && ! TREE_ASM_WRITTEN (decl_node)
  310.     && (DECL_INITIAL (decl_node) != 0)
  311.     && TREE_ADDRESSABLE (decl_node))
  312.       {
  313.     push_function_context ();
  314.     output_inline_function (decl_node);
  315.     pop_function_context ();
  316.       }
  317.  
  318.   block_created_by_back_end = current_binding_level->block_created_by_back_end;
  319.   if (block_created_by_back_end != 0)
  320.     {
  321.       block_node = block_created_by_back_end;
  322.  
  323.       /* Update decls and chain into the block the back end made.  */
  324.       if ((keep || functionbody) && (decl_chain || subblock_chain))
  325.     {
  326.       BLOCK_VARS (block_node) = keep? decl_chain : 0;
  327.       BLOCK_SUBBLOCKS (block_node) = subblock_chain;
  328.     }
  329.     }
  330.  
  331.   /* If there were any declarations in the current binding level, or if this
  332.      binding level is a function body, or if there are any nested blocks then
  333.      create a BLOCK node to record them for the life of this function.  */
  334.   else if (keep || functionbody)
  335.     block_node = build_block (keep ? decl_chain : 0, 0, subblock_chain, 0, 0);
  336.  
  337.   /* Record the BLOCK node just built as the subblock its enclosing scope.  */
  338.   for (subblock_node = subblock_chain; subblock_node;
  339.        subblock_node = TREE_CHAIN (subblock_node))
  340.     BLOCK_SUPERCONTEXT (subblock_node) = block_node;
  341.  
  342.   /* Clear out the meanings of the local variables of this level.  */
  343.  
  344.   for (subblock_node = decl_chain; subblock_node;
  345.        subblock_node = TREE_CHAIN (subblock_node))
  346.     if (DECL_NAME (subblock_node) != 0)
  347.       /* If the identifier was used or addressed via a local extern decl,  
  348.      don't forget that fact.   */
  349.       if (DECL_EXTERNAL (subblock_node))
  350.     {
  351.       if (TREE_USED (subblock_node))
  352.         TREE_USED (DECL_NAME (subblock_node)) = 1;
  353.       if (TREE_ADDRESSABLE (subblock_node))
  354.         TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
  355.     }
  356.  
  357.   {
  358.     /* Pop the current level, and free the structure for reuse.  */
  359.     struct binding_level *level = current_binding_level;
  360.     current_binding_level = current_binding_level->level_chain;
  361.     level->level_chain = free_binding_level;
  362.     free_binding_level = level;
  363.   }
  364.  
  365.   if (functionbody)
  366.     {
  367.       /* This is the top level block of a function. The ..._DECL chain stored
  368.      in BLOCK_VARS are the function's parameters (PARM_DECL nodes). Don't
  369.      leave them in the BLOCK because they are found in the FUNCTION_DECL
  370.      instead.  */
  371.       DECL_INITIAL (current_function_decl) = block_node;
  372.       BLOCK_VARS (block_node) = 0;
  373.     }
  374.   else if (block_node)
  375.     {
  376.       if (block_created_by_back_end == NULL)
  377.     current_binding_level->blocks
  378.       = chainon (current_binding_level->blocks, block_node);
  379.     }
  380.  
  381.   /* If we did not make a block for the level just exited, any blocks made for
  382.      inner levels (since they cannot be recorded as subblocks in that level)
  383.      must be carried forward so they will later become subblocks of something
  384.      else.  */
  385.   else if (subblock_chain)
  386.     current_binding_level->blocks
  387.       = chainon (current_binding_level->blocks, subblock_chain);
  388.   if (block_node)
  389.     TREE_USED (block_node) = 1;
  390.  
  391.   return block_node;
  392. }
  393.  
  394. /* Insert BLOCK at the end of the list of subblocks of the
  395.    current binding level.  This is used when a BIND_EXPR is expanded,
  396.    to handle the BLOCK node inside the BIND_EXPR.  */
  397.  
  398. void
  399. insert_block (block)
  400.      tree block;
  401. {
  402.   TREE_USED (block) = 1;
  403.   current_binding_level->blocks
  404.     = chainon (current_binding_level->blocks, block);
  405. }
  406.  
  407. /* Set the BLOCK node for the innermost scope
  408.    (the one we are currently in).  */
  409.  
  410. void
  411. set_block (block)
  412.      tree block;
  413. {
  414.   current_binding_level->block_created_by_back_end = block;
  415. }
  416.  
  417. /* Records a ..._DECL node DECL as belonging to the current lexical scope.
  418.    Returns the ..._DECL node. */
  419.  
  420. tree
  421. pushdecl (decl)
  422.      tree decl;
  423. {
  424.   struct binding_level *b = current_binding_level;
  425.  
  426.   /* External objects aren't nested, other objects may be.  */
  427.   if (DECL_EXTERNAL (decl))
  428.     {
  429.       DECL_CONTEXT (decl) = 0;
  430.       b = global_binding_level;
  431.     }
  432.   else
  433.     DECL_CONTEXT (decl) = current_function_decl;
  434.  
  435.   /* Put the declaration on the list.  The list of declarations is in reverse
  436.      order. The list will be reversed later if necessary.  This needs to be
  437.      this way for compatibility with the back-end.
  438.  
  439.      Don't put TYPE_DECLs for UNCONSTRAINED_ARRAY_TYPE into the list.  They
  440.      will cause trouble with the debugger and aren't needed anyway.  */
  441.   if (TREE_CODE (decl) != TYPE_DECL
  442.       || TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
  443.     {
  444.       TREE_CHAIN (decl) = b->names;
  445.       b->names = decl;
  446.     }
  447.  
  448.   /* For the declaration of a type, set its name if it either is not already
  449.      set or is an implicit type name.  We'd rather have the type named with a
  450.      real name and all the pointer types to the same object have the same
  451.      POINTER_TYPE node.  Code in this function in c-decl.c makes a copy
  452.      of the type node here, but that may cause us trouble with incomplete
  453.      types, so let's not try it (at least for now).  Ensure we don't set a
  454.      name if TYPE is not in the same obstack as DECL would have been placed. */
  455.  
  456.   if (TREE_CODE (decl) == TYPE_DECL
  457.       && DECL_NAME (decl) != 0
  458.       && (TYPE_NAME (TREE_TYPE (decl)) == 0
  459.       || (TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == IDENTIFIER_NODE
  460.           && *(IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)))) == 'T'))
  461.       && (TREE_PERMANENT (decl)
  462.       || saveable_obstack == TYPE_OBSTACK (TREE_TYPE (decl))))
  463.     TYPE_NAME (TREE_TYPE (decl)) = decl;
  464.  
  465.   return decl;
  466. }
  467.  
  468. /* Create the predefined scalar types such as `integer_type_node' needed 
  469.    in the gcc back-end and initialize the global binding level.  */
  470.  
  471. void
  472. init_decl_processing ()
  473. {
  474.   tree endlink;
  475.  
  476.   /* The structure `tree_identifier' is the GCC tree data structure that holds
  477.      IDENTIFIER_NODE nodes. We need to call `set_identifier_size' to tell GCC
  478.      that we have not added any language specific fields to IDENTIFIER_NODE
  479.      nodes.  */
  480.   set_identifier_size (sizeof (struct tree_identifier));
  481.  
  482.   lineno = 0;
  483.  
  484.   /* incomplete_decl_finalize_hook is defined in toplev.c. It needs to be set
  485.      by each front end to the appropriate routine that handles incomplete 
  486.      VAR_DECL nodes. This routine will be invoked by compile_file when a  
  487.      VAR_DECL node of DECL_SIZE zero is encountered.  */
  488.   incomplete_decl_finalize_hook = finish_incomplete_decl;
  489.  
  490.   /* Make the binding_level structure for global names.  */
  491.   current_function_decl = 0;
  492.   current_binding_level = 0;
  493.   free_binding_level = 0;
  494.   pushlevel (0);
  495.   global_binding_level = current_binding_level;
  496.  
  497.   /* In Ada, we use a signed type for SIZETYPE.  Use the signed type
  498.      corresponding to the size of Pmode.  */
  499.   sizetype = type_for_size (GET_MODE_BITSIZE (Pmode), 0);
  500.   pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype));
  501.  
  502.   integer_type_node = type_for_size (INT_TYPE_SIZE, 0) ;
  503.   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"), integer_type_node));
  504.   unsigned_type_node = type_for_size (INT_TYPE_SIZE, 1);
  505.   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
  506.             unsigned_type_node));
  507.   char_type_node = type_for_size (CHAR_TYPE_SIZE, 1);
  508.   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
  509.             char_type_node));
  510.  
  511.   longest_float_type_node = make_node (REAL_TYPE);
  512.   TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
  513.   layout_type (longest_float_type_node);
  514.   pushdecl (build_decl (TYPE_DECL, get_identifier ("longest float type"),
  515.             longest_float_type_node));
  516.  
  517.   error_mark_node = make_node (ERROR_MARK);
  518.   TREE_TYPE (error_mark_node) = error_mark_node;
  519.  
  520.   integer_zero_node = build_int_2 (0, 0);
  521.   integer_one_node = build_int_2 (1, 0);
  522.  
  523.   size_zero_node = build_int_2 (0, 0);
  524.   TREE_TYPE (size_zero_node) = sizetype;
  525.   size_one_node = build_int_2 (1, 0);
  526.   TREE_TYPE (size_one_node) = sizetype;
  527.  
  528.   void_type_node = make_node (VOID_TYPE);
  529.   layout_type (void_type_node);
  530.   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
  531.   void_type_decl_node
  532.     = pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
  533.                 void_type_node));
  534.  
  535.   ptr_void_type_node = build_pointer_type (void_type_node);
  536.  
  537.   null_pointer_node = build_int_2 (0, 0);
  538.   TREE_TYPE (null_pointer_node) = ptr_void_type_node;
  539.   layout_type (TREE_TYPE (null_pointer_node));
  540.  
  541.   void_ftype = build_function_type (void_type_node, NULL_TREE);
  542.   ptr_void_ftype = build_pointer_type (void_ftype);
  543.  
  544.   /* Now declare runtime functions. */
  545.   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
  546.  
  547.   /* malloc is a function declaration tree for a function to allocate
  548.      memory.  */
  549.   malloc_decl = create_subprog_decl ("__gnat_malloc", NULL_PTR,
  550.                      build_function_type (ptr_void_type_node,
  551.                               tree_cons (NULL_TREE,
  552.                                      sizetype,
  553.                                      endlink)),
  554.                      NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  555.  
  556.   /* free is a function declaration tree for a function to free memory.  */
  557.  
  558.   free_decl
  559.     = create_subprog_decl ("free", NULL_PTR,
  560.                build_function_type (void_type_node,
  561.                         tree_cons (NULL_TREE,
  562.                                ptr_void_type_node,
  563.                                endlink)),
  564.                NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  565.  
  566.   /* Make the types and functions used for exception processing.  
  567.      We assume here that a jmp_buf is no more than 100 size_t entries.  */
  568.   jmpbuf_type
  569.     = build_array_type (sizetype, build_index_type (build_int_2 (100, 0)));
  570.   pushdecl (build_decl (TYPE_DECL, get_identifier ("jmpbuf_t"), jmpbuf_type));
  571.   jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
  572.  
  573.   /* Functions to get and set the jumpbuf pointer for the current thread.  */
  574.   get_jmpbuf_decl
  575.     = create_subprog_decl ("system__task_specific_data__get_jmpbuf_address",
  576.                NULL_PTR,
  577.                (build_function_type (jmpbuf_ptr_type, NULL_TREE)),
  578.                NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  579.  
  580.   set_jmpbuf_decl
  581.     = create_subprog_decl ("system__task_specific_data__set_jmpbuf_address",
  582.                NULL_PTR,
  583.                build_function_type (void_type_node, 
  584.                            tree_cons (NULL_TREE,
  585.                               jmpbuf_ptr_type,
  586.                               endlink)),
  587.                NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  588.  
  589.   /* Right now the type of an exception is a byte.  We need to
  590.      get the actual type from the front end eventually.  */
  591.   except_type_node = char_type_node;
  592.  
  593.   /* Function to get the current exception.  */
  594.   get_excptr_decl
  595.     = create_subprog_decl ("system__task_specific_data__get_gnat_exception",
  596.                NULL_PTR,
  597.                build_function_type
  598.                (build_pointer_type (except_type_node), NULL_TREE),
  599.                NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  600.  
  601.   /* Functions that raise exceptions.  */
  602.   raise_decl
  603.     = create_subprog_decl
  604.       ("__gnat_raise", NULL_PTR,
  605.        build_function_type (void_type_node,
  606.                 tree_cons (NULL_TREE,
  607.                        build_pointer_type (except_type_node),
  608.                        endlink)),
  609.        NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  610.  
  611.   raise_nodefer_decl
  612.     = create_subprog_decl
  613.       ("__gnat_raise_nodefer", NULL_PTR,
  614.        build_function_type (void_type_node,
  615.                 tree_cons (NULL_TREE,
  616.                        build_pointer_type (except_type_node),
  617.                        endlink)),
  618.        NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  619.  
  620.   /* Indicate that these never return.  */
  621.   TREE_THIS_VOLATILE (raise_decl) = 1;
  622.   TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
  623.  
  624.   /* setjmp returns an integer and has one operand, which is a pointer to
  625.      a jmpbuf.  */
  626.   setjmp_decl
  627.     = create_subprog_decl
  628. #ifdef WINNT
  629.       ("_setjmp", NULL_PTR,
  630. #else
  631.       ("setjmp", NULL_PTR,
  632. #endif
  633.        build_function_type (integer_type_node,
  634.                 tree_cons (NULL_TREE,  jmpbuf_ptr_type, endlink)),
  635.        NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  636.  
  637.   /* __gnat_raise_constraint_error takes no operands and never returns.  */
  638.   raise_constraint_error_decl
  639.     = create_subprog_decl
  640.       ("__gnat_raise_constraint_error", NULL_PTR,
  641.        build_function_type (void_type_node, endlink),
  642.        NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  643.  
  644.   TREE_THIS_VOLATILE (raise_constraint_error_decl) = 1;
  645.   TREE_SIDE_EFFECTS (raise_constraint_error_decl) = 1;
  646.  
  647.   /* Likewise for __gnat_raise_program_error.  */
  648.   raise_program_error_decl
  649.     = create_subprog_decl
  650.       ("__gnat_raise_program_error", NULL_PTR,
  651.        build_function_type (void_type_node, endlink),
  652.        NULL_TREE, 0, 1, 1, 0, NULL_TREE);
  653.  
  654.   TREE_THIS_VOLATILE (raise_program_error_decl) = 1;
  655.   TREE_SIDE_EFFECTS (raise_program_error_decl) = 1;
  656.  
  657.   /* Make a UNION_TYPE that will be copied to form a union to be used to
  658.      do an unchecked conversion.  */
  659.   unchecked_union_node = make_node (UNION_TYPE);
  660. }
  661.  
  662. /* This routine is called in tree.c to print an error message for invalid use
  663.    of an incomplete type.  */
  664.  
  665. void
  666. incomplete_type_error (dont_care_1, dont_care_2)
  667.      tree dont_care_1, dont_care_2;
  668. {
  669.   gigi_abort (404);
  670. }
  671.  
  672. /* This function is called indirectly from toplev.c to handle incomplete 
  673.    declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero.  To be precise,
  674.    compile_file in toplev.c makes an indirect call through the function pointer
  675.    incomplete_decl_finalize_hook which is initialized to this routine in
  676.    init_decl_processing.  */
  677.  
  678. void
  679. finish_incomplete_decl (dont_care)
  680.      tree dont_care;
  681. {
  682.   gigi_abort (405);
  683. }
  684.  
  685. /* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
  686.    nodes (FIELDLIST), finish constructing the record or union type. 
  687.    If HAS_REP is nonzero, this record has a rep clause; don't call
  688.    layout_type but merely set the size and alignment ourselves. 
  689.    If DEFER_DEBUG is nonzero, do not call the debugging routines
  690.    on this type; it will be done later. */
  691.  
  692. void
  693. finish_record_type (record_type, fieldlist, has_rep, defer_debug)
  694.      tree record_type;
  695.      tree fieldlist;
  696.      int has_rep;
  697.      int defer_debug;
  698. {
  699.   TYPE_FIELDS (record_type) = fieldlist;
  700.  
  701.   if (TYPE_NAME (record_type) != 0
  702.       && TREE_CODE (TYPE_NAME (record_type)) == TYPE_DECL)
  703.     TYPE_STUB_DECL (record_type) = TYPE_NAME (record_type);
  704.   else
  705.     TYPE_STUB_DECL (record_type)
  706.       = pushdecl (build_decl (TYPE_DECL, TYPE_NAME (record_type),
  707.                   record_type));
  708.  
  709.   /* If we had a rep clause, compute the size from the highest ending position
  710.      plus one and the alignment from the highest actual alignment.  Otherwise,
  711.      let GCC lay out the type.  */
  712.   if (has_rep)
  713.     {
  714.       tree field;
  715.       int must_be_blkmode = 0;
  716.       int has_size = (TYPE_SIZE (record_type) != 0);
  717.  
  718.       TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
  719.       TYPE_MODE (record_type) = BLKmode;
  720.       if (TYPE_SIZE (record_type) == 0)
  721.     TYPE_SIZE (record_type) = size_int (0);
  722.  
  723.       for (field = fieldlist; field; field = TREE_CHAIN (field))
  724.     {
  725.       tree end_bit = size_binop (PLUS_EXPR, DECL_FIELD_BITPOS (field),
  726.                      DECL_SIZE (field));
  727.       int bitpos;
  728.  
  729.       if (tree_int_cst_lt (TYPE_SIZE (record_type), end_bit))
  730.         TYPE_SIZE (record_type) = end_bit;
  731.  
  732.       if (TREE_INT_CST_LOW (DECL_FIELD_BITPOS (field)) % DECL_ALIGN (field) == 0
  733.           && DECL_FIELD_SIZE (field) % DECL_ALIGN (field) == 0)
  734.         TYPE_ALIGN (record_type)
  735.           = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
  736.  
  737.       /* A record which has any BLKmode members must itself be BLKmode; it
  738.          can't go in a register unless the member is BLKmode only because
  739.          it isn't aligned.  */
  740.       if (TYPE_MODE (TREE_TYPE (field)) == BLKmode
  741.           && ! TYPE_NO_FORCE_BLK (TREE_TYPE (field)))
  742.         must_be_blkmode = 1;
  743.  
  744.       bitpos = TREE_INT_CST_LOW (DECL_FIELD_BITPOS (field));
  745.  
  746.       /* Must be BLKmode if any field crosses a word boundary,
  747.          since extract_bit_field can't handle that in registers.  */
  748.       if (bitpos / BITS_PER_WORD
  749.           != ((TREE_INT_CST_LOW (DECL_SIZE (field)) + bitpos - 1)
  750.           / BITS_PER_WORD)
  751.           /* But there is no problem if the field is entire words.  */
  752.           && TREE_INT_CST_LOW (DECL_SIZE (field)) % BITS_PER_WORD == 0)
  753.         must_be_blkmode = 1;
  754.     }
  755.  
  756.       /* First round our size to a multiple of a byte.  */
  757.       TYPE_SIZE (record_type)
  758.     = round_up (TYPE_SIZE (record_type), BITS_PER_UNIT);
  759.  
  760.       /* If a size was not specified, round the size we've computed
  761.      to the required alignment of the type.  If a size was specified,
  762.      see if it restricts the alignment.  */
  763.       if (! has_size)
  764.     {
  765. #ifdef ROUND_TYPE_SIZE
  766.       TYPE_SIZE (record_type)
  767.         = ROUND_TYPE_SIZE (record_type, TYPE_SIZE (record_type),
  768.                    TYPE_ALIGN (record_type));
  769. #else
  770.       TYPE_SIZE (record_type) = round_up (TYPE_SIZE (record_type),
  771.                           TYPE_ALIGN (record_type));
  772. #endif
  773.     }
  774.       else
  775.     TYPE_ALIGN (record_type)
  776.       = MIN (TYPE_ALIGN (record_type),
  777.          (TREE_INT_CST_LOW (TYPE_SIZE (record_type))
  778.           & (- TREE_INT_CST_LOW (TYPE_SIZE (record_type)))));
  779.  
  780.       if (! must_be_blkmode)
  781.     TYPE_MODE (record_type)
  782.       = mode_for_size (TREE_INT_CST_LOW (TYPE_SIZE (record_type)),
  783.                MODE_INT, 1);
  784.  
  785.       /* If structure's known alignment is less than
  786.      what the scalar mode would need, and it matters,
  787.      then stick with BLKmode.  */
  788.       if (STRICT_ALIGNMENT
  789.       && ! (TYPE_ALIGN (record_type) >= BIGGEST_ALIGNMENT
  790.         || (TYPE_ALIGN (record_type)
  791.             >= TREE_INT_CST_LOW (TYPE_SIZE (record_type)))))
  792.     {
  793.       if (TYPE_MODE (record_type) != BLKmode)
  794.         /* If this is the only reason this type is BLKmode,
  795.            then don't force containing types to be BLKmode.  */
  796.         TYPE_NO_FORCE_BLK (record_type) = 1;
  797.       TYPE_MODE (record_type) = BLKmode;
  798.     }
  799.     }
  800.   else
  801.     layout_type (record_type);
  802.  
  803.   if (! defer_debug)
  804.     rest_of_type_compilation (record_type, global_bindings_p ());
  805. }
  806.  
  807. /* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
  808.    subprogram. If it is void_type_node, then we are dealing with a procedure,
  809.    otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
  810.    PARM_DECL nodes that are the subprogram arguments.  CICO_LIST is the
  811.    copy-in/copy-out list to be stored into TYPE_CICO_LIST.
  812.    RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
  813.    object.  RETURNS_BY_REF is nonzero if the function returns by reference.  */
  814.  
  815. tree
  816. create_subprog_type (return_type, param_decl_list, cico_list,
  817.              returns_unconstrained, returns_by_ref)
  818.      tree return_type;
  819.      tree param_decl_list;
  820.      tree cico_list;
  821.      int returns_unconstrained, returns_by_ref;
  822. {
  823.   /* A chain of TREE_LIST nodes whose TREE_VALUEs are the data type nodes of
  824.      the subprogram formal parameters. This list is generated by traversing th
  825.      input list of PARM_DECL nodes.  */
  826.   tree param_type_list = NULL;
  827.   tree param_decl;
  828.   tree type;
  829.  
  830.   for (param_decl = param_decl_list; param_decl;
  831.        param_decl = TREE_CHAIN (param_decl))
  832.     param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl),
  833.                  param_type_list);
  834.  
  835.   /* The list of the function parameter types has to be terminated by the void
  836.      type to signal to the back-end that we are not dealing with a variable
  837.      parameter subprogram, but that the subprogram has a fixed number of
  838.      parameters.  */
  839.   param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
  840.  
  841.   /* The list of argument types has been created in reverse
  842.      so nreverse it.   */
  843.   param_type_list = nreverse (param_type_list);
  844.  
  845.   type = build_function_type (return_type, param_type_list);
  846.  
  847.   /* TYPE may have been shared since GCC hashes types.  If it has a CICO_LIST
  848.      or the new type should, make a copy of TYPE.  Likewise for
  849.      RETURNS_UNCONSTRAINED and RETURNS_BY_REF.  */
  850.   if (TYPE_CI_CO_LIST (type) != 0 || cico_list != 0
  851.       || TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
  852.       || TYPE_RETURNS_BY_REF_P (type) != returns_by_ref)
  853.     {
  854.       push_obstacks (TYPE_OBSTACK (type), TYPE_OBSTACK (type));
  855.       type = copy_node (type);
  856.       pop_obstacks ();
  857.     }
  858.  
  859.   TYPE_CI_CO_LIST (type) = cico_list;
  860.   TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
  861.   TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
  862.   return type;
  863. }
  864.  
  865. /* Return a copy of TYPE, in the same obstack as it was, but safe to modify
  866.    in any way.  */
  867.  
  868. tree
  869. copy_type (type)
  870.      tree type;
  871. {
  872.   tree new;
  873.  
  874.   push_obstacks (TYPE_OBSTACK (type), TYPE_OBSTACK (type));
  875.   new = copy_node (type);
  876.   pop_obstacks ();
  877.  
  878.   TYPE_POINTER_TO (new) = 0;
  879.   TYPE_REFERENCE_TO (new) = 0;
  880.   TYPE_MAIN_VARIANT (new) = new;
  881.   TYPE_NEXT_VARIANT (new) = 0;
  882.  
  883.   return new;
  884. }
  885.  
  886. /* Return an INTEGER_TYPE of SIZETYPE with range MIN to MAX and whose
  887.    TYPE_INDEX_TYPE is INDEX.  */
  888.  
  889. tree
  890. create_index_type (min, max, index)
  891.      tree min, max;
  892.      tree index;
  893. {
  894.   /* First build a type for the desired range.  */
  895.   tree type = build_index_2_type (min, max);
  896.  
  897.   /* If this type has the TYPE_INDEX_TYPE we want, return it.  Otherwise, if it
  898.      doesn't have TYPE_INDEX_TYPE set, set it to INDEX.  If TYPE_INDEX_TYPE
  899.      is set, but not to INDEX, make a copy of this type with the requested
  900.      index type.  Note that we have no way of sharing these types, but that's
  901.      only a small hole.  */
  902.   if (TYPE_INDEX_TYPE (type) == index)
  903.     return type;
  904.   else if (TYPE_INDEX_TYPE (type) != 0)
  905.     type = copy_type (type);
  906.  
  907.   TYPE_INDEX_TYPE (type) = index;
  908.   return type;
  909. }
  910.  
  911. /* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
  912.    string) and TYPE is a ..._TYPE node giving its data type.  */
  913.  
  914. tree
  915. create_type_decl (type_name, type)
  916.      char *type_name;
  917.      tree type;
  918. {
  919.   tree id_node   = type_name ? get_identifier (type_name): NULL_TREE;
  920.   tree type_decl = build_decl (TYPE_DECL, id_node, type);
  921.   enum tree_code code = TREE_CODE (type);
  922.  
  923.   /* Add this decl to the current binding level.  */
  924.   type_decl = pushdecl (type_decl);
  925.  
  926.   /* Pass type declaration information to the debugger unless this is an
  927.      UNCONSTRAINED_ARRAY_TYPE, which the debugger does not support,
  928.      and ENUMERAL_TYPE or RECORD_TYPE which is handled separately,
  929.      or a dummy type, which will be completed later.  */
  930.   if (code != UNCONSTRAINED_ARRAY_TYPE && code != ENUMERAL_TYPE 
  931.       && code != RECORD_TYPE && ! TYPE_IS_DUMMY_P (type))
  932.     rest_of_decl_compilation (type_decl, NULL, global_bindings_p (), 0);
  933.  
  934.   return type_decl;
  935. }
  936.  
  937. /* Returns a GCC VAR_DECL node. VAR_NAME gives the name of the variable (a
  938.    character string). ASM_NAME is its assembler name (if provided).  TYPE is
  939.    its data type (a GCC ..._TYPE node).  VAR_INIT is the GCC tree for an
  940.    optional initial expression; NULL_TREE if none.
  941.  
  942.    SIZE, if nonzero, is a GCC tree to be used for the size of the variable.
  943.    ALIGN, if nonzero, is the required alignment of the variable.
  944.  
  945.    CONST_FLAG is nonzero if this variable is constant.
  946.  
  947.    PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
  948.    the current compilation unit. This flag should be set when processing the
  949.    variable definitions in a package specification.  EXTERN_FLAG is nonzero 
  950.    when processing an external variable declaration (as opposed to a
  951.    definition: no storage is to be allocated for the variable here). 
  952.    STATIC_FLAG is only relevant when not at top level.  In that case
  953.    it indicates whether to always allocate storage to the variable.   */
  954.  
  955. tree
  956. create_var_decl (var_name, asm_name, type, var_init, size, align,
  957.          const_flag, public_flag, extern_flag, static_flag)
  958.      char *var_name;
  959.      char *asm_name;
  960.      tree type;
  961.      tree var_init;
  962.      tree size;
  963.      int align;
  964.      int const_flag;
  965.      int public_flag;
  966.      int extern_flag;
  967.      int static_flag;
  968. {
  969.   tree id_node  = get_identifier (var_name);
  970.   tree var_decl
  971.     = build_decl ((const_flag && var_init && TREE_CONSTANT (var_init)
  972.            /* Only make a CONST_DECL for sufficiently-small objects.
  973.               We consider complex double "sufficiently-small"  */
  974.            && TYPE_SIZE (type)
  975.            && TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST
  976.            && TREE_INT_CST_HIGH (TYPE_SIZE (type)) == 0
  977.            && (TREE_INT_CST_LOW (TYPE_SIZE (type))
  978.                <= GET_MODE_BITSIZE (DCmode)))
  979.           ? CONST_DECL : VAR_DECL, id_node, type);
  980.  
  981.   /* If this is external, throw away any initializations unless this is a
  982.      CONST_DECL (meaning we have a constant); they will be done elsewhere.  If
  983.      we are defining a global here, leave a constant initialization and save
  984.      any variable elaborations for the elaboration routine.  */
  985.  
  986.   if (extern_flag && TREE_CODE (var_decl) != CONST_DECL)
  987.     var_init = 0;
  988.  
  989.   if (global_bindings_p () && var_init != 0 && ! TREE_CONSTANT (var_init))
  990.     {
  991.       add_pending_elaborations (var_decl, var_init);
  992.       var_init = 0;
  993.     }
  994.  
  995.   DECL_COMMON   (var_decl) = 1;
  996.   DECL_INITIAL  (var_decl) = var_init;
  997.   TREE_READONLY (var_decl) = const_flag;
  998.   DECL_EXTERNAL (var_decl) = extern_flag;
  999.   TREE_PUBLIC   (var_decl) = public_flag || extern_flag;
  1000.   TREE_STATIC   (var_decl)
  1001.     = (global_bindings_p () ? !extern_flag
  1002.        : static_flag || TYPE_VOLATILE (type));
  1003.   TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL;
  1004.   TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
  1005.     = TYPE_VOLATILE (type);
  1006.  
  1007.   /* At the global binding level we need to allocate static storage for the
  1008.      variable if and only if its not external. If we are not at the top level
  1009.      we always allocate automatic storage. */
  1010.   if (asm_name)
  1011.     DECL_ASSEMBLER_NAME (var_decl) = get_identifier (asm_name);
  1012.  
  1013.   if (size != 0)
  1014.     DECL_SIZE (var_decl) = size;
  1015.  
  1016.   /* If the type is a RECORD_TYPE and its size depends on a discriminant,
  1017.      the size to be used for the object is the maximum possible size.  */
  1018.   else if (TREE_CODE (type) == RECORD_TYPE
  1019.        && ! TREE_CONSTANT (TYPE_SIZE (type))
  1020.       && contains_placeholder_p (TYPE_SIZE (type)))
  1021.     DECL_SIZE (var_decl) = max_size (TYPE_SIZE (type), 1);
  1022.  
  1023.   if (align != 0)
  1024.     DECL_ALIGN (var_decl) = align;
  1025.  
  1026.   /* Add this decl to the current binding level and generate any
  1027.      needed code and RTL. */
  1028.   var_decl = pushdecl (var_decl);
  1029.   expand_decl (var_decl);
  1030.   expand_decl_init (var_decl);
  1031.   if (TREE_CODE (var_decl) != CONST_DECL)
  1032.     rest_of_decl_compilation (var_decl, 0, global_bindings_p (), 0);
  1033.  
  1034.   return var_decl;
  1035. }
  1036.  
  1037. /* Returns a FIELD_DECL node. FIELD_NAME the field name, FIELD_TYPE is its
  1038.    type, and RECORD_TYPE is the type of the parent.  PACKED is nonzero if
  1039.    this field is in a record type with a "pragma pack".  If SIZE is nonnegative
  1040.    it is the specified size for this field and POS is the bit position.  
  1041.    If SIZE is the special value -2, it means we should not replace a
  1042.    discriminated size with the maximum value; this is used in laying
  1043.    out nested variants.  */
  1044.  
  1045. tree
  1046. create_field_decl (field_name, field_type, record_type, packed, size, pos)
  1047.      char *field_name;
  1048.      tree field_type;
  1049.      tree record_type;
  1050.      int packed;
  1051.      int size, pos;
  1052. {
  1053.   tree field_id   = field_name ? get_identifier (field_name): NULL_TREE;
  1054.   tree field_decl = build_decl (FIELD_DECL, field_id, field_type);
  1055.  
  1056.   DECL_CONTEXT (field_decl) = record_type;
  1057.  
  1058.   /* If we have a specified size and it is not the same as the size
  1059.      of the mode or if the position does not correspond to the
  1060.      proper alignment, make this a bit field.  Likewise for a BLKmode
  1061.      field not byte aligned.  */
  1062.   if (size >= 0)
  1063.     {
  1064.       if (((INTEGRAL_TYPE_P (field_type)
  1065.         && (size != GET_MODE_BITSIZE (TYPE_MODE (field_type))
  1066.         || pos % GET_MODE_ALIGNMENT (TYPE_MODE (field_type) != 0)))
  1067.       || (TYPE_MODE (field_type) == BLKmode
  1068.           && pos % BITS_PER_UNIT != 0)))
  1069.     {
  1070.       DECL_BIT_FIELD (field_decl) = 1;
  1071.       DECL_PACKED (field_decl) = 1;
  1072.     }
  1073.  
  1074.       DECL_FIELD_SIZE (field_decl) = size;
  1075.       DECL_FIELD_BITPOS (field_decl) = size_int (pos);
  1076.       layout_decl (field_decl, pos);
  1077.     }
  1078.  
  1079.   /* If this is to be packed and it is an integral type make a bit field whose
  1080.      width is the precision of the type.  */
  1081.   else if (packed && INTEGRAL_TYPE_P (field_type)
  1082.       && TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST)
  1083.     {
  1084.       DECL_BIT_FIELD (field_decl) = 1;
  1085.       DECL_PACKED (field_decl) = 1;
  1086.       DECL_FIELD_SIZE (field_decl) = TYPE_PRECISION (field_type);
  1087.     }
  1088.   else
  1089.     DECL_ALIGN (field_decl)
  1090.       = MAX (DECL_ALIGN (field_decl),
  1091.          packed ? BITS_PER_UNIT : TYPE_ALIGN (TREE_TYPE (field_decl)));
  1092.  
  1093.   /* If the type is a RECORD_TYPE and its size depends on a discriminant,
  1094.      the size to be used for the object is the maximum possible size.  */
  1095.   if (size != -2 && TREE_CODE (field_type) == RECORD_TYPE
  1096.       && ! TREE_CONSTANT (TYPE_SIZE (field_type))
  1097.       && contains_placeholder_except_p (TYPE_SIZE (field_type), record_type))
  1098.     DECL_SIZE (field_decl) = max_size (TYPE_SIZE (field_type), 1);
  1099.  
  1100.   return field_decl;
  1101. }
  1102.  
  1103. /* Returns a PARM_DECL node. PARAM_NAME is the name of the parameter,
  1104.    PARAM_TYPE is its type.  READONLY is nonzero if the parameter is
  1105.    readonly (either an IN parameter or an address of a pass-by-ref
  1106.    parameter). */
  1107.  
  1108. tree
  1109. create_param_decl (param_name, param_type, readonly)
  1110.      char *param_name;
  1111.      tree param_type;
  1112.      int readonly;
  1113. {
  1114.   tree param_id   = get_identifier (param_name);
  1115.   tree param_decl = build_decl (PARM_DECL, param_id, param_type);
  1116.  
  1117.   DECL_ARG_TYPE (param_decl) = param_type;
  1118.   TREE_READONLY (param_decl) = readonly;
  1119.   return param_decl;
  1120. }
  1121.  
  1122. /* Add some pending elaborations on the list .  */
  1123.  
  1124. void 
  1125. add_pending_elaborations (var_decl, var_init)
  1126.      tree var_decl;
  1127.      tree var_init;
  1128. {
  1129.   pending_elaborations
  1130.     = chainon (pending_elaborations, build_tree_list (var_decl, var_init));
  1131. }
  1132.  
  1133. /* Obtain any pending elaborations and clear the old list.  */
  1134.  
  1135. tree
  1136. get_pending_elaborations ()
  1137. {
  1138.   /* Each thing added to the list went on the end; we want it on the
  1139.      beginning.  */
  1140.   tree result = TREE_CHAIN (pending_elaborations);
  1141.  
  1142.   TREE_CHAIN (pending_elaborations) = 0;
  1143.   return result;
  1144. }
  1145.  
  1146. /* Save a copy of the current pending elaboration list and make a new
  1147.    one.  */
  1148.  
  1149. void
  1150. push_pending_elaborations ()
  1151. {
  1152.   struct e_stack *p = (struct e_stack *) oballoc (sizeof (struct e_stack));
  1153.  
  1154.   p->next = elist_stack;
  1155.   p->elab_list = pending_elaborations;
  1156.   elist_stack = p;
  1157.   pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
  1158. }
  1159.  
  1160. /* Pop the stack of pending elaborations.  */
  1161.  
  1162. void
  1163. pop_pending_elaborations ()
  1164. {
  1165.   pending_elaborations = elist_stack->elab_list;
  1166.   elist_stack = elist_stack->next;
  1167. }
  1168.  
  1169. /* Return the current position in pending_elaborations so we can insert
  1170.    elaborations after that point.  */
  1171.  
  1172. tree
  1173. get_elaboration_location ()
  1174. {
  1175.   return pending_elaborations;
  1176. }
  1177.  
  1178. /* Insert the current elaborations after ELAB, which is in some elaboration
  1179.    list.  */
  1180.  
  1181. void
  1182. insert_elaboration_list (elab)
  1183.      tree elab;
  1184. {
  1185.   tree next = TREE_CHAIN (elab);
  1186.  
  1187.   if (TREE_CHAIN (pending_elaborations))
  1188.     {
  1189.       TREE_CHAIN (elab) = TREE_CHAIN (pending_elaborations);
  1190.       TREE_CHAIN (tree_last (pending_elaborations)) = next;
  1191.     }
  1192. }
  1193.  
  1194. /* Returns a LABEL_DECL node for LABEL_NAME.  */
  1195.  
  1196. tree
  1197. create_label_decl (label_name)
  1198.      char *label_name;
  1199. {
  1200.   tree label_id   = get_identifier (label_name);
  1201.   tree label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
  1202.  
  1203.   DECL_CONTEXT (label_decl)     = current_function_decl;
  1204.   DECL_MODE (label_decl)        = VOIDmode;
  1205.   DECL_SOURCE_LINE (label_decl) = lineno;
  1206.   DECL_SOURCE_FILE (label_decl) = input_filename;
  1207.  
  1208.   return label_decl;
  1209. }
  1210.  
  1211. /* Returns a FUNCTION_DECL node.  SUBPROG_NAME is the name of the subprogram,
  1212.    ASM_NAME is its assembler name, SUBPROG_TYPE is its type (a FUNCTION_TYPE
  1213.    node), PARAM_DECL_LIST is the list of the subprogram arguments (a list of
  1214.    PARM_DECL nodes chained through the TREE_CHAIN field).
  1215.  
  1216.    INLINE_FLAG, PUBLIC_FLAG, EXTERN_FLAG, and PURE_FLAG are used to set the
  1217.    appropriate fields in the FUNCTION_DECL.  */
  1218.  
  1219. tree
  1220. create_subprog_decl (subprog_name, asm_name, subprog_type, param_decl_list,
  1221.              inline_flag, public_flag, extern_flag, pure_flag,
  1222.              machine_attr)
  1223.      char *subprog_name;
  1224.      char *asm_name;
  1225.      tree subprog_type;
  1226.      tree param_decl_list;
  1227.      int inline_flag;
  1228.      int public_flag;
  1229.      int extern_flag;
  1230.      int pure_flag;
  1231.      tree machine_attr;
  1232. {
  1233.   tree subprog_id   = get_identifier (subprog_name);
  1234.   tree return_type  = TREE_TYPE (subprog_type);
  1235.   tree subprog_decl = build_decl (FUNCTION_DECL, subprog_id, subprog_type);
  1236.  
  1237.   DECL_EXTERNAL (subprog_decl)  = extern_flag;
  1238.   TREE_PUBLIC (subprog_decl)    = public_flag;
  1239.   DECL_INLINE (subprog_decl)    = inline_flag;
  1240.   TREE_READONLY (subprog_decl)  = pure_flag;
  1241.   DECL_ARGUMENTS (subprog_decl) = param_decl_list;
  1242.   DECL_RESULT (subprog_decl)    = build_decl (RESULT_DECL, 0, return_type);
  1243.  
  1244.   if (machine_attr)
  1245.     {
  1246. #ifdef DECL_STATIC_CONSTRUCTOR /* GCC 2.7.0  */
  1247.       if (valid_machine_attribute (TREE_PURPOSE (machine_attr), NULL_TREE,
  1248.                    subprog_decl, subprog_type))
  1249.     ;
  1250.       else
  1251. #endif
  1252.     warning ("`%s' attribute directive ignored",
  1253.          IDENTIFIER_POINTER (TREE_PURPOSE (machine_attr)));
  1254.     }
  1255.  
  1256.   if (asm_name)
  1257.     DECL_ASSEMBLER_NAME (subprog_decl) = get_identifier (asm_name);
  1258.  
  1259.   /* Add this decl to the current binding level.  */
  1260.   subprog_decl = pushdecl (subprog_decl);
  1261.  
  1262.   /* Output the assembler code and/or RTL for the declaration.  */
  1263.   rest_of_decl_compilation (subprog_decl, 0, global_bindings_p (), 0);
  1264.  
  1265.   return subprog_decl;
  1266. }
  1267.  
  1268. /* Count how deep we are into nested functions.  This is because
  1269.    we shouldn't call the backend function context routines unless we
  1270.    are in a nested function.  */
  1271.  
  1272. static int function_nesting_depth;
  1273.  
  1274. /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
  1275.    body. This routine needs to be invoked before processing the declarations
  1276.    appearing in the subprogram.  */
  1277.  
  1278. void
  1279. begin_subprog_body (subprog_decl)
  1280.      tree subprog_decl;
  1281. {
  1282.   tree param_decl_list;
  1283.   tree param_decl;
  1284.   tree next_param;
  1285.  
  1286.   if (function_nesting_depth++ != 0)
  1287.     push_function_context ();
  1288.  
  1289.   announce_function (subprog_decl);
  1290.  
  1291.   /* Make this field nonzero so further routines know that this is not
  1292.      tentative. error_mark_node is replaced below (in poplevel) with the
  1293.      adequate BLOCK.  */
  1294.   DECL_INITIAL (subprog_decl)  = error_mark_node;
  1295.  
  1296.   /* This function exists in static storage. This does not mean `static' in
  1297.      the C sense!  */
  1298.   TREE_STATIC (subprog_decl)   = 1;
  1299.  
  1300.   /* Enter a new binding level.  */
  1301.   temporary_allocation ();
  1302.   current_function_decl = subprog_decl;
  1303.   pushlevel (0);
  1304.  
  1305.   make_function_rtl (subprog_decl);
  1306.  
  1307.   /* Push all the PARM_DECL nodes onto the current scope (i.e. the scope of the
  1308.      subprogram body) so that they can be recognized as local variables in the
  1309.      subprogram. 
  1310.  
  1311.      The list of PARM_DECL nodes is stored in the right order in
  1312.      DECL_ARGUMENTS.  Since ..._DECL nodes get stored in the reverse order in
  1313.      which they are transmitted to `pushdecl' we need to reverse the list of
  1314.      PARM_DECLs if we want it to be stored in the right order. The reason why
  1315.      we want to make sure the PARM_DECLs are stored in the correct order is
  1316.      that this list will be retrieved in a few lines with a call to `getdecl'
  1317.      to store it back into the DECL_ARGUMENTS field.  */
  1318.     param_decl_list = nreverse (DECL_ARGUMENTS (subprog_decl));
  1319.  
  1320.     for (param_decl = param_decl_list; param_decl; param_decl = next_param)
  1321.       {
  1322.     next_param = TREE_CHAIN (param_decl);
  1323.     TREE_CHAIN (param_decl) = NULL;
  1324.     pushdecl (param_decl);
  1325.       }
  1326.  
  1327.   /* Store back the PARM_DECL nodes. They appear in the right order. */
  1328.   DECL_ARGUMENTS (subprog_decl) = getdecls ();
  1329.  
  1330.   init_function_start   (subprog_decl, input_filename, lineno);
  1331.   expand_function_start (subprog_decl, 0);
  1332. }
  1333.  
  1334.  
  1335. /* Finish the definition of the current subprogram and compile it all the way
  1336.    to assembler language output.  */
  1337.  
  1338. void
  1339. end_subprog_body (void)
  1340. {
  1341.   poplevel (1, 0, 1);
  1342.  
  1343.   /* Mark the RESULT_DECL as being in this subprogram. */
  1344.   DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl;
  1345.  
  1346.   expand_function_end (input_filename, lineno, 0);
  1347.   rest_of_compilation (current_function_decl);
  1348.  
  1349.   /* If we are not at the bottom of the function nesting stack, pop up to
  1350.      the containing function.  Otherwise show we aren't in any function
  1351.      and switch back to permanent allocation.  */
  1352.   if (--function_nesting_depth != 0)
  1353.     pop_function_context ();
  1354.   else
  1355.     {
  1356.       current_function_decl = 0;
  1357.       permanent_allocation (1);
  1358.     }
  1359. }
  1360.  
  1361. /* Return 1 if EXP contains a PLACEHOLDER_EXPR for any type other than T;
  1362.    i.e., if it represents a size or offset that depends on a field within a
  1363.    record other than the RECORD_TYPE denoted by T.  If T is zero,
  1364.    return 1 for any PLACEHOLDER_EXPR.
  1365.  
  1366.    Note that we only allow such expressions within simple arithmetic
  1367.    or a COND_EXPR.  */
  1368.  
  1369. static int
  1370. contains_placeholder_except_p (exp, t)
  1371.      tree exp;
  1372.      tree t;
  1373. {
  1374.   register enum tree_code code = TREE_CODE (exp);
  1375.   tree inner;
  1376.  
  1377.   /* If we have a WITH_RECORD_EXPR, it "cancels" any PLACEHOLDER_EXPR
  1378.      in it since it is supplying a value for it.  */
  1379.   if (code == WITH_RECORD_EXPR)
  1380.     return 0;
  1381.  
  1382.   switch (TREE_CODE_CLASS (code))
  1383.     {
  1384.     case 'r':
  1385.       for (inner = TREE_OPERAND (exp, 0);
  1386.        TREE_CODE_CLASS (TREE_CODE (inner)) == 'r';
  1387.        inner = TREE_OPERAND (inner, 0))
  1388.     ;
  1389.       return (TREE_CODE (inner) == PLACEHOLDER_EXPR
  1390.           && TREE_TYPE (inner) != t);
  1391.  
  1392.     case '1':
  1393.     case '2':  case '<':
  1394.     case 'e':
  1395.       switch (tree_code_length[(int) code])
  1396.     {
  1397.     case 1:
  1398.       return contains_placeholder_except_p (TREE_OPERAND (exp, 0), t);
  1399.     case 2:
  1400.       return (code != RTL_EXPR
  1401.           && code != CONSTRUCTOR
  1402.           && ! (code == SAVE_EXPR && SAVE_EXPR_RTL (exp) != 0)
  1403.           && code != WITH_RECORD_EXPR
  1404.           && (contains_placeholder_except_p (TREE_OPERAND (exp, 0), t)
  1405.               || contains_placeholder_except_p (TREE_OPERAND (exp, 1),
  1406.                             t)));
  1407.     case 3:
  1408.       return
  1409.         (code == COND_EXPR
  1410.          && (contains_placeholder_except_p (TREE_OPERAND (exp, 0), t)
  1411.          || contains_placeholder_except_p (TREE_OPERAND (exp, 1), t)
  1412.          || contains_placeholder_except_p (TREE_OPERAND (exp, 2), t)));
  1413.     }
  1414.     }
  1415.  
  1416.   return 0;
  1417. }
  1418.  
  1419. #ifndef MAX_BITS_PER_WORD
  1420. #define MAX_BITS_PER_WORD  BITS_PER_WORD
  1421. #endif
  1422.  
  1423. /* This variable keeps a table for types for each precision so that we only 
  1424.    allocate each of them once. Signed and unsigned types are kept separate.
  1425.  
  1426.    Note that these types are only used when fold-const requests something
  1427.    special.  Perhaps we should NOT share these types; we'll see how it
  1428.    goes later.  */
  1429. static tree signed_and_unsigned_types[MAX_BITS_PER_WORD + 1][2];
  1430.  
  1431. /* Return an integer type with the number of bits of precision given by  
  1432.    PRECISION.  UNSIGNEDP is nonzero if the type is unsigned; otherwise
  1433.    it is a signed type.  */
  1434.  
  1435. tree
  1436. type_for_size (precision, unsignedp)
  1437.      unsigned precision;
  1438.      int unsignedp;
  1439. {
  1440.   tree t;
  1441.   int moment;
  1442.  
  1443.   if (precision <= MAX_BITS_PER_WORD
  1444.       && signed_and_unsigned_types[precision][unsignedp] != 0)
  1445.     return signed_and_unsigned_types[precision][unsignedp];
  1446.  
  1447.   /* Since we will keep these types around, they must be permanent.  */
  1448.   moment = suspend_momentary ();
  1449.   push_obstacks_nochange ();
  1450.   end_temporary_allocation ();
  1451.  
  1452.  if (unsignedp)
  1453.     t = signed_and_unsigned_types[precision][1]
  1454.       = make_unsigned_type (precision);
  1455.   else
  1456.     t = signed_and_unsigned_types[precision][0]
  1457.       = make_signed_type (precision);
  1458.  
  1459.   pop_obstacks ();
  1460.   resume_momentary (moment);
  1461.  
  1462.   return t;
  1463. }
  1464.  
  1465. /* Return a data type that has machine mode MODE.  UNSIGNEDP selects
  1466.    an unsigned type; otherwise a signed type is returned.  */
  1467.  
  1468. tree
  1469. type_for_mode (mode, unsignedp)
  1470.      enum machine_mode mode;
  1471.      int unsignedp;
  1472. {
  1473.   return type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
  1474. }
  1475.  
  1476. /* Return the unsigned version of a TYPE_NODE, a scalar type.  */
  1477.  
  1478. tree
  1479. unsigned_type (type_node)
  1480.      tree type_node;
  1481. {
  1482.   tree type = type_for_size (TYPE_PRECISION (type_node), 1);
  1483.  
  1484.   if (TYPE_MODULAR_P (type_node))
  1485.     {
  1486.       type = copy_node (type);
  1487.       TREE_TYPE (type) = type_node;
  1488.     }
  1489.   else if (TREE_TYPE (type_node) != 0
  1490.        && TYPE_MODULAR_P (TREE_TYPE (type_node)))
  1491.     {
  1492.       type = copy_node (type);
  1493.       TREE_TYPE (type) = TREE_TYPE (type_node);
  1494.     }
  1495.  
  1496.   return type;
  1497. }
  1498.  
  1499. /* Return the signed version of a TYPE_NODE, a scalar type.  */
  1500.  
  1501. tree
  1502. signed_type (type_node)
  1503.      tree type_node;
  1504. {
  1505.   tree type = type_for_size (TYPE_PRECISION (type_node), 0);
  1506.  
  1507.   if (TYPE_MODULAR_P (type_node))
  1508.     {
  1509.       type = copy_node (type);
  1510.       TREE_TYPE (type) = type_node;
  1511.     }
  1512.   else if (TREE_TYPE (type_node) != 0
  1513.        && TYPE_MODULAR_P (TREE_TYPE (type_node)))
  1514.     {
  1515.       type = copy_node (type);
  1516.       TREE_TYPE (type) = TREE_TYPE (type_node);
  1517.     }
  1518.  
  1519.   return type;
  1520. }
  1521.  
  1522. /* Return a type the same as TYPE except unsigned or signed according to
  1523.    UNSIGNEDP.  */
  1524.  
  1525. tree
  1526. signed_or_unsigned_type (unsignedp, type)
  1527.      int unsignedp;
  1528.      tree type;
  1529. {
  1530.   if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp)
  1531.     return type;
  1532.   else
  1533.     return type_for_size (TYPE_PRECISION (type), unsignedp);
  1534. }
  1535.  
  1536. /* EXP is an expression for the size of an object.  If this size contains
  1537.    discriminant references, replace them with the maximum (if MAX_P) or
  1538.    minimum (if ! MAX_P) possible value of the discriminant.  */
  1539.  
  1540. tree
  1541. max_size (exp, max_p)
  1542.      tree exp;
  1543.      int max_p;
  1544. {
  1545.   enum tree_code code = TREE_CODE (exp);
  1546.   tree type = TREE_TYPE (exp);
  1547.  
  1548.   switch (TREE_CODE_CLASS (code))
  1549.     {
  1550.     case 'd':
  1551.     case 'c':
  1552.       return exp;
  1553.  
  1554.     case 'r':
  1555.       /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
  1556.      modify.  Otherwise, we abort since it is something we can't
  1557.      handle.  */
  1558.       if (! contains_placeholder_p (exp))
  1559.     gigi_abort (406);
  1560.  
  1561.       type = TREE_TYPE (TREE_OPERAND (exp, 1));
  1562.       return
  1563.     max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), 1);
  1564.  
  1565.     case '1':
  1566.     case '2':
  1567.     case '<':
  1568.     case 'e':
  1569.       switch (tree_code_length[(int) code])
  1570.     {
  1571.     case 1:
  1572.       return
  1573.         fold (build1 (code, type,
  1574.               max_size (TREE_OPERAND (exp, 0),
  1575.                     code == NEGATE_EXPR ? ! max_p : max_p)));
  1576.  
  1577.     case 2:
  1578.       if (code == RTL_EXPR)
  1579.         gigi_abort (407);
  1580.  
  1581.       return
  1582.         fold (build (code, type,
  1583.              max_size (TREE_OPERAND (exp, 0), max_p),
  1584.              max_size (TREE_OPERAND (exp, 1),
  1585.                    code == MINUS_EXPR ? ! max_p : max_p)));
  1586.  
  1587.     case 3:
  1588.       if (code == SAVE_EXPR)
  1589.         return exp;
  1590.       else if (code == COND_EXPR)
  1591.         return fold (build (MAX_EXPR, type,
  1592.                 max_size (TREE_OPERAND (exp, 1), max_p),
  1593.                 max_size (TREE_OPERAND (exp, 2), max_p)));
  1594.     }
  1595.     }
  1596.  
  1597.   gigi_abort (408);
  1598. }
  1599.  
  1600. /* Build a template of type TEMPLATE_TYPE from the array bounds of ARRAY_TYPE.
  1601.    EXPR is an expression that we can use to locate any PLACEHOLDER_EXPRs.
  1602.    Return a constructor for the template.  */
  1603.  
  1604. tree
  1605. build_template (template_type, array_type, expr)
  1606.      tree template_type;
  1607.      tree array_type;
  1608.      tree expr;
  1609. {
  1610.   tree template_elts = NULL_TREE;
  1611.   tree field;
  1612.  
  1613.   /* First make the list for a CONSTRUCTOR for the template.   Go down the
  1614.      field list of the template instead of the type chain because this
  1615.      array might be an Ada array of arrays and we can't tell where the
  1616.      nested arrays stop being the underlying object.  */
  1617.  
  1618.   for (field = TYPE_FIELDS (template_type); field;
  1619.        array_type = TREE_TYPE (array_type),
  1620.        field = TREE_CHAIN (TREE_CHAIN (field)))
  1621.     {
  1622.       tree bounds, min, max;
  1623.  
  1624.       if (TREE_CODE (array_type) != ARRAY_TYPE)
  1625.     gigi_abort (411);
  1626.  
  1627.       if (TYPE_ACTUAL_BOUNDS (array_type) != 0)
  1628.     bounds = TYPE_ACTUAL_BOUNDS (array_type);
  1629.       else
  1630.     bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
  1631.  
  1632.       min = TYPE_MIN_VALUE (bounds);
  1633.       max = TYPE_MAX_VALUE (bounds);
  1634.  
  1635.       /* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
  1636.      surround them with a WITH_RECORD_EXPR giving EXPR as the
  1637.      OBJECT.  */
  1638.       if (! TREE_CONSTANT (min) && contains_placeholder_p (min))
  1639.     min = build (WITH_RECORD_EXPR, TREE_TYPE (min), min, expr);
  1640.       if (! TREE_CONSTANT (max) && contains_placeholder_p (max))
  1641.     max = build (WITH_RECORD_EXPR, TREE_TYPE (max), max, expr);
  1642.  
  1643.       template_elts = tree_cons (TREE_CHAIN (field), max,
  1644.                  tree_cons (field, min, template_elts));
  1645.     }
  1646.  
  1647.   return build_constructor (template_type, nreverse (template_elts));
  1648. }
  1649.  
  1650. /* Update anything previously pointing to OLD_TYPE to point to NEW_TYPE.  In
  1651.    the normal case this is just two adjustments, but we have more to do
  1652.    if NEW is an UNCONSTRAINED_ARRAY_TYPE.  */
  1653.  
  1654. void
  1655. update_pointer_to (old_type, new_type)
  1656.      tree old_type;
  1657.      tree new_type;
  1658. {
  1659.   tree ptr = TYPE_POINTER_TO (old_type);
  1660.  
  1661.   if (ptr == 0)
  1662.     return;
  1663.  
  1664.   /* First handle the simple case.  */
  1665.   if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
  1666.     {
  1667.       TREE_TYPE (ptr) = new_type;
  1668.       TYPE_POINTER_TO (new_type) = ptr;
  1669.     }
  1670.  
  1671.   /* Now deal with the unconstrained array case. In this case the "pointer"
  1672.      is actually a RECORD_TYPE where the types of both fields are
  1673.      pointers to void.  In that case, copy the field list from the
  1674.      old type to the new one and update the fields' context. */
  1675.   else if (TREE_CODE (ptr) != RECORD_TYPE || ! TYPE_FAT_POINTER_P (ptr))
  1676.     gigi_abort (412);
  1677.  
  1678.   else
  1679.     {
  1680.       tree ptr_temp_type;
  1681.  
  1682.       TYPE_FIELDS (ptr) = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
  1683.       DECL_CONTEXT (TYPE_FIELDS (ptr)) = ptr;
  1684.       DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr))) = ptr;
  1685.  
  1686.       /* Rework the PLACEHOLDER_EXPR inside the reference to the
  1687.      template bounds.  */
  1688.       ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
  1689.       update_pointer_to 
  1690.     (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
  1691.      gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
  1692.                   TREE_CHAIN (TYPE_FIELDS (ptr)),
  1693.                   build (COMPONENT_REF, ptr_temp_type,
  1694.                      build (PLACEHOLDER_EXPR, ptr),
  1695.                      TREE_CHAIN (TYPE_FIELDS (ptr)))));
  1696.  
  1697.       TYPE_UNCONSTRAINED_ARRAY (ptr) = new_type;
  1698.       TYPE_POINTER_TO (new_type) = TREE_TYPE (new_type) = ptr;
  1699.       rest_of_type_compilation (ptr, global_bindings_p ());
  1700.     }
  1701. }
  1702.  
  1703. /* Convert a pointer to a constrained array into a pointer to an unconstrained
  1704.    array.  This involves making a template.  */
  1705.  
  1706. tree
  1707. convert_to_unconstrained (type, expr)
  1708.      tree type;
  1709.      tree expr;
  1710. {
  1711.   tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
  1712.   tree template_cons, template_addr;
  1713.  
  1714.   /* If EXPR is a constant of zero, we make a fat pointer that has a null
  1715.      pointer to the template and array.  */
  1716.   if (integer_zerop (expr))
  1717.     return
  1718.       build_constructor
  1719.     (type,
  1720.      tree_cons (TYPE_FIELDS (type),
  1721.             convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
  1722.             tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
  1723.                    convert (build_pointer_type (template_type),
  1724.                     expr),
  1725.                    NULL_TREE)));
  1726.  
  1727.   /* Build the constructor for the template.  If EXPR is a pointer to a
  1728.      COMPONENT_REF from a TYPE_CONTAINS_TEMPLATE_P, get the template from the
  1729.      underlying type.  In that case, we don't have to worry about
  1730.      allocation.  */
  1731.   if (TREE_CODE (expr) == ADDR_EXPR
  1732.       && TREE_CODE (TREE_OPERAND (expr, 0)) == COMPONENT_REF
  1733.       && (TYPE_CONTAINS_TEMPLATE_P
  1734.       (TREE_TYPE (TREE_OPERAND (TREE_OPERAND (expr, 0), 0)))))
  1735.     {
  1736.       tree underlying = TREE_OPERAND (TREE_OPERAND (expr, 0), 0);
  1737.       tree temp_field = TYPE_FIELDS (TREE_TYPE (underlying));
  1738.  
  1739.       template_cons = build_component_ref (underlying, NULL_TREE, temp_field);
  1740.     }
  1741.   else
  1742.     template_cons
  1743.       = build_template (template_type, TREE_TYPE (TREE_TYPE (expr)), expr);
  1744.  
  1745.   template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_cons);
  1746.  
  1747.   /* The result is a CONSTRUCTOR for the fat pointer.  */
  1748.   return
  1749.     build_constructor (type,
  1750.                tree_cons (TYPE_FIELDS (type), expr,
  1751.                   tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
  1752.                          template_addr, NULL_TREE)));
  1753. }
  1754.  
  1755. /* Create an expression whose value is that of EXPR,
  1756.    converted to type TYPE.  The TREE_TYPE of the value
  1757.    is always TYPE.  This function implements all reasonable
  1758.    conversions; callers should filter out those that are
  1759.    not permitted by the language being compiled.  */
  1760.  
  1761. tree
  1762. convert (type, expr)
  1763.      tree type, expr;
  1764. {
  1765.   enum tree_code code = TREE_CODE (type);
  1766.   tree etype = TREE_TYPE (expr);
  1767.   enum tree_code ecode = TREE_CODE (etype);
  1768.  
  1769.   /* If EXPR is already the right type, we are done.  */
  1770.   if (type == etype)
  1771.     return expr;
  1772.  
  1773.   /* There are some special cases of expressions that we process
  1774.      specially.  */
  1775.   switch (TREE_CODE (expr))
  1776.     {
  1777.     case ERROR_MARK:
  1778.       return expr;
  1779.  
  1780.     case TRANSFORM_EXPR:
  1781.       /* Just set its type here.  We will do the actual conversion in
  1782.      gnat_expand_expr.  */
  1783.       TREE_TYPE (expr) = type;
  1784.       return expr;
  1785.  
  1786.     case STRING_CST:
  1787.       /* If we are converting a STRING_CST to another constrained array type,
  1788.      just make a new one in the proper type.  */
  1789.       if (code != ARRAY_TYPE)
  1790.     break;
  1791.  
  1792.       expr = copy_node (expr);
  1793.       TREE_TYPE (expr) = type;
  1794.       return expr;
  1795.  
  1796.     case UNCONSTRAINED_ARRAY_REF:
  1797.       /* Convert this to the type of the inner array by getting the address of
  1798.      the array from the template.  */
  1799.       expr = build_unary_op (INDIRECT_REF, NULL_TREE,
  1800.                  build_component_ref (TREE_OPERAND (expr, 0),
  1801.                           get_identifier ("P_ARRAY"),
  1802.                           NULL_TREE));
  1803.       break;
  1804.     }
  1805.  
  1806.   /* Check for converting a pointer to a constrained array into a pointer to
  1807.      a constrained array.  */
  1808.   if (TYPE_FAT_POINTER_P (type)
  1809.       && (integer_zerop (expr)
  1810.       || (ecode == POINTER_TYPE
  1811.           && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)))
  1812.     return convert_to_unconstrained (type, expr);
  1813.  
  1814.   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
  1815.       || (code == INTEGER_CST && ecode == INTEGER_CST
  1816.       && (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
  1817.     return fold (build1 (NOP_EXPR, type, expr));
  1818.  
  1819.   switch (code)
  1820.     {
  1821.     case VOID_TYPE:
  1822.       return build1 (CONVERT_EXPR, type, expr);
  1823.  
  1824.     case INTEGER_TYPE:
  1825.       /* If TYPE has a modulus and EXPR's type does not (or has a 
  1826.      different modulus), first convert to its base type, then take the
  1827.      modulus and convert to TYPE.  */
  1828.       if (TREE_TYPE (type) != 0 && TYPE_MODULAR_P (TREE_TYPE (type))
  1829.       && ! (ecode == INTEGER_TYPE && TYPE_MODULAR_P (etype)
  1830.         && tree_int_cst_equal (TYPE_MODULUS (TREE_TYPE (type)),
  1831.                        TYPE_MODULUS (etype)))
  1832.       && ! (ecode == INTEGER_TYPE
  1833.         && TREE_TYPE (etype) != 0
  1834.         && TYPE_MODULAR_P (TREE_TYPE (etype))
  1835.         && tree_int_cst_equal (TYPE_MODULUS (TREE_TYPE (etype)),
  1836.                        TYPE_MODULUS (TREE_TYPE (type)))))
  1837.     {
  1838.       tree base_type = TREE_TYPE (type);
  1839.       tree result = fold (convert_to_integer (base_type, expr));
  1840.  
  1841.       result = fold (build (FLOOR_MOD_EXPR, base_type, result,
  1842.                 convert (base_type,
  1843.                      TYPE_MODULUS (base_type))));
  1844.       return fold (convert_to_integer (type, result));
  1845.     }
  1846.  
  1847.       /* ... fall through ... */
  1848.  
  1849.     case ENUMERAL_TYPE:
  1850.       return fold (convert_to_integer (type, expr));
  1851.  
  1852.     case POINTER_TYPE:
  1853.       /* If converting fat pointer to normal pointer, get the pointer to the
  1854.      array and then convert it.  */
  1855.       if (TYPE_FAT_POINTER_P (etype))
  1856.     expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
  1857.                     NULL_TREE);
  1858.  
  1859.       return fold (convert_to_pointer (type, expr));
  1860.  
  1861.     case REAL_TYPE:
  1862.       return fold (convert_to_real (type, expr));
  1863.  
  1864.     case ARRAY_TYPE:
  1865.     case RECORD_TYPE:
  1866.       /* In these cases, assume the front-end has validated the conversion.
  1867.      If the conversion is valid, it will bit a bit-wise conversion, so
  1868.      it can be viewed as an unchecked conversion.  */
  1869.       expr = build1 (UNCHECKED_CONVERT_EXPR, type, expr);
  1870.  
  1871.       /* If our result has side-effects and is of an unconstrained type,
  1872.      make a SAVE_EXPR so that we can be sure it will only be referenced
  1873.      once.  */
  1874.       if (TREE_SIDE_EFFECTS (expr)
  1875.       && (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE
  1876.           || (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST
  1877.           && contains_placeholder_p (TYPE_SIZE (type)))))
  1878.     expr = make_save_expr (expr);
  1879.       return expr;
  1880.  
  1881.     case UNCONSTRAINED_ARRAY_TYPE:
  1882.       /* If EXPR is a constrained array, take its address, convert it to a
  1883.      fat pointer, and then dereference it.  */
  1884.       if (ecode == ARRAY_TYPE)
  1885.     return
  1886.       build_unary_op
  1887.         (INDIRECT_REF, NULL_TREE,
  1888.          convert_to_unconstrained (TREE_TYPE (type),
  1889.                        build_unary_op (ADDR_EXPR,
  1890.                                NULL_TREE, expr)));
  1891.  
  1892.       /* Do something very similar for converting one unconstrained
  1893.      array to another.  */
  1894.       else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
  1895.     return
  1896.       build_unary_op (INDIRECT_REF, NULL_TREE,
  1897.               convert (TREE_TYPE (type),
  1898.                    build_unary_op (ADDR_EXPR,
  1899.                            NULL_TREE, expr)));
  1900.       else
  1901.     gigi_abort (409);
  1902.  
  1903.     default:
  1904.       gigi_abort (410);
  1905.     }
  1906. }
  1907.