1/**************************************************************************** 2 * * 3 * GNAT COMPILER COMPONENTS * 4 * * 5 * T R A N S * 6 * * 7 * C Implementation File * 8 * * 9 * Copyright (C) 1992-2015, Free Software Foundation, Inc. * 10 * * 11 * GNAT is free software; you can redistribute it and/or modify it under * 12 * terms of the GNU General Public License as published by the Free Soft- * 13 * ware Foundation; either version 3, or (at your option) any later ver- * 14 * sion. GNAT is distributed in the hope that it will be useful, but WITH- * 15 * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * 16 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License * 17 * for more details. You should have received a copy of the GNU General * 18 * Public License distributed with GNAT; see file COPYING3. If not see * 19 * <http://www.gnu.org/licenses/>. * 20 * * 21 * GNAT was originally developed by the GNAT team at New York University. * 22 * Extensive contributions were provided by Ada Core Technologies Inc. * 23 * * 24 ****************************************************************************/ 25 26#include "config.h" 27#include "system.h" 28#include "coretypes.h" 29#include "tm.h" 30#include "hash-set.h" 31#include "machmode.h" 32#include "vec.h" 33#include "double-int.h" 34#include "input.h" 35#include "alias.h" 36#include "symtab.h" 37#include "wide-int.h" 38#include "inchash.h" 39#include "real.h" 40#include "tree.h" 41#include "fold-const.h" 42#include "stringpool.h" 43#include "stor-layout.h" 44#include "stmt.h" 45#include "varasm.h" 46#include "flags.h" 47#include "output.h" 48#include "libfuncs.h" /* For set_stack_check_libfunc. */ 49#include "tree-iterator.h" 50#include "gimple-expr.h" 51#include "gimplify.h" 52#include "bitmap.h" 53#include "hash-map.h" 54#include "is-a.h" 55#include "plugin-api.h" 56#include "hard-reg-set.h" 57#include "input.h" 58#include "function.h" 59#include "ipa-ref.h" 60#include "cgraph.h" 61#include "diagnostic.h" 62#include "opts.h" 63#include "target.h" 64#include "common/common-target.h" 65 66#include "ada.h" 67#include "adadecode.h" 68#include "types.h" 69#include "atree.h" 70#include "elists.h" 71#include "namet.h" 72#include "nlists.h" 73#include "snames.h" 74#include "stringt.h" 75#include "uintp.h" 76#include "urealp.h" 77#include "fe.h" 78#include "sinfo.h" 79#include "einfo.h" 80#include "gadaint.h" 81#include "ada-tree.h" 82#include "gigi.h" 83 84/* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca, 85 for fear of running out of stack space. If we need more, we use xmalloc 86 instead. */ 87#define ALLOCA_THRESHOLD 1000 88 89/* In configurations where blocks have no end_locus attached, just 90 sink assignments into a dummy global. */ 91#ifndef BLOCK_SOURCE_END_LOCATION 92static location_t block_end_locus_sink; 93#define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink 94#endif 95 96/* Pointers to front-end tables accessed through macros. */ 97struct Node *Nodes_Ptr; 98struct Flags *Flags_Ptr; 99Node_Id *Next_Node_Ptr; 100Node_Id *Prev_Node_Ptr; 101struct Elist_Header *Elists_Ptr; 102struct Elmt_Item *Elmts_Ptr; 103struct String_Entry *Strings_Ptr; 104Char_Code *String_Chars_Ptr; 105struct List_Header *List_Headers_Ptr; 106 107/* Highest number in the front-end node table. */ 108int max_gnat_nodes; 109 110/* Current node being treated, in case abort called. */ 111Node_Id error_gnat_node; 112 113/* True when gigi is being called on an analyzed but unexpanded 114 tree, and the only purpose of the call is to properly annotate 115 types with representation information. */ 116bool type_annotate_only; 117 118/* Current filename without path. */ 119const char *ref_filename; 120 121 122/* List of N_Validate_Unchecked_Conversion nodes in the unit. */ 123static vec<Node_Id> gnat_validate_uc_list; 124 125/* When not optimizing, we cache the 'First, 'Last and 'Length attributes 126 of unconstrained array IN parameters to avoid emitting a great deal of 127 redundant instructions to recompute them each time. */ 128struct GTY (()) parm_attr_d { 129 int id; /* GTY doesn't like Entity_Id. */ 130 int dim; 131 tree first; 132 tree last; 133 tree length; 134}; 135 136typedef struct parm_attr_d *parm_attr; 137 138 139struct GTY(()) language_function { 140 vec<parm_attr, va_gc> *parm_attr_cache; 141 bitmap named_ret_val; 142 vec<tree, va_gc> *other_ret_val; 143 int gnat_ret; 144}; 145 146#define f_parm_attr_cache \ 147 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache 148 149#define f_named_ret_val \ 150 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val 151 152#define f_other_ret_val \ 153 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val 154 155#define f_gnat_ret \ 156 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret 157 158/* A structure used to gather together information about a statement group. 159 We use this to gather related statements, for example the "then" part 160 of a IF. In the case where it represents a lexical scope, we may also 161 have a BLOCK node corresponding to it and/or cleanups. */ 162 163struct GTY((chain_next ("%h.previous"))) stmt_group { 164 struct stmt_group *previous; /* Previous code group. */ 165 tree stmt_list; /* List of statements for this code group. */ 166 tree block; /* BLOCK for this code group, if any. */ 167 tree cleanups; /* Cleanups for this code group, if any. */ 168}; 169 170static GTY(()) struct stmt_group *current_stmt_group; 171 172/* List of unused struct stmt_group nodes. */ 173static GTY((deletable)) struct stmt_group *stmt_group_free_list; 174 175/* A structure used to record information on elaboration procedures 176 we've made and need to process. 177 178 ??? gnat_node should be Node_Id, but gengtype gets confused. */ 179 180struct GTY((chain_next ("%h.next"))) elab_info { 181 struct elab_info *next; /* Pointer to next in chain. */ 182 tree elab_proc; /* Elaboration procedure. */ 183 int gnat_node; /* The N_Compilation_Unit. */ 184}; 185 186static GTY(()) struct elab_info *elab_info_list; 187 188/* Stack of exception pointer variables. Each entry is the VAR_DECL 189 that stores the address of the raised exception. Nonzero means we 190 are in an exception handler. Not used in the zero-cost case. */ 191static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack; 192 193/* In ZCX case, current exception pointer. Used to re-raise it. */ 194static GTY(()) tree gnu_incoming_exc_ptr; 195 196/* Stack for storing the current elaboration procedure decl. */ 197static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack; 198 199/* Stack of labels to be used as a goto target instead of a return in 200 some functions. See processing for N_Subprogram_Body. */ 201static GTY(()) vec<tree, va_gc> *gnu_return_label_stack; 202 203/* Stack of variable for the return value of a function with copy-in/copy-out 204 parameters. See processing for N_Subprogram_Body. */ 205static GTY(()) vec<tree, va_gc> *gnu_return_var_stack; 206 207/* Structure used to record information for a range check. */ 208struct GTY(()) range_check_info_d { 209 tree low_bound; 210 tree high_bound; 211 tree type; 212 tree invariant_cond; 213}; 214 215typedef struct range_check_info_d *range_check_info; 216 217 218/* Structure used to record information for a loop. */ 219struct GTY(()) loop_info_d { 220 tree stmt; 221 tree loop_var; 222 vec<range_check_info, va_gc> *checks; 223}; 224 225typedef struct loop_info_d *loop_info; 226 227 228/* Stack of loop_info structures associated with LOOP_STMT nodes. */ 229static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack; 230 231/* The stacks for N_{Push,Pop}_*_Label. */ 232static GTY(()) vec<tree, va_gc> *gnu_constraint_error_label_stack; 233static GTY(()) vec<tree, va_gc> *gnu_storage_error_label_stack; 234static GTY(()) vec<tree, va_gc> *gnu_program_error_label_stack; 235 236/* Map GNAT tree codes to GCC tree codes for simple expressions. */ 237static enum tree_code gnu_codes[Number_Node_Kinds]; 238 239static void init_code_table (void); 240static void Compilation_Unit_to_gnu (Node_Id); 241static void record_code_position (Node_Id); 242static void insert_code_for (Node_Id); 243static void add_cleanup (tree, Node_Id); 244static void add_stmt_list (List_Id); 245static void push_exception_label_stack (vec<tree, va_gc> **, Entity_Id); 246static tree build_stmt_group (List_Id, bool); 247static inline bool stmt_group_may_fallthru (void); 248static enum gimplify_status gnat_gimplify_stmt (tree *); 249static void elaborate_all_entities (Node_Id); 250static void process_freeze_entity (Node_Id); 251static void process_decls (List_Id, List_Id, Node_Id, bool, bool); 252static tree emit_range_check (tree, Node_Id, Node_Id); 253static tree emit_index_check (tree, tree, tree, tree, Node_Id); 254static tree emit_check (tree, tree, int, Node_Id); 255static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id); 256static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id); 257static tree convert_with_check (Entity_Id, tree, bool, bool, bool, Node_Id); 258static bool addressable_p (tree, tree); 259static tree assoc_to_constructor (Entity_Id, Node_Id, tree); 260static tree extract_values (tree, tree); 261static tree pos_to_constructor (Node_Id, tree, Entity_Id); 262static void validate_unchecked_conversion (Node_Id); 263static tree maybe_implicit_deref (tree); 264static void set_expr_location_from_node (tree, Node_Id); 265static void set_expr_location_from_node1 (tree, Node_Id, bool); 266static bool Sloc_to_locus1 (Source_Ptr, location_t *, bool); 267static bool set_end_locus_from_node (tree, Node_Id); 268static void set_gnu_expr_location_from_node (tree, Node_Id); 269static int lvalue_required_p (Node_Id, tree, bool, bool, bool); 270static tree build_raise_check (int, enum exception_info_kind); 271static tree create_init_temporary (const char *, tree, tree *, Node_Id); 272 273/* Hooks for debug info back-ends, only supported and used in a restricted set 274 of configurations. */ 275static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; 276static const char *decode_name (const char *) ATTRIBUTE_UNUSED; 277 278/* This is the main program of the back-end. It sets up all the table 279 structures and then generates code. */ 280 281void 282gigi (Node_Id gnat_root, 283 int max_gnat_node, 284 int number_name ATTRIBUTE_UNUSED, 285 struct Node *nodes_ptr, 286 struct Flags *flags_ptr, 287 Node_Id *next_node_ptr, 288 Node_Id *prev_node_ptr, 289 struct Elist_Header *elists_ptr, 290 struct Elmt_Item *elmts_ptr, 291 struct String_Entry *strings_ptr, 292 Char_Code *string_chars_ptr, 293 struct List_Header *list_headers_ptr, 294 Nat number_file, 295 struct File_Info_Type *file_info_ptr, 296 Entity_Id standard_boolean, 297 Entity_Id standard_integer, 298 Entity_Id standard_character, 299 Entity_Id standard_long_long_float, 300 Entity_Id standard_exception_type, 301 Int gigi_operating_mode) 302{ 303 Node_Id gnat_iter; 304 Entity_Id gnat_literal; 305 tree t, ftype, int64_type; 306 struct elab_info *info; 307 int i; 308 309 max_gnat_nodes = max_gnat_node; 310 311 Nodes_Ptr = nodes_ptr; 312 Flags_Ptr = flags_ptr; 313 Next_Node_Ptr = next_node_ptr; 314 Prev_Node_Ptr = prev_node_ptr; 315 Elists_Ptr = elists_ptr; 316 Elmts_Ptr = elmts_ptr; 317 Strings_Ptr = strings_ptr; 318 String_Chars_Ptr = string_chars_ptr; 319 List_Headers_Ptr = list_headers_ptr; 320 321 type_annotate_only = (gigi_operating_mode == 1); 322 323 for (i = 0; i < number_file; i++) 324 { 325 /* Use the identifier table to make a permanent copy of the filename as 326 the name table gets reallocated after Gigi returns but before all the 327 debugging information is output. The __gnat_to_canonical_file_spec 328 call translates filenames from pragmas Source_Reference that contain 329 host style syntax not understood by gdb. */ 330 const char *filename 331 = IDENTIFIER_POINTER 332 (get_identifier 333 (__gnat_to_canonical_file_spec 334 (Get_Name_String (file_info_ptr[i].File_Name)))); 335 336 /* We rely on the order isomorphism between files and line maps. */ 337 gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i); 338 339 /* We create the line map for a source file at once, with a fixed number 340 of columns chosen to avoid jumping over the next power of 2. */ 341 linemap_add (line_table, LC_ENTER, 0, filename, 1); 342 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); 343 linemap_position_for_column (line_table, 252 - 1); 344 linemap_add (line_table, LC_LEAVE, 0, NULL, 0); 345 } 346 347 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit); 348 349 /* Declare the name of the compilation unit as the first global 350 name in order to make the middle-end fully deterministic. */ 351 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL); 352 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t)); 353 354 /* Initialize ourselves. */ 355 init_code_table (); 356 init_gnat_decl (); 357 init_gnat_utils (); 358 359 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid 360 errors. */ 361 if (type_annotate_only) 362 { 363 TYPE_SIZE (void_type_node) = bitsize_zero_node; 364 TYPE_SIZE_UNIT (void_type_node) = size_zero_node; 365 } 366 367 /* Enable GNAT stack checking method if needed */ 368 if (!Stack_Check_Probes_On_Target) 369 set_stack_check_libfunc ("_gnat_stack_check"); 370 371 /* Retrieve alignment settings. */ 372 double_float_alignment = get_target_double_float_alignment (); 373 double_scalar_alignment = get_target_double_scalar_alignment (); 374 375 /* Record the builtin types. Define `integer' and `character' first so that 376 dbx will output them first. */ 377 record_builtin_type ("integer", integer_type_node, false); 378 record_builtin_type ("character", unsigned_char_type_node, false); 379 record_builtin_type ("boolean", boolean_type_node, false); 380 record_builtin_type ("void", void_type_node, false); 381 382 /* Save the type we made for integer as the type for Standard.Integer. */ 383 save_gnu_tree (Base_Type (standard_integer), 384 TYPE_NAME (integer_type_node), 385 false); 386 387 /* Likewise for character as the type for Standard.Character. */ 388 save_gnu_tree (Base_Type (standard_character), 389 TYPE_NAME (unsigned_char_type_node), 390 false); 391 392 /* Likewise for boolean as the type for Standard.Boolean. */ 393 save_gnu_tree (Base_Type (standard_boolean), 394 TYPE_NAME (boolean_type_node), 395 false); 396 gnat_literal = First_Literal (Base_Type (standard_boolean)); 397 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node); 398 gcc_assert (t == boolean_false_node); 399 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, 400 boolean_type_node, t, true, false, false, false, 401 NULL, gnat_literal); 402 DECL_IGNORED_P (t) = 1; 403 save_gnu_tree (gnat_literal, t, false); 404 gnat_literal = Next_Literal (gnat_literal); 405 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node); 406 gcc_assert (t == boolean_true_node); 407 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE, 408 boolean_type_node, t, true, false, false, false, 409 NULL, gnat_literal); 410 DECL_IGNORED_P (t) = 1; 411 save_gnu_tree (gnat_literal, t, false); 412 413 void_ftype = build_function_type_list (void_type_node, NULL_TREE); 414 ptr_void_ftype = build_pointer_type (void_ftype); 415 416 /* Now declare run-time functions. */ 417 ftype = build_function_type_list (ptr_void_type_node, sizetype, NULL_TREE); 418 419 /* malloc is a function declaration tree for a function to allocate 420 memory. */ 421 malloc_decl 422 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE, 423 ftype, NULL_TREE, is_disabled, true, true, true, 424 NULL, Empty); 425 DECL_IS_MALLOC (malloc_decl) = 1; 426 427 /* free is a function declaration tree for a function to free memory. */ 428 free_decl 429 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE, 430 build_function_type_list (void_type_node, 431 ptr_void_type_node, 432 NULL_TREE), 433 NULL_TREE, is_disabled, true, true, true, NULL, 434 Empty); 435 436 /* This is used for 64-bit multiplication with overflow checking. */ 437 int64_type = gnat_type_for_size (64, 0); 438 mulv64_decl 439 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE, 440 build_function_type_list (int64_type, int64_type, 441 int64_type, NULL_TREE), 442 NULL_TREE, is_disabled, true, true, true, NULL, 443 Empty); 444 445 /* Name of the _Parent field in tagged record types. */ 446 parent_name_id = get_identifier (Get_Name_String (Name_uParent)); 447 448 /* Name of the Exception_Data type defined in System.Standard_Library. */ 449 exception_data_name_id 450 = get_identifier ("system__standard_library__exception_data"); 451 452 /* Make the types and functions used for exception processing. */ 453 jmpbuf_type 454 = build_array_type (gnat_type_for_mode (Pmode, 0), 455 build_index_type (size_int (5))); 456 record_builtin_type ("JMPBUF_T", jmpbuf_type, true); 457 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type); 458 459 /* Functions to get and set the jumpbuf pointer for the current thread. */ 460 get_jmpbuf_decl 461 = create_subprog_decl 462 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"), 463 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE), 464 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 465 DECL_IGNORED_P (get_jmpbuf_decl) = 1; 466 467 set_jmpbuf_decl 468 = create_subprog_decl 469 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"), 470 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type, 471 NULL_TREE), 472 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 473 DECL_IGNORED_P (set_jmpbuf_decl) = 1; 474 475 /* setjmp returns an integer and has one operand, which is a pointer to 476 a jmpbuf. */ 477 setjmp_decl 478 = create_subprog_decl 479 (get_identifier ("__builtin_setjmp"), NULL_TREE, 480 build_function_type_list (integer_type_node, jmpbuf_ptr_type, 481 NULL_TREE), 482 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 483 DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; 484 DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; 485 486 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer 487 address. */ 488 update_setjmp_buf_decl 489 = create_subprog_decl 490 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE, 491 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE), 492 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 493 DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL; 494 DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF; 495 496 /* Hooks to call when entering/leaving an exception handler. */ 497 ftype 498 = build_function_type_list (void_type_node, ptr_void_type_node, NULL_TREE); 499 500 begin_handler_decl 501 = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE, 502 ftype, NULL_TREE, is_disabled, true, true, true, 503 NULL, Empty); 504 DECL_IGNORED_P (begin_handler_decl) = 1; 505 506 end_handler_decl 507 = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE, 508 ftype, NULL_TREE, is_disabled, true, true, true, 509 NULL, Empty); 510 DECL_IGNORED_P (end_handler_decl) = 1; 511 512 unhandled_except_decl 513 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"), 514 NULL_TREE, 515 ftype, NULL_TREE, is_disabled, true, true, true, 516 NULL, Empty); 517 DECL_IGNORED_P (unhandled_except_decl) = 1; 518 519 reraise_zcx_decl 520 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE, 521 ftype, NULL_TREE, is_disabled, true, true, true, 522 NULL, Empty); 523 /* Indicate that these never return. */ 524 DECL_IGNORED_P (reraise_zcx_decl) = 1; 525 TREE_THIS_VOLATILE (reraise_zcx_decl) = 1; 526 TREE_SIDE_EFFECTS (reraise_zcx_decl) = 1; 527 TREE_TYPE (reraise_zcx_decl) 528 = build_qualified_type (TREE_TYPE (reraise_zcx_decl), TYPE_QUAL_VOLATILE); 529 530 /* If in no exception handlers mode, all raise statements are redirected to 531 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since 532 this procedure will never be called in this mode. */ 533 if (No_Exception_Handlers_Set ()) 534 { 535 tree decl 536 = create_subprog_decl 537 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, 538 build_function_type_list (void_type_node, 539 build_pointer_type 540 (unsigned_char_type_node), 541 integer_type_node, NULL_TREE), 542 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 543 TREE_THIS_VOLATILE (decl) = 1; 544 TREE_SIDE_EFFECTS (decl) = 1; 545 TREE_TYPE (decl) 546 = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); 547 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++) 548 gnat_raise_decls[i] = decl; 549 } 550 else 551 { 552 /* Otherwise, make one decl for each exception reason. */ 553 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++) 554 gnat_raise_decls[i] = build_raise_check (i, exception_simple); 555 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++) 556 gnat_raise_decls_ext[i] 557 = build_raise_check (i, 558 i == CE_Index_Check_Failed 559 || i == CE_Range_Check_Failed 560 || i == CE_Invalid_Data 561 ? exception_range : exception_column); 562 } 563 564 /* Set the types that GCC and Gigi use from the front end. */ 565 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type)); 566 567 /* Make other functions used for exception processing. */ 568 get_excptr_decl 569 = create_subprog_decl 570 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE, 571 build_function_type_list (build_pointer_type (except_type_node), 572 NULL_TREE), 573 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 574 DECL_IGNORED_P (get_excptr_decl) = 1; 575 576 set_exception_parameter_decl 577 = create_subprog_decl 578 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE, 579 build_function_type_list (void_type_node, 580 ptr_void_type_node, 581 ptr_void_type_node, 582 NULL_TREE), 583 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 584 585 raise_nodefer_decl 586 = create_subprog_decl 587 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, 588 build_function_type_list (void_type_node, 589 build_pointer_type (except_type_node), 590 NULL_TREE), 591 NULL_TREE, is_disabled, true, true, true, NULL, Empty); 592 593 /* Indicate that it never returns. */ 594 TREE_THIS_VOLATILE (raise_nodefer_decl) = 1; 595 TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1; 596 TREE_TYPE (raise_nodefer_decl) 597 = build_qualified_type (TREE_TYPE (raise_nodefer_decl), 598 TYPE_QUAL_VOLATILE); 599 600 /* Build the special descriptor type and its null node if needed. */ 601 if (TARGET_VTABLE_USES_DESCRIPTORS) 602 { 603 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node); 604 tree field_list = NULL_TREE; 605 int j; 606 vec<constructor_elt, va_gc> *null_vec = NULL; 607 constructor_elt *elt; 608 609 fdesc_type_node = make_node (RECORD_TYPE); 610 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS); 611 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1); 612 613 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++) 614 { 615 tree field 616 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node, 617 NULL_TREE, NULL_TREE, 0, 1); 618 DECL_CHAIN (field) = field_list; 619 field_list = field; 620 elt->index = field; 621 elt->value = null_node; 622 elt--; 623 } 624 625 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false); 626 record_builtin_type ("descriptor", fdesc_type_node, true); 627 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec); 628 } 629 630 longest_float_type_node 631 = get_unpadded_type (Base_Type (standard_long_long_float)); 632 633 /* Dummy objects to materialize "others" and "all others" in the exception 634 tables. These are exported by a-exexpr-gcc.adb, so see this unit for 635 the types to use. */ 636 others_decl 637 = create_var_decl (get_identifier ("OTHERS"), 638 get_identifier ("__gnat_others_value"), 639 unsigned_char_type_node, 640 NULL_TREE, true, false, true, false, NULL, Empty); 641 642 all_others_decl 643 = create_var_decl (get_identifier ("ALL_OTHERS"), 644 get_identifier ("__gnat_all_others_value"), 645 unsigned_char_type_node, 646 NULL_TREE, true, false, true, false, NULL, Empty); 647 648 unhandled_others_decl 649 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"), 650 get_identifier ("__gnat_unhandled_others_value"), 651 unsigned_char_type_node, 652 NULL_TREE, true, false, true, false, NULL, Empty); 653 654 main_identifier_node = get_identifier ("main"); 655 656 /* Install the builtins we might need, either internally or as 657 user available facilities for Intrinsic imports. */ 658 gnat_install_builtins (); 659 660 vec_safe_push (gnu_except_ptr_stack, NULL_TREE); 661 vec_safe_push (gnu_constraint_error_label_stack, NULL_TREE); 662 vec_safe_push (gnu_storage_error_label_stack, NULL_TREE); 663 vec_safe_push (gnu_program_error_label_stack, NULL_TREE); 664 665 /* Process any Pragma Ident for the main unit. */ 666 if (Present (Ident_String (Main_Unit))) 667 targetm.asm_out.output_ident 668 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit)))); 669 670 /* If we are using the GCC exception mechanism, let GCC know. */ 671 if (Exception_Mechanism == Back_End_Exceptions) 672 gnat_init_gcc_eh (); 673 674 /* Initialize the GCC support for FP operations. */ 675 gnat_init_gcc_fp (); 676 677 /* Force -fno-strict-aliasing if the configuration pragma was seen. */ 678 if (No_Strict_Aliasing_CP) 679 flag_strict_aliasing = 0; 680 681 /* Save the current optimization options again after the above possible 682 global_options changes. */ 683 optimization_default_node = build_optimization_node (&global_options); 684 optimization_current_node = optimization_default_node; 685 686 /* Now translate the compilation unit proper. */ 687 Compilation_Unit_to_gnu (gnat_root); 688 689 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at 690 the very end to avoid having to second-guess the front-end when we run 691 into dummy nodes during the regular processing. */ 692 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++) 693 validate_unchecked_conversion (gnat_iter); 694 gnat_validate_uc_list.release (); 695 696 /* Finally see if we have any elaboration procedures to deal with. */ 697 for (info = elab_info_list; info; info = info->next) 698 { 699 tree gnu_body = DECL_SAVED_TREE (info->elab_proc), gnu_stmts; 700 701 /* We should have a BIND_EXPR but it may not have any statements in it. 702 If it doesn't have any, we have nothing to do except for setting the 703 flag on the GNAT node. Otherwise, process the function as others. */ 704 gnu_stmts = gnu_body; 705 if (TREE_CODE (gnu_stmts) == BIND_EXPR) 706 gnu_stmts = BIND_EXPR_BODY (gnu_stmts); 707 if (!gnu_stmts || !STATEMENT_LIST_HEAD (gnu_stmts)) 708 Set_Has_No_Elaboration_Code (info->gnat_node, 1); 709 else 710 { 711 begin_subprog_body (info->elab_proc); 712 end_subprog_body (gnu_body); 713 rest_of_subprog_body_compilation (info->elab_proc); 714 } 715 } 716 717 /* Destroy ourselves. */ 718 destroy_gnat_decl (); 719 destroy_gnat_utils (); 720 721 /* We cannot track the location of errors past this point. */ 722 error_gnat_node = Empty; 723} 724 725/* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given 726 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */ 727 728static tree 729build_raise_check (int check, enum exception_info_kind kind) 730{ 731 tree result, ftype; 732 const char pfx[] = "__gnat_rcheck_"; 733 734 strcpy (Name_Buffer, pfx); 735 Name_Len = sizeof (pfx) - 1; 736 Get_RT_Exception_Name (check); 737 738 if (kind == exception_simple) 739 { 740 Name_Buffer[Name_Len] = 0; 741 ftype 742 = build_function_type_list (void_type_node, 743 build_pointer_type 744 (unsigned_char_type_node), 745 integer_type_node, NULL_TREE); 746 } 747 else 748 { 749 tree t = (kind == exception_column ? NULL_TREE : integer_type_node); 750 751 strcpy (Name_Buffer + Name_Len, "_ext"); 752 Name_Buffer[Name_Len + 4] = 0; 753 ftype 754 = build_function_type_list (void_type_node, 755 build_pointer_type 756 (unsigned_char_type_node), 757 integer_type_node, integer_type_node, 758 t, t, NULL_TREE); 759 } 760 761 result 762 = create_subprog_decl (get_identifier (Name_Buffer), 763 NULL_TREE, ftype, NULL_TREE, 764 is_disabled, true, true, true, NULL, Empty); 765 766 /* Indicate that it never returns. */ 767 TREE_THIS_VOLATILE (result) = 1; 768 TREE_SIDE_EFFECTS (result) = 1; 769 TREE_TYPE (result) 770 = build_qualified_type (TREE_TYPE (result), TYPE_QUAL_VOLATILE); 771 772 return result; 773} 774 775/* Return a positive value if an lvalue is required for GNAT_NODE, which is 776 an N_Attribute_Reference. */ 777 778static int 779lvalue_required_for_attribute_p (Node_Id gnat_node) 780{ 781 switch (Get_Attribute_Id (Attribute_Name (gnat_node))) 782 { 783 case Attr_Pos: 784 case Attr_Val: 785 case Attr_Pred: 786 case Attr_Succ: 787 case Attr_First: 788 case Attr_Last: 789 case Attr_Range_Length: 790 case Attr_Length: 791 case Attr_Object_Size: 792 case Attr_Value_Size: 793 case Attr_Component_Size: 794 case Attr_Descriptor_Size: 795 case Attr_Max_Size_In_Storage_Elements: 796 case Attr_Min: 797 case Attr_Max: 798 case Attr_Null_Parameter: 799 case Attr_Passed_By_Reference: 800 case Attr_Mechanism_Code: 801 case Attr_Machine: 802 case Attr_Model: 803 return 0; 804 805 case Attr_Address: 806 case Attr_Access: 807 case Attr_Unchecked_Access: 808 case Attr_Unrestricted_Access: 809 case Attr_Code_Address: 810 case Attr_Pool_Address: 811 case Attr_Size: 812 case Attr_Alignment: 813 case Attr_Bit_Position: 814 case Attr_Position: 815 case Attr_First_Bit: 816 case Attr_Last_Bit: 817 case Attr_Bit: 818 case Attr_Asm_Input: 819 case Attr_Asm_Output: 820 default: 821 return 1; 822 } 823} 824 825/* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE 826 is the type that will be used for GNAT_NODE in the translated GNU tree. 827 CONSTANT indicates whether the underlying object represented by GNAT_NODE 828 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates 829 whether its value is the address of a constant and ALIASED whether it is 830 aliased. If it isn't, ADDRESS_OF_CONSTANT and ALIASED are ignored. 831 832 The function climbs up the GNAT tree starting from the node and returns 1 833 upon encountering a node that effectively requires an lvalue downstream. 834 It returns int instead of bool to facilitate usage in non-purely binary 835 logic contexts. */ 836 837static int 838lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant, 839 bool address_of_constant, bool aliased) 840{ 841 Node_Id gnat_parent = Parent (gnat_node), gnat_temp; 842 843 switch (Nkind (gnat_parent)) 844 { 845 case N_Reference: 846 return 1; 847 848 case N_Attribute_Reference: 849 return lvalue_required_for_attribute_p (gnat_parent); 850 851 case N_Parameter_Association: 852 case N_Function_Call: 853 case N_Procedure_Call_Statement: 854 /* If the parameter is by reference, an lvalue is required. */ 855 return (!constant 856 || must_pass_by_ref (gnu_type) 857 || default_pass_by_ref (gnu_type)); 858 859 case N_Indexed_Component: 860 /* Only the array expression can require an lvalue. */ 861 if (Prefix (gnat_parent) != gnat_node) 862 return 0; 863 864 /* ??? Consider that referencing an indexed component with a 865 non-constant index forces the whole aggregate to memory. 866 Note that N_Integer_Literal is conservative, any static 867 expression in the RM sense could probably be accepted. */ 868 for (gnat_temp = First (Expressions (gnat_parent)); 869 Present (gnat_temp); 870 gnat_temp = Next (gnat_temp)) 871 if (Nkind (gnat_temp) != N_Integer_Literal) 872 return 1; 873 874 /* ... fall through ... */ 875 876 case N_Slice: 877 /* Only the array expression can require an lvalue. */ 878 if (Prefix (gnat_parent) != gnat_node) 879 return 0; 880 881 aliased |= Has_Aliased_Components (Etype (gnat_node)); 882 return lvalue_required_p (gnat_parent, gnu_type, constant, 883 address_of_constant, aliased); 884 885 case N_Selected_Component: 886 aliased |= Is_Aliased (Entity (Selector_Name (gnat_parent))); 887 return lvalue_required_p (gnat_parent, gnu_type, constant, 888 address_of_constant, aliased); 889 890 case N_Object_Renaming_Declaration: 891 /* We need to preserve addresses through a renaming. */ 892 return 1; 893 894 case N_Object_Declaration: 895 /* We cannot use a constructor if this is an atomic object because 896 the actual assignment might end up being done component-wise. */ 897 return (!constant 898 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node))) 899 && Is_Atomic (Defining_Entity (gnat_parent))) 900 /* We don't use a constructor if this is a class-wide object 901 because the effective type of the object is the equivalent 902 type of the class-wide subtype and it smashes most of the 903 data into an array of bytes to which we cannot convert. */ 904 || Ekind ((Etype (Defining_Entity (gnat_parent)))) 905 == E_Class_Wide_Subtype); 906 907 case N_Assignment_Statement: 908 /* We cannot use a constructor if the LHS is an atomic object because 909 the actual assignment might end up being done component-wise. */ 910 return (!constant 911 || Name (gnat_parent) == gnat_node 912 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node))) 913 && Is_Atomic (Entity (Name (gnat_parent))))); 914 915 case N_Unchecked_Type_Conversion: 916 if (!constant) 917 return 1; 918 919 /* ... fall through ... */ 920 921 case N_Type_Conversion: 922 case N_Qualified_Expression: 923 /* We must look through all conversions because we may need to bypass 924 an intermediate conversion that is meant to be purely formal. */ 925 return lvalue_required_p (gnat_parent, 926 get_unpadded_type (Etype (gnat_parent)), 927 constant, address_of_constant, aliased); 928 929 case N_Allocator: 930 /* We should only reach here through the N_Qualified_Expression case. 931 Force an lvalue for composite types since a block-copy to the newly 932 allocated area of memory is made. */ 933 return Is_Composite_Type (Underlying_Type (Etype (gnat_node))); 934 935 case N_Explicit_Dereference: 936 /* We look through dereferences for address of constant because we need 937 to handle the special cases listed above. */ 938 if (constant && address_of_constant) 939 return lvalue_required_p (gnat_parent, 940 get_unpadded_type (Etype (gnat_parent)), 941 true, false, true); 942 943 /* ... fall through ... */ 944 945 default: 946 return 0; 947 } 948 949 gcc_unreachable (); 950} 951 952/* Return true if T is a constant DECL node that can be safely replaced 953 by its initializer. */ 954 955static bool 956constant_decl_with_initializer_p (tree t) 957{ 958 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t)) 959 return false; 960 961 /* Return false for aggregate types that contain a placeholder since 962 their initializers cannot be manipulated easily. */ 963 if (AGGREGATE_TYPE_P (TREE_TYPE (t)) 964 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t)) 965 && type_contains_placeholder_p (TREE_TYPE (t))) 966 return false; 967 968 return true; 969} 970 971/* Return an expression equivalent to EXP but where constant DECL nodes 972 have been replaced by their initializer. */ 973 974static tree 975fold_constant_decl_in_expr (tree exp) 976{ 977 enum tree_code code = TREE_CODE (exp); 978 tree op0; 979 980 switch (code) 981 { 982 case CONST_DECL: 983 case VAR_DECL: 984 if (!constant_decl_with_initializer_p (exp)) 985 return exp; 986 987 return DECL_INITIAL (exp); 988 989 case BIT_FIELD_REF: 990 case COMPONENT_REF: 991 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0)); 992 if (op0 == TREE_OPERAND (exp, 0)) 993 return exp; 994 995 return fold_build3 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1), 996 TREE_OPERAND (exp, 2)); 997 998 case ARRAY_REF: 999 case ARRAY_RANGE_REF: 1000 /* If the index is not itself constant, then nothing can be folded. */ 1001 if (!TREE_CONSTANT (TREE_OPERAND (exp, 1))) 1002 return exp; 1003 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0)); 1004 if (op0 == TREE_OPERAND (exp, 0)) 1005 return exp; 1006 1007 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1), 1008 TREE_OPERAND (exp, 2), TREE_OPERAND (exp, 3))); 1009 1010 case VIEW_CONVERT_EXPR: 1011 case REALPART_EXPR: 1012 case IMAGPART_EXPR: 1013 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0)); 1014 if (op0 == TREE_OPERAND (exp, 0)) 1015 return exp; 1016 1017 return fold_build1 (code, TREE_TYPE (exp), op0); 1018 1019 default: 1020 return exp; 1021 } 1022 1023 gcc_unreachable (); 1024} 1025 1026/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier, 1027 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer 1028 to where we should place the result type. */ 1029 1030static tree 1031Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) 1032{ 1033 Node_Id gnat_temp, gnat_temp_type; 1034 tree gnu_result, gnu_result_type; 1035 1036 /* Whether we should require an lvalue for GNAT_NODE. Needed in 1037 specific circumstances only, so evaluated lazily. < 0 means 1038 unknown, > 0 means known true, 0 means known false. */ 1039 int require_lvalue = -1; 1040 1041 /* If GNAT_NODE is a constant, whether we should use the initialization 1042 value instead of the constant entity, typically for scalars with an 1043 address clause when the parent doesn't require an lvalue. */ 1044 bool use_constant_initializer = false; 1045 1046 /* If the Etype of this node does not equal the Etype of the Entity, 1047 something is wrong with the entity map, probably in generic 1048 instantiation. However, this does not apply to types. Since we sometime 1049 have strange Ekind's, just do this test for objects. Also, if the Etype of 1050 the Entity is private, the Etype of the N_Identifier is allowed to be the 1051 full type and also we consider a packed array type to be the same as the 1052 original type. Similarly, a class-wide type is equivalent to a subtype of 1053 itself. Finally, if the types are Itypes, one may be a copy of the other, 1054 which is also legal. */ 1055 gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier 1056 ? gnat_node : Entity (gnat_node)); 1057 gnat_temp_type = Etype (gnat_temp); 1058 1059 gcc_assert (Etype (gnat_node) == gnat_temp_type 1060 || (Is_Packed (gnat_temp_type) 1061 && (Etype (gnat_node) 1062 == Packed_Array_Impl_Type (gnat_temp_type))) 1063 || (Is_Class_Wide_Type (Etype (gnat_node))) 1064 || (IN (Ekind (gnat_temp_type), Private_Kind) 1065 && Present (Full_View (gnat_temp_type)) 1066 && ((Etype (gnat_node) == Full_View (gnat_temp_type)) 1067 || (Is_Packed (Full_View (gnat_temp_type)) 1068 && (Etype (gnat_node) 1069 == Packed_Array_Impl_Type 1070 (Full_View (gnat_temp_type)))))) 1071 || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type)) 1072 || !(Ekind (gnat_temp) == E_Variable 1073 || Ekind (gnat_temp) == E_Component 1074 || Ekind (gnat_temp) == E_Constant 1075 || Ekind (gnat_temp) == E_Loop_Parameter 1076 || IN (Ekind (gnat_temp), Formal_Kind))); 1077 1078 /* If this is a reference to a deferred constant whose partial view is an 1079 unconstrained private type, the proper type is on the full view of the 1080 constant, not on the full view of the type, which may be unconstrained. 1081 1082 This may be a reference to a type, for example in the prefix of the 1083 attribute Position, generated for dispatching code (see Make_DT in 1084 exp_disp,adb). In that case we need the type itself, not is parent, 1085 in particular if it is a derived type */ 1086 if (Ekind (gnat_temp) == E_Constant 1087 && Is_Private_Type (gnat_temp_type) 1088 && (Has_Unknown_Discriminants (gnat_temp_type) 1089 || (Present (Full_View (gnat_temp_type)) 1090 && Has_Discriminants (Full_View (gnat_temp_type)))) 1091 && Present (Full_View (gnat_temp))) 1092 { 1093 gnat_temp = Full_View (gnat_temp); 1094 gnat_temp_type = Etype (gnat_temp); 1095 } 1096 else 1097 { 1098 /* We want to use the Actual_Subtype if it has already been elaborated, 1099 otherwise the Etype. Avoid using Actual_Subtype for packed arrays to 1100 simplify things. */ 1101 if ((Ekind (gnat_temp) == E_Constant 1102 || Ekind (gnat_temp) == E_Variable || Is_Formal (gnat_temp)) 1103 && !(Is_Array_Type (Etype (gnat_temp)) 1104 && Present (Packed_Array_Impl_Type (Etype (gnat_temp)))) 1105 && Present (Actual_Subtype (gnat_temp)) 1106 && present_gnu_tree (Actual_Subtype (gnat_temp))) 1107 gnat_temp_type = Actual_Subtype (gnat_temp); 1108 else 1109 gnat_temp_type = Etype (gnat_node); 1110 } 1111 1112 /* Expand the type of this identifier first, in case it is an enumeral 1113 literal, which only get made when the type is expanded. There is no 1114 order-of-elaboration issue here. */ 1115 gnu_result_type = get_unpadded_type (gnat_temp_type); 1116 1117 /* If this is a non-imported elementary constant with an address clause, 1118 retrieve the value instead of a pointer to be dereferenced unless 1119 an lvalue is required. This is generally more efficient and actually 1120 required if this is a static expression because it might be used 1121 in a context where a dereference is inappropriate, such as a case 1122 statement alternative or a record discriminant. There is no possible 1123 volatile-ness short-circuit here since Volatile constants must be 1124 imported per C.6. */ 1125 if (Ekind (gnat_temp) == E_Constant 1126 && Is_Elementary_Type (gnat_temp_type) 1127 && !Is_Imported (gnat_temp) 1128 && Present (Address_Clause (gnat_temp))) 1129 { 1130 require_lvalue = lvalue_required_p (gnat_node, gnu_result_type, true, 1131 false, Is_Aliased (gnat_temp)); 1132 use_constant_initializer = !require_lvalue; 1133 } 1134 1135 if (use_constant_initializer) 1136 { 1137 /* If this is a deferred constant, the initializer is attached to 1138 the full view. */ 1139 if (Present (Full_View (gnat_temp))) 1140 gnat_temp = Full_View (gnat_temp); 1141 1142 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp))); 1143 } 1144 else 1145 gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0); 1146 1147 /* Some objects (such as parameters passed by reference, globals of 1148 variable size, and renamed objects) actually represent the address 1149 of the object. In that case, we must do the dereference. Likewise, 1150 deal with parameters to foreign convention subprograms. */ 1151 if (DECL_P (gnu_result) 1152 && (DECL_BY_REF_P (gnu_result) 1153 || (TREE_CODE (gnu_result) == PARM_DECL 1154 && DECL_BY_COMPONENT_PTR_P (gnu_result)))) 1155 { 1156 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result); 1157 1158 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */ 1159 if (TREE_CODE (gnu_result) == PARM_DECL 1160 && DECL_BY_COMPONENT_PTR_P (gnu_result)) 1161 gnu_result 1162 = convert (build_pointer_type (gnu_result_type), gnu_result); 1163 1164 /* If it's a CONST_DECL, return the underlying constant like below. */ 1165 else if (TREE_CODE (gnu_result) == CONST_DECL 1166 && !(DECL_CONST_ADDRESS_P (gnu_result) 1167 && lvalue_required_p (gnat_node, gnu_result_type, true, 1168 true, false))) 1169 gnu_result = DECL_INITIAL (gnu_result); 1170 1171 /* If it's a renaming pointer and, either the renamed object is constant 1172 or we are at the right binding level, we can reference the renamed 1173 object directly, since it is constant or has been protected against 1174 multiple evaluations. */ 1175 if (TREE_CODE (gnu_result) == VAR_DECL 1176 && !DECL_LOOP_PARM_P (gnu_result) 1177 && DECL_RENAMED_OBJECT (gnu_result) 1178 && (TREE_CONSTANT (DECL_RENAMED_OBJECT (gnu_result)) 1179 || !DECL_RENAMING_GLOBAL_P (gnu_result) 1180 || global_bindings_p ())) 1181 gnu_result = DECL_RENAMED_OBJECT (gnu_result); 1182 1183 /* Otherwise, do the final dereference. */ 1184 else 1185 { 1186 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); 1187 1188 if ((TREE_CODE (gnu_result) == INDIRECT_REF 1189 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) 1190 && No (Address_Clause (gnat_temp))) 1191 TREE_THIS_NOTRAP (gnu_result) = 1; 1192 1193 if (read_only) 1194 TREE_READONLY (gnu_result) = 1; 1195 } 1196 } 1197 1198 /* If we have a constant declaration and its initializer, try to return the 1199 latter to avoid the need to call fold in lots of places and the need for 1200 elaboration code if this identifier is used as an initializer itself. */ 1201 if (constant_decl_with_initializer_p (gnu_result)) 1202 { 1203 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL 1204 && !DECL_CONST_CORRESPONDING_VAR (gnu_result)); 1205 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL 1206 && DECL_CONST_ADDRESS_P (gnu_result)); 1207 1208 /* If there is a (corresponding) variable or this is the address of a 1209 constant, we only want to return the initializer if an lvalue isn't 1210 required. Evaluate this now if we have not already done so. */ 1211 if ((!constant_only || address_of_constant) && require_lvalue < 0) 1212 require_lvalue 1213 = lvalue_required_p (gnat_node, gnu_result_type, true, 1214 address_of_constant, Is_Aliased (gnat_temp)); 1215 1216 /* Finally retrieve the initializer if this is deemed valid. */ 1217 if ((constant_only && !address_of_constant) || !require_lvalue) 1218 gnu_result = DECL_INITIAL (gnu_result); 1219 } 1220 1221 /* But for a constant renaming we couldn't do that incrementally for its 1222 definition because of the need to return an lvalue so, if the present 1223 context doesn't itself require an lvalue, we try again here. */ 1224 else if (Ekind (gnat_temp) == E_Constant 1225 && Is_Elementary_Type (gnat_temp_type) 1226 && Present (Renamed_Object (gnat_temp))) 1227 { 1228 if (require_lvalue < 0) 1229 require_lvalue 1230 = lvalue_required_p (gnat_node, gnu_result_type, true, false, 1231 Is_Aliased (gnat_temp)); 1232 if (!require_lvalue) 1233 gnu_result = fold_constant_decl_in_expr (gnu_result); 1234 } 1235 1236 /* The GNAT tree has the type of a function set to its result type, so we 1237 adjust here. Also use the type of the result if the Etype is a subtype 1238 that is nominally unconstrained. Likewise if this is a deferred constant 1239 of a discriminated type whose full view can be elaborated statically, to 1240 avoid problematic conversions to the nominal subtype. But remove any 1241 padding from the resulting type. */ 1242 if (TREE_CODE (TREE_TYPE (gnu_result)) == FUNCTION_TYPE 1243 || Is_Constr_Subt_For_UN_Aliased (gnat_temp_type) 1244 || (Ekind (gnat_temp) == E_Constant 1245 && Present (Full_View (gnat_temp)) 1246 && Has_Discriminants (gnat_temp_type) 1247 && TREE_CODE (gnu_result) == CONSTRUCTOR)) 1248 { 1249 gnu_result_type = TREE_TYPE (gnu_result); 1250 if (TYPE_IS_PADDING_P (gnu_result_type)) 1251 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type)); 1252 } 1253 1254 *gnu_result_type_p = gnu_result_type; 1255 1256 return gnu_result; 1257} 1258 1259/* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return 1260 any statements we generate. */ 1261 1262static tree 1263Pragma_to_gnu (Node_Id gnat_node) 1264{ 1265 tree gnu_result = alloc_stmt_list (); 1266 unsigned char pragma_id; 1267 Node_Id gnat_temp; 1268 1269 /* Do nothing if we are just annotating types and check for (and ignore) 1270 unrecognized pragmas. */ 1271 if (type_annotate_only 1272 || !Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node)))) 1273 return gnu_result; 1274 1275 pragma_id = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node))); 1276 switch (pragma_id) 1277 { 1278 case Pragma_Inspection_Point: 1279 /* Do nothing at top level: all such variables are already viewable. */ 1280 if (global_bindings_p ()) 1281 break; 1282 1283 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); 1284 Present (gnat_temp); 1285 gnat_temp = Next (gnat_temp)) 1286 { 1287 Node_Id gnat_expr = Expression (gnat_temp); 1288 tree gnu_expr = gnat_to_gnu (gnat_expr); 1289 int use_address; 1290 machine_mode mode; 1291 tree asm_constraint = NULL_TREE; 1292#ifdef ASM_COMMENT_START 1293 char *comment; 1294#endif 1295 1296 if (TREE_CODE (gnu_expr) == UNCONSTRAINED_ARRAY_REF) 1297 gnu_expr = TREE_OPERAND (gnu_expr, 0); 1298 1299 /* Use the value only if it fits into a normal register, 1300 otherwise use the address. */ 1301 mode = TYPE_MODE (TREE_TYPE (gnu_expr)); 1302 use_address = ((GET_MODE_CLASS (mode) != MODE_INT 1303 && GET_MODE_CLASS (mode) != MODE_PARTIAL_INT) 1304 || GET_MODE_SIZE (mode) > UNITS_PER_WORD); 1305 1306 if (use_address) 1307 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); 1308 1309#ifdef ASM_COMMENT_START 1310 comment = concat (ASM_COMMENT_START, 1311 " inspection point: ", 1312 Get_Name_String (Chars (gnat_expr)), 1313 use_address ? " address" : "", 1314 " is in %0", 1315 NULL); 1316 asm_constraint = build_string (strlen (comment), comment); 1317 free (comment); 1318#endif 1319 gnu_expr = build5 (ASM_EXPR, void_type_node, 1320 asm_constraint, 1321 NULL_TREE, 1322 tree_cons 1323 (build_tree_list (NULL_TREE, 1324 build_string (1, "g")), 1325 gnu_expr, NULL_TREE), 1326 NULL_TREE, NULL_TREE); 1327 ASM_VOLATILE_P (gnu_expr) = 1; 1328 set_expr_location_from_node (gnu_expr, gnat_node); 1329 append_to_statement_list (gnu_expr, &gnu_result); 1330 } 1331 break; 1332 1333 case Pragma_Loop_Optimize: 1334 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node)); 1335 Present (gnat_temp); 1336 gnat_temp = Next (gnat_temp)) 1337 { 1338 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt; 1339 1340 switch (Chars (Expression (gnat_temp))) 1341 { 1342 case Name_Ivdep: 1343 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1; 1344 break; 1345 1346 case Name_No_Unroll: 1347 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1; 1348 break; 1349 1350 case Name_Unroll: 1351 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1; 1352 break; 1353 1354 case Name_No_Vector: 1355 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1; 1356 break; 1357 1358 case Name_Vector: 1359 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1; 1360 break; 1361 1362 default: 1363 gcc_unreachable (); 1364 } 1365 } 1366 break; 1367 1368 case Pragma_Optimize: 1369 switch (Chars (Expression 1370 (First (Pragma_Argument_Associations (gnat_node))))) 1371 { 1372 case Name_Off: 1373 if (optimize) 1374 post_error ("must specify -O0?", gnat_node); 1375 break; 1376 1377 case Name_Space: 1378 if (!optimize_size) 1379 post_error ("must specify -Os?", gnat_node); 1380 break; 1381 1382 case Name_Time: 1383 if (!optimize) 1384 post_error ("insufficient -O value?", gnat_node); 1385 break; 1386 1387 default: 1388 gcc_unreachable (); 1389 } 1390 break; 1391 1392 case Pragma_Reviewable: 1393 if (write_symbols == NO_DEBUG) 1394 post_error ("must specify -g?", gnat_node); 1395 break; 1396 1397 case Pragma_Warning_As_Error: 1398 case Pragma_Warnings: 1399 { 1400 Node_Id gnat_expr; 1401 /* Preserve the location of the pragma. */ 1402 const location_t location = input_location; 1403 struct cl_option_handlers handlers; 1404 unsigned int option_index; 1405 diagnostic_t kind; 1406 bool imply; 1407 1408 gnat_temp = First (Pragma_Argument_Associations (gnat_node)); 1409 1410 /* This is the String form: pragma Warning{s|_As_Error}(String). */ 1411 if (Nkind (Expression (gnat_temp)) == N_String_Literal) 1412 { 1413 switch (pragma_id) 1414 { 1415 case Pragma_Warning_As_Error: 1416 kind = DK_ERROR; 1417 imply = false; 1418 break; 1419 1420 case Pragma_Warnings: 1421 kind = DK_WARNING; 1422 imply = true; 1423 break; 1424 1425 default: 1426 gcc_unreachable (); 1427 } 1428 1429 gnat_expr = Expression (gnat_temp); 1430 } 1431 1432 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */ 1433 else if (Nkind (Expression (gnat_temp)) == N_Identifier) 1434 { 1435 switch (Chars (Expression (gnat_temp))) 1436 { 1437 case Name_Off: 1438 kind = DK_IGNORED; 1439 break; 1440 1441 case Name_On: 1442 kind = DK_WARNING; 1443 break; 1444 1445 default: 1446 gcc_unreachable (); 1447 } 1448 1449 /* Deal with optional pattern (but ignore Reason => "..."). */ 1450 if (Present (Next (gnat_temp)) 1451 && Chars (Next (gnat_temp)) != Name_Reason) 1452 { 1453 /* pragma Warnings (On | Off, Name) is handled differently. */ 1454 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal) 1455 break; 1456 1457 gnat_expr = Expression (Next (gnat_temp)); 1458 } 1459 else 1460 gnat_expr = Empty; 1461 1462 imply = false; 1463 } 1464 1465 else 1466 gcc_unreachable (); 1467 1468 /* This is the same implementation as in the C family of compilers. */ 1469 if (Present (gnat_expr)) 1470 { 1471 tree gnu_expr = gnat_to_gnu (gnat_expr); 1472 const char *opt_string = TREE_STRING_POINTER (gnu_expr); 1473 const int len = TREE_STRING_LENGTH (gnu_expr); 1474 if (len < 3 || opt_string[0] != '-' || opt_string[1] != 'W') 1475 break; 1476 for (option_index = 0; 1477 option_index < cl_options_count; 1478 option_index++) 1479 if (strcmp (cl_options[option_index].opt_text, opt_string) == 0) 1480 break; 1481 if (option_index == cl_options_count) 1482 { 1483 post_error ("unknown -W switch", gnat_node); 1484 break; 1485 } 1486 } 1487 else 1488 option_index = 0; 1489 1490 set_default_handlers (&handlers); 1491 control_warning_option (option_index, (int) kind, imply, location, 1492 CL_Ada, &handlers, &global_options, 1493 &global_options_set, global_dc); 1494 } 1495 break; 1496 1497 default: 1498 break; 1499 } 1500 1501 return gnu_result; 1502} 1503 1504 1505/* Check the inline status of nested function FNDECL wrt its parent function. 1506 1507 If a non-inline nested function is referenced from an inline external 1508 function, we cannot honor both requests at the same time without cloning 1509 the nested function in the current unit since it is private to its unit. 1510 We could inline it as well but it's probably better to err on the side 1511 of too little inlining. 1512 1513 This must be done only on nested functions present in the source code 1514 and not on nested functions generated by the compiler, e.g. finalizers, 1515 because they may be not marked inline and we don't want them to block 1516 the inlining of the parent function. */ 1517 1518static void 1519check_inlining_for_nested_subprog (tree fndecl) 1520{ 1521 if (DECL_IGNORED_P (current_function_decl) || DECL_IGNORED_P (fndecl)) 1522 return; 1523 1524 if (DECL_DECLARED_INLINE_P (fndecl)) 1525 return; 1526 1527 tree parent_decl = decl_function_context (fndecl); 1528 if (DECL_EXTERNAL (parent_decl) && DECL_DECLARED_INLINE_P (parent_decl)) 1529 { 1530 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl); 1531 const location_t loc2 = DECL_SOURCE_LOCATION (parent_decl); 1532 1533 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl))) 1534 { 1535 error_at (loc1, "subprogram %q+F not marked Inline_Always", fndecl); 1536 error_at (loc2, "parent subprogram cannot be inlined"); 1537 } 1538 else 1539 { 1540 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked Inline", 1541 fndecl); 1542 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined"); 1543 } 1544 1545 DECL_DECLARED_INLINE_P (parent_decl) = 0; 1546 DECL_UNINLINABLE (parent_decl) = 1; 1547 } 1548} 1549 1550/* Return an expression for the length of TYPE, an integral type, computed in 1551 RESULT_TYPE, another integral type. 1552 1553 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow 1554 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0 1555 which would only overflow in much rarer cases, for extremely large arrays 1556 we expect never to encounter in practice. Besides, the former computation 1557 required the use of potentially constraining signed arithmetics while the 1558 latter does not. Note that the comparison must be done in the original 1559 base index type in order to avoid any overflow during the conversion. */ 1560 1561static tree 1562get_type_length (tree type, tree result_type) 1563{ 1564 tree comp_type = get_base_type (result_type); 1565 tree base_type = get_base_type (type); 1566 tree lb = convert (base_type, TYPE_MIN_VALUE (type)); 1567 tree hb = convert (base_type, TYPE_MAX_VALUE (type)); 1568 tree length 1569 = build_binary_op (PLUS_EXPR, comp_type, 1570 build_binary_op (MINUS_EXPR, comp_type, 1571 convert (comp_type, hb), 1572 convert (comp_type, lb)), 1573 convert (comp_type, integer_one_node)); 1574 length 1575 = build_cond_expr (result_type, 1576 build_binary_op (GE_EXPR, boolean_type_node, hb, lb), 1577 convert (result_type, length), 1578 convert (result_type, integer_zero_node)); 1579 return length; 1580} 1581 1582/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node, 1583 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to 1584 where we should place the result type. ATTRIBUTE is the attribute ID. */ 1585 1586static tree 1587Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) 1588{ 1589 const Node_Id gnat_prefix = Prefix (gnat_node); 1590 tree gnu_prefix, gnu_type, gnu_expr; 1591 tree gnu_result_type, gnu_result = error_mark_node; 1592 bool prefix_unused = false; 1593 1594 /* ??? If this is an access attribute for a public subprogram to be used in 1595 a dispatch table, do not translate its type as it's useless in this case 1596 and the parameter types might be incomplete types coming from a limited 1597 context in Ada 2012 (AI05-0151). */ 1598 if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type 1599 && Is_Dispatch_Table_Entity (Etype (gnat_node)) 1600 && Nkind (gnat_prefix) == N_Identifier 1601 && Is_Subprogram (Entity (gnat_prefix)) 1602 && Is_Public (Entity (gnat_prefix)) 1603 && !present_gnu_tree (Entity (gnat_prefix))) 1604 gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix)); 1605 else 1606 gnu_prefix = gnat_to_gnu (gnat_prefix); 1607 gnu_type = TREE_TYPE (gnu_prefix); 1608 1609 /* If the input is a NULL_EXPR, make a new one. */ 1610 if (TREE_CODE (gnu_prefix) == NULL_EXPR) 1611 { 1612 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1613 *gnu_result_type_p = gnu_result_type; 1614 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0)); 1615 } 1616 1617 switch (attribute) 1618 { 1619 case Attr_Pos: 1620 case Attr_Val: 1621 /* These are just conversions since representation clauses for 1622 enumeration types are handled in the front-end. */ 1623 { 1624 bool checkp = Do_Range_Check (First (Expressions (gnat_node))); 1625 gnu_result = gnat_to_gnu (First (Expressions (gnat_node))); 1626 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1627 gnu_result = convert_with_check (Etype (gnat_node), gnu_result, 1628 checkp, checkp, true, gnat_node); 1629 } 1630 break; 1631 1632 case Attr_Pred: 1633 case Attr_Succ: 1634 /* These just add or subtract the constant 1 since representation 1635 clauses for enumeration types are handled in the front-end. */ 1636 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); 1637 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1638 1639 if (Do_Range_Check (First (Expressions (gnat_node)))) 1640 { 1641 gnu_expr = gnat_protect_expr (gnu_expr); 1642 gnu_expr 1643 = emit_check 1644 (build_binary_op (EQ_EXPR, boolean_type_node, 1645 gnu_expr, 1646 attribute == Attr_Pred 1647 ? TYPE_MIN_VALUE (gnu_result_type) 1648 : TYPE_MAX_VALUE (gnu_result_type)), 1649 gnu_expr, CE_Range_Check_Failed, gnat_node); 1650 } 1651 1652 gnu_result 1653 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR, 1654 gnu_result_type, gnu_expr, 1655 convert (gnu_result_type, integer_one_node)); 1656 break; 1657 1658 case Attr_Address: 1659 case Attr_Unrestricted_Access: 1660 /* Conversions don't change addresses but can cause us to miss the 1661 COMPONENT_REF case below, so strip them off. */ 1662 gnu_prefix = remove_conversions (gnu_prefix, 1663 !Must_Be_Byte_Aligned (gnat_node)); 1664 1665 /* If we are taking 'Address of an unconstrained object, this is the 1666 pointer to the underlying array. */ 1667 if (attribute == Attr_Address) 1668 gnu_prefix = maybe_unconstrained_array (gnu_prefix); 1669 1670 /* If we are building a static dispatch table, we have to honor 1671 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible 1672 with the C++ ABI. We do it in the non-static case as well, 1673 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */ 1674 else if (TARGET_VTABLE_USES_DESCRIPTORS 1675 && Is_Dispatch_Table_Entity (Etype (gnat_node))) 1676 { 1677 tree gnu_field, t; 1678 /* Descriptors can only be built here for top-level functions. */ 1679 bool build_descriptor = (global_bindings_p () != 0); 1680 int i; 1681 vec<constructor_elt, va_gc> *gnu_vec = NULL; 1682 constructor_elt *elt; 1683 1684 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1685 1686 /* If we're not going to build the descriptor, we have to retrieve 1687 the one which will be built by the linker (or by the compiler 1688 later if a static chain is requested). */ 1689 if (!build_descriptor) 1690 { 1691 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix); 1692 gnu_result = fold_convert (build_pointer_type (gnu_result_type), 1693 gnu_result); 1694 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result); 1695 } 1696 1697 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS); 1698 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1); 1699 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0; 1700 i < TARGET_VTABLE_USES_DESCRIPTORS; 1701 gnu_field = DECL_CHAIN (gnu_field), i++) 1702 { 1703 if (build_descriptor) 1704 { 1705 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix, 1706 build_int_cst (NULL_TREE, i)); 1707 TREE_CONSTANT (t) = 1; 1708 } 1709 else 1710 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result, 1711 gnu_field, NULL_TREE); 1712 1713 elt->index = gnu_field; 1714 elt->value = t; 1715 elt--; 1716 } 1717 1718 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); 1719 break; 1720 } 1721 1722 /* ... fall through ... */ 1723 1724 case Attr_Access: 1725 case Attr_Unchecked_Access: 1726 case Attr_Code_Address: 1727 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1728 gnu_result 1729 = build_unary_op (((attribute == Attr_Address 1730 || attribute == Attr_Unrestricted_Access) 1731 && !Must_Be_Byte_Aligned (gnat_node)) 1732 ? ATTR_ADDR_EXPR : ADDR_EXPR, 1733 gnu_result_type, gnu_prefix); 1734 1735 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we 1736 don't try to build a trampoline. */ 1737 if (attribute == Attr_Code_Address) 1738 { 1739 gnu_expr = remove_conversions (gnu_result, false); 1740 1741 if (TREE_CODE (gnu_expr) == ADDR_EXPR) 1742 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1; 1743 } 1744 1745 /* For 'Access, issue an error message if the prefix is a C++ method 1746 since it can use a special calling convention on some platforms, 1747 which cannot be propagated to the access type. */ 1748 else if (attribute == Attr_Access 1749 && Nkind (gnat_prefix) == N_Identifier 1750 && is_cplusplus_method (Entity (gnat_prefix))) 1751 post_error ("access to C++ constructor or member function not allowed", 1752 gnat_node); 1753 1754 /* For other address attributes applied to a nested function, 1755 find an inner ADDR_EXPR and annotate it so that we can issue 1756 a useful warning with -Wtrampolines. */ 1757 else if (TREE_CODE (TREE_TYPE (gnu_prefix)) == FUNCTION_TYPE) 1758 { 1759 gnu_expr = remove_conversions (gnu_result, false); 1760 1761 if (TREE_CODE (gnu_expr) == ADDR_EXPR 1762 && decl_function_context (TREE_OPERAND (gnu_expr, 0))) 1763 { 1764 set_expr_location_from_node (gnu_expr, gnat_node); 1765 1766 /* Also check the inlining status. */ 1767 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0)); 1768 1769 /* Check that we're not violating the No_Implicit_Dynamic_Code 1770 restriction. Be conservative if we don't know anything 1771 about the trampoline strategy for the target. */ 1772 Check_Implicit_Dynamic_Code_Allowed (gnat_node); 1773 } 1774 } 1775 break; 1776 1777 case Attr_Pool_Address: 1778 { 1779 tree gnu_ptr = gnu_prefix; 1780 tree gnu_obj_type; 1781 1782 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1783 1784 /* If this is fat pointer, the object must have been allocated with the 1785 template in front of the array. So compute the template address; do 1786 it by converting to a thin pointer. */ 1787 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) 1788 gnu_ptr 1789 = convert (build_pointer_type 1790 (TYPE_OBJECT_RECORD_TYPE 1791 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), 1792 gnu_ptr); 1793 1794 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); 1795 1796 /* If this is a thin pointer, the object must have been allocated with 1797 the template in front of the array. So compute the template address 1798 and return it. */ 1799 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) 1800 gnu_ptr 1801 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr), 1802 gnu_ptr, 1803 fold_build1 (NEGATE_EXPR, sizetype, 1804 byte_position 1805 (DECL_CHAIN 1806 TYPE_FIELDS ((gnu_obj_type))))); 1807 1808 gnu_result = convert (gnu_result_type, gnu_ptr); 1809 } 1810 break; 1811 1812 case Attr_Size: 1813 case Attr_Object_Size: 1814 case Attr_Value_Size: 1815 case Attr_Max_Size_In_Storage_Elements: 1816 gnu_expr = gnu_prefix; 1817 1818 /* Remove NOPs and conversions between original and packable version 1819 from GNU_EXPR, and conversions from GNU_PREFIX. We use GNU_EXPR 1820 to see if a COMPONENT_REF was involved. */ 1821 while (TREE_CODE (gnu_expr) == NOP_EXPR 1822 || (TREE_CODE (gnu_expr) == VIEW_CONVERT_EXPR 1823 && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE 1824 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))) 1825 == RECORD_TYPE 1826 && TYPE_NAME (TREE_TYPE (gnu_expr)) 1827 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))) 1828 gnu_expr = TREE_OPERAND (gnu_expr, 0); 1829 1830 gnu_prefix = remove_conversions (gnu_prefix, true); 1831 prefix_unused = true; 1832 gnu_type = TREE_TYPE (gnu_prefix); 1833 1834 /* Replace an unconstrained array type with the type of the underlying 1835 array. We can't do this with a call to maybe_unconstrained_array 1836 since we may have a TYPE_DECL. For 'Max_Size_In_Storage_Elements, 1837 use the record type that will be used to allocate the object and its 1838 template. */ 1839 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) 1840 { 1841 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); 1842 if (attribute != Attr_Max_Size_In_Storage_Elements) 1843 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))); 1844 } 1845 1846 /* If we're looking for the size of a field, return the field size. */ 1847 if (TREE_CODE (gnu_prefix) == COMPONENT_REF) 1848 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1)); 1849 1850 /* Otherwise, if the prefix is an object, or if we are looking for 1851 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the 1852 GCC size of the type. We make an exception for padded objects, 1853 as we do not take into account alignment promotions for the size. 1854 This is in keeping with the object case of gnat_to_gnu_entity. */ 1855 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL 1856 && !(TYPE_IS_PADDING_P (gnu_type) 1857 && TREE_CODE (gnu_expr) == COMPONENT_REF)) 1858 || attribute == Attr_Object_Size 1859 || attribute == Attr_Max_Size_In_Storage_Elements) 1860 { 1861 /* If this is a dereference and we have a special dynamic constrained 1862 subtype on the prefix, use it to compute the size; otherwise, use 1863 the designated subtype. */ 1864 if (Nkind (gnat_prefix) == N_Explicit_Dereference) 1865 { 1866 Node_Id gnat_actual_subtype 1867 = Actual_Designated_Subtype (gnat_prefix); 1868 tree gnu_ptr_type 1869 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix))); 1870 1871 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type) 1872 && Present (gnat_actual_subtype)) 1873 { 1874 tree gnu_actual_obj_type 1875 = gnat_to_gnu_type (gnat_actual_subtype); 1876 gnu_type 1877 = build_unc_object_type_from_ptr (gnu_ptr_type, 1878 gnu_actual_obj_type, 1879 get_identifier ("SIZE"), 1880 false); 1881 } 1882 } 1883 1884 gnu_result = TYPE_SIZE (gnu_type); 1885 } 1886 1887 /* Otherwise, the result is the RM size of the type. */ 1888 else 1889 gnu_result = rm_size (gnu_type); 1890 1891 /* Deal with a self-referential size by returning the maximum size for 1892 a type and by qualifying the size with the object otherwise. */ 1893 if (CONTAINS_PLACEHOLDER_P (gnu_result)) 1894 { 1895 if (TREE_CODE (gnu_prefix) == TYPE_DECL) 1896 gnu_result = max_size (gnu_result, true); 1897 else 1898 gnu_result = substitute_placeholder_in_expr (gnu_result, gnu_expr); 1899 } 1900 1901 /* If the type contains a template, subtract its size. */ 1902 if (TREE_CODE (gnu_type) == RECORD_TYPE 1903 && TYPE_CONTAINS_TEMPLATE_P (gnu_type)) 1904 gnu_result = size_binop (MINUS_EXPR, gnu_result, 1905 DECL_SIZE (TYPE_FIELDS (gnu_type))); 1906 1907 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */ 1908 if (attribute == Attr_Max_Size_In_Storage_Elements) 1909 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node); 1910 1911 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1912 break; 1913 1914 case Attr_Alignment: 1915 { 1916 unsigned int align; 1917 1918 if (TREE_CODE (gnu_prefix) == COMPONENT_REF 1919 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) 1920 gnu_prefix = TREE_OPERAND (gnu_prefix, 0); 1921 1922 gnu_type = TREE_TYPE (gnu_prefix); 1923 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1924 prefix_unused = true; 1925 1926 if (TREE_CODE (gnu_prefix) == COMPONENT_REF) 1927 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT; 1928 else 1929 { 1930 Entity_Id gnat_type = Etype (gnat_prefix); 1931 unsigned int double_align; 1932 bool is_capped_double, align_clause; 1933 1934 /* If the default alignment of "double" or larger scalar types is 1935 specifically capped and there is an alignment clause neither 1936 on the type nor on the prefix itself, return the cap. */ 1937 if ((double_align = double_float_alignment) > 0) 1938 is_capped_double 1939 = is_double_float_or_array (gnat_type, &align_clause); 1940 else if ((double_align = double_scalar_alignment) > 0) 1941 is_capped_double 1942 = is_double_scalar_or_array (gnat_type, &align_clause); 1943 else 1944 is_capped_double = align_clause = false; 1945 1946 if (is_capped_double 1947 && Nkind (gnat_prefix) == N_Identifier 1948 && Present (Alignment_Clause (Entity (gnat_prefix)))) 1949 align_clause = true; 1950 1951 if (is_capped_double && !align_clause) 1952 align = double_align; 1953 else 1954 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT; 1955 } 1956 1957 gnu_result = size_int (align); 1958 } 1959 break; 1960 1961 case Attr_First: 1962 case Attr_Last: 1963 case Attr_Range_Length: 1964 prefix_unused = true; 1965 1966 if (INTEGRAL_TYPE_P (gnu_type) || TREE_CODE (gnu_type) == REAL_TYPE) 1967 { 1968 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 1969 1970 if (attribute == Attr_First) 1971 gnu_result = TYPE_MIN_VALUE (gnu_type); 1972 else if (attribute == Attr_Last) 1973 gnu_result = TYPE_MAX_VALUE (gnu_type); 1974 else 1975 gnu_result = get_type_length (gnu_type, gnu_result_type); 1976 break; 1977 } 1978 1979 /* ... fall through ... */ 1980 1981 case Attr_Length: 1982 { 1983 int Dimension = (Present (Expressions (gnat_node)) 1984 ? UI_To_Int (Intval (First (Expressions (gnat_node)))) 1985 : 1), i; 1986 struct parm_attr_d *pa = NULL; 1987 Entity_Id gnat_param = Empty; 1988 bool unconstrained_ptr_deref = false; 1989 1990 /* Make sure any implicit dereference gets done. */ 1991 gnu_prefix = maybe_implicit_deref (gnu_prefix); 1992 gnu_prefix = maybe_unconstrained_array (gnu_prefix); 1993 1994 /* We treat unconstrained array In parameters specially. We also note 1995 whether we are dereferencing a pointer to unconstrained array. */ 1996 if (!Is_Constrained (Etype (gnat_prefix))) 1997 switch (Nkind (gnat_prefix)) 1998 { 1999 case N_Identifier: 2000 /* This is the direct case. */ 2001 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter) 2002 gnat_param = Entity (gnat_prefix); 2003 break; 2004 2005 case N_Explicit_Dereference: 2006 /* This is the indirect case. Note that we need to be sure that 2007 the access value cannot be null as we'll hoist the load. */ 2008 if (Nkind (Prefix (gnat_prefix)) == N_Identifier 2009 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter) 2010 { 2011 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix)))) 2012 gnat_param = Entity (Prefix (gnat_prefix)); 2013 } 2014 else 2015 unconstrained_ptr_deref = true; 2016 break; 2017 2018 default: 2019 break; 2020 } 2021 2022 /* If the prefix is the view conversion of a constrained array to an 2023 unconstrained form, we retrieve the constrained array because we 2024 might not be able to substitute the PLACEHOLDER_EXPR coming from 2025 the conversion. This can occur with the 'Old attribute applied 2026 to a parameter with an unconstrained type, which gets rewritten 2027 into a constrained local variable very late in the game. */ 2028 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR 2029 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix))) 2030 && !CONTAINS_PLACEHOLDER_P 2031 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))) 2032 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)); 2033 else 2034 gnu_type = TREE_TYPE (gnu_prefix); 2035 2036 prefix_unused = true; 2037 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2038 2039 if (TYPE_CONVENTION_FORTRAN_P (gnu_type)) 2040 { 2041 int ndim; 2042 tree gnu_type_temp; 2043 2044 for (ndim = 1, gnu_type_temp = gnu_type; 2045 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE 2046 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp)); 2047 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp)) 2048 ; 2049 2050 Dimension = ndim + 1 - Dimension; 2051 } 2052 2053 for (i = 1; i < Dimension; i++) 2054 gnu_type = TREE_TYPE (gnu_type); 2055 2056 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); 2057 2058 /* When not optimizing, look up the slot associated with the parameter 2059 and the dimension in the cache and create a new one on failure. 2060 Don't do this when the actual subtype needs debug info (this happens 2061 with -gnatD): in elaborate_expression_1, we create variables that 2062 hold the bounds, so caching attributes isn't very interesting and 2063 causes dependency issues between these variables and cached 2064 expressions. */ 2065 if (!optimize 2066 && Present (gnat_param) 2067 && !(Present (Actual_Subtype (gnat_param)) 2068 && Needs_Debug_Info (Actual_Subtype (gnat_param)))) 2069 { 2070 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa) 2071 if (pa->id == gnat_param && pa->dim == Dimension) 2072 break; 2073 2074 if (!pa) 2075 { 2076 pa = ggc_cleared_alloc<parm_attr_d> (); 2077 pa->id = gnat_param; 2078 pa->dim = Dimension; 2079 vec_safe_push (f_parm_attr_cache, pa); 2080 } 2081 } 2082 2083 /* Return the cached expression or build a new one. */ 2084 if (attribute == Attr_First) 2085 { 2086 if (pa && pa->first) 2087 { 2088 gnu_result = pa->first; 2089 break; 2090 } 2091 2092 gnu_result 2093 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); 2094 } 2095 2096 else if (attribute == Attr_Last) 2097 { 2098 if (pa && pa->last) 2099 { 2100 gnu_result = pa->last; 2101 break; 2102 } 2103 2104 gnu_result 2105 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))); 2106 } 2107 2108 else /* attribute == Attr_Range_Length || attribute == Attr_Length */ 2109 { 2110 if (pa && pa->length) 2111 { 2112 gnu_result = pa->length; 2113 break; 2114 } 2115 2116 gnu_result 2117 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)), 2118 gnu_result_type); 2119 } 2120 2121 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are 2122 handling. Note that these attributes could not have been used on 2123 an unconstrained array type. */ 2124 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); 2125 2126 /* Cache the expression we have just computed. Since we want to do it 2127 at run time, we force the use of a SAVE_EXPR and let the gimplifier 2128 create the temporary in the outermost binding level. We will make 2129 sure in Subprogram_Body_to_gnu that it is evaluated on all possible 2130 paths by forcing its evaluation on entry of the function. */ 2131 if (pa) 2132 { 2133 gnu_result 2134 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result); 2135 switch (attribute) 2136 { 2137 case Attr_First: 2138 pa->first = gnu_result; 2139 break; 2140 2141 case Attr_Last: 2142 pa->last = gnu_result; 2143 break; 2144 2145 case Attr_Length: 2146 case Attr_Range_Length: 2147 pa->length = gnu_result; 2148 break; 2149 2150 default: 2151 gcc_unreachable (); 2152 } 2153 } 2154 2155 /* Otherwise, evaluate it each time it is referenced. */ 2156 else 2157 switch (attribute) 2158 { 2159 case Attr_First: 2160 case Attr_Last: 2161 /* If we are dereferencing a pointer to unconstrained array, we 2162 need to capture the value because the pointed-to bounds may 2163 subsequently be released. */ 2164 if (unconstrained_ptr_deref) 2165 gnu_result 2166 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result); 2167 break; 2168 2169 case Attr_Length: 2170 case Attr_Range_Length: 2171 /* Set the source location onto the predicate of the condition 2172 but not if the expression is cached to avoid messing up the 2173 debug info. */ 2174 if (TREE_CODE (gnu_result) == COND_EXPR 2175 && EXPR_P (TREE_OPERAND (gnu_result, 0))) 2176 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0), 2177 gnat_node); 2178 break; 2179 2180 default: 2181 gcc_unreachable (); 2182 } 2183 2184 break; 2185 } 2186 2187 case Attr_Bit_Position: 2188 case Attr_Position: 2189 case Attr_First_Bit: 2190 case Attr_Last_Bit: 2191 case Attr_Bit: 2192 { 2193 HOST_WIDE_INT bitsize; 2194 HOST_WIDE_INT bitpos; 2195 tree gnu_offset; 2196 tree gnu_field_bitpos; 2197 tree gnu_field_offset; 2198 tree gnu_inner; 2199 machine_mode mode; 2200 int unsignedp, volatilep; 2201 2202 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2203 gnu_prefix = remove_conversions (gnu_prefix, true); 2204 prefix_unused = true; 2205 2206 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF, 2207 the result is 0. Don't allow 'Bit on a bare component, though. */ 2208 if (attribute == Attr_Bit 2209 && TREE_CODE (gnu_prefix) != COMPONENT_REF 2210 && TREE_CODE (gnu_prefix) != FIELD_DECL) 2211 { 2212 gnu_result = integer_zero_node; 2213 break; 2214 } 2215 2216 else 2217 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF 2218 || (attribute == Attr_Bit_Position 2219 && TREE_CODE (gnu_prefix) == FIELD_DECL)); 2220 2221 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset, 2222 &mode, &unsignedp, &volatilep, false); 2223 2224 if (TREE_CODE (gnu_prefix) == COMPONENT_REF) 2225 { 2226 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1)); 2227 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1)); 2228 2229 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0); 2230 TREE_CODE (gnu_inner) == COMPONENT_REF 2231 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1)); 2232 gnu_inner = TREE_OPERAND (gnu_inner, 0)) 2233 { 2234 gnu_field_bitpos 2235 = size_binop (PLUS_EXPR, gnu_field_bitpos, 2236 bit_position (TREE_OPERAND (gnu_inner, 1))); 2237 gnu_field_offset 2238 = size_binop (PLUS_EXPR, gnu_field_offset, 2239 byte_position (TREE_OPERAND (gnu_inner, 1))); 2240 } 2241 } 2242 else if (TREE_CODE (gnu_prefix) == FIELD_DECL) 2243 { 2244 gnu_field_bitpos = bit_position (gnu_prefix); 2245 gnu_field_offset = byte_position (gnu_prefix); 2246 } 2247 else 2248 { 2249 gnu_field_bitpos = bitsize_zero_node; 2250 gnu_field_offset = size_zero_node; 2251 } 2252 2253 switch (attribute) 2254 { 2255 case Attr_Position: 2256 gnu_result = gnu_field_offset; 2257 break; 2258 2259 case Attr_First_Bit: 2260 case Attr_Bit: 2261 gnu_result = size_int (bitpos % BITS_PER_UNIT); 2262 break; 2263 2264 case Attr_Last_Bit: 2265 gnu_result = bitsize_int (bitpos % BITS_PER_UNIT); 2266 gnu_result = size_binop (PLUS_EXPR, gnu_result, 2267 TYPE_SIZE (TREE_TYPE (gnu_prefix))); 2268 /* ??? Avoid a large unsigned result that will overflow when 2269 converted to the signed universal_integer. */ 2270 if (integer_zerop (gnu_result)) 2271 gnu_result = integer_minus_one_node; 2272 else 2273 gnu_result 2274 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node); 2275 break; 2276 2277 case Attr_Bit_Position: 2278 gnu_result = gnu_field_bitpos; 2279 break; 2280 } 2281 2282 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are 2283 handling. */ 2284 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix); 2285 break; 2286 } 2287 2288 case Attr_Min: 2289 case Attr_Max: 2290 { 2291 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node))); 2292 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node)))); 2293 2294 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2295 2296 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is 2297 a NaN so we implement the semantics of C99 f{min,max} to make it 2298 predictable in this case: if either operand is a NaN, the other 2299 is returned; if both operands are NaN's, a NaN is returned. */ 2300 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)) 2301 { 2302 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs); 2303 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs); 2304 tree t = builtin_decl_explicit (BUILT_IN_ISNAN); 2305 tree lhs_is_nan, rhs_is_nan; 2306 2307 /* If the operands have side-effects, they need to be evaluated 2308 only once in spite of the multiple references in the result. */ 2309 if (lhs_side_effects_p) 2310 gnu_lhs = gnat_protect_expr (gnu_lhs); 2311 if (rhs_side_effects_p) 2312 gnu_rhs = gnat_protect_expr (gnu_rhs); 2313 2314 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node, 2315 build_call_expr (t, 1, gnu_lhs), 2316 integer_zero_node); 2317 2318 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node, 2319 build_call_expr (t, 1, gnu_rhs), 2320 integer_zero_node); 2321 2322 gnu_result = build_binary_op (attribute == Attr_Min 2323 ? MIN_EXPR : MAX_EXPR, 2324 gnu_result_type, gnu_lhs, gnu_rhs); 2325 gnu_result = fold_build3 (COND_EXPR, gnu_result_type, 2326 rhs_is_nan, gnu_lhs, gnu_result); 2327 gnu_result = fold_build3 (COND_EXPR, gnu_result_type, 2328 lhs_is_nan, gnu_rhs, gnu_result); 2329 2330 /* If the operands have side-effects, they need to be evaluated 2331 before doing the tests above since the place they otherwise 2332 would end up being evaluated at run time could be wrong. */ 2333 if (lhs_side_effects_p) 2334 gnu_result 2335 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result); 2336 2337 if (rhs_side_effects_p) 2338 gnu_result 2339 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result); 2340 } 2341 else 2342 gnu_result = build_binary_op (attribute == Attr_Min 2343 ? MIN_EXPR : MAX_EXPR, 2344 gnu_result_type, gnu_lhs, gnu_rhs); 2345 } 2346 break; 2347 2348 case Attr_Passed_By_Reference: 2349 gnu_result = size_int (default_pass_by_ref (gnu_type) 2350 || must_pass_by_ref (gnu_type)); 2351 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2352 break; 2353 2354 case Attr_Component_Size: 2355 if (TREE_CODE (gnu_prefix) == COMPONENT_REF 2356 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))) 2357 gnu_prefix = TREE_OPERAND (gnu_prefix, 0); 2358 2359 gnu_prefix = maybe_implicit_deref (gnu_prefix); 2360 gnu_type = TREE_TYPE (gnu_prefix); 2361 2362 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) 2363 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type)))); 2364 2365 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE 2366 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) 2367 gnu_type = TREE_TYPE (gnu_type); 2368 2369 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); 2370 2371 /* Note this size cannot be self-referential. */ 2372 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type)); 2373 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2374 prefix_unused = true; 2375 break; 2376 2377 case Attr_Descriptor_Size: 2378 gnu_type = TREE_TYPE (gnu_prefix); 2379 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE); 2380 2381 /* What we want is the offset of the ARRAY field in the record 2382 that the thin pointer designates. */ 2383 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type); 2384 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type))); 2385 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2386 prefix_unused = true; 2387 break; 2388 2389 case Attr_Null_Parameter: 2390 /* This is just a zero cast to the pointer type for our prefix and 2391 dereferenced. */ 2392 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2393 gnu_result 2394 = build_unary_op (INDIRECT_REF, NULL_TREE, 2395 convert (build_pointer_type (gnu_result_type), 2396 integer_zero_node)); 2397 TREE_PRIVATE (gnu_result) = 1; 2398 break; 2399 2400 case Attr_Mechanism_Code: 2401 { 2402 Entity_Id gnat_obj = Entity (gnat_prefix); 2403 int code; 2404 2405 prefix_unused = true; 2406 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2407 if (Present (Expressions (gnat_node))) 2408 { 2409 int i = UI_To_Int (Intval (First (Expressions (gnat_node)))); 2410 2411 for (gnat_obj = First_Formal (gnat_obj); i > 1; 2412 i--, gnat_obj = Next_Formal (gnat_obj)) 2413 ; 2414 } 2415 2416 code = Mechanism (gnat_obj); 2417 if (code == Default) 2418 code = ((present_gnu_tree (gnat_obj) 2419 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj)) 2420 || ((TREE_CODE (get_gnu_tree (gnat_obj)) 2421 == PARM_DECL) 2422 && (DECL_BY_COMPONENT_PTR_P 2423 (get_gnu_tree (gnat_obj)))))) 2424 ? By_Reference : By_Copy); 2425 gnu_result = convert (gnu_result_type, size_int (- code)); 2426 } 2427 break; 2428 2429 case Attr_Model: 2430 /* We treat Model as identical to Machine. This is true for at least 2431 IEEE and some other nice floating-point systems. */ 2432 2433 /* ... fall through ... */ 2434 2435 case Attr_Machine: 2436 /* The trick is to force the compiler to store the result in memory so 2437 that we do not have extra precision used. But do this only when this 2438 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of 2439 the type is lower than that of the longest floating-point type. */ 2440 prefix_unused = true; 2441 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); 2442 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2443 gnu_result = convert (gnu_result_type, gnu_expr); 2444 2445 if (fp_arith_may_widen 2446 && TYPE_PRECISION (gnu_result_type) 2447 < TYPE_PRECISION (longest_float_type_node)) 2448 { 2449 tree rec_type = make_node (RECORD_TYPE); 2450 tree field 2451 = create_field_decl (get_identifier ("OBJ"), gnu_result_type, 2452 rec_type, NULL_TREE, NULL_TREE, 0, 0); 2453 tree rec_val, asm_expr; 2454 2455 finish_record_type (rec_type, field, 0, false); 2456 2457 rec_val = build_constructor_single (rec_type, field, gnu_result); 2458 rec_val = save_expr (rec_val); 2459 2460 asm_expr 2461 = build5 (ASM_EXPR, void_type_node, 2462 build_string (0, ""), 2463 tree_cons (build_tree_list (NULL_TREE, 2464 build_string (2, "=m")), 2465 rec_val, NULL_TREE), 2466 tree_cons (build_tree_list (NULL_TREE, 2467 build_string (1, "m")), 2468 rec_val, NULL_TREE), 2469 NULL_TREE, NULL_TREE); 2470 ASM_VOLATILE_P (asm_expr) = 1; 2471 2472 gnu_result 2473 = build_compound_expr (gnu_result_type, asm_expr, 2474 build_component_ref (rec_val, NULL_TREE, 2475 field, false)); 2476 } 2477 break; 2478 2479 case Attr_Deref: 2480 prefix_unused = true; 2481 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); 2482 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 2483 /* This can be a random address so build an alias-all pointer type. */ 2484 gnu_expr 2485 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode, 2486 true), 2487 gnu_expr); 2488 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr); 2489 break; 2490 2491 default: 2492 /* This abort means that we have an unimplemented attribute. */ 2493 gcc_unreachable (); 2494 } 2495 2496 /* If this is an attribute where the prefix was unused, force a use of it if 2497 it has a side-effect. But don't do it if the prefix is just an entity 2498 name. However, if an access check is needed, we must do it. See second 2499 example in AARM 11.6(5.e). */ 2500 if (prefix_unused 2501 && TREE_SIDE_EFFECTS (gnu_prefix) 2502 && !Is_Entity_Name (gnat_prefix)) 2503 gnu_result 2504 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result); 2505 2506 *gnu_result_type_p = gnu_result_type; 2507 return gnu_result; 2508} 2509 2510/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement, 2511 to a GCC tree, which is returned. */ 2512 2513static tree 2514Case_Statement_to_gnu (Node_Id gnat_node) 2515{ 2516 tree gnu_result, gnu_expr, gnu_label; 2517 Node_Id gnat_when; 2518 location_t end_locus; 2519 bool may_fallthru = false; 2520 2521 gnu_expr = gnat_to_gnu (Expression (gnat_node)); 2522 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); 2523 2524 /* The range of values in a case statement is determined by the rules in 2525 RM 5.4(7-9). In almost all cases, this range is represented by the Etype 2526 of the expression. One exception arises in the case of a simple name that 2527 is parenthesized. This still has the Etype of the name, but since it is 2528 not a name, para 7 does not apply, and we need to go to the base type. 2529 This is the only case where parenthesization affects the dynamic 2530 semantics (i.e. the range of possible values at run time that is covered 2531 by the others alternative). 2532 2533 Another exception is if the subtype of the expression is non-static. In 2534 that case, we also have to use the base type. */ 2535 if (Paren_Count (Expression (gnat_node)) != 0 2536 || !Is_OK_Static_Subtype (Underlying_Type 2537 (Etype (Expression (gnat_node))))) 2538 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); 2539 2540 /* We build a SWITCH_EXPR that contains the code with interspersed 2541 CASE_LABEL_EXPRs for each label. */ 2542 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus)) 2543 end_locus = input_location; 2544 gnu_label = create_artificial_label (end_locus); 2545 start_stmt_group (); 2546 2547 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node)); 2548 Present (gnat_when); 2549 gnat_when = Next_Non_Pragma (gnat_when)) 2550 { 2551 bool choices_added_p = false; 2552 Node_Id gnat_choice; 2553 2554 /* First compile all the different case choices for the current WHEN 2555 alternative. */ 2556 for (gnat_choice = First (Discrete_Choices (gnat_when)); 2557 Present (gnat_choice); 2558 gnat_choice = Next (gnat_choice)) 2559 { 2560 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; 2561 tree label = create_artificial_label (input_location); 2562 2563 switch (Nkind (gnat_choice)) 2564 { 2565 case N_Range: 2566 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice)); 2567 gnu_high = gnat_to_gnu (High_Bound (gnat_choice)); 2568 break; 2569 2570 case N_Subtype_Indication: 2571 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression 2572 (Constraint (gnat_choice)))); 2573 gnu_high = gnat_to_gnu (High_Bound (Range_Expression 2574 (Constraint (gnat_choice)))); 2575 break; 2576 2577 case N_Identifier: 2578 case N_Expanded_Name: 2579 /* This represents either a subtype range or a static value of 2580 some kind; Ekind says which. */ 2581 if (IN (Ekind (Entity (gnat_choice)), Type_Kind)) 2582 { 2583 tree gnu_type = get_unpadded_type (Entity (gnat_choice)); 2584 2585 gnu_low = TYPE_MIN_VALUE (gnu_type); 2586 gnu_high = TYPE_MAX_VALUE (gnu_type); 2587 break; 2588 } 2589 2590 /* ... fall through ... */ 2591 2592 case N_Character_Literal: 2593 case N_Integer_Literal: 2594 gnu_low = gnat_to_gnu (gnat_choice); 2595 break; 2596 2597 case N_Others_Choice: 2598 break; 2599 2600 default: 2601 gcc_unreachable (); 2602 } 2603 2604 /* Everything should be folded into constants at this point. */ 2605 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST); 2606 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST); 2607 2608 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label), 2609 gnat_choice); 2610 choices_added_p = true; 2611 } 2612 2613 /* This construct doesn't define a scope so we shouldn't push a binding 2614 level around the statement list. Except that we have always done so 2615 historically and this makes it possible to reduce stack usage. As a 2616 compromise, we keep doing it for case statements, for which this has 2617 never been problematic, but not for case expressions in Ada 2012. */ 2618 if (choices_added_p) 2619 { 2620 const bool is_case_expression 2621 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions); 2622 tree group 2623 = build_stmt_group (Statements (gnat_when), !is_case_expression); 2624 bool group_may_fallthru = block_may_fallthru (group); 2625 add_stmt (group); 2626 if (group_may_fallthru) 2627 { 2628 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label); 2629 SET_EXPR_LOCATION (stmt, end_locus); 2630 add_stmt (stmt); 2631 may_fallthru = true; 2632 } 2633 } 2634 } 2635 2636 /* Now emit a definition of the label the cases branch to, if any. */ 2637 if (may_fallthru) 2638 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label)); 2639 gnu_result = build3 (SWITCH_EXPR, TREE_TYPE (gnu_expr), gnu_expr, 2640 end_stmt_group (), NULL_TREE); 2641 2642 return gnu_result; 2643} 2644 2645/* Find out whether VAR is an iteration variable of an enclosing loop in the 2646 current function. If so, push a range_check_info structure onto the stack 2647 of this enclosing loop and return it. Otherwise, return NULL. */ 2648 2649static struct range_check_info_d * 2650push_range_check_info (tree var) 2651{ 2652 struct loop_info_d *iter = NULL; 2653 unsigned int i; 2654 2655 var = remove_conversions (var, false); 2656 2657 if (TREE_CODE (var) != VAR_DECL) 2658 return NULL; 2659 2660 if (decl_function_context (var) != current_function_decl) 2661 return NULL; 2662 2663 gcc_assert (vec_safe_length (gnu_loop_stack) > 0); 2664 2665 for (i = vec_safe_length (gnu_loop_stack) - 1; 2666 vec_safe_iterate (gnu_loop_stack, i, &iter); 2667 i--) 2668 if (var == iter->loop_var) 2669 break; 2670 2671 if (iter) 2672 { 2673 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> (); 2674 vec_safe_push (iter->checks, rci); 2675 return rci; 2676 } 2677 2678 return NULL; 2679} 2680 2681/* Return true if VAL (of type TYPE) can equal the minimum value if MAX is 2682 false, or the maximum value if MAX is true, of TYPE. */ 2683 2684static bool 2685can_equal_min_or_max_val_p (tree val, tree type, bool max) 2686{ 2687 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type)); 2688 2689 if (TREE_CODE (min_or_max_val) != INTEGER_CST) 2690 return true; 2691 2692 if (TREE_CODE (val) == NOP_EXPR) 2693 val = (max 2694 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))) 2695 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))); 2696 2697 if (TREE_CODE (val) != INTEGER_CST) 2698 return true; 2699 2700 if (max) 2701 return tree_int_cst_lt (val, min_or_max_val) == 0; 2702 else 2703 return tree_int_cst_lt (min_or_max_val, val) == 0; 2704} 2705 2706/* Return true if VAL (of type TYPE) can equal the minimum value of TYPE. 2707 If REVERSE is true, minimum value is taken as maximum value. */ 2708 2709static inline bool 2710can_equal_min_val_p (tree val, tree type, bool reverse) 2711{ 2712 return can_equal_min_or_max_val_p (val, type, reverse); 2713} 2714 2715/* Return true if VAL (of type TYPE) can equal the maximum value of TYPE. 2716 If REVERSE is true, maximum value is taken as minimum value. */ 2717 2718static inline bool 2719can_equal_max_val_p (tree val, tree type, bool reverse) 2720{ 2721 return can_equal_min_or_max_val_p (val, type, !reverse); 2722} 2723 2724/* Return true if VAL1 can be lower than VAL2. */ 2725 2726static bool 2727can_be_lower_p (tree val1, tree val2) 2728{ 2729 if (TREE_CODE (val1) == NOP_EXPR) 2730 val1 = TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val1, 0))); 2731 2732 if (TREE_CODE (val1) != INTEGER_CST) 2733 return true; 2734 2735 if (TREE_CODE (val2) == NOP_EXPR) 2736 val2 = TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val2, 0))); 2737 2738 if (TREE_CODE (val2) != INTEGER_CST) 2739 return true; 2740 2741 return tree_int_cst_lt (val1, val2); 2742} 2743 2744/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, 2745 to a GCC tree, which is returned. */ 2746 2747static tree 2748Loop_Statement_to_gnu (Node_Id gnat_node) 2749{ 2750 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); 2751 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> (); 2752 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, 2753 NULL_TREE, NULL_TREE, NULL_TREE); 2754 tree gnu_loop_label = create_artificial_label (input_location); 2755 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE; 2756 tree gnu_result; 2757 2758 /* Push the loop_info structure associated with the LOOP_STMT. */ 2759 vec_safe_push (gnu_loop_stack, gnu_loop_info); 2760 2761 /* Set location information for statement and end label. */ 2762 set_expr_location_from_node (gnu_loop_stmt, gnat_node); 2763 Sloc_to_locus (Sloc (End_Label (gnat_node)), 2764 &DECL_SOURCE_LOCATION (gnu_loop_label)); 2765 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; 2766 2767 /* Save the statement for later reuse. */ 2768 gnu_loop_info->stmt = gnu_loop_stmt; 2769 2770 /* Set the condition under which the loop must keep going. 2771 For the case "LOOP .... END LOOP;" the condition is always true. */ 2772 if (No (gnat_iter_scheme)) 2773 ; 2774 2775 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */ 2776 else if (Present (Condition (gnat_iter_scheme))) 2777 LOOP_STMT_COND (gnu_loop_stmt) 2778 = gnat_to_gnu (Condition (gnat_iter_scheme)); 2779 2780 /* Otherwise we have an iteration scheme and the condition is given by the 2781 bounds of the subtype of the iteration variable. */ 2782 else 2783 { 2784 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme); 2785 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec); 2786 Entity_Id gnat_type = Etype (gnat_loop_var); 2787 tree gnu_type = get_unpadded_type (gnat_type); 2788 tree gnu_base_type = get_base_type (gnu_type); 2789 tree gnu_one_node = convert (gnu_base_type, integer_one_node); 2790 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt; 2791 enum tree_code update_code, test_code, shift_code; 2792 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false; 2793 2794 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type)); 2795 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type)); 2796 2797 /* We must disable modulo reduction for the iteration variable, if any, 2798 in order for the loop comparison to be effective. */ 2799 if (reverse) 2800 { 2801 gnu_first = gnu_high; 2802 gnu_last = gnu_low; 2803 update_code = MINUS_NOMOD_EXPR; 2804 test_code = GE_EXPR; 2805 shift_code = PLUS_NOMOD_EXPR; 2806 } 2807 else 2808 { 2809 gnu_first = gnu_low; 2810 gnu_last = gnu_high; 2811 update_code = PLUS_NOMOD_EXPR; 2812 test_code = LE_EXPR; 2813 shift_code = MINUS_NOMOD_EXPR; 2814 } 2815 2816 /* We use two different strategies to translate the loop, depending on 2817 whether optimization is enabled. 2818 2819 If it is, we generate the canonical loop form expected by the loop 2820 optimizer and the loop vectorizer, which is the do-while form: 2821 2822 ENTRY_COND 2823 loop: 2824 TOP_UPDATE 2825 BODY 2826 BOTTOM_COND 2827 GOTO loop 2828 2829 This avoids an implicit dependency on loop header copying and makes 2830 it possible to turn BOTTOM_COND into an inequality test. 2831 2832 If optimization is disabled, loop header copying doesn't come into 2833 play and we try to generate the loop form with the fewer conditional 2834 branches. First, the default form, which is: 2835 2836 loop: 2837 TOP_COND 2838 BODY 2839 BOTTOM_UPDATE 2840 GOTO loop 2841 2842 It should catch most loops with constant ending point. Then, if we 2843 cannot, we try to generate the shifted form: 2844 2845 loop: 2846 TOP_COND 2847 TOP_UPDATE 2848 BODY 2849 GOTO loop 2850 2851 which should catch loops with constant starting point. Otherwise, if 2852 we cannot, we generate the fallback form: 2853 2854 ENTRY_COND 2855 loop: 2856 BODY 2857 BOTTOM_COND 2858 BOTTOM_UPDATE 2859 GOTO loop 2860 2861 which works in all cases. */ 2862 2863 if (optimize) 2864 { 2865 /* We can use the do-while form directly if GNU_FIRST-1 doesn't 2866 overflow. */ 2867 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)) 2868 ; 2869 2870 /* Otherwise, use the do-while form with the help of a special 2871 induction variable in the unsigned version of the base type 2872 or the unsigned version of the size type, whichever is the 2873 largest, in order to have wrap-around arithmetics for it. */ 2874 else 2875 { 2876 if (TYPE_PRECISION (gnu_base_type) 2877 > TYPE_PRECISION (size_type_node)) 2878 gnu_base_type 2879 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1); 2880 else 2881 gnu_base_type = size_type_node; 2882 2883 gnu_first = convert (gnu_base_type, gnu_first); 2884 gnu_last = convert (gnu_base_type, gnu_last); 2885 gnu_one_node = convert (gnu_base_type, integer_one_node); 2886 use_iv = true; 2887 } 2888 2889 gnu_first 2890 = build_binary_op (shift_code, gnu_base_type, gnu_first, 2891 gnu_one_node); 2892 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1; 2893 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1; 2894 } 2895 else 2896 { 2897 /* We can use the default form if GNU_LAST+1 doesn't overflow. */ 2898 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse)) 2899 ; 2900 2901 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor 2902 GNU_LAST-1 does. */ 2903 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse) 2904 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse)) 2905 { 2906 gnu_first 2907 = build_binary_op (shift_code, gnu_base_type, gnu_first, 2908 gnu_one_node); 2909 gnu_last 2910 = build_binary_op (shift_code, gnu_base_type, gnu_last, 2911 gnu_one_node); 2912 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1; 2913 } 2914 2915 /* Otherwise, use the fallback form. */ 2916 else 2917 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1; 2918 } 2919 2920 /* If we use the BOTTOM_COND, we can turn the test into an inequality 2921 test but we may have to add ENTRY_COND to protect the empty loop. */ 2922 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt)) 2923 { 2924 test_code = NE_EXPR; 2925 if (can_be_lower_p (gnu_high, gnu_low)) 2926 { 2927 gnu_cond_expr 2928 = build3 (COND_EXPR, void_type_node, 2929 build_binary_op (LE_EXPR, boolean_type_node, 2930 gnu_low, gnu_high), 2931 NULL_TREE, alloc_stmt_list ()); 2932 set_expr_location_from_node (gnu_cond_expr, gnat_loop_spec); 2933 } 2934 } 2935 2936 /* Open a new nesting level that will surround the loop to declare the 2937 iteration variable. */ 2938 start_stmt_group (); 2939 gnat_pushlevel (); 2940 2941 /* If we use the special induction variable, create it and set it to 2942 its initial value. Morever, the regular iteration variable cannot 2943 itself be initialized, lest the initial value wrapped around. */ 2944 if (use_iv) 2945 { 2946 gnu_loop_iv 2947 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var); 2948 add_stmt (gnu_stmt); 2949 gnu_first = NULL_TREE; 2950 } 2951 else 2952 gnu_loop_iv = NULL_TREE; 2953 2954 /* Declare the iteration variable and set it to its initial value. */ 2955 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1); 2956 if (DECL_BY_REF_P (gnu_loop_var)) 2957 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var); 2958 else if (use_iv) 2959 { 2960 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var)); 2961 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv); 2962 } 2963 gnu_loop_info->loop_var = gnu_loop_var; 2964 2965 /* Do all the arithmetics in the base type. */ 2966 gnu_loop_var = convert (gnu_base_type, gnu_loop_var); 2967 2968 /* Set either the top or bottom exit condition. */ 2969 if (use_iv) 2970 LOOP_STMT_COND (gnu_loop_stmt) 2971 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv, 2972 gnu_last); 2973 else 2974 LOOP_STMT_COND (gnu_loop_stmt) 2975 = build_binary_op (test_code, boolean_type_node, gnu_loop_var, 2976 gnu_last); 2977 2978 /* Set either the top or bottom update statement and give it the source 2979 location of the iteration for better coverage info. */ 2980 if (use_iv) 2981 { 2982 gnu_stmt 2983 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv, 2984 build_binary_op (update_code, gnu_base_type, 2985 gnu_loop_iv, gnu_one_node)); 2986 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme); 2987 append_to_statement_list (gnu_stmt, 2988 &LOOP_STMT_UPDATE (gnu_loop_stmt)); 2989 gnu_stmt 2990 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var, 2991 gnu_loop_iv); 2992 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme); 2993 append_to_statement_list (gnu_stmt, 2994 &LOOP_STMT_UPDATE (gnu_loop_stmt)); 2995 } 2996 else 2997 { 2998 gnu_stmt 2999 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var, 3000 build_binary_op (update_code, gnu_base_type, 3001 gnu_loop_var, gnu_one_node)); 3002 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme); 3003 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt; 3004 } 3005 } 3006 3007 /* If the loop was named, have the name point to this loop. In this case, 3008 the association is not a DECL node, but the end label of the loop. */ 3009 if (Present (Identifier (gnat_node))) 3010 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true); 3011 3012 /* Make the loop body into its own block, so any allocated storage will be 3013 released every iteration. This is needed for stack allocation. */ 3014 LOOP_STMT_BODY (gnu_loop_stmt) 3015 = build_stmt_group (Statements (gnat_node), true); 3016 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1; 3017 3018 /* If we have an iteration scheme, then we are in a statement group. Add 3019 the LOOP_STMT to it, finish it and make it the "loop". */ 3020 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme))) 3021 { 3022 struct range_check_info_d *rci; 3023 unsigned n_checks = vec_safe_length (gnu_loop_info->checks); 3024 unsigned int i; 3025 3026 /* First, if we have computed a small number of invariant conditions for 3027 range checks applied to the iteration variable, then initialize these 3028 conditions in front of the loop. Otherwise, leave them set to true. 3029 3030 ??? The heuristics need to be improved, by taking into account the 3031 following datapoints: 3032 - loop unswitching is disabled for big loops. The cap is the 3033 parameter PARAM_MAX_UNSWITCH_INSNS (50). 3034 - loop unswitching can only be applied a small number of times 3035 to a given loop. The cap is PARAM_MAX_UNSWITCH_LEVEL (3). 3036 - the front-end quickly generates useless or redundant checks 3037 that can be entirely optimized away in the end. */ 3038 if (1 <= n_checks && n_checks <= 4) 3039 for (i = 0; 3040 vec_safe_iterate (gnu_loop_info->checks, i, &rci); 3041 i++) 3042 { 3043 tree low_ok 3044 = rci->low_bound 3045 ? build_binary_op (GE_EXPR, boolean_type_node, 3046 convert (rci->type, gnu_low), 3047 rci->low_bound) 3048 : boolean_true_node; 3049 3050 tree high_ok 3051 = rci->high_bound 3052 ? build_binary_op (LE_EXPR, boolean_type_node, 3053 convert (rci->type, gnu_high), 3054 rci->high_bound) 3055 : boolean_true_node; 3056 3057 tree range_ok 3058 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, 3059 low_ok, high_ok); 3060 3061 TREE_OPERAND (rci->invariant_cond, 0) 3062 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok); 3063 3064 add_stmt_with_node_force (rci->invariant_cond, gnat_node); 3065 } 3066 3067 add_stmt (gnu_loop_stmt); 3068 gnat_poplevel (); 3069 gnu_loop_stmt = end_stmt_group (); 3070 } 3071 3072 /* If we have an outer COND_EXPR, that's our result and this loop is its 3073 "true" statement. Otherwise, the result is the LOOP_STMT. */ 3074 if (gnu_cond_expr) 3075 { 3076 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt; 3077 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1; 3078 gnu_result = gnu_cond_expr; 3079 } 3080 else 3081 gnu_result = gnu_loop_stmt; 3082 3083 gnu_loop_stack->pop (); 3084 3085 return gnu_result; 3086} 3087 3088/* This page implements a form of Named Return Value optimization modelled 3089 on the C++ optimization of the same name. The main difference is that 3090 we disregard any semantical considerations when applying it here, the 3091 counterpart being that we don't try to apply it to semantically loaded 3092 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set. 3093 3094 We consider a function body of the following GENERIC form: 3095 3096 return_type R1; 3097 [...] 3098 RETURN_EXPR [<retval> = ...] 3099 [...] 3100 RETURN_EXPR [<retval> = R1] 3101 [...] 3102 return_type Ri; 3103 [...] 3104 RETURN_EXPR [<retval> = ...] 3105 [...] 3106 RETURN_EXPR [<retval> = Ri] 3107 [...] 3108 3109 and we try to fulfill a simple criterion that would make it possible to 3110 replace one or several Ri variables with the RESULT_DECL of the function. 3111 3112 The first observation is that RETURN_EXPRs that don't directly reference 3113 any of the Ri variables on the RHS of their assignment are transparent wrt 3114 the optimization. This is because the Ri variables aren't addressable so 3115 any transformation applied to them doesn't affect the RHS; moreover, the 3116 assignment writes the full <retval> object so existing values are entirely 3117 discarded. 3118 3119 This property can be extended to some forms of RETURN_EXPRs that reference 3120 the Ri variables, for example CONSTRUCTORs, but isn't true in the general 3121 case, in particular when function calls are involved. 3122 3123 Therefore the algorithm is as follows: 3124 3125 1. Collect the list of candidates for a Named Return Value (Ri variables 3126 on the RHS of assignments of RETURN_EXPRs) as well as the list of the 3127 other expressions on the RHS of such assignments. 3128 3129 2. Prune the members of the first list (candidates) that are referenced 3130 by a member of the second list (expressions). 3131 3132 3. Extract a set of candidates with non-overlapping live ranges from the 3133 first list. These are the Named Return Values. 3134 3135 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the 3136 Named Return Values in the function with the RESULT_DECL. 3137 3138 If the function returns an unconstrained type, things are a bit different 3139 because the anonymous return object is allocated on the secondary stack 3140 and RESULT_DECL is only a pointer to it. Each return object can be of a 3141 different size and is allocated separately so we need not care about the 3142 aforementioned overlapping issues. Therefore, we don't collect the other 3143 expressions and skip step #2 in the algorithm. */ 3144 3145struct nrv_data 3146{ 3147 bitmap nrv; 3148 tree result; 3149 Node_Id gnat_ret; 3150 hash_set<tree> *visited; 3151}; 3152 3153/* Return true if T is a Named Return Value. */ 3154 3155static inline bool 3156is_nrv_p (bitmap nrv, tree t) 3157{ 3158 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t)); 3159} 3160 3161/* Helper function for walk_tree, used by finalize_nrv below. */ 3162 3163static tree 3164prune_nrv_r (tree *tp, int *walk_subtrees, void *data) 3165{ 3166 struct nrv_data *dp = (struct nrv_data *)data; 3167 tree t = *tp; 3168 3169 /* No need to walk into types or decls. */ 3170 if (IS_TYPE_OR_DECL_P (t)) 3171 *walk_subtrees = 0; 3172 3173 if (is_nrv_p (dp->nrv, t)) 3174 bitmap_clear_bit (dp->nrv, DECL_UID (t)); 3175 3176 return NULL_TREE; 3177} 3178 3179/* Prune Named Return Values in BLOCK and return true if there is still a 3180 Named Return Value in BLOCK or one of its sub-blocks. */ 3181 3182static bool 3183prune_nrv_in_block (bitmap nrv, tree block) 3184{ 3185 bool has_nrv = false; 3186 tree t; 3187 3188 /* First recurse on the sub-blocks. */ 3189 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t)) 3190 has_nrv |= prune_nrv_in_block (nrv, t); 3191 3192 /* Then make sure to keep at most one NRV per block. */ 3193 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t)) 3194 if (is_nrv_p (nrv, t)) 3195 { 3196 if (has_nrv) 3197 bitmap_clear_bit (nrv, DECL_UID (t)); 3198 else 3199 has_nrv = true; 3200 } 3201 3202 return has_nrv; 3203} 3204 3205/* Helper function for walk_tree, used by finalize_nrv below. */ 3206 3207static tree 3208finalize_nrv_r (tree *tp, int *walk_subtrees, void *data) 3209{ 3210 struct nrv_data *dp = (struct nrv_data *)data; 3211 tree t = *tp; 3212 3213 /* No need to walk into types. */ 3214 if (TYPE_P (t)) 3215 *walk_subtrees = 0; 3216 3217 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a 3218 nop, but differs from using NULL_TREE in that it indicates that we care 3219 about the value of the RESULT_DECL. */ 3220 else if (TREE_CODE (t) == RETURN_EXPR 3221 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR) 3222 { 3223 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1), init_expr; 3224 3225 /* If this is the temporary created for a return value with variable 3226 size in Call_to_gnu, we replace the RHS with the init expression. */ 3227 if (TREE_CODE (ret_val) == COMPOUND_EXPR 3228 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR 3229 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0) 3230 == TREE_OPERAND (ret_val, 1)) 3231 { 3232 init_expr = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1); 3233 ret_val = TREE_OPERAND (ret_val, 1); 3234 } 3235 else 3236 init_expr = NULL_TREE; 3237 3238 /* Strip useless conversions around the return value. */ 3239 if (gnat_useless_type_conversion (ret_val)) 3240 ret_val = TREE_OPERAND (ret_val, 0); 3241 3242 if (is_nrv_p (dp->nrv, ret_val)) 3243 { 3244 if (init_expr) 3245 TREE_OPERAND (TREE_OPERAND (t, 0), 1) = init_expr; 3246 else 3247 TREE_OPERAND (t, 0) = dp->result; 3248 } 3249 } 3250 3251 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL, 3252 if needed. */ 3253 else if (TREE_CODE (t) == DECL_EXPR 3254 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t))) 3255 { 3256 tree var = DECL_EXPR_DECL (t), init; 3257 3258 if (DECL_INITIAL (var)) 3259 { 3260 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result, 3261 DECL_INITIAL (var)); 3262 SET_EXPR_LOCATION (init, EXPR_LOCATION (t)); 3263 DECL_INITIAL (var) = NULL_TREE; 3264 } 3265 else 3266 init = build_empty_stmt (EXPR_LOCATION (t)); 3267 *tp = init; 3268 3269 /* Identify the NRV to the RESULT_DECL for debugging purposes. */ 3270 SET_DECL_VALUE_EXPR (var, dp->result); 3271 DECL_HAS_VALUE_EXPR_P (var) = 1; 3272 /* ??? Kludge to avoid an assertion failure during inlining. */ 3273 DECL_SIZE (var) = bitsize_unit_node; 3274 DECL_SIZE_UNIT (var) = size_one_node; 3275 } 3276 3277 /* And replace all uses of NRVs with the RESULT_DECL. */ 3278 else if (is_nrv_p (dp->nrv, t)) 3279 *tp = convert (TREE_TYPE (t), dp->result); 3280 3281 /* Avoid walking into the same tree more than once. Unfortunately, we 3282 can't just use walk_tree_without_duplicates because it would only 3283 call us for the first occurrence of NRVs in the function body. */ 3284 if (dp->visited->add (*tp)) 3285 *walk_subtrees = 0; 3286 3287 return NULL_TREE; 3288} 3289 3290/* Likewise, but used when the function returns an unconstrained type. */ 3291 3292static tree 3293finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) 3294{ 3295 struct nrv_data *dp = (struct nrv_data *)data; 3296 tree t = *tp; 3297 3298 /* No need to walk into types. */ 3299 if (TYPE_P (t)) 3300 *walk_subtrees = 0; 3301 3302 /* We need to see the DECL_EXPR of NRVs before any other references so we 3303 walk the body of BIND_EXPR before walking its variables. */ 3304 else if (TREE_CODE (t) == BIND_EXPR) 3305 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL); 3306 3307 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final 3308 return value built by the allocator instead of the whole construct. */ 3309 else if (TREE_CODE (t) == RETURN_EXPR 3310 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR) 3311 { 3312 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1); 3313 3314 /* This is the construct returned by the allocator. */ 3315 if (TREE_CODE (ret_val) == COMPOUND_EXPR 3316 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR) 3317 { 3318 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val))) 3319 ret_val 3320 = (*CONSTRUCTOR_ELTS (TREE_OPERAND (TREE_OPERAND (ret_val, 0), 3321 1)))[1].value; 3322 else 3323 ret_val = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1); 3324 } 3325 3326 /* Strip useless conversions around the return value. */ 3327 if (gnat_useless_type_conversion (ret_val) 3328 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR) 3329 ret_val = TREE_OPERAND (ret_val, 0); 3330 3331 /* Strip unpadding around the return value. */ 3332 if (TREE_CODE (ret_val) == COMPONENT_REF 3333 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0)))) 3334 ret_val = TREE_OPERAND (ret_val, 0); 3335 3336 /* Assign the new return value to the RESULT_DECL. */ 3337 if (is_nrv_p (dp->nrv, ret_val)) 3338 TREE_OPERAND (TREE_OPERAND (t, 0), 1) 3339 = TREE_OPERAND (DECL_INITIAL (ret_val), 0); 3340 } 3341 3342 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result 3343 into a new variable. */ 3344 else if (TREE_CODE (t) == DECL_EXPR 3345 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t))) 3346 { 3347 tree saved_current_function_decl = current_function_decl; 3348 tree var = DECL_EXPR_DECL (t); 3349 tree alloc, p_array, new_var, new_ret; 3350 vec<constructor_elt, va_gc> *v; 3351 vec_alloc (v, 2); 3352 3353 /* Create an artificial context to build the allocation. */ 3354 current_function_decl = decl_function_context (var); 3355 start_stmt_group (); 3356 gnat_pushlevel (); 3357 3358 /* This will return a COMPOUND_EXPR with the allocation in the first 3359 arm and the final return value in the second arm. */ 3360 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var), 3361 TREE_TYPE (dp->result), 3362 Procedure_To_Call (dp->gnat_ret), 3363 Storage_Pool (dp->gnat_ret), 3364 Empty, false); 3365 3366 /* The new variable is built as a reference to the allocated space. */ 3367 new_var 3368 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var), 3369 build_reference_type (TREE_TYPE (var))); 3370 DECL_BY_REFERENCE (new_var) = 1; 3371 3372 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc))) 3373 { 3374 /* The new initial value is a COMPOUND_EXPR with the allocation in 3375 the first arm and the value of P_ARRAY in the second arm. */ 3376 DECL_INITIAL (new_var) 3377 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var), 3378 TREE_OPERAND (alloc, 0), 3379 (*CONSTRUCTOR_ELTS (TREE_OPERAND (alloc, 1)))[0].value); 3380 3381 /* Build a modified CONSTRUCTOR that references NEW_VAR. */ 3382 p_array = TYPE_FIELDS (TREE_TYPE (alloc)); 3383 CONSTRUCTOR_APPEND_ELT (v, p_array, 3384 fold_convert (TREE_TYPE (p_array), new_var)); 3385 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array), 3386 (*CONSTRUCTOR_ELTS ( 3387 TREE_OPERAND (alloc, 1)))[1].value); 3388 new_ret = build_constructor (TREE_TYPE (alloc), v); 3389 } 3390 else 3391 { 3392 /* The new initial value is just the allocation. */ 3393 DECL_INITIAL (new_var) = alloc; 3394 new_ret = fold_convert (TREE_TYPE (alloc), new_var); 3395 } 3396 3397 gnat_pushdecl (new_var, Empty); 3398 3399 /* Destroy the artificial context and insert the new statements. */ 3400 gnat_zaplevel (); 3401 *tp = end_stmt_group (); 3402 current_function_decl = saved_current_function_decl; 3403 3404 /* Chain NEW_VAR immediately after VAR and ignore the latter. */ 3405 DECL_CHAIN (new_var) = DECL_CHAIN (var); 3406 DECL_CHAIN (var) = new_var; 3407 DECL_IGNORED_P (var) = 1; 3408 3409 /* Save the new return value and the dereference of NEW_VAR. */ 3410 DECL_INITIAL (var) 3411 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret, 3412 build1 (INDIRECT_REF, TREE_TYPE (var), new_var)); 3413 /* ??? Kludge to avoid messing up during inlining. */ 3414 DECL_CONTEXT (var) = NULL_TREE; 3415 } 3416 3417 /* And replace all uses of NRVs with the dereference of NEW_VAR. */ 3418 else if (is_nrv_p (dp->nrv, t)) 3419 *tp = TREE_OPERAND (DECL_INITIAL (t), 1); 3420 3421 /* Avoid walking into the same tree more than once. Unfortunately, we 3422 can't just use walk_tree_without_duplicates because it would only 3423 call us for the first occurrence of NRVs in the function body. */ 3424 if (dp->visited->add (*tp)) 3425 *walk_subtrees = 0; 3426 3427 return NULL_TREE; 3428} 3429 3430/* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap 3431 contains the candidates for Named Return Value and OTHER is a list of 3432 the other return values. GNAT_RET is a representative return node. */ 3433 3434static void 3435finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret) 3436{ 3437 struct cgraph_node *node; 3438 struct nrv_data data; 3439 walk_tree_fn func; 3440 unsigned int i; 3441 tree iter; 3442 3443 /* We shouldn't be applying the optimization to return types that we aren't 3444 allowed to manipulate freely. */ 3445 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl)))); 3446 3447 /* Prune the candidates that are referenced by other return values. */ 3448 data.nrv = nrv; 3449 data.result = NULL_TREE; 3450 data.visited = NULL; 3451 for (i = 0; vec_safe_iterate (other, i, &iter); i++) 3452 walk_tree_without_duplicates (&iter, prune_nrv_r, &data); 3453 if (bitmap_empty_p (nrv)) 3454 return; 3455 3456 /* Prune also the candidates that are referenced by nested functions. */ 3457 node = cgraph_node::get_create (fndecl); 3458 for (node = node->nested; node; node = node->next_nested) 3459 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r, 3460 &data); 3461 if (bitmap_empty_p (nrv)) 3462 return; 3463 3464 /* Extract a set of NRVs with non-overlapping live ranges. */ 3465 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl))) 3466 return; 3467 3468 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */ 3469 data.nrv = nrv; 3470 data.result = DECL_RESULT (fndecl); 3471 data.gnat_ret = gnat_ret; 3472 data.visited = new hash_set<tree>; 3473 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl))) 3474 func = finalize_nrv_unc_r; 3475 else 3476 func = finalize_nrv_r; 3477 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL); 3478 delete data.visited; 3479} 3480 3481/* Return true if RET_VAL can be used as a Named Return Value for the 3482 anonymous return object RET_OBJ. */ 3483 3484static bool 3485return_value_ok_for_nrv_p (tree ret_obj, tree ret_val) 3486{ 3487 if (TREE_CODE (ret_val) != VAR_DECL) 3488 return false; 3489 3490 if (TREE_THIS_VOLATILE (ret_val)) 3491 return false; 3492 3493 if (DECL_CONTEXT (ret_val) != current_function_decl) 3494 return false; 3495 3496 if (TREE_STATIC (ret_val)) 3497 return false; 3498 3499 if (TREE_ADDRESSABLE (ret_val)) 3500 return false; 3501 3502 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj)) 3503 return false; 3504 3505 return true; 3506} 3507 3508/* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around 3509 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR 3510 around RESULT_OBJ, which may be null in this case. */ 3511 3512static tree 3513build_return_expr (tree ret_obj, tree ret_val) 3514{ 3515 tree result_expr; 3516 3517 if (ret_val) 3518 { 3519 /* The gimplifier explicitly enforces the following invariant: 3520 3521 RETURN_EXPR 3522 | 3523 INIT_EXPR 3524 / \ 3525 / \ 3526 RET_OBJ ... 3527 3528 As a consequence, type consistency dictates that we use the type 3529 of the RET_OBJ as the operation type. */ 3530 tree operation_type = TREE_TYPE (ret_obj); 3531 3532 /* Convert the right operand to the operation type. Note that this is 3533 the transformation applied in the INIT_EXPR case of build_binary_op, 3534 with the assumption that the type cannot involve a placeholder. */ 3535 if (operation_type != TREE_TYPE (ret_val)) 3536 ret_val = convert (operation_type, ret_val); 3537 3538 /* We always can use an INIT_EXPR for the return object. */ 3539 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val); 3540 3541 /* If the function returns an aggregate type, find out whether this is 3542 a candidate for Named Return Value. If so, record it. Otherwise, 3543 if this is an expression of some kind, record it elsewhere. */ 3544 if (optimize 3545 && AGGREGATE_TYPE_P (operation_type) 3546 && !TYPE_IS_FAT_POINTER_P (operation_type) 3547 && TYPE_MODE (operation_type) == BLKmode 3548 && aggregate_value_p (operation_type, current_function_decl)) 3549 { 3550 /* Recognize the temporary created for a return value with variable 3551 size in Call_to_gnu. We want to eliminate it if possible. */ 3552 if (TREE_CODE (ret_val) == COMPOUND_EXPR 3553 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR 3554 && TREE_OPERAND (TREE_OPERAND (ret_val, 0), 0) 3555 == TREE_OPERAND (ret_val, 1)) 3556 ret_val = TREE_OPERAND (ret_val, 1); 3557 3558 /* Strip useless conversions around the return value. */ 3559 if (gnat_useless_type_conversion (ret_val)) 3560 ret_val = TREE_OPERAND (ret_val, 0); 3561 3562 /* Now apply the test to the return value. */ 3563 if (return_value_ok_for_nrv_p (ret_obj, ret_val)) 3564 { 3565 if (!f_named_ret_val) 3566 f_named_ret_val = BITMAP_GGC_ALLOC (); 3567 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val)); 3568 } 3569 3570 /* Note that we need not care about CONSTRUCTORs here, as they are 3571 totally transparent given the read-compose-write semantics of 3572 assignments from CONSTRUCTORs. */ 3573 else if (EXPR_P (ret_val)) 3574 vec_safe_push (f_other_ret_val, ret_val); 3575 } 3576 } 3577 else 3578 result_expr = ret_obj; 3579 3580 return build1 (RETURN_EXPR, void_type_node, result_expr); 3581} 3582 3583/* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We 3584 don't return anything. */ 3585 3586static void 3587Subprogram_Body_to_gnu (Node_Id gnat_node) 3588{ 3589 /* Defining identifier of a parameter to the subprogram. */ 3590 Entity_Id gnat_param; 3591 /* The defining identifier for the subprogram body. Note that if a 3592 specification has appeared before for this body, then the identifier 3593 occurring in that specification will also be a defining identifier and all 3594 the calls to this subprogram will point to that specification. */ 3595 Entity_Id gnat_subprog_id 3596 = (Present (Corresponding_Spec (gnat_node)) 3597 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node)); 3598 /* The FUNCTION_DECL node corresponding to the subprogram spec. */ 3599 tree gnu_subprog_decl; 3600 /* Its RESULT_DECL node. */ 3601 tree gnu_result_decl; 3602 /* Its FUNCTION_TYPE node. */ 3603 tree gnu_subprog_type; 3604 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */ 3605 tree gnu_cico_list; 3606 /* The entry in the CI_CO_LIST that represents a function return, if any. */ 3607 tree gnu_return_var_elmt = NULL_TREE; 3608 tree gnu_result; 3609 location_t locus; 3610 struct language_function *gnu_subprog_language; 3611 vec<parm_attr, va_gc> *cache; 3612 3613 /* If this is a generic object or if it has been eliminated, 3614 ignore it. */ 3615 if (Ekind (gnat_subprog_id) == E_Generic_Procedure 3616 || Ekind (gnat_subprog_id) == E_Generic_Function 3617 || Is_Eliminated (gnat_subprog_id)) 3618 return; 3619 3620 /* If this subprogram acts as its own spec, define it. Otherwise, just get 3621 the already-elaborated tree node. However, if this subprogram had its 3622 elaboration deferred, we will already have made a tree node for it. So 3623 treat it as not being defined in that case. Such a subprogram cannot 3624 have an address clause or a freeze node, so this test is safe, though it 3625 does disable some otherwise-useful error checking. */ 3626 gnu_subprog_decl 3627 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 3628 Acts_As_Spec (gnat_node) 3629 && !present_gnu_tree (gnat_subprog_id)); 3630 gnu_result_decl = DECL_RESULT (gnu_subprog_decl); 3631 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl); 3632 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); 3633 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node) 3634 gnu_return_var_elmt = gnu_cico_list; 3635 3636 /* If the function returns by invisible reference, make it explicit in the 3637 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */ 3638 if (TREE_ADDRESSABLE (gnu_subprog_type)) 3639 { 3640 TREE_TYPE (gnu_result_decl) 3641 = build_reference_type (TREE_TYPE (gnu_result_decl)); 3642 relayout_decl (gnu_result_decl); 3643 } 3644 3645 /* Set the line number in the decl to correspond to that of the body. */ 3646 Sloc_to_locus (Sloc (gnat_node), &locus); 3647 DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus; 3648 3649 /* Initialize the information structure for the function. */ 3650 allocate_struct_function (gnu_subprog_decl, false); 3651 gnu_subprog_language = ggc_cleared_alloc<language_function> (); 3652 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language; 3653 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_start_locus = locus; 3654 set_cfun (NULL); 3655 3656 begin_subprog_body (gnu_subprog_decl); 3657 3658 /* If there are copy-in/copy-out parameters, we need to ensure that they are 3659 properly copied out by the return statement. We do this by making a new 3660 block and converting any return into a goto to a label at the end of the 3661 block. */ 3662 if (gnu_cico_list) 3663 { 3664 tree gnu_return_var = NULL_TREE; 3665 3666 vec_safe_push (gnu_return_label_stack, 3667 create_artificial_label (input_location)); 3668 3669 start_stmt_group (); 3670 gnat_pushlevel (); 3671 3672 /* If this is a function with copy-in/copy-out parameters and which does 3673 not return by invisible reference, we also need a variable for the 3674 return value to be placed. */ 3675 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type)) 3676 { 3677 tree gnu_return_type 3678 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt)); 3679 3680 gnu_return_var 3681 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE, 3682 gnu_return_type, NULL_TREE, false, false, 3683 false, false, NULL, gnat_subprog_id); 3684 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var; 3685 } 3686 3687 vec_safe_push (gnu_return_var_stack, gnu_return_var); 3688 3689 /* See whether there are parameters for which we don't have a GCC tree 3690 yet. These must be Out parameters. Make a VAR_DECL for them and 3691 put it into TYPE_CI_CO_LIST, which must contain an empty entry too. 3692 We can match up the entries because TYPE_CI_CO_LIST is in the order 3693 of the parameters. */ 3694 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); 3695 Present (gnat_param); 3696 gnat_param = Next_Formal_With_Extras (gnat_param)) 3697 if (!present_gnu_tree (gnat_param)) 3698 { 3699 tree gnu_cico_entry = gnu_cico_list; 3700 tree gnu_decl; 3701 3702 /* Skip any entries that have been already filled in; they must 3703 correspond to In Out parameters. */ 3704 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry)) 3705 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry); 3706 3707 /* Do any needed dereferences for by-ref objects. */ 3708 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1); 3709 gcc_assert (DECL_P (gnu_decl)); 3710 if (DECL_BY_REF_P (gnu_decl)) 3711 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl); 3712 3713 /* Do any needed references for padded types. */ 3714 TREE_VALUE (gnu_cico_entry) 3715 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl); 3716 } 3717 } 3718 else 3719 vec_safe_push (gnu_return_label_stack, NULL_TREE); 3720 3721 /* Get a tree corresponding to the code for the subprogram. */ 3722 start_stmt_group (); 3723 gnat_pushlevel (); 3724 3725 process_decls (Declarations (gnat_node), Empty, Empty, true, true); 3726 3727 /* Generate the code of the subprogram itself. A return statement will be 3728 present and any Out parameters will be handled there. */ 3729 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); 3730 gnat_poplevel (); 3731 gnu_result = end_stmt_group (); 3732 3733 /* If we populated the parameter attributes cache, we need to make sure that 3734 the cached expressions are evaluated on all the possible paths leading to 3735 their uses. So we force their evaluation on entry of the function. */ 3736 cache = gnu_subprog_language->parm_attr_cache; 3737 if (cache) 3738 { 3739 struct parm_attr_d *pa; 3740 int i; 3741 3742 start_stmt_group (); 3743 3744 FOR_EACH_VEC_ELT (*cache, i, pa) 3745 { 3746 if (pa->first) 3747 add_stmt_with_node_force (pa->first, gnat_node); 3748 if (pa->last) 3749 add_stmt_with_node_force (pa->last, gnat_node); 3750 if (pa->length) 3751 add_stmt_with_node_force (pa->length, gnat_node); 3752 } 3753 3754 add_stmt (gnu_result); 3755 gnu_result = end_stmt_group (); 3756 3757 gnu_subprog_language->parm_attr_cache = NULL; 3758 } 3759 3760 /* If we are dealing with a return from an Ada procedure with parameters 3761 passed by copy-in/copy-out, we need to return a record containing the 3762 final values of these parameters. If the list contains only one entry, 3763 return just that entry though. 3764 3765 For a full description of the copy-in/copy-out parameter mechanism, see 3766 the part of the gnat_to_gnu_entity routine dealing with the translation 3767 of subprograms. 3768 3769 We need to make a block that contains the definition of that label and 3770 the copying of the return value. It first contains the function, then 3771 the label and copy statement. */ 3772 if (gnu_cico_list) 3773 { 3774 const Node_Id gnat_end_label 3775 = End_Label (Handled_Statement_Sequence (gnat_node)); 3776 3777 gnu_return_var_stack->pop (); 3778 3779 add_stmt (gnu_result); 3780 add_stmt (build1 (LABEL_EXPR, void_type_node, 3781 gnu_return_label_stack->last ())); 3782 3783 /* If this is a function which returns by invisible reference, the 3784 return value has already been dealt with at the return statements, 3785 so we only need to indirectly copy out the parameters. */ 3786 if (TREE_ADDRESSABLE (gnu_subprog_type)) 3787 { 3788 tree gnu_ret_deref 3789 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl); 3790 tree t; 3791 3792 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node); 3793 3794 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t)) 3795 { 3796 tree gnu_field_deref 3797 = build_component_ref (gnu_ret_deref, NULL_TREE, 3798 TREE_PURPOSE (t), true); 3799 gnu_result = build2 (MODIFY_EXPR, void_type_node, 3800 gnu_field_deref, TREE_VALUE (t)); 3801 add_stmt_with_node (gnu_result, gnat_end_label); 3802 } 3803 } 3804 3805 /* Otherwise, if this is a procedure or a function which does not return 3806 by invisible reference, we can do a direct block-copy out. */ 3807 else 3808 { 3809 tree gnu_retval; 3810 3811 if (list_length (gnu_cico_list) == 1) 3812 gnu_retval = TREE_VALUE (gnu_cico_list); 3813 else 3814 gnu_retval 3815 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type), 3816 gnu_cico_list); 3817 3818 gnu_result = build_return_expr (gnu_result_decl, gnu_retval); 3819 add_stmt_with_node (gnu_result, gnat_end_label); 3820 } 3821 3822 gnat_poplevel (); 3823 gnu_result = end_stmt_group (); 3824 } 3825 3826 gnu_return_label_stack->pop (); 3827 3828 /* Attempt setting the end_locus of our GCC body tree, typically a 3829 BIND_EXPR or STATEMENT_LIST, then the end_locus of our GCC subprogram 3830 declaration tree. */ 3831 set_end_locus_from_node (gnu_result, gnat_node); 3832 set_end_locus_from_node (gnu_subprog_decl, gnat_node); 3833 3834 /* On SEH targets, install an exception handler around the main entry 3835 point to catch unhandled exceptions. */ 3836 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node 3837 && targetm_common.except_unwind_info (&global_options) == UI_SEH) 3838 { 3839 tree t; 3840 tree etype; 3841 3842 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER), 3843 1, integer_zero_node); 3844 t = build_call_n_expr (unhandled_except_decl, 1, t); 3845 3846 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl); 3847 etype = tree_cons (NULL_TREE, etype, NULL_TREE); 3848 3849 t = build2 (CATCH_EXPR, void_type_node, etype, t); 3850 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result), 3851 gnu_result, t); 3852 } 3853 3854 end_subprog_body (gnu_result); 3855 3856 /* Finally annotate the parameters and disconnect the trees for parameters 3857 that we have turned into variables since they are now unusable. */ 3858 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id); 3859 Present (gnat_param); 3860 gnat_param = Next_Formal_With_Extras (gnat_param)) 3861 { 3862 tree gnu_param = get_gnu_tree (gnat_param); 3863 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL); 3864 3865 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE, 3866 DECL_BY_REF_P (gnu_param)); 3867 3868 if (is_var_decl) 3869 save_gnu_tree (gnat_param, NULL_TREE, false); 3870 } 3871 3872 /* Disconnect the variable created for the return value. */ 3873 if (gnu_return_var_elmt) 3874 TREE_VALUE (gnu_return_var_elmt) = void_type_node; 3875 3876 /* If the function returns an aggregate type and we have candidates for 3877 a Named Return Value, finalize the optimization. */ 3878 if (optimize && gnu_subprog_language->named_ret_val) 3879 { 3880 finalize_nrv (gnu_subprog_decl, 3881 gnu_subprog_language->named_ret_val, 3882 gnu_subprog_language->other_ret_val, 3883 gnu_subprog_language->gnat_ret); 3884 gnu_subprog_language->named_ret_val = NULL; 3885 gnu_subprog_language->other_ret_val = NULL; 3886 } 3887 3888 /* If this is an inlined external function that has been marked uninlinable, 3889 drop the body and stop there. Otherwise compile the body. */ 3890 if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl)) 3891 DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE; 3892 else 3893 rest_of_subprog_body_compilation (gnu_subprog_decl); 3894} 3895 3896/* Return true if GNAT_NODE requires atomic synchronization. */ 3897 3898static bool 3899atomic_sync_required_p (Node_Id gnat_node) 3900{ 3901 const Node_Id gnat_parent = Parent (gnat_node); 3902 Node_Kind kind; 3903 unsigned char attr_id; 3904 3905 /* First, scan the node to find the Atomic_Sync_Required flag. */ 3906 kind = Nkind (gnat_node); 3907 if (kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion) 3908 { 3909 gnat_node = Expression (gnat_node); 3910 kind = Nkind (gnat_node); 3911 } 3912 3913 switch (kind) 3914 { 3915 case N_Expanded_Name: 3916 case N_Explicit_Dereference: 3917 case N_Identifier: 3918 case N_Indexed_Component: 3919 case N_Selected_Component: 3920 if (!Atomic_Sync_Required (gnat_node)) 3921 return false; 3922 break; 3923 3924 default: 3925 return false; 3926 } 3927 3928 /* Then, scan the parent to find out cases where the flag is irrelevant. */ 3929 kind = Nkind (gnat_parent); 3930 switch (kind) 3931 { 3932 case N_Attribute_Reference: 3933 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent)); 3934 /* Do not mess up machine code insertions. */ 3935 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output) 3936 return false; 3937 break; 3938 3939 case N_Object_Renaming_Declaration: 3940 /* Do not generate a function call as a renamed object. */ 3941 return false; 3942 3943 default: 3944 break; 3945 } 3946 3947 return true; 3948} 3949 3950/* Create a temporary variable with PREFIX and TYPE, and return it. */ 3951 3952static tree 3953create_temporary (const char *prefix, tree type) 3954{ 3955 tree gnu_temp = create_var_decl (create_tmp_var_name (prefix), NULL_TREE, 3956 type, NULL_TREE, false, false, false, false, 3957 NULL, Empty); 3958 DECL_ARTIFICIAL (gnu_temp) = 1; 3959 DECL_IGNORED_P (gnu_temp) = 1; 3960 3961 return gnu_temp; 3962} 3963 3964/* Create a temporary variable with PREFIX and initialize it with GNU_INIT. 3965 Put the initialization statement into GNU_INIT_STMT and annotate it with 3966 the SLOC of GNAT_NODE. Return the temporary variable. */ 3967 3968static tree 3969create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt, 3970 Node_Id gnat_node) 3971{ 3972 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init)); 3973 3974 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init); 3975 set_expr_location_from_node (*gnu_init_stmt, gnat_node); 3976 3977 return gnu_temp; 3978} 3979 3980/* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call 3981 or an N_Procedure_Call_Statement, to a GCC tree, which is returned. 3982 GNU_RESULT_TYPE_P is a pointer to where we should place the result type. 3983 If GNU_TARGET is non-null, this must be a function call on the RHS of a 3984 N_Assignment_Statement and the result is to be placed into that object. 3985 If, in addition, ATOMIC_SYNC is true, then the assignment to GNU_TARGET 3986 requires atomic synchronization. */ 3987 3988static tree 3989Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, 3990 bool atomic_sync) 3991{ 3992 const bool function_call = (Nkind (gnat_node) == N_Function_Call); 3993 const bool returning_value = (function_call && !gnu_target); 3994 /* The GCC node corresponding to the GNAT subprogram name. This can either 3995 be a FUNCTION_DECL node if we are dealing with a standard subprogram call, 3996 or an indirect reference expression (an INDIRECT_REF node) pointing to a 3997 subprogram. */ 3998 tree gnu_subprog = gnat_to_gnu (Name (gnat_node)); 3999 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */ 4000 tree gnu_subprog_type = TREE_TYPE (gnu_subprog); 4001 /* The return type of the FUNCTION_TYPE. */ 4002 tree gnu_result_type = TREE_TYPE (gnu_subprog_type); 4003 tree gnu_subprog_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_subprog); 4004 vec<tree, va_gc> *gnu_actual_vec = NULL; 4005 tree gnu_name_list = NULL_TREE; 4006 tree gnu_stmt_list = NULL_TREE; 4007 tree gnu_after_list = NULL_TREE; 4008 tree gnu_retval = NULL_TREE; 4009 tree gnu_call, gnu_result; 4010 bool went_into_elab_proc = false; 4011 bool pushed_binding_level = false; 4012 Entity_Id gnat_formal; 4013 Node_Id gnat_actual; 4014 4015 gcc_assert (TREE_CODE (gnu_subprog_type) == FUNCTION_TYPE); 4016 4017 /* If we are calling a stubbed function, raise Program_Error, but Elaborate 4018 all our args first. */ 4019 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL && DECL_STUBBED_P (gnu_subprog)) 4020 { 4021 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called, 4022 gnat_node, N_Raise_Program_Error); 4023 4024 for (gnat_actual = First_Actual (gnat_node); 4025 Present (gnat_actual); 4026 gnat_actual = Next_Actual (gnat_actual)) 4027 add_stmt (gnat_to_gnu (gnat_actual)); 4028 4029 if (returning_value) 4030 { 4031 *gnu_result_type_p = gnu_result_type; 4032 return build1 (NULL_EXPR, gnu_result_type, call_expr); 4033 } 4034 4035 return call_expr; 4036 } 4037 4038 /* For a call to a nested function, check the inlining status. */ 4039 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL 4040 && decl_function_context (gnu_subprog)) 4041 check_inlining_for_nested_subprog (gnu_subprog); 4042 4043 /* The only way we can be making a call via an access type is if Name is an 4044 explicit dereference. In that case, get the list of formal args from the 4045 type the access type is pointing to. Otherwise, get the formals from the 4046 entity being called. */ 4047 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) 4048 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); 4049 else if (Nkind (Name (gnat_node)) == N_Attribute_Reference) 4050 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */ 4051 gnat_formal = Empty; 4052 else 4053 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); 4054 4055 /* The lifetime of the temporaries created for the call ends right after the 4056 return value is copied, so we can give them the scope of the elaboration 4057 routine at top level. */ 4058 if (!current_function_decl) 4059 { 4060 current_function_decl = get_elaboration_procedure (); 4061 went_into_elab_proc = true; 4062 } 4063 4064 /* First, create the temporary for the return value when: 4065 4066 1. There is no target and the function has copy-in/copy-out parameters, 4067 because we need to preserve the return value before copying back the 4068 parameters. 4069 4070 2. There is no target and this is not an object declaration, and the 4071 return type has variable size, because in these cases the gimplifier 4072 cannot create the temporary. 4073 4074 3. There is a target and it is a slice or an array with fixed size, 4075 and the return type has variable size, because the gimplifier 4076 doesn't handle these cases. 4077 4078 This must be done before we push a binding level around the call, since 4079 we will pop it before copying the return value. */ 4080 if (function_call 4081 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type)) 4082 || (!gnu_target 4083 && Nkind (Parent (gnat_node)) != N_Object_Declaration 4084 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST) 4085 || (gnu_target 4086 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF 4087 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE 4088 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target))) 4089 == INTEGER_CST)) 4090 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST))) 4091 gnu_retval = create_temporary ("R", gnu_result_type); 4092 4093 /* Create the list of the actual parameters as GCC expects it, namely a 4094 chain of TREE_LIST nodes in which the TREE_VALUE field of each node 4095 is an expression and the TREE_PURPOSE field is null. But skip Out 4096 parameters not passed by reference and that need not be copied in. */ 4097 for (gnat_actual = First_Actual (gnat_node); 4098 Present (gnat_actual); 4099 gnat_formal = Next_Formal_With_Extras (gnat_formal), 4100 gnat_actual = Next_Actual (gnat_actual)) 4101 { 4102 Entity_Id gnat_formal_type = Etype (gnat_formal); 4103 tree gnu_formal = present_gnu_tree (gnat_formal) 4104 ? get_gnu_tree (gnat_formal) : NULL_TREE; 4105 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type); 4106 const bool is_true_formal_parm 4107 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL; 4108 const bool is_by_ref_formal_parm 4109 = is_true_formal_parm 4110 && (DECL_BY_REF_P (gnu_formal) 4111 || DECL_BY_COMPONENT_PTR_P (gnu_formal)); 4112 /* In the Out or In Out case, we must suppress conversions that yield 4113 an lvalue but can nevertheless cause the creation of a temporary, 4114 because we need the real object in this case, either to pass its 4115 address if it's passed by reference or as target of the back copy 4116 done after the call if it uses the copy-in/copy-out mechanism. 4117 We do it in the In case too, except for an unchecked conversion 4118 to an elementary type or a constrained composite type because it 4119 alone can cause the actual to be misaligned and the addressability 4120 test is applied to the real object. */ 4121 const bool suppress_type_conversion 4122 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion 4123 && (Ekind (gnat_formal) != E_In_Parameter 4124 || (Is_Composite_Type (Underlying_Type (gnat_formal_type)) 4125 && !Is_Constrained (Underlying_Type (gnat_formal_type))))) 4126 || (Nkind (gnat_actual) == N_Type_Conversion 4127 && Is_Composite_Type (Underlying_Type (gnat_formal_type)))); 4128 Node_Id gnat_name = suppress_type_conversion 4129 ? Expression (gnat_actual) : gnat_actual; 4130 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type; 4131 tree gnu_actual; 4132 4133 /* If it's possible we may need to use this expression twice, make sure 4134 that any side-effects are handled via SAVE_EXPRs; likewise if we need 4135 to force side-effects before the call. 4136 ??? This is more conservative than we need since we don't need to do 4137 this for pass-by-ref with no conversion. */ 4138 if (Ekind (gnat_formal) != E_In_Parameter) 4139 gnu_name = gnat_stabilize_reference (gnu_name, true, NULL); 4140 4141 /* If we are passing a non-addressable parameter by reference, pass the 4142 address of a copy. In the Out or In Out case, set up to copy back 4143 out after the call. */ 4144 if (is_by_ref_formal_parm 4145 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name))) 4146 && !addressable_p (gnu_name, gnu_name_type)) 4147 { 4148 bool in_param = (Ekind (gnat_formal) == E_In_Parameter); 4149 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt; 4150 4151 /* Do not issue warnings for CONSTRUCTORs since this is not a copy 4152 but sort of an instantiation for them. */ 4153 if (TREE_CODE (gnu_name) == CONSTRUCTOR) 4154 ; 4155 4156 /* If the type is passed by reference, a copy is not allowed. */ 4157 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type)) 4158 post_error ("misaligned actual cannot be passed by reference", 4159 gnat_actual); 4160 4161 /* For users of Starlet we issue a warning because the interface 4162 apparently assumes that by-ref parameters outlive the procedure 4163 invocation. The code still will not work as intended, but we 4164 cannot do much better since low-level parts of the back-end 4165 would allocate temporaries at will because of the misalignment 4166 if we did not do so here. */ 4167 else if (Is_Valued_Procedure (Entity (Name (gnat_node)))) 4168 { 4169 post_error 4170 ("?possible violation of implicit assumption", gnat_actual); 4171 post_error_ne 4172 ("?made by pragma Import_Valued_Procedure on &", gnat_actual, 4173 Entity (Name (gnat_node))); 4174 post_error_ne ("?because of misalignment of &", gnat_actual, 4175 gnat_formal); 4176 } 4177 4178 /* If the actual type of the object is already the nominal type, 4179 we have nothing to do, except if the size is self-referential 4180 in which case we'll remove the unpadding below. */ 4181 if (TREE_TYPE (gnu_name) == gnu_name_type 4182 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type))) 4183 ; 4184 4185 /* Otherwise remove the unpadding from all the objects. */ 4186 else if (TREE_CODE (gnu_name) == COMPONENT_REF 4187 && TYPE_IS_PADDING_P 4188 (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))) 4189 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0); 4190 4191 /* Otherwise convert to the nominal type of the object if needed. 4192 There are several cases in which we need to make the temporary 4193 using this type instead of the actual type of the object when 4194 they are distinct, because the expectations of the callee would 4195 otherwise not be met: 4196 - if it's a justified modular type, 4197 - if the actual type is a smaller form of it, 4198 - if it's a smaller form of the actual type. */ 4199 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE 4200 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type) 4201 || smaller_form_type_p (TREE_TYPE (gnu_name), 4202 gnu_name_type))) 4203 || (INTEGRAL_TYPE_P (gnu_name_type) 4204 && smaller_form_type_p (gnu_name_type, 4205 TREE_TYPE (gnu_name)))) 4206 gnu_name = convert (gnu_name_type, gnu_name); 4207 4208 /* If this is an In Out or Out parameter and we're returning a value, 4209 we need to create a temporary for the return value because we must 4210 preserve it before copying back at the very end. */ 4211 if (!in_param && returning_value && !gnu_retval) 4212 gnu_retval = create_temporary ("R", gnu_result_type); 4213 4214 /* If we haven't pushed a binding level, push a new one. This will 4215 narrow the lifetime of the temporary we are about to make as much 4216 as possible. The drawback is that we'd need to create a temporary 4217 for the return value, if any (see comment before the loop). So do 4218 it only when this temporary was already created just above. */ 4219 if (!pushed_binding_level && !(in_param && returning_value)) 4220 { 4221 start_stmt_group (); 4222 gnat_pushlevel (); 4223 pushed_binding_level = true; 4224 } 4225 4226 /* Create an explicit temporary holding the copy. */ 4227 gnu_temp 4228 = create_init_temporary ("A", gnu_name, &gnu_stmt, gnat_actual); 4229 4230 /* But initialize it on the fly like for an implicit temporary as 4231 we aren't necessarily having a statement list. */ 4232 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt, 4233 gnu_temp); 4234 4235 /* Set up to move the copy back to the original if needed. */ 4236 if (!in_param) 4237 { 4238 /* If the original is a COND_EXPR whose first arm isn't meant to 4239 be further used, just deal with the second arm. This is very 4240 likely the conditional expression built for a check. */ 4241 if (TREE_CODE (gnu_orig) == COND_EXPR 4242 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR 4243 && integer_zerop 4244 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1))) 4245 gnu_orig = TREE_OPERAND (gnu_orig, 2); 4246 4247 gnu_stmt 4248 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp); 4249 set_expr_location_from_node (gnu_stmt, gnat_node); 4250 4251 append_to_statement_list (gnu_stmt, &gnu_after_list); 4252 } 4253 } 4254 4255 /* Start from the real object and build the actual. */ 4256 gnu_actual = gnu_name; 4257 4258 /* If this is an atomic access of an In or In Out parameter for which 4259 synchronization is required, build the atomic load. */ 4260 if (is_true_formal_parm 4261 && !is_by_ref_formal_parm 4262 && Ekind (gnat_formal) != E_Out_Parameter 4263 && atomic_sync_required_p (gnat_actual)) 4264 gnu_actual = build_atomic_load (gnu_actual); 4265 4266 /* If this was a procedure call, we may not have removed any padding. 4267 So do it here for the part we will use as an input, if any. */ 4268 if (Ekind (gnat_formal) != E_Out_Parameter 4269 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) 4270 gnu_actual 4271 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual); 4272 4273 /* Put back the conversion we suppressed above in the computation of the 4274 real object. And even if we didn't suppress any conversion there, we 4275 may have suppressed a conversion to the Etype of the actual earlier, 4276 since the parent is a procedure call, so put it back here. */ 4277 if (suppress_type_conversion 4278 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion) 4279 gnu_actual 4280 = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)), 4281 gnu_actual, No_Truncation (gnat_actual)); 4282 else 4283 gnu_actual 4284 = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual); 4285 4286 /* Make sure that the actual is in range of the formal's type. */ 4287 if (Ekind (gnat_formal) != E_Out_Parameter 4288 && Do_Range_Check (gnat_actual)) 4289 gnu_actual 4290 = emit_range_check (gnu_actual, gnat_formal_type, gnat_actual); 4291 4292 /* Unless this is an In parameter, we must remove any justified modular 4293 building from GNU_NAME to get an lvalue. */ 4294 if (Ekind (gnat_formal) != E_In_Parameter 4295 && TREE_CODE (gnu_name) == CONSTRUCTOR 4296 && TREE_CODE (TREE_TYPE (gnu_name)) == RECORD_TYPE 4297 && TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (gnu_name))) 4298 gnu_name 4299 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_name))), gnu_name); 4300 4301 /* First see if the parameter is passed by reference. */ 4302 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal)) 4303 { 4304 if (Ekind (gnat_formal) != E_In_Parameter) 4305 { 4306 /* In Out or Out parameters passed by reference don't use the 4307 copy-in/copy-out mechanism so the address of the real object 4308 must be passed to the function. */ 4309 gnu_actual = gnu_name; 4310 4311 /* If we have a padded type, be sure we've removed padding. */ 4312 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))) 4313 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)), 4314 gnu_actual); 4315 4316 /* If we have the constructed subtype of an aliased object 4317 with an unconstrained nominal subtype, the type of the 4318 actual includes the template, although it is formally 4319 constrained. So we need to convert it back to the real 4320 constructed subtype to retrieve the constrained part 4321 and takes its address. */ 4322 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE 4323 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual)) 4324 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual)) 4325 && Is_Array_Type (Underlying_Type (Etype (gnat_actual)))) 4326 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), 4327 gnu_actual); 4328 } 4329 4330 /* There is no need to convert the actual to the formal's type before 4331 taking its address. The only exception is for unconstrained array 4332 types because of the way we build fat pointers. */ 4333 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE) 4334 { 4335 /* Put back a view conversion for In Out or Out parameters. */ 4336 if (Ekind (gnat_formal) != E_In_Parameter) 4337 gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)), 4338 gnu_actual); 4339 gnu_actual = convert (gnu_formal_type, gnu_actual); 4340 } 4341 4342 /* The symmetry of the paths to the type of an entity is broken here 4343 since arguments don't know that they will be passed by ref. */ 4344 gnu_formal_type = TREE_TYPE (gnu_formal); 4345 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); 4346 } 4347 4348 /* Then see if the parameter is an array passed to a foreign convention 4349 subprogram. */ 4350 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal)) 4351 { 4352 gnu_formal_type = TREE_TYPE (gnu_formal); 4353 gnu_actual = maybe_implicit_deref (gnu_actual); 4354 gnu_actual = maybe_unconstrained_array (gnu_actual); 4355 4356 if (TYPE_IS_PADDING_P (gnu_formal_type)) 4357 { 4358 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type)); 4359 gnu_actual = convert (gnu_formal_type, gnu_actual); 4360 } 4361 4362 /* Take the address of the object and convert to the proper pointer 4363 type. We'd like to actually compute the address of the beginning 4364 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a 4365 possibility that the ARRAY_REF might return a constant and we'd be 4366 getting the wrong address. Neither approach is exactly correct, 4367 but this is the most likely to work in all cases. */ 4368 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); 4369 } 4370 4371 /* Otherwise the parameter is passed by copy. */ 4372 else 4373 { 4374 tree gnu_size; 4375 4376 if (Ekind (gnat_formal) != E_In_Parameter) 4377 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list); 4378 4379 /* If we didn't create a PARM_DECL for the formal, this means that 4380 it is an Out parameter not passed by reference and that need not 4381 be copied in. In this case, the value of the actual need not be 4382 read. However, we still need to make sure that its side-effects 4383 are evaluated before the call, so we evaluate its address. */ 4384 if (!is_true_formal_parm) 4385 { 4386 if (TREE_SIDE_EFFECTS (gnu_name)) 4387 { 4388 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name); 4389 append_to_statement_list (addr, &gnu_stmt_list); 4390 } 4391 continue; 4392 } 4393 4394 gnu_actual = convert (gnu_formal_type, gnu_actual); 4395 4396 /* If this is 'Null_Parameter, pass a zero even though we are 4397 dereferencing it. */ 4398 if (TREE_CODE (gnu_actual) == INDIRECT_REF 4399 && TREE_PRIVATE (gnu_actual) 4400 && (gnu_size = TYPE_SIZE (TREE_TYPE (gnu_actual))) 4401 && TREE_CODE (gnu_size) == INTEGER_CST 4402 && compare_tree_int (gnu_size, BITS_PER_WORD) <= 0) 4403 gnu_actual 4404 = unchecked_convert (DECL_ARG_TYPE (gnu_formal), 4405 convert (gnat_type_for_size 4406 (TREE_INT_CST_LOW (gnu_size), 1), 4407 integer_zero_node), 4408 false); 4409 else 4410 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual); 4411 } 4412 4413 vec_safe_push (gnu_actual_vec, gnu_actual); 4414 } 4415 4416 gnu_call 4417 = build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec); 4418 set_expr_location_from_node (gnu_call, gnat_node); 4419 4420 /* If we have created a temporary for the return value, initialize it. */ 4421 if (gnu_retval) 4422 { 4423 tree gnu_stmt 4424 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call); 4425 set_expr_location_from_node (gnu_stmt, gnat_node); 4426 append_to_statement_list (gnu_stmt, &gnu_stmt_list); 4427 gnu_call = gnu_retval; 4428 } 4429 4430 /* If this is a subprogram with copy-in/copy-out parameters, we need to 4431 unpack the valued returned from the function into the In Out or Out 4432 parameters. We deal with the function return (if this is an Ada 4433 function) below. */ 4434 if (TYPE_CI_CO_LIST (gnu_subprog_type)) 4435 { 4436 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/ 4437 copy-out parameters. */ 4438 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type); 4439 const int length = list_length (gnu_cico_list); 4440 4441 /* The call sequence must contain one and only one call, even though the 4442 function is pure. Save the result into a temporary if needed. */ 4443 if (length > 1) 4444 { 4445 if (!gnu_retval) 4446 { 4447 tree gnu_stmt; 4448 /* If we haven't pushed a binding level, push a new one. This 4449 will narrow the lifetime of the temporary we are about to 4450 make as much as possible. */ 4451 if (!pushed_binding_level) 4452 { 4453 start_stmt_group (); 4454 gnat_pushlevel (); 4455 pushed_binding_level = true; 4456 } 4457 gnu_call 4458 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node); 4459 append_to_statement_list (gnu_stmt, &gnu_stmt_list); 4460 } 4461 4462 gnu_name_list = nreverse (gnu_name_list); 4463 } 4464 4465 /* The first entry is for the actual return value if this is a 4466 function, so skip it. */ 4467 if (function_call) 4468 gnu_cico_list = TREE_CHAIN (gnu_cico_list); 4469 4470 if (Nkind (Name (gnat_node)) == N_Explicit_Dereference) 4471 gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node))); 4472 else 4473 gnat_formal = First_Formal_With_Extras (Entity (Name (gnat_node))); 4474 4475 for (gnat_actual = First_Actual (gnat_node); 4476 Present (gnat_actual); 4477 gnat_formal = Next_Formal_With_Extras (gnat_formal), 4478 gnat_actual = Next_Actual (gnat_actual)) 4479 /* If we are dealing with a copy-in/copy-out parameter, we must 4480 retrieve its value from the record returned in the call. */ 4481 if (!(present_gnu_tree (gnat_formal) 4482 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL 4483 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) 4484 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))) 4485 && Ekind (gnat_formal) != E_In_Parameter) 4486 { 4487 /* Get the value to assign to this Out or In Out parameter. It is 4488 either the result of the function if there is only a single such 4489 parameter or the appropriate field from the record returned. */ 4490 tree gnu_result 4491 = length == 1 4492 ? gnu_call 4493 : build_component_ref (gnu_call, NULL_TREE, 4494 TREE_PURPOSE (gnu_cico_list), false); 4495 4496 /* If the actual is a conversion, get the inner expression, which 4497 will be the real destination, and convert the result to the 4498 type of the actual parameter. */ 4499 tree gnu_actual 4500 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list)); 4501 4502 /* If the result is a padded type, remove the padding. */ 4503 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) 4504 gnu_result 4505 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), 4506 gnu_result); 4507 4508 /* If the actual is a type conversion, the real target object is 4509 denoted by the inner Expression and we need to convert the 4510 result to the associated type. 4511 We also need to convert our gnu assignment target to this type 4512 if the corresponding GNU_NAME was constructed from the GNAT 4513 conversion node and not from the inner Expression. */ 4514 if (Nkind (gnat_actual) == N_Type_Conversion) 4515 { 4516 gnu_result 4517 = convert_with_check 4518 (Etype (Expression (gnat_actual)), gnu_result, 4519 Do_Overflow_Check (gnat_actual), 4520 Do_Range_Check (Expression (gnat_actual)), 4521 Float_Truncate (gnat_actual), gnat_actual); 4522 4523 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal)))) 4524 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual); 4525 } 4526 4527 /* Unchecked conversions as actuals for Out parameters are not 4528 allowed in user code because they are not variables, but do 4529 occur in front-end expansions. The associated GNU_NAME is 4530 always obtained from the inner expression in such cases. */ 4531 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion) 4532 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual), 4533 gnu_result, 4534 No_Truncation (gnat_actual)); 4535 else 4536 { 4537 if (Do_Range_Check (gnat_actual)) 4538 gnu_result 4539 = emit_range_check (gnu_result, Etype (gnat_actual), 4540 gnat_actual); 4541 4542 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual))) 4543 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result))))) 4544 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result); 4545 } 4546 4547 if (atomic_sync_required_p (gnat_actual)) 4548 gnu_result = build_atomic_store (gnu_actual, gnu_result); 4549 else 4550 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, 4551 gnu_actual, gnu_result); 4552 set_expr_location_from_node (gnu_result, gnat_node); 4553 append_to_statement_list (gnu_result, &gnu_stmt_list); 4554 gnu_cico_list = TREE_CHAIN (gnu_cico_list); 4555 gnu_name_list = TREE_CHAIN (gnu_name_list); 4556 } 4557 } 4558 4559 /* If this is a function call, the result is the call expression unless a 4560 target is specified, in which case we copy the result into the target 4561 and return the assignment statement. */ 4562 if (function_call) 4563 { 4564 /* If this is a function with copy-in/copy-out parameters, extract the 4565 return value from it and update the return type. */ 4566 if (TYPE_CI_CO_LIST (gnu_subprog_type)) 4567 { 4568 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type); 4569 gnu_call = build_component_ref (gnu_call, NULL_TREE, 4570 TREE_PURPOSE (gnu_elmt), false); 4571 gnu_result_type = TREE_TYPE (gnu_call); 4572 } 4573 4574 /* If the function returns an unconstrained array or by direct reference, 4575 we have to dereference the pointer. */ 4576 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type) 4577 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)) 4578 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call); 4579 4580 if (gnu_target) 4581 { 4582 Node_Id gnat_parent = Parent (gnat_node); 4583 enum tree_code op_code; 4584 4585 /* If range check is needed, emit code to generate it. */ 4586 if (Do_Range_Check (gnat_node)) 4587 gnu_call 4588 = emit_range_check (gnu_call, Etype (Name (gnat_parent)), 4589 gnat_parent); 4590 4591 /* ??? If the return type has variable size, then force the return 4592 slot optimization as we would not be able to create a temporary. 4593 Likewise if it was unconstrained as we would copy too much data. 4594 That's what has been done historically. */ 4595 if (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST 4596 || (TYPE_IS_PADDING_P (gnu_result_type) 4597 && CONTAINS_PLACEHOLDER_P 4598 (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_result_type)))))) 4599 op_code = INIT_EXPR; 4600 else 4601 op_code = MODIFY_EXPR; 4602 4603 if (atomic_sync) 4604 gnu_call = build_atomic_store (gnu_target, gnu_call); 4605 else 4606 gnu_call 4607 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call); 4608 set_expr_location_from_node (gnu_call, gnat_parent); 4609 append_to_statement_list (gnu_call, &gnu_stmt_list); 4610 } 4611 else 4612 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); 4613 } 4614 4615 /* Otherwise, if this is a procedure call statement without copy-in/copy-out 4616 parameters, the result is just the call statement. */ 4617 else if (!TYPE_CI_CO_LIST (gnu_subprog_type)) 4618 append_to_statement_list (gnu_call, &gnu_stmt_list); 4619 4620 /* Finally, add the copy back statements, if any. */ 4621 append_to_statement_list (gnu_after_list, &gnu_stmt_list); 4622 4623 if (went_into_elab_proc) 4624 current_function_decl = NULL_TREE; 4625 4626 /* If we have pushed a binding level, pop it and finish up the enclosing 4627 statement group. */ 4628 if (pushed_binding_level) 4629 { 4630 add_stmt (gnu_stmt_list); 4631 gnat_poplevel (); 4632 gnu_result = end_stmt_group (); 4633 } 4634 4635 /* Otherwise, retrieve the statement list, if any. */ 4636 else if (gnu_stmt_list) 4637 gnu_result = gnu_stmt_list; 4638 4639 /* Otherwise, just return the call expression. */ 4640 else 4641 return gnu_call; 4642 4643 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it. 4644 But first simplify if we have only one statement in the list. */ 4645 if (returning_value) 4646 { 4647 tree first = expr_first (gnu_result), last = expr_last (gnu_result); 4648 if (first == last) 4649 gnu_result = first; 4650 gnu_result 4651 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call); 4652 } 4653 4654 return gnu_result; 4655} 4656 4657/* Subroutine of gnat_to_gnu to translate gnat_node, an 4658 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */ 4659 4660static tree 4661Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node) 4662{ 4663 tree gnu_jmpsave_decl = NULL_TREE; 4664 tree gnu_jmpbuf_decl = NULL_TREE; 4665 /* If just annotating, ignore all EH and cleanups. */ 4666 bool gcc_zcx = (!type_annotate_only 4667 && Present (Exception_Handlers (gnat_node)) 4668 && Exception_Mechanism == Back_End_Exceptions); 4669 bool setjmp_longjmp 4670 = (!type_annotate_only && Present (Exception_Handlers (gnat_node)) 4671 && Exception_Mechanism == Setjmp_Longjmp); 4672 bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node)); 4673 bool binding_for_block = (at_end || gcc_zcx || setjmp_longjmp); 4674 tree gnu_inner_block; /* The statement(s) for the block itself. */ 4675 tree gnu_result; 4676 tree gnu_expr; 4677 Node_Id gnat_temp; 4678 /* Node providing the sloc for the cleanup actions. */ 4679 Node_Id gnat_cleanup_loc_node = (Present (End_Label (gnat_node)) ? 4680 End_Label (gnat_node) : 4681 gnat_node); 4682 4683 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes 4684 and we have our own SJLJ mechanism. To call the GCC mechanism, we call 4685 add_cleanup, and when we leave the binding, end_stmt_group will create 4686 the TRY_FINALLY_EXPR. 4687 4688 ??? The region level calls down there have been specifically put in place 4689 for a ZCX context and currently the order in which things are emitted 4690 (region/handlers) is different from the SJLJ case. Instead of putting 4691 other calls with different conditions at other places for the SJLJ case, 4692 it seems cleaner to reorder things for the SJLJ case and generalize the 4693 condition to make it not ZCX specific. 4694 4695 If there are any exceptions or cleanup processing involved, we need an 4696 outer statement group (for Setjmp_Longjmp) and binding level. */ 4697 if (binding_for_block) 4698 { 4699 start_stmt_group (); 4700 gnat_pushlevel (); 4701 } 4702 4703 /* If using setjmp_longjmp, make the variables for the setjmp buffer and save 4704 area for address of previous buffer. Do this first since we need to have 4705 the setjmp buf known for any decls in this block. */ 4706 if (setjmp_longjmp) 4707 { 4708 gnu_jmpsave_decl 4709 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE, 4710 jmpbuf_ptr_type, 4711 build_call_n_expr (get_jmpbuf_decl, 0), 4712 false, false, false, false, NULL, gnat_node); 4713 DECL_ARTIFICIAL (gnu_jmpsave_decl) = 1; 4714 4715 /* The __builtin_setjmp receivers will immediately reinstall it. Now 4716 because of the unstructured form of EH used by setjmp_longjmp, there 4717 might be forward edges going to __builtin_setjmp receivers on which 4718 it is uninitialized, although they will never be actually taken. */ 4719 TREE_NO_WARNING (gnu_jmpsave_decl) = 1; 4720 gnu_jmpbuf_decl 4721 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE, 4722 jmpbuf_type, 4723 NULL_TREE, 4724 false, false, false, false, NULL, gnat_node); 4725 DECL_ARTIFICIAL (gnu_jmpbuf_decl) = 1; 4726 4727 set_block_jmpbuf_decl (gnu_jmpbuf_decl); 4728 4729 /* When we exit this block, restore the saved value. */ 4730 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl), 4731 gnat_cleanup_loc_node); 4732 } 4733 4734 /* If we are to call a function when exiting this block, add a cleanup 4735 to the binding level we made above. Note that add_cleanup is FIFO 4736 so we must register this cleanup after the EH cleanup just above. */ 4737 if (at_end) 4738 add_cleanup (build_call_n_expr (gnat_to_gnu (At_End_Proc (gnat_node)), 0), 4739 gnat_cleanup_loc_node); 4740 4741 /* Now build the tree for the declarations and statements inside this block. 4742 If this is SJLJ, set our jmp_buf as the current buffer. */ 4743 start_stmt_group (); 4744 4745 if (setjmp_longjmp) 4746 { 4747 gnu_expr = build_call_n_expr (set_jmpbuf_decl, 1, 4748 build_unary_op (ADDR_EXPR, NULL_TREE, 4749 gnu_jmpbuf_decl)); 4750 set_expr_location_from_node (gnu_expr, gnat_node); 4751 add_stmt (gnu_expr); 4752 } 4753 4754 if (Present (First_Real_Statement (gnat_node))) 4755 process_decls (Statements (gnat_node), Empty, 4756 First_Real_Statement (gnat_node), true, true); 4757 4758 /* Generate code for each statement in the block. */ 4759 for (gnat_temp = (Present (First_Real_Statement (gnat_node)) 4760 ? First_Real_Statement (gnat_node) 4761 : First (Statements (gnat_node))); 4762 Present (gnat_temp); gnat_temp = Next (gnat_temp)) 4763 add_stmt (gnat_to_gnu (gnat_temp)); 4764 gnu_inner_block = end_stmt_group (); 4765 4766 /* Now generate code for the two exception models, if either is relevant for 4767 this block. */ 4768 if (setjmp_longjmp) 4769 { 4770 tree *gnu_else_ptr = 0; 4771 tree gnu_handler; 4772 4773 /* Make a binding level for the exception handling declarations and code 4774 and set up gnu_except_ptr_stack for the handlers to use. */ 4775 start_stmt_group (); 4776 gnat_pushlevel (); 4777 4778 vec_safe_push (gnu_except_ptr_stack, 4779 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE, 4780 build_pointer_type (except_type_node), 4781 build_call_n_expr (get_excptr_decl, 0), 4782 false, false, false, false, 4783 NULL, gnat_node)); 4784 4785 /* Generate code for each handler. The N_Exception_Handler case does the 4786 real work and returns a COND_EXPR for each handler, which we chain 4787 together here. */ 4788 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); 4789 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp)) 4790 { 4791 gnu_expr = gnat_to_gnu (gnat_temp); 4792 4793 /* If this is the first one, set it as the outer one. Otherwise, 4794 point the "else" part of the previous handler to us. Then point 4795 to our "else" part. */ 4796 if (!gnu_else_ptr) 4797 add_stmt (gnu_expr); 4798 else 4799 *gnu_else_ptr = gnu_expr; 4800 4801 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); 4802 } 4803 4804 /* If none of the exception handlers did anything, re-raise but do not 4805 defer abortion. */ 4806 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1, 4807 gnu_except_ptr_stack->last ()); 4808 set_expr_location_from_node 4809 (gnu_expr, 4810 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node); 4811 4812 if (gnu_else_ptr) 4813 *gnu_else_ptr = gnu_expr; 4814 else 4815 add_stmt (gnu_expr); 4816 4817 /* End the binding level dedicated to the exception handlers and get the 4818 whole statement group. */ 4819 gnu_except_ptr_stack->pop (); 4820 gnat_poplevel (); 4821 gnu_handler = end_stmt_group (); 4822 4823 /* If the setjmp returns 1, we restore our incoming longjmp value and 4824 then check the handlers. */ 4825 start_stmt_group (); 4826 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1, 4827 gnu_jmpsave_decl), 4828 gnat_node); 4829 add_stmt (gnu_handler); 4830 gnu_handler = end_stmt_group (); 4831 4832 /* This block is now "if (setjmp) ... <handlers> else <block>". */ 4833 gnu_result = build3 (COND_EXPR, void_type_node, 4834 (build_call_n_expr 4835 (setjmp_decl, 1, 4836 build_unary_op (ADDR_EXPR, NULL_TREE, 4837 gnu_jmpbuf_decl))), 4838 gnu_handler, gnu_inner_block); 4839 } 4840 else if (gcc_zcx) 4841 { 4842 tree gnu_handlers; 4843 location_t locus; 4844 4845 /* First make a block containing the handlers. */ 4846 start_stmt_group (); 4847 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node)); 4848 Present (gnat_temp); 4849 gnat_temp = Next_Non_Pragma (gnat_temp)) 4850 add_stmt (gnat_to_gnu (gnat_temp)); 4851 gnu_handlers = end_stmt_group (); 4852 4853 /* Now make the TRY_CATCH_EXPR for the block. */ 4854 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node, 4855 gnu_inner_block, gnu_handlers); 4856 /* Set a location. We need to find a unique location for the dispatching 4857 code, otherwise we can get coverage or debugging issues. Try with 4858 the location of the end label. */ 4859 if (Present (End_Label (gnat_node)) 4860 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus)) 4861 SET_EXPR_LOCATION (gnu_result, locus); 4862 else 4863 /* Clear column information so that the exception handler of an 4864 implicit transient block does not incorrectly inherit the slocs 4865 of a decision, which would otherwise confuse control flow based 4866 coverage analysis tools. */ 4867 set_expr_location_from_node1 (gnu_result, gnat_node, true); 4868 } 4869 else 4870 gnu_result = gnu_inner_block; 4871 4872 /* Now close our outer block, if we had to make one. */ 4873 if (binding_for_block) 4874 { 4875 add_stmt (gnu_result); 4876 gnat_poplevel (); 4877 gnu_result = end_stmt_group (); 4878 } 4879 4880 return gnu_result; 4881} 4882 4883/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, 4884 to a GCC tree, which is returned. This is the variant for Setjmp_Longjmp 4885 exception handling. */ 4886 4887static tree 4888Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) 4889{ 4890 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make 4891 an "if" statement to select the proper exceptions. For "Others", exclude 4892 exceptions where Handled_By_Others is nonzero unless the All_Others flag 4893 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */ 4894 tree gnu_choice = boolean_false_node; 4895 tree gnu_body = build_stmt_group (Statements (gnat_node), false); 4896 Node_Id gnat_temp; 4897 4898 for (gnat_temp = First (Exception_Choices (gnat_node)); 4899 gnat_temp; gnat_temp = Next (gnat_temp)) 4900 { 4901 tree this_choice; 4902 4903 if (Nkind (gnat_temp) == N_Others_Choice) 4904 { 4905 if (All_Others (gnat_temp)) 4906 this_choice = boolean_true_node; 4907 else 4908 this_choice 4909 = build_binary_op 4910 (EQ_EXPR, boolean_type_node, 4911 convert 4912 (integer_type_node, 4913 build_component_ref 4914 (build_unary_op 4915 (INDIRECT_REF, NULL_TREE, 4916 gnu_except_ptr_stack->last ()), 4917 get_identifier ("not_handled_by_others"), NULL_TREE, 4918 false)), 4919 integer_zero_node); 4920 } 4921 4922 else if (Nkind (gnat_temp) == N_Identifier 4923 || Nkind (gnat_temp) == N_Expanded_Name) 4924 { 4925 Entity_Id gnat_ex_id = Entity (gnat_temp); 4926 tree gnu_expr; 4927 4928 /* Exception may be a renaming. Recover original exception which is 4929 the one elaborated and registered. */ 4930 if (Present (Renamed_Object (gnat_ex_id))) 4931 gnat_ex_id = Renamed_Object (gnat_ex_id); 4932 4933 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); 4934 4935 this_choice 4936 = build_binary_op 4937 (EQ_EXPR, boolean_type_node, 4938 gnu_except_ptr_stack->last (), 4939 convert (TREE_TYPE (gnu_except_ptr_stack->last ()), 4940 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); 4941} 4942 else 4943 gcc_unreachable (); 4944 4945 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, 4946 gnu_choice, this_choice); 4947 } 4948 4949 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE); 4950} 4951 4952/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler, 4953 to a GCC tree, which is returned. This is the variant for ZCX. */ 4954 4955static tree 4956Exception_Handler_to_gnu_zcx (Node_Id gnat_node) 4957{ 4958 tree gnu_etypes_list = NULL_TREE; 4959 tree gnu_current_exc_ptr, prev_gnu_incoming_exc_ptr; 4960 Node_Id gnat_temp; 4961 4962 /* We build a TREE_LIST of nodes representing what exception types this 4963 handler can catch, with special cases for others and all others cases. 4964 4965 Each exception type is actually identified by a pointer to the exception 4966 id, or to a dummy object for "others" and "all others". */ 4967 for (gnat_temp = First (Exception_Choices (gnat_node)); 4968 gnat_temp; gnat_temp = Next (gnat_temp)) 4969 { 4970 tree gnu_expr, gnu_etype; 4971 4972 if (Nkind (gnat_temp) == N_Others_Choice) 4973 { 4974 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl; 4975 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); 4976 } 4977 else if (Nkind (gnat_temp) == N_Identifier 4978 || Nkind (gnat_temp) == N_Expanded_Name) 4979 { 4980 Entity_Id gnat_ex_id = Entity (gnat_temp); 4981 4982 /* Exception may be a renaming. Recover original exception which is 4983 the one elaborated and registered. */ 4984 if (Present (Renamed_Object (gnat_ex_id))) 4985 gnat_ex_id = Renamed_Object (gnat_ex_id); 4986 4987 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); 4988 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); 4989 } 4990 else 4991 gcc_unreachable (); 4992 4993 /* The GCC interface expects NULL to be passed for catch all handlers, so 4994 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype 4995 is integer_zero_node. It would not work, however, because GCC's 4996 notion of "catch all" is stronger than our notion of "others". Until 4997 we correctly use the cleanup interface as well, doing that would 4998 prevent the "all others" handlers from being seen, because nothing 4999 can be caught beyond a catch all from GCC's point of view. */ 5000 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list); 5001 } 5002 5003 start_stmt_group (); 5004 gnat_pushlevel (); 5005 5006 /* Expand a call to the begin_handler hook at the beginning of the handler, 5007 and arrange for a call to the end_handler hook to occur on every possible 5008 exit path. 5009 5010 The hooks expect a pointer to the low level occurrence. This is required 5011 for our stack management scheme because a raise inside the handler pushes 5012 a new occurrence on top of the stack, which means that this top does not 5013 necessarily match the occurrence this handler was dealing with. 5014 5015 __builtin_eh_pointer references the exception occurrence being 5016 propagated. Upon handler entry, this is the exception for which the 5017 handler is triggered. This might not be the case upon handler exit, 5018 however, as we might have a new occurrence propagated by the handler's 5019 body, and the end_handler hook called as a cleanup in this context. 5020 5021 We use a local variable to retrieve the incoming value at handler entry 5022 time, and reuse it to feed the end_handler hook's argument at exit. */ 5023 5024 gnu_current_exc_ptr 5025 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER), 5026 1, integer_zero_node); 5027 prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr; 5028 gnu_incoming_exc_ptr = create_var_decl (get_identifier ("EXPTR"), NULL_TREE, 5029 ptr_type_node, gnu_current_exc_ptr, 5030 false, false, false, false, 5031 NULL, gnat_node); 5032 5033 add_stmt_with_node (build_call_n_expr (begin_handler_decl, 1, 5034 gnu_incoming_exc_ptr), 5035 gnat_node); 5036 5037 /* Declare and initialize the choice parameter, if present. */ 5038 if (Present (Choice_Parameter (gnat_node))) 5039 { 5040 tree gnu_param 5041 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, 1); 5042 5043 add_stmt (build_call_n_expr 5044 (set_exception_parameter_decl, 2, 5045 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param), 5046 gnu_incoming_exc_ptr)); 5047 } 5048 5049 /* We don't have an End_Label at hand to set the location of the cleanup 5050 actions, so we use that of the exception handler itself instead. */ 5051 add_cleanup (build_call_n_expr (end_handler_decl, 1, gnu_incoming_exc_ptr), 5052 gnat_node); 5053 add_stmt_list (Statements (gnat_node)); 5054 gnat_poplevel (); 5055 5056 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr; 5057 5058 return 5059 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ()); 5060} 5061 5062/* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */ 5063 5064static void 5065Compilation_Unit_to_gnu (Node_Id gnat_node) 5066{ 5067 const Node_Id gnat_unit = Unit (gnat_node); 5068 const bool body_p = (Nkind (gnat_unit) == N_Package_Body 5069 || Nkind (gnat_unit) == N_Subprogram_Body); 5070 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit); 5071 Entity_Id gnat_entity; 5072 Node_Id gnat_pragma; 5073 /* Make the decl for the elaboration procedure. */ 5074 tree gnu_elab_proc_decl 5075 = create_subprog_decl 5076 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"), 5077 NULL_TREE, void_ftype, NULL_TREE, is_disabled, true, false, true, NULL, 5078 gnat_unit); 5079 struct elab_info *info; 5080 5081 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl); 5082 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1; 5083 5084 /* Initialize the information structure for the function. */ 5085 allocate_struct_function (gnu_elab_proc_decl, false); 5086 set_cfun (NULL); 5087 5088 current_function_decl = NULL_TREE; 5089 5090 start_stmt_group (); 5091 gnat_pushlevel (); 5092 5093 /* For a body, first process the spec if there is one. */ 5094 if (Nkind (gnat_unit) == N_Package_Body 5095 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node))) 5096 add_stmt (gnat_to_gnu (Library_Unit (gnat_node))); 5097 5098 if (type_annotate_only && gnat_node == Cunit (Main_Unit)) 5099 { 5100 elaborate_all_entities (gnat_node); 5101 5102 if (Nkind (gnat_unit) == N_Subprogram_Declaration 5103 || Nkind (gnat_unit) == N_Generic_Package_Declaration 5104 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration) 5105 return; 5106 } 5107 5108 /* Then process any pragmas and declarations preceding the unit. */ 5109 for (gnat_pragma = First (Context_Items (gnat_node)); 5110 Present (gnat_pragma); 5111 gnat_pragma = Next (gnat_pragma)) 5112 if (Nkind (gnat_pragma) == N_Pragma) 5113 add_stmt (gnat_to_gnu (gnat_pragma)); 5114 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty, 5115 true, true); 5116 5117 /* Process the unit itself. */ 5118 add_stmt (gnat_to_gnu (gnat_unit)); 5119 5120 /* Generate code for all the inlined subprograms. */ 5121 for (gnat_entity = First_Inlined_Subprogram (gnat_node); 5122 Present (gnat_entity); 5123 gnat_entity = Next_Inlined_Subprogram (gnat_entity)) 5124 { 5125 Node_Id gnat_body; 5126 5127 /* Without optimization, process only the required subprograms. */ 5128 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity)) 5129 continue; 5130 5131 gnat_body = Parent (Declaration_Node (gnat_entity)); 5132 if (Nkind (gnat_body) != N_Subprogram_Body) 5133 { 5134 /* ??? This happens when only the spec of a package is provided. */ 5135 if (No (Corresponding_Body (gnat_body))) 5136 continue; 5137 5138 gnat_body 5139 = Parent (Declaration_Node (Corresponding_Body (gnat_body))); 5140 } 5141 5142 /* Define the entity first so we set DECL_EXTERNAL. */ 5143 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); 5144 add_stmt (gnat_to_gnu (gnat_body)); 5145 } 5146 5147 /* Process any pragmas and actions following the unit. */ 5148 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node))); 5149 add_stmt_list (Actions (Aux_Decls_Node (gnat_node))); 5150 finalize_from_limited_with (); 5151 5152 /* Save away what we've made so far and record this potential elaboration 5153 procedure. */ 5154 info = ggc_alloc<elab_info> (); 5155 set_current_block_context (gnu_elab_proc_decl); 5156 gnat_poplevel (); 5157 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group (); 5158 5159 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit); 5160 5161 info->next = elab_info_list; 5162 info->elab_proc = gnu_elab_proc_decl; 5163 info->gnat_node = gnat_node; 5164 elab_info_list = info; 5165 5166 /* Generate elaboration code for this unit, if necessary, and say whether 5167 we did or not. */ 5168 gnu_elab_proc_stack->pop (); 5169 5170 /* Invalidate the global renaming pointers. This is necessary because 5171 stabilization of the renamed entities may create SAVE_EXPRs which 5172 have been tied to a specific elaboration routine just above. */ 5173 invalidate_global_renaming_pointers (); 5174 5175 /* Force the processing for all nodes that remain in the queue. */ 5176 process_deferred_decl_context (true); 5177} 5178 5179/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error, 5180 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where 5181 we should place the result type. LABEL_P is true if there is a label to 5182 branch to for the exception. */ 5183 5184static tree 5185Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) 5186{ 5187 const Node_Kind kind = Nkind (gnat_node); 5188 const int reason = UI_To_Int (Reason (gnat_node)); 5189 const Node_Id gnat_cond = Condition (gnat_node); 5190 const bool with_extra_info 5191 = Exception_Extra_Info 5192 && !No_Exception_Handlers_Set () 5193 && !get_exception_label (kind); 5194 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE; 5195 5196 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node)); 5197 5198 switch (reason) 5199 { 5200 case CE_Access_Check_Failed: 5201 if (with_extra_info) 5202 gnu_result = build_call_raise_column (reason, gnat_node); 5203 break; 5204 5205 case CE_Index_Check_Failed: 5206 case CE_Range_Check_Failed: 5207 case CE_Invalid_Data: 5208 if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not) 5209 { 5210 Node_Id gnat_range, gnat_index, gnat_type; 5211 tree gnu_index, gnu_low_bound, gnu_high_bound; 5212 struct range_check_info_d *rci; 5213 5214 switch (Nkind (Right_Opnd (gnat_cond))) 5215 { 5216 case N_In: 5217 gnat_range = Right_Opnd (Right_Opnd (gnat_cond)); 5218 gcc_assert (Nkind (gnat_range) == N_Range); 5219 gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range)); 5220 gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range)); 5221 break; 5222 5223 case N_Op_Ge: 5224 gnu_low_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond))); 5225 gnu_high_bound = NULL_TREE; 5226 break; 5227 5228 case N_Op_Le: 5229 gnu_low_bound = NULL_TREE; 5230 gnu_high_bound = gnat_to_gnu (Right_Opnd (Right_Opnd (gnat_cond))); 5231 break; 5232 5233 default: 5234 goto common; 5235 } 5236 5237 gnat_index = Left_Opnd (Right_Opnd (gnat_cond)); 5238 gnat_type = Etype (gnat_index); 5239 gnu_index = gnat_to_gnu (gnat_index); 5240 5241 if (with_extra_info 5242 && gnu_low_bound 5243 && gnu_high_bound 5244 && Known_Esize (gnat_type) 5245 && UI_To_Int (Esize (gnat_type)) <= 32) 5246 gnu_result 5247 = build_call_raise_range (reason, gnat_node, gnu_index, 5248 gnu_low_bound, gnu_high_bound); 5249 5250 /* If loop unswitching is enabled, we try to compute invariant 5251 conditions for checks applied to iteration variables, i.e. 5252 conditions that are both independent of the variable and 5253 necessary in order for the check to fail in the course of 5254 some iteration, and prepend them to the original condition 5255 of the checks. This will make it possible later for the 5256 loop unswitching pass to replace the loop with two loops, 5257 one of which has the checks eliminated and the other has 5258 the original checks reinstated, and a run time selection. 5259 The former loop will be suitable for vectorization. */ 5260 if (flag_unswitch_loops 5261 && !vec_safe_is_empty (gnu_loop_stack) 5262 && (!gnu_low_bound 5263 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound))) 5264 && (!gnu_high_bound 5265 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound))) 5266 && (rci = push_range_check_info (gnu_index))) 5267 { 5268 rci->low_bound = gnu_low_bound; 5269 rci->high_bound = gnu_high_bound; 5270 rci->type = get_unpadded_type (gnat_type); 5271 rci->invariant_cond = build1 (SAVE_EXPR, boolean_type_node, 5272 boolean_true_node); 5273 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR, 5274 boolean_type_node, 5275 rci->invariant_cond, 5276 gnat_to_gnu (gnat_cond)); 5277 } 5278 } 5279 break; 5280 5281 default: 5282 break; 5283 } 5284 5285common: 5286 if (!gnu_result) 5287 gnu_result = build_call_raise (reason, gnat_node, kind); 5288 set_expr_location_from_node (gnu_result, gnat_node); 5289 5290 /* If the type is VOID, this is a statement, so we need to generate the code 5291 for the call. Handle a condition, if there is one. */ 5292 if (VOID_TYPE_P (*gnu_result_type_p)) 5293 { 5294 if (Present (gnat_cond)) 5295 { 5296 if (!gnu_cond) 5297 gnu_cond = gnat_to_gnu (gnat_cond); 5298 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result, 5299 alloc_stmt_list ()); 5300 } 5301 } 5302 else 5303 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result); 5304 5305 return gnu_result; 5306} 5307 5308/* Return true if GNAT_NODE is on the LHS of an assignment or an actual 5309 parameter of a call. */ 5310 5311static bool 5312lhs_or_actual_p (Node_Id gnat_node) 5313{ 5314 Node_Id gnat_parent = Parent (gnat_node); 5315 Node_Kind kind = Nkind (gnat_parent); 5316 5317 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node) 5318 return true; 5319 5320 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call) 5321 && Name (gnat_parent) != gnat_node) 5322 return true; 5323 5324 if (kind == N_Parameter_Association) 5325 return true; 5326 5327 return false; 5328} 5329 5330/* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS 5331 of an assignment or an actual parameter of a call. */ 5332 5333static bool 5334present_in_lhs_or_actual_p (Node_Id gnat_node) 5335{ 5336 Node_Kind kind; 5337 5338 if (lhs_or_actual_p (gnat_node)) 5339 return true; 5340 5341 kind = Nkind (Parent (gnat_node)); 5342 5343 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion) 5344 && lhs_or_actual_p (Parent (gnat_node))) 5345 return true; 5346 5347 return false; 5348} 5349 5350/* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far 5351 as gigi is concerned. This is used to avoid conversions on the LHS. */ 5352 5353static bool 5354unchecked_conversion_nop (Node_Id gnat_node) 5355{ 5356 Entity_Id from_type, to_type; 5357 5358 /* The conversion must be on the LHS of an assignment or an actual parameter 5359 of a call. Otherwise, even if the conversion was essentially a no-op, it 5360 could de facto ensure type consistency and this should be preserved. */ 5361 if (!lhs_or_actual_p (gnat_node)) 5362 return false; 5363 5364 from_type = Etype (Expression (gnat_node)); 5365 5366 /* We're interested in artificial conversions generated by the front-end 5367 to make private types explicit, e.g. in Expand_Assign_Array. */ 5368 if (!Is_Private_Type (from_type)) 5369 return false; 5370 5371 from_type = Underlying_Type (from_type); 5372 to_type = Etype (gnat_node); 5373 5374 /* The direct conversion to the underlying type is a no-op. */ 5375 if (to_type == from_type) 5376 return true; 5377 5378 /* For an array subtype, the conversion to the PAIT is a no-op. */ 5379 if (Ekind (from_type) == E_Array_Subtype 5380 && to_type == Packed_Array_Impl_Type (from_type)) 5381 return true; 5382 5383 /* For a record subtype, the conversion to the type is a no-op. */ 5384 if (Ekind (from_type) == E_Record_Subtype 5385 && to_type == Etype (from_type)) 5386 return true; 5387 5388 return false; 5389} 5390 5391/* This function is the driver of the GNAT to GCC tree transformation process. 5392 It is the entry point of the tree transformer. GNAT_NODE is the root of 5393 some GNAT tree. Return the root of the corresponding GCC tree. If this 5394 is an expression, return the GCC equivalent of the expression. If this 5395 is a statement, return the statement or add it to the current statement 5396 group, in which case anything returned is to be interpreted as occurring 5397 after anything added. */ 5398 5399tree 5400gnat_to_gnu (Node_Id gnat_node) 5401{ 5402 const Node_Kind kind = Nkind (gnat_node); 5403 bool went_into_elab_proc = false; 5404 tree gnu_result = error_mark_node; /* Default to no value. */ 5405 tree gnu_result_type = void_type_node; 5406 tree gnu_expr, gnu_lhs, gnu_rhs; 5407 Node_Id gnat_temp; 5408 5409 /* Save node number for error message and set location information. */ 5410 error_gnat_node = gnat_node; 5411 Sloc_to_locus (Sloc (gnat_node), &input_location); 5412 5413 /* If this node is a statement and we are only annotating types, return an 5414 empty statement list. */ 5415 if (type_annotate_only && IN (kind, N_Statement_Other_Than_Procedure_Call)) 5416 return alloc_stmt_list (); 5417 5418 /* If this node is a non-static subexpression and we are only annotating 5419 types, make this into a NULL_EXPR. */ 5420 if (type_annotate_only 5421 && IN (kind, N_Subexpr) 5422 && kind != N_Identifier 5423 && !Compile_Time_Known_Value (gnat_node)) 5424 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)), 5425 build_call_raise (CE_Range_Check_Failed, gnat_node, 5426 N_Raise_Constraint_Error)); 5427 5428 if ((IN (kind, N_Statement_Other_Than_Procedure_Call) 5429 && kind != N_Null_Statement) 5430 || kind == N_Procedure_Call_Statement 5431 || kind == N_Label 5432 || kind == N_Implicit_Label_Declaration 5433 || kind == N_Handled_Sequence_Of_Statements 5434 || (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)) 5435 { 5436 tree current_elab_proc = get_elaboration_procedure (); 5437 5438 /* If this is a statement and we are at top level, it must be part of 5439 the elaboration procedure, so mark us as being in that procedure. */ 5440 if (!current_function_decl) 5441 { 5442 current_function_decl = current_elab_proc; 5443 went_into_elab_proc = true; 5444 } 5445 5446 /* If we are in the elaboration procedure, check if we are violating a 5447 No_Elaboration_Code restriction by having a statement there. Don't 5448 check for a possible No_Elaboration_Code restriction violation on 5449 N_Handled_Sequence_Of_Statements, as we want to signal an error on 5450 every nested real statement instead. This also avoids triggering 5451 spurious errors on dummy (empty) sequences created by the front-end 5452 for package bodies in some cases. */ 5453 if (current_function_decl == current_elab_proc 5454 && kind != N_Handled_Sequence_Of_Statements) 5455 Check_Elaboration_Code_Allowed (gnat_node); 5456 } 5457 5458 switch (kind) 5459 { 5460 /********************************/ 5461 /* Chapter 2: Lexical Elements */ 5462 /********************************/ 5463 5464 case N_Identifier: 5465 case N_Expanded_Name: 5466 case N_Operator_Symbol: 5467 case N_Defining_Identifier: 5468 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type); 5469 5470 /* If this is an atomic access on the RHS for which synchronization is 5471 required, build the atomic load. */ 5472 if (atomic_sync_required_p (gnat_node) 5473 && !present_in_lhs_or_actual_p (gnat_node)) 5474 gnu_result = build_atomic_load (gnu_result); 5475 break; 5476 5477 case N_Integer_Literal: 5478 { 5479 tree gnu_type; 5480 5481 /* Get the type of the result, looking inside any padding and 5482 justified modular types. Then get the value in that type. */ 5483 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5484 5485 if (TREE_CODE (gnu_type) == RECORD_TYPE 5486 && TYPE_JUSTIFIED_MODULAR_P (gnu_type)) 5487 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); 5488 5489 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type); 5490 5491 /* If the result overflows (meaning it doesn't fit in its base type), 5492 abort. We would like to check that the value is within the range 5493 of the subtype, but that causes problems with subtypes whose usage 5494 will raise Constraint_Error and with biased representation, so 5495 we don't. */ 5496 gcc_assert (!TREE_OVERFLOW (gnu_result)); 5497 } 5498 break; 5499 5500 case N_Character_Literal: 5501 /* If a Entity is present, it means that this was one of the 5502 literals in a user-defined character type. In that case, 5503 just return the value in the CONST_DECL. Otherwise, use the 5504 character code. In that case, the base type should be an 5505 INTEGER_TYPE, but we won't bother checking for that. */ 5506 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5507 if (Present (Entity (gnat_node))) 5508 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node))); 5509 else 5510 gnu_result 5511 = build_int_cst_type 5512 (gnu_result_type, UI_To_CC (Char_Literal_Value (gnat_node))); 5513 break; 5514 5515 case N_Real_Literal: 5516 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5517 5518 /* If this is of a fixed-point type, the value we want is the value of 5519 the corresponding integer. */ 5520 if (IN (Ekind (Underlying_Type (Etype (gnat_node))), Fixed_Point_Kind)) 5521 { 5522 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node), 5523 gnu_result_type); 5524 gcc_assert (!TREE_OVERFLOW (gnu_result)); 5525 } 5526 5527 else 5528 { 5529 Ureal ur_realval = Realval (gnat_node); 5530 5531 /* First convert the value to a machine number if it isn't already. 5532 That will force the base to 2 for non-zero values and simplify 5533 the rest of the logic. */ 5534 if (!Is_Machine_Number (gnat_node)) 5535 ur_realval 5536 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))), 5537 ur_realval, Round_Even, gnat_node); 5538 5539 if (UR_Is_Zero (ur_realval)) 5540 gnu_result = convert (gnu_result_type, integer_zero_node); 5541 else 5542 { 5543 REAL_VALUE_TYPE tmp; 5544 5545 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type); 5546 5547 /* The base must be 2 as Machine guarantees this, so we scale 5548 the value, which we know can fit in the mantissa of the type 5549 (hence the use of that type above). */ 5550 gcc_assert (Rbase (ur_realval) == 2); 5551 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result), 5552 - UI_To_Int (Denominator (ur_realval))); 5553 gnu_result = build_real (gnu_result_type, tmp); 5554 } 5555 5556 /* Now see if we need to negate the result. Do it this way to 5557 properly handle -0. */ 5558 if (UR_Is_Negative (Realval (gnat_node))) 5559 gnu_result 5560 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type), 5561 gnu_result); 5562 } 5563 5564 break; 5565 5566 case N_String_Literal: 5567 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5568 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR) 5569 { 5570 String_Id gnat_string = Strval (gnat_node); 5571 int length = String_Length (gnat_string); 5572 int i; 5573 char *string; 5574 if (length >= ALLOCA_THRESHOLD) 5575 string = XNEWVEC (char, length + 1); 5576 else 5577 string = (char *) alloca (length + 1); 5578 5579 /* Build the string with the characters in the literal. Note 5580 that Ada strings are 1-origin. */ 5581 for (i = 0; i < length; i++) 5582 string[i] = Get_String_Char (gnat_string, i + 1); 5583 5584 /* Put a null at the end of the string in case it's in a context 5585 where GCC will want to treat it as a C string. */ 5586 string[i] = 0; 5587 5588 gnu_result = build_string (length, string); 5589 5590 /* Strings in GCC don't normally have types, but we want 5591 this to not be converted to the array type. */ 5592 TREE_TYPE (gnu_result) = gnu_result_type; 5593 5594 if (length >= ALLOCA_THRESHOLD) 5595 free (string); 5596 } 5597 else 5598 { 5599 /* Build a list consisting of each character, then make 5600 the aggregate. */ 5601 String_Id gnat_string = Strval (gnat_node); 5602 int length = String_Length (gnat_string); 5603 int i; 5604 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); 5605 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node); 5606 vec<constructor_elt, va_gc> *gnu_vec; 5607 vec_alloc (gnu_vec, length); 5608 5609 for (i = 0; i < length; i++) 5610 { 5611 tree t = build_int_cst (TREE_TYPE (gnu_result_type), 5612 Get_String_Char (gnat_string, i + 1)); 5613 5614 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t); 5615 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node); 5616 } 5617 5618 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec); 5619 } 5620 break; 5621 5622 case N_Pragma: 5623 gnu_result = Pragma_to_gnu (gnat_node); 5624 break; 5625 5626 /**************************************/ 5627 /* Chapter 3: Declarations and Types */ 5628 /**************************************/ 5629 5630 case N_Subtype_Declaration: 5631 case N_Full_Type_Declaration: 5632 case N_Incomplete_Type_Declaration: 5633 case N_Private_Type_Declaration: 5634 case N_Private_Extension_Declaration: 5635 case N_Task_Type_Declaration: 5636 process_type (Defining_Entity (gnat_node)); 5637 gnu_result = alloc_stmt_list (); 5638 break; 5639 5640 case N_Object_Declaration: 5641 case N_Exception_Declaration: 5642 gnat_temp = Defining_Entity (gnat_node); 5643 gnu_result = alloc_stmt_list (); 5644 5645 /* If we are just annotating types and this object has an unconstrained 5646 or task type, don't elaborate it. */ 5647 if (type_annotate_only 5648 && (((Is_Array_Type (Etype (gnat_temp)) 5649 || Is_Record_Type (Etype (gnat_temp))) 5650 && !Is_Constrained (Etype (gnat_temp))) 5651 || Is_Concurrent_Type (Etype (gnat_temp)))) 5652 break; 5653 5654 if (Present (Expression (gnat_node)) 5655 && !(kind == N_Object_Declaration && No_Initialization (gnat_node)) 5656 && (!type_annotate_only 5657 || Compile_Time_Known_Value (Expression (gnat_node)))) 5658 { 5659 gnu_expr = gnat_to_gnu (Expression (gnat_node)); 5660 if (Do_Range_Check (Expression (gnat_node))) 5661 gnu_expr 5662 = emit_range_check (gnu_expr, Etype (gnat_temp), gnat_node); 5663 5664 /* If this object has its elaboration delayed, we must force 5665 evaluation of GNU_EXPR right now and save it for when the object 5666 is frozen. */ 5667 if (Present (Freeze_Node (gnat_temp))) 5668 { 5669 if (TREE_CONSTANT (gnu_expr)) 5670 ; 5671 else if (global_bindings_p ()) 5672 gnu_expr 5673 = create_var_decl (create_concat_name (gnat_temp, "init"), 5674 NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 5675 false, false, false, false, 5676 NULL, gnat_temp); 5677 else 5678 gnu_expr = gnat_save_expr (gnu_expr); 5679 5680 save_gnu_tree (gnat_node, gnu_expr, true); 5681 } 5682 } 5683 else 5684 gnu_expr = NULL_TREE; 5685 5686 if (type_annotate_only && gnu_expr && TREE_CODE (gnu_expr) == ERROR_MARK) 5687 gnu_expr = NULL_TREE; 5688 5689 /* If this is a deferred constant with an address clause, we ignore the 5690 full view since the clause is on the partial view and we cannot have 5691 2 different GCC trees for the object. The only bits of the full view 5692 we will use is the initializer, but it will be directly fetched. */ 5693 if (Ekind(gnat_temp) == E_Constant 5694 && Present (Address_Clause (gnat_temp)) 5695 && Present (Full_View (gnat_temp))) 5696 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true); 5697 5698 if (No (Freeze_Node (gnat_temp))) 5699 gnat_to_gnu_entity (gnat_temp, gnu_expr, 1); 5700 break; 5701 5702 case N_Object_Renaming_Declaration: 5703 gnat_temp = Defining_Entity (gnat_node); 5704 5705 /* Don't do anything if this renaming is handled by the front end or if 5706 we are just annotating types and this object has a composite or task 5707 type, don't elaborate it. We return the result in case it has any 5708 SAVE_EXPRs in it that need to be evaluated here. */ 5709 if (!Is_Renaming_Of_Object (gnat_temp) 5710 && ! (type_annotate_only 5711 && (Is_Array_Type (Etype (gnat_temp)) 5712 || Is_Record_Type (Etype (gnat_temp)) 5713 || Is_Concurrent_Type (Etype (gnat_temp))))) 5714 gnu_result 5715 = gnat_to_gnu_entity (gnat_temp, 5716 gnat_to_gnu (Renamed_Object (gnat_temp)), 1); 5717 else 5718 gnu_result = alloc_stmt_list (); 5719 break; 5720 5721 case N_Exception_Renaming_Declaration: 5722 gnat_temp = Defining_Entity (gnat_node); 5723 if (Renamed_Entity (gnat_temp) != Empty) 5724 gnu_result 5725 = gnat_to_gnu_entity (gnat_temp, 5726 gnat_to_gnu (Renamed_Entity (gnat_temp)), 1); 5727 else 5728 gnu_result = alloc_stmt_list (); 5729 break; 5730 5731 case N_Implicit_Label_Declaration: 5732 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); 5733 gnu_result = alloc_stmt_list (); 5734 break; 5735 5736 case N_Number_Declaration: 5737 case N_Subprogram_Renaming_Declaration: 5738 case N_Package_Renaming_Declaration: 5739 /* These are fully handled in the front end. */ 5740 /* ??? For package renamings, find a way to use GENERIC namespaces so 5741 that we get proper debug information for them. */ 5742 gnu_result = alloc_stmt_list (); 5743 break; 5744 5745 /*************************************/ 5746 /* Chapter 4: Names and Expressions */ 5747 /*************************************/ 5748 5749 case N_Explicit_Dereference: 5750 gnu_result = gnat_to_gnu (Prefix (gnat_node)); 5751 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5752 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result); 5753 5754 /* If this is an atomic access on the RHS for which synchronization is 5755 required, build the atomic load. */ 5756 if (atomic_sync_required_p (gnat_node) 5757 && !present_in_lhs_or_actual_p (gnat_node)) 5758 gnu_result = build_atomic_load (gnu_result); 5759 break; 5760 5761 case N_Indexed_Component: 5762 { 5763 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node)); 5764 tree gnu_type; 5765 int ndim; 5766 int i; 5767 Node_Id *gnat_expr_array; 5768 5769 gnu_array_object = maybe_implicit_deref (gnu_array_object); 5770 5771 /* Convert vector inputs to their representative array type, to fit 5772 what the code below expects. */ 5773 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object))) 5774 { 5775 if (present_in_lhs_or_actual_p (gnat_node)) 5776 gnat_mark_addressable (gnu_array_object); 5777 gnu_array_object = maybe_vector_array (gnu_array_object); 5778 } 5779 5780 gnu_array_object = maybe_unconstrained_array (gnu_array_object); 5781 5782 /* If we got a padded type, remove it too. */ 5783 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object))) 5784 gnu_array_object 5785 = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))), 5786 gnu_array_object); 5787 5788 gnu_result = gnu_array_object; 5789 5790 /* The failure of this assertion will very likely come from a missing 5791 expansion for a packed array access. */ 5792 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE); 5793 5794 /* First compute the number of dimensions of the array, then 5795 fill the expression array, the order depending on whether 5796 this is a Convention_Fortran array or not. */ 5797 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object); 5798 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE 5799 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)); 5800 ndim++, gnu_type = TREE_TYPE (gnu_type)) 5801 ; 5802 5803 gnat_expr_array = XALLOCAVEC (Node_Id, ndim); 5804 5805 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object))) 5806 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node)); 5807 i >= 0; 5808 i--, gnat_temp = Next (gnat_temp)) 5809 gnat_expr_array[i] = gnat_temp; 5810 else 5811 for (i = 0, gnat_temp = First (Expressions (gnat_node)); 5812 i < ndim; 5813 i++, gnat_temp = Next (gnat_temp)) 5814 gnat_expr_array[i] = gnat_temp; 5815 5816 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object); 5817 i < ndim; i++, gnu_type = TREE_TYPE (gnu_type)) 5818 { 5819 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); 5820 gnat_temp = gnat_expr_array[i]; 5821 gnu_expr = gnat_to_gnu (gnat_temp); 5822 5823 if (Do_Range_Check (gnat_temp)) 5824 gnu_expr 5825 = emit_index_check 5826 (gnu_array_object, gnu_expr, 5827 TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), 5828 TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), 5829 gnat_temp); 5830 5831 gnu_result 5832 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr); 5833 5834 /* Array accesses are bound-checked so they cannot trap, but this 5835 is valid only if they are not hoisted ahead of the check. We 5836 need to mark them as no-trap to get decent loop optimizations 5837 in the presence of -fnon-call-exceptions, so we do it when we 5838 know that the original expression had no side-effects. */ 5839 if (TREE_CODE (gnu_result) == ARRAY_REF 5840 && !(Nkind (gnat_temp) == N_Identifier 5841 && Ekind (Entity (gnat_temp)) == E_Constant)) 5842 TREE_THIS_NOTRAP (gnu_result) = 1; 5843 } 5844 5845 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5846 5847 /* If this is an atomic access on the RHS for which synchronization is 5848 required, build the atomic load. */ 5849 if (atomic_sync_required_p (gnat_node) 5850 && !present_in_lhs_or_actual_p (gnat_node)) 5851 gnu_result = build_atomic_load (gnu_result); 5852 } 5853 break; 5854 5855 case N_Slice: 5856 { 5857 Node_Id gnat_range_node = Discrete_Range (gnat_node); 5858 tree gnu_type; 5859 5860 gnu_result = gnat_to_gnu (Prefix (gnat_node)); 5861 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5862 5863 /* Do any implicit dereferences of the prefix and do any needed 5864 range check. */ 5865 gnu_result = maybe_implicit_deref (gnu_result); 5866 gnu_result = maybe_unconstrained_array (gnu_result); 5867 gnu_type = TREE_TYPE (gnu_result); 5868 if (Do_Range_Check (gnat_range_node)) 5869 { 5870 /* Get the bounds of the slice. */ 5871 tree gnu_index_type 5872 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_result_type)); 5873 tree gnu_min_expr = TYPE_MIN_VALUE (gnu_index_type); 5874 tree gnu_max_expr = TYPE_MAX_VALUE (gnu_index_type); 5875 /* Get the permitted bounds. */ 5876 tree gnu_base_index_type 5877 = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); 5878 tree gnu_base_min_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR 5879 (TYPE_MIN_VALUE (gnu_base_index_type), gnu_result); 5880 tree gnu_base_max_expr = SUBSTITUTE_PLACEHOLDER_IN_EXPR 5881 (TYPE_MAX_VALUE (gnu_base_index_type), gnu_result); 5882 tree gnu_expr_l, gnu_expr_h, gnu_expr_type; 5883 5884 gnu_min_expr = gnat_protect_expr (gnu_min_expr); 5885 gnu_max_expr = gnat_protect_expr (gnu_max_expr); 5886 5887 /* Derive a good type to convert everything to. */ 5888 gnu_expr_type = get_base_type (gnu_index_type); 5889 5890 /* Test whether the minimum slice value is too small. */ 5891 gnu_expr_l = build_binary_op (LT_EXPR, boolean_type_node, 5892 convert (gnu_expr_type, 5893 gnu_min_expr), 5894 convert (gnu_expr_type, 5895 gnu_base_min_expr)); 5896 5897 /* Test whether the maximum slice value is too large. */ 5898 gnu_expr_h = build_binary_op (GT_EXPR, boolean_type_node, 5899 convert (gnu_expr_type, 5900 gnu_max_expr), 5901 convert (gnu_expr_type, 5902 gnu_base_max_expr)); 5903 5904 /* Build a slice index check that returns the low bound, 5905 assuming the slice is not empty. */ 5906 gnu_expr = emit_check 5907 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, 5908 gnu_expr_l, gnu_expr_h), 5909 gnu_min_expr, CE_Index_Check_Failed, gnat_node); 5910 5911 /* Build a conditional expression that does the index checks and 5912 returns the low bound if the slice is not empty (max >= min), 5913 and returns the naked low bound otherwise (max < min), unless 5914 it is non-constant and the high bound is; this prevents VRP 5915 from inferring bogus ranges on the unlikely path. */ 5916 gnu_expr = fold_build3 (COND_EXPR, gnu_expr_type, 5917 build_binary_op (GE_EXPR, gnu_expr_type, 5918 convert (gnu_expr_type, 5919 gnu_max_expr), 5920 convert (gnu_expr_type, 5921 gnu_min_expr)), 5922 gnu_expr, 5923 TREE_CODE (gnu_min_expr) != INTEGER_CST 5924 && TREE_CODE (gnu_max_expr) == INTEGER_CST 5925 ? gnu_max_expr : gnu_min_expr); 5926 } 5927 else 5928 /* Simply return the naked low bound. */ 5929 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type)); 5930 5931 /* If this is a slice with non-constant size of an array with constant 5932 size, set the maximum size for the allocation of temporaries. */ 5933 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type)) 5934 && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_type))) 5935 TYPE_ARRAY_MAX_SIZE (gnu_result_type) = TYPE_SIZE_UNIT (gnu_type); 5936 5937 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type, 5938 gnu_result, gnu_expr); 5939 } 5940 break; 5941 5942 case N_Selected_Component: 5943 { 5944 Entity_Id gnat_prefix = Prefix (gnat_node); 5945 Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); 5946 tree gnu_prefix = gnat_to_gnu (gnat_prefix); 5947 tree gnu_field; 5948 5949 gnu_prefix = maybe_implicit_deref (gnu_prefix); 5950 5951 /* For discriminant references in tagged types always substitute the 5952 corresponding discriminant as the actual selected component. */ 5953 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix)))) 5954 while (Present (Corresponding_Discriminant (gnat_field))) 5955 gnat_field = Corresponding_Discriminant (gnat_field); 5956 5957 /* For discriminant references of untagged types always substitute the 5958 corresponding stored discriminant. */ 5959 else if (Present (Corresponding_Discriminant (gnat_field))) 5960 gnat_field = Original_Record_Component (gnat_field); 5961 5962 /* Handle extracting the real or imaginary part of a complex. 5963 The real part is the first field and the imaginary the last. */ 5964 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE) 5965 gnu_result = build_unary_op (Present (Next_Entity (gnat_field)) 5966 ? REALPART_EXPR : IMAGPART_EXPR, 5967 NULL_TREE, gnu_prefix); 5968 else 5969 { 5970 gnu_field = gnat_to_gnu_field_decl (gnat_field); 5971 5972 /* If there are discriminants, the prefix might be evaluated more 5973 than once, which is a problem if it has side-effects. */ 5974 if (Has_Discriminants (Is_Access_Type (Etype (Prefix (gnat_node))) 5975 ? Designated_Type (Etype 5976 (Prefix (gnat_node))) 5977 : Etype (Prefix (gnat_node)))) 5978 gnu_prefix = gnat_stabilize_reference (gnu_prefix, false, NULL); 5979 5980 gnu_result 5981 = build_component_ref (gnu_prefix, NULL_TREE, gnu_field, 5982 (Nkind (Parent (gnat_node)) 5983 == N_Attribute_Reference) 5984 && lvalue_required_for_attribute_p 5985 (Parent (gnat_node))); 5986 } 5987 5988 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 5989 5990 /* If this is an atomic access on the RHS for which synchronization is 5991 required, build the atomic load. */ 5992 if (atomic_sync_required_p (gnat_node) 5993 && !present_in_lhs_or_actual_p (gnat_node)) 5994 gnu_result = build_atomic_load (gnu_result); 5995 } 5996 break; 5997 5998 case N_Attribute_Reference: 5999 { 6000 /* The attribute designator. */ 6001 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node)); 6002 6003 /* The Elab_Spec and Elab_Body attributes are special in that Prefix 6004 is a unit, not an object with a GCC equivalent. */ 6005 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body) 6006 return 6007 create_subprog_decl (create_concat_name 6008 (Entity (Prefix (gnat_node)), 6009 attr == Attr_Elab_Body ? "elabb" : "elabs"), 6010 NULL_TREE, void_ftype, NULL_TREE, is_disabled, 6011 true, true, true, NULL, gnat_node); 6012 6013 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr); 6014 } 6015 break; 6016 6017 case N_Reference: 6018 /* Like 'Access as far as we are concerned. */ 6019 gnu_result = gnat_to_gnu (Prefix (gnat_node)); 6020 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); 6021 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6022 break; 6023 6024 case N_Aggregate: 6025 case N_Extension_Aggregate: 6026 { 6027 tree gnu_aggr_type; 6028 6029 /* ??? It is wrong to evaluate the type now, but there doesn't 6030 seem to be any other practical way of doing it. */ 6031 6032 gcc_assert (!Expansion_Delayed (gnat_node)); 6033 6034 gnu_aggr_type = gnu_result_type 6035 = get_unpadded_type (Etype (gnat_node)); 6036 6037 if (TREE_CODE (gnu_result_type) == RECORD_TYPE 6038 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type)) 6039 gnu_aggr_type 6040 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type))); 6041 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE) 6042 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type); 6043 6044 if (Null_Record_Present (gnat_node)) 6045 gnu_result = gnat_build_constructor (gnu_aggr_type, 6046 NULL); 6047 6048 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE 6049 || TREE_CODE (gnu_aggr_type) == UNION_TYPE) 6050 gnu_result 6051 = assoc_to_constructor (Etype (gnat_node), 6052 First (Component_Associations (gnat_node)), 6053 gnu_aggr_type); 6054 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE) 6055 gnu_result = pos_to_constructor (First (Expressions (gnat_node)), 6056 gnu_aggr_type, 6057 Component_Type (Etype (gnat_node))); 6058 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE) 6059 gnu_result 6060 = build_binary_op 6061 (COMPLEX_EXPR, gnu_aggr_type, 6062 gnat_to_gnu (Expression (First 6063 (Component_Associations (gnat_node)))), 6064 gnat_to_gnu (Expression 6065 (Next 6066 (First (Component_Associations (gnat_node)))))); 6067 else 6068 gcc_unreachable (); 6069 6070 gnu_result = convert (gnu_result_type, gnu_result); 6071 } 6072 break; 6073 6074 case N_Null: 6075 if (TARGET_VTABLE_USES_DESCRIPTORS 6076 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type 6077 && Is_Dispatch_Table_Entity (Etype (gnat_node))) 6078 gnu_result = null_fdesc_node; 6079 else 6080 gnu_result = null_pointer_node; 6081 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6082 break; 6083 6084 case N_Type_Conversion: 6085 case N_Qualified_Expression: 6086 /* Get the operand expression. */ 6087 gnu_result = gnat_to_gnu (Expression (gnat_node)); 6088 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6089 6090 /* If this is a qualified expression for a tagged type, we mark the type 6091 as used. Because of polymorphism, this might be the only reference to 6092 the tagged type in the program while objects have it as dynamic type. 6093 The debugger needs to see it to display these objects properly. */ 6094 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node))) 6095 used_types_insert (gnu_result_type); 6096 6097 gnu_result 6098 = convert_with_check (Etype (gnat_node), gnu_result, 6099 Do_Overflow_Check (gnat_node), 6100 Do_Range_Check (Expression (gnat_node)), 6101 kind == N_Type_Conversion 6102 && Float_Truncate (gnat_node), gnat_node); 6103 break; 6104 6105 case N_Unchecked_Type_Conversion: 6106 gnu_result = gnat_to_gnu (Expression (gnat_node)); 6107 6108 /* Skip further processing if the conversion is deemed a no-op. */ 6109 if (unchecked_conversion_nop (gnat_node)) 6110 { 6111 gnu_result_type = TREE_TYPE (gnu_result); 6112 break; 6113 } 6114 6115 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6116 6117 /* If the result is a pointer type, see if we are improperly 6118 converting to a stricter alignment. */ 6119 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type) 6120 && IN (Ekind (Etype (gnat_node)), Access_Kind)) 6121 { 6122 unsigned int align = known_alignment (gnu_result); 6123 tree gnu_obj_type = TREE_TYPE (gnu_result_type); 6124 unsigned int oalign = TYPE_ALIGN (gnu_obj_type); 6125 6126 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type)) 6127 post_error_ne_tree_2 6128 ("?source alignment (^) '< alignment of & (^)", 6129 gnat_node, Designated_Type (Etype (gnat_node)), 6130 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT); 6131 } 6132 6133 /* If we are converting a descriptor to a function pointer, first 6134 build the pointer. */ 6135 if (TARGET_VTABLE_USES_DESCRIPTORS 6136 && TREE_TYPE (gnu_result) == fdesc_type_node 6137 && POINTER_TYPE_P (gnu_result_type)) 6138 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result); 6139 6140 gnu_result = unchecked_convert (gnu_result_type, gnu_result, 6141 No_Truncation (gnat_node)); 6142 break; 6143 6144 case N_In: 6145 case N_Not_In: 6146 { 6147 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node)); 6148 Node_Id gnat_range = Right_Opnd (gnat_node); 6149 tree gnu_low, gnu_high; 6150 6151 /* GNAT_RANGE is either an N_Range node or an identifier denoting a 6152 subtype. */ 6153 if (Nkind (gnat_range) == N_Range) 6154 { 6155 gnu_low = gnat_to_gnu (Low_Bound (gnat_range)); 6156 gnu_high = gnat_to_gnu (High_Bound (gnat_range)); 6157 } 6158 else if (Nkind (gnat_range) == N_Identifier 6159 || Nkind (gnat_range) == N_Expanded_Name) 6160 { 6161 tree gnu_range_type = get_unpadded_type (Entity (gnat_range)); 6162 tree gnu_range_base_type = get_base_type (gnu_range_type); 6163 6164 gnu_low 6165 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type)); 6166 gnu_high 6167 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type)); 6168 } 6169 else 6170 gcc_unreachable (); 6171 6172 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6173 6174 /* If LOW and HIGH are identical, perform an equality test. Otherwise, 6175 ensure that GNU_OBJ is evaluated only once and perform a full range 6176 test. */ 6177 if (operand_equal_p (gnu_low, gnu_high, 0)) 6178 gnu_result 6179 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low); 6180 else 6181 { 6182 tree t1, t2; 6183 gnu_obj = gnat_protect_expr (gnu_obj); 6184 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low); 6185 if (EXPR_P (t1)) 6186 set_expr_location_from_node (t1, gnat_node); 6187 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high); 6188 if (EXPR_P (t2)) 6189 set_expr_location_from_node (t2, gnat_node); 6190 gnu_result 6191 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2); 6192 } 6193 6194 if (kind == N_Not_In) 6195 gnu_result 6196 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result); 6197 } 6198 break; 6199 6200 case N_Op_Divide: 6201 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); 6202 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); 6203 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6204 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type) 6205 ? RDIV_EXPR 6206 : (Rounded_Result (gnat_node) 6207 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR), 6208 gnu_result_type, gnu_lhs, gnu_rhs); 6209 break; 6210 6211 case N_Op_Or: case N_Op_And: case N_Op_Xor: 6212 /* These can either be operations on booleans or on modular types. 6213 Fall through for boolean types since that's the way GNU_CODES is 6214 set up. */ 6215 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node)))) 6216 { 6217 enum tree_code code 6218 = (kind == N_Op_Or ? BIT_IOR_EXPR 6219 : kind == N_Op_And ? BIT_AND_EXPR 6220 : BIT_XOR_EXPR); 6221 6222 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); 6223 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); 6224 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6225 gnu_result = build_binary_op (code, gnu_result_type, 6226 gnu_lhs, gnu_rhs); 6227 break; 6228 } 6229 6230 /* ... fall through ... */ 6231 6232 case N_Op_Eq: case N_Op_Ne: case N_Op_Lt: 6233 case N_Op_Le: case N_Op_Gt: case N_Op_Ge: 6234 case N_Op_Add: case N_Op_Subtract: case N_Op_Multiply: 6235 case N_Op_Mod: case N_Op_Rem: 6236 case N_Op_Rotate_Left: 6237 case N_Op_Rotate_Right: 6238 case N_Op_Shift_Left: 6239 case N_Op_Shift_Right: 6240 case N_Op_Shift_Right_Arithmetic: 6241 case N_And_Then: case N_Or_Else: 6242 { 6243 enum tree_code code = gnu_codes[kind]; 6244 bool ignore_lhs_overflow = false; 6245 location_t saved_location = input_location; 6246 tree gnu_type; 6247 6248 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node)); 6249 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node)); 6250 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6251 6252 /* Pending generic support for efficient vector logical operations in 6253 GCC, convert vectors to their representative array type view and 6254 fallthrough. */ 6255 gnu_lhs = maybe_vector_array (gnu_lhs); 6256 gnu_rhs = maybe_vector_array (gnu_rhs); 6257 6258 /* If this is a comparison operator, convert any references to an 6259 unconstrained array value into a reference to the actual array. */ 6260 if (TREE_CODE_CLASS (code) == tcc_comparison) 6261 { 6262 gnu_lhs = maybe_unconstrained_array (gnu_lhs); 6263 gnu_rhs = maybe_unconstrained_array (gnu_rhs); 6264 } 6265 6266 /* If this is a shift whose count is not guaranteed to be correct, 6267 we need to adjust the shift count. */ 6268 if (IN (kind, N_Op_Shift) && !Shift_Count_OK (gnat_node)) 6269 { 6270 tree gnu_count_type = get_base_type (TREE_TYPE (gnu_rhs)); 6271 tree gnu_max_shift 6272 = convert (gnu_count_type, TYPE_SIZE (gnu_type)); 6273 6274 if (kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right) 6275 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, gnu_count_type, 6276 gnu_rhs, gnu_max_shift); 6277 else if (kind == N_Op_Shift_Right_Arithmetic) 6278 gnu_rhs 6279 = build_binary_op 6280 (MIN_EXPR, gnu_count_type, 6281 build_binary_op (MINUS_EXPR, 6282 gnu_count_type, 6283 gnu_max_shift, 6284 convert (gnu_count_type, 6285 integer_one_node)), 6286 gnu_rhs); 6287 } 6288 6289 /* For right shifts, the type says what kind of shift to do, 6290 so we may need to choose a different type. In this case, 6291 we have to ignore integer overflow lest it propagates all 6292 the way down and causes a CE to be explicitly raised. */ 6293 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type)) 6294 { 6295 gnu_type = gnat_unsigned_type (gnu_type); 6296 ignore_lhs_overflow = true; 6297 } 6298 else if (kind == N_Op_Shift_Right_Arithmetic 6299 && TYPE_UNSIGNED (gnu_type)) 6300 { 6301 gnu_type = gnat_signed_type (gnu_type); 6302 ignore_lhs_overflow = true; 6303 } 6304 6305 if (gnu_type != gnu_result_type) 6306 { 6307 tree gnu_old_lhs = gnu_lhs; 6308 gnu_lhs = convert (gnu_type, gnu_lhs); 6309 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow) 6310 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs); 6311 gnu_rhs = convert (gnu_type, gnu_rhs); 6312 } 6313 6314 /* Instead of expanding overflow checks for addition, subtraction 6315 and multiplication itself, the front end will leave this to 6316 the back end when Backend_Overflow_Checks_On_Target is set. 6317 As the GCC back end itself does not know yet how to properly 6318 do overflow checking, do it here. The goal is to push 6319 the expansions further into the back end over time. */ 6320 if (Do_Overflow_Check (gnat_node) && Backend_Overflow_Checks_On_Target 6321 && (kind == N_Op_Add 6322 || kind == N_Op_Subtract 6323 || kind == N_Op_Multiply) 6324 && !TYPE_UNSIGNED (gnu_type) 6325 && !FLOAT_TYPE_P (gnu_type)) 6326 gnu_result = build_binary_op_trapv (code, gnu_type, 6327 gnu_lhs, gnu_rhs, gnat_node); 6328 else 6329 { 6330 /* Some operations, e.g. comparisons of arrays, generate complex 6331 trees that need to be annotated while they are being built. */ 6332 input_location = saved_location; 6333 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs); 6334 } 6335 6336 /* If this is a logical shift with the shift count not verified, 6337 we must return zero if it is too large. We cannot compensate 6338 above in this case. */ 6339 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right) 6340 && !Shift_Count_OK (gnat_node)) 6341 gnu_result 6342 = build_cond_expr 6343 (gnu_type, 6344 build_binary_op (GE_EXPR, boolean_type_node, 6345 gnu_rhs, 6346 convert (TREE_TYPE (gnu_rhs), 6347 TYPE_SIZE (gnu_type))), 6348 convert (gnu_type, integer_zero_node), 6349 gnu_result); 6350 } 6351 break; 6352 6353 case N_If_Expression: 6354 { 6355 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node))); 6356 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node)))); 6357 tree gnu_false 6358 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node))))); 6359 6360 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6361 gnu_result 6362 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false); 6363 } 6364 break; 6365 6366 case N_Op_Plus: 6367 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node)); 6368 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6369 break; 6370 6371 case N_Op_Not: 6372 /* This case can apply to a boolean or a modular type. 6373 Fall through for a boolean operand since GNU_CODES is set 6374 up to handle this. */ 6375 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node)))) 6376 { 6377 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); 6378 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6379 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type, 6380 gnu_expr); 6381 break; 6382 } 6383 6384 /* ... fall through ... */ 6385 6386 case N_Op_Minus: case N_Op_Abs: 6387 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node)); 6388 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6389 6390 if (Do_Overflow_Check (gnat_node) 6391 && !TYPE_UNSIGNED (gnu_result_type) 6392 && !FLOAT_TYPE_P (gnu_result_type)) 6393 gnu_result 6394 = build_unary_op_trapv (gnu_codes[kind], 6395 gnu_result_type, gnu_expr, gnat_node); 6396 else 6397 gnu_result = build_unary_op (gnu_codes[kind], 6398 gnu_result_type, gnu_expr); 6399 break; 6400 6401 case N_Allocator: 6402 { 6403 tree gnu_init = 0; 6404 tree gnu_type; 6405 bool ignore_init_type = false; 6406 6407 gnat_temp = Expression (gnat_node); 6408 6409 /* The Expression operand can either be an N_Identifier or 6410 Expanded_Name, which must represent a type, or a 6411 N_Qualified_Expression, which contains both the object type and an 6412 initial value for the object. */ 6413 if (Nkind (gnat_temp) == N_Identifier 6414 || Nkind (gnat_temp) == N_Expanded_Name) 6415 gnu_type = gnat_to_gnu_type (Entity (gnat_temp)); 6416 else if (Nkind (gnat_temp) == N_Qualified_Expression) 6417 { 6418 Entity_Id gnat_desig_type 6419 = Designated_Type (Underlying_Type (Etype (gnat_node))); 6420 6421 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type); 6422 gnu_init = gnat_to_gnu (Expression (gnat_temp)); 6423 6424 gnu_init = maybe_unconstrained_array (gnu_init); 6425 if (Do_Range_Check (Expression (gnat_temp))) 6426 gnu_init 6427 = emit_range_check (gnu_init, gnat_desig_type, gnat_temp); 6428 6429 if (Is_Elementary_Type (gnat_desig_type) 6430 || Is_Constrained (gnat_desig_type)) 6431 gnu_type = gnat_to_gnu_type (gnat_desig_type); 6432 else 6433 { 6434 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp))); 6435 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE) 6436 gnu_type = TREE_TYPE (gnu_init); 6437 } 6438 6439 /* See the N_Qualified_Expression case for the rationale. */ 6440 if (Is_Tagged_Type (gnat_desig_type)) 6441 used_types_insert (gnu_type); 6442 6443 gnu_init = convert (gnu_type, gnu_init); 6444 } 6445 else 6446 gcc_unreachable (); 6447 6448 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 6449 return build_allocator (gnu_type, gnu_init, gnu_result_type, 6450 Procedure_To_Call (gnat_node), 6451 Storage_Pool (gnat_node), gnat_node, 6452 ignore_init_type); 6453 } 6454 break; 6455 6456 /**************************/ 6457 /* Chapter 5: Statements */ 6458 /**************************/ 6459 6460 case N_Label: 6461 gnu_result = build1 (LABEL_EXPR, void_type_node, 6462 gnat_to_gnu (Identifier (gnat_node))); 6463 break; 6464 6465 case N_Null_Statement: 6466 /* When not optimizing, turn null statements from source into gotos to 6467 the next statement that the middle-end knows how to preserve. */ 6468 if (!optimize && Comes_From_Source (gnat_node)) 6469 { 6470 tree stmt, label = create_label_decl (NULL_TREE, gnat_node); 6471 DECL_IGNORED_P (label) = 1; 6472 start_stmt_group (); 6473 stmt = build1 (GOTO_EXPR, void_type_node, label); 6474 set_expr_location_from_node (stmt, gnat_node); 6475 add_stmt (stmt); 6476 stmt = build1 (LABEL_EXPR, void_type_node, label); 6477 set_expr_location_from_node (stmt, gnat_node); 6478 add_stmt (stmt); 6479 gnu_result = end_stmt_group (); 6480 } 6481 else 6482 gnu_result = alloc_stmt_list (); 6483 break; 6484 6485 case N_Assignment_Statement: 6486 /* Get the LHS and RHS of the statement and convert any reference to an 6487 unconstrained array into a reference to the underlying array. */ 6488 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node))); 6489 6490 /* If the type has a size that overflows, convert this into raise of 6491 Storage_Error: execution shouldn't have gotten here anyway. */ 6492 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST 6493 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs)))) 6494 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node, 6495 N_Raise_Storage_Error); 6496 else if (Nkind (Expression (gnat_node)) == N_Function_Call) 6497 gnu_result 6498 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs, 6499 atomic_sync_required_p (Name (gnat_node))); 6500 else 6501 { 6502 const Node_Id gnat_expr = Expression (gnat_node); 6503 const Entity_Id gnat_type 6504 = Underlying_Type (Etype (Name (gnat_node))); 6505 const bool regular_array_type_p 6506 = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type)); 6507 const bool use_memset_p 6508 = (regular_array_type_p 6509 && Nkind (gnat_expr) == N_Aggregate 6510 && Is_Others_Aggregate (gnat_expr)); 6511 6512 /* If we'll use memset, we need to find the inner expression. */ 6513 if (use_memset_p) 6514 { 6515 Node_Id gnat_inner 6516 = Expression (First (Component_Associations (gnat_expr))); 6517 while (Nkind (gnat_inner) == N_Aggregate 6518 && Is_Others_Aggregate (gnat_inner)) 6519 gnat_inner 6520 = Expression (First (Component_Associations (gnat_inner))); 6521 gnu_rhs = gnat_to_gnu (gnat_inner); 6522 } 6523 else 6524 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr)); 6525 6526 /* If range check is needed, emit code to generate it. */ 6527 if (Do_Range_Check (gnat_expr)) 6528 gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)), 6529 gnat_node); 6530 6531 /* If atomic synchronization is required, build an atomic store. */ 6532 if (atomic_sync_required_p (Name (gnat_node))) 6533 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs); 6534 6535 /* Or else, use memset when the conditions are met. */ 6536 else if (use_memset_p) 6537 { 6538 tree value = fold_convert (integer_type_node, gnu_rhs); 6539 tree to = gnu_lhs; 6540 tree type = TREE_TYPE (to); 6541 tree size 6542 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), to); 6543 tree to_ptr = build_fold_addr_expr (to); 6544 tree t = builtin_decl_explicit (BUILT_IN_MEMSET); 6545 if (TREE_CODE (value) == INTEGER_CST) 6546 { 6547 tree mask 6548 = build_int_cst (integer_type_node, 6549 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1); 6550 value = int_const_binop (BIT_AND_EXPR, value, mask); 6551 } 6552 gnu_result = build_call_expr (t, 3, to_ptr, value, size); 6553 } 6554 6555 /* Otherwise build a regular assignment. */ 6556 else 6557 gnu_result 6558 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); 6559 6560 /* If the assignment type is a regular array and the two sides are 6561 not completely disjoint, play safe and use memmove. But don't do 6562 it for a bit-packed array as it might not be byte-aligned. */ 6563 if (TREE_CODE (gnu_result) == MODIFY_EXPR 6564 && regular_array_type_p 6565 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node))) 6566 { 6567 tree to = TREE_OPERAND (gnu_result, 0); 6568 tree from = TREE_OPERAND (gnu_result, 1); 6569 tree type = TREE_TYPE (from); 6570 tree size 6571 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from); 6572 tree to_ptr = build_fold_addr_expr (to); 6573 tree from_ptr = build_fold_addr_expr (from); 6574 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE); 6575 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size); 6576 } 6577 } 6578 break; 6579 6580 case N_If_Statement: 6581 { 6582 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */ 6583 6584 /* Make the outer COND_EXPR. Avoid non-determinism. */ 6585 gnu_result = build3 (COND_EXPR, void_type_node, 6586 gnat_to_gnu (Condition (gnat_node)), 6587 NULL_TREE, NULL_TREE); 6588 COND_EXPR_THEN (gnu_result) 6589 = build_stmt_group (Then_Statements (gnat_node), false); 6590 TREE_SIDE_EFFECTS (gnu_result) = 1; 6591 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result); 6592 6593 /* Now make a COND_EXPR for each of the "else if" parts. Put each 6594 into the previous "else" part and point to where to put any 6595 outer "else". Also avoid non-determinism. */ 6596 if (Present (Elsif_Parts (gnat_node))) 6597 for (gnat_temp = First (Elsif_Parts (gnat_node)); 6598 Present (gnat_temp); gnat_temp = Next (gnat_temp)) 6599 { 6600 gnu_expr = build3 (COND_EXPR, void_type_node, 6601 gnat_to_gnu (Condition (gnat_temp)), 6602 NULL_TREE, NULL_TREE); 6603 COND_EXPR_THEN (gnu_expr) 6604 = build_stmt_group (Then_Statements (gnat_temp), false); 6605 TREE_SIDE_EFFECTS (gnu_expr) = 1; 6606 set_expr_location_from_node (gnu_expr, gnat_temp); 6607 *gnu_else_ptr = gnu_expr; 6608 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr); 6609 } 6610 6611 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false); 6612 } 6613 break; 6614 6615 case N_Case_Statement: 6616 gnu_result = Case_Statement_to_gnu (gnat_node); 6617 break; 6618 6619 case N_Loop_Statement: 6620 gnu_result = Loop_Statement_to_gnu (gnat_node); 6621 break; 6622 6623 case N_Block_Statement: 6624 /* The only way to enter the block is to fall through to it. */ 6625 if (stmt_group_may_fallthru ()) 6626 { 6627 start_stmt_group (); 6628 gnat_pushlevel (); 6629 process_decls (Declarations (gnat_node), Empty, Empty, true, true); 6630 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); 6631 gnat_poplevel (); 6632 gnu_result = end_stmt_group (); 6633 } 6634 else 6635 gnu_result = alloc_stmt_list (); 6636 break; 6637 6638 case N_Exit_Statement: 6639 gnu_result 6640 = build2 (EXIT_STMT, void_type_node, 6641 (Present (Condition (gnat_node)) 6642 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE), 6643 (Present (Name (gnat_node)) 6644 ? get_gnu_tree (Entity (Name (gnat_node))) 6645 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt))); 6646 break; 6647 6648 case N_Simple_Return_Statement: 6649 { 6650 tree gnu_ret_obj, gnu_ret_val; 6651 6652 /* If the subprogram is a function, we must return the expression. */ 6653 if (Present (Expression (gnat_node))) 6654 { 6655 tree gnu_subprog_type = TREE_TYPE (current_function_decl); 6656 6657 /* If this function has copy-in/copy-out parameters parameters and 6658 doesn't return by invisible reference, get the real object for 6659 the return. See Subprogram_Body_to_gnu. */ 6660 if (TYPE_CI_CO_LIST (gnu_subprog_type) 6661 && !TREE_ADDRESSABLE (gnu_subprog_type)) 6662 gnu_ret_obj = gnu_return_var_stack->last (); 6663 else 6664 gnu_ret_obj = DECL_RESULT (current_function_decl); 6665 6666 /* Get the GCC tree for the expression to be returned. */ 6667 gnu_ret_val = gnat_to_gnu (Expression (gnat_node)); 6668 6669 /* Do not remove the padding from GNU_RET_VAL if the inner type is 6670 self-referential since we want to allocate the fixed size. */ 6671 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF 6672 && TYPE_IS_PADDING_P 6673 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))) 6674 && CONTAINS_PLACEHOLDER_P 6675 (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))) 6676 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0); 6677 6678 /* If the function returns by direct reference, return a pointer 6679 to the return value. */ 6680 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type) 6681 || By_Ref (gnat_node)) 6682 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val); 6683 6684 /* Otherwise, if it returns an unconstrained array, we have to 6685 allocate a new version of the result and return it. */ 6686 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)) 6687 { 6688 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val); 6689 6690 /* And find out whether this is a candidate for Named Return 6691 Value. If so, record it. */ 6692 if (!TYPE_CI_CO_LIST (gnu_subprog_type) && optimize) 6693 { 6694 tree ret_val = gnu_ret_val; 6695 6696 /* Strip useless conversions around the return value. */ 6697 if (gnat_useless_type_conversion (ret_val)) 6698 ret_val = TREE_OPERAND (ret_val, 0); 6699 6700 /* Strip unpadding around the return value. */ 6701 if (TREE_CODE (ret_val) == COMPONENT_REF 6702 && TYPE_IS_PADDING_P 6703 (TREE_TYPE (TREE_OPERAND (ret_val, 0)))) 6704 ret_val = TREE_OPERAND (ret_val, 0); 6705 6706 /* Now apply the test to the return value. */ 6707 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val)) 6708 { 6709 if (!f_named_ret_val) 6710 f_named_ret_val = BITMAP_GGC_ALLOC (); 6711 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val)); 6712 if (!f_gnat_ret) 6713 f_gnat_ret = gnat_node; 6714 } 6715 } 6716 6717 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val), 6718 gnu_ret_val, 6719 TREE_TYPE (gnu_ret_obj), 6720 Procedure_To_Call (gnat_node), 6721 Storage_Pool (gnat_node), 6722 gnat_node, false); 6723 } 6724 6725 /* Otherwise, if it returns by invisible reference, dereference 6726 the pointer it is passed using the type of the return value 6727 and build the copy operation manually. This ensures that we 6728 don't copy too much data, for example if the return type is 6729 unconstrained with a maximum size. */ 6730 else if (TREE_ADDRESSABLE (gnu_subprog_type)) 6731 { 6732 tree gnu_ret_deref 6733 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val), 6734 gnu_ret_obj); 6735 gnu_result = build2 (MODIFY_EXPR, void_type_node, 6736 gnu_ret_deref, gnu_ret_val); 6737 add_stmt_with_node (gnu_result, gnat_node); 6738 gnu_ret_val = NULL_TREE; 6739 } 6740 } 6741 6742 else 6743 gnu_ret_obj = gnu_ret_val = NULL_TREE; 6744 6745 /* If we have a return label defined, convert this into a branch to 6746 that label. The return proper will be handled elsewhere. */ 6747 if (gnu_return_label_stack->last ()) 6748 { 6749 if (gnu_ret_val) 6750 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_ret_obj, 6751 gnu_ret_val)); 6752 6753 gnu_result = build1 (GOTO_EXPR, void_type_node, 6754 gnu_return_label_stack->last ()); 6755 6756 /* When not optimizing, make sure the return is preserved. */ 6757 if (!optimize && Comes_From_Source (gnat_node)) 6758 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0; 6759 } 6760 6761 /* Otherwise, build a regular return. */ 6762 else 6763 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val); 6764 } 6765 break; 6766 6767 case N_Goto_Statement: 6768 gnu_result 6769 = build1 (GOTO_EXPR, void_type_node, gnat_to_gnu (Name (gnat_node))); 6770 break; 6771 6772 /***************************/ 6773 /* Chapter 6: Subprograms */ 6774 /***************************/ 6775 6776 case N_Subprogram_Declaration: 6777 /* Unless there is a freeze node, declare the subprogram. We consider 6778 this a "definition" even though we're not generating code for 6779 the subprogram because we will be making the corresponding GCC 6780 node here. */ 6781 6782 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node))))) 6783 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)), 6784 NULL_TREE, 1); 6785 gnu_result = alloc_stmt_list (); 6786 break; 6787 6788 case N_Abstract_Subprogram_Declaration: 6789 /* This subprogram doesn't exist for code generation purposes, but we 6790 have to elaborate the types of any parameters and result, unless 6791 they are imported types (nothing to generate in this case). 6792 6793 The parameter list may contain types with freeze nodes, e.g. not null 6794 subtypes, so the subprogram itself may carry a freeze node, in which 6795 case its elaboration must be deferred. */ 6796 6797 /* Process the parameter types first. */ 6798 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node))))) 6799 for (gnat_temp 6800 = First_Formal_With_Extras 6801 (Defining_Entity (Specification (gnat_node))); 6802 Present (gnat_temp); 6803 gnat_temp = Next_Formal_With_Extras (gnat_temp)) 6804 if (Is_Itype (Etype (gnat_temp)) 6805 && !From_Limited_With (Etype (gnat_temp))) 6806 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0); 6807 6808 /* Then the result type, set to Standard_Void_Type for procedures. */ 6809 { 6810 Entity_Id gnat_temp_type 6811 = Etype (Defining_Entity (Specification (gnat_node))); 6812 6813 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type)) 6814 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0); 6815 } 6816 6817 gnu_result = alloc_stmt_list (); 6818 break; 6819 6820 case N_Defining_Program_Unit_Name: 6821 /* For a child unit identifier go up a level to get the specification. 6822 We get this when we try to find the spec of a child unit package 6823 that is the compilation unit being compiled. */ 6824 gnu_result = gnat_to_gnu (Parent (gnat_node)); 6825 break; 6826 6827 case N_Subprogram_Body: 6828 Subprogram_Body_to_gnu (gnat_node); 6829 gnu_result = alloc_stmt_list (); 6830 break; 6831 6832 case N_Function_Call: 6833 case N_Procedure_Call_Statement: 6834 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE, false); 6835 break; 6836 6837 /************************/ 6838 /* Chapter 7: Packages */ 6839 /************************/ 6840 6841 case N_Package_Declaration: 6842 gnu_result = gnat_to_gnu (Specification (gnat_node)); 6843 break; 6844 6845 case N_Package_Specification: 6846 6847 start_stmt_group (); 6848 process_decls (Visible_Declarations (gnat_node), 6849 Private_Declarations (gnat_node), Empty, true, true); 6850 gnu_result = end_stmt_group (); 6851 break; 6852 6853 case N_Package_Body: 6854 6855 /* If this is the body of a generic package - do nothing. */ 6856 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package) 6857 { 6858 gnu_result = alloc_stmt_list (); 6859 break; 6860 } 6861 6862 start_stmt_group (); 6863 process_decls (Declarations (gnat_node), Empty, Empty, true, true); 6864 6865 if (Present (Handled_Statement_Sequence (gnat_node))) 6866 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node))); 6867 6868 gnu_result = end_stmt_group (); 6869 break; 6870 6871 /********************************/ 6872 /* Chapter 8: Visibility Rules */ 6873 /********************************/ 6874 6875 case N_Use_Package_Clause: 6876 case N_Use_Type_Clause: 6877 /* Nothing to do here - but these may appear in list of declarations. */ 6878 gnu_result = alloc_stmt_list (); 6879 break; 6880 6881 /*********************/ 6882 /* Chapter 9: Tasks */ 6883 /*********************/ 6884 6885 case N_Protected_Type_Declaration: 6886 gnu_result = alloc_stmt_list (); 6887 break; 6888 6889 case N_Single_Task_Declaration: 6890 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); 6891 gnu_result = alloc_stmt_list (); 6892 break; 6893 6894 /*********************************************************/ 6895 /* Chapter 10: Program Structure and Compilation Issues */ 6896 /*********************************************************/ 6897 6898 case N_Compilation_Unit: 6899 /* This is not called for the main unit on which gigi is invoked. */ 6900 Compilation_Unit_to_gnu (gnat_node); 6901 gnu_result = alloc_stmt_list (); 6902 break; 6903 6904 case N_Subprogram_Body_Stub: 6905 case N_Package_Body_Stub: 6906 case N_Protected_Body_Stub: 6907 case N_Task_Body_Stub: 6908 /* Simply process whatever unit is being inserted. */ 6909 if (Present (Library_Unit (gnat_node))) 6910 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node))); 6911 else 6912 { 6913 gcc_assert (type_annotate_only); 6914 gnu_result = alloc_stmt_list (); 6915 } 6916 break; 6917 6918 case N_Subunit: 6919 gnu_result = gnat_to_gnu (Proper_Body (gnat_node)); 6920 break; 6921 6922 /***************************/ 6923 /* Chapter 11: Exceptions */ 6924 /***************************/ 6925 6926 case N_Handled_Sequence_Of_Statements: 6927 /* If there is an At_End procedure attached to this node, and the EH 6928 mechanism is SJLJ, we must have at least a corresponding At_End 6929 handler, unless the No_Exception_Handlers restriction is set. */ 6930 gcc_assert (type_annotate_only 6931 || Exception_Mechanism != Setjmp_Longjmp 6932 || No (At_End_Proc (gnat_node)) 6933 || Present (Exception_Handlers (gnat_node)) 6934 || No_Exception_Handlers_Set ()); 6935 6936 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node); 6937 break; 6938 6939 case N_Exception_Handler: 6940 if (Exception_Mechanism == Setjmp_Longjmp) 6941 gnu_result = Exception_Handler_to_gnu_sjlj (gnat_node); 6942 else if (Exception_Mechanism == Back_End_Exceptions) 6943 gnu_result = Exception_Handler_to_gnu_zcx (gnat_node); 6944 else 6945 gcc_unreachable (); 6946 break; 6947 6948 case N_Raise_Statement: 6949 /* Only for reraise in back-end exceptions mode. */ 6950 gcc_assert (No (Name (gnat_node)) 6951 && Exception_Mechanism == Back_End_Exceptions); 6952 6953 start_stmt_group (); 6954 gnat_pushlevel (); 6955 6956 /* Clear the current exception pointer so that the occurrence won't be 6957 deallocated. */ 6958 gnu_expr = create_var_decl (get_identifier ("SAVED_EXPTR"), NULL_TREE, 6959 ptr_type_node, gnu_incoming_exc_ptr, 6960 false, false, false, false, NULL, gnat_node); 6961 6962 add_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_incoming_exc_ptr, 6963 convert (ptr_type_node, integer_zero_node))); 6964 add_stmt (build_call_n_expr (reraise_zcx_decl, 1, gnu_expr)); 6965 gnat_poplevel (); 6966 gnu_result = end_stmt_group (); 6967 break; 6968 6969 case N_Push_Constraint_Error_Label: 6970 push_exception_label_stack (&gnu_constraint_error_label_stack, 6971 Exception_Label (gnat_node)); 6972 break; 6973 6974 case N_Push_Storage_Error_Label: 6975 push_exception_label_stack (&gnu_storage_error_label_stack, 6976 Exception_Label (gnat_node)); 6977 break; 6978 6979 case N_Push_Program_Error_Label: 6980 push_exception_label_stack (&gnu_program_error_label_stack, 6981 Exception_Label (gnat_node)); 6982 break; 6983 6984 case N_Pop_Constraint_Error_Label: 6985 gnu_constraint_error_label_stack->pop (); 6986 break; 6987 6988 case N_Pop_Storage_Error_Label: 6989 gnu_storage_error_label_stack->pop (); 6990 break; 6991 6992 case N_Pop_Program_Error_Label: 6993 gnu_program_error_label_stack->pop (); 6994 break; 6995 6996 /******************************/ 6997 /* Chapter 12: Generic Units */ 6998 /******************************/ 6999 7000 case N_Generic_Function_Renaming_Declaration: 7001 case N_Generic_Package_Renaming_Declaration: 7002 case N_Generic_Procedure_Renaming_Declaration: 7003 case N_Generic_Package_Declaration: 7004 case N_Generic_Subprogram_Declaration: 7005 case N_Package_Instantiation: 7006 case N_Procedure_Instantiation: 7007 case N_Function_Instantiation: 7008 /* These nodes can appear on a declaration list but there is nothing to 7009 to be done with them. */ 7010 gnu_result = alloc_stmt_list (); 7011 break; 7012 7013 /**************************************************/ 7014 /* Chapter 13: Representation Clauses and */ 7015 /* Implementation-Dependent Features */ 7016 /**************************************************/ 7017 7018 case N_Attribute_Definition_Clause: 7019 gnu_result = alloc_stmt_list (); 7020 7021 /* The only one we need to deal with is 'Address since, for the others, 7022 the front-end puts the information elsewhere. */ 7023 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address) 7024 break; 7025 7026 /* And we only deal with 'Address if the object has a Freeze node. */ 7027 gnat_temp = Entity (Name (gnat_node)); 7028 if (No (Freeze_Node (gnat_temp))) 7029 break; 7030 7031 /* Get the value to use as the address and save it as the equivalent 7032 for the object. When it is frozen, gnat_to_gnu_entity will do the 7033 right thing. */ 7034 save_gnu_tree (gnat_temp, gnat_to_gnu (Expression (gnat_node)), true); 7035 break; 7036 7037 case N_Enumeration_Representation_Clause: 7038 case N_Record_Representation_Clause: 7039 case N_At_Clause: 7040 /* We do nothing with these. SEM puts the information elsewhere. */ 7041 gnu_result = alloc_stmt_list (); 7042 break; 7043 7044 case N_Code_Statement: 7045 if (!type_annotate_only) 7046 { 7047 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node)); 7048 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE; 7049 tree gnu_clobbers = NULL_TREE, tail; 7050 bool allows_mem, allows_reg, fake; 7051 int ninputs, noutputs, i; 7052 const char **oconstraints; 7053 const char *constraint; 7054 char *clobber; 7055 7056 /* First retrieve the 3 operand lists built by the front-end. */ 7057 Setup_Asm_Outputs (gnat_node); 7058 while (Present (gnat_temp = Asm_Output_Variable ())) 7059 { 7060 tree gnu_value = gnat_to_gnu (gnat_temp); 7061 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu 7062 (Asm_Output_Constraint ())); 7063 7064 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs); 7065 Next_Asm_Output (); 7066 } 7067 7068 Setup_Asm_Inputs (gnat_node); 7069 while (Present (gnat_temp = Asm_Input_Value ())) 7070 { 7071 tree gnu_value = gnat_to_gnu (gnat_temp); 7072 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu 7073 (Asm_Input_Constraint ())); 7074 7075 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs); 7076 Next_Asm_Input (); 7077 } 7078 7079 Clobber_Setup (gnat_node); 7080 while ((clobber = Clobber_Get_Next ())) 7081 gnu_clobbers 7082 = tree_cons (NULL_TREE, 7083 build_string (strlen (clobber) + 1, clobber), 7084 gnu_clobbers); 7085 7086 /* Then perform some standard checking and processing on the 7087 operands. In particular, mark them addressable if needed. */ 7088 gnu_outputs = nreverse (gnu_outputs); 7089 noutputs = list_length (gnu_outputs); 7090 gnu_inputs = nreverse (gnu_inputs); 7091 ninputs = list_length (gnu_inputs); 7092 oconstraints = XALLOCAVEC (const char *, noutputs); 7093 7094 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail)) 7095 { 7096 tree output = TREE_VALUE (tail); 7097 constraint 7098 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); 7099 oconstraints[i] = constraint; 7100 7101 if (parse_output_constraint (&constraint, i, ninputs, noutputs, 7102 &allows_mem, &allows_reg, &fake)) 7103 { 7104 /* If the operand is going to end up in memory, 7105 mark it addressable. Note that we don't test 7106 allows_mem like in the input case below; this 7107 is modelled on the C front-end. */ 7108 if (!allows_reg) 7109 { 7110 output = remove_conversions (output, false); 7111 if (TREE_CODE (output) == CONST_DECL 7112 && DECL_CONST_CORRESPONDING_VAR (output)) 7113 output = DECL_CONST_CORRESPONDING_VAR (output); 7114 if (!gnat_mark_addressable (output)) 7115 output = error_mark_node; 7116 } 7117 } 7118 else 7119 output = error_mark_node; 7120 7121 TREE_VALUE (tail) = output; 7122 } 7123 7124 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail)) 7125 { 7126 tree input = TREE_VALUE (tail); 7127 constraint 7128 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail))); 7129 7130 if (parse_input_constraint (&constraint, i, ninputs, noutputs, 7131 0, oconstraints, 7132 &allows_mem, &allows_reg)) 7133 { 7134 /* If the operand is going to end up in memory, 7135 mark it addressable. */ 7136 if (!allows_reg && allows_mem) 7137 { 7138 input = remove_conversions (input, false); 7139 if (TREE_CODE (input) == CONST_DECL 7140 && DECL_CONST_CORRESPONDING_VAR (input)) 7141 input = DECL_CONST_CORRESPONDING_VAR (input); 7142 if (!gnat_mark_addressable (input)) 7143 input = error_mark_node; 7144 } 7145 } 7146 else 7147 input = error_mark_node; 7148 7149 TREE_VALUE (tail) = input; 7150 } 7151 7152 gnu_result = build5 (ASM_EXPR, void_type_node, 7153 gnu_template, gnu_outputs, 7154 gnu_inputs, gnu_clobbers, NULL_TREE); 7155 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node); 7156 } 7157 else 7158 gnu_result = alloc_stmt_list (); 7159 7160 break; 7161 7162 /****************/ 7163 /* Added Nodes */ 7164 /****************/ 7165 7166 case N_Expression_With_Actions: 7167 /* This construct doesn't define a scope so we don't push a binding 7168 level around the statement list, but we wrap it in a SAVE_EXPR to 7169 protect it from unsharing. Elaborate the expression as part of the 7170 same statement group as the actions so that the type declaration 7171 gets inserted there as well. This ensures that the type elaboration 7172 code is issued past the actions computing values on which it might 7173 depend. */ 7174 7175 start_stmt_group (); 7176 add_stmt_list (Actions (gnat_node)); 7177 gnu_expr = gnat_to_gnu (Expression (gnat_node)); 7178 gnu_result = end_stmt_group (); 7179 7180 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result); 7181 TREE_SIDE_EFFECTS (gnu_result) = 1; 7182 7183 gnu_result 7184 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr); 7185 gnu_result_type = get_unpadded_type (Etype (gnat_node)); 7186 break; 7187 7188 case N_Freeze_Entity: 7189 start_stmt_group (); 7190 process_freeze_entity (gnat_node); 7191 process_decls (Actions (gnat_node), Empty, Empty, true, true); 7192 gnu_result = end_stmt_group (); 7193 break; 7194 7195 case N_Freeze_Generic_Entity: 7196 gnu_result = alloc_stmt_list (); 7197 break; 7198 7199 case N_Itype_Reference: 7200 if (!present_gnu_tree (Itype (gnat_node))) 7201 process_type (Itype (gnat_node)); 7202 7203 gnu_result = alloc_stmt_list (); 7204 break; 7205 7206 case N_Free_Statement: 7207 if (!type_annotate_only) 7208 { 7209 tree gnu_ptr = gnat_to_gnu (Expression (gnat_node)); 7210 tree gnu_ptr_type = TREE_TYPE (gnu_ptr); 7211 tree gnu_obj_type, gnu_actual_obj_type; 7212 7213 /* If this is a thin pointer, we must first dereference it to create 7214 a fat pointer, then go back below to a thin pointer. The reason 7215 for this is that we need to have a fat pointer someplace in order 7216 to properly compute the size. */ 7217 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) 7218 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE, 7219 build_unary_op (INDIRECT_REF, NULL_TREE, 7220 gnu_ptr)); 7221 7222 /* If this is a fat pointer, the object must have been allocated with 7223 the template in front of the array. So pass the template address, 7224 and get the total size; do it by converting to a thin pointer. */ 7225 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr))) 7226 gnu_ptr 7227 = convert (build_pointer_type 7228 (TYPE_OBJECT_RECORD_TYPE 7229 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))), 7230 gnu_ptr); 7231 7232 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr)); 7233 7234 /* If this is a thin pointer, the object must have been allocated with 7235 the template in front of the array. So pass the template address, 7236 and get the total size. */ 7237 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr))) 7238 gnu_ptr 7239 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr), 7240 gnu_ptr, 7241 fold_build1 (NEGATE_EXPR, sizetype, 7242 byte_position 7243 (DECL_CHAIN 7244 TYPE_FIELDS ((gnu_obj_type))))); 7245 7246 /* If we have a special dynamic constrained subtype on the node, use 7247 it to compute the size; otherwise, use the designated subtype. */ 7248 if (Present (Actual_Designated_Subtype (gnat_node))) 7249 { 7250 gnu_actual_obj_type 7251 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node)); 7252 7253 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)) 7254 gnu_actual_obj_type 7255 = build_unc_object_type_from_ptr (gnu_ptr_type, 7256 gnu_actual_obj_type, 7257 get_identifier ("DEALLOC"), 7258 false); 7259 } 7260 else 7261 gnu_actual_obj_type = gnu_obj_type; 7262 7263 gnu_result 7264 = build_call_alloc_dealloc (gnu_ptr, 7265 TYPE_SIZE_UNIT (gnu_actual_obj_type), 7266 gnu_obj_type, 7267 Procedure_To_Call (gnat_node), 7268 Storage_Pool (gnat_node), 7269 gnat_node); 7270 } 7271 break; 7272 7273 case N_Raise_Constraint_Error: 7274 case N_Raise_Program_Error: 7275 case N_Raise_Storage_Error: 7276 if (type_annotate_only) 7277 gnu_result = alloc_stmt_list (); 7278 else 7279 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type); 7280 break; 7281 7282 case N_Validate_Unchecked_Conversion: 7283 /* The only validation we currently do on an unchecked conversion is 7284 that of aliasing assumptions. */ 7285 if (flag_strict_aliasing) 7286 gnat_validate_uc_list.safe_push (gnat_node); 7287 gnu_result = alloc_stmt_list (); 7288 break; 7289 7290 case N_Function_Specification: 7291 case N_Procedure_Specification: 7292 case N_Op_Concat: 7293 case N_Component_Association: 7294 case N_Protected_Body: 7295 case N_Task_Body: 7296 /* These nodes should only be present when annotating types. */ 7297 gcc_assert (type_annotate_only); 7298 gnu_result = alloc_stmt_list (); 7299 break; 7300 7301 default: 7302 /* Other nodes are not supposed to reach here. */ 7303 gcc_unreachable (); 7304 } 7305 7306 /* If we pushed the processing of the elaboration routine, pop it back. */ 7307 if (went_into_elab_proc) 7308 current_function_decl = NULL_TREE; 7309 7310 /* When not optimizing, turn boolean rvalues B into B != false tests 7311 so that the code just below can put the location information of the 7312 reference to B on the inequality operator for better debug info. */ 7313 if (!optimize 7314 && TREE_CODE (gnu_result) != INTEGER_CST 7315 && (kind == N_Identifier 7316 || kind == N_Expanded_Name 7317 || kind == N_Explicit_Dereference 7318 || kind == N_Function_Call 7319 || kind == N_Indexed_Component 7320 || kind == N_Selected_Component) 7321 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE 7322 && !lvalue_required_p (gnat_node, gnu_result_type, false, false, false)) 7323 gnu_result = build_binary_op (NE_EXPR, gnu_result_type, 7324 convert (gnu_result_type, gnu_result), 7325 convert (gnu_result_type, 7326 boolean_false_node)); 7327 7328 /* Set the location information on the result. Note that we may have 7329 no result if we tried to build a CALL_EXPR node to a procedure with 7330 no side-effects and optimization is enabled. */ 7331 if (gnu_result && EXPR_P (gnu_result)) 7332 set_gnu_expr_location_from_node (gnu_result, gnat_node); 7333 7334 /* If we're supposed to return something of void_type, it means we have 7335 something we're elaborating for effect, so just return. */ 7336 if (TREE_CODE (gnu_result_type) == VOID_TYPE) 7337 return gnu_result; 7338 7339 /* If the result is a constant that overflowed, raise Constraint_Error. */ 7340 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result)) 7341 { 7342 post_error ("?`Constraint_Error` will be raised at run time", gnat_node); 7343 gnu_result 7344 = build1 (NULL_EXPR, gnu_result_type, 7345 build_call_raise (CE_Overflow_Check_Failed, gnat_node, 7346 N_Raise_Constraint_Error)); 7347 } 7348 7349 /* If the result has side-effects and is of an unconstrained type, make a 7350 SAVE_EXPR so that we can be sure it will only be referenced once. But 7351 this is useless for a call to a function that returns an unconstrained 7352 type with default discriminant, as we cannot compute the size of the 7353 actual returned object. We must do this before any conversions. */ 7354 if (TREE_SIDE_EFFECTS (gnu_result) 7355 && !(TREE_CODE (gnu_result) == CALL_EXPR 7356 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) 7357 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE 7358 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))) 7359 gnu_result = gnat_stabilize_reference (gnu_result, false, NULL); 7360 7361 /* Now convert the result to the result type, unless we are in one of the 7362 following cases: 7363 7364 1. If this is the LHS of an assignment or an actual parameter of a 7365 call, return the result almost unmodified since the RHS will have 7366 to be converted to our type in that case, unless the result type 7367 has a simpler size. Likewise if there is just a no-op unchecked 7368 conversion in-between. Similarly, don't convert integral types 7369 that are the operands of an unchecked conversion since we need 7370 to ignore those conversions (for 'Valid). 7371 7372 2. If we have a label (which doesn't have any well-defined type), a 7373 field or an error, return the result almost unmodified. Similarly, 7374 if the two types are record types with the same name, don't convert. 7375 This will be the case when we are converting from a packable version 7376 of a type to its original type and we need those conversions to be 7377 NOPs in order for assignments into these types to work properly. 7378 7379 3. If the type is void or if we have no result, return error_mark_node 7380 to show we have no result. 7381 7382 4. If this a call to a function that returns an unconstrained type with 7383 default discriminant, return the call expression unmodified since we 7384 cannot compute the size of the actual returned object. 7385 7386 5. Finally, if the type of the result is already correct. */ 7387 7388 if (Present (Parent (gnat_node)) 7389 && (lhs_or_actual_p (gnat_node) 7390 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion 7391 && unchecked_conversion_nop (Parent (gnat_node))) 7392 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion 7393 && !AGGREGATE_TYPE_P (gnu_result_type) 7394 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))) 7395 && !(TYPE_SIZE (gnu_result_type) 7396 && TYPE_SIZE (TREE_TYPE (gnu_result)) 7397 && (AGGREGATE_TYPE_P (gnu_result_type) 7398 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))) 7399 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST 7400 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result))) 7401 != INTEGER_CST)) 7402 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST 7403 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)) 7404 && (CONTAINS_PLACEHOLDER_P 7405 (TYPE_SIZE (TREE_TYPE (gnu_result)))))) 7406 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE 7407 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type)))) 7408 { 7409 /* Remove padding only if the inner object is of self-referential 7410 size: in that case it must be an object of unconstrained type 7411 with a default discriminant and we want to avoid copying too 7412 much data. */ 7413 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) 7414 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS 7415 (TREE_TYPE (gnu_result)))))) 7416 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), 7417 gnu_result); 7418 } 7419 7420 else if (TREE_CODE (gnu_result) == LABEL_DECL 7421 || TREE_CODE (gnu_result) == FIELD_DECL 7422 || TREE_CODE (gnu_result) == ERROR_MARK 7423 || (TYPE_NAME (gnu_result_type) 7424 == TYPE_NAME (TREE_TYPE (gnu_result)) 7425 && TREE_CODE (gnu_result_type) == RECORD_TYPE 7426 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE)) 7427 { 7428 /* Remove any padding. */ 7429 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))) 7430 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))), 7431 gnu_result); 7432 } 7433 7434 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node) 7435 gnu_result = error_mark_node; 7436 7437 else if (TREE_CODE (gnu_result) == CALL_EXPR 7438 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_result)) 7439 && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))) 7440 == gnu_result_type 7441 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))) 7442 ; 7443 7444 else if (TREE_TYPE (gnu_result) != gnu_result_type) 7445 gnu_result = convert (gnu_result_type, gnu_result); 7446 7447 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */ 7448 while ((TREE_CODE (gnu_result) == NOP_EXPR 7449 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR) 7450 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result)) 7451 gnu_result = TREE_OPERAND (gnu_result, 0); 7452 7453 return gnu_result; 7454} 7455 7456/* Subroutine of above to push the exception label stack. GNU_STACK is 7457 a pointer to the stack to update and GNAT_LABEL, if present, is the 7458 label to push onto the stack. */ 7459 7460static void 7461push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label) 7462{ 7463 tree gnu_label = (Present (gnat_label) 7464 ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0) 7465 : NULL_TREE); 7466 7467 vec_safe_push (*gnu_stack, gnu_label); 7468} 7469 7470/* Record the current code position in GNAT_NODE. */ 7471 7472static void 7473record_code_position (Node_Id gnat_node) 7474{ 7475 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE); 7476 7477 add_stmt_with_node (stmt_stmt, gnat_node); 7478 save_gnu_tree (gnat_node, stmt_stmt, true); 7479} 7480 7481/* Insert the code for GNAT_NODE at the position saved for that node. */ 7482 7483static void 7484insert_code_for (Node_Id gnat_node) 7485{ 7486 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = gnat_to_gnu (gnat_node); 7487 save_gnu_tree (gnat_node, NULL_TREE, true); 7488} 7489 7490/* Start a new statement group chained to the previous group. */ 7491 7492void 7493start_stmt_group (void) 7494{ 7495 struct stmt_group *group = stmt_group_free_list; 7496 7497 /* First see if we can get one from the free list. */ 7498 if (group) 7499 stmt_group_free_list = group->previous; 7500 else 7501 group = ggc_alloc<stmt_group> (); 7502 7503 group->previous = current_stmt_group; 7504 group->stmt_list = group->block = group->cleanups = NULL_TREE; 7505 current_stmt_group = group; 7506} 7507 7508/* Add GNU_STMT to the current statement group. If it is an expression with 7509 no effects, it is ignored. */ 7510 7511void 7512add_stmt (tree gnu_stmt) 7513{ 7514 append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list); 7515} 7516 7517/* Similar, but the statement is always added, regardless of side-effects. */ 7518 7519void 7520add_stmt_force (tree gnu_stmt) 7521{ 7522 append_to_statement_list_force (gnu_stmt, ¤t_stmt_group->stmt_list); 7523} 7524 7525/* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */ 7526 7527void 7528add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node) 7529{ 7530 /* Do not emit a location for renamings that come from generic instantiation, 7531 they are likely to disturb debugging. */ 7532 if (Present (gnat_node) 7533 && !renaming_from_generic_instantiation_p (gnat_node)) 7534 set_expr_location_from_node (gnu_stmt, gnat_node); 7535 add_stmt (gnu_stmt); 7536} 7537 7538/* Similar, but the statement is always added, regardless of side-effects. */ 7539 7540void 7541add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node) 7542{ 7543 if (Present (gnat_node)) 7544 set_expr_location_from_node (gnu_stmt, gnat_node); 7545 add_stmt_force (gnu_stmt); 7546} 7547 7548/* Add a declaration statement for GNU_DECL to the current statement group. 7549 Get SLOC from Entity_Id. */ 7550 7551void 7552add_decl_expr (tree gnu_decl, Entity_Id gnat_entity) 7553{ 7554 tree type = TREE_TYPE (gnu_decl); 7555 tree gnu_stmt, gnu_init, t; 7556 7557 /* If this is a variable that Gigi is to ignore, we may have been given 7558 an ERROR_MARK. So test for it. We also might have been given a 7559 reference for a renaming. So only do something for a decl. Also 7560 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */ 7561 if (!DECL_P (gnu_decl) 7562 || (TREE_CODE (gnu_decl) == TYPE_DECL 7563 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)) 7564 return; 7565 7566 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl); 7567 7568 /* If we are external or global, we don't want to output the DECL_EXPR for 7569 this DECL node since we already have evaluated the expressions in the 7570 sizes and positions as globals and doing it again would be wrong. */ 7571 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ()) 7572 { 7573 /* Mark everything as used to prevent node sharing with subprograms. 7574 Note that walk_tree knows how to deal with TYPE_DECL, but neither 7575 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */ 7576 MARK_VISITED (gnu_stmt); 7577 if (TREE_CODE (gnu_decl) == VAR_DECL 7578 || TREE_CODE (gnu_decl) == CONST_DECL) 7579 { 7580 MARK_VISITED (DECL_SIZE (gnu_decl)); 7581 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl)); 7582 MARK_VISITED (DECL_INITIAL (gnu_decl)); 7583 } 7584 /* In any case, we have to deal with our own TYPE_ADA_SIZE field. */ 7585 else if (TREE_CODE (gnu_decl) == TYPE_DECL 7586 && RECORD_OR_UNION_TYPE_P (type) 7587 && !TYPE_FAT_POINTER_P (type)) 7588 MARK_VISITED (TYPE_ADA_SIZE (type)); 7589 } 7590 else 7591 add_stmt_with_node (gnu_stmt, gnat_entity); 7592 7593 /* If this is a variable and an initializer is attached to it, it must be 7594 valid for the context. Similar to init_const in create_var_decl_1. */ 7595 if (TREE_CODE (gnu_decl) == VAR_DECL 7596 && (gnu_init = DECL_INITIAL (gnu_decl)) != NULL_TREE 7597 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init)) 7598 || (TREE_STATIC (gnu_decl) 7599 && !initializer_constant_valid_p (gnu_init, 7600 TREE_TYPE (gnu_init))))) 7601 { 7602 /* If GNU_DECL has a padded type, convert it to the unpadded 7603 type so the assignment is done properly. */ 7604 if (TYPE_IS_PADDING_P (type)) 7605 t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl); 7606 else 7607 t = gnu_decl; 7608 7609 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init); 7610 7611 DECL_INITIAL (gnu_decl) = NULL_TREE; 7612 if (TREE_READONLY (gnu_decl)) 7613 { 7614 TREE_READONLY (gnu_decl) = 0; 7615 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1; 7616 } 7617 7618 add_stmt_with_node (gnu_stmt, gnat_entity); 7619 } 7620} 7621 7622/* Callback for walk_tree to mark the visited trees rooted at *TP. */ 7623 7624static tree 7625mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) 7626{ 7627 tree t = *tp; 7628 7629 if (TREE_VISITED (t)) 7630 *walk_subtrees = 0; 7631 7632 /* Don't mark a dummy type as visited because we want to mark its sizes 7633 and fields once it's filled in. */ 7634 else if (!TYPE_IS_DUMMY_P (t)) 7635 TREE_VISITED (t) = 1; 7636 7637 if (TYPE_P (t)) 7638 TYPE_SIZES_GIMPLIFIED (t) = 1; 7639 7640 return NULL_TREE; 7641} 7642 7643/* Mark nodes rooted at T with TREE_VISITED and types as having their 7644 sized gimplified. We use this to indicate all variable sizes and 7645 positions in global types may not be shared by any subprogram. */ 7646 7647void 7648mark_visited (tree t) 7649{ 7650 walk_tree (&t, mark_visited_r, NULL, NULL); 7651} 7652 7653/* Add GNU_CLEANUP, a cleanup action, to the current code group and 7654 set its location to that of GNAT_NODE if present, but with column info 7655 cleared so that conditional branches generated as part of the cleanup 7656 code do not interfere with coverage analysis tools. */ 7657 7658static void 7659add_cleanup (tree gnu_cleanup, Node_Id gnat_node) 7660{ 7661 if (Present (gnat_node)) 7662 set_expr_location_from_node1 (gnu_cleanup, gnat_node, true); 7663 append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups); 7664} 7665 7666/* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */ 7667 7668void 7669set_block_for_group (tree gnu_block) 7670{ 7671 gcc_assert (!current_stmt_group->block); 7672 current_stmt_group->block = gnu_block; 7673} 7674 7675/* Return code corresponding to the current code group. It is normally 7676 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if 7677 BLOCK or cleanups were set. */ 7678 7679tree 7680end_stmt_group (void) 7681{ 7682 struct stmt_group *group = current_stmt_group; 7683 tree gnu_retval = group->stmt_list; 7684 7685 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there 7686 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK, 7687 make a BIND_EXPR. Note that we nest in that because the cleanup may 7688 reference variables in the block. */ 7689 if (gnu_retval == NULL_TREE) 7690 gnu_retval = alloc_stmt_list (); 7691 7692 if (group->cleanups) 7693 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval, 7694 group->cleanups); 7695 7696 if (current_stmt_group->block) 7697 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block), 7698 gnu_retval, group->block); 7699 7700 /* Remove this group from the stack and add it to the free list. */ 7701 current_stmt_group = group->previous; 7702 group->previous = stmt_group_free_list; 7703 stmt_group_free_list = group; 7704 7705 return gnu_retval; 7706} 7707 7708/* Return whether the current statement group may fall through. */ 7709 7710static inline bool 7711stmt_group_may_fallthru (void) 7712{ 7713 if (current_stmt_group->stmt_list) 7714 return block_may_fallthru (current_stmt_group->stmt_list); 7715 else 7716 return true; 7717} 7718 7719/* Add a list of statements from GNAT_LIST, a possibly-empty list of 7720 statements.*/ 7721 7722static void 7723add_stmt_list (List_Id gnat_list) 7724{ 7725 Node_Id gnat_node; 7726 7727 if (Present (gnat_list)) 7728 for (gnat_node = First (gnat_list); Present (gnat_node); 7729 gnat_node = Next (gnat_node)) 7730 add_stmt (gnat_to_gnu (gnat_node)); 7731} 7732 7733/* Build a tree from GNAT_LIST, a possibly-empty list of statements. 7734 If BINDING_P is true, push and pop a binding level around the list. */ 7735 7736static tree 7737build_stmt_group (List_Id gnat_list, bool binding_p) 7738{ 7739 start_stmt_group (); 7740 if (binding_p) 7741 gnat_pushlevel (); 7742 7743 add_stmt_list (gnat_list); 7744 if (binding_p) 7745 gnat_poplevel (); 7746 7747 return end_stmt_group (); 7748} 7749 7750/* Generate GIMPLE in place for the expression at *EXPR_P. */ 7751 7752int 7753gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, 7754 gimple_seq *post_p ATTRIBUTE_UNUSED) 7755{ 7756 tree expr = *expr_p; 7757 tree type = TREE_TYPE (expr); 7758 tree op; 7759 7760 if (IS_ADA_STMT (expr)) 7761 return gnat_gimplify_stmt (expr_p); 7762 7763 switch (TREE_CODE (expr)) 7764 { 7765 case NULL_EXPR: 7766 /* If this is an aggregate type, build a null pointer of the appropriate 7767 type and dereference it. */ 7768 if (AGGREGATE_TYPE_P (type) 7769 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) 7770 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE, 7771 convert (build_pointer_type (type), 7772 integer_zero_node)); 7773 /* Otherwise, just make a VAR_DECL. */ 7774 else 7775 { 7776 *expr_p = create_tmp_var (type, NULL); 7777 TREE_NO_WARNING (*expr_p) = 1; 7778 } 7779 7780 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p); 7781 return GS_OK; 7782 7783 case UNCONSTRAINED_ARRAY_REF: 7784 /* We should only do this if we are just elaborating for side-effects, 7785 but we can't know that yet. */ 7786 *expr_p = TREE_OPERAND (*expr_p, 0); 7787 return GS_OK; 7788 7789 case ADDR_EXPR: 7790 op = TREE_OPERAND (expr, 0); 7791 7792 /* If we are taking the address of a constant CONSTRUCTOR, make sure it 7793 is put into static memory. We know that it's going to be read-only 7794 given the semantics we have and it must be in static memory when the 7795 reference is in an elaboration procedure. */ 7796 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op)) 7797 { 7798 tree addr = build_fold_addr_expr (tree_output_constant_def (op)); 7799 *expr_p = fold_convert (type, addr); 7800 return GS_ALL_DONE; 7801 } 7802 7803 return GS_UNHANDLED; 7804 7805 case VIEW_CONVERT_EXPR: 7806 op = TREE_OPERAND (expr, 0); 7807 7808 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate 7809 type to a scalar one, explicitly create the local temporary. That's 7810 required if the type is passed by reference. */ 7811 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR) 7812 && AGGREGATE_TYPE_P (TREE_TYPE (op)) 7813 && !AGGREGATE_TYPE_P (type)) 7814 { 7815 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C"); 7816 gimple_add_tmp_var (new_var); 7817 7818 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op); 7819 gimplify_and_add (mod, pre_p); 7820 7821 TREE_OPERAND (expr, 0) = new_var; 7822 return GS_OK; 7823 } 7824 7825 return GS_UNHANDLED; 7826 7827 case DECL_EXPR: 7828 op = DECL_EXPR_DECL (expr); 7829 7830 /* The expressions for the RM bounds must be gimplified to ensure that 7831 they are properly elaborated. See gimplify_decl_expr. */ 7832 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL) 7833 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op))) 7834 switch (TREE_CODE (TREE_TYPE (op))) 7835 { 7836 case INTEGER_TYPE: 7837 case ENUMERAL_TYPE: 7838 case BOOLEAN_TYPE: 7839 case REAL_TYPE: 7840 { 7841 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val; 7842 7843 val = TYPE_RM_MIN_VALUE (type); 7844 if (val) 7845 { 7846 gimplify_one_sizepos (&val, pre_p); 7847 for (t = type; t; t = TYPE_NEXT_VARIANT (t)) 7848 SET_TYPE_RM_MIN_VALUE (t, val); 7849 } 7850 7851 val = TYPE_RM_MAX_VALUE (type); 7852 if (val) 7853 { 7854 gimplify_one_sizepos (&val, pre_p); 7855 for (t = type; t; t = TYPE_NEXT_VARIANT (t)) 7856 SET_TYPE_RM_MAX_VALUE (t, val); 7857 } 7858 7859 } 7860 break; 7861 7862 default: 7863 break; 7864 } 7865 7866 /* ... fall through ... */ 7867 7868 default: 7869 return GS_UNHANDLED; 7870 } 7871} 7872 7873/* Generate GIMPLE in place for the statement at *STMT_P. */ 7874 7875static enum gimplify_status 7876gnat_gimplify_stmt (tree *stmt_p) 7877{ 7878 tree stmt = *stmt_p; 7879 7880 switch (TREE_CODE (stmt)) 7881 { 7882 case STMT_STMT: 7883 *stmt_p = STMT_STMT_STMT (stmt); 7884 return GS_OK; 7885 7886 case LOOP_STMT: 7887 { 7888 tree gnu_start_label = create_artificial_label (input_location); 7889 tree gnu_cond = LOOP_STMT_COND (stmt); 7890 tree gnu_update = LOOP_STMT_UPDATE (stmt); 7891 tree gnu_end_label = LOOP_STMT_LABEL (stmt); 7892 7893 /* Build the condition expression from the test, if any. */ 7894 if (gnu_cond) 7895 { 7896 /* Deal with the optimization hints. */ 7897 if (LOOP_STMT_IVDEP (stmt)) 7898 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond, 7899 build_int_cst (integer_type_node, 7900 annot_expr_ivdep_kind)); 7901 if (LOOP_STMT_NO_VECTOR (stmt)) 7902 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond, 7903 build_int_cst (integer_type_node, 7904 annot_expr_no_vector_kind)); 7905 if (LOOP_STMT_VECTOR (stmt)) 7906 gnu_cond = build2 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond, 7907 build_int_cst (integer_type_node, 7908 annot_expr_vector_kind)); 7909 7910 gnu_cond 7911 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE, 7912 build1 (GOTO_EXPR, void_type_node, gnu_end_label)); 7913 } 7914 7915 /* Set to emit the statements of the loop. */ 7916 *stmt_p = NULL_TREE; 7917 7918 /* We first emit the start label and then a conditional jump to the 7919 end label if there's a top condition, then the update if it's at 7920 the top, then the body of the loop, then a conditional jump to 7921 the end label if there's a bottom condition, then the update if 7922 it's at the bottom, and finally a jump to the start label and the 7923 definition of the end label. */ 7924 append_to_statement_list (build1 (LABEL_EXPR, void_type_node, 7925 gnu_start_label), 7926 stmt_p); 7927 7928 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt)) 7929 append_to_statement_list (gnu_cond, stmt_p); 7930 7931 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt)) 7932 append_to_statement_list (gnu_update, stmt_p); 7933 7934 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p); 7935 7936 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt)) 7937 append_to_statement_list (gnu_cond, stmt_p); 7938 7939 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt)) 7940 append_to_statement_list (gnu_update, stmt_p); 7941 7942 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label); 7943 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label)); 7944 append_to_statement_list (t, stmt_p); 7945 7946 append_to_statement_list (build1 (LABEL_EXPR, void_type_node, 7947 gnu_end_label), 7948 stmt_p); 7949 return GS_OK; 7950 } 7951 7952 case EXIT_STMT: 7953 /* Build a statement to jump to the corresponding end label, then 7954 see if it needs to be conditional. */ 7955 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt)); 7956 if (EXIT_STMT_COND (stmt)) 7957 *stmt_p = build3 (COND_EXPR, void_type_node, 7958 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ()); 7959 return GS_OK; 7960 7961 default: 7962 gcc_unreachable (); 7963 } 7964} 7965 7966/* Force references to each of the entities in packages withed by GNAT_NODE. 7967 Operate recursively but check that we aren't elaborating something more 7968 than once. 7969 7970 This routine is exclusively called in type_annotate mode, to compute DDA 7971 information for types in withed units, for ASIS use. */ 7972 7973static void 7974elaborate_all_entities (Node_Id gnat_node) 7975{ 7976 Entity_Id gnat_with_clause, gnat_entity; 7977 7978 /* Process each unit only once. As we trace the context of all relevant 7979 units transitively, including generic bodies, we may encounter the 7980 same generic unit repeatedly. */ 7981 if (!present_gnu_tree (gnat_node)) 7982 save_gnu_tree (gnat_node, integer_zero_node, true); 7983 7984 /* Save entities in all context units. A body may have an implicit_with 7985 on its own spec, if the context includes a child unit, so don't save 7986 the spec twice. */ 7987 for (gnat_with_clause = First (Context_Items (gnat_node)); 7988 Present (gnat_with_clause); 7989 gnat_with_clause = Next (gnat_with_clause)) 7990 if (Nkind (gnat_with_clause) == N_With_Clause 7991 && !present_gnu_tree (Library_Unit (gnat_with_clause)) 7992 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit))) 7993 { 7994 elaborate_all_entities (Library_Unit (gnat_with_clause)); 7995 7996 if (Ekind (Entity (Name (gnat_with_clause))) == E_Package) 7997 { 7998 for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause))); 7999 Present (gnat_entity); 8000 gnat_entity = Next_Entity (gnat_entity)) 8001 if (Is_Public (gnat_entity) 8002 && Convention (gnat_entity) != Convention_Intrinsic 8003 && Ekind (gnat_entity) != E_Package 8004 && Ekind (gnat_entity) != E_Package_Body 8005 && Ekind (gnat_entity) != E_Operator 8006 && !(IN (Ekind (gnat_entity), Type_Kind) 8007 && !Is_Frozen (gnat_entity)) 8008 && !((Ekind (gnat_entity) == E_Procedure 8009 || Ekind (gnat_entity) == E_Function) 8010 && Is_Intrinsic_Subprogram (gnat_entity)) 8011 && !IN (Ekind (gnat_entity), Named_Kind) 8012 && !IN (Ekind (gnat_entity), Generic_Unit_Kind)) 8013 gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); 8014 } 8015 else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package) 8016 { 8017 Node_Id gnat_body 8018 = Corresponding_Body (Unit (Library_Unit (gnat_with_clause))); 8019 8020 /* Retrieve compilation unit node of generic body. */ 8021 while (Present (gnat_body) 8022 && Nkind (gnat_body) != N_Compilation_Unit) 8023 gnat_body = Parent (gnat_body); 8024 8025 /* If body is available, elaborate its context. */ 8026 if (Present (gnat_body)) 8027 elaborate_all_entities (gnat_body); 8028 } 8029 } 8030 8031 if (Nkind (Unit (gnat_node)) == N_Package_Body) 8032 elaborate_all_entities (Library_Unit (gnat_node)); 8033} 8034 8035/* Do the processing of GNAT_NODE, an N_Freeze_Entity. */ 8036 8037static void 8038process_freeze_entity (Node_Id gnat_node) 8039{ 8040 const Entity_Id gnat_entity = Entity (gnat_node); 8041 const Entity_Kind kind = Ekind (gnat_entity); 8042 tree gnu_old, gnu_new; 8043 8044 /* If this is a package, we need to generate code for the package. */ 8045 if (kind == E_Package) 8046 { 8047 insert_code_for 8048 (Parent (Corresponding_Body 8049 (Parent (Declaration_Node (gnat_entity))))); 8050 return; 8051 } 8052 8053 /* Don't do anything for class-wide types as they are always transformed 8054 into their root type. */ 8055 if (kind == E_Class_Wide_Type) 8056 return; 8057 8058 /* Check for an old definition. This freeze node might be for an Itype. */ 8059 gnu_old 8060 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE; 8061 8062 /* If this entity has an address representation clause, GNU_OLD is the 8063 address, so discard it here. */ 8064 if (Present (Address_Clause (gnat_entity))) 8065 gnu_old = NULL_TREE; 8066 8067 /* Don't do anything for subprograms that may have been elaborated before 8068 their freeze nodes. This can happen, for example, because of an inner 8069 call in an instance body or because of previous compilation of a spec 8070 for inlining purposes. */ 8071 if (gnu_old 8072 && ((TREE_CODE (gnu_old) == FUNCTION_DECL 8073 && (kind == E_Function || kind == E_Procedure)) 8074 || (TREE_CODE (TREE_TYPE (gnu_old)) == FUNCTION_TYPE 8075 && kind == E_Subprogram_Type))) 8076 return; 8077 8078 /* If we have a non-dummy type old tree, we have nothing to do, except 8079 aborting if this is the public view of a private type whose full view was 8080 not delayed, as this node was never delayed as it should have been. We 8081 let this happen for concurrent types and their Corresponding_Record_Type, 8082 however, because each might legitimately be elaborated before its own 8083 freeze node, e.g. while processing the other. */ 8084 if (gnu_old 8085 && !(TREE_CODE (gnu_old) == TYPE_DECL 8086 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)))) 8087 { 8088 gcc_assert ((IN (kind, Incomplete_Or_Private_Kind) 8089 && Present (Full_View (gnat_entity)) 8090 && No (Freeze_Node (Full_View (gnat_entity)))) 8091 || Is_Concurrent_Type (gnat_entity) 8092 || (IN (kind, Record_Kind) 8093 && Is_Concurrent_Record_Type (gnat_entity))); 8094 return; 8095 } 8096 8097 /* Reset the saved tree, if any, and elaborate the object or type for real. 8098 If there is a full view, elaborate it and use the result. And, if this 8099 is the root type of a class-wide type, reuse it for the latter. */ 8100 if (gnu_old) 8101 { 8102 save_gnu_tree (gnat_entity, NULL_TREE, false); 8103 8104 if (IN (kind, Incomplete_Or_Private_Kind) 8105 && Present (Full_View (gnat_entity))) 8106 { 8107 Entity_Id full_view = Full_View (gnat_entity); 8108 8109 save_gnu_tree (full_view, NULL_TREE, false); 8110 8111 if (IN (Ekind (full_view), Private_Kind) 8112 && Present (Underlying_Full_View (full_view))) 8113 { 8114 full_view = Underlying_Full_View (full_view); 8115 save_gnu_tree (full_view, NULL_TREE, false); 8116 } 8117 } 8118 8119 if (IN (kind, Type_Kind) 8120 && Present (Class_Wide_Type (gnat_entity)) 8121 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity) 8122 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false); 8123 } 8124 8125 if (IN (kind, Incomplete_Or_Private_Kind) 8126 && Present (Full_View (gnat_entity))) 8127 { 8128 Entity_Id full_view = Full_View (gnat_entity); 8129 8130 if (IN (Ekind (full_view), Private_Kind) 8131 && Present (Underlying_Full_View (full_view))) 8132 full_view = Underlying_Full_View (full_view); 8133 8134 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1); 8135 8136 /* Propagate back-annotations from full view to partial view. */ 8137 if (Unknown_Alignment (gnat_entity)) 8138 Set_Alignment (gnat_entity, Alignment (full_view)); 8139 8140 if (Unknown_Esize (gnat_entity)) 8141 Set_Esize (gnat_entity, Esize (full_view)); 8142 8143 if (Unknown_RM_Size (gnat_entity)) 8144 Set_RM_Size (gnat_entity, RM_Size (full_view)); 8145 8146 /* The above call may have defined this entity (the simplest example 8147 of this is when we have a private enumeral type since the bounds 8148 will have the public view). */ 8149 if (!present_gnu_tree (gnat_entity)) 8150 save_gnu_tree (gnat_entity, gnu_new, false); 8151 } 8152 else 8153 { 8154 tree gnu_init 8155 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration 8156 && present_gnu_tree (Declaration_Node (gnat_entity))) 8157 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE; 8158 8159 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1); 8160 } 8161 8162 if (IN (kind, Type_Kind) 8163 && Present (Class_Wide_Type (gnat_entity)) 8164 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity) 8165 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false); 8166 8167 /* If we have an old type and we've made pointers to this type, update those 8168 pointers. If this is a Taft amendment type in the main unit, we need to 8169 mark the type as used since other units referencing it don't see the full 8170 declaration and, therefore, cannot mark it as used themselves. */ 8171 if (gnu_old) 8172 { 8173 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), 8174 TREE_TYPE (gnu_new)); 8175 if (DECL_TAFT_TYPE_P (gnu_old)) 8176 used_types_insert (TREE_TYPE (gnu_new)); 8177 } 8178} 8179 8180/* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present. 8181 We make two passes, one to elaborate anything other than bodies (but 8182 we declare a function if there was no spec). The second pass 8183 elaborates the bodies. 8184 8185 GNAT_END_LIST gives the element in the list past the end. Normally, 8186 this is Empty, but can be First_Real_Statement for a 8187 Handled_Sequence_Of_Statements. 8188 8189 We make a complete pass through both lists if PASS1P is true, then make 8190 the second pass over both lists if PASS2P is true. The lists usually 8191 correspond to the public and private parts of a package. */ 8192 8193static void 8194process_decls (List_Id gnat_decls, List_Id gnat_decls2, 8195 Node_Id gnat_end_list, bool pass1p, bool pass2p) 8196{ 8197 List_Id gnat_decl_array[2]; 8198 Node_Id gnat_decl; 8199 int i; 8200 8201 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2; 8202 8203 if (pass1p) 8204 for (i = 0; i <= 1; i++) 8205 if (Present (gnat_decl_array[i])) 8206 for (gnat_decl = First (gnat_decl_array[i]); 8207 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) 8208 { 8209 /* For package specs, we recurse inside the declarations, 8210 thus taking the two pass approach inside the boundary. */ 8211 if (Nkind (gnat_decl) == N_Package_Declaration 8212 && (Nkind (Specification (gnat_decl) 8213 == N_Package_Specification))) 8214 process_decls (Visible_Declarations (Specification (gnat_decl)), 8215 Private_Declarations (Specification (gnat_decl)), 8216 Empty, true, false); 8217 8218 /* Similarly for any declarations in the actions of a 8219 freeze node. */ 8220 else if (Nkind (gnat_decl) == N_Freeze_Entity) 8221 { 8222 process_freeze_entity (gnat_decl); 8223 process_decls (Actions (gnat_decl), Empty, Empty, true, false); 8224 } 8225 8226 /* Package bodies with freeze nodes get their elaboration deferred 8227 until the freeze node, but the code must be placed in the right 8228 place, so record the code position now. */ 8229 else if (Nkind (gnat_decl) == N_Package_Body 8230 && Present (Freeze_Node (Corresponding_Spec (gnat_decl)))) 8231 record_code_position (gnat_decl); 8232 8233 else if (Nkind (gnat_decl) == N_Package_Body_Stub 8234 && Present (Library_Unit (gnat_decl)) 8235 && Present (Freeze_Node 8236 (Corresponding_Spec 8237 (Proper_Body (Unit 8238 (Library_Unit (gnat_decl))))))) 8239 record_code_position 8240 (Proper_Body (Unit (Library_Unit (gnat_decl)))); 8241 8242 /* We defer most subprogram bodies to the second pass. */ 8243 else if (Nkind (gnat_decl) == N_Subprogram_Body) 8244 { 8245 if (Acts_As_Spec (gnat_decl)) 8246 { 8247 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl); 8248 8249 if (Ekind (gnat_subprog_id) != E_Generic_Procedure 8250 && Ekind (gnat_subprog_id) != E_Generic_Function) 8251 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); 8252 } 8253 } 8254 8255 /* For bodies and stubs that act as their own specs, the entity 8256 itself must be elaborated in the first pass, because it may 8257 be used in other declarations. */ 8258 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub) 8259 { 8260 Node_Id gnat_subprog_id 8261 = Defining_Entity (Specification (gnat_decl)); 8262 8263 if (Ekind (gnat_subprog_id) != E_Subprogram_Body 8264 && Ekind (gnat_subprog_id) != E_Generic_Procedure 8265 && Ekind (gnat_subprog_id) != E_Generic_Function) 8266 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1); 8267 } 8268 8269 /* Concurrent stubs stand for the corresponding subprogram bodies, 8270 which are deferred like other bodies. */ 8271 else if (Nkind (gnat_decl) == N_Task_Body_Stub 8272 || Nkind (gnat_decl) == N_Protected_Body_Stub) 8273 ; 8274 8275 else 8276 add_stmt (gnat_to_gnu (gnat_decl)); 8277 } 8278 8279 /* Here we elaborate everything we deferred above except for package bodies, 8280 which are elaborated at their freeze nodes. Note that we must also 8281 go inside things (package specs and freeze nodes) the first pass did. */ 8282 if (pass2p) 8283 for (i = 0; i <= 1; i++) 8284 if (Present (gnat_decl_array[i])) 8285 for (gnat_decl = First (gnat_decl_array[i]); 8286 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl)) 8287 { 8288 if (Nkind (gnat_decl) == N_Subprogram_Body 8289 || Nkind (gnat_decl) == N_Subprogram_Body_Stub 8290 || Nkind (gnat_decl) == N_Task_Body_Stub 8291 || Nkind (gnat_decl) == N_Protected_Body_Stub) 8292 add_stmt (gnat_to_gnu (gnat_decl)); 8293 8294 else if (Nkind (gnat_decl) == N_Package_Declaration 8295 && (Nkind (Specification (gnat_decl) 8296 == N_Package_Specification))) 8297 process_decls (Visible_Declarations (Specification (gnat_decl)), 8298 Private_Declarations (Specification (gnat_decl)), 8299 Empty, false, true); 8300 8301 else if (Nkind (gnat_decl) == N_Freeze_Entity) 8302 process_decls (Actions (gnat_decl), Empty, Empty, false, true); 8303 } 8304} 8305 8306/* Make a unary operation of kind CODE using build_unary_op, but guard 8307 the operation by an overflow check. CODE can be one of NEGATE_EXPR 8308 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually 8309 the operation is to be performed in that type. GNAT_NODE is the gnat 8310 node conveying the source location for which the error should be 8311 signaled. */ 8312 8313static tree 8314build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand, 8315 Node_Id gnat_node) 8316{ 8317 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR); 8318 8319 operand = gnat_protect_expr (operand); 8320 8321 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node, 8322 operand, TYPE_MIN_VALUE (gnu_type)), 8323 build_unary_op (code, gnu_type, operand), 8324 CE_Overflow_Check_Failed, gnat_node); 8325} 8326 8327/* Make a binary operation of kind CODE using build_binary_op, but guard 8328 the operation by an overflow check. CODE can be one of PLUS_EXPR, 8329 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result. 8330 Usually the operation is to be performed in that type. GNAT_NODE is 8331 the GNAT node conveying the source location for which the error should 8332 be signaled. */ 8333 8334static tree 8335build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, 8336 tree right, Node_Id gnat_node) 8337{ 8338 const unsigned int precision = TYPE_PRECISION (gnu_type); 8339 tree lhs = gnat_protect_expr (left); 8340 tree rhs = gnat_protect_expr (right); 8341 tree type_max = TYPE_MAX_VALUE (gnu_type); 8342 tree type_min = TYPE_MIN_VALUE (gnu_type); 8343 tree zero = convert (gnu_type, integer_zero_node); 8344 tree gnu_expr, rhs_lt_zero, tmp1, tmp2; 8345 tree check_pos, check_neg, check; 8346 8347 /* Assert that the precision is a power of 2. */ 8348 gcc_assert ((precision & (precision - 1)) == 0); 8349 8350 /* Prefer a constant or known-positive rhs to simplify checks. */ 8351 if (!TREE_CONSTANT (rhs) 8352 && commutative_tree_code (code) 8353 && (TREE_CONSTANT (lhs) 8354 || (!tree_expr_nonnegative_p (rhs) 8355 && tree_expr_nonnegative_p (lhs)))) 8356 { 8357 tree tmp = lhs; 8358 lhs = rhs; 8359 rhs = tmp; 8360 } 8361 8362 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs); 8363 8364 /* If we can fold the expression to a constant, just return it. 8365 The caller will deal with overflow, no need to generate a check. */ 8366 if (TREE_CONSTANT (gnu_expr)) 8367 return gnu_expr; 8368 8369 rhs_lt_zero = tree_expr_nonnegative_p (rhs) 8370 ? boolean_false_node 8371 : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero); 8372 8373 /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */ 8374 8375 /* Try a few strategies that may be cheaper than the general 8376 code at the end of the function, if the rhs is not known. 8377 The strategies are: 8378 - Call library function for 64-bit multiplication (complex) 8379 - Widen, if input arguments are sufficiently small 8380 - Determine overflow using wrapped result for addition/subtraction. */ 8381 8382 if (!TREE_CONSTANT (rhs)) 8383 { 8384 /* Even for add/subtract double size to get another base type. */ 8385 const unsigned int needed_precision = precision * 2; 8386 8387 if (code == MULT_EXPR && precision == 64) 8388 { 8389 tree int_64 = gnat_type_for_size (64, 0); 8390 8391 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2, 8392 convert (int_64, lhs), 8393 convert (int_64, rhs))); 8394 } 8395 8396 if (needed_precision <= BITS_PER_WORD 8397 || (code == MULT_EXPR && needed_precision <= LONG_LONG_TYPE_SIZE)) 8398 { 8399 tree wide_type = gnat_type_for_size (needed_precision, 0); 8400 tree wide_result = build_binary_op (code, wide_type, 8401 convert (wide_type, lhs), 8402 convert (wide_type, rhs)); 8403 8404 check = build_binary_op 8405 (TRUTH_ORIF_EXPR, boolean_type_node, 8406 build_binary_op (LT_EXPR, boolean_type_node, wide_result, 8407 convert (wide_type, type_min)), 8408 build_binary_op (GT_EXPR, boolean_type_node, wide_result, 8409 convert (wide_type, type_max))); 8410 8411 return 8412 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node); 8413 } 8414 8415 if (code == PLUS_EXPR || code == MINUS_EXPR) 8416 { 8417 tree unsigned_type = gnat_type_for_size (precision, 1); 8418 tree wrapped_expr 8419 = convert (gnu_type, 8420 build_binary_op (code, unsigned_type, 8421 convert (unsigned_type, lhs), 8422 convert (unsigned_type, rhs))); 8423 8424 /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition 8425 or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */ 8426 check 8427 = build_binary_op (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero, 8428 build_binary_op (code == PLUS_EXPR 8429 ? LT_EXPR : GT_EXPR, 8430 boolean_type_node, 8431 wrapped_expr, lhs)); 8432 8433 return 8434 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node); 8435 } 8436 } 8437 8438 switch (code) 8439 { 8440 case PLUS_EXPR: 8441 /* When rhs >= 0, overflow when lhs > type_max - rhs. */ 8442 check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs, 8443 build_binary_op (MINUS_EXPR, gnu_type, 8444 type_max, rhs)), 8445 8446 /* When rhs < 0, overflow when lhs < type_min - rhs. */ 8447 check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs, 8448 build_binary_op (MINUS_EXPR, gnu_type, 8449 type_min, rhs)); 8450 break; 8451 8452 case MINUS_EXPR: 8453 /* When rhs >= 0, overflow when lhs < type_min + rhs. */ 8454 check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs, 8455 build_binary_op (PLUS_EXPR, gnu_type, 8456 type_min, rhs)), 8457 8458 /* When rhs < 0, overflow when lhs > type_max + rhs. */ 8459 check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs, 8460 build_binary_op (PLUS_EXPR, gnu_type, 8461 type_max, rhs)); 8462 break; 8463 8464 case MULT_EXPR: 8465 /* The check here is designed to be efficient if the rhs is constant, 8466 but it will work for any rhs by using integer division. 8467 Four different check expressions determine whether X * C overflows, 8468 depending on C. 8469 C == 0 => false 8470 C > 0 => X > type_max / C || X < type_min / C 8471 C == -1 => X == type_min 8472 C < -1 => X > type_min / C || X < type_max / C */ 8473 8474 tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs); 8475 tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs); 8476 8477 check_pos 8478 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, 8479 build_binary_op (NE_EXPR, boolean_type_node, zero, 8480 rhs), 8481 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, 8482 build_binary_op (GT_EXPR, 8483 boolean_type_node, 8484 lhs, tmp1), 8485 build_binary_op (LT_EXPR, 8486 boolean_type_node, 8487 lhs, tmp2))); 8488 8489 check_neg 8490 = fold_build3 (COND_EXPR, boolean_type_node, 8491 build_binary_op (EQ_EXPR, boolean_type_node, rhs, 8492 build_int_cst (gnu_type, -1)), 8493 build_binary_op (EQ_EXPR, boolean_type_node, lhs, 8494 type_min), 8495 build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, 8496 build_binary_op (GT_EXPR, 8497 boolean_type_node, 8498 lhs, tmp2), 8499 build_binary_op (LT_EXPR, 8500 boolean_type_node, 8501 lhs, tmp1))); 8502 break; 8503 8504 default: 8505 gcc_unreachable(); 8506 } 8507 8508 check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg, 8509 check_pos); 8510 8511 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node); 8512} 8513 8514/* Emit code for a range check. GNU_EXPR is the expression to be checked, 8515 GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against 8516 which we have to check. GNAT_NODE is the GNAT node conveying the source 8517 location for which the error should be signaled. */ 8518 8519static tree 8520emit_range_check (tree gnu_expr, Entity_Id gnat_range_type, Node_Id gnat_node) 8521{ 8522 tree gnu_range_type = get_unpadded_type (gnat_range_type); 8523 tree gnu_compare_type = get_base_type (TREE_TYPE (gnu_expr)); 8524 8525 /* If GNU_EXPR has GNAT_RANGE_TYPE as its base type, no check is needed. 8526 This can for example happen when translating 'Val or 'Value. */ 8527 if (gnu_compare_type == gnu_range_type) 8528 return gnu_expr; 8529 8530 /* Range checks can only be applied to types with ranges. */ 8531 gcc_assert (INTEGRAL_TYPE_P (gnu_range_type) 8532 || SCALAR_FLOAT_TYPE_P (gnu_range_type)); 8533 8534 /* If GNU_EXPR has an integral type that is narrower than GNU_RANGE_TYPE, 8535 we can't do anything since we might be truncating the bounds. No 8536 check is needed in this case. */ 8537 if (INTEGRAL_TYPE_P (TREE_TYPE (gnu_expr)) 8538 && (TYPE_PRECISION (gnu_compare_type) 8539 < TYPE_PRECISION (get_base_type (gnu_range_type)))) 8540 return gnu_expr; 8541 8542 /* Checked expressions must be evaluated only once. */ 8543 gnu_expr = gnat_protect_expr (gnu_expr); 8544 8545 /* Note that the form of the check is 8546 (not (expr >= lo)) or (not (expr <= hi)) 8547 the reason for this slightly convoluted form is that NaNs 8548 are not considered to be in range in the float case. */ 8549 return emit_check 8550 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, 8551 invert_truthvalue 8552 (build_binary_op (GE_EXPR, boolean_type_node, 8553 convert (gnu_compare_type, gnu_expr), 8554 convert (gnu_compare_type, 8555 TYPE_MIN_VALUE 8556 (gnu_range_type)))), 8557 invert_truthvalue 8558 (build_binary_op (LE_EXPR, boolean_type_node, 8559 convert (gnu_compare_type, gnu_expr), 8560 convert (gnu_compare_type, 8561 TYPE_MAX_VALUE 8562 (gnu_range_type))))), 8563 gnu_expr, CE_Range_Check_Failed, gnat_node); 8564} 8565 8566/* Emit code for an index check. GNU_ARRAY_OBJECT is the array object which 8567 we are about to index, GNU_EXPR is the index expression to be checked, 8568 GNU_LOW and GNU_HIGH are the lower and upper bounds against which GNU_EXPR 8569 has to be checked. Note that for index checking we cannot simply use the 8570 emit_range_check function (although very similar code needs to be generated 8571 in both cases) since for index checking the array type against which we are 8572 checking the indices may be unconstrained and consequently we need to get 8573 the actual index bounds from the array object itself (GNU_ARRAY_OBJECT). 8574 The place where we need to do that is in subprograms having unconstrained 8575 array formal parameters. GNAT_NODE is the GNAT node conveying the source 8576 location for which the error should be signaled. */ 8577 8578static tree 8579emit_index_check (tree gnu_array_object, tree gnu_expr, tree gnu_low, 8580 tree gnu_high, Node_Id gnat_node) 8581{ 8582 tree gnu_expr_check; 8583 8584 /* Checked expressions must be evaluated only once. */ 8585 gnu_expr = gnat_protect_expr (gnu_expr); 8586 8587 /* Must do this computation in the base type in case the expression's 8588 type is an unsigned subtypes. */ 8589 gnu_expr_check = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr); 8590 8591 /* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by 8592 the object we are handling. */ 8593 gnu_low = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_low, gnu_array_object); 8594 gnu_high = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_high, gnu_array_object); 8595 8596 return emit_check 8597 (build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, 8598 build_binary_op (LT_EXPR, boolean_type_node, 8599 gnu_expr_check, 8600 convert (TREE_TYPE (gnu_expr_check), 8601 gnu_low)), 8602 build_binary_op (GT_EXPR, boolean_type_node, 8603 gnu_expr_check, 8604 convert (TREE_TYPE (gnu_expr_check), 8605 gnu_high))), 8606 gnu_expr, CE_Index_Check_Failed, gnat_node); 8607} 8608 8609/* GNU_COND contains the condition corresponding to an access, discriminant or 8610 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR if 8611 GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true. 8612 REASON is the code that says why the exception was raised. GNAT_NODE is 8613 the GNAT node conveying the source location for which the error should be 8614 signaled. */ 8615 8616static tree 8617emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node) 8618{ 8619 tree gnu_call 8620 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error); 8621 tree gnu_result 8622 = fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond, 8623 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call, 8624 convert (TREE_TYPE (gnu_expr), integer_zero_node)), 8625 gnu_expr); 8626 8627 /* GNU_RESULT has side effects if and only if GNU_EXPR has: 8628 we don't need to evaluate it just for the check. */ 8629 TREE_SIDE_EFFECTS (gnu_result) = TREE_SIDE_EFFECTS (gnu_expr); 8630 8631 return gnu_result; 8632} 8633 8634/* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow 8635 checks if OVERFLOW_P is true and range checks if RANGE_P is true. 8636 GNAT_TYPE is known to be an integral type. If TRUNCATE_P true, do a 8637 float to integer conversion with truncation; otherwise round. 8638 GNAT_NODE is the GNAT node conveying the source location for which the 8639 error should be signaled. */ 8640 8641static tree 8642convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, 8643 bool rangep, bool truncatep, Node_Id gnat_node) 8644{ 8645 tree gnu_type = get_unpadded_type (gnat_type); 8646 tree gnu_in_type = TREE_TYPE (gnu_expr); 8647 tree gnu_in_basetype = get_base_type (gnu_in_type); 8648 tree gnu_base_type = get_base_type (gnu_type); 8649 tree gnu_result = gnu_expr; 8650 8651 /* If we are not doing any checks, the output is an integral type and the 8652 input is not a floating-point type, just do the conversion. This is 8653 required for packed array types and is simpler in all cases anyway. */ 8654 if (!rangep 8655 && !overflowp 8656 && INTEGRAL_TYPE_P (gnu_base_type) 8657 && !FLOAT_TYPE_P (gnu_in_type)) 8658 return convert (gnu_type, gnu_expr); 8659 8660 /* First convert the expression to its base type. This 8661 will never generate code, but makes the tests below much simpler. 8662 But don't do this if converting from an integer type to an unconstrained 8663 array type since then we need to get the bounds from the original 8664 (unpacked) type. */ 8665 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE) 8666 gnu_result = convert (gnu_in_basetype, gnu_result); 8667 8668 /* If overflow checks are requested, we need to be sure the result will 8669 fit in the output base type. But don't do this if the input 8670 is integer and the output floating-point. */ 8671 if (overflowp 8672 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_basetype))) 8673 { 8674 /* Ensure GNU_EXPR only gets evaluated once. */ 8675 tree gnu_input = gnat_protect_expr (gnu_result); 8676 tree gnu_cond = boolean_false_node; 8677 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_basetype); 8678 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_basetype); 8679 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type); 8680 tree gnu_out_ub = TYPE_MAX_VALUE (gnu_base_type); 8681 8682 /* Convert the lower bounds to signed types, so we're sure we're 8683 comparing them properly. Likewise, convert the upper bounds 8684 to unsigned types. */ 8685 if (INTEGRAL_TYPE_P (gnu_in_basetype) && TYPE_UNSIGNED (gnu_in_basetype)) 8686 gnu_in_lb = convert (gnat_signed_type (gnu_in_basetype), gnu_in_lb); 8687 8688 if (INTEGRAL_TYPE_P (gnu_in_basetype) 8689 && !TYPE_UNSIGNED (gnu_in_basetype)) 8690 gnu_in_ub = convert (gnat_unsigned_type (gnu_in_basetype), gnu_in_ub); 8691 8692 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type)) 8693 gnu_out_lb = convert (gnat_signed_type (gnu_base_type), gnu_out_lb); 8694 8695 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type)) 8696 gnu_out_ub = convert (gnat_unsigned_type (gnu_base_type), gnu_out_ub); 8697 8698 /* Check each bound separately and only if the result bound 8699 is tighter than the bound on the input type. Note that all the 8700 types are base types, so the bounds must be constant. Also, 8701 the comparison is done in the base type of the input, which 8702 always has the proper signedness. First check for input 8703 integer (which means output integer), output float (which means 8704 both float), or mixed, in which case we always compare. 8705 Note that we have to do the comparison which would *fail* in the 8706 case of an error since if it's an FP comparison and one of the 8707 values is a NaN or Inf, the comparison will fail. */ 8708 if (INTEGRAL_TYPE_P (gnu_in_basetype) 8709 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb) 8710 : (FLOAT_TYPE_P (gnu_base_type) 8711 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_in_lb), 8712 TREE_REAL_CST (gnu_out_lb)) 8713 : 1)) 8714 gnu_cond 8715 = invert_truthvalue 8716 (build_binary_op (GE_EXPR, boolean_type_node, 8717 gnu_input, convert (gnu_in_basetype, 8718 gnu_out_lb))); 8719 8720 if (INTEGRAL_TYPE_P (gnu_in_basetype) 8721 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub) 8722 : (FLOAT_TYPE_P (gnu_base_type) 8723 ? REAL_VALUES_LESS (TREE_REAL_CST (gnu_out_ub), 8724 TREE_REAL_CST (gnu_in_lb)) 8725 : 1)) 8726 gnu_cond 8727 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond, 8728 invert_truthvalue 8729 (build_binary_op (LE_EXPR, boolean_type_node, 8730 gnu_input, 8731 convert (gnu_in_basetype, 8732 gnu_out_ub)))); 8733 8734 if (!integer_zerop (gnu_cond)) 8735 gnu_result = emit_check (gnu_cond, gnu_input, 8736 CE_Overflow_Check_Failed, gnat_node); 8737 } 8738 8739 /* Now convert to the result base type. If this is a non-truncating 8740 float-to-integer conversion, round. */ 8741 if (INTEGRAL_TYPE_P (gnu_base_type) 8742 && FLOAT_TYPE_P (gnu_in_basetype) 8743 && !truncatep) 8744 { 8745 REAL_VALUE_TYPE half_minus_pred_half, pred_half; 8746 tree gnu_conv, gnu_zero, gnu_comp, calc_type; 8747 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half; 8748 const struct real_format *fmt; 8749 8750 /* The following calculations depend on proper rounding to even 8751 of each arithmetic operation. In order to prevent excess 8752 precision from spoiling this property, use the widest hardware 8753 floating-point type if FP_ARITH_MAY_WIDEN is true. */ 8754 calc_type 8755 = fp_arith_may_widen ? longest_float_type_node : gnu_in_basetype; 8756 8757 /* Compute the exact value calc_type'Pred (0.5) at compile time. */ 8758 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type)); 8759 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type)); 8760 REAL_ARITHMETIC (pred_half, MINUS_EXPR, dconsthalf, 8761 half_minus_pred_half); 8762 gnu_pred_half = build_real (calc_type, pred_half); 8763 8764 /* If the input is strictly negative, subtract this value 8765 and otherwise add it from the input. For 0.5, the result 8766 is exactly between 1.0 and the machine number preceding 1.0 8767 (for calc_type). Since the last bit of 1.0 is even, this 0.5 8768 will round to 1.0, while all other number with an absolute 8769 value less than 0.5 round to 0.0. For larger numbers exactly 8770 halfway between integers, rounding will always be correct as 8771 the true mathematical result will be closer to the higher 8772 integer compared to the lower one. So, this constant works 8773 for all floating-point numbers. 8774 8775 The reason to use the same constant with subtract/add instead 8776 of a positive and negative constant is to allow the comparison 8777 to be scheduled in parallel with retrieval of the constant and 8778 conversion of the input to the calc_type (if necessary). */ 8779 8780 gnu_zero = convert (gnu_in_basetype, integer_zero_node); 8781 gnu_result = gnat_protect_expr (gnu_result); 8782 gnu_conv = convert (calc_type, gnu_result); 8783 gnu_comp 8784 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero); 8785 gnu_add_pred_half 8786 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half); 8787 gnu_subtract_pred_half 8788 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half); 8789 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp, 8790 gnu_add_pred_half, gnu_subtract_pred_half); 8791 } 8792 8793 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE 8794 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type) 8795 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF) 8796 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false); 8797 else 8798 gnu_result = convert (gnu_base_type, gnu_result); 8799 8800 /* Finally, do the range check if requested. Note that if the result type 8801 is a modular type, the range check is actually an overflow check. */ 8802 if (rangep 8803 || (TREE_CODE (gnu_base_type) == INTEGER_TYPE 8804 && TYPE_MODULAR_P (gnu_base_type) && overflowp)) 8805 gnu_result = emit_range_check (gnu_result, gnat_type, gnat_node); 8806 8807 return convert (gnu_type, gnu_result); 8808} 8809 8810/* Return true if GNU_EXPR can be directly addressed. This is the case 8811 unless it is an expression involving computation or if it involves a 8812 reference to a bitfield or to an object not sufficiently aligned for 8813 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can 8814 be directly addressed as an object of this type. 8815 8816 *** Notes on addressability issues in the Ada compiler *** 8817 8818 This predicate is necessary in order to bridge the gap between Gigi 8819 and the middle-end about addressability of GENERIC trees. A tree 8820 is said to be addressable if it can be directly addressed, i.e. if 8821 its address can be taken, is a multiple of the type's alignment on 8822 strict-alignment architectures and returns the first storage unit 8823 assigned to the object represented by the tree. 8824 8825 In the C family of languages, everything is in practice addressable 8826 at the language level, except for bit-fields. This means that these 8827 compilers will take the address of any tree that doesn't represent 8828 a bit-field reference and expect the result to be the first storage 8829 unit assigned to the object. Even in cases where this will result 8830 in unaligned accesses at run time, nothing is supposed to be done 8831 and the program is considered as erroneous instead (see PR c/18287). 8832 8833 The implicit assumptions made in the middle-end are in keeping with 8834 the C viewpoint described above: 8835 - the address of a bit-field reference is supposed to be never 8836 taken; the compiler (generally) will stop on such a construct, 8837 - any other tree is addressable if it is formally addressable, 8838 i.e. if it is formally allowed to be the operand of ADDR_EXPR. 8839 8840 In Ada, the viewpoint is the opposite one: nothing is addressable 8841 at the language level unless explicitly declared so. This means 8842 that the compiler will both make sure that the trees representing 8843 references to addressable ("aliased" in Ada parlance) objects are 8844 addressable and make no real attempts at ensuring that the trees 8845 representing references to non-addressable objects are addressable. 8846 8847 In the first case, Ada is effectively equivalent to C and handing 8848 down the direct result of applying ADDR_EXPR to these trees to the 8849 middle-end works flawlessly. In the second case, Ada cannot afford 8850 to consider the program as erroneous if the address of trees that 8851 are not addressable is requested for technical reasons, unlike C; 8852 as a consequence, the Ada compiler must arrange for either making 8853 sure that this address is not requested in the middle-end or for 8854 compensating by inserting temporaries if it is requested in Gigi. 8855 8856 The first goal can be achieved because the middle-end should not 8857 request the address of non-addressable trees on its own; the only 8858 exception is for the invocation of low-level block operations like 8859 memcpy, for which the addressability requirements are lower since 8860 the type's alignment can be disregarded. In practice, this means 8861 that Gigi must make sure that such operations cannot be applied to 8862 non-BLKmode bit-fields. 8863 8864 The second goal is achieved by means of the addressable_p predicate, 8865 which computes whether a temporary must be inserted by Gigi when the 8866 address of a tree is requested; if so, the address of the temporary 8867 will be used in lieu of that of the original tree and some glue code 8868 generated to connect everything together. */ 8869 8870static bool 8871addressable_p (tree gnu_expr, tree gnu_type) 8872{ 8873 /* For an integral type, the size of the actual type of the object may not 8874 be greater than that of the expected type, otherwise an indirect access 8875 in the latter type wouldn't correctly set all the bits of the object. */ 8876 if (gnu_type 8877 && INTEGRAL_TYPE_P (gnu_type) 8878 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr))) 8879 return false; 8880 8881 /* The size of the actual type of the object may not be smaller than that 8882 of the expected type, otherwise an indirect access in the latter type 8883 would be larger than the object. But only record types need to be 8884 considered in practice for this case. */ 8885 if (gnu_type 8886 && TREE_CODE (gnu_type) == RECORD_TYPE 8887 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type)) 8888 return false; 8889 8890 switch (TREE_CODE (gnu_expr)) 8891 { 8892 case VAR_DECL: 8893 case PARM_DECL: 8894 case FUNCTION_DECL: 8895 case RESULT_DECL: 8896 /* All DECLs are addressable: if they are in a register, we can force 8897 them to memory. */ 8898 return true; 8899 8900 case UNCONSTRAINED_ARRAY_REF: 8901 case INDIRECT_REF: 8902 /* Taking the address of a dereference yields the original pointer. */ 8903 return true; 8904 8905 case STRING_CST: 8906 case INTEGER_CST: 8907 /* Taking the address yields a pointer to the constant pool. */ 8908 return true; 8909 8910 case CONSTRUCTOR: 8911 /* Taking the address of a static constructor yields a pointer to the 8912 tree constant pool. */ 8913 return TREE_STATIC (gnu_expr) ? true : false; 8914 8915 case NULL_EXPR: 8916 case SAVE_EXPR: 8917 case CALL_EXPR: 8918 case PLUS_EXPR: 8919 case MINUS_EXPR: 8920 case BIT_IOR_EXPR: 8921 case BIT_XOR_EXPR: 8922 case BIT_AND_EXPR: 8923 case BIT_NOT_EXPR: 8924 /* All rvalues are deemed addressable since taking their address will 8925 force a temporary to be created by the middle-end. */ 8926 return true; 8927 8928 case COMPOUND_EXPR: 8929 /* The address of a compound expression is that of its 2nd operand. */ 8930 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type); 8931 8932 case COND_EXPR: 8933 /* We accept &COND_EXPR as soon as both operands are addressable and 8934 expect the outcome to be the address of the selected operand. */ 8935 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE) 8936 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE)); 8937 8938 case COMPONENT_REF: 8939 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1)) 8940 /* Even with DECL_BIT_FIELD cleared, we have to ensure that 8941 the field is sufficiently aligned, in case it is subject 8942 to a pragma Component_Alignment. But we don't need to 8943 check the alignment of the containing record, as it is 8944 guaranteed to be not smaller than that of its most 8945 aligned field that is not a bit-field. */ 8946 && (!STRICT_ALIGNMENT 8947 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1)) 8948 >= TYPE_ALIGN (TREE_TYPE (gnu_expr)))) 8949 /* The field of a padding record is always addressable. */ 8950 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))) 8951 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); 8952 8953 case ARRAY_REF: case ARRAY_RANGE_REF: 8954 case REALPART_EXPR: case IMAGPART_EXPR: 8955 case NOP_EXPR: 8956 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE); 8957 8958 case CONVERT_EXPR: 8959 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr)) 8960 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); 8961 8962 case VIEW_CONVERT_EXPR: 8963 { 8964 /* This is addressable if we can avoid a copy. */ 8965 tree type = TREE_TYPE (gnu_expr); 8966 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0)); 8967 return (((TYPE_MODE (type) == TYPE_MODE (inner_type) 8968 && (!STRICT_ALIGNMENT 8969 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) 8970 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT)) 8971 || ((TYPE_MODE (type) == BLKmode 8972 || TYPE_MODE (inner_type) == BLKmode) 8973 && (!STRICT_ALIGNMENT 8974 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type) 8975 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT 8976 || TYPE_ALIGN_OK (type) 8977 || TYPE_ALIGN_OK (inner_type)))) 8978 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE)); 8979 } 8980 8981 default: 8982 return false; 8983 } 8984} 8985 8986/* Do the processing for the declaration of a GNAT_ENTITY, a type. If 8987 a separate Freeze node exists, delay the bulk of the processing. Otherwise 8988 make a GCC type for GNAT_ENTITY and set up the correspondence. */ 8989 8990void 8991process_type (Entity_Id gnat_entity) 8992{ 8993 tree gnu_old 8994 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0; 8995 tree gnu_new; 8996 8997 /* If we are to delay elaboration of this type, just do any 8998 elaborations needed for expressions within the declaration and 8999 make a dummy type entry for this node and its Full_View (if 9000 any) in case something points to it. Don't do this if it 9001 has already been done (the only way that can happen is if 9002 the private completion is also delayed). */ 9003 if (Present (Freeze_Node (gnat_entity)) 9004 || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) 9005 && Present (Full_View (gnat_entity)) 9006 && Present (Freeze_Node (Full_View (gnat_entity))) 9007 && !present_gnu_tree (Full_View (gnat_entity)))) 9008 { 9009 elaborate_entity (gnat_entity); 9010 9011 if (!gnu_old) 9012 { 9013 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity)); 9014 save_gnu_tree (gnat_entity, gnu_decl, false); 9015 if (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind) 9016 && Present (Full_View (gnat_entity))) 9017 { 9018 if (Has_Completion_In_Body (gnat_entity)) 9019 DECL_TAFT_TYPE_P (gnu_decl) = 1; 9020 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false); 9021 } 9022 } 9023 9024 return; 9025 } 9026 9027 /* If we saved away a dummy type for this node it means that this 9028 made the type that corresponds to the full type of an incomplete 9029 type. Clear that type for now and then update the type in the 9030 pointers. */ 9031 if (gnu_old) 9032 { 9033 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL 9034 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))); 9035 9036 save_gnu_tree (gnat_entity, NULL_TREE, false); 9037 } 9038 9039 /* Now fully elaborate the type. */ 9040 gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1); 9041 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL); 9042 9043 /* If we have an old type and we've made pointers to this type, update those 9044 pointers. If this is a Taft amendment type in the main unit, we need to 9045 mark the type as used since other units referencing it don't see the full 9046 declaration and, therefore, cannot mark it as used themselves. */ 9047 if (gnu_old) 9048 { 9049 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), 9050 TREE_TYPE (gnu_new)); 9051 if (DECL_TAFT_TYPE_P (gnu_old)) 9052 used_types_insert (TREE_TYPE (gnu_new)); 9053 } 9054 9055 /* If this is a record type corresponding to a task or protected type 9056 that is a completion of an incomplete type, perform a similar update 9057 on the type. ??? Including protected types here is a guess. */ 9058 if (IN (Ekind (gnat_entity), Record_Kind) 9059 && Is_Concurrent_Record_Type (gnat_entity) 9060 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity))) 9061 { 9062 tree gnu_task_old 9063 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)); 9064 9065 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), 9066 NULL_TREE, false); 9067 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity), 9068 gnu_new, false); 9069 9070 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)), 9071 TREE_TYPE (gnu_new)); 9072 } 9073} 9074 9075/* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the 9076 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the 9077 GCC type of the corresponding record type. Return the CONSTRUCTOR. */ 9078 9079static tree 9080assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type) 9081{ 9082 tree gnu_list = NULL_TREE, gnu_result; 9083 9084 /* We test for GNU_FIELD being empty in the case where a variant 9085 was the last thing since we don't take things off GNAT_ASSOC in 9086 that case. We check GNAT_ASSOC in case we have a variant, but it 9087 has no fields. */ 9088 9089 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc)) 9090 { 9091 Node_Id gnat_field = First (Choices (gnat_assoc)); 9092 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field)); 9093 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc)); 9094 9095 /* The expander is supposed to put a single component selector name 9096 in every record component association. */ 9097 gcc_assert (No (Next (gnat_field))); 9098 9099 /* Ignore fields that have Corresponding_Discriminants since we'll 9100 be setting that field in the parent. */ 9101 if (Present (Corresponding_Discriminant (Entity (gnat_field))) 9102 && Is_Tagged_Type (Scope (Entity (gnat_field)))) 9103 continue; 9104 9105 /* Also ignore discriminants of Unchecked_Unions. */ 9106 if (Is_Unchecked_Union (gnat_entity) 9107 && Ekind (Entity (gnat_field)) == E_Discriminant) 9108 continue; 9109 9110 /* Before assigning a value in an aggregate make sure range checks 9111 are done if required. Then convert to the type of the field. */ 9112 if (Do_Range_Check (Expression (gnat_assoc))) 9113 gnu_expr = emit_range_check (gnu_expr, Etype (gnat_field), Empty); 9114 9115 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr); 9116 9117 /* Add the field and expression to the list. */ 9118 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list); 9119 } 9120 9121 gnu_result = extract_values (gnu_list, gnu_type); 9122 9123#ifdef ENABLE_CHECKING 9124 /* Verify that every entry in GNU_LIST was used. */ 9125 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list)) 9126 gcc_assert (TREE_ADDRESSABLE (gnu_list)); 9127#endif 9128 9129 return gnu_result; 9130} 9131 9132/* Build a possibly nested constructor for array aggregates. GNAT_EXPR is 9133 the first element of an array aggregate. It may itself be an aggregate. 9134 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. 9135 GNAT_COMPONENT_TYPE is the type of the array component; it is needed 9136 for range checking. */ 9137 9138static tree 9139pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type, 9140 Entity_Id gnat_component_type) 9141{ 9142 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type)); 9143 tree gnu_expr; 9144 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL; 9145 9146 for ( ; Present (gnat_expr); gnat_expr = Next (gnat_expr)) 9147 { 9148 /* If the expression is itself an array aggregate then first build the 9149 innermost constructor if it is part of our array (multi-dimensional 9150 case). */ 9151 if (Nkind (gnat_expr) == N_Aggregate 9152 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE 9153 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type))) 9154 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)), 9155 TREE_TYPE (gnu_array_type), 9156 gnat_component_type); 9157 else 9158 { 9159 gnu_expr = gnat_to_gnu (gnat_expr); 9160 9161 /* Before assigning the element to the array, make sure it is 9162 in range. */ 9163 if (Do_Range_Check (gnat_expr)) 9164 gnu_expr = emit_range_check (gnu_expr, gnat_component_type, Empty); 9165 } 9166 9167 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index, 9168 convert (TREE_TYPE (gnu_array_type), gnu_expr)); 9169 9170 gnu_index = int_const_binop (PLUS_EXPR, gnu_index, 9171 convert (TREE_TYPE (gnu_index), 9172 integer_one_node)); 9173 } 9174 9175 return gnat_build_constructor (gnu_array_type, gnu_expr_vec); 9176} 9177 9178/* Subroutine of assoc_to_constructor: VALUES is a list of field associations, 9179 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting 9180 of the associations that are from RECORD_TYPE. If we see an internal 9181 record, make a recursive call to fill it in as well. */ 9182 9183static tree 9184extract_values (tree values, tree record_type) 9185{ 9186 tree field, tem; 9187 vec<constructor_elt, va_gc> *v = NULL; 9188 9189 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field)) 9190 { 9191 tree value = 0; 9192 9193 /* _Parent is an internal field, but may have values in the aggregate, 9194 so check for values first. */ 9195 if ((tem = purpose_member (field, values))) 9196 { 9197 value = TREE_VALUE (tem); 9198 TREE_ADDRESSABLE (tem) = 1; 9199 } 9200 9201 else if (DECL_INTERNAL_P (field)) 9202 { 9203 value = extract_values (values, TREE_TYPE (field)); 9204 if (TREE_CODE (value) == CONSTRUCTOR 9205 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value))) 9206 value = 0; 9207 } 9208 else 9209 /* If we have a record subtype, the names will match, but not the 9210 actual FIELD_DECLs. */ 9211 for (tem = values; tem; tem = TREE_CHAIN (tem)) 9212 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field)) 9213 { 9214 value = convert (TREE_TYPE (field), TREE_VALUE (tem)); 9215 TREE_ADDRESSABLE (tem) = 1; 9216 } 9217 9218 if (!value) 9219 continue; 9220 9221 CONSTRUCTOR_APPEND_ELT (v, field, value); 9222 } 9223 9224 return gnat_build_constructor (record_type, v); 9225} 9226 9227/* Process a N_Validate_Unchecked_Conversion node. */ 9228 9229static void 9230validate_unchecked_conversion (Node_Id gnat_node) 9231{ 9232 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node)); 9233 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node)); 9234 9235 /* If the target is a pointer type, see if we are either converting from a 9236 non-pointer or from a pointer to a type with a different alias set and 9237 warn if so, unless the pointer has been marked to alias everything. */ 9238 if (POINTER_TYPE_P (gnu_target_type) 9239 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type)) 9240 { 9241 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type) 9242 ? TREE_TYPE (gnu_source_type) 9243 : NULL_TREE; 9244 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type); 9245 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type); 9246 9247 if (target_alias_set != 0 9248 && (!POINTER_TYPE_P (gnu_source_type) 9249 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type), 9250 target_alias_set))) 9251 { 9252 post_error_ne ("?possible aliasing problem for type&", 9253 gnat_node, Target_Type (gnat_node)); 9254 post_error ("\\?use -fno-strict-aliasing switch for references", 9255 gnat_node); 9256 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`", 9257 gnat_node, Target_Type (gnat_node)); 9258 } 9259 } 9260 9261 /* Likewise if the target is a fat pointer type, but we have no mechanism to 9262 mitigate the problem in this case, so we unconditionally warn. */ 9263 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type)) 9264 { 9265 tree gnu_source_desig_type 9266 = TYPE_IS_FAT_POINTER_P (gnu_source_type) 9267 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type))) 9268 : NULL_TREE; 9269 tree gnu_target_desig_type 9270 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type))); 9271 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type); 9272 9273 if (target_alias_set != 0 9274 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type) 9275 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type), 9276 target_alias_set))) 9277 { 9278 post_error_ne ("?possible aliasing problem for type&", 9279 gnat_node, Target_Type (gnat_node)); 9280 post_error ("\\?use -fno-strict-aliasing switch for references", 9281 gnat_node); 9282 } 9283 } 9284} 9285 9286/* EXP is to be treated as an array or record. Handle the cases when it is 9287 an access object and perform the required dereferences. */ 9288 9289static tree 9290maybe_implicit_deref (tree exp) 9291{ 9292 /* If the type is a pointer, dereference it. */ 9293 if (POINTER_TYPE_P (TREE_TYPE (exp)) 9294 || TYPE_IS_FAT_POINTER_P (TREE_TYPE (exp))) 9295 exp = build_unary_op (INDIRECT_REF, NULL_TREE, exp); 9296 9297 /* If we got a padded type, remove it too. */ 9298 if (TYPE_IS_PADDING_P (TREE_TYPE (exp))) 9299 exp = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp); 9300 9301 return exp; 9302} 9303 9304/* Convert SLOC into LOCUS. Return true if SLOC corresponds to a source code 9305 location and false if it doesn't. In the former case, set the Gigi global 9306 variable REF_FILENAME to the simple debug file name as given by sinput. 9307 If clear_column is true, set column information to 0. */ 9308 9309static bool 9310Sloc_to_locus1 (Source_Ptr Sloc, location_t *locus, bool clear_column) 9311{ 9312 if (Sloc == No_Location) 9313 return false; 9314 9315 if (Sloc <= Standard_Location) 9316 { 9317 *locus = BUILTINS_LOCATION; 9318 return false; 9319 } 9320 else 9321 { 9322 Source_File_Index file = Get_Source_File_Index (Sloc); 9323 Logical_Line_Number line = Get_Logical_Line_Number (Sloc); 9324 Column_Number column = (clear_column ? 0 : Get_Column_Number (Sloc)); 9325 struct line_map *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1); 9326 9327 /* We can have zero if pragma Source_Reference is in effect. */ 9328 if (line < 1) 9329 line = 1; 9330 9331 /* Translate the location. */ 9332 *locus = linemap_position_for_line_and_column (map, line, column); 9333 } 9334 9335 ref_filename 9336 = IDENTIFIER_POINTER 9337 (get_identifier 9338 (Get_Name_String (Debug_Source_Name (Get_Source_File_Index (Sloc)))));; 9339 9340 return true; 9341} 9342 9343/* Similar to the above, not clearing the column information. */ 9344 9345bool 9346Sloc_to_locus (Source_Ptr Sloc, location_t *locus) 9347{ 9348 return Sloc_to_locus1 (Sloc, locus, false); 9349} 9350 9351/* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and 9352 don't do anything if it doesn't correspond to a source location. */ 9353 9354static void 9355set_expr_location_from_node1 (tree node, Node_Id gnat_node, bool clear_column) 9356{ 9357 location_t locus; 9358 9359 if (!Sloc_to_locus1 (Sloc (gnat_node), &locus, clear_column)) 9360 return; 9361 9362 SET_EXPR_LOCATION (node, locus); 9363} 9364 9365/* Similar to the above, not clearing the column information. */ 9366 9367static void 9368set_expr_location_from_node (tree node, Node_Id gnat_node) 9369{ 9370 set_expr_location_from_node1 (node, gnat_node, false); 9371} 9372 9373/* More elaborate version of set_expr_location_from_node to be used in more 9374 general contexts, for example the result of the translation of a generic 9375 GNAT node. */ 9376 9377static void 9378set_gnu_expr_location_from_node (tree node, Node_Id gnat_node) 9379{ 9380 /* Set the location information on the node if it is a real expression. 9381 References can be reused for multiple GNAT nodes and they would get 9382 the location information of their last use. Also make sure not to 9383 overwrite an existing location as it is probably more precise. */ 9384 9385 switch (TREE_CODE (node)) 9386 { 9387 CASE_CONVERT: 9388 case NON_LVALUE_EXPR: 9389 case SAVE_EXPR: 9390 break; 9391 9392 case COMPOUND_EXPR: 9393 if (EXPR_P (TREE_OPERAND (node, 1))) 9394 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node); 9395 9396 /* ... fall through ... */ 9397 9398 default: 9399 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node)) 9400 { 9401 set_expr_location_from_node (node, gnat_node); 9402 set_end_locus_from_node (node, gnat_node); 9403 } 9404 break; 9405 } 9406} 9407 9408/* Return a colon-separated list of encodings contained in encoded Ada 9409 name. */ 9410 9411static const char * 9412extract_encoding (const char *name) 9413{ 9414 char *encoding = (char *) ggc_alloc_atomic (strlen (name)); 9415 get_encoding (name, encoding); 9416 return encoding; 9417} 9418 9419/* Extract the Ada name from an encoded name. */ 9420 9421static const char * 9422decode_name (const char *name) 9423{ 9424 char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60); 9425 __gnat_decode (name, decoded, 0); 9426 return decoded; 9427} 9428 9429/* Post an error message. MSG is the error message, properly annotated. 9430 NODE is the node at which to post the error and the node to use for the 9431 '&' substitution. */ 9432 9433void 9434post_error (const char *msg, Node_Id node) 9435{ 9436 String_Template temp; 9437 String_Pointer sp; 9438 9439 if (No (node)) 9440 return; 9441 9442 temp.Low_Bound = 1; 9443 temp.High_Bound = strlen (msg); 9444 sp.Bounds = &temp; 9445 sp.Array = msg; 9446 Error_Msg_N (sp, node); 9447} 9448 9449/* Similar to post_error, but NODE is the node at which to post the error and 9450 ENT is the node to use for the '&' substitution. */ 9451 9452void 9453post_error_ne (const char *msg, Node_Id node, Entity_Id ent) 9454{ 9455 String_Template temp; 9456 String_Pointer sp; 9457 9458 if (No (node)) 9459 return; 9460 9461 temp.Low_Bound = 1; 9462 temp.High_Bound = strlen (msg); 9463 sp.Bounds = &temp; 9464 sp.Array = msg; 9465 Error_Msg_NE (sp, node, ent); 9466} 9467 9468/* Similar to post_error_ne, but NUM is the number to use for the '^'. */ 9469 9470void 9471post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num) 9472{ 9473 Error_Msg_Uint_1 = UI_From_Int (num); 9474 post_error_ne (msg, node, ent); 9475} 9476 9477/* Set the end_locus information for GNU_NODE, if any, from an explicit end 9478 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes 9479 most sense. Return true if a sensible assignment was performed. */ 9480 9481static bool 9482set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) 9483{ 9484 Node_Id gnat_end_label = Empty; 9485 location_t end_locus; 9486 9487 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node 9488 end_locus when there is one. We consider only GNAT nodes with a possible 9489 End_Label attached. If the End_Label actually was unassigned, fallback 9490 on the original node. We'd better assign an explicit sloc associated with 9491 the outer construct in any case. */ 9492 9493 switch (Nkind (gnat_node)) 9494 { 9495 case N_Package_Body: 9496 case N_Subprogram_Body: 9497 case N_Block_Statement: 9498 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node)); 9499 break; 9500 9501 case N_Package_Declaration: 9502 gnat_end_label = End_Label (Specification (gnat_node)); 9503 break; 9504 9505 default: 9506 return false; 9507 } 9508 9509 gnat_node = Present (gnat_end_label) ? gnat_end_label : gnat_node; 9510 9511 /* Some expanded subprograms have neither an End_Label nor a Sloc 9512 attached. Notify that to callers. For a block statement with no 9513 End_Label, clear column information, so that the tree for a 9514 transient block does not receive the sloc of a source condition. */ 9515 9516 if (!Sloc_to_locus1 (Sloc (gnat_node), &end_locus, 9517 No (gnat_end_label) && 9518 (Nkind (gnat_node) == N_Block_Statement))) 9519 return false; 9520 9521 switch (TREE_CODE (gnu_node)) 9522 { 9523 case BIND_EXPR: 9524 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus; 9525 return true; 9526 9527 case FUNCTION_DECL: 9528 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus; 9529 return true; 9530 9531 default: 9532 return false; 9533 } 9534} 9535 9536/* Similar to post_error_ne, but T is a GCC tree representing the number to 9537 write. If T represents a constant, the text inside curly brackets in 9538 MSG will be output (presumably including a '^'). Otherwise it will not 9539 be output and the text inside square brackets will be output instead. */ 9540 9541void 9542post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t) 9543{ 9544 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1); 9545 char start_yes, end_yes, start_no, end_no; 9546 const char *p; 9547 char *q; 9548 9549 if (TREE_CODE (t) == INTEGER_CST) 9550 { 9551 Error_Msg_Uint_1 = UI_From_gnu (t); 9552 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']'; 9553 } 9554 else 9555 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}'; 9556 9557 for (p = msg, q = new_msg; *p; p++) 9558 { 9559 if (*p == start_yes) 9560 for (p++; *p != end_yes; p++) 9561 *q++ = *p; 9562 else if (*p == start_no) 9563 for (p++; *p != end_no; p++) 9564 ; 9565 else 9566 *q++ = *p; 9567 } 9568 9569 *q = 0; 9570 9571 post_error_ne (new_msg, node, ent); 9572} 9573 9574/* Similar to post_error_ne_tree, but NUM is a second integer to write. */ 9575 9576void 9577post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t, 9578 int num) 9579{ 9580 Error_Msg_Uint_2 = UI_From_Int (num); 9581 post_error_ne_tree (msg, node, ent, t); 9582} 9583 9584/* Initialize the table that maps GNAT codes to GCC codes for simple 9585 binary and unary operations. */ 9586 9587static void 9588init_code_table (void) 9589{ 9590 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR; 9591 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR; 9592 9593 gnu_codes[N_Op_And] = TRUTH_AND_EXPR; 9594 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR; 9595 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR; 9596 gnu_codes[N_Op_Eq] = EQ_EXPR; 9597 gnu_codes[N_Op_Ne] = NE_EXPR; 9598 gnu_codes[N_Op_Lt] = LT_EXPR; 9599 gnu_codes[N_Op_Le] = LE_EXPR; 9600 gnu_codes[N_Op_Gt] = GT_EXPR; 9601 gnu_codes[N_Op_Ge] = GE_EXPR; 9602 gnu_codes[N_Op_Add] = PLUS_EXPR; 9603 gnu_codes[N_Op_Subtract] = MINUS_EXPR; 9604 gnu_codes[N_Op_Multiply] = MULT_EXPR; 9605 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR; 9606 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR; 9607 gnu_codes[N_Op_Minus] = NEGATE_EXPR; 9608 gnu_codes[N_Op_Abs] = ABS_EXPR; 9609 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR; 9610 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR; 9611 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR; 9612 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR; 9613 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR; 9614 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR; 9615} 9616 9617/* Return a label to branch to for the exception type in KIND or NULL_TREE 9618 if none. */ 9619 9620tree 9621get_exception_label (char kind) 9622{ 9623 if (kind == N_Raise_Constraint_Error) 9624 return gnu_constraint_error_label_stack->last (); 9625 else if (kind == N_Raise_Storage_Error) 9626 return gnu_storage_error_label_stack->last (); 9627 else if (kind == N_Raise_Program_Error) 9628 return gnu_program_error_label_stack->last (); 9629 else 9630 return NULL_TREE; 9631} 9632 9633/* Return the decl for the current elaboration procedure. */ 9634 9635tree 9636get_elaboration_procedure (void) 9637{ 9638 return gnu_elab_proc_stack->last (); 9639} 9640 9641#include "gt-ada-trans.h" 9642