From 471babd88668dbe4f9ff4dba6d2036ecef09653b Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 30 Mar 2021 00:41:46 +0200 Subject: Fix wrong assignment of aggregate to full-access component This is a regression present on the mainline: the compiler (front-end) fails to assign an aggregate to a full-access component (i.e. Atomic or VFA) as a whole if the type of the component is not full access itself. gcc/ada/ PR ada/99802 * freeze.adb (Is_Full_Access_Aggregate): Call Is_Full_Access_Object on the name of an N_Assignment_Statement to spot full access. --- gcc/ada/freeze.adb | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 8dc8a22..da14af9 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1754,8 +1754,7 @@ package body Freeze is Typ := Etype (Name (Par)); if not Is_Full_Access (Typ) - and then not (Is_Entity_Name (Name (Par)) - and then Is_Full_Access (Entity (Name (Par)))) + and then not Is_Full_Access_Object (Name (Par)) then return False; end if; -- cgit v1.1 From 65374af219f9c5c594951a07e766fe70c1136a1f Mon Sep 17 00:00:00 2001 From: GCC Administrator Date: Tue, 30 Mar 2021 00:16:29 +0000 Subject: Daily bump. --- gcc/ada/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2f39282..651f951 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2021-03-29 Eric Botcazou + + PR ada/99802 + * freeze.adb (Is_Full_Access_Aggregate): Call Is_Full_Access_Object + on the name of an N_Assignment_Statement to spot full access. + 2021-03-10 Eric Botcazou * gcc-interface/decl.c (gnat_to_gnu_entity): Build a TYPE_STUB_DECL -- cgit v1.1 From c660464a9ef07726a5d5217b4b39def189ec21e6 Mon Sep 17 00:00:00 2001 From: Gerald Pfeifer Date: Sun, 11 Apr 2021 11:23:41 +0200 Subject: ada: Avoid invalid "up" link in manual gcc/ada/ * gnat_ugn.texi (Top): Avoid invalid "up" link. --- gcc/ada/gnat_ugn.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 360177b..ae8f758 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -41,7 +41,7 @@ Copyright @copyright{} 2008-2021, Free Software Foundation @c %** end of user preamble @ifnottex -@node Top +@node Top, About This Guide @top GNAT User's Guide for Native Platforms @insertcopying @end ifnottex -- cgit v1.1 From a0ecde220da1edf7062ec429aa2c7a5b4103e92f Mon Sep 17 00:00:00 2001 From: GCC Administrator Date: Mon, 12 Apr 2021 00:16:27 +0000 Subject: Daily bump. --- gcc/ada/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 651f951..6972d1f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2021-04-11 Gerald Pfeifer + + * gnat_ugn.texi (Top): Avoid invalid "up" link. + 2021-03-29 Eric Botcazou PR ada/99802 -- cgit v1.1 From 39fa0de5994559d4f672a5528ea09433cbe6ec80 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 13 Apr 2021 17:07:36 +0200 Subject: Further increase the limit on the size of accepted Ada files It turns out that the limit on the size of accepted Ada files had been already lowered earlier, namely when location ranges had been introduced. Now we do not make use of location ranges in Ada so we can recoup the loss. gcc/ada/ * gcc-interface/misc.c (gnat_init): Set default range bits to 0. * gcc-interface/trans.c (extract_encoding): Delete. (decode_name): Likewise. (File_Name_to_gnu): New function. (gigi): Call it to translate file names. Replace assertion on 1-1 mapping between files and line maps with conditional error. --- gcc/ada/gcc-interface/misc.c | 3 +++ gcc/ada/gcc-interface/trans.c | 62 ++++++++++++++++--------------------------- 2 files changed, 26 insertions(+), 39 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c index d0867e0..16bccb9 100644 --- a/gcc/ada/gcc-interface/misc.c +++ b/gcc/ada/gcc-interface/misc.c @@ -370,6 +370,9 @@ gnat_init (void) sbitsize_one_node = sbitsize_int (1); sbitsize_unit_node = sbitsize_int (BITS_PER_UNIT); + /* In Ada, we do not use location ranges. */ + line_table->default_range_bits = 0; + /* Register our internal error function. */ global_dc->internal_error = &internal_error_function; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index ae7a52f..5a55ca4 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -251,17 +251,27 @@ static tree build_raise_check (int, enum exception_info_kind); static tree create_init_temporary (const char *, tree, tree *, Node_Id); static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk); -/* Hooks for debug info back-ends, only supported and used in a restricted set - of configurations. */ -static const char *extract_encoding (const char *) ATTRIBUTE_UNUSED; -static const char *decode_name (const char *) ATTRIBUTE_UNUSED; - /* This makes gigi's file_info_ptr visible in this translation unit, so that Sloc_to_locus can look it up when deciding whether to map decls to instances. */ static struct File_Info_Type *file_map; +/* Return the string of the identifier allocated for the file name Id. */ + +static const char* +File_Name_to_gnu (Name_Id Id) +{ + /* __gnat_to_canonical_file_spec translates file names from pragmas + Source_Reference that contain host style syntax not understood by GDB. */ + const char *name = __gnat_to_canonical_file_spec (Get_Name_String (Id)); + + /* Use the identifier table to make a permanent copy of the file name as + the name table gets reallocated after Gigi returns but before all the + debugging information is output. */ + return IDENTIFIER_POINTER (get_identifier (name)); +} + /* This is the main program of the back-end. It sets up all the table structures and then generates code. */ @@ -315,23 +325,18 @@ gigi (Node_Id gnat_root, for (i = 0; i < number_file; i++) { - /* Use the identifier table to make a permanent copy of the filename as - the name table gets reallocated after Gigi returns but before all the - debugging information is output. The __gnat_to_canonical_file_spec - call translates filenames from pragmas Source_Reference that contain - host style syntax not understood by gdb. */ - const char *filename - = IDENTIFIER_POINTER - (get_identifier - (__gnat_to_canonical_file_spec - (Get_Name_String (file_info_ptr[i].File_Name)))); - /* We rely on the order isomorphism between files and line maps. */ - gcc_assert ((int) LINEMAPS_ORDINARY_USED (line_table) == i); + if ((int) LINEMAPS_ORDINARY_USED (line_table) != i) + { + gcc_assert (i > 0); + error ("%s contains too many lines", + File_Name_to_gnu (file_info_ptr[i - 1].File_Name)); + } /* We create the line map for a source file at once, with a fixed number of columns chosen to avoid jumping over the next power of 2. */ - linemap_add (line_table, LC_ENTER, 0, filename, 1); + linemap_add (line_table, LC_ENTER, 0, + File_Name_to_gnu (file_info_ptr[i].File_Name), 1); linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252); linemap_position_for_column (line_table, 252 - 1); linemap_add (line_table, LC_LEAVE, 0, NULL, 0); @@ -10401,27 +10406,6 @@ set_end_locus_from_node (tree gnu_node, Node_Id gnat_node) } } -/* Return a colon-separated list of encodings contained in encoded Ada - name. */ - -static const char * -extract_encoding (const char *name) -{ - char *encoding = (char *) ggc_alloc_atomic (strlen (name)); - get_encoding (name, encoding); - return encoding; -} - -/* Extract the Ada name from an encoded name. */ - -static const char * -decode_name (const char *name) -{ - char *decoded = (char *) ggc_alloc_atomic (strlen (name) * 2 + 60); - __gnat_decode (name, decoded, 0); - return decoded; -} - /* Post an error message. MSG is the error message, properly annotated. NODE is the node at which to post the error and the node to use for the '&' substitution. */ -- cgit v1.1 From 6d0d35d518a12ee43c1fbd77df73a66d02305a69 Mon Sep 17 00:00:00 2001 From: GCC Administrator Date: Wed, 14 Apr 2021 00:16:24 +0000 Subject: Daily bump. --- gcc/ada/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6972d1f..d64ae06 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2021-04-13 Eric Botcazou + + * gcc-interface/misc.c (gnat_init): Set default range bits to 0. + * gcc-interface/trans.c (extract_encoding): Delete. + (decode_name): Likewise. + (File_Name_to_gnu): New function. + (gigi): Call it to translate file names. Replace assertion on + 1-1 mapping between files and line maps with conditional error. + 2021-04-11 Gerald Pfeifer * gnat_ugn.texi (Top): Avoid invalid "up" link. -- cgit v1.1 From 50bc1a879536de42d44c110663d8e132609435c0 Mon Sep 17 00:00:00 2001 From: Martin Liska Date: Tue, 20 Apr 2021 11:43:51 +0200 Subject: Bump version to 12. gcc/ada/ChangeLog: * gnatvsn.ads: Bump Library_Version to 12. --- gcc/ada/gnatvsn.ads | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads index bbfa9f5..c0a77bc 100644 --- a/gcc/ada/gnatvsn.ads +++ b/gcc/ada/gnatvsn.ads @@ -32,7 +32,7 @@ package Gnatvsn is -- Static string identifying this version, that can be used as an argument -- to e.g. pragma Ident. - Library_Version : constant String := "11"; + Library_Version : constant String := "12"; -- Library version. It needs to be updated whenever the major version -- number is changed. -- -- cgit v1.1 From be8aad8d73f47e2581c873ba1069489e071c2a86 Mon Sep 17 00:00:00 2001 From: GCC Administrator Date: Wed, 21 Apr 2021 00:16:23 +0000 Subject: Daily bump. --- gcc/ada/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index d64ae06..55ef853 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,7 @@ +2021-04-20 Martin Liska + + * gnatvsn.ads: Bump Library_Version to 12. + 2021-04-13 Eric Botcazou * gcc-interface/misc.c (gnat_init): Set default range bits to 0. -- cgit v1.1 From 852dd866e2faba95cb407c98d31a48b6aae66677 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 28 Apr 2021 09:43:02 +0200 Subject: Fix loss of optimization of array iteration due to inlining This helps loop-invariant motion to hoist complicated offset computations. gcc/ada/ * gcc-interface/trans.c (language_function): Add comment. (loop_info_d): Add fndecl and invariants fields. (find_loop_for): Test fndecl instead of the context of var. (find_loop): New function. (Regular_Loop_to_gnu): Fold back into... (Loop_Statement_to_gnu): ...this. Emit invariants on entry, if any. (gnat_to_gnu) : Record nonconstant invariant offset computations in loops when optimization is enabled. * gcc-interface/utils2.c (gnat_invariant_expr): Handle BIT_AND_EXPR. gcc/testsuite/ * gnat.dg/opt93.ads, gnat.dg/opt93.adb: New test. --- gcc/ada/gcc-interface/trans.c | 134 +++++++++++++++++++++++------------------ gcc/ada/gcc-interface/utils2.c | 11 ++++ 2 files changed, 87 insertions(+), 58 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 5a55ca4..4e533ce 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -112,7 +112,7 @@ struct GTY (()) parm_attr_d { typedef struct parm_attr_d *parm_attr; - +/* Structure used to record information for a function. */ struct GTY(()) language_function { vec *parm_attr_cache; bitmap named_ret_val; @@ -194,9 +194,9 @@ struct GTY(()) range_check_info_d { typedef struct range_check_info_d *range_check_info; - /* Structure used to record information for a loop. */ struct GTY(()) loop_info_d { + tree fndecl; tree stmt; tree loop_var; tree low_bound; @@ -205,11 +205,11 @@ struct GTY(()) loop_info_d { tree omp_construct_clauses; enum tree_code omp_code; vec *checks; + vec *invariants; }; typedef struct loop_info_d *loop_info; - /* Stack of loop_info structures associated with LOOP_STMT nodes. */ static GTY(()) vec *gnu_loop_stack; @@ -2768,13 +2768,27 @@ find_loop_for (tree expr, tree *disp, bool *neg_p) if (TREE_CODE (var) != VAR_DECL) return NULL; - if (decl_function_context (var) != current_function_decl) - return NULL; + gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0); + + FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter) + if (iter->loop_var == var && iter->fndecl == current_function_decl) + break; + + return iter; +} - gcc_assert (vec_safe_length (gnu_loop_stack) > 0); +/* Return the innermost enclosing loop in the current function. */ + +static struct loop_info_d * +find_loop (void) +{ + struct loop_info_d *iter = NULL; + unsigned int i; + + gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0); FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter) - if (var == iter->loop_var) + if (iter->fndecl == current_function_decl) break; return iter; @@ -2924,26 +2938,30 @@ independent_iterations_p (tree stmt_list) return true; } -/* Helper for Loop_Statement_to_gnu, to translate the body of a loop not - subject to any sort of parallelization directive or restriction, designated - by GNAT_NODE. - - We expect the top of gnu_loop_stack to hold a pointer to the loop info - setup for the translation, which holds a pointer to the initial gnu loop - stmt node. We return the new gnu loop statement to use. - - We might also set *GNU_COND_EXPR_P to request a variant of the translation - scheme in Loop_Statement_to_gnu. */ +/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, + to a GCC tree, which is returned. */ static tree -Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) +Loop_Statement_to_gnu (Node_Id gnat_node) { const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node); - struct loop_info_d *const gnu_loop_info = gnu_loop_stack->last (); - tree gnu_loop_stmt = gnu_loop_info->stmt; - tree gnu_loop_label = LOOP_STMT_LABEL (gnu_loop_stmt); - tree gnu_cond_expr = *gnu_cond_expr_p; - tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + struct loop_info_d *gnu_loop_info = ggc_cleared_alloc (); + tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, + NULL_TREE, NULL_TREE, NULL_TREE); + tree gnu_loop_label = create_artificial_label (input_location); + tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE; + tree gnu_result; + + /* Push the loop_info structure associated with the LOOP_STMT. */ + gnu_loop_info->fndecl = current_function_decl; + gnu_loop_info->stmt = gnu_loop_stmt; + vec_safe_push (gnu_loop_stack, gnu_loop_info); + + /* Set location information for statement and end label. */ + set_expr_location_from_node (gnu_loop_stmt, gnat_node); + Sloc_to_locus (Sloc (End_Label (gnat_node)), + &DECL_SOURCE_LOCATION (gnu_loop_label)); + LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; /* Set the condition under which the loop must keep going. If we have an explicit condition, use it to set the location information throughout @@ -3277,7 +3295,16 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) } } - /* Second, if loop vectorization is enabled and the iterations of the + /* Second, if we have recorded invariants to be hoisted, emit them. */ + if (vec_safe_length (gnu_loop_info->invariants) > 0) + { + tree *iter; + unsigned int i; + FOR_EACH_VEC_ELT (*gnu_loop_info->invariants, i, iter) + add_stmt_with_node_force (*iter, gnat_node); + } + + /* Third, if loop vectorization is enabled and the iterations of the loop can easily be proved as independent, mark the loop. */ if (optimize >= 3 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt))) @@ -3288,40 +3315,6 @@ Regular_Loop_to_gnu (Node_Id gnat_node, tree *gnu_cond_expr_p) gnu_loop_stmt = end_stmt_group (); } - *gnu_cond_expr_p = gnu_cond_expr; - - return gnu_loop_stmt; -} - -/* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement, - to a GCC tree, which is returned. */ - -static tree -Loop_Statement_to_gnu (Node_Id gnat_node) -{ - struct loop_info_d *gnu_loop_info = ggc_cleared_alloc (); - - tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE, - NULL_TREE, NULL_TREE, NULL_TREE); - tree gnu_cond_expr = NULL_TREE; - tree gnu_loop_label = create_artificial_label (input_location); - tree gnu_result; - - /* Push the loop_info structure associated with the LOOP_STMT. */ - vec_safe_push (gnu_loop_stack, gnu_loop_info); - - /* Set location information for statement and end label. */ - set_expr_location_from_node (gnu_loop_stmt, gnat_node); - Sloc_to_locus (Sloc (End_Label (gnat_node)), - &DECL_SOURCE_LOCATION (gnu_loop_label)); - LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label; - - /* Save the statement for later reuse. */ - gnu_loop_info->stmt = gnu_loop_stmt; - - /* Perform the core loop body translation. */ - gnu_loop_stmt = Regular_Loop_to_gnu (gnat_node, &gnu_cond_expr); - /* If we have an outer COND_EXPR, that's our result and this loop is its "true" statement. Otherwise, the result is the LOOP_STMT. */ if (gnu_cond_expr) @@ -6731,6 +6724,8 @@ gnat_to_gnu (Node_Id gnat_node) else { tree gnu_field = gnat_to_gnu_field_decl (gnat_field); + tree gnu_offset; + struct loop_info_d *loop; gnu_result = build_component_ref (gnu_prefix, gnu_field, @@ -6738,6 +6733,29 @@ gnat_to_gnu (Node_Id gnat_node) == N_Attribute_Reference) && lvalue_required_for_attribute_p (Parent (gnat_node))); + + /* If optimization is enabled and we are inside a loop, we try to + hoist nonconstant but invariant offset computations outside of + the loop, since they very likely contain loads that could turn + out to be hard to move if they end up in active EH regions. */ + if (optimize + && inside_loop_p () + && TREE_CODE (gnu_result) == COMPONENT_REF + && (gnu_offset = component_ref_field_offset (gnu_result)) + && !TREE_CONSTANT (gnu_offset) + && (gnu_offset = gnat_invariant_expr (gnu_offset)) + && (loop = find_loop ())) + { + tree invariant + = build1 (SAVE_EXPR, TREE_TYPE (gnu_offset), gnu_offset); + vec_safe_push (loop->invariants, invariant); + tree field = TREE_OPERAND (gnu_result, 1); + tree factor + = size_int (DECL_OFFSET_ALIGN (field) / BITS_PER_UNIT); + /* Divide the offset by its alignment. */ + TREE_OPERAND (gnu_result, 2) + = size_binop (EXACT_DIV_EXPR, invariant, factor); + } } gnu_result_type = get_unpadded_type (Etype (gnat_node)); diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 316033b..83cc794 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -2946,6 +2946,17 @@ gnat_invariant_expr (tree expr) if (TREE_CONSTANT (expr)) return fold_convert (type, expr); + /* Deal with aligning patterns. */ + if (TREE_CODE (expr) == BIT_AND_EXPR + && TREE_CONSTANT (TREE_OPERAND (expr, 1))) + { + tree op0 = gnat_invariant_expr (TREE_OPERAND (expr, 0)); + if (op0) + return fold_build2 (BIT_AND_EXPR, type, op0, TREE_OPERAND (expr, 1)); + else + return NULL_TREE; + } + /* Deal with addition or subtraction of constants. */ if (is_simple_additive_expression (expr, &add, &cst, &minus_p)) { -- cgit v1.1 From b81e2d5e76a6bcc71f45b122e8b5538ddb7ebf4c Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 28 Apr 2021 09:58:21 +0200 Subject: Get rid of useless temporary for call to pure function This avoids creating a useless temporary for a call to a pure function with good properties by using the RSO. gcc/ada/ * gcc-interface/trans.c (is_array_of_scalar_type): New predicate. (find_decls_r): New function. (return_slot_opt_for_pure_call_p): New predicate. (Call_to_gnu): Do not create a temporary for the return value if the parent node is an aggregate. If there is a target, try to apply the return slot optimization to regular calls to pure functions returning an array of scalar type. --- gcc/ada/gcc-interface/trans.c | 94 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 85 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 4e533ce..07f5e81 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -4377,6 +4377,69 @@ create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt, return gnu_temp; } +/* Return true if TYPE is an array of scalar type. */ + +static bool +is_array_of_scalar_type (tree type) +{ + if (TREE_CODE (type) != ARRAY_TYPE) + return false; + + type = TREE_TYPE (type); + + return !AGGREGATE_TYPE_P (type) && !POINTER_TYPE_P (type); +} + +/* Helper function for walk_tree, used by return_slot_opt_for_pure_call_p. */ + +static tree +find_decls_r (tree *tp, int *walk_subtrees, void *data) +{ + bitmap decls = (bitmap) data; + + if (TYPE_P (*tp)) + *walk_subtrees = 0; + + else if (DECL_P (*tp)) + bitmap_set_bit (decls, DECL_UID (*tp)); + + return NULL_TREE; +} + +/* Return whether the assignment TARGET = CALL can be subject to the return + slot optimization, under the assumption that the called function be pure + in the Ada sense and return an array of scalar type. */ + +static bool +return_slot_opt_for_pure_call_p (tree target, tree call) +{ + /* Check that the target is a DECL. */ + if (!DECL_P (target)) + return false; + + const bitmap decls = BITMAP_GGC_ALLOC (); + call_expr_arg_iterator iter; + tree arg; + + /* Check that all the arguments have either a scalar type (we assume that + this means by-copy passing mechanism) or array of scalar type. */ + FOR_EACH_CALL_EXPR_ARG (arg, iter, call) + { + tree arg_type = TREE_TYPE (arg); + if (TREE_CODE (arg_type) == REFERENCE_TYPE) + arg_type = TREE_TYPE (arg_type); + + if (is_array_of_scalar_type (arg_type)) + walk_tree_without_duplicates (&arg, find_decls_r, decls); + + else if (AGGREGATE_TYPE_P (arg_type) || POINTER_TYPE_P (arg_type)) + return false; + } + + /* Check that the target is not referenced by the non-scalar arguments. */ + return !bitmap_bit_p (decls, DECL_UID (target)); +} + /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call or an N_Procedure_Call_Statement, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. @@ -4501,15 +4564,16 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, because we need to preserve the return value before copying back the parameters. - 2. There is no target and the call is made for neither an object, nor a - renaming declaration, nor a return statement, nor an allocator, and - the return type has variable size because in this case the gimplifier - cannot create the temporary, or more generally is an aggregate type, - because the gimplifier would create the temporary in the outermost - scope instead of locally. But there is an exception for an allocator - of an unconstrained record type with default discriminant because we - allocate the actual size in this case, unlike the other 3 cases, so - we need a temporary to fetch the discriminant and we create it here. + 2. There is no target and the call is made for neither the declaration + of an object (regular or renaming), nor a return statement, nor an + allocator, nor an aggregate, and the return type has variable size + because in this case the gimplifier cannot create the temporary, or + more generally is an aggregate type, because the gimplifier would + create the temporary in the outermost scope instead of locally here. + But there is an exception for an allocator of unconstrained record + type with default discriminant because we allocate the actual size + in this case, unlike in the other cases, so we need a temporary to + fetch the discriminant and we create it here. 3. There is a target and it is a slice or an array with fixed size, and the return type has variable size, because the gimplifier @@ -4535,6 +4599,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, && (!(Nkind (Parent (gnat_node)) == N_Qualified_Expression && Nkind (Parent (Parent (gnat_node))) == N_Allocator) || type_is_padding_self_referential (gnu_result_type)) + && Nkind (Parent (gnat_node)) != N_Aggregate && AGGREGATE_TYPE_P (gnu_result_type) && !TYPE_IS_FAT_POINTER_P (gnu_result_type)) || (gnu_target @@ -5153,6 +5218,17 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, That's what has been done historically. */ if (return_type_with_variable_size_p (gnu_result_type)) op_code = INIT_EXPR; + + /* If this is a call to a pure function returning an array of scalar + type, try to apply the return slot optimization. */ + else if ((TYPE_READONLY (gnu_subprog_type) + || TYPE_RESTRICT (gnu_subprog_type)) + && is_array_of_scalar_type (gnu_result_type) + && TYPE_MODE (gnu_result_type) == BLKmode + && aggregate_value_p (gnu_result_type, gnu_subprog_type) + && return_slot_opt_for_pure_call_p (gnu_target, gnu_call)) + op_code = INIT_EXPR; + else op_code = MODIFY_EXPR; -- cgit v1.1 From fccc47dddc2ee605dd7fce5c1d1711404e19cd7f Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 28 Apr 2021 10:21:59 +0200 Subject: Avoid creating useless local bounds around calls This prevents the compiler from creating useless local bounds around calls that take a parameter of an unconstrained array type when the bounds already exist somewhere else for the actual parameter. gcc/ada/ * gcc-interface/decl.c (gnat_to_gnu_subprog_type): Do not demote a const or pure function because of a parameter whose type is pointer to function. * gcc-interface/trans.c (Call_to_gnu): Do not put back a conversion between an actual and a formal that are unconstrained array types. (gnat_gimplify_expr) : New case. * gcc-interface/utils2.c (build_binary_op): Do not use |= operator. (gnat_stabilize_reference_1): Likewise. (gnat_rewrite_reference): Likewise. (build_unary_op): Do not clear existing TREE_CONSTANT on the result. (gnat_build_constructor): Also accept the address of a constant CONSTRUCTOR as constant element. --- gcc/ada/gcc-interface/decl.c | 11 ++++++----- gcc/ada/gcc-interface/trans.c | 34 +++++++++++++++++++++++++++++++++- gcc/ada/gcc-interface/utils2.c | 40 +++++++++++++++++++++++++--------------- 3 files changed, 64 insertions(+), 21 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index 27ef51a..6fd5c2c 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -6059,12 +6059,13 @@ gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition, /* A pure function in the Ada sense which takes an access parameter may modify memory through it and thus need be considered neither - const nor pure in the GCC sense. Likewise it if takes a by-ref - In Out or Out parameter. But if it takes a by-ref In parameter, - then it may only read memory through it and can be considered - pure in the GCC sense. */ + const nor pure in the GCC sense, unless it's access-to-function. + Likewise it if takes a by-ref In Out or Out parameter. But if it + takes a by-ref In parameter, then it may only read memory through + it and can be considered pure in the GCC sense. */ if ((const_flag || pure_flag) - && (POINTER_TYPE_P (gnu_param_type) + && ((POINTER_TYPE_P (gnu_param_type) + && TREE_CODE (TREE_TYPE (gnu_param_type)) != FUNCTION_TYPE) || TYPE_IS_FAT_POINTER_P (gnu_param_type))) { const_flag = false; diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 07f5e81..2461259 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -4816,7 +4816,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, may have suppressed a conversion to the Etype of the actual earlier, since the parent is a procedure call, so put it back here. Note that we might have a dummy type here if the actual is the dereference of a - pointer to it, but that's OK if the formal is passed by reference. */ + pointer to it, but that's OK when the formal is passed by reference. + We also do not put back a conversion between an actual and a formal + that are unconstrained array types to avoid creating local bounds. */ tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual)); if (TYPE_IS_DUMMY_P (gnu_actual_type)) gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal)); @@ -4824,6 +4826,11 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, && Nkind (gnat_actual) == N_Unchecked_Type_Conversion) gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual, No_Truncation (gnat_actual)); + else if ((TREE_CODE (TREE_TYPE (gnu_actual)) == UNCONSTRAINED_ARRAY_TYPE + || (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE + && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual)))) + && TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE) + ; else gnu_actual = convert (gnu_actual_type, gnu_actual); @@ -8835,6 +8842,31 @@ gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p, return GS_UNHANDLED; + case CALL_EXPR: + /* If we are passing a constant fat pointer CONSTRUCTOR, make sure it is + put into static memory; this performs a restricted version of constant + propagation on fat pointers in calls. But do not do it for strings to + avoid blocking concatenation in the caller when it is inlined. */ + for (int i = 0; i < call_expr_nargs (expr); i++) + { + tree arg = *(CALL_EXPR_ARGP (expr) + i); + + if (TREE_CODE (arg) == CONSTRUCTOR + && TREE_CONSTANT (arg) + && TYPE_IS_FAT_POINTER_P (TREE_TYPE (arg))) + { + tree t = CONSTRUCTOR_ELT (arg, 0)->value; + if (TREE_CODE (t) == NOP_EXPR) + t = TREE_OPERAND (t, 0); + if (TREE_CODE (t) == ADDR_EXPR) + t = TREE_OPERAND (t, 0); + if (TREE_CODE (t) != STRING_CST) + *(CALL_EXPR_ARGP (expr) + i) = tree_output_constant_def (arg); + } + } + + return GS_UNHANDLED; + case VIEW_CONVERT_EXPR: op = TREE_OPERAND (expr, 0); diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 83cc794..3bf0e15 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -1301,11 +1301,11 @@ build_binary_op (enum tree_code op_code, tree result_type, if (TYPE_VOLATILE (operation_type)) TREE_THIS_VOLATILE (result) = 1; } - else - TREE_CONSTANT (result) - |= (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand)); + else if (TREE_CONSTANT (left_operand) && TREE_CONSTANT (right_operand)) + TREE_CONSTANT (result) = 1; - TREE_SIDE_EFFECTS (result) |= has_side_effects; + if (has_side_effects) + TREE_SIDE_EFFECTS (result) = 1; /* If we are working with modular types, perform the MOD operation if something above hasn't eliminated the need for it. */ @@ -1528,7 +1528,9 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand) result = build_fold_addr_expr (operand); } - TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand); + if (TREE_CONSTANT (operand) || staticp (operand)) + TREE_CONSTANT (result) = 1; + break; case INDIRECT_REF: @@ -1957,14 +1959,19 @@ gnat_build_constructor (tree type, vec *v) the elements along the way for possible sorting purposes below. */ FOR_EACH_CONSTRUCTOR_ELT (v, n_elmts, obj, val) { - /* The predicate must be in keeping with output_constructor. */ + /* The predicate must be in keeping with output_constructor and, unlike + initializer_constant_valid_p, we accept "&{...}" because we'll put + the CONSTRUCTOR into the constant pool during gimplification. */ if ((!TREE_CONSTANT (val) && !TREE_STATIC (val)) || (TREE_CODE (type) == RECORD_TYPE && CONSTRUCTOR_BITFIELD_P (obj) && !initializer_constant_valid_for_bitfield_p (val)) - || !initializer_constant_valid_p (val, - TREE_TYPE (val), - TYPE_REVERSE_STORAGE_ORDER (type))) + || (!initializer_constant_valid_p (val, + TREE_TYPE (val), + TYPE_REVERSE_STORAGE_ORDER (type)) + && !(TREE_CODE (val) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (val, 0)) == CONSTRUCTOR + && TREE_CONSTANT (TREE_OPERAND (val, 0))))) allconstant = false; if (!TREE_READONLY (val)) @@ -2676,10 +2683,13 @@ gnat_stabilize_reference_1 (tree e, void *data) gcc_unreachable (); } + /* See gnat_rewrite_reference below for the rationale. */ TREE_READONLY (result) = TREE_READONLY (e); - TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (e); TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (e); + if (TREE_SIDE_EFFECTS (e)) + TREE_SIDE_EFFECTS (result) = 1; + return result; } @@ -2796,18 +2806,18 @@ gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, tree *init) gcc_unreachable (); } - /* TREE_THIS_VOLATILE and TREE_SIDE_EFFECTS set on the initial expression - may not be sustained across some paths, such as the way via build1 for - INDIRECT_REF. We reset those flags here in the general case, which is - consistent with the GCC version of this routine. + /* TREE_READONLY and TREE_THIS_VOLATILE set on the initial expression may + not be sustained across some paths, such as the one for INDIRECT_REF. Special care should be taken regarding TREE_SIDE_EFFECTS, because some paths introduce side-effects where there was none initially (e.g. if a SAVE_EXPR is built) and we also want to keep track of that. */ TREE_READONLY (result) = TREE_READONLY (ref); - TREE_SIDE_EFFECTS (result) |= TREE_SIDE_EFFECTS (ref); TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref); + if (TREE_SIDE_EFFECTS (ref)) + TREE_SIDE_EFFECTS (result) = 1; + if (code == INDIRECT_REF || code == UNCONSTRAINED_ARRAY_REF || code == ARRAY_REF -- cgit v1.1 From 5b4b66291f2086f56dc3a1d7df494f901cd0b63e Mon Sep 17 00:00:00 2001 From: Richard Wai Date: Mon, 15 Mar 2021 06:24:00 -0400 Subject: [Ada] Hashed container Cursor type predefined equality non-conformance gcc/ada/ * libgnat/a-cohase.ads (Cursor): Synchronize comments for the Cursor type definition to be consistent with identical definitions in other container packages. Add additional comments regarding the importance of maintaining the "Position" component for predefined equality. * libgnat/a-cohama.ads (Cursor): Likewise. * libgnat/a-cihama.ads (Cursor): Likewise. * libgnat/a-cohase.adb (Find, Insert): Ensure that Cursor objects always have their "Position" component set to ensure predefined equality works as required. * libgnat/a-cohama.adb (Find, Insert): Likewise. * libgnat/a-cihama.adb (Find, Insert): Likewise. gcc/testsuite/ * gnat.dg/containers2.adb: New test. --- gcc/ada/libgnat/a-cihama.adb | 4 +++- gcc/ada/libgnat/a-cihama.ads | 14 ++++++++++++++ gcc/ada/libgnat/a-cohama.adb | 5 ++++- gcc/ada/libgnat/a-cohama.ads | 10 +++++++++- gcc/ada/libgnat/a-cohase.adb | 8 +++++--- gcc/ada/libgnat/a-cohase.ads | 14 ++++++++++++++ 6 files changed, 49 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb index 7a490d5..50adea1 100644 --- a/gcc/ada/libgnat/a-cihama.adb +++ b/gcc/ada/libgnat/a-cihama.adb @@ -522,7 +522,8 @@ is return No_Element; end if; - return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); + return Cursor' + (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node)); end Find; -------------------- @@ -748,6 +749,7 @@ is end if; Position.Container := Container'Unchecked_Access; + Position.Position := HT_Ops.Index (HT, Position.Node); end Insert; procedure Insert diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads index ccf5f4e..f896167 100644 --- a/gcc/ada/libgnat/a-cihama.ads +++ b/gcc/ada/libgnat/a-cihama.ads @@ -363,8 +363,22 @@ private type Cursor is record Container : Map_Access; + -- Access to this cursor's container + Node : Node_Access; + -- Access to the node pointed to by this cursor + Position : Hash_Type := Hash_Type'Last; + -- Position of the node in the buckets of the container. If this is + -- equal to Hash_Type'Last, then it will not be used. Position is + -- not requried by the implementation, but improves the efficiency + -- of various operations. + -- + -- However, this value must be maintained so that the predefined + -- equality operation acts as required by RM A.18.4-18/2, which + -- states: "The predefined "=" operator for type Cursor returns True + -- if both cursors are No_Element, or designate the same element + -- in the same container." end record; procedure Write diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb index 9c4e51a..fb46e07 100644 --- a/gcc/ada/libgnat/a-cohama.adb +++ b/gcc/ada/libgnat/a-cohama.adb @@ -478,7 +478,8 @@ is return No_Element; end if; - return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); + return Cursor' + (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node)); end Find; -------------------- @@ -635,6 +636,7 @@ is end if; Position.Container := Container'Unrestricted_Access; + Position.Position := HT_Ops.Index (HT, Position.Node); end Insert; procedure Insert @@ -677,6 +679,7 @@ is end if; Position.Container := Container'Unrestricted_Access; + Position.Position := HT_Ops.Index (HT, Position.Node); end Insert; procedure Insert diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads index 21b6935..c6e377c 100644 --- a/gcc/ada/libgnat/a-cohama.ads +++ b/gcc/ada/libgnat/a-cohama.ads @@ -465,7 +465,15 @@ private Position : Hash_Type := Hash_Type'Last; -- Position of the node in the buckets of the container. If this is - -- equal to Hash_Type'Last, then it will not be used. + -- equal to Hash_Type'Last, then it will not be used. Position is + -- not requried by the implementation, but improves the efficiency + -- of various operations. + -- + -- However, this value must be maintained so that the predefined + -- equality operation acts as required by RM A.18.4-18/2, which + -- states: "The predefined "=" operator for type Cursor returns True + -- if both cursors are No_Element, or designate the same element + -- in the same container." end record; procedure Read diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb index 0131f73..aac5b1b 100644 --- a/gcc/ada/libgnat/a-cohase.adb +++ b/gcc/ada/libgnat/a-cohase.adb @@ -605,13 +605,13 @@ is is HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; Node : constant Node_Access := Element_Keys.Find (HT, Item); - begin if Node = null then return No_Element; end if; - return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); + return Cursor' + (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node)); end Find; -------------------- @@ -763,9 +763,11 @@ is Position : out Cursor; Inserted : out Boolean) is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; begin Insert (Container.HT, New_Item, Position.Node, Inserted); Position.Container := Container'Unchecked_Access; + Position.Position := HT_Ops.Index (HT, Position.Node); end Insert; procedure Insert @@ -1998,7 +2000,7 @@ is return No_Element; else return Cursor' - (Container'Unrestricted_Access, Node, Hash_Type'Last); + (Container'Unrestricted_Access, Node, HT_Ops.Index (HT, Node)); end if; end Find; diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads index a0aca52..c1415b5 100644 --- a/gcc/ada/libgnat/a-cohase.ads +++ b/gcc/ada/libgnat/a-cohase.ads @@ -537,8 +537,22 @@ private type Cursor is record Container : Set_Access; + -- Access to this cursor's container + Node : Node_Access; + -- Access to the node pointed to by this cursor + Position : Hash_Type := Hash_Type'Last; + -- Position of the node in the buckets of the container. If this is + -- equal to Hash_Type'Last, then it will not be used. Position is + -- not requried by the implementation, but improves the efficiency + -- of various operations. + -- + -- However, this value must be maintained so that the predefined + -- equality operation acts as required by RM A.18.7-17/2, which + -- states: "The predefined "=" operator for type Cursor returns True + -- if both cursors are No_Element, or designate the same element + -- in the same container." end record; procedure Write -- cgit v1.1 From 4c118453c7c6db1e24145401abf70d286133de3f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 7 Apr 2021 05:11:57 -0400 Subject: [Ada] Fix the Sphinx configuration and port it to Python3 gcc/ada/ * .gitignore: New. * doc/share/conf.py: Add Python 3 compatibility. * doc/share/gnat.sty: Add missing file. --- gcc/ada/.gitignore | 2 ++ gcc/ada/doc/share/conf.py | 32 ++++++++++----------- gcc/ada/doc/share/gnat.sty | 72 ++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 90 insertions(+), 16 deletions(-) create mode 100644 gcc/ada/.gitignore create mode 100644 gcc/ada/doc/share/gnat.sty (limited to 'gcc/ada') diff --git a/gcc/ada/.gitignore b/gcc/ada/.gitignore new file mode 100644 index 0000000..36a0db0 --- /dev/null +++ b/gcc/ada/.gitignore @@ -0,0 +1,2 @@ +# Sphinx build artifacts +doc/build diff --git a/gcc/ada/doc/share/conf.py b/gcc/ada/doc/share/conf.py index e6fafcf..debd716 100644 --- a/gcc/ada/doc/share/conf.py +++ b/gcc/ada/doc/share/conf.py @@ -37,45 +37,45 @@ def get_copyright(): def get_gnat_version(): - m = re.search(r'Gnat_Static_Version_String : ' + - r'constant String := "([^\(\)]+)\(.*\)?";', + m = re.search(br'Gnat_Static_Version_String : ' + + br'constant String := "([^\(\)]+)\(.*\)?";', gnatvsn_content) if m: - return m.group(1).strip() + return m.group(1).strip().decode() else: if texi_fsf and os.path.exists(basever): return '' try: - with open(basever, 'rb') as fd: + with open(basever) as fd: return fd.read() - except: + except Exception: pass - print 'cannot find GNAT version in gnatvsn.ads or in ' + basever + print('cannot find GNAT version in gnatvsn.ads or in ' + basever) sys.exit(1) def get_gnat_build_type(): - m = re.search(r'Build_Type : constant Gnat_Build_Type := (.+);', + m = re.search(br'Build_Type : constant Gnat_Build_Type := (.+);', gnatvsn_content) if m: - return {'Gnatpro': 'PRO', - 'FSF': 'FSF', - 'GPL': 'GPL'}[m.group(1).strip()] + return {b'Gnatpro': 'PRO', + b'FSF': 'FSF', + b'GPL': 'GPL'}[m.group(1).strip()] else: - print 'cannot compute GNAT build type' + print('cannot compute GNAT build type') sys.exit(1) # First retrieve the name of the documentation we are building doc_name = os.environ.get('DOC_NAME', None) if doc_name is None: - print 'DOC_NAME environment variable should be set' + print('DOC_NAME environment variable should be set') sys.exit(1) if doc_name not in DOCS: - print '%s is not a valid documentation name' % doc_name + print('%s is not a valid documentation name' % doc_name) sys.exit(1) @@ -84,11 +84,11 @@ exclude_patterns = [] for d in os.listdir(root_source_dir): if d not in ('share', doc_name, doc_name + '.rst'): exclude_patterns.append(d) - print 'ignoring %s' % d + print('ignoring %s' % d) if doc_name == 'gnat_rm': exclude_patterns.append('share/gnat_project_manager.rst') - print 'ignoring share/gnat_project_manager.rst' + print('ignoring share/gnat_project_manager.rst') extensions = [] templates_path = ['_templates'] @@ -103,7 +103,7 @@ copyright = get_copyright() version = get_gnat_version() release = get_gnat_version() -pygments_style = 'sphinx' +pygments_style = None tags.add(get_gnat_build_type()) html_theme = 'sphinxdoc' if os.path.isfile('adacore_transparent.png'): diff --git a/gcc/ada/doc/share/gnat.sty b/gcc/ada/doc/share/gnat.sty new file mode 100644 index 0000000..1a152fb --- /dev/null +++ b/gcc/ada/doc/share/gnat.sty @@ -0,0 +1,72 @@ +% Needed to generate footers with total number of pages +\RequirePackage{lastpage} + +% AdaCore specific maketitle +\renewcommand{\maketitle}{% + \begin{titlepage}% + \let\footnotesize\small + \let\footnoterule\relax + \rule{\textwidth}{1pt}% + \ifsphinxpdfoutput + \begingroup + % These \defs are required to deal with multi-line authors; it + % changes \\ to ', ' (comma-space), making it pass muster for + % generating document info in the PDF file. + \def\\{, } + \def\and{and } + \pdfinfo{ + /Author (\@author) + /Title (\@title) + } + \endgroup + \fi + \begin{flushright}% + \sphinxlogo% + {\rm\Huge \@title \par}% + {\em\LARGE\py@HeaderFamily \py@release\releaseinfo \par} + \vfill + {\LARGE\py@HeaderFamily + \par} + \vfill\vfill + {\large + \@date \par + \vfill + \py@authoraddress \par + }% + \end{flushright}%\par + \@thanks + \end{titlepage}% + \cleardoublepage% + \setcounter{footnote}{0}% + \let\thanks\relax\let\maketitle\relax +} + +% AdaCore specific headers/footers +% Redefine the 'normal' header/footer style when using "fancyhdr" package: +\@ifundefined{fancyhf}{}{ + % Use \pagestyle{normal} as the primary pagestyle for text. + \fancypagestyle{normal}{ + \fancyhf{} + \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage\ of \pageref*{LastPage}}} + \fancyfoot[LO]{{\py@HeaderFamily\nouppercase{\rightmark}}} + \fancyfoot[RE]{{\py@HeaderFamily\nouppercase{\leftmark}}} + \fancyhead[LE,RO]{{\py@HeaderFamily \@title, \py@release}} + \renewcommand{\headrulewidth}{0.4pt} + \renewcommand{\footrulewidth}{0.4pt} + % define chaptermark with \@chappos when \@chappos is available for Japanese + \ifx\@chappos\undefined\else + \def\chaptermark##1{\markboth{\@chapapp\space\thechapter\space\@chappos\space ##1}{}} + \fi + } + % Update the plain style so we get the page number & footer line, + % but not a chapter or section title. This is to keep the first + % page of a chapter and the blank page between chapters `clean.' + \fancypagestyle{plain}{ + \fancyhf{} + \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage\ of \pageref*{LastPage}}} + \fancyfoot[LO,RE]{{\py@HeaderFamily \GNATFullDocumentName}} + \fancyhead[LE,RO]{{\py@HeaderFamily \@title\ \GNATVersion}} + \renewcommand{\headrulewidth}{0.0pt} + \renewcommand{\footrulewidth}{0.4pt} + } +} -- cgit v1.1 From ce32ccfc25a1b12ff9f42b1d9b6150ea128a26ec Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 2 Dec 2020 04:15:36 -0500 Subject: [Ada] Bad handling of 'Valid_Scalars and arrays gcc/ada/ * exp_attr.adb (Build_Array_VS_Func, Build_Record_VS_Func, Expand_N_Attribute_Reference): Use Get_Fullest_View instead of Validated_View. (Build_Record_VS_Func): Adjust to keep using Validated_View. (Expand_N_Attribute_Reference) [Valid]: Use Small_Integer_Type_For to allow for more compile time evaluations. * sem_util.adb (Cannot_Raise_Constraint_Error): Add more precise support for N_Indexed_Component and fix support for N_Selected_Component which wasn't completely safe. (List_Cannot_Raise_CE): New. * libgnat/i-cobol.adb (Valid_Packed): Simplify test to address new GNAT warning. --- gcc/ada/exp_attr.adb | 47 +++++++++++++++++++++++++++++++++--------- gcc/ada/libgnat/i-cobol.adb | 2 +- gcc/ada/sem_util.adb | 50 ++++++++++++++++++++++++++++++--------------- 3 files changed, 72 insertions(+), 27 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 7f63a2d..b3ac7b7 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -244,7 +244,7 @@ package body Exp_Attr is is Loc : constant Source_Ptr := Sloc (Attr); Comp_Typ : constant Entity_Id := - Validated_View (Component_Type (Array_Typ)); + Get_Fullest_View (Component_Type (Array_Typ)); function Validate_Component (Obj_Id : Entity_Id; @@ -531,7 +531,7 @@ package body Exp_Attr is is Field_Id : constant Entity_Id := Defining_Entity (Field); Field_Nam : constant Name_Id := Chars (Field_Id); - Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id)); + Field_Typ : constant Entity_Id := Get_Fullest_View (Etype (Field_Id)); Attr_Nam : Name_Id; begin @@ -733,7 +733,7 @@ package body Exp_Attr is -- Start of processing for Build_Record_VS_Func begin - Typ := Rec_Typ; + Typ := Validated_View (Rec_Typ); -- Use the root type when dealing with a class-wide type @@ -7329,7 +7329,7 @@ package body Exp_Attr is -- of the size of the type, not the range of the values). We write -- this as two tests, rather than a range check, so that static -- evaluation will easily remove either or both of the checks if - -- they can be -statically determined to be true (this happens + -- they can be statically determined to be true (this happens -- when the type of X is static and the range extends to the full -- range of stored values). @@ -7350,12 +7350,39 @@ package body Exp_Attr is else declare - Uns : constant Boolean - := Is_Unsigned_Type (Ptyp) - or else (Is_Private_Type (Ptyp) - and then Is_Unsigned_Type (Btyp)); + Uns : constant Boolean := + Is_Unsigned_Type (Ptyp) + or else (Is_Private_Type (Ptyp) + and then Is_Unsigned_Type (Btyp)); + Size : Uint; + P : Node_Id := Pref; + begin - PBtyp := Integer_Type_For (Esize (Ptyp), Uns); + -- If the prefix has an entity, use the Esize from this entity + -- to handle in a more user friendly way the case of objects + -- or components with a large Size aspect: if a Size aspect is + -- specified, we want to read a scalar value as large as the + -- Size, unless the Size is larger than + -- System_Max_Integer_Size. + + if Nkind (P) = N_Selected_Component then + P := Selector_Name (P); + end if; + + if Nkind (P) in N_Has_Entity + and then Present (Entity (P)) + and then Esize (Entity (P)) /= Uint_0 + then + if Esize (Entity (P)) <= System_Max_Integer_Size then + Size := Esize (Entity (P)); + else + Size := UI_From_Int (System_Max_Integer_Size); + end if; + else + Size := Esize (Ptyp); + end if; + + PBtyp := Small_Integer_Type_For (Size, Uns); Rewrite (N, Make_Range_Test); end; end if; @@ -7385,7 +7412,7 @@ package body Exp_Attr is ------------------- when Attribute_Valid_Scalars => Valid_Scalars : declare - Val_Typ : constant Entity_Id := Validated_View (Ptyp); + Val_Typ : constant Entity_Id := Get_Fullest_View (Ptyp); Expr : Node_Id; begin diff --git a/gcc/ada/libgnat/i-cobol.adb b/gcc/ada/libgnat/i-cobol.adb index d69ef9d..96f6f81 100644 --- a/gcc/ada/libgnat/i-cobol.adb +++ b/gcc/ada/libgnat/i-cobol.adb @@ -692,7 +692,7 @@ package body Interfaces.COBOL is -- For signed, accept all standard and non-standard signs else - return Item (Item'Last) in 16#A# .. 16#F#; + return Item (Item'Last) >= 16#A#; end if; end case; end Valid_Packed; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1cf5c69..e3ac718 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2900,6 +2900,32 @@ package body Sem_Util is ----------------------------------- function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean is + + function List_Cannot_Raise_CE (L : List_Id) return Boolean; + -- Returns True if none of the list members cannot possibly raise + -- Constraint_Error. + + -------------------------- + -- List_Cannot_Raise_CE -- + -------------------------- + + function List_Cannot_Raise_CE (L : List_Id) return Boolean is + N : Node_Id; + begin + N := First (L); + while Present (N) loop + if Cannot_Raise_Constraint_Error (N) then + Next (N); + else + return False; + end if; + end loop; + + return True; + end List_Cannot_Raise_CE; + + -- Start of processing for Cannot_Raise_Constraint_Error + begin if Compile_Time_Known_Value (Expr) then return True; @@ -2918,8 +2944,14 @@ package body Sem_Util is when N_Expanded_Name => return True; + when N_Indexed_Component => + return not Do_Range_Check (Expr) + and then Cannot_Raise_Constraint_Error (Prefix (Expr)) + and then List_Cannot_Raise_CE (Expressions (Expr)); + when N_Selected_Component => - return not Do_Discriminant_Check (Expr); + return not Do_Discriminant_Check (Expr) + and then Cannot_Raise_Constraint_Error (Prefix (Expr)); when N_Attribute_Reference => if Do_Overflow_Check (Expr) then @@ -2929,21 +2961,7 @@ package body Sem_Util is return True; else - declare - N : Node_Id; - - begin - N := First (Expressions (Expr)); - while Present (N) loop - if Cannot_Raise_Constraint_Error (N) then - Next (N); - else - return False; - end if; - end loop; - - return True; - end; + return List_Cannot_Raise_CE (Expressions (Expr)); end if; when N_Type_Conversion => -- cgit v1.1 From 3cb4256addca89ff6d6c47ed3ea53499d5b97a52 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 7 Dec 2020 07:47:37 -0500 Subject: [Ada] Remove unused subprograms gcc/ada/ * sem_ch3.adb (Analyze_Object_Declaration): Remove dead code. * ali.ads, ali.adb (Scan_ALI): Remove unused parameters. Remove unused code related to Xref lines. (Get_Typeref): Removed, no longer used. --- gcc/ada/ali.adb | 474 +--------------------------------------------------- gcc/ada/ali.ads | 20 --- gcc/ada/sem_ch3.adb | 19 +-- 3 files changed, 8 insertions(+), 505 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index f213c30..7093766 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -894,8 +894,6 @@ package body ALI is T : Text_Buffer_Ptr; Ignore_ED : Boolean; Err : Boolean; - Read_Xref : Boolean := False; - Read_Lines : String := ""; Ignore_Lines : String := "X"; Ignore_Errors : Boolean := False; Directly_Scanned : Boolean := False) return ALI_Id @@ -907,7 +905,8 @@ package body ALI is NS_Found : Boolean; First_Arg : Arg_Id; - Ignore : array (Character range 'A' .. 'Z') of Boolean; + Ignore : array (Character range 'A' .. 'Z') of Boolean := + (others => False); -- Ignore (X) is set to True if lines starting with X are to -- be ignored by Scan_ALI and skipped, and False if the lines -- are to be read and processed. @@ -1006,16 +1005,6 @@ package body ALI is function Nextc return Character; -- Return current character without modifying pointer P - procedure Get_Typeref - (Current_File_Num : Sdep_Id; - Ref : out Tref_Kind; - File_Num : out Sdep_Id; - Line : out Nat; - Ref_Type : out Character; - Col : out Nat; - Standard_Entity : out Name_Id); - -- Parse the definition of a typeref (<...>, {...} or (...)) - procedure Scan_Invocation_Graph_Line; -- Parse a single line that encodes a piece of the invocation graph @@ -1423,94 +1412,6 @@ package body ALI is return T; end Get_Stamp; - ----------------- - -- Get_Typeref -- - ----------------- - - procedure Get_Typeref - (Current_File_Num : Sdep_Id; - Ref : out Tref_Kind; - File_Num : out Sdep_Id; - Line : out Nat; - Ref_Type : out Character; - Col : out Nat; - Standard_Entity : out Name_Id) - is - N : Nat; - begin - case Nextc is - when '<' => Ref := Tref_Derived; - when '(' => Ref := Tref_Access; - when '{' => Ref := Tref_Type; - when others => Ref := Tref_None; - end case; - - -- Case of typeref field present - - if Ref /= Tref_None then - P := P + 1; -- skip opening bracket - - if Nextc in 'a' .. 'z' then - File_Num := No_Sdep_Id; - Line := 0; - Ref_Type := ' '; - Col := 0; - Standard_Entity := Get_Name (Ignore_Spaces => True); - else - N := Get_Nat; - - if Nextc = '|' then - File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); - P := P + 1; - N := Get_Nat; - else - File_Num := Current_File_Num; - end if; - - Line := N; - Ref_Type := Getc; - Col := Get_Nat; - Standard_Entity := No_Name; - end if; - - -- ??? Temporary workaround for nested generics case: - -- 4i4 Directories{1|4I9[4|6[3|3]]} - -- See C918-002 - - declare - Nested_Brackets : Natural := 0; - - begin - loop - case Nextc is - when '[' => - Nested_Brackets := Nested_Brackets + 1; - when ']' => - Nested_Brackets := Nested_Brackets - 1; - when others => - if Nested_Brackets = 0 then - exit; - end if; - end case; - - Skipc; - end loop; - end; - - P := P + 1; -- skip closing bracket - Skip_Space; - - -- No typeref entry present - - else - File_Num := No_Sdep_Id; - Line := 0; - Ref_Type := ' '; - Col := 0; - Standard_Entity := No_Name; - end if; - end Get_Typeref; - ---------- -- Getc -- ---------- @@ -1836,31 +1737,10 @@ package body ALI is begin First_Sdep_Entry := Sdep.Last + 1; - -- Acquire lines to be ignored - - if Read_Xref then - Ignore := - ('T' | 'U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); - - -- Read_Lines parameter given - - elsif Read_Lines /= "" then - Ignore := ('U' => False, others => True); - - for J in Read_Lines'Range loop - Ignore (Read_Lines (J)) := False; - end loop; - - -- Process Ignore_Lines parameter - - else - Ignore := (others => False); - - for J in Ignore_Lines'Range loop - pragma Assert (Ignore_Lines (J) /= 'U'); - Ignore (Ignore_Lines (J)) := True; - end loop; - end if; + for J in Ignore_Lines'Range loop + pragma Assert (Ignore_Lines (J) /= 'U'); + Ignore (Ignore_Lines (J)) := True; + end loop; -- Setup ALI Table entry with appropriate defaults @@ -3465,347 +3345,7 @@ package body ALI is Fatal_Error; end if; - -- If we are ignoring Xref sections we are done (we ignore all - -- remaining lines since only xref related lines follow X). - - if Ignore ('X') and then not Debug_Flag_X then - return Id; - end if; - - -- Loop through Xref sections - - X_Loop : loop - Check_Unknown_Line; - exit X_Loop when C /= 'X'; - - -- Make new entry in section table - - Xref_Section.Increment_Last; - - Read_Refs_For_One_File : declare - XS : Xref_Section_Record renames - Xref_Section.Table (Xref_Section.Last); - - Current_File_Num : Sdep_Id; - -- Keeps track of the current file number (changed by nn|) - - begin - XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1); - XS.File_Name := Get_File_Name; - XS.First_Entity := Xref_Entity.Last + 1; - - Current_File_Num := XS.File_Num; - - Skip_Space; - - Skip_Eol; - C := Nextc; - - -- Loop through Xref entities - - while C /= 'X' and then C /= EOF loop - Xref_Entity.Increment_Last; - - Read_Refs_For_One_Entity : declare - XE : Xref_Entity_Record renames - Xref_Entity.Table (Xref_Entity.Last); - N : Nat; - - procedure Read_Instantiation_Reference; - -- Acquire instantiation reference. Caller has checked - -- that current character is '[' and on return the cursor - -- is skipped past the corresponding closing ']'. - - ---------------------------------- - -- Read_Instantiation_Reference -- - ---------------------------------- - - procedure Read_Instantiation_Reference is - Local_File_Num : Sdep_Id := Current_File_Num; - - begin - Xref.Increment_Last; - - declare - XR : Xref_Record renames Xref.Table (Xref.Last); - - begin - P := P + 1; -- skip [ - N := Get_Nat; - - if Nextc = '|' then - XR.File_Num := - Sdep_Id (N + Nat (First_Sdep_Entry) - 1); - Local_File_Num := XR.File_Num; - P := P + 1; - N := Get_Nat; - - else - XR.File_Num := Local_File_Num; - end if; - - XR.Line := N; - XR.Rtype := ' '; - XR.Col := 0; - - -- Recursive call for next reference - - if Nextc = '[' then - pragma Warnings (Off); -- kill recursion warning - Read_Instantiation_Reference; - pragma Warnings (On); - end if; - - -- Skip closing bracket after recursive call - - P := P + 1; - end; - end Read_Instantiation_Reference; - - -- Start of processing for Read_Refs_For_One_Entity - - begin - XE.Line := Get_Nat; - XE.Etype := Getc; - XE.Col := Get_Nat; - - case Getc is - when '*' => - XE.Visibility := Global; - when '+' => - XE.Visibility := Static; - when others => - XE.Visibility := Other; - end case; - - XE.Entity := Get_Name; - - -- Handle the information about generic instantiations - - if Nextc = '[' then - Skipc; -- Opening '[' - N := Get_Nat; - - if Nextc /= '|' then - XE.Iref_File_Num := Current_File_Num; - XE.Iref_Line := N; - else - XE.Iref_File_Num := - Sdep_Id (N + Nat (First_Sdep_Entry) - 1); - Skipc; - XE.Iref_Line := Get_Nat; - end if; - - if Getc /= ']' then - Fatal_Error; - end if; - - else - XE.Iref_File_Num := No_Sdep_Id; - XE.Iref_Line := 0; - end if; - - Current_File_Num := XS.File_Num; - - -- Renaming reference is present - - if Nextc = '=' then - P := P + 1; - XE.Rref_Line := Get_Nat; - - if Getc /= ':' then - Fatal_Error; - end if; - - XE.Rref_Col := Get_Nat; - - -- No renaming reference present - - else - XE.Rref_Line := 0; - XE.Rref_Col := 0; - end if; - - Skip_Space; - - XE.Oref_File_Num := No_Sdep_Id; - XE.Tref_File_Num := No_Sdep_Id; - XE.Tref := Tref_None; - XE.First_Xref := Xref.Last + 1; - - -- Loop to check for additional info present - - loop - declare - Ref : Tref_Kind; - File : Sdep_Id; - Line : Nat; - Typ : Character; - Col : Nat; - Std : Name_Id; - - begin - Get_Typeref - (Current_File_Num, Ref, File, Line, Typ, Col, Std); - exit when Ref = Tref_None; - - -- Do we have an overriding procedure? - - if Ref = Tref_Derived and then Typ = 'p' then - XE.Oref_File_Num := File; - XE.Oref_Line := Line; - XE.Oref_Col := Col; - - -- Arrays never override anything, and <> points to - -- the index types instead - - elsif Ref = Tref_Derived and then XE.Etype = 'A' then - - -- Index types are stored in the list of references - - Xref.Increment_Last; - - declare - XR : Xref_Record renames Xref.Table (Xref.Last); - begin - XR.File_Num := File; - XR.Line := Line; - XR.Rtype := Array_Index_Reference; - XR.Col := Col; - XR.Name := Std; - end; - - -- Interfaces are stored in the list of references, - -- although the parent type itself is stored in XE. - -- The first interface (when there are only - -- interfaces) is stored in XE.Tref*) - - elsif Ref = Tref_Derived - and then Typ = 'R' - and then XE.Tref_File_Num /= No_Sdep_Id - then - Xref.Increment_Last; - - declare - XR : Xref_Record renames Xref.Table (Xref.Last); - begin - XR.File_Num := File; - XR.Line := Line; - XR.Rtype := Interface_Reference; - XR.Col := Col; - XR.Name := Std; - end; - - else - XE.Tref := Ref; - XE.Tref_File_Num := File; - XE.Tref_Line := Line; - XE.Tref_Type := Typ; - XE.Tref_Col := Col; - XE.Tref_Standard_Entity := Std; - end if; - end; - end loop; - - -- Loop through cross-references for this entity - - loop - Skip_Space; - - if At_Eol then - Skip_Eol; - exit when Nextc /= '.'; - P := P + 1; - end if; - - Xref.Increment_Last; - - declare - XR : Xref_Record renames Xref.Table (Xref.Last); - - begin - N := Get_Nat; - - if Nextc = '|' then - XR.File_Num := - Sdep_Id (N + Nat (First_Sdep_Entry) - 1); - Current_File_Num := XR.File_Num; - P := P + 1; - N := Get_Nat; - else - XR.File_Num := Current_File_Num; - end if; - - XR.Line := N; - XR.Rtype := Getc; - - -- Imported entities reference as in: - -- 494b25 - - if Nextc = '<' then - Skipc; - XR.Imported_Lang := Get_Name; - - pragma Assert (Nextc = ','); - Skipc; - - XR.Imported_Name := Get_Name; - - pragma Assert (Nextc = '>'); - Skipc; - - else - XR.Imported_Lang := No_Name; - XR.Imported_Name := No_Name; - end if; - - XR.Col := Get_Nat; - - if Nextc = '[' then - Read_Instantiation_Reference; - end if; - end; - end loop; - - -- Record last cross-reference - - XE.Last_Xref := Xref.Last; - C := Nextc; - - exception - when Bad_ALI_Format => - - -- If ignoring errors, then we skip a line with an - -- unexpected error, and try to continue subsequent - -- xref lines. - - if Ignore_Errors then - Xref_Entity.Decrement_Last; - Skip_Line; - C := Nextc; - - -- Otherwise, we reraise the fatal exception - - else - raise; - end if; - end Read_Refs_For_One_Entity; - end loop; - - -- Record last entity - - XS.Last_Entity := Xref_Entity.Last; - end Read_Refs_For_One_File; - - C := Getc; - end loop X_Loop; - - -- Here after dealing with xref sections - - -- Ignore remaining lines, which belong to an additional section of the - -- ALI file not considered here (like SCO or SPARK information). - - Check_Unknown_Line; + -- This ALI parser does not care about Xref lines. return Id; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index ccb516f..90bc94a 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -1391,8 +1391,6 @@ package ALI is T : Text_Buffer_Ptr; Ignore_ED : Boolean; Err : Boolean; - Read_Xref : Boolean := False; - Read_Lines : String := ""; Ignore_Lines : String := "X"; Ignore_Errors : Boolean := False; Directly_Scanned : Boolean := False) return ALI_Id; @@ -1417,24 +1415,6 @@ package ALI is -- tables will not be filled in this case. It is not possible -- to ignore U (unit) lines, they are always read. -- - -- Read_Lines requests that Scan_ALI process only lines that start - -- with one of the given characters. The corresponding data in the - -- ALI file for any characters not given in the list will not be - -- set. The default value of the null string indicates that all - -- lines should be read (unless Ignore_Lines is specified). U - -- (unit) lines are always read regardless of the value of this - -- parameter. - -- - -- Note: either Ignore_Lines or Read_Lines should be non-null, but not - -- both. If both are provided then only the Read_Lines value is used, - -- and the Ignore_Lines parameter is ignored. - -- - -- Read_Xref is set True to read and acquire the cross-reference - -- information. If Read_XREF is set to True, then the effect is to ignore - -- all lines other than U, W, D and X lines and the Ignore_Lines and - -- Read_Lines parameters are ignored (i.e. the use of True for Read_XREF - -- is equivalent to specifying an argument of "UWDX" for Read_Lines. - -- -- Ignore_Errors is normally False. If it is set True, then Scan_ALI -- will do its best to scan through a file and extract all information -- it can, even if there are errors. In this case Err is only set if diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4c7b8e7..d796c47 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4164,27 +4164,10 @@ package body Sem_Ch3 is Set_Related_Array_Object (Base_Type (T), Id); end if; - -- Special checks for protected objects not at library level + -- Check for protected objects not at library level if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then Check_Restriction (No_Local_Protected_Objects, Id); - - -- Protected objects with interrupt handlers must be at library level - - -- Ada 2005: This test is not needed (and the corresponding clause - -- in the RM is removed) because accessibility checks are sufficient - -- to make handlers not at the library level illegal. - - -- AI05-0303: The AI is in fact a binding interpretation, and thus - -- applies to the '95 version of the language as well. - - if Is_Protected_Type (T) - and then Has_Interrupt_Handler (T) - and then Ada_Version < Ada_95 - then - Error_Msg_N - ("interrupt object can only be declared at library level", Id); - end if; end if; -- Check for violation of No_Local_Timing_Events -- cgit v1.1 From cbd743fe0942e91eaa5e788ad21ac660f686a0de Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 7 Dec 2020 08:16:34 -0500 Subject: [Ada] Incorrect error with Default_Value on private/modular type gcc/ada/ * exp_ch3.adb (Simple_Init_Defaulted_Type): Simplify the code, and always use OK_Convert_To, rather than Unchecked_Convert_To and Convert_To. --- gcc/ada/exp_ch3.adb | 37 +++++++++++++++---------------------- 1 file changed, 15 insertions(+), 22 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e0040ed..b916aef 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -8597,35 +8597,28 @@ package body Exp_Ch3 is -------------------------------- function Simple_Init_Defaulted_Type return Node_Id is - Subtyp : constant Entity_Id := First_Subtype (Typ); + Subtyp : Entity_Id := First_Subtype (Typ); begin - -- Use the Sloc of the context node when constructing the initial - -- value because the expression of Default_Value may come from a - -- different unit. Updating the Sloc will result in accurate error - -- diagnostics. - -- When the first subtype is private, retrieve the expression of the -- Default_Value from the underlying type. if Is_Private_Type (Subtyp) then - return - Unchecked_Convert_To - (Typ => Typ, - Expr => - New_Copy_Tree - (Source => Default_Aspect_Value (Full_View (Subtyp)), - New_Sloc => Loc)); - - else - return - Convert_To - (Typ => Typ, - Expr => - New_Copy_Tree - (Source => Default_Aspect_Value (Subtyp), - New_Sloc => Loc)); + Subtyp := Full_View (Subtyp); end if; + + -- Use the Sloc of the context node when constructing the initial + -- value because the expression of Default_Value may come from a + -- different unit. Updating the Sloc will result in accurate error + -- diagnostics. + + return + OK_Convert_To + (Typ => Typ, + Expr => + New_Copy_Tree + (Source => Default_Aspect_Value (Subtyp), + New_Sloc => Loc)); end Simple_Init_Defaulted_Type; ----------------------------------------- -- cgit v1.1 From 7458323aa60cc9a42bed8d029059e5ebd33bafb9 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 7 Dec 2020 15:32:40 +0100 Subject: [Ada] Cleanups related to entry barrier conditions gcc/ada/ * exp_ch9.adb (Build_Barrier_Function): Refine type of a protected type entity. (Is_Pure_Barrier): Fix style. --- gcc/ada/exp_ch9.adb | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index b055b27..32bf11c 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -120,7 +120,7 @@ package body Exp_Ch9 is function Build_Barrier_Function (N : Node_Id; Ent : Entity_Id; - Pid : Node_Id) return Node_Id; + Pid : Entity_Id) return Node_Id; -- Build the function body returning the value of the barrier expression -- for the specified entry body. @@ -1052,7 +1052,7 @@ package body Exp_Ch9 is function Build_Barrier_Function (N : Node_Id; Ent : Entity_Id; - Pid : Node_Id) return Node_Id + Pid : Entity_Id) return Node_Id is Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N); Cond : constant Node_Id := Condition (Ent_Formals); @@ -6322,8 +6322,8 @@ package body Exp_Ch9 is end if; when N_Short_Circuit - | N_If_Expression - | N_Case_Expression + | N_If_Expression + | N_Case_Expression => return OK; -- cgit v1.1 From 416d48eba3a3809757ef7c9d35dd0ac0c9795be4 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 7 Dec 2020 16:54:06 +0100 Subject: [Ada] Extend compile-time evaluation in case statements to all objects gcc/ada/ * sem_ch5.adb (Analyze_Case_Statement): Extend optimization to all objects; fix typo in comment. --- gcc/ada/sem_ch5.adb | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 04fc980..0869bea 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1456,7 +1456,7 @@ package body Sem_Ch5 is if Is_Entity_Name (Exp) then Ent := Entity (Exp); - if Is_Assignable (Ent) then + if Is_Object (Ent) then if List_Length (Choices) = 1 and then Nkind (First (Choices)) in N_Subexpr and then Compile_Time_Known_Value (First (Choices)) @@ -1475,7 +1475,7 @@ package body Sem_Ch5 is end if; end if; - -- Case where expression is not an entity name of a variable + -- Case where expression is not an entity name of an object Analyze_Statements (Statements (Alternative)); end Process_Statements; -- cgit v1.1 From 75716ebc25bfb4a647b05d0b2443b5495dab425e Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 7 Dec 2020 22:04:43 +0100 Subject: [Ada] Couple of adjustments for the sake of static analyzers gcc/ada/ * libgnat/s-valrea.adb (Integer_to_Real): Use a subtype of Num for the component type of the table of powers of ten. * libgnat/s-valuer.adb (Round_Extra): Add assertion on Base. --- gcc/ada/libgnat/s-valrea.adb | 4 +++- gcc/ada/libgnat/s-valuer.adb | 2 ++ 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index 0ac3846..582b966 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -173,7 +173,9 @@ package body System.Val_Real is when 10 => declare - Powten : constant array (0 .. Maxpow) of Num; + subtype Pow_Num is Num range 1.0 .. Num'Last; + + Powten : constant array (0 .. Maxpow) of Pow_Num; pragma Import (Ada, Powten); for Powten'Address use Powten_Address; diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index 9e4de3e..bd57bfb 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -128,6 +128,8 @@ package body System.Value_R is Extra : in out Char_As_Digit; Base : Unsigned) is + pragma Assert (Base in 2 .. 16); + B : constant Uns := Uns (Base); begin -- cgit v1.1 From 3545103fa4c2586796e1738b19ca8cb049998951 Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Tue, 8 Dec 2020 09:23:09 +0100 Subject: [Ada] Improve error message for ghost in predicate gcc/ada/ * ghost.adb (Check_Ghost_Context): Add continuation message when in predicate. --- gcc/ada/ghost.adb | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 866f7f7..0311020 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -159,6 +159,9 @@ package body Ghost is -- Determine whether node Context denotes a Ghost-friendly context where -- a Ghost entity can safely reside (SPARK RM 6.9(10)). + function In_Aspect_Or_Pragma_Predicate (N : Node_Id) return Boolean; + -- Return True iff N is enclosed in an aspect or pragma Predicate + ------------------------- -- Is_OK_Ghost_Context -- ------------------------- @@ -540,6 +543,40 @@ package body Ghost is end if; end Check_Ghost_Policy; + ----------------------------------- + -- In_Aspect_Or_Pragma_Predicate -- + ----------------------------------- + + function In_Aspect_Or_Pragma_Predicate (N : Node_Id) return Boolean is + Par : Node_Id := N; + begin + while Present (Par) loop + if Nkind (Par) = N_Pragma + and then Get_Pragma_Id (Par) = Pragma_Predicate + then + return True; + + elsif Nkind (Par) = N_Aspect_Specification + and then Same_Aspect (Get_Aspect_Id (Par), Aspect_Predicate) + then + return True; + + -- Stop the search when it's clear it cannot be inside an aspect + -- or pragma. + + elsif Is_Declaration (Par) + or else Is_Statement (Par) + or else Is_Body (Par) + then + return False; + end if; + + Par := Parent (Par); + end loop; + + return False; + end In_Aspect_Or_Pragma_Predicate; + -- Start of processing for Check_Ghost_Context begin @@ -555,6 +592,19 @@ package body Ghost is else Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref); + + -- When the Ghost entity appears in a pragma Predicate, explain the + -- reason for this being illegal, and suggest a fix instead. + + if In_Aspect_Or_Pragma_Predicate (Ghost_Ref) then + Error_Msg_N + ("\as predicates are checked in membership tests, " + & "the type and its predicate must be both ghost", + Ghost_Ref); + Error_Msg_N + ("\either make the type ghost " + & "or use a type invariant on a private type", Ghost_Ref); + end if; end if; end Check_Ghost_Context; -- cgit v1.1 From ef1acd3f18b8d16db139cbab96d27abe0a81d7e0 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 7 Dec 2020 23:47:12 +0100 Subject: [Ada] Update reference with description of type resolution gcc/ada/ * sem_res.ads: Update reference in comment. * sem_type.ads: Fix casing in a name of a unit. --- gcc/ada/sem_res.ads | 2 +- gcc/ada/sem_type.ads | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads index 44a8487..d538566 100644 --- a/gcc/ada/sem_res.ads +++ b/gcc/ada/sem_res.ads @@ -31,7 +31,7 @@ with Types; use Types; package Sem_Res is - -- As described in Sem_Ch4, the type resolution proceeds in two phases. + -- As described in Sem_Type, the type resolution proceeds in two phases. -- The first phase is a bottom up pass that is achieved during the -- recursive traversal performed by the Analyze procedures. This phase -- determines unambiguous types, and collects sets of possible types diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 6c6d5eb..4dea6e2 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -85,7 +85,7 @@ package Sem_Type is -- with the appropriate use clause. The global variable Candidate_Type is -- set in Add_One_Interp whenever an interpretation might be legal for an -- operator if the type were directly visible. This variable is used in - -- sem_ch4 when no legal interpretation is found. + -- Sem_Ch4 when no legal interpretation is found. Candidate_Type : Entity_Id; -- cgit v1.1 From 4ba1f7f65b46c1f0e0143ec982a62e6bd9a3ef2e Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Tue, 8 Dec 2020 00:22:20 +0100 Subject: [Ada] Remove double initialization of interpretation tables gcc/ada/ * fmap.ads (Reset_Tables): Remove outdated references to GNSA/ASIS. * sem_eval.ads (Initialize): Likewise. * sem_type.adb (Headers): Remove initialization at elaboration. * sem_type.ads (Init_Interp_Tables): Remove outdated reference to gnatf. * stringt.ads (Initialize): Fix style in comment. --- gcc/ada/fmap.ads | 5 +---- gcc/ada/sem_eval.ads | 3 +-- gcc/ada/sem_type.adb | 2 +- gcc/ada/sem_type.ads | 2 +- gcc/ada/stringt.ads | 2 +- 5 files changed, 5 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads index 862b8ea..aae3219 100644 --- a/gcc/ada/fmap.ads +++ b/gcc/ada/fmap.ads @@ -68,10 +68,7 @@ package Fmap is -- mapping file whose file name is File_Name. procedure Reset_Tables; - -- Initialize all the internal data structures. This procedure is used - -- when several compilations are performed by the same process (by GNSA - -- for ASIS, for example) to remove any existing mappings from a previous - -- compilation. + -- Initialize all the internal data structures procedure Add_Forbidden_File_Name (Name : File_Name_Type); -- Indicate that a source file name is forbidden. This is used when there diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 972cee6..3cbd438 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -556,8 +556,7 @@ package Sem_Eval is -- messages must always point to the same location as the parent message. procedure Initialize; - -- Initializes the internal data structures. Must be called before each - -- separate main program unit (e.g. in a GNSA/ASIS context). + -- Initializes the internal data structures private -- The Eval routines are all marked inline, since they are called once diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 8dbfa18..8f636be 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -97,7 +97,7 @@ package body Sem_Type is Header_Size : constant Int := 2 ** 12; No_Entry : constant Int := -1; - Headers : array (0 .. Header_Size) of Int := (others => No_Entry); + Headers : array (0 .. Header_Size) of Int; package Interp_Map is new Table.Table ( Table_Component_Type => Interp_Ref, diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 4dea6e2..3177bd3 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -94,7 +94,7 @@ package Sem_Type is ----------------- procedure Init_Interp_Tables; - -- Invoked by gnatf when processing multiple files + -- Initialize data structures for overload resolution procedure Collect_Interps (N : Node_Id); -- Invoked when the name N has more than one visible interpretation. This diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads index 77a794e..b85a590 100644 --- a/gcc/ada/stringt.ads +++ b/gcc/ada/stringt.ads @@ -56,7 +56,7 @@ package Stringt is -------------------------------------- procedure Initialize; - -- Initializes the strings table for a new compilation. + -- Initializes the strings table for a new compilation procedure Lock; -- Lock internal tables before calling back end -- cgit v1.1 From df5f901ce89cdbf73ae827ee528da776cbcacfac Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 8 Dec 2020 08:16:45 -0500 Subject: [Ada] Incorrect discriminant check on call to access to subprogram gcc/ada/ * exp_ch6.adb: Fix typo in comment. * sem_ch3.adb (Access_Subprogram_Declaration): Add missing call to Create_Extra_Formals. Remove obsolete bootstrap check. * sem_eval.adb (Eval_Selected_Component): Simplify a selected_component on an aggregate. --- gcc/ada/exp_ch6.adb | 2 +- gcc/ada/sem_ch3.adb | 9 ++------- gcc/ada/sem_eval.adb | 36 +++++++++++++++++++++++++++++++++++- 3 files changed, 38 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 2cd40e4..6b14656 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -3801,7 +3801,7 @@ package body Exp_Ch6 is -- is internally generated code that manipulates addresses, -- e.g. when building interface tables. No check should -- occur in this case, and the discriminated object is not - -- directly a hand. + -- directly at hand. if not Comes_From_Source (Actual) and then Nkind (Actual) = N_Unchecked_Type_Conversion diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d796c47..41e1e49 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -840,13 +840,6 @@ package body Sem_Ch3 is -- the corresponding semantic routine if Present (Access_To_Subprogram_Definition (N)) then - - -- Compiler runtime units are compiled in Ada 2005 mode when building - -- the runtime library but must also be compilable in Ada 95 mode - -- (when bootstrapping the compiler). - - Check_Compiler_Unit ("anonymous access to subprogram", N); - Access_Subprogram_Declaration (T_Name => Anon_Type, T_Def => Access_To_Subprogram_Definition (N)); @@ -1312,6 +1305,8 @@ package body Sem_Ch3 is Set_Can_Never_Be_Null (T_Name, Null_Exclusion_Present (T_Def)); Check_Restriction (No_Access_Subprograms, T_Def); + + Create_Extra_Formals (Desig_Type); end Access_Subprogram_Declaration; ---------------------------- diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 8d47589..263b9fd 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3830,6 +3830,11 @@ package body Sem_Eval is ----------------------------- procedure Eval_Selected_Component (N : Node_Id) is + Node : Node_Id; + Comp : Node_Id; + C : Node_Id; + Nam : Name_Id; + begin -- If an attribute reference or a LHS, nothing to do. -- Also do not fold if N is an [in] out subprogram parameter. @@ -3839,7 +3844,36 @@ package body Sem_Eval is and then Is_LHS (N) = No and then not Is_Actual_Out_Or_In_Out_Parameter (N) then - Fold (N); + -- Simplify a selected_component on an aggregate by extracting + -- the field directly. + + Node := Prefix (N); + + while Nkind (Node) = N_Qualified_Expression loop + Node := Expression (Node); + end loop; + + if Nkind (Node) = N_Aggregate then + Comp := First (Component_Associations (Node)); + Nam := Chars (Selector_Name (N)); + + while Present (Comp) loop + C := First (Choices (Comp)); + + while Present (C) loop + if Chars (C) = Nam then + Rewrite (N, Relocate_Node (Expression (Comp))); + return; + end if; + + Next (C); + end loop; + + Next (Comp); + end loop; + else + Fold (N); + end if; end if; end Eval_Selected_Component; -- cgit v1.1 From ff683f9f0341391253eef171890f1b98f18ec99d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 3 Dec 2020 10:06:47 -0500 Subject: [Ada] Crash with declare expression used in a postcondition gcc/ada/ * sem_aux.adb (Is_Limited_Type): Fix logic to check Is_Type before assuming Ent is a typo. * sem_ch4.adb (Analyze_Expression_With_Actions): Update comments, minor reformatting. * sem_res.adb (Resolve_Declare_Expression): Add protection against no type. --- gcc/ada/sem_aux.adb | 10 +++++++--- gcc/ada/sem_ch4.adb | 11 +++++++---- gcc/ada/sem_res.adb | 1 + 3 files changed, 15 insertions(+), 7 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4925ffd..3eddad9 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1072,14 +1072,18 @@ package body Sem_Aux is --------------------- function Is_Limited_Type (Ent : Entity_Id) return Boolean is - Btype : constant E := Base_Type (Ent); - Rtype : constant E := Root_Type (Btype); + Btype : Entity_Id; + Rtype : Entity_Id; begin if not Is_Type (Ent) then return False; + end if; - elsif Ekind (Btype) = E_Limited_Private_Type + Btype := Base_Type (Ent); + Rtype := Root_Type (Btype); + + if Ekind (Btype) = E_Limited_Private_Type or else Is_Limited_Composite (Btype) then return True; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 7a8c261..ad6c7fd 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2278,9 +2278,12 @@ package body Sem_Ch4 is procedure Analyze_Expression_With_Actions (N : Node_Id) is procedure Check_Action_OK (A : Node_Id); - -- Check that the action is something that is allows as a declare_item - -- of a declare_expression, except the checks are suppressed for - -- generated code. + -- Check that the action A is allowed as a declare_item of a declare + -- expression if N and A come from source. + + --------------------- + -- Check_Action_OK -- + --------------------- procedure Check_Action_OK (A : Node_Id) is begin @@ -2324,7 +2327,7 @@ package body Sem_Ch4 is Error_Msg_N ("object renaming or constant declaration expected", A); end Check_Action_OK; - A : Node_Id; + A : Node_Id; EWA_Scop : Entity_Id; -- Start of processing for Analyze_Expression_With_Actions diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f6e0eab..39907ae 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7494,6 +7494,7 @@ package body Sem_Res is Node := First (Actions (N)); while Present (Node) loop if Nkind (Node) = N_Object_Declaration + and then Is_Type (Etype (Defining_Identifier (Node))) and then Requires_Transient_Scope (Etype (Defining_Identifier (Node))) then -- cgit v1.1 From bb60efc5c75afa2c409c740b970f5f1e6fdd4890 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 7 Dec 2020 19:34:01 -0500 Subject: [Ada] Crash on inherited component in type extension in generic unit. gcc/ada/ * exp_ch3.adb (Expand_Record_Extension): Set Parent_Subtype on the type extension when within a generic unit, even though expansion is disabled, to allow for proper resolution of selected components inherited from an ancestor. --- gcc/ada/exp_ch3.adb | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b916aef..56924a0 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7782,9 +7782,14 @@ package body Exp_Ch3 is -- Expand_Record_Extension is called directly from the semantics, so -- we must check to see whether expansion is active before proceeding, -- because this affects the visibility of selected components in bodies - -- of instances. + -- of instances. Within a generic we still need to set Parent_Subtype + -- link because the visibility of inherited components will have to be + -- verified in subsequent instances. if not Expander_Active then + if Inside_A_Generic and then Ekind (T) = E_Record_Type then + Set_Parent_Subtype (T, Etype (T)); + end if; return; end if; -- cgit v1.1 From d2e59934c4f79791b337470e9ef7c34ef66b1b49 Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Mon, 7 Dec 2020 01:58:10 -0500 Subject: [Ada] AI12-0397: Default_Initial_Condition expressions for derived types gcc/ada/ * exp_util.adb (Add_Own_DIC): Suppress expansion of a DIC pragma when the pragma occurs for an abstract type, since that could lead to a call to an abstract function, and such DIC checks can never be performed for abstract types in any case. * sem_disp.adb (Check_Dispatching_Context): Suppress the check for illegal calls to abstract subprograms when the call occurs within a Default_Initial_Condition aspect and the call is passed the current instance as an actual. (Has_Controlling_Current_Instance_Actual): New function to test a call to see if it has any actuals given by direct references to a current instance of a type * sem_res.adb (Resolve_Actuals): Issue an error for a call within a DIC aspect to a nonprimitive subprogram with an actual given by the name of the DIC type's current instance (which will show up as a reference to the formal parameter of a DIC procedure). --- gcc/ada/exp_util.adb | 18 ++++++++++------ gcc/ada/sem_disp.adb | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_res.adb | 35 +++++++++++++++++++++++++++++++ 3 files changed, 105 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index cf4059a..36af89b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1854,12 +1854,18 @@ package body Exp_Util is end if; -- Once the DIC assertion expression is fully processed, add a check - -- to the statements of the DIC procedure. - - Add_DIC_Check - (DIC_Prag => DIC_Prag, - DIC_Expr => Expr, - Stmts => Stmts); + -- to the statements of the DIC procedure (unless the type is an + -- abstract type, in which case we don't want the possibility of + -- generating a call to an abstract function of the type; such DIC + -- procedures can never be called in any case, so not generating the + -- check at all is OK). + + if not Is_Abstract_Type (DIC_Typ) then + Add_DIC_Check + (DIC_Prag => DIC_Prag, + DIC_Expr => Expr, + Stmts => Stmts); + end if; end Add_Own_DIC; --------------------- diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 36efa42..360e73c 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -517,6 +517,12 @@ package body Sem_Disp is procedure Abstract_Context_Error; -- Error for abstract call dispatching on result is not dispatching + function Has_Controlling_Current_Instance_Actual_In_DIC + (Call : Node_Id) return Boolean; + -- Return True if the subprogram call Call has a controlling actual + -- given directly by a current instance referenced within a DIC + -- aspect. + ---------------------------- -- Abstract_Context_Error -- ---------------------------- @@ -536,6 +542,44 @@ package body Sem_Disp is end if; end Abstract_Context_Error; + ---------------------------------------- + -- Has_Current_Instance_Actual_In_DIC -- + ---------------------------------------- + + function Has_Controlling_Current_Instance_Actual_In_DIC + (Call : Node_Id) return Boolean + is + A : Node_Id; + F : Entity_Id; + begin + F := First_Formal (Subp_Entity); + A := First_Actual (Call); + + while Present (F) loop + + -- Return True if the actual denotes a current instance (which + -- will be represented by an in-mode formal of the enclosing + -- DIC_Procedure) passed to a controlling formal. We don't have + -- to worry about controlling access formals here, because its + -- illegal to apply Access (etc.) attributes to a current + -- instance within an aspect (by AI12-0068). + + if Is_Controlling_Formal (F) + and then Nkind (A) = N_Identifier + and then Ekind (Entity (A)) = E_In_Parameter + and then Is_Subprogram (Scope (Entity (A))) + and then Is_DIC_Procedure (Scope (Entity (A))) + then + return True; + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + return False; + end Has_Controlling_Current_Instance_Actual_In_DIC; + -- Local variables Scop : constant Entity_Id := Current_Scope_No_Loops; @@ -591,6 +635,20 @@ package body Sem_Disp is then null; + -- Similarly to the dispensation for postconditions, a call to + -- an abstract function within a Default_Initial_Condition aspect + -- can be legal when passed a current instance of the type. Such + -- a call will be effectively mapped to a call to a primitive of + -- a descendant type (see AI12-0397, as well as AI12-0170), so + -- doesn't need to be dispatching. We test for being within a DIC + -- procedure, since that's where the call will be analyzed. + + elsif Is_Subprogram (Scop) + and then Is_DIC_Procedure (Scop) + and then Has_Controlling_Current_Instance_Actual_In_DIC (Call) + then + null; + elsif Ekind (Current_Scope) = E_Function and then Nkind (Unit_Declaration_Node (Scop)) = N_Generic_Subprogram_Declaration diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 39907ae..fb551d3 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5036,6 +5036,41 @@ package body Sem_Res is end if; end if; + -- (AI12-0397): The target of a subprogram call that occurs within + -- the expression of an Default_Initial_Condition aspect and has + -- an actual that is the current instance of the type must be + -- either a primitive of the type or a class-wide subprogram, + -- because the type of the current instance in such an aspect is + -- considered to be a notional formal derived type whose only + -- operations correspond to the primitives of the enclosing type. + -- Nonprimitives can be called, but the current instance must be + -- converted rather than passed directly. Note that a current + -- instance of a type with DIC will occur as a reference to an + -- in-mode formal of an enclosing DIC procedure or partial DIC + -- procedure. (It seems that this check should perhaps also apply + -- to calls within Type_Invariant'Class, but not Type_Invariant, + -- aspects???) + + if Nkind (A) = N_Identifier + and then Ekind (Entity (A)) = E_In_Parameter + + and then Is_Subprogram (Scope (Entity (A))) + and then Is_DIC_Procedure (Scope (Entity (A))) + + -- We check Comes_From_Source to exclude inherited primitives + -- from being flagged, because such subprograms turn out to not + -- always have the Is_Primitive flag set. ??? + + and then Comes_From_Source (Nam) + + and then not Is_Primitive (Nam) + and then not Is_Class_Wide_Type (Etype (F)) + then + Error_Msg_NE + ("call to nonprimitive & with current instance not allowed " & + "for aspect", A, Nam); + end if; + Next_Actual (A); -- Case where actual is not present -- cgit v1.1 From ae77b299e9717e3a76ac6b7be65145a50aa31ed2 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 8 Dec 2020 12:14:08 -0500 Subject: [Ada] Assert failure on complex code with private type and discriminant gcc/ada/ * einfo.adb (Discriminant_Constraint): Refine assertion. --- gcc/ada/einfo.adb | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 8c401ca..471aea3 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -1120,7 +1120,9 @@ package body Einfo is function Discriminant_Constraint (Id : E) return L is begin - pragma Assert (Is_Composite_Type (Id) and then Has_Discriminants (Id)); + pragma Assert + (Is_Composite_Type (Id) + and then (Has_Discriminants (Id) or else Is_Constrained (Id))); return Elist21 (Id); end Discriminant_Constraint; -- cgit v1.1 From 9d5f3b7a694ceb774330d45894b38e34bb90f86a Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Mon, 7 Dec 2020 16:45:23 +0100 Subject: [Ada] Use spans instead of locations for compiler diagnostics gcc/ada/ * errout.adb: (Error_Msg_Internal): Use span instead of location. (Error_Msg, Error_Msg_NEL): Add versions with span parameter. (Error_Msg_F, Error_Msg_FE, Error_Msg_N, Error_Msg_NE, Error_Msg_NW): Retrieve span from node. (First_Node): Use the new First_And_Last_Nodes. (First_And_Last_Nodes): Expand on previous First_Node. Apply to other nodes than expressions. (First_Sloc): Protect against inconsistent locations. (Last_Node): New function based on First_And_Last_Nodes. (Last_Sloc): New function similar to First_Sloc. (Output_Messages): Update output when -gnatdF is used. Use character ~ for making the span visible, similar to what is done in GCC and Clang. * errout.ads (Error_Msg, Error_Msg_NEL): Add versions with span parameter. (First_And_Last_Nodes, Last_Node, Last_Sloc): New subprograms. * erroutc.adb: Adapt to Sptr field being a span. * erroutc.ads (Error_Msg_Object): Change field Sptr from location to span. * errutil.adb: Adapt to Sptr field being a span. * freeze.adb: Use Errout reporting procedures for nodes to get spans. * par-ch3.adb: Likewise. * par-prag.adb: Likewise. * par-util.adb: Likewise. * sem_case.adb: Likewise. * sem_ch13.adb: Likewise. * sem_ch3.adb: Likewise. * sem_prag.adb: Likewise. * types.ads: (Source_Span): New type for spans. (To_Span): Basic constructors for spans. --- gcc/ada/errout.adb | 466 +++++++++++++++++++++++++++++++++++++++++---------- gcc/ada/errout.ads | 38 ++++- gcc/ada/erroutc.adb | 16 +- gcc/ada/erroutc.ads | 2 +- gcc/ada/errutil.adb | 4 +- gcc/ada/freeze.adb | 4 +- gcc/ada/par-ch3.adb | 4 +- gcc/ada/par-prag.adb | 40 ++--- gcc/ada/par-util.adb | 2 +- gcc/ada/sem_case.adb | 10 +- gcc/ada/sem_ch13.adb | 17 +- gcc/ada/sem_ch3.adb | 5 +- gcc/ada/sem_prag.adb | 17 +- gcc/ada/types.ads | 10 ++ 14 files changed, 479 insertions(+), 156 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index cc291c6..97fd9d4 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -98,8 +98,8 @@ package body Errout is procedure Error_Msg_Internal (Msg : String; - Sptr : Source_Ptr; - Optr : Source_Ptr; + Span : Source_Span; + Opan : Source_Span; Msg_Cont : Boolean; Node : Node_Id); -- This is the low level routine used to post messages after dealing with @@ -218,7 +218,7 @@ package body Errout is Err_Id : Error_Msg_Id := Error_Id; begin - Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); + Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr.Ptr); Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen)); -- If in immediate error message mode, output modified error message now @@ -300,14 +300,19 @@ package body Errout is --------------- -- Error_Msg posts a flag at the given location, except that if the - -- Flag_Location points within a generic template and corresponds to an - -- instantiation of this generic template, then the actual message will be - -- posted on the generic instantiation, along with additional messages - -- referencing the generic declaration. + -- Flag_Location/Flag_Span points within a generic template and corresponds + -- to an instantiation of this generic template, then the actual message + -- will be posted on the generic instantiation, along with additional + -- messages referencing the generic declaration. procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is begin - Error_Msg (Msg, Flag_Location, Current_Node); + Error_Msg (Msg, To_Span (Flag_Location), Current_Node); + end Error_Msg; + + procedure Error_Msg (Msg : String; Flag_Span : Source_Span) is + begin + Error_Msg (Msg, Flag_Span, Current_Node); end Error_Msg; procedure Error_Msg @@ -318,7 +323,7 @@ package body Errout is Save_Is_Compile_Time_Msg : constant Boolean := Is_Compile_Time_Msg; begin Is_Compile_Time_Msg := Is_Compile_Time_Pragma; - Error_Msg (Msg, Flag_Location, Current_Node); + Error_Msg (Msg, To_Span (Flag_Location), Current_Node); Is_Compile_Time_Msg := Save_Is_Compile_Time_Msg; end Error_Msg; @@ -327,6 +332,17 @@ package body Errout is Flag_Location : Source_Ptr; N : Node_Id) is + begin + Error_Msg (Msg, To_Span (Flag_Location), N); + end Error_Msg; + + procedure Error_Msg + (Msg : String; + Flag_Span : Source_Span; + N : Node_Id) + is + Flag_Location : constant Source_Ptr := Flag_Span.Ptr; + Sindex : Source_File_Index; -- Source index for flag location @@ -429,7 +445,7 @@ package body Errout is -- Error_Msg_Internal to place the message in the requested location. if Instantiation (Sindex) = No_Location then - Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N); + Error_Msg_Internal (Msg, Flag_Span, Flag_Span, False, N); return; end if; @@ -525,32 +541,32 @@ package body Errout is if Is_Info_Msg then Error_Msg_Internal (Msg => "info: in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Warning_Msg then Error_Msg_Internal (Msg => Warn_Insertion & "in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Style_Msg then Error_Msg_Internal (Msg => "style: in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); else Error_Msg_Internal (Msg => "error in inlined body #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); end if; @@ -561,32 +577,32 @@ package body Errout is if Is_Info_Msg then Error_Msg_Internal (Msg => "info: in instantiation #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Warning_Msg then Error_Msg_Internal (Msg => Warn_Insertion & "in instantiation #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); elsif Is_Style_Msg then Error_Msg_Internal (Msg => "style: in instantiation #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); else Error_Msg_Internal (Msg => "instantiation error #", - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); end if; @@ -605,8 +621,8 @@ package body Errout is Error_Msg_Internal (Msg => Msg, - Sptr => Actual_Error_Loc, - Optr => Flag_Location, + Span => To_Span (Actual_Error_Loc), + Opan => Flag_Span, Msg_Cont => Msg_Cont_Status, Node => N); end; @@ -834,8 +850,13 @@ package body Errout is ----------------- procedure Error_Msg_F (Msg : String; N : Node_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N))); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, N, + To_Span (Ptr => Sloc (Fst), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_F; ------------------ @@ -847,8 +868,13 @@ package body Errout is N : Node_Id; E : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N))); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, E, + To_Span (Ptr => Sloc (Fst), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_FE; ------------------------ @@ -857,11 +883,14 @@ package body Errout is procedure Error_Msg_Internal (Msg : String; - Sptr : Source_Ptr; - Optr : Source_Ptr; + Span : Source_Span; + Opan : Source_Span; Msg_Cont : Boolean; Node : Node_Id) is + Sptr : constant Source_Ptr := Span.Ptr; + Optr : constant Source_Ptr := Opan.Ptr; + Next_Msg : Error_Msg_Id; -- Pointer to next message at insertion point @@ -1136,7 +1165,7 @@ package body Errout is ((Text => new String'(Msg_Buffer (1 .. Msglen)), Next => No_Error_Msg, Prev => No_Error_Msg, - Sptr => Sptr, + Sptr => Span, Optr => Optr, Insertion_Sloc => (if Has_Insertion_Line then Error_Msg_Sloc else No_Location), @@ -1196,9 +1225,9 @@ package body Errout is if Last_Error_Msg /= No_Error_Msg and then Errors.Table (Cur_Msg).Sfile = Errors.Table (Last_Error_Msg).Sfile - and then (Sptr > Errors.Table (Last_Error_Msg).Sptr + and then (Sptr > Errors.Table (Last_Error_Msg).Sptr.Ptr or else - (Sptr = Errors.Table (Last_Error_Msg).Sptr + (Sptr = Errors.Table (Last_Error_Msg).Sptr.Ptr and then Optr > Errors.Table (Last_Error_Msg).Optr)) then @@ -1216,8 +1245,8 @@ package body Errout is if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then - exit when Sptr < Errors.Table (Next_Msg).Sptr - or else (Sptr = Errors.Table (Next_Msg).Sptr + exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr + or else (Sptr = Errors.Table (Next_Msg).Sptr.Ptr and then Optr < Errors.Table (Next_Msg).Optr); end if; @@ -1364,8 +1393,13 @@ package body Errout is ----------------- procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, N, Sloc (N)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, N, + To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_N; ------------------ @@ -1377,8 +1411,13 @@ package body Errout is N : Node_Or_Entity_Id; E : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, E, Sloc (N)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, E, + To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end Error_Msg_NE; ------------------- @@ -1392,6 +1431,16 @@ package body Errout is Flag_Location : Source_Ptr) is begin + Error_Msg_NEL (Msg, N, E, To_Span (Flag_Location)); + end Error_Msg_NEL; + + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Span : Source_Span) + is + begin if Special_Msg_Delete (Msg, N, E) then return; end if; @@ -1443,7 +1492,7 @@ package body Errout is then Debug_Output (N); Error_Msg_Node_1 := E; - Error_Msg (Msg, Flag_Location, N); + Error_Msg (Msg, Flag_Span, N); else Last_Killed := True; @@ -1463,12 +1512,17 @@ package body Errout is Msg : String; N : Node_Or_Entity_Id) is + Fst, Lst : Node_Id; begin if Eflag and then In_Extended_Main_Source_Unit (N) and then Comes_From_Source (N) then - Error_Msg_NEL (Msg, N, N, Sloc (N)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL (Msg, N, N, + To_Span (Ptr => Sloc (N), + First => First_Sloc (Fst), + Last => Last_Sloc (Lst))); end if; end Error_Msg_NW; @@ -1563,7 +1617,7 @@ package body Errout is F := Nxt; while F /= No_Error_Msg - and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr + and then Errors.Table (F).Sptr.Ptr = Errors.Table (Cur).Sptr.Ptr loop Check_Duplicate_Message (Cur, F); F := Errors.Table (F).Next; @@ -1583,8 +1637,8 @@ package body Errout is begin if (CE.Warn and not CE.Deleted) and then - (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /= - No_String + (Warning_Specifically_Suppressed (CE.Sptr.Ptr, CE.Text, Tag) + /= No_String or else Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /= No_String) @@ -1630,23 +1684,40 @@ package body Errout is ---------------- function First_Node (C : Node_Id) return Node_Id is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (C, Fst, Lst); + return Fst; + end First_Node; + + -------------------------- + -- First_And_Last_Nodes -- + -------------------------- + + procedure First_And_Last_Nodes + (C : Node_Id; + First_Node, Last_Node : out Node_Id) + is Orig : constant Node_Id := Original_Node (C); Loc : constant Source_Ptr := Sloc (Orig); Sfile : constant Source_File_Index := Get_Source_File_Index (Loc); Earliest : Node_Id; + Latest : Node_Id; Eloc : Source_Ptr; + Lloc : Source_Ptr; - function Test_Earlier (N : Node_Id) return Traverse_Result; + function Test_First_And_Last (N : Node_Id) return Traverse_Result; -- Function applied to every node in the construct - procedure Search_Tree_First is new Traverse_Proc (Test_Earlier); + procedure Search_Tree_First_And_Last is new + Traverse_Proc (Test_First_And_Last); -- Create traversal procedure - ------------------ - -- Test_Earlier -- - ------------------ + ------------------------- + -- Test_First_And_Last -- + ------------------------- - function Test_Earlier (N : Node_Id) return Traverse_Result is + function Test_First_And_Last (N : Node_Id) return Traverse_Result is Norig : constant Node_Id := Original_Node (N); Loc : constant Source_Ptr := Sloc (Norig); @@ -1670,22 +1741,61 @@ package body Errout is Eloc := Loc; end if; + -- Check for later + + if Loc > Lloc + + -- Ignore nodes with no useful location information + + and then Loc /= Standard_Location + and then Loc /= No_Location + + -- Ignore nodes from a different file. This ensures against cases + -- of strange foreign code somehow being present. We don't want + -- wild placement of messages if that happens. + + and then Get_Source_File_Index (Loc) = Sfile + then + Latest := Norig; + Lloc := Loc; + end if; + return OK_Orig; - end Test_Earlier; + end Test_First_And_Last; - -- Start of processing for First_Node + -- Start of processing for First_And_Last_Nodes begin - if Nkind (Orig) in N_Subexpr then + if Nkind (Orig) in N_Subexpr + | N_Declaration + | N_Access_To_Subprogram_Definition + | N_Generic_Instantiation + | N_Subprogram_Declaration + | N_Use_Package_Clause + | N_Array_Type_Definition + | N_Renaming_Declaration + | N_Generic_Renaming_Declaration + | N_Assignment_Statement + | N_Raise_Statement + | N_Simple_Return_Statement + | N_Exit_Statement + | N_Pragma + | N_Use_Type_Clause + | N_With_Clause + then Earliest := Orig; Eloc := Loc; - Search_Tree_First (Orig); - return Earliest; + Latest := Orig; + Lloc := Loc; + Search_Tree_First_And_Last (Orig); + First_Node := Earliest; + Last_Node := Latest; else - return Orig; + First_Node := Orig; + Last_Node := Orig; end if; - end First_Node; + end First_And_Last_Nodes; ---------------- -- First_Sloc -- @@ -1694,6 +1804,7 @@ package body Errout is function First_Sloc (N : Node_Id) return Source_Ptr is SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); SF : constant Source_Ptr := Source_First (SI); + SL : constant Source_Ptr := Source_Last (SI); F : Node_Id; S : Source_Ptr; @@ -1701,6 +1812,14 @@ package body Errout is F := First_Node (N); S := Sloc (F); + -- ??? Protect against inconsistency in locations, by returning S + -- immediately if not in the expected range, rather than failing with + -- a Constraint_Error when accessing Source_Text(SI)(S) + + if S not in SF .. SL then + return S; + end if; + -- The following circuit is a bit subtle. When we have parenthesized -- expressions, then the Sloc will not record the location of the paren, -- but we would like to post the flag on the paren. So what we do is to @@ -1786,6 +1905,92 @@ package body Errout is -- True if S starts with Size_For end Is_Size_Too_Small_Message; + --------------- + -- Last_Node -- + --------------- + + function Last_Node (C : Node_Id) return Node_Id is + Fst, Lst : Node_Id; + begin + First_And_Last_Nodes (C, Fst, Lst); + return Lst; + end Last_Node; + + --------------- + -- Last_Sloc -- + --------------- + + function Last_Sloc (N : Node_Id) return Source_Ptr is + SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); + SF : constant Source_Ptr := Source_First (SI); + SL : constant Source_Ptr := Source_Last (SI); + F : Node_Id; + S : Source_Ptr; + + begin + F := Last_Node (N); + S := Sloc (F); + + -- ??? Protect against inconsistency in locations, by returning S + -- immediately if not in the expected range, rather than failing with + -- a Constraint_Error when accessing Source_Text(SI)(S) + + if S not in SF .. SL then + return S; + end if; + + -- Skip past an identifier + + while S in SF .. SL - 1 + and then Source_Text (SI) (S + 1) + in + '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' + loop + S := S + 1; + end loop; + + -- The following circuit attempts at crawling up the tree from the + -- Last_Node, adjusting the Sloc value for any parentheses we know + -- are present, similarly to what is done in First_Sloc. + + Node_Loop : loop + Paren_Loop : for J in 1 .. Paren_Count (F) loop + + -- We don't look more than 12 characters after the current + -- location + + Search_Loop : for K in 1 .. 12 loop + exit Node_Loop when S = SL; + + if Source_Text (SI) (S + 1) = ')' then + S := S + 1; + exit Search_Loop; + + elsif Source_Text (SI) (S + 1) <= ' ' then + S := S + 1; + + else + exit Search_Loop; + end if; + end loop Search_Loop; + end loop Paren_Loop; + + exit Node_Loop when F = N; + F := Parent (F); + exit Node_Loop when Nkind (F) not in N_Subexpr; + end loop Node_Loop; + + -- Remove any trailing space + + while S in SF + 1 .. SL + and then Source_Text (SI) (S) = ' ' + loop + S := S - 1; + end loop; + + return S; + end Last_Sloc; + ----------------- -- No_Warnings -- ----------------- @@ -1858,13 +2063,30 @@ package body Errout is procedure Write_Max_Errors; -- Write message if max errors reached - procedure Write_Source_Code_Line (Loc : Source_Ptr); - -- Write the source code line corresponding to Loc, as follows: + procedure Write_Source_Code_Lines (Span : Source_Span); + -- Write the source code line corresponding to Span, as follows when + -- Span in on one line: + -- + -- line | actual code line here with Span somewhere + -- | ~~~~~^~~~ + -- + -- where the caret on the line points to location Span.Ptr, and the + -- range Span.First..Span.Last is underlined. + -- + -- or when the span is over multiple lines: + -- + -- line | beginning of the Span on this line + -- ... | ... + -- line>| actual code line here with Span.Ptr somewhere + -- ... | ... + -- line | end of the Span on this line + -- + -- or when the span is a simple location, as follows: -- - -- line | actual code line here with Loc somewhere + -- line | actual code line here with Span somewhere -- | ^ here -- - -- where the carret on the last line points to location Loc. + -- where the caret on the line points to location Span.Ptr ------------------------- -- Write_Error_Summary -- @@ -2056,17 +2278,25 @@ package body Errout is end if; end Write_Max_Errors; - ---------------------------- - -- Write_Source_Code_Line -- - ---------------------------- + ----------------------------- + -- Write_Source_Code_Lines -- + ----------------------------- - procedure Write_Source_Code_Line (Loc : Source_Ptr) is + procedure Write_Source_Code_Lines (Span : Source_Span) is function Image (X : Positive; Width : Positive) return String; -- Output number X over Width characters, with whitespace padding. -- Only output the low-order Width digits of X, if X is larger than -- Width digits. + procedure Write_Line_Marker + (Num : Pos; + Mark : Boolean; + Width : Positive); + -- Output the line number Num over Width characters, with possibly + -- a Mark to denote the line with the main location when reporting + -- a span over multiple lines. + ----------- -- Image -- ----------- @@ -2087,26 +2317,76 @@ package body Errout is return Str; end Image; + ----------------------- + -- Write_Line_Marker -- + ----------------------- + + procedure Write_Line_Marker + (Num : Pos; + Mark : Boolean; + Width : Positive) + is + begin + Write_Str (Image (Positive (Num), Width => Width)); + Write_Str ((if Mark then ">" else " ") & "|"); + end Write_Line_Marker; + -- Local variables - Line : constant Pos := Pos (Get_Physical_Line_Number (Loc)); - Col : constant Natural := Natural (Get_Column_Number (Loc)); - Width : constant := 5; + Loc : constant Source_Ptr := Span.Ptr; + Line : constant Pos := Pos (Get_Physical_Line_Number (Loc)); - Buf : Source_Buffer_Ptr; - Cur_Loc : Source_Ptr := Loc; + Col : constant Natural := Natural (Get_Column_Number (Loc)); - -- Start of processing for Write_Source_Code_Line + Fst : constant Source_Ptr := Span.First; + Line_Fst : constant Pos := + Pos (Get_Physical_Line_Number (Fst)); + Col_Fst : constant Natural := + Natural (Get_Column_Number (Fst)); + Lst : constant Source_Ptr := Span.Last; + Line_Lst : constant Pos := + Pos (Get_Physical_Line_Number (Lst)); + Col_Lst : constant Natural := + Natural (Get_Column_Number (Lst)); + + Width : constant := 5; + Buf : Source_Buffer_Ptr; + Cur_Loc : Source_Ptr := Fst; + Cur_Line : Pos := Line_Fst; + + -- Start of processing for Write_Source_Code_Lines begin if Loc >= First_Source_Ptr then Buf := Source_Text (Get_Source_File_Index (Loc)); - -- First line with the actual source code line + -- First line of the span with actual source code - Write_Str (Image (Positive (Line), Width => Width)); - Write_Str (" |"); - Write_Str (String (Buf (Loc - Source_Ptr (Col) + 1 .. Loc - 1))); + Write_Line_Marker + (Cur_Line, + Line_Fst /= Line_Lst and then Cur_Line = Line, + Width); + Write_Str + (String (Buf (Fst - Source_Ptr (Col_Fst) + 1 .. Fst - 1))); + + -- Output all the lines in the span + + while Cur_Loc <= Buf'Last + and then Cur_Loc < Lst + loop + Write_Char (Buf (Cur_Loc)); + Cur_Loc := Cur_Loc + 1; + + if Buf (Cur_Loc - 1) = ASCII.LF then + Cur_Line := Cur_Line + 1; + Write_Line_Marker + (Cur_Line, + Line_Fst /= Line_Lst and then Cur_Line = Line, + Width); + end if; + end loop; + + -- Output the rest of the last line of the span while Cur_Loc <= Buf'Last and then Buf (Cur_Loc) /= ASCII.LF @@ -2117,15 +2397,28 @@ package body Errout is Write_Eol; - -- Second line with carret sign pointing to location Loc + -- If the span is on one line, output a second line with caret + -- sign pointing to location Loc - Write_Str (String'(1 .. Width => ' ')); - Write_Str (" |"); - Write_Str (String'(1 .. Col - 1 => ' ')); - Write_Str ("^ here"); - Write_Eol; + if Line_Fst = Line_Lst then + Write_Str (String'(1 .. Width => ' ')); + Write_Str (" |"); + Write_Str (String'(1 .. Col_Fst - 1 => ' ')); + Write_Str (String'(Col_Fst .. Col - 1 => '~')); + Write_Str ("^"); + Write_Str (String'(Col + 1 .. Col_Lst => '~')); + + -- If the span is really just a location, add the word "here" + -- to clarify this is the location for the message. + + if Col_Fst = Col_Lst then + Write_Str (" here"); + end if; + + Write_Eol; + end if; end if; - end Write_Source_Code_Line; + end Write_Source_Code_Lines; -- Local variables @@ -2217,12 +2510,12 @@ package body Errout is Errors.Table (E).Insertion_Sloc; begin if Loc /= No_Location then - Write_Source_Code_Line (Loc); + Write_Source_Code_Lines (To_Span (Loc)); end if; end; else - Write_Source_Code_Line (Errors.Table (E).Sptr); + Write_Source_Code_Lines (Errors.Table (E).Sptr); end if; end if; end if; @@ -2355,11 +2648,12 @@ package body Errout is -- subunits for a body). while E /= No_Error_Msg - and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr) + and then (not In_Extended_Main_Source_Unit + (Errors.Table (E).Sptr.Ptr) or else (Debug_Flag_Dot_M and then Get_Source_Unit - (Errors.Table (E).Sptr) /= Main_Unit)) + (Errors.Table (E).Sptr.Ptr) /= Main_Unit)) loop if Errors.Table (E).Deleted then E := Errors.Table (E).Next; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 02cfdee..f9a8379 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -703,10 +703,15 @@ package Errout is procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr); procedure Error_Msg + (Msg : String; Flag_Span : Source_Span); + procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr; N : Node_Id); + procedure Error_Msg + (Msg : String; Flag_Span : Source_Span; N : Node_Id); -- Output a message at specified location. Can be called from the parser -- or the semantic analyzer. If N is set, points to the relevant node for - -- this message. + -- this message. The version with a span is preferred whenever possible, + -- in other cases the version with a location can still be used. procedure Error_Msg (Msg : String; @@ -782,8 +787,13 @@ package Errout is N : Node_Or_Entity_Id; E : Node_Or_Entity_Id; Flag_Location : Source_Ptr); + procedure Error_Msg_NEL + (Msg : String; + N : Node_Or_Entity_Id; + E : Node_Or_Entity_Id; + Flag_Span : Source_Span); -- Exactly the same as Error_Msg_NE, except that the flag is placed at - -- the specified Flag_Location instead of at Sloc (N). + -- the specified Flag_Location/Flag_Span instead of at Sloc (N). procedure Error_Msg_NW (Eflag : Boolean; @@ -801,12 +811,17 @@ package Errout is -- the given text. This text may contain insertion characters in the -- usual manner, and need not be the same length as the original text. + procedure First_And_Last_Nodes + (C : Node_Id; + First_Node, Last_Node : out Node_Id); + -- Given a construct C, finds the first and last node in the construct, + -- i.e. the ones with the lowest and highest Sloc value. This is useful in + -- placing error msgs. Note that this procedure uses Original_Node to look + -- at the original source tree, since that's what we want for placing an + -- error message flag in the right place. + function First_Node (C : Node_Id) return Node_Id; - -- Given a construct C, finds the first node in the construct, i.e. the one - -- with the lowest Sloc value. This is useful in placing error msgs. Note - -- that this procedure uses Original_Node to look at the original source - -- tree, since that's what we want for placing an error message flag in - -- the right place. + -- Return the first output of First_And_Last_Nodes function First_Sloc (N : Node_Id) return Source_Ptr; -- Given the node for an expression, return a source pointer value that @@ -817,6 +832,15 @@ package Errout is function Get_Ignore_Errors return Boolean; -- Return True if all error calls are ignored. + function Last_Node (C : Node_Id) return Node_Id; + -- Return the last output of First_And_Last_Nodes + + function Last_Sloc (N : Node_Id) return Source_Ptr; + -- Given the node for an expression, return a source pointer value that + -- points to the end of the last token in the expression. In the case + -- where the expression is parenthesized, an attempt is made to include + -- the parentheses (i.e. to return the location of the final paren). + procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) renames Erroutc.Purge_Messages; -- All error messages whose location is in the range From .. To (not diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index d0cc6ff..d7ca221 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -321,7 +321,7 @@ package body Erroutc is Write_Str (" Sptr = "); - Write_Location (E.Sptr); + Write_Location (E.Sptr.Ptr); -- ??? Do not write the full span for now Write_Eol; Write_Str @@ -350,7 +350,7 @@ package body Erroutc is function Get_Location (E : Error_Msg_Id) return Source_Ptr is begin - return Errors.Table (E).Sptr; + return Errors.Table (E).Sptr.Ptr; end Get_Location; ---------------- @@ -477,7 +477,7 @@ package body Erroutc is and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile loop - if Errors.Table (T).Sptr > Errors.Table (E).Sptr then + if Errors.Table (T).Sptr.Ptr > Errors.Table (E).Sptr.Ptr then Mult_Flags := True; end if; @@ -490,7 +490,7 @@ package body Erroutc is if not Debug_Flag_2 then Write_Str (" "); - P := Line_Start (Errors.Table (E).Sptr); + P := Line_Start (Errors.Table (E).Sptr.Ptr); Flag_Num := 1; -- Loop through error messages for this line to place flags @@ -507,7 +507,7 @@ package body Erroutc is begin -- Loop to output blanks till current flag position - while P < Errors.Table (T).Sptr loop + while P < Errors.Table (T).Sptr.Ptr loop -- Horizontal tab case, just echo the tab @@ -536,7 +536,7 @@ package body Erroutc is -- Output flag (unless already output, this happens if more -- than one error message occurs at the same flag position). - if P = Errors.Table (T).Sptr then + if P = Errors.Table (T).Sptr.Ptr then if (Flag_Num = 1 and then not Mult_Flags) or else Flag_Num > 9 then @@ -955,8 +955,8 @@ package body Erroutc is function To_Be_Purged (E : Error_Msg_Id) return Boolean is begin if E /= No_Error_Msg - and then Errors.Table (E).Sptr > From - and then Errors.Table (E).Sptr < To + and then Errors.Table (E).Sptr.Ptr > From + and then Errors.Table (E).Sptr.Ptr < To then if Errors.Table (E).Warn or else Errors.Table (E).Style then Warnings_Detected := Warnings_Detected - 1; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 4c0e68a..eb43466 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -197,7 +197,7 @@ package Erroutc is -- refers to a template, always references the original template -- not an instantiation copy. - Sptr : Source_Ptr; + Sptr : Source_Span; -- Flag pointer. In the case of an error that refers to a template, -- always references the original template, not an instantiation copy. -- This value is the actual place in the source that the error message diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index d4821fc..0a9f6ad 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -207,7 +207,7 @@ package body Errutil is Next => No_Error_Msg, Prev => No_Error_Msg, Sfile => Get_Source_File_Index (Sptr), - Sptr => Sptr, + Sptr => To_Span (Sptr), Optr => Optr, Insertion_Sloc => No_Location, Line => Get_Physical_Line_Number (Sptr), @@ -234,7 +234,7 @@ package body Errutil is Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then - exit when Sptr < Errors.Table (Next_Msg).Sptr; + exit when Sptr < Errors.Table (Next_Msg).Sptr.Ptr; end if; Prev_Msg := Next_Msg; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index da14af9..cbdecaa 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3644,8 +3644,8 @@ package body Freeze is and then not Freezing_Library_Level_Tagged_Type then Error_Msg_Node_1 := F_Type; - Error_Msg - ("type & must be fully defined before this point", Loc); + Error_Msg_N + ("type & must be fully defined before this point", N); end if; end if; diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 78a3ebd..41aad79 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1379,9 +1379,9 @@ package body Ch3 is procedure No_List is begin if Num_Idents > 1 then - Error_Msg + Error_Msg_N ("identifier list not allowed for RENAMES", - Sloc (Idents (2))); + Idents (2)); end if; List_OK := False; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 51409f2..d05f267 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -158,7 +158,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Check_Arg_Count (Required : Int) is begin if Arg_Count /= Required then - Error_Msg ("wrong number of arguments for pragma%", Pragma_Sloc); + Error_Msg_N ("wrong number of arguments for pragma%", Pragma_Node); raise Error_Resync; end if; end Check_Arg_Count; @@ -177,7 +177,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is Error_Msg_Name_2 := Name_On; Error_Msg_Name_3 := Name_Off; - Error_Msg ("argument for pragma% must be% or%", Sloc (Argx)); + Error_Msg_N ("argument for pragma% must be% or%", Argx); raise Error_Resync; end if; end Check_Arg_Is_On_Or_Off; @@ -189,9 +189,9 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is begin if Nkind (Expression (Arg)) /= N_String_Literal then - Error_Msg + Error_Msg_N ("argument for pragma% must be string literal", - Sloc (Expression (Arg))); + Expression (Arg)); raise Error_Resync; end if; end Check_Arg_Is_String_Literal; @@ -466,7 +466,7 @@ begin A := Expression (Arg1); if Nkind (A) /= N_Identifier then - Error_Msg ("incorrect argument for pragma %", Sloc (A)); + Error_Msg_N ("incorrect argument for pragma %", A); else Set_Name_Table_Boolean3 (Chars (A), True); end if; @@ -718,9 +718,9 @@ begin begin if Prag_Id = Pragma_Source_File_Name then if Project_File_In_Use = In_Use then - Error_Msg + Error_Msg_N ("pragma Source_File_Name cannot be used " & - "with a project file", Pragma_Sloc); + "with a project file", Pragma_Node); else Project_File_In_Use := Not_In_Use; @@ -728,9 +728,9 @@ begin else if Project_File_In_Use = Not_In_Use then - Error_Msg + Error_Msg_N ("pragma Source_File_Name_Project should only be used " & - "with a project file", Pragma_Sloc); + "with a project file", Pragma_Node); else Project_File_In_Use := In_Use; end if; @@ -773,9 +773,9 @@ begin or else Intval (Expr) > 999 or else Intval (Expr) <= 0 then - Error_Msg + Error_Msg_N ("pragma% index must be integer literal" & - " in range 1 .. 999", Sloc (Expr)); + " in range 1 .. 999", Expr); raise Error_Resync; else Index := UI_To_Int (Intval (Expr)); @@ -908,8 +908,8 @@ begin and then Num_SRef_Pragmas (Current_Source_File) = 0 and then Operating_Mode /= Check_Syntax then - Error_Msg -- CODEFIX - ("first % pragma must be first line of file", Pragma_Sloc); + Error_Msg_N -- CODEFIX + ("first % pragma must be first line of file", Pragma_Node); raise Error_Resync; end if; @@ -917,9 +917,9 @@ begin if Arg_Count = 1 then if Num_SRef_Pragmas (Current_Source_File) = 0 then - Error_Msg + Error_Msg_N ("file name required for first % pragma in file", - Pragma_Sloc); + Pragma_Node); raise Error_Resync; else Fname := No_File; @@ -934,17 +934,17 @@ begin if Num_SRef_Pragmas (Current_Source_File) > 0 then if Fname /= Full_Ref_Name (Current_Source_File) then - Error_Msg - ("file name must be same in all % pragmas", Pragma_Sloc); + Error_Msg_N + ("file name must be same in all % pragmas", Pragma_Node); raise Error_Resync; end if; end if; end if; if Nkind (Expression (Arg1)) /= N_Integer_Literal then - Error_Msg + Error_Msg_N ("argument for pragma% must be integer literal", - Sloc (Expression (Arg1))); + Expression (Arg1)); raise Error_Resync; -- OK, this source reference pragma is effective, however, we @@ -1059,7 +1059,7 @@ begin end if; if not OK then - Error_Msg ("incorrect argument for pragma%", Sloc (A)); + Error_Msg_N ("incorrect argument for pragma%", A); raise Error_Resync; end if; end if; diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb index 1f26075..0571c0f 100644 --- a/gcc/ada/par-util.adb +++ b/gcc/ada/par-util.adb @@ -254,7 +254,7 @@ package body Util is then return Mark; else - Error_Msg ("subtype mark expected", Sloc (Mark)); + Error_Msg_N ("subtype mark expected", Mark); return Error; end if; end Check_Subtype_Mark; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 6cda6a9..7f35cfc 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -677,8 +677,6 @@ package body Sem_Case is -------------------- procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is - Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); - begin -- AI05-0188 : within an instance the non-others choices do not have -- to belong to the actual subtype. @@ -704,10 +702,10 @@ package body Sem_Case is if Value1 = Value2 then if Is_Integer_Type (Bounds_Type) then Error_Msg_Uint_1 := Value1; - Error_Msg ("missing case value: ^!", Msg_Sloc); + Error_Msg_N ("missing case value: ^!", Case_Node); else Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); - Error_Msg ("missing case value: %!", Msg_Sloc); + Error_Msg_N ("missing case value: %!", Case_Node); end if; -- More than one choice value, so print range of values @@ -716,11 +714,11 @@ package body Sem_Case is if Is_Integer_Type (Bounds_Type) then Error_Msg_Uint_1 := Value1; Error_Msg_Uint_2 := Value2; - Error_Msg ("missing case values: ^ .. ^!", Msg_Sloc); + Error_Msg_N ("missing case values: ^ .. ^!", Case_Node); else Error_Msg_Name_1 := Choice_Image (Value1, Bounds_Type); Error_Msg_Name_2 := Choice_Image (Value2, Bounds_Type); - Error_Msg ("missing case values: % .. %!", Msg_Sloc); + Error_Msg_N ("missing case values: % .. %!", Case_Node); end if; end if; end Missing_Choice; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 4724e0e..07dec4c 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4147,8 +4147,8 @@ package body Sem_Ch13 is -- Must not be parenthesized if Paren_Count (Expr) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Expr)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Expr); end if; -- List of arguments is list of aggregate expressions @@ -4442,8 +4442,8 @@ package body Sem_Ch13 is -- parentheses). if Paren_Count (Expr) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Expr)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Expr); goto Continue; end if; @@ -4860,11 +4860,11 @@ package body Sem_Ch13 is Error_Msg_Name_1 := Aspect_Names (A_Id); Error_Msg_Sloc := Sloc (Inherited_Aspect); - Error_Msg + Error_Msg_N ("overriding aspect specification for " & "nonoverridable aspect % does not confirm " & "aspect specification inherited from #", - Sloc (Aspect)); + Aspect); end if; end; end if; @@ -7909,9 +7909,8 @@ package body Sem_Ch13 is -- Check that the expression is a proper aggregate (no parentheses) elsif Paren_Count (Aggr) /= 0 then - Error_Msg - ("extra parentheses surrounding aggregate not allowed", - First_Sloc (Aggr)); + Error_Msg_F + ("extra parentheses surrounding aggregate not allowed", Aggr); return; -- All tests passed, so set rep clause in place diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 41e1e49..4784397 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1575,9 +1575,8 @@ package body Sem_Ch3 is begin if not RTE_Available (RE_Interface_Tag) then - Error_Msg - ("(Ada 2005) interface types not supported by this run-time!", - Sloc (N)); + Error_Msg_N + ("(Ada 2005) interface types not supported by this run-time!", N); return; end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 3ef5e82..1b1e01b 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -566,8 +566,8 @@ package body Sem_Prag is -- Check that the expression is a proper aggregate (no parentheses) if Paren_Count (CCases) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (CCases)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", CCases); end if; -- Ensure that the formal parameters are visible when analyzing all @@ -15041,9 +15041,8 @@ package body Sem_Prag is else -- All other cases: diagnose error - Error_Msg - ("argument of pragma ""Debug"" is not procedure call", - Sloc (Call)); + Error_Msg_N + ("argument of pragma ""Debug"" is not procedure call", Call); return; end if; @@ -25632,9 +25631,9 @@ package body Sem_Prag is Set_Specific_Warning_On (Loc, Message, Err); if Err then - Error_Msg + Error_Msg_N ("??pragma Warnings On with no matching " - & "Warnings Off", Loc); + & "Warnings Off", N); end if; end if; end; @@ -29206,8 +29205,8 @@ package body Sem_Prag is -- Check that the expression is a proper aggregate (no parentheses) if Paren_Count (Variants) /= 0 then - Error_Msg -- CODEFIX - ("redundant parentheses", First_Sloc (Variants)); + Error_Msg_F -- CODEFIX + ("redundant parentheses", Variants); end if; -- Ensure that the formal parameters are visible when analyzing all diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 175ffb2..408d661 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -218,6 +218,16 @@ package Types is -- which source it refers to. Note that negative numbers are allowed to -- accommodate the following special values. + type Source_Span is record + Ptr, First, Last : Source_Ptr; + end record; + -- Type used to represent a source span, consisting in a main location Ptr, + -- with a First and Last location, such that Ptr in First .. Last + + function To_Span (Loc : Source_Ptr) return Source_Span is ((others => Loc)); + function To_Span (Ptr, First, Last : Source_Ptr) return Source_Span is + ((Ptr, First, Last)); + No_Location : constant Source_Ptr := -1; -- Value used to indicate no source position set in a node. A test for a -- Source_Ptr value being > No_Location is the approved way to test for a -- cgit v1.1 From 35e3a1f670dc5ef033184ef1103f8d4e0fb42d1e Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Tue, 8 Dec 2020 23:53:43 +0100 Subject: [Ada] Eliminate early roundoff error for Long_Long_Float on x86 gcc/ada/ * libgnat/s-valrea.adb (Fast2Sum): New function. (Integer_to_Real): Use it in an iterated addition with exact error handling for the case where an extra digit is needed. Move local variable now only used in the exponentiation case. --- gcc/ada/libgnat/s-valrea.adb | 100 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 84 insertions(+), 16 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb index 582b966..99dd25d 100644 --- a/gcc/ada/libgnat/s-valrea.adb +++ b/gcc/ada/libgnat/s-valrea.adb @@ -46,7 +46,7 @@ package body System.Val_Real is -- If the mantissa of the floating-point type is almost as large as the -- unsigned type, we do not have enough space for an extra digit in the -- unsigned type so we handle the extra digit separately, at the cost of - -- a potential roundoff error. + -- a bit more work in Integer_to_Real. Precision_Limit : constant Uns := (if Need_Extra then 2**Num'Machine_Mantissa - 1 else 2**Uns'Size - 1); @@ -76,6 +76,10 @@ package body System.Val_Real is 7 => 5836, 8 => 5461, 9 => 5168, 10 => 4932, 11 => 4736, 12 => 4570, 13 => 4427, 14 => 4303, 15 => 4193, 16 => 4095); + function Fast2Sum (A, B : Num; Err : in out Num) return Num; + -- This is the classical Fast2Sum function assuming round to nearest, + -- with the error accumulated into Err. + function Integer_to_Real (Str : String; Val : Uns; @@ -85,6 +89,25 @@ package body System.Val_Real is Minus : Boolean) return Num; -- Convert the real value from integer to real representation + -------------- + -- Fast2Sum -- + -------------- + + function Fast2Sum (A, B : Num; Err : in out Num) return Num is + S, Z : Num; + + begin + pragma Assert (abs (A) >= abs (B)); + + S := A + B; + Z := S - A; + Z := B - Z; + + Err := Err + Z; + + return S; + end Fast2Sum; + --------------------- -- Integer_to_Real -- --------------------- @@ -110,8 +133,6 @@ package body System.Val_Real is else raise Program_Error); -- Maximum exponent of the base that can fit in Num - B : constant Num := Num (Base); - R_Val : Num; S : Integer := Scale; @@ -129,12 +150,53 @@ package body System.Val_Real is R_Val := Num (Val); - -- Take into account the extra digit, if need be. In this case, the - -- three operands are exact, so using an FMA would be ideal. + -- Take into account the extra digit, i.e. do the two computations + + -- (1) R_Val := R_Val * Num (B) + Num (Extra) + -- (2) S := S - 1 + + -- In the first, the three operands are exact, so using an FMA would + -- be ideal, but we are most likely running on the x87 FPU, hence we + -- may not have one. That is why we turn the multiplication into an + -- iterated addition with exact error handling, so that we can do a + -- single rounding at the end. if Need_Extra and then Extra > 0 then - R_Val := R_Val * B + Num (Extra); - S := S - 1; + declare + B : Unsigned := Base; + + Acc : Num := 0.0; + Err : Num := 0.0; + Fac : Num := R_Val; + + begin + loop + -- If B is odd, add one factor. Note that the accumulator is + -- never larger than the factor at this point (it is in fact + -- never larger than the factor minus the initial value). + + if B rem 2 /= 0 then + Acc := (if Acc = 0.0 then Fac else Fast2Sum (Fac, Acc, Err)); + exit when B = 1; + end if; + + -- Now B is (morally) even, halve it and double the factor, + -- which is always an exact operation. + + B := B / 2; + Fac := Fac * 2.0; + end loop; + + -- Add Extra to the error, which are both small integers + + Err := Err + Num (Extra); + + -- Acc + Err is the exact result before rounding + + R_Val := Acc + Err; + + S := S - 1; + end; end if; -- Compute the final value @@ -207,17 +269,23 @@ package body System.Val_Real is -- an artificial underflow. when others => - if S > 0 then - R_Val := R_Val * B ** S; + declare + B : constant Num := Num (Base); - else - if S < -Maxexp then - R_Val := R_Val / B ** Maxexp; - S := S + Maxexp; - end if; + begin - R_Val := R_Val / B ** (-S); - end if; + if S > 0 then + R_Val := R_Val * B ** S; + + else + if S < -Maxexp then + R_Val := R_Val / B ** Maxexp; + S := S + Maxexp; + end if; + + R_Val := R_Val / B ** (-S); + end if; + end; end case; end if; -- cgit v1.1 From 43d5138227078bf9fca4f9b40074609cf51f8e69 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 9 Dec 2020 17:02:26 +0100 Subject: [Ada] Simplify folding of selected components with qualified prefixes gcc/ada/ * sem_eval.adb (Eval_Selected_Component): Simplify with Unqualify. --- gcc/ada/sem_eval.adb | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 263b9fd..7b1e48d 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3847,11 +3847,7 @@ package body Sem_Eval is -- Simplify a selected_component on an aggregate by extracting -- the field directly. - Node := Prefix (N); - - while Nkind (Node) = N_Qualified_Expression loop - Node := Expression (Node); - end loop; + Node := Unqualify (Prefix (N)); if Nkind (Node) = N_Aggregate then Comp := First (Component_Associations (Node)); -- cgit v1.1 From 12e67086ad2777e1f583124f15210ee0323533c3 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 9 Dec 2020 14:34:45 +0100 Subject: [Ada] More precise error about aspects conflicting with Static gcc/ada/ * sem_ch13.adb (Analyze_Aspect_Static): Use aspect name in the error message. --- gcc/ada/sem_ch13.adb | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 07dec4c..2273887 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2594,8 +2594,9 @@ package body Sem_Ch13 is for Asp in Pre_Post_Aspects loop if Has_Aspect (E, Asp) then + Error_Msg_Name_1 := Aspect_Names (Asp); Error_Msg_N - ("this aspect is not allowed for a static " + ("aspect % is not allowed for a static " & "expression function", Find_Aspect (E, Asp)); -- cgit v1.1 From 189c58042ddde50ab07ee105d14c7a24d05f9482 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 9 Dec 2020 15:22:29 +0100 Subject: [Ada] Refactor repeated checks for the expression of aspect Static gcc/ada/ * sem_ch13.adb (Analyze_Aspect_Static): Refactor to have a single check for the expression being present; adapt comments. --- gcc/ada/sem_ch13.adb | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2273887..25e3bd7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2610,25 +2610,23 @@ package body Sem_Ch13 is -- component type C, a similar rule applies to C." end if; - -- Preanalyze the expression (if any) when the aspect resides - -- in a generic unit. (Is this generic-related code necessary - -- for this aspect? It's modeled on what's done for aspect - -- Disable_Controlled. ???) + -- When the expression is present, it must be static. If it + -- evaluates to True, the expression function is treated as + -- a static function. Otherwise the aspect appears without + -- an expression and defaults to True. - if Inside_A_Generic then - if Present (Expr) then - Preanalyze_And_Resolve (Expr, Any_Boolean); - end if; + if Present (Expr) then + -- Preanalyze the expression when the aspect resides in a + -- generic unit. (Is this generic-related code necessary + -- for this aspect? It's modeled on what's done for aspect + -- Disable_Controlled. ???) - -- Otherwise the aspect resides in a nongeneric context + if Inside_A_Generic then + Preanalyze_And_Resolve (Expr, Any_Boolean); - else - -- When the expression statically evaluates to True, the - -- expression function is treated as a static function. - -- Otherwise the aspect appears without an expression and - -- defaults to True. + -- Otherwise the aspect resides in a nongeneric context - if Present (Expr) then + else Analyze_And_Resolve (Expr, Any_Boolean); -- Error if the boolean expression is not static -- cgit v1.1 From 88fd22e721c32580610d1756701cef892e713ad8 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 9 Dec 2020 14:44:00 +0100 Subject: [Ada] Consistent diagnostic on missing -gnat2020 switch for aspects gcc/ada/ * sem_ch13.adb (Analyze_Aspect_Static): Reuse Error_Msg_Ada_2020_Feature for aspect Static. (Analyze_One_Aspect): Likewise for aspect Full_Access. --- gcc/ada/sem_ch13.adb | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 25e3bd7..6af3238 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2500,10 +2500,7 @@ package body Sem_Ch13 is begin if Ada_Version < Ada_2020 then - Error_Msg_N - ("aspect % is an Ada 202x feature", Aspect); - Error_Msg_N ("\compile with -gnat2020", Aspect); - + Error_Msg_Ada_2020_Feature ("aspect %", Sloc (Aspect)); return; end if; @@ -4575,11 +4572,7 @@ package body Sem_Ch13 is -- Ada 202x (AI12-0363): Full_Access_Only elsif A_Id = Aspect_Full_Access_Only then - if Ada_Version < Ada_2020 then - Error_Msg_N - ("aspect % is an Ada 202x feature", Aspect); - Error_Msg_N ("\compile with -gnat2020", Aspect); - end if; + Error_Msg_Ada_2020_Feature ("aspect %", Sloc (Aspect)); -- Ada 202x (AI12-0075): static expression functions -- cgit v1.1 From f358e5c17720c744e227da0c121c1ae168e5c533 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Tue, 8 Dec 2020 21:28:24 +0100 Subject: [Ada] Replace dubious use of Traverse_Func with Traverse_Proc gcc/ada/ * inline.adb (Do_Reset_Calls): Now an instance of Traverse_Proc. --- gcc/ada/inline.adb | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index bb4d97c..f373e89 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3578,17 +3578,10 @@ package body Inline is return OK; end Do_Reset; - function Do_Reset_Calls is new Traverse_Func (Do_Reset); - - -- Local variables - - Dummy : constant Traverse_Result := Do_Reset_Calls (N); - pragma Unreferenced (Dummy); - - -- Start of processing for Reset_Dispatching_Calls + procedure Do_Reset_Calls is new Traverse_Proc (Do_Reset); begin - null; + Do_Reset_Calls (N); end Reset_Dispatching_Calls; --------------------------- -- cgit v1.1 From 894376c44d94df54727b591292e5965cfa35001b Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Tue, 8 Dec 2020 22:34:29 +0100 Subject: [Ada] Simplify data structures for overloaded interpretations gcc/ada/ * sem_type.ads (Write_Interp_Ref): Removed; no longer needed. * sem_type.adb (Headers): Removed; now the hash table is directly in the Interp_Map alone. (Interp_Map): Now an instance of the GNAT.HTable.Simple_HTable. (Last_Overloaded): New variable to emulate Interp_Map.Last. (Add_One_Interp): Adapt to new data structure. (Get_First_Interp): Likewise. (Hash): Likewise. (Init_Interp_Tables): Likewise. (New_Interps): Likewise. (Save_Interps): Likewise; handle O_N variable like in Get_First_Interp. (Write_Interp_Ref): Removed; no longer needed. --- gcc/ada/sem_type.adb | 167 +++++++++++++++------------------------------------ gcc/ada/sem_type.ads | 4 -- 2 files changed, 50 insertions(+), 121 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index 8f636be..8c12b08 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -50,6 +50,8 @@ with Table; with Treepr; use Treepr; with Uintp; use Uintp; +with GNAT.HTable; use GNAT.HTable; + package body Sem_Type is --------------------- @@ -60,21 +62,17 @@ package body Sem_Type is -- their interpretations. An overloaded node has an entry in Interp_Map, -- which in turn contains a pointer into the All_Interp array. The -- interpretations of a given node are contiguous in All_Interp. Each set - -- of interpretations is terminated with the marker No_Interp. In order to - -- speed up the retrieval of the interpretations of an overloaded node, the - -- Interp_Map table is accessed by means of a simple hashing scheme, and - -- the entries in Interp_Map are chained. The heads of clash lists are - -- stored in array Headers. - - -- Headers Interp_Map All_Interp - - -- _ +-----+ +--------+ - -- |_| |_____| --->|interp1 | - -- |_|---------->|node | | |interp2 | - -- |_| |index|---------| |nointerp| - -- |_| |next | | | - -- |-----| | | - -- +-----+ +--------+ + -- of interpretations is terminated with the marker No_Interp. + + -- Interp_Map All_Interp + + -- +-----+ +--------+ + -- | | --->|interp1 | + -- |_____| | |interp2 | + -- |index|---------| |nointerp| + -- |-----| | | + -- | | | | + -- +-----+ +--------+ -- This scheme does not currently reclaim interpretations. In principle, -- after a unit is compiled, all overloadings have been resolved, and the @@ -89,28 +87,26 @@ package body Sem_Type is Table_Increment => Alloc.All_Interp_Increment, Table_Name => "All_Interp"); - type Interp_Ref is record - Node : Node_Id; - Index : Interp_Index; - Next : Int; - end record; - - Header_Size : constant Int := 2 ** 12; - No_Entry : constant Int := -1; - Headers : array (0 .. Header_Size) of Int; + Header_Max : constant := 3079; + -- The number of hash buckets; an arbitrary prime number - package Interp_Map is new Table.Table ( - Table_Component_Type => Interp_Ref, - Table_Index_Type => Int, - Table_Low_Bound => 0, - Table_Initial => Alloc.Interp_Map_Initial, - Table_Increment => Alloc.Interp_Map_Increment, - Table_Name => "Interp_Map"); + subtype Header_Num is Integer range 0 .. Header_Max - 1; - function Hash (N : Node_Id) return Int; + function Hash (N : Node_Id) return Header_Num; -- A trivial hashing function for nodes, used to insert an overloaded -- node into the Interp_Map table. + package Interp_Map is new Simple_HTable + (Header_Num => Header_Num, + Element => Interp_Index, + No_Element => -1, + Key => Node_Id, + Hash => Hash, + Equal => "="); + + Last_Overloaded : Node_Id := Empty; + -- Overloaded node after initializing a new collection of intepretation + ------------------------------------- -- Handling of Overload Resolution -- ------------------------------------- @@ -479,9 +475,9 @@ package body Sem_Type is -- node or the interpretation that is present is for a different -- node. In both cases add a new interpretation to the table. - elsif Interp_Map.Last < 0 + elsif No (Last_Overloaded) or else - (Interp_Map.Table (Interp_Map.Last).Node /= N + (Last_Overloaded /= N and then not Is_Overloaded (N)) then New_Interps (N); @@ -2380,7 +2376,6 @@ package body Sem_Type is It : out Interp) is Int_Ind : Interp_Index; - Map_Ptr : Int; O_N : Node_Id; begin @@ -2398,21 +2393,16 @@ package body Sem_Type is O_N := N; end if; - Map_Ptr := Headers (Hash (O_N)); - while Map_Ptr /= No_Entry loop - if Interp_Map.Table (Map_Ptr).Node = O_N then - Int_Ind := Interp_Map.Table (Map_Ptr).Index; - It := All_Interp.Table (Int_Ind); - I := Int_Ind; - return; - else - Map_Ptr := Interp_Map.Table (Map_Ptr).Next; - end if; - end loop; + Int_Ind := Interp_Map.Get (O_N); -- Procedure should never be called if the node has no interpretations - raise Program_Error; + if Int_Ind < 0 then + raise Program_Error; + end if; + + I := Int_Ind; + It := All_Interp.Table (Int_Ind); end Get_First_Interp; --------------------- @@ -2545,12 +2535,9 @@ package body Sem_Type is -- Hash -- ---------- - function Hash (N : Node_Id) return Int is + function Hash (N : Node_Id) return Header_Num is begin - -- Nodes have a size that is power of two, so to select significant - -- bits only we remove the low-order bits. - - return ((Int (N) / 2 ** 5) mod Header_Size); + return Header_Num (N mod Header_Max); end Hash; -------------- @@ -2575,8 +2562,7 @@ package body Sem_Type is procedure Init_Interp_Tables is begin All_Interp.Init; - Interp_Map.Init; - Headers := (others => No_Entry); + Interp_Map.Reset; end Init_Interp_Tables; ----------------------------------- @@ -3094,47 +3080,12 @@ package body Sem_Type is ----------------- procedure New_Interps (N : Node_Id) is - Map_Ptr : Int; - begin All_Interp.Append (No_Interp); - Map_Ptr := Headers (Hash (N)); - - if Map_Ptr = No_Entry then - - -- Place new node at end of table - - Interp_Map.Increment_Last; - Headers (Hash (N)) := Interp_Map.Last; - - else - -- Place node at end of chain, or locate its previous entry - - loop - if Interp_Map.Table (Map_Ptr).Node = N then - - -- Node is already in the table, and is being rewritten. - -- Start a new interp section, retain hash link. - - Interp_Map.Table (Map_Ptr).Node := N; - Interp_Map.Table (Map_Ptr).Index := All_Interp.Last; - Set_Is_Overloaded (N, True); - return; - - else - exit when Interp_Map.Table (Map_Ptr).Next = No_Entry; - Map_Ptr := Interp_Map.Table (Map_Ptr).Next; - end if; - end loop; - - -- Chain the new node - - Interp_Map.Increment_Last; - Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last; - end if; - - Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry); + -- Add or rewrite the existing node + Last_Overloaded := N; + Interp_Map.Set (N, All_Interp.Last); Set_Is_Overloaded (N, True); end New_Interps; @@ -3319,8 +3270,8 @@ package body Sem_Type is ------------------ procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is - Map_Ptr : Int; - O_N : Node_Id := Old_N; + Old_Ind : Interp_Index; + O_N : Node_Id; begin if Is_Overloaded (Old_N) then @@ -3330,18 +3281,15 @@ package body Sem_Type is and then Is_Overloaded (Selector_Name (Old_N)) then O_N := Selector_Name (Old_N); + else + O_N := Old_N; end if; - Map_Ptr := Headers (Hash (O_N)); - - while Interp_Map.Table (Map_Ptr).Node /= O_N loop - Map_Ptr := Interp_Map.Table (Map_Ptr).Next; - pragma Assert (Map_Ptr /= No_Entry); - end loop; + Old_Ind := Interp_Map.Get (O_N); + pragma Assert (Old_Ind >= 0); New_Interps (New_N); - Interp_Map.Table (Interp_Map.Last).Index := - Interp_Map.Table (Map_Ptr).Index; + Interp_Map.Set (New_N, Old_Ind); end if; end Save_Interps; @@ -3646,21 +3594,6 @@ package body Sem_Type is Print_Tree_Node (It.Abstract_Op); end Write_Interp; - ---------------------- - -- Write_Interp_Ref -- - ---------------------- - - procedure Write_Interp_Ref (Map_Ptr : Int) is - begin - Write_Str (" Node: "); - Write_Int (Int (Interp_Map.Table (Map_Ptr).Node)); - Write_Str (" Index: "); - Write_Int (Int (Interp_Map.Table (Map_Ptr).Index)); - Write_Str (" Next: "); - Write_Int (Interp_Map.Table (Map_Ptr).Next); - Write_Eol; - end Write_Interp_Ref; - --------------------- -- Write_Overloads -- --------------------- diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads index 3177bd3..a9c1ba2 100644 --- a/gcc/ada/sem_type.ads +++ b/gcc/ada/sem_type.ads @@ -268,10 +268,6 @@ package Sem_Type is procedure Write_Interp (It : Interp); -- Debugging procedure to display an Interp - procedure Write_Interp_Ref (Map_Ptr : Int); - -- Debugging procedure to display entry in Interp_Map. Would not be needed - -- if it were possible to debug instantiations of Table. - procedure Write_Overloads (N : Node_Id); -- Debugging procedure to output info on possibly overloaded entities for -- specified node. -- cgit v1.1 From bed6154a5a64235fb196e9d6007a4382481e426e Mon Sep 17 00:00:00 2001 From: Patrick Bernardi Date: Wed, 9 Dec 2020 16:48:20 -0500 Subject: [Ada] Install_Restricted_Handlers: define Prio parameter as Interrupt_Priority gcc/ada/ * libgnarl/s-interr.adb (Install_Restricted_Handlers): Change Prio parameter to type Interrupt_Priority. * libgnarl/s-interr.ads (Install_Restricted_Handlers): Likewise. * libgnarl/s-interr__dummy.adb (Install_Restricted_Handlers): Likewise. * libgnarl/s-interr__hwint.adb (Install_Restricted_Handlers): Likewise. * libgnarl/s-interr__sigaction.adb (Install_Restricted_Handlers): Likewise. * libgnarl/s-interr__vxworks.adb (Install_Restricted_Handlers): Likewise. --- gcc/ada/libgnarl/s-interr.adb | 2 +- gcc/ada/libgnarl/s-interr.ads | 2 +- gcc/ada/libgnarl/s-interr__dummy.adb | 2 +- gcc/ada/libgnarl/s-interr__hwint.adb | 2 +- gcc/ada/libgnarl/s-interr__sigaction.adb | 2 +- gcc/ada/libgnarl/s-interr__vxworks.adb | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnarl/s-interr.adb b/gcc/ada/libgnarl/s-interr.adb index c386c47..4cdd912 100644 --- a/gcc/ada/libgnarl/s-interr.adb +++ b/gcc/ada/libgnarl/s-interr.adb @@ -473,7 +473,7 @@ package body System.Interrupts is --------------------------------- procedure Install_Restricted_Handlers - (Prio : Any_Priority; + (Prio : Interrupt_Priority; Handlers : New_Handler_Array) is pragma Unreferenced (Prio); diff --git a/gcc/ada/libgnarl/s-interr.ads b/gcc/ada/libgnarl/s-interr.ads index 0f82beb..ed1602f 100644 --- a/gcc/ada/libgnarl/s-interr.ads +++ b/gcc/ada/libgnarl/s-interr.ads @@ -267,7 +267,7 @@ package System.Interrupts is -- the new static handlers. procedure Install_Restricted_Handlers - (Prio : Any_Priority; + (Prio : Interrupt_Priority; Handlers : New_Handler_Array); -- Install the static Handlers for the given interrupts and do not -- store previously installed handlers. This procedure is used when diff --git a/gcc/ada/libgnarl/s-interr__dummy.adb b/gcc/ada/libgnarl/s-interr__dummy.adb index ffa0710..99df03d 100644 --- a/gcc/ada/libgnarl/s-interr__dummy.adb +++ b/gcc/ada/libgnarl/s-interr__dummy.adb @@ -188,7 +188,7 @@ package body System.Interrupts is --------------------------------- procedure Install_Restricted_Handlers - (Prio : Any_Priority; + (Prio : Interrupt_Priority; Handlers : New_Handler_Array) is begin diff --git a/gcc/ada/libgnarl/s-interr__hwint.adb b/gcc/ada/libgnarl/s-interr__hwint.adb index 5c2c321..912da07 100644 --- a/gcc/ada/libgnarl/s-interr__hwint.adb +++ b/gcc/ada/libgnarl/s-interr__hwint.adb @@ -478,7 +478,7 @@ package body System.Interrupts is --------------------------------- procedure Install_Restricted_Handlers - (Prio : Any_Priority; + (Prio : Interrupt_Priority; Handlers : New_Handler_Array) is pragma Unreferenced (Prio); diff --git a/gcc/ada/libgnarl/s-interr__sigaction.adb b/gcc/ada/libgnarl/s-interr__sigaction.adb index 83bd36c..3e456e3 100644 --- a/gcc/ada/libgnarl/s-interr__sigaction.adb +++ b/gcc/ada/libgnarl/s-interr__sigaction.adb @@ -291,7 +291,7 @@ package body System.Interrupts is --------------------------------- procedure Install_Restricted_Handlers - (Prio : Any_Priority; + (Prio : Interrupt_Priority; Handlers : New_Handler_Array) is pragma Unreferenced (Prio); diff --git a/gcc/ada/libgnarl/s-interr__vxworks.adb b/gcc/ada/libgnarl/s-interr__vxworks.adb index 157f82f..646c822 100644 --- a/gcc/ada/libgnarl/s-interr__vxworks.adb +++ b/gcc/ada/libgnarl/s-interr__vxworks.adb @@ -494,7 +494,7 @@ package body System.Interrupts is --------------------------------- procedure Install_Restricted_Handlers - (Prio : Any_Priority; + (Prio : Interrupt_Priority; Handlers : New_Handler_Array) is pragma Unreferenced (Prio); -- cgit v1.1 From 33d1be873954bc387387c2f9462fa0139157a182 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Thu, 10 Dec 2020 13:12:22 +0100 Subject: [Ada] Remove redundant assignment in Formal_Is_Used_Once gcc/ada/ * inline.adb (Formal_Is_Used_Once): Refine type of the counter variable; remove redundant assignment. --- gcc/ada/inline.adb | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index f373e89..16c4cd7 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -2827,7 +2827,7 @@ package body Inline is ------------------------- function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is - Use_Counter : Int := 0; + Use_Counter : Nat := 0; function Count_Uses (N : Node_Id) return Traverse_Result; -- Traverse the tree and count the uses of the formal parameter. @@ -2856,13 +2856,10 @@ package body Inline is then Use_Counter := Use_Counter + 1; - if Use_Counter > 1 then - - -- Denote more than one use and abandon the traversal + -- If this is a second use then abandon the traversal - Use_Counter := 2; + if Use_Counter > 1 then return Abandon; - end if; end if; -- cgit v1.1 From 4e60fea9206696782e2292419da9add02d0b609c Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 10 Dec 2020 21:02:07 +0100 Subject: [Ada] Fix computation of Prec/Succ of zero without denormals gcc/ada/ * libgnat/s-fatgen.adb: Add use clause for Interfaces.Unsigned_16 and Interfaces.Unsigned_32. (Small16): New constant. (Small32): Likewise. (Small64): Likewise. (Small80): Likewise. (Pred): Declare a local overlay for Small and return it negated for zero if the type does not support denormalized numbers. (Succ): Likewise, but return it directly. --- gcc/ada/libgnat/s-fatgen.adb | 33 +++++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb index 9f25987..01493b7 100644 --- a/gcc/ada/libgnat/s-fatgen.adb +++ b/gcc/ada/libgnat/s-fatgen.adb @@ -42,6 +42,8 @@ pragma Warnings (Off, "non-static constant in preelaborated unit"); -- Every constant is static given our instantiation model package body System.Fat_Gen is + use type Interfaces.Unsigned_16; + use type Interfaces.Unsigned_32; use type Interfaces.Unsigned_64; pragma Assert (T'Machine_Radix = 2); @@ -59,6 +61,18 @@ package body System.Fat_Gen is -- Small : constant T := Rad ** (T'Machine_Emin - 1); -- Smallest positive normalized number + Small16 : constant Interfaces.Unsigned_16 := 2**(Mantissa - 1); + Small32 : constant Interfaces.Unsigned_32 := 2**(Mantissa - 1); + Small64 : constant Interfaces.Unsigned_64 := 2**(Mantissa - 1); + Small80 : constant array (1 .. 2) of Interfaces.Unsigned_64 := + (2**48 * (1 - Standard'Default_Bit_Order), + 1 * Standard'Default_Bit_Order); + for Small80'Alignment use Standard'Maximum_Alignment; + -- We cannot use the direct declaration because it cannot be translated + -- into C90, as the hexadecimal floating constants were introduced in C99. + -- So we work around this by using an overlay of the integer constant. + -- ??? Revisit this when the new CCG technoloy is in production + -- Tiny : constant T := Rad ** (T'Machine_Emin - Mantissa); -- Smallest positive denormalized number @@ -72,6 +86,7 @@ package body System.Fat_Gen is -- We cannot use the direct declaration because it cannot be translated -- into C90, as the hexadecimal floating constants were introduced in C99. -- So we work around this by using an overlay of the integer constant. + -- ??? Revisit this when the new CCG technoloy is in production RM1 : constant T := Rad ** (Mantissa - 1); -- Smallest positive member of the large consecutive integers. It is equal @@ -424,6 +439,13 @@ package body System.Fat_Gen is ---------- function Pred (X : T) return T is + Small : constant T; + pragma Import (Ada, Small); + for Small'Address use (if T'Size = 16 then Small16'Address + elsif T'Size = 32 then Small32'Address + elsif T'Size = 64 then Small64'Address + elsif Mantissa = 64 then Small80'Address + else raise Program_Error); Tiny : constant T; pragma Import (Ada, Tiny); for Tiny'Address use (if T'Size = 16 then Tiny16'Address @@ -438,7 +460,7 @@ package body System.Fat_Gen is -- Zero has to be treated specially, since its exponent is zero if X = 0.0 then - return -Tiny; + return -(if T'Denorm then Tiny else Small); -- Special treatment for largest negative number: raise Constraint_Error @@ -700,6 +722,13 @@ package body System.Fat_Gen is ---------- function Succ (X : T) return T is + Small : constant T; + pragma Import (Ada, Small); + for Small'Address use (if T'Size = 16 then Small16'Address + elsif T'Size = 32 then Small32'Address + elsif T'Size = 64 then Small64'Address + elsif Mantissa = 64 then Small80'Address + else raise Program_Error); Tiny : constant T; pragma Import (Ada, Tiny); for Tiny'Address use (if T'Size = 16 then Tiny16'Address @@ -714,7 +743,7 @@ package body System.Fat_Gen is -- Treat zero specially since it has a zero exponent if X = 0.0 then - return Tiny; + return (if T'Denorm then Tiny else Small); -- Special treatment for largest positive number: raise Constraint_Error -- cgit v1.1 From 5485d0e5569037c0bdc04192e174a048f7d69a61 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 10 Dec 2020 11:22:23 -0500 Subject: [Ada] Fix recent optimization in evaluation of selected component for GNATprove gcc/ada/ * sem_eval.adb (Eval_Selected_Component): Only consider compile time known aggregates. --- gcc/ada/sem_eval.adb | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 7b1e48d..3ccf3a0 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -3849,7 +3849,9 @@ package body Sem_Eval is Node := Unqualify (Prefix (N)); - if Nkind (Node) = N_Aggregate then + if Nkind (Node) = N_Aggregate + and then Compile_Time_Known_Aggregate (Node) + then Comp := First (Component_Associations (Node)); Nam := Chars (Selector_Name (N)); -- cgit v1.1 From ba344f1ba6948ded21ba3bda4d0f7460eee2862b Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Fri, 11 Dec 2020 00:42:22 +0100 Subject: [Ada] Adjust List_Length description gcc/ada/ * nlists.ads (List_Length): Adapt comment to match the behaviour. --- gcc/ada/nlists.ads | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads index 169c8e5..c006131 100644 --- a/gcc/ada/nlists.ads +++ b/gcc/ada/nlists.ads @@ -146,9 +146,9 @@ package Nlists is -- No_List. (No_List is not considered to be the same as an empty list). function List_Length (List : List_Id) return Nat; - -- Returns number of items in the given list. It is an error to call - -- this function with No_List (No_List is not considered to be the same - -- as an empty list). + -- Returns number of items in the given list. If called on No_List it + -- returns 0, even though No_List is not considered to be the same as an + -- empty list. function Next (Node : Node_Or_Entity_Id) return Node_Or_Entity_Id; pragma Inline (Next); -- cgit v1.1 From f9d670128f6e6b3631a2db575ddf6f19fa43afdc Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Fri, 11 Dec 2020 10:41:20 +0100 Subject: [Ada] Style fixes related to calls to List_Length gcc/ada/ * sem_ch13.adb, sem_util.adb: Fix style. --- gcc/ada/sem_ch13.adb | 2 ++ gcc/ada/sem_util.adb | 8 ++++++-- 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 6af3238..c863154 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -11794,6 +11794,8 @@ package body Sem_Ch13 is end; end Check_Component_List; + -- Local variables + Sbit : Uint; -- Starting bit for call to Check_Component_List. Zero for an -- untagged type. The size of the Tag for a nonderived tagged diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index e3ac718..b7b622d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -29957,7 +29957,7 @@ package body Sem_Util is procedure Normalize_Interval_List (List : in out Discrete_Interval_List; Last : out Nat); - -- Perform sorting and merging as required by Check_Consistency. + -- Perform sorting and merging as required by Check_Consistency ------------------------- -- Aggregate_Intervals -- @@ -29972,6 +29972,10 @@ package body Sem_Util is -- Count the number of intervals given in the aggregate N; the others -- choice (if present) is not taken into account. + ------------------------------ + -- Unmerged_Intervals_Count -- + ------------------------------ + function Unmerged_Intervals_Count return Nat is Count : Nat := 0; Choice : Node_Id; @@ -30072,7 +30076,7 @@ package body Sem_Util is (Discrete_Choices : List_Id) return Discrete_Interval_List is function Unmerged_Choice_Count return Nat; - -- The number of intervals before adjacent intervals are merged. + -- The number of intervals before adjacent intervals are merged --------------------------- -- Unmerged_Choice_Count -- -- cgit v1.1 From e4ff4ffb43d3d8520f1c106e04421f2e6a021c39 Mon Sep 17 00:00:00 2001 From: GCC Administrator Date: Thu, 29 Apr 2021 00:17:01 +0000 Subject: Daily bump. --- gcc/ada/ChangeLog | 298 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 298 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 55ef853..f3ad896 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,301 @@ +2021-04-28 Piotr Trojanek + + * sem_ch13.adb, sem_util.adb: Fix style. + +2021-04-28 Piotr Trojanek + + * nlists.ads (List_Length): Adapt comment to match the + behaviour. + +2021-04-28 Arnaud Charlet + + * sem_eval.adb (Eval_Selected_Component): Only consider compile + time known aggregates. + +2021-04-28 Eric Botcazou + + * libgnat/s-fatgen.adb: Add use clause for Interfaces.Unsigned_16 + and Interfaces.Unsigned_32. + (Small16): New constant. + (Small32): Likewise. + (Small64): Likewise. + (Small80): Likewise. + (Pred): Declare a local overlay for Small and return it negated + for zero if the type does not support denormalized numbers. + (Succ): Likewise, but return it directly. + +2021-04-28 Piotr Trojanek + + * inline.adb (Formal_Is_Used_Once): Refine type of the counter + variable; remove redundant assignment. + +2021-04-28 Patrick Bernardi + + * libgnarl/s-interr.adb (Install_Restricted_Handlers): Change + Prio parameter to type Interrupt_Priority. + * libgnarl/s-interr.ads (Install_Restricted_Handlers): Likewise. + * libgnarl/s-interr__dummy.adb (Install_Restricted_Handlers): + Likewise. + * libgnarl/s-interr__hwint.adb (Install_Restricted_Handlers): + Likewise. + * libgnarl/s-interr__sigaction.adb (Install_Restricted_Handlers): + Likewise. + * libgnarl/s-interr__vxworks.adb (Install_Restricted_Handlers): + Likewise. + +2021-04-28 Piotr Trojanek + + * sem_type.ads (Write_Interp_Ref): Removed; no longer needed. + * sem_type.adb (Headers): Removed; now the hash table is + directly in the Interp_Map alone. + (Interp_Map): Now an instance of the GNAT.HTable.Simple_HTable. + (Last_Overloaded): New variable to emulate Interp_Map.Last. + (Add_One_Interp): Adapt to new data structure. + (Get_First_Interp): Likewise. + (Hash): Likewise. + (Init_Interp_Tables): Likewise. + (New_Interps): Likewise. + (Save_Interps): Likewise; handle O_N variable like in + Get_First_Interp. + (Write_Interp_Ref): Removed; no longer needed. + +2021-04-28 Piotr Trojanek + + * inline.adb (Do_Reset_Calls): Now an instance of Traverse_Proc. + +2021-04-28 Piotr Trojanek + + * sem_ch13.adb (Analyze_Aspect_Static): Reuse + Error_Msg_Ada_2020_Feature for aspect Static. + (Analyze_One_Aspect): Likewise for aspect Full_Access. + +2021-04-28 Piotr Trojanek + + * sem_ch13.adb (Analyze_Aspect_Static): Refactor to have a + single check for the expression being present; adapt comments. + +2021-04-28 Piotr Trojanek + + * sem_ch13.adb (Analyze_Aspect_Static): Use aspect name in the + error message. + +2021-04-28 Piotr Trojanek + + * sem_eval.adb (Eval_Selected_Component): Simplify with + Unqualify. + +2021-04-28 Eric Botcazou + + * libgnat/s-valrea.adb (Fast2Sum): New function. + (Integer_to_Real): Use it in an iterated addition with exact + error handling for the case where an extra digit is needed. + Move local variable now only used in the exponentiation case. + +2021-04-28 Yannick Moy + + * errout.adb: (Error_Msg_Internal): Use span instead of + location. + (Error_Msg, Error_Msg_NEL): Add versions with span parameter. + (Error_Msg_F, Error_Msg_FE, Error_Msg_N, Error_Msg_NE, + Error_Msg_NW): Retrieve span from node. + (First_Node): Use the new First_And_Last_Nodes. + (First_And_Last_Nodes): Expand on previous First_Node. Apply to + other nodes than expressions. + (First_Sloc): Protect against inconsistent locations. + (Last_Node): New function based on First_And_Last_Nodes. + (Last_Sloc): New function similar to First_Sloc. + (Output_Messages): Update output when -gnatdF is used. Use + character ~ for making the span visible, similar to what is done + in GCC and Clang. + * errout.ads (Error_Msg, Error_Msg_NEL): Add versions with span + parameter. + (First_And_Last_Nodes, Last_Node, Last_Sloc): New subprograms. + * erroutc.adb: Adapt to Sptr field being a span. + * erroutc.ads (Error_Msg_Object): Change field Sptr from + location to span. + * errutil.adb: Adapt to Sptr field being a span. + * freeze.adb: Use Errout reporting procedures for nodes to get + spans. + * par-ch3.adb: Likewise. + * par-prag.adb: Likewise. + * par-util.adb: Likewise. + * sem_case.adb: Likewise. + * sem_ch13.adb: Likewise. + * sem_ch3.adb: Likewise. + * sem_prag.adb: Likewise. + * types.ads: (Source_Span): New type for spans. + (To_Span): Basic constructors for spans. + +2021-04-28 Arnaud Charlet + + * einfo.adb (Discriminant_Constraint): Refine assertion. + +2021-04-28 Gary Dismukes + + * exp_util.adb (Add_Own_DIC): Suppress expansion of a DIC pragma + when the pragma occurs for an abstract type, since that could + lead to a call to an abstract function, and such DIC checks can + never be performed for abstract types in any case. + * sem_disp.adb (Check_Dispatching_Context): Suppress the check + for illegal calls to abstract subprograms when the call occurs + within a Default_Initial_Condition aspect and the call is passed + the current instance as an actual. + (Has_Controlling_Current_Instance_Actual): New function to test + a call to see if it has any actuals given by direct references + to a current instance of a type + * sem_res.adb (Resolve_Actuals): Issue an error for a call + within a DIC aspect to a nonprimitive subprogram with an actual + given by the name of the DIC type's current instance (which will + show up as a reference to the formal parameter of a DIC + procedure). + +2021-04-28 Ed Schonberg + + * exp_ch3.adb (Expand_Record_Extension): Set Parent_Subtype on + the type extension when within a generic unit, even though + expansion is disabled, to allow for proper resolution of + selected components inherited from an ancestor. + +2021-04-28 Arnaud Charlet + + * sem_aux.adb (Is_Limited_Type): Fix logic to check Is_Type + before assuming Ent is a typo. + * sem_ch4.adb (Analyze_Expression_With_Actions): Update + comments, minor reformatting. + * sem_res.adb (Resolve_Declare_Expression): Add protection + against no type. + +2021-04-28 Arnaud Charlet + + * exp_ch6.adb: Fix typo in comment. + * sem_ch3.adb (Access_Subprogram_Declaration): Add missing call + to Create_Extra_Formals. Remove obsolete bootstrap check. + * sem_eval.adb (Eval_Selected_Component): Simplify a + selected_component on an aggregate. + +2021-04-28 Piotr Trojanek + + * fmap.ads (Reset_Tables): Remove outdated references to + GNSA/ASIS. + * sem_eval.ads (Initialize): Likewise. + * sem_type.adb (Headers): Remove initialization at elaboration. + * sem_type.ads (Init_Interp_Tables): Remove outdated reference + to gnatf. + * stringt.ads (Initialize): Fix style in comment. + +2021-04-28 Piotr Trojanek + + * sem_res.ads: Update reference in comment. + * sem_type.ads: Fix casing in a name of a unit. + +2021-04-28 Yannick Moy + + * ghost.adb (Check_Ghost_Context): Add continuation message when + in predicate. + +2021-04-28 Eric Botcazou + + * libgnat/s-valrea.adb (Integer_to_Real): Use a subtype of Num + for the component type of the table of powers of ten. + * libgnat/s-valuer.adb (Round_Extra): Add assertion on Base. + +2021-04-28 Piotr Trojanek + + * sem_ch5.adb (Analyze_Case_Statement): Extend optimization to + all objects; fix typo in comment. + +2021-04-28 Piotr Trojanek + + * exp_ch9.adb (Build_Barrier_Function): Refine type of a + protected type entity. + (Is_Pure_Barrier): Fix style. + +2021-04-28 Bob Duff + + * exp_ch3.adb (Simple_Init_Defaulted_Type): Simplify the code, + and always use OK_Convert_To, rather than Unchecked_Convert_To + and Convert_To. + +2021-04-28 Arnaud Charlet + + * sem_ch3.adb (Analyze_Object_Declaration): Remove dead code. + * ali.ads, ali.adb (Scan_ALI): Remove unused parameters. + Remove unused code related to Xref lines. + (Get_Typeref): Removed, no longer used. + +2021-04-28 Arnaud Charlet + + * exp_attr.adb (Build_Array_VS_Func, Build_Record_VS_Func, + Expand_N_Attribute_Reference): Use Get_Fullest_View instead of + Validated_View. + (Build_Record_VS_Func): Adjust to keep using Validated_View. + (Expand_N_Attribute_Reference) [Valid]: Use + Small_Integer_Type_For to allow for more compile time + evaluations. + * sem_util.adb (Cannot_Raise_Constraint_Error): Add more precise + support for N_Indexed_Component and fix support for + N_Selected_Component which wasn't completely safe. + (List_Cannot_Raise_CE): New. + * libgnat/i-cobol.adb (Valid_Packed): Simplify test to address + new GNAT warning. + +2021-04-28 Arnaud Charlet + + * .gitignore: New. + * doc/share/conf.py: Add Python 3 compatibility. + * doc/share/gnat.sty: Add missing file. + +2021-04-28 Richard Wai + + * libgnat/a-cohase.ads (Cursor): Synchronize comments for the Cursor + type definition to be consistent with identical definitions in other + container packages. Add additional comments regarding the importance of + maintaining the "Position" component for predefined equality. + * libgnat/a-cohama.ads (Cursor): Likewise. + * libgnat/a-cihama.ads (Cursor): Likewise. + * libgnat/a-cohase.adb (Find, Insert): Ensure that Cursor objects + always have their "Position" component set to ensure predefined + equality works as required. + * libgnat/a-cohama.adb (Find, Insert): Likewise. + * libgnat/a-cihama.adb (Find, Insert): Likewise. + +2021-04-28 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_subprog_type): Do not demote a + const or pure function because of a parameter whose type is pointer + to function. + * gcc-interface/trans.c (Call_to_gnu): Do not put back a conversion + between an actual and a formal that are unconstrained array types. + (gnat_gimplify_expr) : New case. + * gcc-interface/utils2.c (build_binary_op): Do not use |= operator. + (gnat_stabilize_reference_1): Likewise. + (gnat_rewrite_reference): Likewise. + (build_unary_op): Do not clear existing TREE_CONSTANT on the result. + (gnat_build_constructor): Also accept the address of a constant + CONSTRUCTOR as constant element. + +2021-04-28 Eric Botcazou + + * gcc-interface/trans.c (is_array_of_scalar_type): New predicate. + (find_decls_r): New function. + (return_slot_opt_for_pure_call_p): New predicate. + (Call_to_gnu): Do not create a temporary for the return value if the + parent node is an aggregate. If there is a target, try to apply the + return slot optimization to regular calls to pure functions returning + an array of scalar type. + +2021-04-28 Eric Botcazou + + * gcc-interface/trans.c (language_function): Add comment. + (loop_info_d): Add fndecl and invariants fields. + (find_loop_for): Test fndecl instead of the context of var. + (find_loop): New function. + (Regular_Loop_to_gnu): Fold back into... + (Loop_Statement_to_gnu): ...this. Emit invariants on entry, if any. + (gnat_to_gnu) : Record nonconstant invariant + offset computations in loops when optimization is enabled. + * gcc-interface/utils2.c (gnat_invariant_expr): Handle BIT_AND_EXPR. + 2021-04-20 Martin Liska * gnatvsn.ads: Bump Library_Version to 12. -- cgit v1.1 From 2baa4614c8f91015f06b69f09f3ce6360a77c5a8 Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Fri, 11 Dec 2020 11:32:07 +0100 Subject: [Ada] Fixes in the use of spans for error locations gcc/ada/ * errout.adb (Error_Msg_NEL): Extract span from node. (First_And_Last_Nodes): Use spans for subtype indications and attribute definition clauses. (Write_Source_Code_Lines): Fix for tabulation characters. Change output for large spans to skip intermediate lines. * sem_case.adb (Check_Choice_Set): Report duplicate choice on the Original_Node for the case. (Generic_Check_Choices): Set the Original_Node for the rewritten case, so that the subtree used in spans has the correct locations. --- gcc/ada/errout.adb | 196 ++++++++++++++++++++++++++++++++++++++++++++------- gcc/ada/sem_case.adb | 17 +++-- 2 files changed, 181 insertions(+), 32 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 97fd9d4..2b4f278 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -1430,8 +1430,14 @@ package body Errout is E : Node_Or_Entity_Id; Flag_Location : Source_Ptr) is + Fst, Lst : Node_Id; begin - Error_Msg_NEL (Msg, N, E, To_Span (Flag_Location)); + First_And_Last_Nodes (N, Fst, Lst); + Error_Msg_NEL + (Msg, N, E, + To_Span (Ptr => Flag_Location, + First => Source_Ptr'Min (Flag_Location, First_Sloc (Fst)), + Last => Source_Ptr'Max (Flag_Location, Last_Sloc (Lst)))); end Error_Msg_NEL; procedure Error_Msg_NEL @@ -1757,7 +1763,7 @@ package body Errout is and then Get_Source_File_Index (Loc) = Sfile then Latest := Norig; - Lloc := Loc; + Lloc := Loc; end if; return OK_Orig; @@ -1782,6 +1788,8 @@ package body Errout is | N_Pragma | N_Use_Type_Clause | N_With_Clause + | N_Attribute_Definition_Clause + | N_Subtype_Indication then Earliest := Orig; Eloc := Loc; @@ -2284,11 +2292,35 @@ package body Errout is procedure Write_Source_Code_Lines (Span : Source_Span) is + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the end of the line in Buf for Loc + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr; + -- Get the source location for the start of the line in Buf for Loc + function Image (X : Positive; Width : Positive) return String; -- Output number X over Width characters, with whitespace padding. -- Only output the low-order Width digits of X, if X is larger than -- Width digits. + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr); + -- Output the characters from First to Last position in Buf, using + -- Write_Buffer_Char. + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr); + -- Output the characters at position Loc in Buf, translating ASCII.HT + -- in a suitable number of spaces so that the output is not modified + -- by starting in a different column that 1. + procedure Write_Line_Marker (Num : Pos; Mark : Boolean; @@ -2297,6 +2329,44 @@ package body Errout is -- a Mark to denote the line with the main location when reporting -- a span over multiple lines. + ------------------ + -- Get_Line_End -- + ------------------ + + function Get_Line_End + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Loc; + begin + while Cur_Loc <= Buf'Last + and then Buf (Cur_Loc) /= ASCII.LF + loop + Cur_Loc := Cur_Loc + 1; + end loop; + + return Cur_Loc; + end Get_Line_End; + + -------------------- + -- Get_Line_Start -- + -------------------- + + function Get_Line_Start + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) return Source_Ptr + is + Cur_Loc : Source_Ptr := Loc; + begin + while Cur_Loc > Buf'First + and then Buf (Cur_Loc - 1) /= ASCII.LF + loop + Cur_Loc := Cur_Loc - 1; + end loop; + + return Cur_Loc; + end Get_Line_Start; + ----------- -- Image -- ----------- @@ -2317,6 +2387,50 @@ package body Errout is return Str; end Image; + ------------------ + -- Write_Buffer -- + ------------------ + + procedure Write_Buffer + (Buf : Source_Buffer_Ptr; + First : Source_Ptr; + Last : Source_Ptr) + is + begin + for Loc in First .. Last loop + Write_Buffer_Char (Buf, Loc); + end loop; + end Write_Buffer; + + ----------------------- + -- Write_Buffer_Char -- + ----------------------- + + procedure Write_Buffer_Char + (Buf : Source_Buffer_Ptr; + Loc : Source_Ptr) + is + begin + -- If the character ASCII.HT is not the last one in the file, + -- output as many spaces as the character represents in the + -- original source file. + + if Buf (Loc) = ASCII.HT + and then Loc < Buf'Last + then + for X in Get_Column_Number (Loc) .. + Get_Column_Number (Loc + 1) - 1 + loop + Write_Char (' '); + end loop; + + -- Otherwise output the character itself + + else + Write_Char (Buf (Loc)); + end if; + end Write_Buffer_Char; + ----------------------- -- Write_Line_Marker -- ----------------------- @@ -2360,42 +2474,70 @@ package body Errout is if Loc >= First_Source_Ptr then Buf := Source_Text (Get_Source_File_Index (Loc)); - -- First line of the span with actual source code + -- First line of the span with actual source code. We retrieve + -- the beginning of the line instead of relying on Col_Fst, as + -- ASCII.HT characters change column numbers by possibly more + -- than one. Write_Line_Marker (Cur_Line, Line_Fst /= Line_Lst and then Cur_Line = Line, Width); - Write_Str - (String (Buf (Fst - Source_Ptr (Col_Fst) + 1 .. Fst - 1))); + Write_Buffer (Buf, Get_Line_Start (Buf, Cur_Loc), Cur_Loc - 1); - -- Output all the lines in the span + -- Output the first/caret/last lines of the span, as well as + -- lines that are directly above/below the caret if they complete + -- the gap with first/last lines, otherwise use ... to denote + -- intermediate lines. - while Cur_Loc <= Buf'Last - and then Cur_Loc < Lst - loop - Write_Char (Buf (Cur_Loc)); - Cur_Loc := Cur_Loc + 1; + declare + function Do_Write_Line (Cur_Line : Pos) return Boolean is + (Cur_Line in Line_Fst | Line | Line_Lst + or else + (Cur_Line = Line_Fst + 1 and then Cur_Line = Line - 1) + or else + (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1)); + begin + while Cur_Loc <= Buf'Last + and then Cur_Loc < Lst + loop + if Do_Write_Line (Cur_Line) then + Write_Buffer_Char (Buf, Cur_Loc); + end if; - if Buf (Cur_Loc - 1) = ASCII.LF then - Cur_Line := Cur_Line + 1; - Write_Line_Marker - (Cur_Line, - Line_Fst /= Line_Lst and then Cur_Line = Line, - Width); - end if; - end loop; + Cur_Loc := Cur_Loc + 1; - -- Output the rest of the last line of the span + if Buf (Cur_Loc - 1) = ASCII.LF then + Cur_Line := Cur_Line + 1; - while Cur_Loc <= Buf'Last - and then Buf (Cur_Loc) /= ASCII.LF - loop - Write_Char (Buf (Cur_Loc)); - Cur_Loc := Cur_Loc + 1; - end loop; + -- Output ... for skipped lines - Write_Eol; + if (Cur_Line = Line + and then not Do_Write_Line (Cur_Line - 1)) + or else + (Cur_Line = Line + 1 + and then not Do_Write_Line (Cur_Line)) + then + Write_Str ((1 .. Width - 3 => ' ') & "... | ..."); + Write_Eol; + end if; + + -- Display the line marker if the line should be + -- displayed. + + if Do_Write_Line (Cur_Line) then + Write_Line_Marker + (Cur_Line, + Line_Fst /= Line_Lst and then Cur_Line = Line, + Width); + end if; + end if; + end loop; + end; + + -- Output the rest of the last line of the span + + Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc)); -- If the span is on one line, output a second line with caret -- sign pointing to location Loc diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 7f35cfc..b69e0ab 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -531,20 +531,23 @@ package body Sem_Case is and then Compile_Time_Known_Value (C) and then Expr_Value (C) = Lo then - Error_Msg_N ("duplication of choice value: &#!", C); + Error_Msg_N + ("duplication of choice value: &#!", Original_Node (C)); -- Not that special case, so just output the integer value else Error_Msg_Uint_1 := Lo; - Error_Msg_N ("duplication of choice value: ^#!", C); + Error_Msg_N + ("duplication of choice value: ^#!", Original_Node (C)); end if; -- Enumeration type else Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); - Error_Msg_N ("duplication of choice value: %#!", C); + Error_Msg_N + ("duplication of choice value: %#!", Original_Node (C)); end if; -- More than one choice value, so print range of values @@ -577,7 +580,9 @@ package body Sem_Case is else Error_Msg_Uint_1 := Lo; Error_Msg_Uint_2 := Hi; - Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); + Error_Msg_N + ("duplication of choice values: ^ .. ^#!", + Original_Node (C)); end if; -- Enumeration type @@ -585,7 +590,8 @@ package body Sem_Case is else Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); - Error_Msg_N ("duplication of choice values: % .. %#!", C); + Error_Msg_N + ("duplication of choice values: % .. %#!", Original_Node (C)); end if; end if; end Dup_Choice; @@ -1521,6 +1527,7 @@ package body Sem_Case is then C := New_Copy (P); Set_Sloc (C, Sloc (Choice)); + Set_Original_Node (C, Choice); if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then Set_Low_Bound (C, Lo); -- cgit v1.1 From 2d98b9a9a8a4a5eb3f361b7e5fc06b7041ba45e6 Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Fri, 11 Dec 2020 01:01:11 -0500 Subject: [Ada] Warning for 'Class applied to untagged incomplete type gcc/ada/ * sem_ch8.adb (Find_Type): Check the No_Obsolescent_Features restriction for 'Class applied to an untagged incomplete type (when Ada_Version >= Ada_2005). Remove disabling of the warning message for such usage, along with the ??? comment, which no longer applies (because the -gnatg switch no longer sets Warn_On_Obsolescent_Feature). --- gcc/ada/sem_ch8.adb | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index efff714..cf5b790 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7893,16 +7893,18 @@ package body Sem_Ch8 is Set_Entity (N, Any_Type); return; - -- ??? This test is temporarily disabled (always - -- False) because it causes an unwanted warning on - -- GNAT sources (built with -gnatg, which includes - -- Warn_On_Obsolescent_ Feature). Once this issue - -- is cleared in the sources, it can be enabled. + else + if Restriction_Check_Required (No_Obsolescent_Features) + then + Check_Restriction + (No_Obsolescent_Features, Prefix (N)); + end if; - elsif Warn_On_Obsolescent_Feature and then False then - Error_Msg_N - ("applying ''Class to an untagged incomplete type" - & " is an obsolescent feature (RM J.11)?r?", N); + if Warn_On_Obsolescent_Feature then + Error_Msg_N + ("applying ''Class to an untagged incomplete type" + & " is an obsolescent feature (RM J.11)?r?", N); + end if; end if; end if; -- cgit v1.1 From ace51190c628d06c12af458dd0b46b99c4e30a4b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 11 Dec 2020 03:57:08 -0500 Subject: [Ada] AI12-0407: Fixups on Big_Integers and Big_Reals gcc/ada/ * libgnat/a-nbnbin.ads (From_Universal_Image): New. (Big_Integer): Update definition. * libgnat/a-nbnbre.ads, libgnat/a-nbnbre.adb (From_Universal_Image): New. (From_String): Remove alternate body, replaced by From_Universal_Image. (Big_Real): Update definition. --- gcc/ada/libgnat/a-nbnbin.ads | 5 ++++- gcc/ada/libgnat/a-nbnbre.adb | 7 ------- gcc/ada/libgnat/a-nbnbre.ads | 11 ++++++++--- 3 files changed, 12 insertions(+), 11 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/a-nbnbin.ads b/gcc/ada/libgnat/a-nbnbin.ads index 668da8d..31a8bc9 100644 --- a/gcc/ada/libgnat/a-nbnbin.ads +++ b/gcc/ada/libgnat/a-nbnbin.ads @@ -22,7 +22,7 @@ package Ada.Numerics.Big_Numbers.Big_Integers with Preelaborate is type Big_Integer is private - with Integer_Literal => From_String, + with Integer_Literal => From_Universal_Image, Put_Image => Put_Image; function Is_Valid (Arg : Big_Integer) return Boolean @@ -116,6 +116,9 @@ is function From_String (Arg : String) return Valid_Big_Integer with Global => null; + function From_Universal_Image (Arg : String) return Valid_Big_Integer + renames From_String; + procedure Put_Image (S : in out Sink'Class; V : Big_Integer); function "+" (L : Valid_Big_Integer) return Valid_Big_Integer diff --git a/gcc/ada/libgnat/a-nbnbre.adb b/gcc/ada/libgnat/a-nbnbre.adb index 4ff5b35..d475b86 100644 --- a/gcc/ada/libgnat/a-nbnbre.adb +++ b/gcc/ada/libgnat/a-nbnbre.adb @@ -593,13 +593,6 @@ package body Ada.Numerics.Big_Numbers.Big_Reals is end; end From_String; - function From_String - (Numerator, Denominator : String) return Valid_Big_Real is - begin - return Big_Integers.From_String (Numerator) / - Big_Integers.From_String (Denominator); - end From_String; - -------------------------- -- From_Quotient_String -- -------------------------- diff --git a/gcc/ada/libgnat/a-nbnbre.ads b/gcc/ada/libgnat/a-nbnbre.ads index ee5636f..eb7c8a7 100644 --- a/gcc/ada/libgnat/a-nbnbre.ads +++ b/gcc/ada/libgnat/a-nbnbre.ads @@ -21,7 +21,7 @@ package Ada.Numerics.Big_Numbers.Big_Reals with Preelaborate is type Big_Real is private with - Real_Literal => From_String, + Real_Literal => From_Universal_Image, Put_Image => Put_Image; function Is_Valid (Arg : Big_Real) return Boolean @@ -122,8 +122,13 @@ is function From_String (Arg : String) return Valid_Big_Real with Global => null; - function From_String (Numerator, Denominator : String) return Valid_Big_Real - with Global => null; + + function From_Universal_Image (Arg : String) return Valid_Big_Real + renames From_String; + function From_Universal_Image (Num, Den : String) return Valid_Big_Real is + (Big_Integers.From_Universal_Image (Num) / + Big_Integers.From_Universal_Image (Den)) + with Global => null; function To_Quotient_String (Arg : Big_Real) return String is (Big_Integers.To_String (Numerator (Arg)) & " / " -- cgit v1.1 From dde4086df2a9c2a1a88bfc02b19dffe2e5b4e87d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Sun, 13 Dec 2020 12:58:26 -0500 Subject: [Ada] Spurious error on 'Image gcc/ada/ * sem_attr.adb (Check_Image_Type): Protect against empty Image_Type. --- gcc/ada/sem_attr.adb | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e4537e4..34865f4 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1466,7 +1466,11 @@ package body Sem_Attr is procedure Check_Image_Type (Image_Type : Entity_Id) is begin + -- Image_Type may be empty in case of another error detected, + -- or if an N_Raise_xxx_Error node is a parent of N. + if Ada_Version < Ada_2020 + and then Present (Image_Type) and then not Is_Scalar_Type (Image_Type) then Error_Msg_Ada_2020_Feature ("nonscalar ''Image", Sloc (P)); -- cgit v1.1 From db3be1483913399077878b763e732f2c5c7e749d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 14 Dec 2020 05:25:13 -0500 Subject: [Ada] Remove obsolete comment gcc/ada/ * debug_a.adb (Debug_Output_Astring): Remove obsolete comment. --- gcc/ada/debug_a.adb | 2 -- 1 file changed, 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb index d3a1424..083ab7d 100644 --- a/gcc/ada/debug_a.adb +++ b/gcc/ada/debug_a.adb @@ -130,8 +130,6 @@ package body Debug_A is procedure Debug_Output_Astring is Vbars : constant String := "|||||||||||||||||||||||||"; - -- Should be constant, removed because of GNAT 1.78 bug ??? - begin if Debug_A_Depth > Vbars'Length then for I in Vbars'Length .. Debug_A_Depth loop -- cgit v1.1 From 4345c9e79ec17c066b4d2d46dd547adbe8fa5e1d Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sun, 13 Dec 2020 23:32:29 +0100 Subject: [Ada] Reimplement Pred and Succ atttributes for floating-point types gcc/ada/ * libgnat/s-fatgen.adb: Remove with clause for Interfaces and use type clauses for Interfaces.Unsigned_{16,32,64}. (Small16): Remove. (Small32): Likewise (Small64): Likewise. (Small80): Likewise. (Tiny16): Likewise. (Tiny32): Likewise. (Tiny64): Likewise. (Tiny80): Likewise. (Siz): Always use 16. (NR): New constant. (Rep_Last): Use it in the computation. (Exp_Factor): Remove special case for 80-bit. (Sign_Mask): Likewise. (Finite_Succ): New function implementing the Succ attribute for finite numbers. (Pred): Rewrite in terms of Finite_Succ. (Succ): Likewise. --- gcc/ada/libgnat/s-fatgen.adb | 375 ++++++++++++++++++++++++------------------- 1 file changed, 213 insertions(+), 162 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb index 01493b7..41af37b 100644 --- a/gcc/ada/libgnat/s-fatgen.adb +++ b/gcc/ada/libgnat/s-fatgen.adb @@ -35,17 +35,12 @@ -- floating-point implementations. with Ada.Unchecked_Conversion; -with Interfaces; with System.Unsigned_Types; pragma Warnings (Off, "non-static constant in preelaborated unit"); -- Every constant is static given our instantiation model package body System.Fat_Gen is - use type Interfaces.Unsigned_16; - use type Interfaces.Unsigned_32; - use type Interfaces.Unsigned_64; - pragma Assert (T'Machine_Radix = 2); -- This version does not handle radix 16 @@ -61,33 +56,9 @@ package body System.Fat_Gen is -- Small : constant T := Rad ** (T'Machine_Emin - 1); -- Smallest positive normalized number - Small16 : constant Interfaces.Unsigned_16 := 2**(Mantissa - 1); - Small32 : constant Interfaces.Unsigned_32 := 2**(Mantissa - 1); - Small64 : constant Interfaces.Unsigned_64 := 2**(Mantissa - 1); - Small80 : constant array (1 .. 2) of Interfaces.Unsigned_64 := - (2**48 * (1 - Standard'Default_Bit_Order), - 1 * Standard'Default_Bit_Order); - for Small80'Alignment use Standard'Maximum_Alignment; - -- We cannot use the direct declaration because it cannot be translated - -- into C90, as the hexadecimal floating constants were introduced in C99. - -- So we work around this by using an overlay of the integer constant. - -- ??? Revisit this when the new CCG technoloy is in production - -- Tiny : constant T := Rad ** (T'Machine_Emin - Mantissa); -- Smallest positive denormalized number - Tiny16 : constant Interfaces.Unsigned_16 := 1; - Tiny32 : constant Interfaces.Unsigned_32 := 1; - Tiny64 : constant Interfaces.Unsigned_64 := 1; - Tiny80 : constant array (1 .. 2) of Interfaces.Unsigned_64 := - (1 * Standard'Default_Bit_Order, - 2**48 * (1 - Standard'Default_Bit_Order)); - for Tiny80'Alignment use Standard'Maximum_Alignment; - -- We cannot use the direct declaration because it cannot be translated - -- into C90, as the hexadecimal floating constants were introduced in C99. - -- So we work around this by using an overlay of the integer constant. - -- ??? Revisit this when the new CCG technoloy is in production - RM1 : constant T := Rad ** (Mantissa - 1); -- Smallest positive member of the large consecutive integers. It is equal -- to the ratio Small / Tiny, which means that multiplying by it normalizes @@ -125,22 +96,23 @@ package body System.Fat_Gen is -- component of Float_Rep, named Most Significant Word (MSW). -- - The sign occupies the most significant bit of the MSW and the - -- exponent is in the following bits. The exception is 80-bit - -- double extended, where they occupy the low 16-bit halfword. - - -- The low-level primitives Copy_Sign, Decompose, Scaling and Valid are - -- implemented by accessing the bit pattern of the floating-point number. - -- Only the normalization of denormalized numbers, if any, and the gradual - -- underflow are left to the hardware, mainly because there is some leeway - -- for the hardware implementation in this area: for example, the MSB of - -- the mantissa, which is 1 for normalized numbers and 0 for denormalized + -- exponent is in the following bits. + + -- The low-level primitives Copy_Sign, Decompose, Finite_Succ, Scaling and + -- Valid are implemented by accessing the bit pattern of the floating-point + -- number. Only the normalization of denormalized numbers, if any, and the + -- gradual underflow are left to the hardware, mainly because there is some + -- leeway for the hardware implementation in this area: for example the MSB + -- of the mantissa, that is 1 for normalized numbers and 0 for denormalized -- numbers, may or may not be stored by the hardware. - Siz : constant := (if System.Word_Size > 32 then 32 else System.Word_Size); + Siz : constant := 16; type Float_Word is mod 2**Siz; + -- We use the GCD of the size of all the supported floating-point formats - N : constant Natural := (T'Size + Siz - 1) / Siz; - Rep_Last : constant Natural := Natural'Min (N - 1, (Mantissa + 16) / Siz); + N : constant Natural := (T'Size + Siz - 1) / Siz; + NR : constant Natural := (Mantissa + 16 + Siz - 1) / Siz; + Rep_Last : constant Natural := Natural'Min (N, NR) - 1; -- Determine the number of Float_Words needed for representing the -- entire floating-point value. Do not take into account excessive -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 @@ -158,12 +130,9 @@ package body System.Fat_Gen is -- we assume Word_Order = Bit_Order. Exp_Factor : constant Float_Word := - (if Mantissa = 64 - then 1 - else 2**(Siz - 1) / Float_Word (IEEE_Emax - IEEE_Emin + 3)); + 2**(Siz - 1) / Float_Word (IEEE_Emax - IEEE_Emin + 3); -- Factor that the extracted exponent needs to be divided by to be in - -- range 0 .. IEEE_Emax - IEEE_Emin + 2. The special case is 80-bit - -- double extended, where the exponent starts the 3rd float word. + -- range 0 .. IEEE_Emax - IEEE_Emin + 2 Exp_Mask : constant Float_Word := Float_Word (IEEE_Emax - IEEE_Emin + 2) * Exp_Factor; @@ -171,10 +140,8 @@ package body System.Fat_Gen is -- range 0 .. IEEE_Emax - IEEE_Emin + 2 contains 2**N values, for some -- N in Natural. - Sign_Mask : constant Float_Word := - (if Mantissa = 64 then 2**15 else 2**(Siz - 1)); - -- Value needed to mask out the sign field. The special case is 80-bit - -- double extended, where the exponent starts the 3rd float word. + Sign_Mask : constant Float_Word := 2**(Siz - 1); + -- Value needed to mask out the sign field ----------------------- -- Local Subprograms -- @@ -186,6 +153,9 @@ package body System.Fat_Gen is -- the sign of the exponent. The absolute value of Frac is in the range -- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero. + function Finite_Succ (X : T) return T; + -- Return the successor of X, a finite number not equal to T'Last + -------------- -- Adjacent -- -------------- @@ -321,6 +291,179 @@ package body System.Fat_Gen is return X_Exp; end Exponent; + ----------------- + -- Finite_Succ -- + ----------------- + + function Finite_Succ (X : T) return T is + XX : T := T'Machine (X); + + Rep : Float_Rep; + for Rep'Address use XX'Address; + -- Rep is a view of the input floating-point parameter + + begin + -- If the floating-point type does not support denormalized numbers, + -- there is a couple of problematic values, namely -Small and Zero, + -- because the increment is equal to Small in these cases. + + if not T'Denorm then + declare + Small : constant T := Rad ** (T'Machine_Emin - 1); + -- Smallest positive normalized number declared here and not at + -- library level for the sake of the CCG compiler, which cannot + -- currently compile the constant because the target is C90. + + begin + if X = -Small then + XX := 0.0; + return -XX; + elsif X = 0.0 then + return Small; + end if; + end; + end if; + + -- In all the other cases, the increment is equal to 1 in the binary + -- integer representation of the number if X is nonnegative and equal + -- to -1 if X is negative. + + if XX >= 0.0 then + -- First clear the sign of negative Zero + + Rep (MSW) := Rep (MSW) and not Sign_Mask; + + -- Deal with big endian + + if MSW = 0 then + for J in reverse 0 .. Rep_Last loop + Rep (J) := Rep (J) + 1; + + -- For 80-bit IEEE Extended, the MSB of the mantissa is stored + -- so, when it has been flipped, its status must be reanalyzed. + + if Mantissa = 64 and then J = 1 then + + -- If the MSB changed from denormalized to normalized, then + -- keep it normalized since the exponent will be bumped. + + if Rep (J) = 2**(Siz - 1) then + null; + + -- If the MSB changed from normalized, restore it since we + -- cannot denormalize in this context. + + elsif Rep (J) = 0 then + Rep (J) := 2**(Siz - 1); + + else + exit; + end if; + + -- In other cases, stop if there is no carry + + else + exit when Rep (J) > 0; + end if; + end loop; + + -- Deal with little endian + + else + for J in 0 .. Rep_Last loop + Rep (J) := Rep (J) + 1; + + -- For 80-bit IEEE Extended, the MSB of the mantissa is stored + -- so, when it has been flipped, its status must be reanalyzed. + + if Mantissa = 64 and then J = Rep_Last - 1 then + + -- If the MSB changed from denormalized to normalized, then + -- keep it normalized since the exponent will be bumped. + + if Rep (J) = 2**(Siz - 1) then + null; + + -- If the MSB changed from normalized, restore it since we + -- cannot denormalize in this context. + + elsif Rep (J) = 0 then + Rep (J) := 2**(Siz - 1); + + else + exit; + end if; + + -- In other cases, stop if there is no carry + + else + exit when Rep (J) > 0; + end if; + end loop; + end if; + + else + if MSW = 0 then + for J in reverse 0 .. Rep_Last loop + Rep (J) := Rep (J) - 1; + + -- For 80-bit IEEE Extended, the MSB of the mantissa is stored + -- so, when it has been flipped, its status must be reanalyzed. + + if Mantissa = 64 and then J = 1 then + + -- If the MSB changed from normalized to denormalized, then + -- keep it normalized if the exponent is not 1. + + if Rep (J) = 2**(Siz - 1) - 1 then + if Rep (0) /= 2**(Siz - 1) + 1 then + Rep (J) := 2**Siz - 1; + end if; + + else + exit; + end if; + + -- In other cases, stop if there is no borrow + + else + exit when Rep (J) < 2**Siz - 1; + end if; + end loop; + + else + for J in 0 .. Rep_Last loop + Rep (J) := Rep (J) - 1; + + -- For 80-bit IEEE Extended, the MSB of the mantissa is stored + -- so, when it has been flipped, its status must be reanalyzed. + + if Mantissa = 64 and then J = Rep_Last - 1 then + + -- If the MSB changed from normalized to denormalized, then + -- keep it normalized if the exponent is not 1. + + if Rep (J) = 2**(Siz - 1) - 1 then + if Rep (Rep_Last) /= 2**(Siz - 1) + 1 then + Rep (J) := 2**Siz - 1; + end if; + + else + exit; + end if; + + -- In other cases, stop if there is no borrow + + else + exit when Rep (J) < 2**Siz - 1; + end if; + end loop; + end if; + end if; + + return XX; + end Finite_Succ; + ----------- -- Floor -- ----------- @@ -439,73 +582,27 @@ package body System.Fat_Gen is ---------- function Pred (X : T) return T is - Small : constant T; - pragma Import (Ada, Small); - for Small'Address use (if T'Size = 16 then Small16'Address - elsif T'Size = 32 then Small32'Address - elsif T'Size = 64 then Small64'Address - elsif Mantissa = 64 then Small80'Address - else raise Program_Error); - Tiny : constant T; - pragma Import (Ada, Tiny); - for Tiny'Address use (if T'Size = 16 then Tiny16'Address - elsif T'Size = 32 then Tiny32'Address - elsif T'Size = 64 then Tiny64'Address - elsif Mantissa = 64 then Tiny80'Address - else raise Program_Error); - X_Frac : T; - X_Exp : UI; - begin - -- Zero has to be treated specially, since its exponent is zero - - if X = 0.0 then - return -(if T'Denorm then Tiny else Small); - -- Special treatment for largest negative number: raise Constraint_Error - elsif X = T'First then + if X = T'First then raise Constraint_Error with "Pred of largest negative number"; - -- For infinities, return unchanged + -- For finite numbers, use the symmetry around zero of floating point - elsif X < T'First or else X > T'Last then + elsif X > T'First and then X <= T'Last then + pragma Annotate (CodePeer, Intentional, "test always true", + "Check for invalid float"); pragma Annotate (CodePeer, Intentional, "condition predetermined", "Check for invalid float"); - return X; - pragma Annotate (CodePeer, Intentional, "dead code", - "Check float range."); + return -Finite_Succ (-X); - -- Subtract from the given number a number equivalent to the value - -- of its least significant bit. Given that the most significant bit - -- represents a value of 1.0 * Radix ** (Exp - 1), the value we want - -- is obtained by shifting this by (Mantissa-1) bits to the right, - -- i.e. decreasing the exponent by that amount. + -- For infinities and NaNs, return unchanged else - Decompose (X, X_Frac, X_Exp); - - -- For a denormalized number or a normalized number with the lowest - -- exponent, just subtract the Tiny. - - if X_Exp <= T'Machine_Emin then - return X - Tiny; - - -- A special case, if the number we had was a power of two on the - -- positive side of zero, then we want to subtract half of what we - -- would have subtracted, since the exponent is going to be reduced. - - -- Note that X_Frac has the same sign as X so, if X_Frac is Invrad, - -- then we know that we had a power of two on the positive side. - - elsif X_Frac = Invrad then - return X - Scaling (1.0, X_Exp - Mantissa - 1); - - -- Otherwise the adjustment is unchanged - - else - return X - Scaling (1.0, X_Exp - Mantissa); - end if; + return X; + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); end if; end Pred; @@ -722,73 +819,27 @@ package body System.Fat_Gen is ---------- function Succ (X : T) return T is - Small : constant T; - pragma Import (Ada, Small); - for Small'Address use (if T'Size = 16 then Small16'Address - elsif T'Size = 32 then Small32'Address - elsif T'Size = 64 then Small64'Address - elsif Mantissa = 64 then Small80'Address - else raise Program_Error); - Tiny : constant T; - pragma Import (Ada, Tiny); - for Tiny'Address use (if T'Size = 16 then Tiny16'Address - elsif T'Size = 32 then Tiny32'Address - elsif T'Size = 64 then Tiny64'Address - elsif Mantissa = 64 then Tiny80'Address - else raise Program_Error); - X_Frac : T; - X_Exp : UI; - begin - -- Treat zero specially since it has a zero exponent - - if X = 0.0 then - return (if T'Denorm then Tiny else Small); - -- Special treatment for largest positive number: raise Constraint_Error - elsif X = T'Last then + if X = T'Last then raise Constraint_Error with "Succ of largest positive number"; - -- For infinities, return unchanged + -- For finite numbers, call the specific routine - elsif X < T'First or else X > T'Last then + elsif X >= T'First and then X < T'Last then + pragma Annotate (CodePeer, Intentional, "test always true", + "Check for invalid float"); pragma Annotate (CodePeer, Intentional, "condition predetermined", "Check for invalid float"); - return X; - pragma Annotate (CodePeer, Intentional, "dead code", - "Check float range."); + return Finite_Succ (X); - -- Add to the given number a number equivalent to the value of its - -- least significant bit. Given that the most significant bit - -- represents a value of 1.0 * Radix ** (Exp - 1), the value we want - -- is obtained by shifting this by (Mantissa-1) bits to the right, - -- i.e. decreasing the exponent by that amount. + -- For infinities and NaNs, return unchanged else - Decompose (X, X_Frac, X_Exp); - - -- For a denormalized number or a normalized number with the lowest - -- exponent, just add the Tiny. - - if X_Exp <= T'Machine_Emin then - return X + Tiny; - - -- A special case, if the number we had was a power of two on the - -- negative side of zero, then we want to add half of what we would - -- have added, since the exponent is going to be reduced. - - -- Note that X_Frac has the same sign as X, so if X_Frac is -Invrad, - -- then we know that we had a power of two on the negative side. - - elsif X_Frac = -Invrad then - return X + Scaling (1.0, X_Exp - Mantissa - 1); - - -- Otherwise the adjustment is unchanged - - else - return X + Scaling (1.0, X_Exp - Mantissa); - end if; + return X; + pragma Annotate (CodePeer, Intentional, "dead code", + "Check float range."); end if; end Succ; -- cgit v1.1 From a5f38dd83e88a6f2325798cd46a1b5ed5107e2ce Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 14 Dec 2020 15:58:49 +0100 Subject: [Ada] Fix static computation of 'Succ for floating point without denormals gcc/ada/ * eval_fat.adb (Succ): Add a special case for zero if the type does not support denormalized numbers. Always use the canonical formula in other cases and add commentary throughout the function. --- gcc/ada/eval_fat.adb | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 8160cba..69ba742 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -729,22 +729,30 @@ package body Eval_Fat is New_Frac : T; begin + -- Treat zero as a regular denormalized number if they are supported, + -- otherwise return the smallest normalized number. + if UR_Is_Zero (X) then - Exp := Emin; + if Has_Denormals (RT) then + Exp := Emin; + else + return Scaling (RT, Ureal_1, Emin - 1); + end if; end if; - -- Set exponent such that the radix point will be directly following the - -- mantissa after scaling. - - if Has_Denormals (RT) or Exp /= Emin then - Exp := Exp - Mantissa; - else - Exp := Exp - 1; - end if; + -- Multiply the number by 2.0**(Mantissa-Exp) so that the radix point + -- will be directly following the mantissa after scaling. + Exp := Exp - Mantissa; Frac := Scaling (RT, X, -Exp); + + -- Round to the neareast integer towards +Inf + New_Frac := Ceiling (RT, Frac); + -- If the rounding was a NOP, add one, except for -2.0**(Mantissa-1) + -- because the exponent is going to be reduced. + if New_Frac = Frac then if New_Frac = Scaling (RT, -Ureal_1, Mantissa - 1) then New_Frac := New_Frac + Scaling (RT, Ureal_1, Uint_Minus_1); @@ -753,6 +761,8 @@ package body Eval_Fat is end if; end if; + -- Divide back by 2.0**(Mantissa-Exp) to get the final result + return Scaling (RT, New_Frac, Exp); end Succ; -- cgit v1.1 From 4002ae566b093586cde4da6790e7c7ed357f2493 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 14 Dec 2020 15:25:18 +0100 Subject: [Ada] Consistent wording for permissible-vs-allowed prefix gcc/ada/ * doc/gnat_rm/implementation_defined_attributes.rst: Change all occurrences of "permissible prefix" to "allowed prefix", for consistency. * gnat_rm.texi: Regenerate. --- .../gnat_rm/implementation_defined_attributes.rst | 20 ++++++++++---------- gcc/ada/gnat_rm.texi | 22 +++++++++++----------- 2 files changed, 21 insertions(+), 21 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index f8d41ea..fe33dd9 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -196,7 +196,7 @@ Attribute Default_Bit_Order .. index:: Default_Bit_Order ``Standard'Default_Bit_Order`` (``Standard`` is the only -permissible prefix), provides the value ``System.Default_Bit_Order`` +allowed prefix), provides the value ``System.Default_Bit_Order`` as a ``Pos`` value (0 for ``High_Order_First``, 1 for ``Low_Order_First``). This is used to construct the definition of ``Default_Bit_Order`` in package ``System``. @@ -210,7 +210,7 @@ Attribute Default_Scalar_Storage_Order .. index:: Default_Scalar_Storage_Order ``Standard'Default_Scalar_Storage_Order`` (``Standard`` is the only -permissible prefix), provides the current value of the default scalar storage +allowed prefix), provides the current value of the default scalar storage order (as specified using pragma ``Default_Scalar_Storage_Order``, or equal to ``Default_Bit_Order`` if unspecified) as a ``System.Bit_Order`` value. This is a static attribute. @@ -665,7 +665,7 @@ Attribute Maximum_Alignment .. index:: Maximum_Alignment ``Standard'Maximum_Alignment`` (``Standard`` is the only -permissible prefix) provides the maximum useful alignment value for the +allowed prefix) provides the maximum useful alignment value for the target. This is a static value that can be used to specify the alignment for an object, guaranteeing that it is properly aligned in all cases. @@ -674,7 +674,7 @@ Attribute Max_Integer_Size ========================== .. index:: Max_Integer_Size -``Standard'Max_Integer_Size`` (``Standard`` is the only permissible +``Standard'Max_Integer_Size`` (``Standard`` is the only allowed prefix) provides the size of the largest supported integer type for the target. The result is a static constant. @@ -1164,7 +1164,7 @@ Attribute Storage_Unit ====================== .. index:: Storage_Unit -``Standard'Storage_Unit`` (``Standard`` is the only permissible +``Standard'Storage_Unit`` (``Standard`` is the only allowed prefix) provides the same value as ``System.Storage_Unit``. Attribute Stub_Type @@ -1195,7 +1195,7 @@ Attribute System_Allocator_Alignment .. index:: System_Allocator_Alignment ``Standard'System_Allocator_Alignment`` (``Standard`` is the only -permissible prefix) provides the observable guaranted to be honored by +allowed prefix) provides the observable guaranted to be honored by the system allocator (malloc). This is a static value that can be used in user storage pools based on malloc either to reject allocation with alignment too large or to enable a realignment circuitry if the @@ -1205,7 +1205,7 @@ Attribute Target_Name ===================== .. index:: Target_Name -``Standard'Target_Name`` (``Standard`` is the only permissible +``Standard'Target_Name`` (``Standard`` is the only allowed prefix) provides a static string value that identifies the target for the current compilation. For GCC implementations, this is the standard gcc target name without the terminating slash (for @@ -1216,7 +1216,7 @@ Attribute To_Address .. index:: To_Address The ``System'To_Address`` -(``System`` is the only permissible prefix) +(``System`` is the only allowed prefix) denotes a function identical to ``System.Storage_Elements.To_Address`` except that it is a static attribute. This means that if its argument is @@ -1650,7 +1650,7 @@ Attribute Wchar_T_Size ====================== .. index:: Wchar_T_Size -``Standard'Wchar_T_Size`` (``Standard`` is the only permissible +``Standard'Wchar_T_Size`` (``Standard`` is the only allowed prefix) provides the size in bits of the C ``wchar_t`` type primarily for constructing the definition of this type in package ``Interfaces.C``. The result is a static constant. @@ -1659,6 +1659,6 @@ Attribute Word_Size =================== .. index:: Word_Size -``Standard'Word_Size`` (``Standard`` is the only permissible +``Standard'Word_Size`` (``Standard`` is the only allowed prefix) provides the value ``System.Word_Size``. The result is a static constant. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 417ee34..9427dcc 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT Reference Manual , Dec 11, 2020 +GNAT Reference Manual , Apr 12, 2021 AdaCore @@ -10306,7 +10306,7 @@ compatible with older Ada compilers, including notably DEC Ada. @geindex Default_Bit_Order @code{Standard'Default_Bit_Order} (@code{Standard} is the only -permissible prefix), provides the value @code{System.Default_Bit_Order} +allowed prefix), provides the value @code{System.Default_Bit_Order} as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Low_Order_First}). This is used to construct the definition of @code{Default_Bit_Order} in package @code{System}. @@ -10323,7 +10323,7 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @geindex Default_Scalar_Storage_Order @code{Standard'Default_Scalar_Storage_Order} (@code{Standard} is the only -permissible prefix), provides the current value of the default scalar storage +allowed prefix), provides the current value of the default scalar storage order (as specified using pragma @code{Default_Scalar_Storage_Order}, or equal to @code{Default_Bit_Order} if unspecified) as a @code{System.Bit_Order} value. This is a static attribute. @@ -10868,7 +10868,7 @@ this attribute. @geindex Maximum_Alignment @code{Standard'Maximum_Alignment} (@code{Standard} is the only -permissible prefix) provides the maximum useful alignment value for the +allowed prefix) provides the maximum useful alignment value for the target. This is a static value that can be used to specify the alignment for an object, guaranteeing that it is properly aligned in all cases. @@ -10880,7 +10880,7 @@ cases. @geindex Max_Integer_Size -@code{Standard'Max_Integer_Size} (@code{Standard} is the only permissible +@code{Standard'Max_Integer_Size} (@code{Standard} is the only allowed prefix) provides the size of the largest supported integer type for the target. The result is a static constant. @@ -11433,7 +11433,7 @@ with coprime factors (i.e. as an irreducible fraction). @geindex Storage_Unit -@code{Standard'Storage_Unit} (@code{Standard} is the only permissible +@code{Standard'Storage_Unit} (@code{Standard} is the only allowed prefix) provides the same value as @code{System.Storage_Unit}. @node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes @@ -11471,7 +11471,7 @@ an implicit dependency on this unit. @geindex System_Allocator_Alignment @code{Standard'System_Allocator_Alignment} (@code{Standard} is the only -permissible prefix) provides the observable guaranted to be honored by +allowed prefix) provides the observable guaranted to be honored by the system allocator (malloc). This is a static value that can be used in user storage pools based on malloc either to reject allocation with alignment too large or to enable a realignment circuitry if the @@ -11484,7 +11484,7 @@ alignment request is larger than this value. @geindex Target_Name -@code{Standard'Target_Name} (@code{Standard} is the only permissible +@code{Standard'Target_Name} (@code{Standard} is the only allowed prefix) provides a static string value that identifies the target for the current compilation. For GCC implementations, this is the standard gcc target name without the terminating slash (for @@ -11498,7 +11498,7 @@ example, GNAT 5.0 on windows yields "i586-pc-mingw32msv"). @geindex To_Address The @code{System'To_Address} -(@code{System} is the only permissible prefix) +(@code{System} is the only allowed prefix) denotes a function identical to @code{System.Storage_Elements.To_Address} except that it is a static attribute. This means that if its argument is @@ -11960,7 +11960,7 @@ but, unlike @code{Size}, may be set for non-first subtypes. @geindex Wchar_T_Size -@code{Standard'Wchar_T_Size} (@code{Standard} is the only permissible +@code{Standard'Wchar_T_Size} (@code{Standard} is the only allowed prefix) provides the size in bits of the C @code{wchar_t} type primarily for constructing the definition of this type in package @code{Interfaces.C}. The result is a static constant. @@ -11972,7 +11972,7 @@ package @code{Interfaces.C}. The result is a static constant. @geindex Word_Size -@code{Standard'Word_Size} (@code{Standard} is the only permissible +@code{Standard'Word_Size} (@code{Standard} is the only allowed prefix) provides the value @code{System.Word_Size}. The result is a static constant. -- cgit v1.1 From 8bba393a0ac1fca0beceadce0c464502d88e2e57 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Sat, 12 Dec 2020 23:59:34 +0100 Subject: [Ada] Extend Find_Related_Context to deal with child instances gcc/ada/ * sem_elab.adb (Process_SPARK_Instantiation): Fix typo in comment. * sem_prag.adb (Find_Related_Context): Add missing reference to No_Caching in the comment; handle pragmas on compilation units. --- gcc/ada/sem_elab.adb | 2 +- gcc/ada/sem_prag.adb | 11 +++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 89b6e13..5bc116a 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -15121,7 +15121,7 @@ package body Sem_Elab is Inst_Rep : Scenario_Rep_Id; In_State : Processing_In_State); pragma Inline (Process_SPARK_Instantiation); - -- Verify that instanciation Inst does not precede the generic body it + -- Verify that instantiation Inst does not precede the generic body it -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the -- instantiation. In_State is the current state of the Processing phase. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1b1e01b..a1d645e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -243,6 +243,7 @@ package body Sem_Prag is -- Constant_After_Elaboration -- Effective_Reads -- Effective_Writers + -- No_Caching -- Part_Of -- Find the first source declaration or statement found while traversing -- the previous node chain starting from pragma Prag. If flag Do_Checks is @@ -30474,6 +30475,16 @@ package body Sem_Prag is Stmt : Node_Id; begin + -- If the pragma comes from an aspect on a compilation unit that is a + -- package instance, then return the original package instantiation + -- node. + + if Nkind (Parent (Prag)) = N_Compilation_Unit_Aux then + return + Get_Unit_Instantiation_Node + (Defining_Entity (Unit (Enclosing_Comp_Unit_Node (Prag)))); + end if; + Stmt := Prev (Prag); while Present (Stmt) loop -- cgit v1.1 From 02ba09894f669a69936e1f4b43cfa0e8385e0c84 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Sun, 13 Dec 2020 00:01:24 +0100 Subject: [Ada] Fix handling of visibility when categorization from pragmas gcc/ada/ * sem_cat.adb (Set_Categorization_From_Pragmas): Remove special case for generic child units; remove optimization for empty list of pragmas; properly restore visibility. --- gcc/ada/sem_cat.adb | 99 ++++++++++++++++++++++++++++------------------------- 1 file changed, 53 insertions(+), 46 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index ee22113..242f1d2 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -691,56 +691,25 @@ package body Sem_Cat is ------------------------------------- procedure Set_Categorization_From_Pragmas (N : Node_Id) is - P : constant Node_Id := Parent (N); - S : constant Entity_Id := Current_Scope; + P : constant Node_Id := Parent (N); - procedure Set_Parents (Visibility : Boolean); - -- If this is a child instance, the parents are not immediately - -- visible during analysis. Make them momentarily visible so that - -- the argument of the pragma can be resolved properly, and reset - -- afterwards. + procedure Make_Parents_Visible_And_Process_Pragmas (Par : Entity_Id); + -- Parents might not be immediately visible during analysis. Make + -- them momentarily visible so that the argument of the pragma can + -- be resolved properly, process pragmas and restore the previous + -- visibility. - ----------------- - -- Set_Parents -- - ----------------- + procedure Process_Categorization_Pragmas; + -- Process categorization pragmas, if any - procedure Set_Parents (Visibility : Boolean) is - Par : Entity_Id; - begin - Par := Scope (S); - while Present (Par) and then Par /= Standard_Standard loop - Set_Is_Immediately_Visible (Par, Visibility); - Par := Scope (Par); - end loop; - end Set_Parents; - - -- Start of processing for Set_Categorization_From_Pragmas - - begin - -- Deal with categorization pragmas in Pragmas of Compilation_Unit. - -- The purpose is to set categorization flags before analyzing the - -- unit itself, so as to diagnose violations of categorization as - -- we process each declaration, even though the pragma appears after - -- the unit. This processing is only needed if compilation unit pragmas - -- are present. - -- Note: This code may be incorrect in the unlikely case a child generic - -- unit is instantiated as a child of its (nongeneric) parent, so that - -- generic and instance are siblings. - - if Nkind (P) /= N_Compilation_Unit - or else No (First (Pragmas_After (Aux_Decls_Node (P)))) - then - return; - end if; + ------------------------------------ + -- Process_Categorization_Pragmas -- + ------------------------------------ - declare + procedure Process_Categorization_Pragmas is PN : Node_Id; begin - if Is_Child_Unit (S) and then Is_Generic_Instance (S) then - Set_Parents (True); - end if; - PN := First (Pragmas_After (Aux_Decls_Node (P))); while Present (PN) loop @@ -765,11 +734,49 @@ package body Sem_Cat is Next (PN); end loop; + end Process_Categorization_Pragmas; + + ---------------------------------------------- + -- Make_Parents_Visible_And_Process_Pragmas -- + ---------------------------------------------- + + procedure Make_Parents_Visible_And_Process_Pragmas (Par : Entity_Id) is + begin + -- When we reached the Standard scope, then just process pragmas + + if Par = Standard_Standard then + Process_Categorization_Pragmas; - if Is_Child_Unit (S) and then Is_Generic_Instance (S) then - Set_Parents (False); + -- Otherwise make the current scope momentarily visible, recurse + -- into its enclosing scope, and restore the visibility. This is + -- required for child units that are instances of generic parents. + + else + declare + Save_Is_Immediately_Visible : constant Boolean := + Is_Immediately_Visible (Par); + begin + Set_Is_Immediately_Visible (Par); + Make_Parents_Visible_And_Process_Pragmas (Scope (Par)); + Set_Is_Immediately_Visible (Par, Save_Is_Immediately_Visible); + end; end if; - end; + end Make_Parents_Visible_And_Process_Pragmas; + + -- Start of processing for Set_Categorization_From_Pragmas + + begin + -- Deal with categorization pragmas in Pragmas of Compilation_Unit. + -- The purpose is to set categorization flags before analyzing the + -- unit itself, so as to diagnose violations of categorization as + -- we process each declaration, even though the pragma appears after + -- the unit. + + if Nkind (P) /= N_Compilation_Unit then + return; + end if; + + Make_Parents_Visible_And_Process_Pragmas (Scope (Current_Scope)); end Set_Categorization_From_Pragmas; ----------------------------------- -- cgit v1.1 From c3b77813eed1060b96f69cc90b761408bcbc6bb0 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 14 Dec 2020 13:54:28 -0500 Subject: [Ada] Crash on predicated constrained out_parameter gcc/ada/ * sem_util.adb (Build_Constrained_Itype): Inhibit the generation of predicate functions for this Itype, which is created for an aggregate of a discriminated type. The object to which the aggregate is assigned, e.g a writable actual parameter, will apply the predicates if any are inherited from the base type. --- gcc/ada/sem_util.adb | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b7b622d..a64cbde 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2380,6 +2380,14 @@ package body Sem_Util is Analyze (Subtyp_Decl, Suppress => All_Checks); + -- In addition, inhibit the generation of predicate functions for + -- this subtype, because its declaration is not in a declarative + -- list, and no predicates apply to the aggregate itself, but only + -- to the object to which it may be assigned. + + Set_Has_Dynamic_Predicate_Aspect (Def_Id, False); + Set_Has_Predicates (Def_Id, False); + Set_Etype (N, Def_Id); end Build_Constrained_Itype; -- cgit v1.1 From 1c3d8c33b10fccd62561047b41dc4c055614637b Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 14 Dec 2020 23:58:59 +0100 Subject: [Ada] Couple of minor tweaks to Eval_Fat.Succ gcc/ada/ * eval_fat.adb (Succ): Use Ureal_Half in a couple of places. --- gcc/ada/eval_fat.adb | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb index 69ba742..f2e8e41 100644 --- a/gcc/ada/eval_fat.adb +++ b/gcc/ada/eval_fat.adb @@ -736,7 +736,7 @@ package body Eval_Fat is if Has_Denormals (RT) then Exp := Emin; else - return Scaling (RT, Ureal_1, Emin - 1); + return Scaling (RT, Ureal_Half, Emin); end if; end if; @@ -755,7 +755,7 @@ package body Eval_Fat is if New_Frac = Frac then if New_Frac = Scaling (RT, -Ureal_1, Mantissa - 1) then - New_Frac := New_Frac + Scaling (RT, Ureal_1, Uint_Minus_1); + New_Frac := New_Frac + Ureal_Half; else New_Frac := New_Frac + Ureal_1; end if; -- cgit v1.1 From c3ccc5d2ad10ee438eb1bc8effab2f45c5b28100 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 14 Dec 2020 14:49:02 +0100 Subject: [Ada] Refine type of a local size variable gcc/ada/ * layout.adb (Layout_Type): Refine type of a local variable with the required size of object from Int to Pos (it is initialized with 8 and only multiplied by 2); fix unbalanced parens in comment. --- gcc/ada/layout.adb | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index ad80849..0c65870 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -368,7 +368,7 @@ package body Layout is if not Known_Esize (E) then declare - S : Int := 8; + S : Pos := 8; begin loop @@ -381,7 +381,7 @@ package body Layout is -- If the RM_Size is greater than System_Max_Integer_Size -- (happens only when strange values are specified by the -- user), then Esize is simply a copy of RM_Size, it will - -- be further refined later on). + -- be further refined later on. elsif S = System_Max_Integer_Size then Set_Esize (E, RM_Size (E)); -- cgit v1.1 From 40f0ef4fa378fc0506be622209927bd2f3c2d6f8 Mon Sep 17 00:00:00 2001 From: Joel Brobecker Date: Tue, 15 Dec 2020 08:58:10 -0500 Subject: [Ada] Makefile.rtl:ADA_EXCLUDE_SRCS update after some System.GCC unit renames gcc/ada/ * Makefile.rtl (ADA_EXCLUDE_SRCS): Remove s-gcc.adb, s-gcc.ads, s-gccdiv.adb, s-gccdiv.ads, s-gccshi.adb and s-gccshi.ads. --- gcc/ada/Makefile.rtl | 2 -- 1 file changed, 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 987eff0..b7d0db3 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -2992,8 +2992,6 @@ ADA_EXCLUDE_SRCS =\ s-bbsle3.ads s-bbsuer.ads s-bbsule.ads s-bbthqu.adb s-bbthqu.ads \ s-bbthre.adb s-bbthre.ads s-bbtiev.adb s-bbtiev.ads s-bbtime.adb \ s-bbtime.ads s-bcprmu.adb s-bcprmu.ads s-btstch.adb s-btstch.ads \ - s-gcc.adb s-gcc.ads s-gccdiv.adb s-gccdiv.ads \ - s-gccshi.adb s-gccshi.ads \ s-init.ads s-init.adb s-linux.ads s-macres.ads \ s-memcom.adb s-memcom.ads s-memmov.adb s-memmov.ads s-memset.adb \ s-memset.ads s-mufalo.adb s-mufalo.ads s-musplo.adb s-musplo.ads \ -- cgit v1.1 From 427c07a2fc7e9799552499795bbe60664ef142ac Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Mon, 14 Dec 2020 15:31:52 -0500 Subject: [Ada] SPARK needs DIC expressions within partial DIC procedures for abstract types gcc/ada/ * exp_util.adb (Add_Own_DIC): Relax the suppression of adding a DIC Check pragma that's done for abstract types by still doing it in the case where GNATprove_Mode is set. --- gcc/ada/exp_util.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 36af89b..801db80 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1860,7 +1860,7 @@ package body Exp_Util is -- procedures can never be called in any case, so not generating the -- check at all is OK). - if not Is_Abstract_Type (DIC_Typ) then + if not Is_Abstract_Type (DIC_Typ) or else GNATprove_Mode then Add_DIC_Check (DIC_Prag => DIC_Prag, DIC_Expr => Expr, -- cgit v1.1 From 0b8d4694de0ea744804eed414c8a1453111fdb68 Mon Sep 17 00:00:00 2001 From: Patrick Bernardi Date: Tue, 15 Dec 2020 20:44:57 -0500 Subject: [Ada] System.Storage_Elements: cleanup comment gcc/ada/ * libgnat/s-stoele.ads (Storage_Offset): Cleanup comment. --- gcc/ada/libgnat/s-stoele.ads | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads index 4abac8e..5369ba4 100644 --- a/gcc/ada/libgnat/s-stoele.ads +++ b/gcc/ada/libgnat/s-stoele.ads @@ -56,8 +56,7 @@ package System.Storage_Elements is +(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1); -- Note: the reason for the Long_Long_Integer qualification here is to -- avoid a bogus ambiguity when this unit is analyzed in an rtsfind - -- context. It may be possible to remove this in the future, but it is - -- certainly harmless in any case ??? + -- context. subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last; -- cgit v1.1 From 3c837e5bf7e68634e65a1b1f5e6052a9aeaae1bb Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 14 Dec 2020 05:10:21 -0500 Subject: [Ada] Ada 2020 AI12-0401: Renaming of qualified expression of variable gcc/ada/ * sem_ch8.adb (Analyze_Object_Renaming): Update check for AI12-0401. --- gcc/ada/sem_ch8.adb | 57 ++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 48 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index cf5b790..817cba9 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -759,6 +759,7 @@ package body Sem_Ch8 is Dec : Node_Id; T : Entity_Id; T2 : Entity_Id; + Q : Node_Id; procedure Check_Constrained_Object; -- If the nominal type is unconstrained but the renamed object is @@ -1074,17 +1075,55 @@ package body Sem_Ch8 is -- Check against AI12-0401 here before Resolve may rewrite Nam and -- potentially generate spurious warnings. + -- In the case where the object_name is a qualified_expression with + -- a nominal subtype T and whose expression is a name that denotes + -- an object Q: + -- * if T is an elementary subtype, then: + -- * Q shall be a constant other than a dereference of an access + -- type; or + -- * the nominal subtype of Q shall be statically compatible with + -- T; or + -- * T shall statically match the base subtype of its type if + -- scalar, or the first subtype of its type if an access type. + -- * if T is a composite subtype, then Q shall be known to be + -- constrained or T shall statically match the first subtype of + -- its type. + if Nkind (Nam) = N_Qualified_Expression - and then Is_Variable (Expression (Nam)) - and then not - (Subtypes_Statically_Match (T, Etype (Expression (Nam))) - or else - Subtypes_Statically_Match (Base_Type (T), Etype (Nam))) + and then Is_Object_Reference (Expression (Nam)) then - Error_Msg_N - ("subtype of renamed qualified expression does not " & - "statically match", N); - return; + Q := Expression (Nam); + + if (Is_Elementary_Type (T) + and then + not ((not Is_Variable (Q) + and then Nkind (Q) /= N_Explicit_Dereference) + or else Subtypes_Statically_Compatible (Etype (Q), T) + or else (Is_Scalar_Type (T) + and then Subtypes_Statically_Match + (T, Base_Type (T))) + or else (Is_Access_Type (T) + and then Subtypes_Statically_Match + (T, First_Subtype (T))))) + or else (Is_Composite_Type (T) + and then + + -- If Q is an aggregate, Is_Constrained may not be set + -- yet and its type may not be resolved yet. + -- This doesn't quite correspond to the complex notion + -- of "known to be constrained" but this is good enough + -- for a rule which is in any case too complex. + + not (Is_Constrained (Etype (Q)) + or else Nkind (Q) = N_Aggregate + or else Subtypes_Statically_Match + (T, First_Subtype (T)))) + then + Error_Msg_N + ("subtype of renamed qualified expression does not " & + "statically match", N); + return; + end if; end if; Resolve (Nam, T); -- cgit v1.1 From fff7a6d923e6189bfce730883c2f81d65432d678 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 10 Dec 2020 08:19:55 -0500 Subject: [Ada] Bad handling of array sliding in aggregate gcc/ada/ * exp_aggr.adb (Collect_Initialization_Statements): Removed. (Convert_Aggr_In_Object_Decl, Expand_Array_Aggregate): Fix creation and insertion of Initialization_Statements. Do not set Initialization_Statements when a transient scope is involved. Move processing of Array_Slice here. Ensure that an object with an Array_Slice call gets its array component initialized. Add comments. * exp_ch7.adb: Update comments. (Store_Actions_In_Scope): Deal properly with an empty list which might now be generated by Convert_Aggr_In_Object_Decl. * exp_ch3.adb: Update comments. (Expand_N_Object_Declaration): Remove processing of Array_Slice. --- gcc/ada/exp_aggr.adb | 123 +++++++++++++++++++++++++++------------------------ gcc/ada/exp_ch3.adb | 15 +++---- gcc/ada/exp_ch7.adb | 5 +-- 3 files changed, 71 insertions(+), 72 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index d7e5470..c719b02 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -78,15 +78,6 @@ package body Exp_Aggr is type Case_Table_Type is array (Nat range <>) of Case_Bounds; -- Table type used by Check_Case_Choices procedure - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id); - -- If Obj is not frozen, collect actions inserted after N until, but not - -- including, Node_After, for initialization of Obj, and move them to an - -- expression with actions, which becomes the Initialization_Statements for - -- Obj. - procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id); procedure Expand_Container_Aggregate (N : Node_Id); @@ -4210,40 +4201,6 @@ package body Exp_Aggr is return L; end Build_Record_Aggr_Code; - --------------------------------------- - -- Collect_Initialization_Statements -- - --------------------------------------- - - procedure Collect_Initialization_Statements - (Obj : Entity_Id; - N : Node_Id; - Node_After : Node_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Init_Actions : constant List_Id := New_List; - Init_Node : Node_Id; - Comp_Stmt : Node_Id; - - begin - -- Nothing to do if Obj is already frozen, as in this case we known we - -- won't need to move the initialization statements about later on. - - if Is_Frozen (Obj) then - return; - end if; - - Init_Node := N; - while Next (Init_Node) /= Node_After loop - Append_To (Init_Actions, Remove_Next (Init_Node)); - end loop; - - if not Is_Empty_List (Init_Actions) then - Comp_Stmt := Make_Compound_Statement (Loc, Actions => Init_Actions); - Insert_Action_After (Init_Node, Comp_Stmt); - Set_Initialization_Statements (Obj, Comp_Stmt); - end if; - end Collect_Initialization_Statements; - ------------------------------- -- Convert_Aggr_In_Allocator -- ------------------------------- @@ -4314,6 +4271,8 @@ package body Exp_Aggr is Typ : constant Entity_Id := Etype (Aggr); Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc); + Has_Transient_Scope : Boolean := False; + function Discriminants_Ok return Boolean; -- If the object type is constrained, the discriminants in the -- aggregate must be checked against the discriminants of the subtype. @@ -4405,7 +4364,7 @@ package body Exp_Aggr is -- the finalization list of the return must be moved to the caller's -- finalization list to complete the return. - -- However, if the aggregate is limited, it is built in place, and the + -- Similarly if the aggregate is limited, it is built in place, and the -- controlled components are not assigned to intermediate temporaries -- so there is no need for a transient scope in this case either. @@ -4414,13 +4373,60 @@ package body Exp_Aggr is and then not Is_Limited_Type (Typ) then Establish_Transient_Scope (Aggr, Manage_Sec_Stack => False); + Has_Transient_Scope := True; end if; declare - Node_After : constant Node_Id := Next (N); + Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ); + Stmt : Node_Id; + Param : Node_Id; + begin - Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ)); - Collect_Initialization_Statements (Obj, N, Node_After); + -- If Obj is already frozen or if N is wrapped in a transient scope, + -- Stmts do not need to be saved in Initialization_Statements since + -- there is no freezing issue. + + if Is_Frozen (Obj) or else Has_Transient_Scope then + Insert_Actions_After (N, Stmts); + else + Stmt := Make_Compound_Statement (Sloc (N), Actions => Stmts); + Insert_Action_After (N, Stmt); + + -- Insert_Action_After may freeze Obj in which case we should + -- remove the compound statement just created and simply insert + -- Stmts after N. + + if Is_Frozen (Obj) then + Remove (Stmt); + Insert_Actions_After (N, Stmts); + else + Set_Initialization_Statements (Obj, Stmt); + end if; + end if; + + -- If Typ has controlled components and a call to a Slice_Assign + -- procedure is part of the initialization statements, then we + -- need to initialize the array component since Slice_Assign will + -- need to adjust it. + + if Has_Controlled_Component (Typ) then + Stmt := First (Stmts); + + while Present (Stmt) loop + if Nkind (Stmt) = N_Procedure_Call_Statement + and then Get_TSS_Name (Entity (Name (Stmt))) + = TSS_Slice_Assign + then + Param := First (Parameter_Associations (Stmt)); + Insert_Actions + (Stmt, + Build_Initialization_Call + (Sloc (N), New_Copy_Tree (Param), Etype (Param))); + end if; + + Next (Stmt); + end loop; + end if; end; Set_No_Initialization (N); @@ -6793,6 +6799,7 @@ package body Exp_Aggr is -- code must be inserted after it. The defining entity might not come -- from source if this is part of an inlined body, but the declaration -- itself will. + -- The test below looks very specialized and kludgy??? if Comes_From_Source (Tmp) or else @@ -6800,18 +6807,18 @@ package body Exp_Aggr is and then Comes_From_Source (Parent (N)) and then Tmp = Defining_Entity (Parent (N))) then - declare - Node_After : constant Node_Id := Next (Parent_Node); - - begin + if Parent_Kind /= N_Object_Declaration or else Is_Frozen (Tmp) then Insert_Actions_After (Parent_Node, Aggr_Code); - - if Parent_Kind = N_Object_Declaration then - Collect_Initialization_Statements - (Obj => Tmp, N => Parent_Node, Node_After => Node_After); - end if; - end; - + else + declare + Comp_Stmt : constant Node_Id := + Make_Compound_Statement + (Sloc (Parent_Node), Actions => Aggr_Code); + begin + Insert_Action_After (Parent_Node, Comp_Stmt); + Set_Initialization_Statements (Tmp, Comp_Stmt); + end; + end if; else Insert_Actions (N, Aggr_Code); end if; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 56924a0..f372985 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -124,7 +124,7 @@ package body Exp_Ch3 is -- Build assignment procedure for one-dimensional arrays of controlled -- types. Other array and slice assignments are expanded in-line, but -- the code expansion for controlled components (when control actions - -- are active) can lead to very large blocks that GCC3 handles poorly. + -- are active) can lead to very large blocks that GCC handles poorly. procedure Build_Untagged_Equality (Typ : Entity_Id); -- AI05-0123: Equality on untagged records composes. This procedure @@ -4168,7 +4168,7 @@ package body Exp_Ch3 is -- Generates the following subprogram: - -- procedure Assign + -- procedure array_typeSA -- (Source, Target : Array_Type, -- Left_Lo, Left_Hi : Index; -- Right_Lo, Right_Hi : Index; @@ -4178,7 +4178,6 @@ package body Exp_Ch3 is -- Ri1 : Index; -- begin - -- if Left_Hi < Left_Lo then -- return; -- end if; @@ -4204,7 +4203,7 @@ package body Exp_Ch3 is -- Ri1 := Index'succ (Ri1); -- end if; -- end loop; - -- end Assign; + -- end array_typeSA; procedure Build_Slice_Assignment (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); @@ -6561,7 +6560,7 @@ package body Exp_Ch3 is if Needs_Finalization (Typ) and then not No_Initialization (N) then Obj_Init := Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + (Obj_Ref => New_Object_Reference, Typ => Typ); end if; @@ -6977,11 +6976,7 @@ package body Exp_Ch3 is else -- Obtain actual expression from qualified expression - if Nkind (Expr) = N_Qualified_Expression then - Expr_Q := Expression (Expr); - else - Expr_Q := Expr; - end if; + Expr_Q := Unqualify (Expr); -- When we have the appropriate type of aggregate in the expression -- (it has been determined during analysis of the aggregate by diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 5d8ad7d..0315458 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -153,9 +153,6 @@ package body Exp_Ch7 is procedure Set_Node_To_Be_Wrapped (N : Node_Id); -- Set the field Node_To_Be_Wrapped of the current scope - -- ??? The entire comment needs to be rewritten - -- ??? which entire comment? - procedure Store_Actions_In_Scope (AK : Scope_Action_Kind; L : List_Id); -- Shared processing for Store_xxx_Actions_In_Scope @@ -9841,7 +9838,7 @@ package body Exp_Ch7 is Actions : List_Id renames SE.Actions_To_Be_Wrapped (AK); begin - if No (Actions) then + if Is_Empty_List (Actions) then Actions := L; if Is_List_Member (SE.Node_To_Be_Wrapped) then -- cgit v1.1 From f64998fed6bc3b9a9af8bdb890bd214828f5a508 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 16 Dec 2020 03:19:40 -0500 Subject: [Ada] Clean up Makefile.rtl gcc/ada/ * Makefile.rtl (ADA_EXCLUDE_SRCS): Remove unused files. (ADA_INCLUDE_SRCS): Remove libgnat/system.ads --- gcc/ada/Makefile.rtl | 17 ++++------------- 1 file changed, 4 insertions(+), 13 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index b7d0db3..7c6f4b2 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -2967,7 +2967,7 @@ GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \ ADA_INCLUDE_SRCS =\ libgnat/ada.ads libgnat/calendar.ads libgnat/directio.ads libgnat/gnat.ads libgnat/interfac.ads libgnat/ioexcept.ads \ libgnat/machcode.ads libgnat/text_io.ads libgnat/unchconv.ads libgnat/unchdeal.ads \ - libgnat/sequenio.ads libgnat/system.ads libgnat/memtrack.adb \ + libgnat/sequenio.ads libgnat/memtrack.adb \ libgna*/*.gpr \ libgnat/a-[a-o]*.adb libgnat/a-[a-o]*.ads \ libgnat/a-[p-z]*.adb libgnat/a-[p-z]*.ads \ @@ -2987,19 +2987,10 @@ ADA_EXCLUDE_SRCS =\ g-altive.ads g-alveop.adb g-alveop.ads g-alvety.ads g-alvevi.ads \ g-intpri.ads g-regist.adb g-regist.ads g-sse.ads g-ssvety.ads \ i-vxinco.adb i-vxinco.ads i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \ - s-bb.ads s-bbbosu.ads s-bbcaco.ads s-bbcppr.ads s-bbexti.adb \ - s-bbexti.ads s-bbinte.adb s-bbinte.ads s-bbprot.adb s-bbprot.ads \ - s-bbsle3.ads s-bbsuer.ads s-bbsule.ads s-bbthqu.adb s-bbthqu.ads \ - s-bbthre.adb s-bbthre.ads s-bbtiev.adb s-bbtiev.ads s-bbtime.adb \ - s-bbtime.ads s-bcprmu.adb s-bcprmu.ads s-btstch.adb s-btstch.ads \ - s-init.ads s-init.adb s-linux.ads s-macres.ads \ - s-memcom.adb s-memcom.ads s-memmov.adb s-memmov.ads s-memset.adb \ - s-memset.ads s-mufalo.adb s-mufalo.ads s-musplo.adb s-musplo.ads \ - s-sam4.ads s-sopco3.adb s-sopco3.ads s-sopco4.adb s-sopco4.ads \ - s-sopco5.adb s-sopco5.ads s-stchop.ads s-stchop.adb s-stm32.ads \ + s-linux.ads s-vxwext.adb s-vxwext.ads s-win32.ads s-winext.ads \ + s-sopco3.adb s-sopco3.ads s-sopco4.adb s-sopco4.ads \ + s-sopco5.adb s-sopco5.ads s-stchop.ads s-stchop.adb \ s-strcom.adb s-strcom.ads s-thread.ads \ - s-vxwext.adb s-vxwext.ads \ - s-win32.ads s-winext.ads # ADA_EXCLUDE_SRCS without the sources used by the target ADA_EXCLUDE_FILES=$(filter-out \ -- cgit v1.1 From 224ae1c7737a7ea307cd80475351fdb5ea25b641 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Wed, 16 Dec 2020 15:18:13 +0100 Subject: [Ada] Fix internal consistency error with Duration and 32-bit target file gcc/ada/ * gnat1drv.adb (Adjust_Global_Switches): Force a 32-bit Duration type if the maximum integer size is lower than 64 bits. --- gcc/ada/gnat1drv.adb | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 0318194..4bdac5e 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -819,6 +819,12 @@ procedure Gnat1drv is Ttypes.Standard_Long_Long_Integer_Size; end if; + -- Forcefully use a 32-bit Duration with only 32-bit integer types + + if Ttypes.System_Max_Integer_Size < 64 then + Targparm.Duration_32_Bits_On_Target := True; + end if; + -- Finally capture adjusted value of Suppress_Options as the initial -- value for Scope_Suppress, which will be modified as we move from -- scope to scope (by Suppress/Unsuppress/Overflow_Checks pragmas). -- cgit v1.1 From 4068698c47ff67bf48edf5c21a386204de370aaf Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 16 Dec 2020 02:00:56 -0500 Subject: [Ada] Missing access-to-discriminated conversion check gcc/ada/ * checks.adb (Apply_Type_Conversion_Checks): Move out constraint check generation, and add case for general access types with constraints. (Make_Discriminant_Constraint_Check): Created to centralize generation of constraint checks for stored discriminants. --- gcc/ada/checks.adb | 201 +++++++++++++++++++++++++++++++++-------------------- 1 file changed, 124 insertions(+), 77 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 61e41dd..0f8b72b 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -3575,6 +3575,102 @@ package body Checks is -- full view might have discriminants with defaults, so we need the -- full view here to retrieve the constraints. + procedure Make_Discriminant_Constraint_Check + (Target_Type : Entity_Id; + Expr_Type : Entity_Id); + -- Generate a discriminant check based on the target type and expression + -- type for Expr. + + ---------------------------------------- + -- Make_Discriminant_Constraint_Check -- + ---------------------------------------- + + procedure Make_Discriminant_Constraint_Check + (Target_Type : Entity_Id; + Expr_Type : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Cond : Node_Id; + Constraint : Elmt_Id; + Discr_Value : Node_Id; + Discr : Entity_Id; + + New_Constraints : constant Elist_Id := New_Elmt_List; + Old_Constraints : constant Elist_Id := + Discriminant_Constraint (Expr_Type); + + begin + -- Build an actual discriminant constraint list using the stored + -- constraint, to verify that the expression of the parent type + -- satisfies the constraints imposed by the (unconstrained) derived + -- type. This applies to value conversions, not to view conversions + -- of tagged types. + + Constraint := First_Elmt (Stored_Constraint (Target_Type)); + while Present (Constraint) loop + Discr_Value := Node (Constraint); + + if Is_Entity_Name (Discr_Value) + and then Ekind (Entity (Discr_Value)) = E_Discriminant + then + Discr := Corresponding_Discriminant (Entity (Discr_Value)); + + if Present (Discr) + and then Scope (Discr) = Base_Type (Expr_Type) + then + -- Parent is constrained by new discriminant. Obtain + -- Value of original discriminant in expression. If the + -- new discriminant has been used to constrain more than + -- one of the stored discriminants, this will provide the + -- required consistency check. + + Append_Elmt + (Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_No_Checks + (Expr, Name_Req => True), + Selector_Name => + Make_Identifier (Loc, Chars (Discr))), + New_Constraints); + + else + -- Discriminant of more remote ancestor ??? + + return; + end if; + + -- Derived type definition has an explicit value for this + -- stored discriminant. + + else + Append_Elmt + (Duplicate_Subexpr_No_Checks (Discr_Value), + New_Constraints); + end if; + + Next_Elmt (Constraint); + end loop; + + -- Use the unconstrained expression type to retrieve the + -- discriminants of the parent, and apply momentarily the + -- discriminant constraint synthesized above. + + -- Note: We use Expr_Type instead of Target_Type since the number of + -- actual discriminants may be different due to the presence of + -- stored discriminants and cause Build_Discriminant_Checks to fail. + + Set_Discriminant_Constraint (Expr_Type, New_Constraints); + Cond := Build_Discriminant_Checks (Expr, Expr_Type); + Set_Discriminant_Constraint (Expr_Type, Old_Constraints); + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => Cond, + Reason => CE_Discriminant_Check_Failed)); + end Make_Discriminant_Constraint_Check; + + -- Start of processing for Apply_Type_Conversion_Checks + begin if Inside_A_Generic then return; @@ -3704,91 +3800,42 @@ package body Checks is end if; end; - elsif Comes_From_Source (N) - and then not Discriminant_Checks_Suppressed (Target_Type) - and then Is_Record_Type (Target_Type) - and then Is_Derived_Type (Target_Type) - and then not Is_Tagged_Type (Target_Type) - and then not Is_Constrained (Target_Type) - and then Present (Stored_Constraint (Target_Type)) - then - -- An unconstrained derived type may have inherited discriminant. - -- Build an actual discriminant constraint list using the stored - -- constraint, to verify that the expression of the parent type - -- satisfies the constraints imposed by the (unconstrained) derived - -- type. This applies to value conversions, not to view conversions - -- of tagged types. - - declare - Loc : constant Source_Ptr := Sloc (N); - Cond : Node_Id; - Constraint : Elmt_Id; - Discr_Value : Node_Id; - Discr : Entity_Id; - - New_Constraints : constant Elist_Id := New_Elmt_List; - Old_Constraints : constant Elist_Id := - Discriminant_Constraint (Expr_Type); + -- Generate discriminant constraint checks for access types on the + -- designated target type's stored constraints. - begin - Constraint := First_Elmt (Stored_Constraint (Target_Type)); - while Present (Constraint) loop - Discr_Value := Node (Constraint); + -- Do we need to generate subtype predicate checks here as well ??? - if Is_Entity_Name (Discr_Value) - and then Ekind (Entity (Discr_Value)) = E_Discriminant - then - Discr := Corresponding_Discriminant (Entity (Discr_Value)); - - if Present (Discr) - and then Scope (Discr) = Base_Type (Expr_Type) - then - -- Parent is constrained by new discriminant. Obtain - -- Value of original discriminant in expression. If the - -- new discriminant has been used to constrain more than - -- one of the stored discriminants, this will provide the - -- required consistency check. - - Append_Elmt - (Make_Selected_Component (Loc, - Prefix => - Duplicate_Subexpr_No_Checks - (Expr, Name_Req => True), - Selector_Name => - Make_Identifier (Loc, Chars (Discr))), - New_Constraints); - - else - -- Discriminant of more remote ancestor ??? + elsif Comes_From_Source (N) + and then Ekind (Target_Type) = E_General_Access_Type - return; - end if; + -- Check that both of the designated types have known discriminants, + -- and that such checks on the target type are not suppressed. - -- Derived type definition has an explicit value for this - -- stored discriminant. + and then Has_Discriminants (Directly_Designated_Type (Target_Type)) + and then Has_Discriminants (Directly_Designated_Type (Expr_Type)) + and then not Discriminant_Checks_Suppressed + (Directly_Designated_Type (Target_Type)) - else - Append_Elmt - (Duplicate_Subexpr_No_Checks (Discr_Value), - New_Constraints); - end if; - - Next_Elmt (Constraint); - end loop; + -- Verify the designated type of the target has stored constraints - -- Use the unconstrained expression type to retrieve the - -- discriminants of the parent, and apply momentarily the - -- discriminant constraint synthesized above. + and then Present + (Stored_Constraint (Directly_Designated_Type (Target_Type))) + then + Make_Discriminant_Constraint_Check + (Target_Type => Directly_Designated_Type (Target_Type), + Expr_Type => Directly_Designated_Type (Expr_Type)); - Set_Discriminant_Constraint (Expr_Type, New_Constraints); - Cond := Build_Discriminant_Checks (Expr, Expr_Type); - Set_Discriminant_Constraint (Expr_Type, Old_Constraints); + -- Create discriminant checks for the Target_Type's stored constraints - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => Cond, - Reason => CE_Discriminant_Check_Failed)); - end; + elsif Comes_From_Source (N) + and then not Discriminant_Checks_Suppressed (Target_Type) + and then Is_Record_Type (Target_Type) + and then Is_Derived_Type (Target_Type) + and then not Is_Tagged_Type (Target_Type) + and then not Is_Constrained (Target_Type) + and then Present (Stored_Constraint (Target_Type)) + then + Make_Discriminant_Constraint_Check (Target_Type, Expr_Type); -- For arrays, checks are set now, but conversions are applied during -- expansion, to take into accounts changes of representation. The -- cgit v1.1 From b626569a56c5b35e4c5a10ba7f0abd5d8b4fd0e7 Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Wed, 16 Dec 2020 14:37:22 +0100 Subject: [Ada] Fix evaluation of expressions in inlined code gcc/ada/ * sem_eval.adb (Check_Non_Static_Context_For_Overflow): Apply compile-time checking for overflows in non-static contexts including inlined code. (Eval_Arithmetic_Op): Use the new procedure. (Eval_Unary_Op, Eval_Op_Expon): Add call to the new procedure. --- gcc/ada/sem_eval.adb | 61 +++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 44 insertions(+), 17 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 3ccf3a0..e3b4650 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -142,6 +142,16 @@ package body Sem_Eval is -- Local Subprograms -- ----------------------- + procedure Check_Non_Static_Context_For_Overflow + (N : Node_Id; + Stat : Boolean; + Result : Uint); + -- For a signed integer type, check non-static overflow in Result when + -- Stat is False. This applies also inside inlined code, where the static + -- property may be an effect of the inlining, which should not be allowed + -- to remove run-time checks (whether during compilation, or even more + -- crucially in the special inlining-for-proof in GNATprove mode). + function Choice_Matches (Expr : Node_Id; Choice : Node_Id) return Match_Result; @@ -649,6 +659,34 @@ package body Sem_Eval is end if; end Check_Non_Static_Context; + ------------------------------------------- + -- Check_Non_Static_Context_For_Overflow -- + ------------------------------------------- + + procedure Check_Non_Static_Context_For_Overflow + (N : Node_Id; + Stat : Boolean; + Result : Uint) + is + begin + if (not Stat or else In_Inlined_Body) + and then Is_Signed_Integer_Type (Etype (N)) + then + declare + BT : constant Entity_Id := Base_Type (Etype (N)); + Lo : constant Uint := Expr_Value (Type_Low_Bound (BT)); + Hi : constant Uint := Expr_Value (Type_High_Bound (BT)); + begin + if Result < Lo or else Result > Hi then + Apply_Compile_Time_Constraint_Error + (N, "value not in range of }??", + CE_Overflow_Check_Failed, + Ent => BT); + end if; + end; + end if; + end Check_Non_Static_Context_For_Overflow; + --------------------------------- -- Check_String_Literal_Length -- --------------------------------- @@ -2143,25 +2181,10 @@ package body Sem_Eval is if Is_Modular_Integer_Type (Ltype) then Result := Result mod Modulus (Ltype); - - -- For a signed integer type, check non-static overflow - - elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then - declare - BT : constant Entity_Id := Base_Type (Ltype); - Lo : constant Uint := Expr_Value (Type_Low_Bound (BT)); - Hi : constant Uint := Expr_Value (Type_High_Bound (BT)); - begin - if Result < Lo or else Result > Hi then - Apply_Compile_Time_Constraint_Error - (N, "value not in range of }??", - CE_Overflow_Check_Failed, - Ent => BT); - return; - end if; - end; end if; + Check_Non_Static_Context_For_Overflow (N, Stat, Result); + -- If we get here we can fold the result Fold_Uint (N, Result, Stat); @@ -3202,6 +3225,8 @@ package body Sem_Eval is Result := Result mod Modulus (Etype (N)); end if; + Check_Non_Static_Context_For_Overflow (N, Stat, Result); + Fold_Uint (N, Result, Stat); end if; end; @@ -4375,6 +4400,8 @@ package body Sem_Eval is Result := abs Rint; end if; + Check_Non_Static_Context_For_Overflow (N, Stat, Result); + Fold_Uint (N, Result, Stat); end; -- cgit v1.1 From 210cae9d510bffe5f4103ea82afe07f9b31418db Mon Sep 17 00:00:00 2001 From: Yannick Moy Date: Thu, 17 Dec 2020 09:56:16 +0100 Subject: [Ada] Add colors to GNATprove messages output to a terminal gcc/ada/ * errout.adb (Output_Messages): Insert SGR strings where needed. * erroutc.adb (Output_Message_Txt): Insert SGR strings where needed in the text of the message itself. (Output_Msg_Text): Allow for style message not to start with (style). * erroutc.ads: Add new constants and functions to control colors in messages output to the terminal. Add variable Use_SGR_Control that should be set to True for using SGR color control strings. --- gcc/ada/errout.adb | 54 +++++++++++++++++++++++++++++++++++++++++------ gcc/ada/erroutc.adb | 45 +++++++++++++++++++++++++++++++++------- gcc/ada/erroutc.ads | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 146 insertions(+), 13 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 2b4f278..f7eb8cd 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2071,7 +2071,9 @@ package body Errout is procedure Write_Max_Errors; -- Write message if max errors reached - procedure Write_Source_Code_Lines (Span : Source_Span); + procedure Write_Source_Code_Lines + (Span : Source_Span; + SGR_Span : String); -- Write the source code line corresponding to Span, as follows when -- Span in on one line: -- @@ -2095,6 +2097,9 @@ package body Errout is -- | ^ here -- -- where the caret on the line points to location Span.Ptr + -- + -- SGR_Span is the SGR string to start the section of code in the span, + -- that should be closed with SGR_Reset. ------------------------- -- Write_Error_Summary -- @@ -2290,8 +2295,10 @@ package body Errout is -- Write_Source_Code_Lines -- ----------------------------- - procedure Write_Source_Code_Lines (Span : Source_Span) is - + procedure Write_Source_Code_Lines + (Span : Source_Span; + SGR_Span : String) + is function Get_Line_End (Buf : Source_Buffer_Ptr; Loc : Source_Ptr) return Source_Ptr; @@ -2490,6 +2497,15 @@ package body Errout is -- the gap with first/last lines, otherwise use ... to denote -- intermediate lines. + -- If the span is on one line and not a simple source location, + -- color it appropriately. + + if Line_Fst = Line_Lst + and then Col_Fst /= Col_Lst + then + Write_Str (SGR_Span); + end if; + declare function Do_Write_Line (Cur_Line : Pos) return Boolean is (Cur_Line in Line_Fst | Line | Line_Lst @@ -2499,7 +2515,7 @@ package body Errout is (Cur_Line = Line + 1 and then Cur_Line = Line_Lst - 1)); begin while Cur_Loc <= Buf'Last - and then Cur_Loc < Lst + and then Cur_Loc <= Lst loop if Do_Write_Line (Cur_Line) then Write_Buffer_Char (Buf, Cur_Loc); @@ -2535,6 +2551,12 @@ package body Errout is end loop; end; + if Line_Fst = Line_Lst + and then Col_Fst /= Col_Lst + then + Write_Str (SGR_Reset); + end if; + -- Output the rest of the last line of the span Write_Buffer (Buf, Cur_Loc, Get_Line_End (Buf, Cur_Loc)); @@ -2546,6 +2568,9 @@ package body Errout is Write_Str (String'(1 .. Width => ' ')); Write_Str (" |"); Write_Str (String'(1 .. Col_Fst - 1 => ' ')); + + Write_Str (SGR_Span); + Write_Str (String'(Col_Fst .. Col - 1 => '~')); Write_Str ("^"); Write_Str (String'(Col + 1 .. Col_Lst => '~')); @@ -2557,6 +2582,8 @@ package body Errout is Write_Str (" here"); end if; + Write_Str (SGR_Reset); + Write_Eol; end if; end if; @@ -2615,6 +2642,8 @@ package body Errout is end if; if Use_Prefix then + Write_Str (SGR_Locus); + if Full_Path_Name_For_Brief_Errors then Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); else @@ -2633,6 +2662,8 @@ package body Errout is Write_Int (Int (Errors.Table (E).Col)); Write_Str (": "); + + Write_Str (SGR_Reset); end if; Output_Msg_Text (E); @@ -2652,12 +2683,23 @@ package body Errout is Errors.Table (E).Insertion_Sloc; begin if Loc /= No_Location then - Write_Source_Code_Lines (To_Span (Loc)); + Write_Source_Code_Lines + (To_Span (Loc), SGR_Span => SGR_Note); end if; end; else - Write_Source_Code_Lines (Errors.Table (E).Sptr); + declare + SGR_Span : constant String := + (if Errors.Table (E).Info then SGR_Note + elsif Errors.Table (E).Warn + and then not Errors.Table (E).Warn_Err + then SGR_Warning + else SGR_Error); + begin + Write_Source_Code_Lines + (Errors.Table (E).Sptr, SGR_Span); + end; end if; end if; end if; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index d7ca221..faef53a 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -699,7 +699,7 @@ package body Erroutc is -- For info messages, prefix message with "info: " elsif E_Msg.Info then - Txt := new String'("info: " & Txt.all); + Txt := new String'(SGR_Note & "info: " & SGR_Reset & Txt.all); -- Warning treated as error @@ -709,27 +709,58 @@ package body Erroutc is -- [warning-as-error] at the end. Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; - Txt := new String'("error: " & Txt.all & " [warning-as-error]"); + Txt := new String'(SGR_Error & "error: " & SGR_Reset + & Txt.all & " [warning-as-error]"); -- Normal warning, prefix with "warning: " elsif E_Msg.Warn then - Txt := new String'("warning: " & Txt.all); + Txt := new String'(SGR_Warning & "warning: " & SGR_Reset & Txt.all); - -- No prefix needed for style message, "(style)" is there already + -- No prefix needed for style message, "(style)" is there already, + -- although not necessarily in first position if -gnatdJ is used. elsif E_Msg.Style then - null; + if Txt (Txt'First .. Txt'First + 6) = "(style)" then + Txt := new String'(SGR_Warning & "(style)" & SGR_Reset + & Txt (Txt'First + 7 .. Txt'Last)); + end if; -- No prefix needed for check message, severity is there already elsif E_Msg.Check then - null; + + -- The message format is "severity: ..." + -- + -- Enclose the severity with an SGR control string if requested + + if Use_SGR_Control then + declare + Msg : String renames Text.all; + Colon : Natural := 0; + begin + -- Find first colon + + for J in Msg'Range loop + if Msg (J) = ':' then + Colon := J; + exit; + end if; + end loop; + + pragma Assert (Colon > 0); + + Txt := new String'(SGR_Error + & Msg (Msg'First .. Colon) + & SGR_Reset + & Msg (Colon + 1 .. Msg'Last)); + end; + end if; -- All other cases, add "error: " if unique error tag set elsif Opt.Unique_Error_Tag then - Txt := new String'("error: " & Txt.all); + Txt := new String'(SGR_Error & "error: " & SGR_Reset & Txt.all); end if; -- Set error message line length and length of message diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index eb43466..62ce0d6 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -390,6 +390,66 @@ package Erroutc is -- find such an On entry, we cancel the indication of it being the -- configuration case. This seems to handle all cases we run into ok. + ------------------- + -- Color Control -- + ------------------- + + Use_SGR_Control : Boolean := False; + -- Set to True for enabling colored output. This should only be done when + -- outputting messages to a terminal that supports it. + + -- Colors in messages output to a terminal are controlled using SGR + -- (Select Graphic Rendition). + + Color_Separator : constant String := ";"; + Color_None : constant String := "00"; + Color_Bold : constant String := "01"; + Color_Underscore : constant String := "04"; + Color_Blink : constant String := "05"; + Color_Reverse : constant String := "07"; + Color_Fg_Black : constant String := "30"; + Color_Fg_Red : constant String := "31"; + Color_Fg_Green : constant String := "32"; + Color_Fg_Yellow : constant String := "33"; + Color_Fg_Blue : constant String := "34"; + Color_Fg_Magenta : constant String := "35"; + Color_Fg_Cyan : constant String := "36"; + Color_Fg_White : constant String := "37"; + Color_Bg_Black : constant String := "40"; + Color_Bg_Red : constant String := "41"; + Color_Bg_Green : constant String := "42"; + Color_Bg_Yellow : constant String := "43"; + Color_Bg_Blue : constant String := "44"; + Color_Bg_Magenta : constant String := "45"; + Color_Bg_Cyan : constant String := "46"; + Color_Bg_White : constant String := "47"; + + SGR_Start : constant String := ASCII.ESC & "["; + SGR_End : constant String := "m" & ASCII.ESC & "[K"; + + function SGR_Seq (Str : String) return String is + (if Use_SGR_Control then SGR_Start & Str & SGR_End else ""); + -- Return the SGR control string for the commands in Str. It returns the + -- empty string if Use_SGR_Control is False, so that we can insert this + -- string unconditionally. + + function SGR_Reset return String is (SGR_Seq ("")); + -- This ends the current section of colored output + + -- We're using the same colors as gcc/g++ for errors/warnings/notes/locus. + -- More colors are defined in gcc/g++ for other features of diagnostic + -- messages (e.g. inline types, fixit) and could be used in GNAT in the + -- future. The following functions start a section of colored output. + + function SGR_Error return String is + (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Red)); + function SGR_Warning return String is + (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Magenta)); + function SGR_Note return String is + (SGR_Seq (Color_Bold & Color_Separator & Color_Fg_Cyan)); + function SGR_Locus return String is + (SGR_Seq (Color_Bold)); + ----------------- -- Subprograms -- ----------------- -- cgit v1.1 From 8833f142768c41651503e709262d0d0fdd4a196c Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 18 Dec 2020 18:49:31 +0100 Subject: [Ada] Fix minor issue in Scan_Decimal_Digits gcc/ada/ * libgnat/s-valuer.adb (Scan_Decimal_Digits): Set Extra to zero when the precision limit is reached by means of trailing zeros and prevent it from being overwritten later. --- gcc/ada/libgnat/s-valuer.adb | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/s-valuer.adb b/gcc/ada/libgnat/s-valuer.adb index bd57bfb..937ef8e 100644 --- a/gcc/ada/libgnat/s-valuer.adb +++ b/gcc/ada/libgnat/s-valuer.adb @@ -261,7 +261,11 @@ package body System.Value_R is Scale := Scale - 1; else + Extra := 0; Precision_Limit_Reached := True; + if Round and then J = Trailing_Zeros then + Round_Extra (Digit, Value, Scale, Extra, Base); + end if; exit; end if; end loop; @@ -274,11 +278,16 @@ package body System.Value_R is Temp := Value * Uns (Base) + Uns (Digit); + -- Precision_Limit_Reached may have been set above + + if Precision_Limit_Reached then + null; + -- Check if Temp is larger than Precision_Limit, taking into -- account that Temp may wrap around when Precision_Limit is -- equal to the largest integer. - if Value <= Umax + elsif Value <= Umax or else (Value <= UmaxB and then ((Precision_Limit < Uns'Last and then Temp <= Precision_Limit) -- cgit v1.1 From c1efbbba84d4d2f266d2591af747e7f64c2f473a Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Fri, 18 Dec 2020 14:59:45 -0500 Subject: [Ada] Error on T'Reduce of when T is not a container gcc/ada/ * sem_attr.adb (Analyze_Attribute): Change "$" to "&". Otherwise, Errout will trip over an uninitialized (invalid) variable (Error_Msg_Unit_1). --- gcc/ada/sem_attr.adb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 34865f4..2226ece 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5682,7 +5682,7 @@ package body Sem_Attr is null; else Error_Msg_NE - ("cannot apply Reduce to object of type$", N, Typ); + ("cannot apply Reduce to object of type&", N, Typ); end if; elsif Present (Expressions (Stream)) -- cgit v1.1 From 42add8097cba0fa15bb3ee78f322f9f5b114280a Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 19 Dec 2020 11:46:06 +0100 Subject: [Ada] Change rounding mode of 'Machine for static floating point gcc/ada/ * sem_attr.adb (Eval_Attribute) : Use Round_Even instead of Round in the call to the Machine routine. --- gcc/ada/sem_attr.adb | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 2226ece..9d96ee1 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -9107,11 +9107,13 @@ package body Sem_Attr is -- Machine -- ------------- + -- We use the same rounding mode as the one used for RM 4.9(38) + when Attribute_Machine => Fold_Ureal (N, Eval_Fat.Machine - (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round, N), + (P_Base_Type, Expr_Value_R (E1), Eval_Fat.Round_Even, N), Static); ------------------ -- cgit v1.1 From 3606939b63072b7f565d1644b243642a71723150 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 17 Dec 2020 18:23:08 +0100 Subject: [Ada] Tree inconsistency between -O0 and -O1 gcc/ada/ * exp_ch5.adb (Expand_N_If_Statement): Only perform the simplification on return True/False for internal nodes when -fpreserve-control-flow is not set. --- gcc/ada/exp_ch5.adb | 92 +++++++++++++++++++++++++---------------------------- 1 file changed, 44 insertions(+), 48 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4cae2ee..dbccf73 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3788,62 +3788,58 @@ package body Exp_Ch5 is -- return not (expression); - -- Only do these optimizations if we are at least at -O1 level and - -- do not do them if control flow optimizations are suppressed. + -- Do these optimizations only for internally generated code and only + -- when -fpreserve-control-flow isn't set, to preserve the original + -- source control flow. - if Optimization_Level > 0 + if not Comes_From_Source (N) and then not Opt.Suppress_Control_Flow_Optimizations + and then Nkind (N) = N_If_Statement + and then No (Elsif_Parts (N)) + and then Present (Else_Statements (N)) + and then List_Length (Then_Statements (N)) = 1 + and then List_Length (Else_Statements (N)) = 1 then - if Nkind (N) = N_If_Statement - and then No (Elsif_Parts (N)) - and then Present (Else_Statements (N)) - and then List_Length (Then_Statements (N)) = 1 - and then List_Length (Else_Statements (N)) = 1 - then - declare - Then_Stm : constant Node_Id := First (Then_Statements (N)); - Else_Stm : constant Node_Id := First (Else_Statements (N)); + declare + Then_Stm : constant Node_Id := First (Then_Statements (N)); + Else_Stm : constant Node_Id := First (Else_Statements (N)); - begin - if Nkind (Then_Stm) = N_Simple_Return_Statement + Then_Expr : Node_Id; + Else_Expr : Node_Id; + + begin + if Nkind (Then_Stm) = N_Simple_Return_Statement + and then + Nkind (Else_Stm) = N_Simple_Return_Statement + then + Then_Expr := Expression (Then_Stm); + Else_Expr := Expression (Else_Stm); + + if Nkind (Then_Expr) in N_Expanded_Name | N_Identifier and then - Nkind (Else_Stm) = N_Simple_Return_Statement + Nkind (Else_Expr) in N_Expanded_Name | N_Identifier then - declare - Then_Expr : constant Node_Id := Expression (Then_Stm); - Else_Expr : constant Node_Id := Expression (Else_Stm); + if Entity (Then_Expr) = Standard_True + and then Entity (Else_Expr) = Standard_False + then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => Relocate_Node (Condition (N)))); + Analyze (N); - begin - if Nkind (Then_Expr) in N_Expanded_Name | N_Identifier - and then - Nkind (Else_Expr) in N_Expanded_Name | N_Identifier - then - if Entity (Then_Expr) = Standard_True - and then Entity (Else_Expr) = Standard_False - then - Rewrite (N, - Make_Simple_Return_Statement (Loc, - Expression => Relocate_Node (Condition (N)))); - Analyze (N); - return; - - elsif Entity (Then_Expr) = Standard_False - and then Entity (Else_Expr) = Standard_True - then - Rewrite (N, - Make_Simple_Return_Statement (Loc, - Expression => - Make_Op_Not (Loc, - Right_Opnd => - Relocate_Node (Condition (N))))); - Analyze (N); - return; - end if; - end if; - end; + elsif Entity (Then_Expr) = Standard_False + and then Entity (Else_Expr) = Standard_True + then + Rewrite (N, + Make_Simple_Return_Statement (Loc, + Expression => + Make_Op_Not (Loc, + Right_Opnd => Relocate_Node (Condition (N))))); + Analyze (N); + end if; end if; - end; - end if; + end if; + end; end if; end Expand_N_If_Statement; -- cgit v1.1 From b55ef4b8d6ff7d8d6f290172cdffbb616816f56a Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 19 Dec 2020 11:55:29 +0100 Subject: [Ada] Fix interaction of 128-bit integer types and -gnato2 mode gcc/ada/ * exp_ch4.adb (Expand_Compare_Minimize_Eliminate_Overflow): Remove entry condition. (Expand_N_In): Call Minimized_Eliminated_Overflow_Check on the left operand before doing the special overflow expansion. (Expand_N_Op_Eq): Likewise. (Expand_N_Op_Ge): Likewise. (Expand_N_Op_Gt): Likewise. (Expand_N_Op_Le): Likewise. (Expand_N_Op_Lt): Likewise. (Expand_N_Op_Ne): Likewise. (Minimized_Eliminated_Overflow_Check): Return False for Minimized if the size of the type is greater than that of Long_Long_Integer. --- gcc/ada/exp_ch4.adb | 49 ++++++++++++++++++++++++++----------------------- 1 file changed, 26 insertions(+), 23 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 04bd1fe..0ca03b1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2253,9 +2253,6 @@ package body Exp_Ch4 is LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); -- Entity for Long_Long_Integer'Base - Check : constant Overflow_Mode_Type := Overflow_Check_Mode; - -- Current overflow checking mode - procedure Set_True; procedure Set_False; -- These procedures rewrite N with an occurrence of Standard_True or @@ -2284,17 +2281,6 @@ package body Exp_Ch4 is -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow begin - -- Nothing to do unless we have a comparison operator with operands - -- that are signed integer types, and we are operating in either - -- MINIMIZED or ELIMINATED overflow checking mode. - - if Nkind (N) not in N_Op_Compare - or else Check not in Minimized_Or_Eliminated - or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N))) - then - return; - end if; - -- OK, this is the case we are interested in. First step is to process -- our operands using the Minimize_Eliminate circuitry which applies -- this processing to the two operand subtrees. @@ -6425,8 +6411,7 @@ package body Exp_Ch4 is -- type, then expand with a separate procedure. Note the use of the -- flag No_Minimize_Eliminate to prevent infinite recursion. - if Overflow_Check_Mode in Minimized_Or_Eliminated - and then Is_Signed_Integer_Type (Ltyp) + if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) and then not No_Minimize_Eliminate (N) then Expand_Membership_Minimize_Eliminate_Overflow (N); @@ -8343,7 +8328,9 @@ package body Exp_Ch4 is -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that -- means we no longer have a comparison operation, we are all done. - Expand_Compare_Minimize_Eliminate_Overflow (N); + if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) then + Expand_Compare_Minimize_Eliminate_Overflow (N); + end if; if Nkind (N) /= N_Op_Eq then return; @@ -9201,7 +9188,9 @@ package body Exp_Ch4 is -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that -- means we no longer have a comparison operation, we are all done. - Expand_Compare_Minimize_Eliminate_Overflow (N); + if Minimized_Eliminated_Overflow_Check (Op1) then + Expand_Compare_Minimize_Eliminate_Overflow (N); + end if; if Nkind (N) /= N_Op_Ge then return; @@ -9250,7 +9239,9 @@ package body Exp_Ch4 is -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that -- means we no longer have a comparison operation, we are all done. - Expand_Compare_Minimize_Eliminate_Overflow (N); + if Minimized_Eliminated_Overflow_Check (Op1) then + Expand_Compare_Minimize_Eliminate_Overflow (N); + end if; if Nkind (N) /= N_Op_Gt then return; @@ -9299,7 +9290,9 @@ package body Exp_Ch4 is -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that -- means we no longer have a comparison operation, we are all done. - Expand_Compare_Minimize_Eliminate_Overflow (N); + if Minimized_Eliminated_Overflow_Check (Op1) then + Expand_Compare_Minimize_Eliminate_Overflow (N); + end if; if Nkind (N) /= N_Op_Le then return; @@ -9348,7 +9341,9 @@ package body Exp_Ch4 is -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that -- means we no longer have a comparison operation, we are all done. - Expand_Compare_Minimize_Eliminate_Overflow (N); + if Minimized_Eliminated_Overflow_Check (Op1) then + Expand_Compare_Minimize_Eliminate_Overflow (N); + end if; if Nkind (N) /= N_Op_Lt then return; @@ -9942,7 +9937,9 @@ package body Exp_Ch4 is -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if -- means we no longer have a /= operation, we are all done. - Expand_Compare_Minimize_Eliminate_Overflow (N); + if Minimized_Eliminated_Overflow_Check (Left_Opnd (N)) then + Expand_Compare_Minimize_Eliminate_Overflow (N); + end if; if Nkind (N) /= N_Op_Ne then return; @@ -14114,9 +14111,15 @@ package body Exp_Ch4 is function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is begin + -- The MINIMIZED mode operates in Long_Long_Integer so we cannot use it + -- if the type of the expression is already larger. + return Is_Signed_Integer_Type (Etype (N)) - and then Overflow_Check_Mode in Minimized_Or_Eliminated; + and then Overflow_Check_Mode in Minimized_Or_Eliminated + and then not (Overflow_Check_Mode = Minimized + and then + Esize (Etype (N)) > Standard_Long_Long_Integer_Size); end Minimized_Eliminated_Overflow_Check; ---------------------------- -- cgit v1.1 From d099fc2e643d6e0228864b5858223e55c8092d7c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 15 Dec 2020 15:36:54 -0500 Subject: [Ada] Self reference access discriminant gcc/ada/ * sem_ch3.adb (Check_Anonymous_Access_Component): Factor out core processing of Check_Anonymous_Access_Components. (Check_Anonymous_Access_Components): Call Check_Anonymous_Access_Component. (Process_Discriminants): Call Check_Anonymous_Access_Component. * freeze.adb (Freeze_Record_Type): Code cleanups and add more tree checking to handle changes in sem_ch3.adb. * sem_ch8.adb (Find_Type): Remove special case for access discriminant in task types, these are now supported. --- gcc/ada/freeze.adb | 37 ++------ gcc/ada/sem_ch3.adb | 237 +++++++++++++++++++++++++++++++--------------------- gcc/ada/sem_ch8.adb | 15 +--- 3 files changed, 148 insertions(+), 141 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index cbdecaa..bf20cbc 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4002,11 +4002,6 @@ package body Freeze is -- Set True if we find at least one component with no component -- clause (used to warn about useless Pack pragmas). - function Check_Allocator (N : Node_Id) return Node_Id; - -- If N is an allocator, possibly wrapped in one or more level of - -- qualified expression(s), return the inner allocator node, else - -- return Empty. - procedure Check_Itype (Typ : Entity_Id); -- If the component subtype is an access to a constrained subtype of -- an already frozen type, make the subtype frozen as well. It might @@ -4022,25 +4017,6 @@ package body Freeze is -- variants referenceed by the Variant_Part VP are frozen. This is -- a recursive routine to deal with nested variants. - --------------------- - -- Check_Allocator -- - --------------------- - - function Check_Allocator (N : Node_Id) return Node_Id is - Inner : Node_Id; - begin - Inner := N; - loop - if Nkind (Inner) = N_Allocator then - return Inner; - elsif Nkind (Inner) = N_Qualified_Expression then - Inner := Expression (Inner); - else - return Empty; - end if; - end loop; - end Check_Allocator; - ----------------- -- Check_Itype -- ----------------- @@ -4355,22 +4331,24 @@ package body Freeze is elsif Is_Access_Type (Etype (Comp)) and then Present (Parent (Comp)) + and then + Nkind (Parent (Comp)) + in N_Component_Declaration | N_Discriminant_Specification and then Present (Expression (Parent (Comp))) then declare Alloc : constant Node_Id := - Check_Allocator (Expression (Parent (Comp))); + Unqualify (Expression (Parent (Comp))); begin - if Present (Alloc) then + if Nkind (Alloc) = N_Allocator then -- If component is pointer to a class-wide type, freeze -- the specific type in the expression being allocated. -- The expression may be a subtype indication, in which -- case freeze the subtype mark. - if Is_Class_Wide_Type - (Designated_Type (Etype (Comp))) + if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append @@ -4382,17 +4360,14 @@ package body Freeze is (Entity (Subtype_Mark (Expression (Alloc))), N, Result); end if; - elsif Is_Itype (Designated_Type (Etype (Comp))) then Check_Itype (Etype (Comp)); - else Freeze_And_Append (Designated_Type (Etype (Comp)), N, Result); end if; end if; end; - elsif Is_Access_Type (Etype (Comp)) and then Is_Itype (Designated_Type (Etype (Comp))) then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 4784397..eb28a69 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -245,11 +245,12 @@ package body Sem_Ch3 is -- belongs must be a concurrent type or a descendant of a type with -- the reserved word 'limited' in its declaration. - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id); + procedure Check_Anonymous_Access_Component + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_Def : Node_Id; + Access_Def : Node_Id); -- Ada 2005 AI-382: an access component in a record definition can refer to -- the enclosing record, in which case it denotes the type itself, and not -- the current instance of the type. We create an anonymous access type for @@ -259,6 +260,13 @@ package body Sem_Ch3 is -- circularity issues in Gigi. We create an incomplete type for the record -- declaration, which is the designated type of the anonymous access. + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id); + -- Call Check_Anonymous_Access_Component on Comp_List + procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id); -- Check that, if a new discriminant is used in a constraint defining the -- parent subtype of a derivation, its subtype is statically compatible @@ -11157,21 +11165,20 @@ package body Sem_Ch3 is end if; end Check_Aliased_Component_Types; - --------------------------------------- - -- Check_Anonymous_Access_Components -- - --------------------------------------- + -------------------------------------- + -- Check_Anonymous_Access_Component -- + -------------------------------------- - procedure Check_Anonymous_Access_Components - (Typ_Decl : Node_Id; - Typ : Entity_Id; - Prev : Entity_Id; - Comp_List : Node_Id) + procedure Check_Anonymous_Access_Component + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_Def : Node_Id; + Access_Def : Node_Id) is - Loc : constant Source_Ptr := Sloc (Typ_Decl); + Loc : constant Source_Ptr := Sloc (Comp_Def); Anon_Access : Entity_Id; Acc_Def : Node_Id; - Comp : Node_Id; - Comp_Def : Node_Id; Decl : Node_Id; Type_Def : Node_Id; @@ -11205,13 +11212,18 @@ package body Sem_Ch3 is -- Is_Tagged indicates whether the type is tagged. It is tagged if -- it's "is new ... with record" or else "is tagged record ...". + Typ_Def : constant Node_Id := + (if Nkind (Typ_Decl) = N_Full_Type_Declaration + then Type_Definition (Typ_Decl) else Empty); Is_Tagged : constant Boolean := - (Nkind (Type_Definition (Typ_Decl)) = N_Derived_Type_Definition - and then - Present (Record_Extension_Part (Type_Definition (Typ_Decl)))) - or else - (Nkind (Type_Definition (Typ_Decl)) = N_Record_Definition - and then Tagged_Present (Type_Definition (Typ_Decl))); + Present (Typ_Def) + and then + ((Nkind (Typ_Def) = N_Derived_Type_Definition + and then + Present (Record_Extension_Part (Typ_Def))) + or else + (Nkind (Typ_Def) = N_Record_Definition + and then Tagged_Present (Typ_Def))); begin -- If there is a previous partial view, no need to create a new one @@ -11429,88 +11441,104 @@ package body Sem_Ch3 is return False; end Mentions_T; - -- Start of processing for Check_Anonymous_Access_Components + -- Start of processing for Check_Anonymous_Access_Component begin - if No (Comp_List) then - return; - end if; + if Present (Access_Def) and then Mentions_T (Access_Def) then + Acc_Def := Access_To_Subprogram_Definition (Access_Def); - Comp := First (Component_Items (Comp_List)); - while Present (Comp) loop - if Nkind (Comp) = N_Component_Declaration - and then Present - (Access_Definition (Component_Definition (Comp))) - and then - Mentions_T (Access_Definition (Component_Definition (Comp))) - then - Comp_Def := Component_Definition (Comp); - Acc_Def := - Access_To_Subprogram_Definition (Access_Definition (Comp_Def)); - - Build_Incomplete_Type_Declaration; - Anon_Access := Make_Temporary (Loc, 'S'); - - -- Create a declaration for the anonymous access type: either - -- an access_to_object or an access_to_subprogram. - - if Present (Acc_Def) then - if Nkind (Acc_Def) = N_Access_Function_Definition then - Type_Def := - Make_Access_Function_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def), - Result_Definition => Result_Definition (Acc_Def)); - else - Type_Def := - Make_Access_Procedure_Definition (Loc, - Parameter_Specifications => - Parameter_Specifications (Acc_Def)); - end if; + Build_Incomplete_Type_Declaration; + Anon_Access := Make_Temporary (Loc, 'S'); + -- Create a declaration for the anonymous access type: either + -- an access_to_object or an access_to_subprogram. + + if Present (Acc_Def) then + if Nkind (Acc_Def) = N_Access_Function_Definition then + Type_Def := + Make_Access_Function_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def), + Result_Definition => Result_Definition (Acc_Def)); else Type_Def := - Make_Access_To_Object_Definition (Loc, - Subtype_Indication => - Relocate_Node - (Subtype_Mark (Access_Definition (Comp_Def)))); - - Set_Constant_Present - (Type_Def, Constant_Present (Access_Definition (Comp_Def))); - Set_All_Present - (Type_Def, All_Present (Access_Definition (Comp_Def))); + Make_Access_Procedure_Definition (Loc, + Parameter_Specifications => + Parameter_Specifications (Acc_Def)); end if; - Set_Null_Exclusion_Present - (Type_Def, - Null_Exclusion_Present (Access_Definition (Comp_Def))); + else + Type_Def := + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + Relocate_Node (Subtype_Mark (Access_Def))); - Decl := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Anon_Access, - Type_Definition => Type_Def); + Set_Constant_Present (Type_Def, Constant_Present (Access_Def)); + Set_All_Present (Type_Def, All_Present (Access_Def)); + end if; - Insert_Before (Typ_Decl, Decl); - Analyze (Decl); + Set_Null_Exclusion_Present + (Type_Def, Null_Exclusion_Present (Access_Def)); - -- If an access to subprogram, create the extra formals + Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Anon_Access, + Type_Definition => Type_Def); - if Present (Acc_Def) then - Create_Extra_Formals (Designated_Type (Anon_Access)); - end if; + Insert_Before (Typ_Decl, Decl); + Analyze (Decl); + + -- If an access to subprogram, create the extra formals + if Present (Acc_Def) then + Create_Extra_Formals (Designated_Type (Anon_Access)); + end if; + + if Nkind (Comp_Def) = N_Component_Definition then Rewrite (Comp_Def, Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Anon_Access, Loc))); + Subtype_Indication => New_Occurrence_Of (Anon_Access, Loc))); + else + pragma Assert (Nkind (Comp_Def) = N_Discriminant_Specification); + Rewrite (Comp_Def, + Make_Discriminant_Specification (Loc, + Defining_Identifier => Defining_Identifier (Comp_Def), + Discriminant_Type => New_Occurrence_Of (Anon_Access, Loc))); + end if; - if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then - Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); - else - Set_Ekind (Anon_Access, E_Anonymous_Access_Type); - end if; + if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then + Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type); + else + Set_Ekind (Anon_Access, E_Anonymous_Access_Type); + end if; + + Set_Is_Local_Anonymous_Access (Anon_Access); + end if; + end Check_Anonymous_Access_Component; + + --------------------------------------- + -- Check_Anonymous_Access_Components -- + --------------------------------------- - Set_Is_Local_Anonymous_Access (Anon_Access); + procedure Check_Anonymous_Access_Components + (Typ_Decl : Node_Id; + Typ : Entity_Id; + Prev : Entity_Id; + Comp_List : Node_Id) + is + Comp : Node_Id; + begin + if No (Comp_List) then + return; + end if; + + Comp := First (Component_Items (Comp_List)); + while Present (Comp) loop + if Nkind (Comp) = N_Component_Declaration then + Check_Anonymous_Access_Component + (Typ_Decl, Typ, Prev, + Component_Definition (Comp), + Access_Definition (Component_Definition (Comp))); end if; Next (Comp); @@ -20041,19 +20069,34 @@ package body Sem_Ch3 is end if; if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then - Discr_Type := Access_Definition (Discr, Discriminant_Type (Discr)); + Check_Anonymous_Access_Component + (Typ_Decl => N, + Typ => Defining_Identifier (N), + Prev => Prev, + Comp_Def => Discr, + Access_Def => Discriminant_Type (Discr)); + + -- if Check_Anonymous_Access_Component replaced Discr then + -- its Original_Node points to the old Discr and the access type + -- for Discr_Type has already been created. + + if Original_Node (Discr) /= Discr then + Discr_Type := Etype (Discriminant_Type (Discr)); + else + Discr_Type := + Access_Definition (Discr, Discriminant_Type (Discr)); - -- Ada 2005 (AI-254) + -- Ada 2005 (AI-254) - if Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - and then Protected_Present (Access_To_Subprogram_Definition - (Discriminant_Type (Discr))) - then - Discr_Type := - Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + if Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + and then Protected_Present (Access_To_Subprogram_Definition + (Discriminant_Type (Discr))) + then + Discr_Type := + Replace_Anonymous_Access_To_Protected_Subprogram (Discr); + end if; end if; - else Find_Type (Discriminant_Type (Discr)); Discr_Type := Etype (Discriminant_Type (Discr)); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 817cba9..62ebaa3 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -8128,25 +8128,14 @@ package body Sem_Ch8 is if Ekind (Base_Type (T_Name)) = E_Task_Type then -- In Ada 2005, a task name can be used in an access - -- definition within its own body. It cannot be used - -- in the discriminant part of the task declaration, - -- nor anywhere else in the declaration because entries - -- cannot have access parameters. + -- definition within its own body. if Ada_Version >= Ada_2005 and then Nkind (Parent (N)) = N_Access_Definition then Set_Entity (N, T_Name); Set_Etype (N, T_Name); - - if Has_Completion (T_Name) then - return; - - else - Error_Msg_N - ("task type cannot be used as type mark " & - "within its own declaration", N); - end if; + return; else Error_Msg_N -- cgit v1.1 From 2e8ee0a364ac7dc9959b1caac7d7145afedd1eaa Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 21 Dec 2020 16:22:53 +0100 Subject: [Ada] Eliminate useless 128-bit overflow check for conversion gcc/ada/ * exp_attr.adb (Expand_N_Attribute_Reference) : Apply the checks for universal integer contexts only in the default case. * exp_ch4.adb (Get_Size_For_Range): Move to library level. (Expand_N_Type_Conversion): If the operand has Universal_Integer type and the conversion requires an overflow check, try to do an intermediate conversion to a narrower type. --- gcc/ada/exp_attr.adb | 51 +++++-------------- gcc/ada/exp_ch4.adb | 139 ++++++++++++++++++++++++++++++++------------------- 2 files changed, 99 insertions(+), 91 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b3ac7b7..25bf0f7 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4598,13 +4598,7 @@ package body Exp_Attr is ---------------------------------- when Attribute_Max_Size_In_Storage_Elements => declare - Typ : constant Entity_Id := Etype (N); - Attr : Node_Id; - Atyp : Entity_Id; - - Conversion_Added : Boolean := False; - -- A flag which tracks whether the original attribute has been - -- wrapped inside a type conversion. + Typ : constant Entity_Id := Etype (N); begin -- If the prefix is X'Class, we transform it into a direct reference @@ -4618,40 +4612,22 @@ package body Exp_Attr is return; end if; - Apply_Universal_Integer_Attribute_Checks (N); - - -- The universal integer check may sometimes add a type conversion, - -- retrieve the original attribute reference from the expression. - - Attr := N; - - if Nkind (Attr) = N_Type_Conversion then - Attr := Expression (Attr); - Conversion_Added := True; - end if; - - pragma Assert (Nkind (Attr) = N_Attribute_Reference); - -- Heap-allocated controlled objects contain two extra pointers which -- are not part of the actual type. Transform the attribute reference -- into a runtime expression to add the size of the hidden header. - if Needs_Finalization (Ptyp) - and then not Header_Size_Added (Attr) - then - Set_Header_Size_Added (Attr); - - Atyp := Etype (Attr); + if Needs_Finalization (Ptyp) and then not Header_Size_Added (N) then + Set_Header_Size_Added (N); -- Generate: -- P'Max_Size_In_Storage_Elements + - -- Atyp (Header_Size_With_Padding (Ptyp'Alignment)) + -- Typ (Header_Size_With_Padding (Ptyp'Alignment)) - Rewrite (Attr, + Rewrite (N, Make_Op_Add (Loc, - Left_Opnd => Relocate_Node (Attr), + Left_Opnd => Relocate_Node (N), Right_Opnd => - Convert_To (Atyp, + Convert_To (Typ, Make_Function_Call (Loc, Name => New_Occurrence_Of @@ -4663,16 +4639,13 @@ package body Exp_Attr is New_Occurrence_Of (Ptyp, Loc), Attribute_Name => Name_Alignment)))))); - Analyze_And_Resolve (Attr, Atyp); - - -- Add a conversion to the target type - - if not Conversion_Added then - Convert_To_And_Rewrite (Typ, Attr); - end if; - + Analyze_And_Resolve (N, Typ); return; end if; + + -- In the other cases apply the required checks + + Apply_Universal_Integer_Attribute_Checks (N); end; -------------------- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0ca03b1..143cce1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -172,6 +172,10 @@ package body Exp_Ch4 is -- routine is to find the real type by looking up the tree. We also -- determine if the operation must be rounded. + function Get_Size_For_Range (Lo, Hi : Uint) return Uint; + -- Return the size of a small signed integer type covering Lo .. Hi, the + -- main goal being to return a size lower than that of standard types. + function Has_Inferable_Discriminants (N : Node_Id) return Boolean; -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable -- discriminants if it has a constrained nominal type, unless the object @@ -12270,6 +12274,41 @@ package body Exp_Ch4 is end; end if; + -- If the conversion is from Universal_Integer and requires an overflow + -- check, try to do an intermediate conversion to a narrower type first + -- without overflow check, in order to avoid doing the overflow check + -- in Universal_Integer, which can be a very large type. + + if Operand_Type = Universal_Integer and then Do_Overflow_Check (N) then + declare + Lo, Hi, Siz : Uint; + OK : Boolean; + Typ : Entity_Id; + + begin + Determine_Range (Operand, OK, Lo, Hi, Assume_Valid => True); + + if OK then + Siz := Get_Size_For_Range (Lo, Hi); + + -- We use the base type instead of the first subtype because + -- overflow checks are done in the base type, so this avoids + -- the need for useless conversions. + + if Siz < System_Max_Integer_Size then + Typ := Etype (Integer_Type_For (Siz, Uns => False)); + + Convert_To_And_Rewrite (Typ, Operand); + Analyze_And_Resolve + (Operand, Typ, Suppress => Overflow_Check); + + Analyze_And_Resolve (N, Target_Type); + goto Done; + end if; + end if; + end; + end if; + -- Do validity check if validity checking operands if Validity_Checks_On and Validity_Check_Operands then @@ -13328,6 +13367,54 @@ package body Exp_Ch4 is end if; end Fixup_Universal_Fixed_Operation; + ------------------------ + -- Get_Size_For_Range -- + ------------------------ + + function Get_Size_For_Range (Lo, Hi : Uint) return Uint is + + function Is_OK_For_Range (Siz : Uint) return Boolean; + -- Return True if a signed integer with given size can cover Lo .. Hi + + -------------------------- + -- Is_OK_For_Range -- + -------------------------- + + function Is_OK_For_Range (Siz : Uint) return Boolean is + B : constant Uint := Uint_2 ** (Siz - 1); + + begin + -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) + + return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B; + end Is_OK_For_Range; + + begin + -- This is (almost always) the size of Integer + + if Is_OK_For_Range (Uint_32) then + return Uint_32; + + -- Check 63 + + elsif Is_OK_For_Range (Uint_63) then + return Uint_63; + + -- This is (almost always) the size of Long_Long_Integer + + elsif Is_OK_For_Range (Uint_64) then + return Uint_64; + + -- Check 127 + + elsif Is_OK_For_Range (Uint_127) then + return Uint_127; + + else + return Uint_128; + end if; + end Get_Size_For_Range; + --------------------------------- -- Has_Inferable_Discriminants -- --------------------------------- @@ -14135,58 +14222,6 @@ package body Exp_Ch4 is Typ : constant Entity_Id := Etype (R); Tsiz : constant Uint := RM_Size (Typ); - function Get_Size_For_Range (Lo, Hi : Uint) return Uint; - -- Return the size of a small signed integer type covering Lo .. Hi. - -- The important thing is to return a size lower than that of Typ. - - ------------------------ - -- Get_Size_For_Range -- - ------------------------ - - function Get_Size_For_Range (Lo, Hi : Uint) return Uint is - - function Is_OK_For_Range (Siz : Uint) return Boolean; - -- Return True if a signed integer with given size can cover Lo .. Hi - - -------------------------- - -- Is_OK_For_Range -- - -------------------------- - - function Is_OK_For_Range (Siz : Uint) return Boolean is - B : constant Uint := Uint_2 ** (Siz - 1); - - begin - -- Test B = 2 ** (size - 1) (can accommodate -B .. +(B - 1)) - - return Lo >= -B and then Hi >= -B and then Lo < B and then Hi < B; - end Is_OK_For_Range; - - begin - -- This is (almost always) the size of Integer - - if Is_OK_For_Range (Uint_32) then - return Uint_32; - - -- If the size of Typ is 64 then check 63 - - elsif Tsiz = Uint_64 and then Is_OK_For_Range (Uint_63) then - return Uint_63; - - -- This is (almost always) the size of Long_Long_Integer - - elsif Is_OK_For_Range (Uint_64) then - return Uint_64; - - -- If the size of Typ is 128 then check 127 - - elsif Tsiz = Uint_128 and then Is_OK_For_Range (Uint_127) then - return Uint_127; - - else - return Uint_128; - end if; - end Get_Size_For_Range; - -- Local variables L : Node_Id; -- cgit v1.1 From 3c8e539dcfd955b24af44b95a1a900dc0a5dc4c9 Mon Sep 17 00:00:00 2001 From: GCC Administrator Date: Fri, 30 Apr 2021 00:16:37 +0000 Subject: Daily bump. --- gcc/ada/ChangeLog | 240 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 240 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f3ad896..acaa7ae 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,243 @@ +2021-04-29 Eric Botcazou + + * exp_attr.adb (Expand_N_Attribute_Reference) + : Apply the checks for + universal integer contexts only in the default case. + * exp_ch4.adb (Get_Size_For_Range): Move to library level. + (Expand_N_Type_Conversion): If the operand has Universal_Integer + type and the conversion requires an overflow check, try to do an + intermediate conversion to a narrower type. + +2021-04-29 Arnaud Charlet + + * sem_ch3.adb (Check_Anonymous_Access_Component): Factor out + core processing of Check_Anonymous_Access_Components. + (Check_Anonymous_Access_Components): Call + Check_Anonymous_Access_Component. + (Process_Discriminants): Call Check_Anonymous_Access_Component. + * freeze.adb (Freeze_Record_Type): Code cleanups and add more tree + checking to handle changes in sem_ch3.adb. + * sem_ch8.adb (Find_Type): Remove special case for access + discriminant in task types, these are now supported. + +2021-04-29 Eric Botcazou + + * exp_ch4.adb (Expand_Compare_Minimize_Eliminate_Overflow): Remove + entry condition. + (Expand_N_In): Call Minimized_Eliminated_Overflow_Check on the left + operand before doing the special overflow expansion. + (Expand_N_Op_Eq): Likewise. + (Expand_N_Op_Ge): Likewise. + (Expand_N_Op_Gt): Likewise. + (Expand_N_Op_Le): Likewise. + (Expand_N_Op_Lt): Likewise. + (Expand_N_Op_Ne): Likewise. + (Minimized_Eliminated_Overflow_Check): Return False for Minimized + if the size of the type is greater than that of Long_Long_Integer. + +2021-04-29 Arnaud Charlet + + * exp_ch5.adb (Expand_N_If_Statement): Only perform the + simplification on return True/False for internal nodes when + -fpreserve-control-flow is not set. + +2021-04-29 Eric Botcazou + + * sem_attr.adb (Eval_Attribute) : Use + Round_Even instead of Round in the call to the Machine routine. + +2021-04-29 Bob Duff + + * sem_attr.adb (Analyze_Attribute): Change "$" to "&". + Otherwise, Errout will trip over an uninitialized (invalid) + variable (Error_Msg_Unit_1). + +2021-04-29 Eric Botcazou + + * libgnat/s-valuer.adb (Scan_Decimal_Digits): Set Extra to zero + when the precision limit is reached by means of trailing zeros + and prevent it from being overwritten later. + +2021-04-29 Yannick Moy + + * errout.adb (Output_Messages): Insert SGR strings where needed. + * erroutc.adb (Output_Message_Txt): Insert SGR strings where + needed in the text of the message itself. + (Output_Msg_Text): Allow for style message not to start + with (style). + * erroutc.ads: Add new constants and functions to control colors + in messages output to the terminal. Add variable Use_SGR_Control + that should be set to True for using SGR color control strings. + +2021-04-29 Yannick Moy + + * sem_eval.adb (Check_Non_Static_Context_For_Overflow): Apply + compile-time checking for overflows in non-static contexts + including inlined code. + (Eval_Arithmetic_Op): Use the new procedure. + (Eval_Unary_Op, Eval_Op_Expon): Add call to the new procedure. + +2021-04-29 Justin Squirek + + * checks.adb (Apply_Type_Conversion_Checks): Move out constraint + check generation, and add case for general access types with + constraints. + (Make_Discriminant_Constraint_Check): Created to centralize + generation of constraint checks for stored discriminants. + +2021-04-29 Eric Botcazou + + * gnat1drv.adb (Adjust_Global_Switches): Force a 32-bit Duration + type if the maximum integer size is lower than 64 bits. + +2021-04-29 Arnaud Charlet + + * Makefile.rtl (ADA_EXCLUDE_SRCS): Remove unused files. + (ADA_INCLUDE_SRCS): Remove libgnat/system.ads + +2021-04-29 Arnaud Charlet + + * exp_aggr.adb (Collect_Initialization_Statements): Removed. + (Convert_Aggr_In_Object_Decl, Expand_Array_Aggregate): Fix + creation and insertion of Initialization_Statements. Do not set + Initialization_Statements when a transient scope is involved. + Move processing of Array_Slice here. Ensure that an object with + an Array_Slice call gets its array component initialized. Add + comments. + * exp_ch7.adb: Update comments. + (Store_Actions_In_Scope): Deal properly with an empty list which + might now be generated by Convert_Aggr_In_Object_Decl. + * exp_ch3.adb: Update comments. + (Expand_N_Object_Declaration): Remove processing of Array_Slice. + +2021-04-29 Arnaud Charlet + + * sem_ch8.adb (Analyze_Object_Renaming): Update check for + AI12-0401. + +2021-04-29 Patrick Bernardi + + * libgnat/s-stoele.ads (Storage_Offset): Cleanup comment. + +2021-04-29 Gary Dismukes + + * exp_util.adb (Add_Own_DIC): Relax the suppression of adding a + DIC Check pragma that's done for abstract types by still doing + it in the case where GNATprove_Mode is set. + +2021-04-29 Joel Brobecker + + * Makefile.rtl (ADA_EXCLUDE_SRCS): Remove s-gcc.adb, s-gcc.ads, + s-gccdiv.adb, s-gccdiv.ads, s-gccshi.adb and s-gccshi.ads. + +2021-04-29 Piotr Trojanek + + * layout.adb (Layout_Type): Refine type of a local variable with + the required size of object from Int to Pos (it is initialized + with 8 and only multiplied by 2); fix unbalanced parens in + comment. + +2021-04-29 Eric Botcazou + + * eval_fat.adb (Succ): Use Ureal_Half in a couple of places. + +2021-04-29 Ed Schonberg + + * sem_util.adb (Build_Constrained_Itype): Inhibit the generation + of predicate functions for this Itype, which is created for an + aggregate of a discriminated type. The object to which the + aggregate is assigned, e.g a writable actual parameter, will + apply the predicates if any are inherited from the base type. + +2021-04-29 Piotr Trojanek + + * sem_cat.adb (Set_Categorization_From_Pragmas): Remove special + case for generic child units; remove optimization for empty list + of pragmas; properly restore visibility. + +2021-04-29 Piotr Trojanek + + * sem_elab.adb (Process_SPARK_Instantiation): Fix typo in + comment. + * sem_prag.adb (Find_Related_Context): Add missing reference to + No_Caching in the comment; handle pragmas on compilation units. + +2021-04-29 Piotr Trojanek + + * doc/gnat_rm/implementation_defined_attributes.rst: Change all + occurrences of "permissible prefix" to "allowed prefix", for + consistency. + * gnat_rm.texi: Regenerate. + +2021-04-29 Eric Botcazou + + * eval_fat.adb (Succ): Add a special case for zero if the type does + not support denormalized numbers. Always use the canonical formula + in other cases and add commentary throughout the function. + +2021-04-29 Eric Botcazou + + * libgnat/s-fatgen.adb: Remove with clause for Interfaces and + use type clauses for Interfaces.Unsigned_{16,32,64}. + (Small16): Remove. + (Small32): Likewise + (Small64): Likewise. + (Small80): Likewise. + (Tiny16): Likewise. + (Tiny32): Likewise. + (Tiny64): Likewise. + (Tiny80): Likewise. + (Siz): Always use 16. + (NR): New constant. + (Rep_Last): Use it in the computation. + (Exp_Factor): Remove special case for 80-bit. + (Sign_Mask): Likewise. + (Finite_Succ): New function implementing the Succ attribute for + finite numbers. + (Pred): Rewrite in terms of Finite_Succ. + (Succ): Likewise. + +2021-04-29 Arnaud Charlet + + * debug_a.adb (Debug_Output_Astring): Remove obsolete comment. + +2021-04-29 Arnaud Charlet + + * sem_attr.adb (Check_Image_Type): Protect against empty + Image_Type. + +2021-04-29 Arnaud Charlet + + * libgnat/a-nbnbin.ads (From_Universal_Image): New. + (Big_Integer): Update definition. + * libgnat/a-nbnbre.ads, libgnat/a-nbnbre.adb + (From_Universal_Image): New. + (From_String): Remove alternate body, replaced by + From_Universal_Image. + (Big_Real): Update definition. + +2021-04-29 Gary Dismukes + + * sem_ch8.adb (Find_Type): Check the No_Obsolescent_Features + restriction for 'Class applied to an untagged incomplete + type (when Ada_Version >= Ada_2005). Remove disabling of the + warning message for such usage, along with the ??? comment, + which no longer applies (because the -gnatg switch no longer + sets Warn_On_Obsolescent_Feature). + +2021-04-29 Yannick Moy + + * errout.adb (Error_Msg_NEL): Extract span from node. + (First_And_Last_Nodes): Use spans for subtype indications and + attribute definition clauses. + (Write_Source_Code_Lines): Fix for tabulation characters. Change + output for large spans to skip intermediate lines. + * sem_case.adb (Check_Choice_Set): Report duplicate choice on + the Original_Node for the case. + (Generic_Check_Choices): Set the Original_Node for the rewritten + case, so that the subtree used in spans has the correct + locations. + 2021-04-28 Piotr Trojanek * sem_ch13.adb, sem_util.adb: Fix style. -- cgit v1.1 From 03c80e174bc059b50063da24cf89b67e692bc5d8 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Sun, 20 Dec 2020 20:18:33 -0500 Subject: [Ada] Compiler aborts on a constrained subtype of a predicated type gcc/ada/ * sem_util.adb (Build_Constrained_Itype): Remove prior patch, issue is better handled in Sem_Ch13.Build_Predicate_Functions. * sem_ch13.adb (Build_Predicate_Functions): Do not build predicate function for an Itype with a defined Predicated_Parent, even if that designated parent does not yet have a Predicate_Function. This can happen in instance bodies nested within a generic unit. --- gcc/ada/sem_ch13.adb | 14 +++++++++++++- gcc/ada/sem_util.adb | 8 -------- 2 files changed, 13 insertions(+), 9 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c863154..005c7b0 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9976,11 +9976,23 @@ package body Sem_Ch13 is -- Start of processing for Build_Predicate_Functions begin - -- Return if already built or if type does not have predicates + -- Return if already built, if type does not have predicates, + -- or if type is a constructed subtype that will inherit a + -- predicate function from its ancestor. In a generic context + -- the predicated parent may not have a predicate function yet + -- but we don't want to build a new one for the subtype. This can + -- happen in an instance body which is nested within a generic + -- unit, in which case Within_A_Generic may be false, SId is + -- Empty, but uses of Typ will receive a predicate check in a + -- context where expansion and tests are enabled. SId := Predicate_Function (Typ); if not Has_Predicates (Typ) or else (Present (SId) and then Has_Completion (SId)) + or else + (Is_Itype (Typ) + and then not Comes_From_Source (Typ) + and then Present (Predicated_Parent (Typ))) then return; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a64cbde..b7b622d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -2380,14 +2380,6 @@ package body Sem_Util is Analyze (Subtyp_Decl, Suppress => All_Checks); - -- In addition, inhibit the generation of predicate functions for - -- this subtype, because its declaration is not in a declarative - -- list, and no predicates apply to the aggregate itself, but only - -- to the object to which it may be assigned. - - Set_Has_Dynamic_Predicate_Aspect (Def_Id, False); - Set_Has_Predicates (Def_Id, False); - Set_Etype (N, Def_Id); end Build_Constrained_Itype; -- cgit v1.1 From 5e024b97f260f393589293e2635a98ca361f57b2 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Mon, 21 Dec 2020 13:37:27 +0100 Subject: [Ada] Cleanup processing of aspect Dynamic_Predicate gcc/ada/ * sem_ch13.adb (Build_Predicate_Functions): Fix typo in comment. (Resolve_Aspect_Expressions): Fix typo in comment; remove redundant check for no aspects; simplify with Discard_Node. --- gcc/ada/sem_ch13.adb | 22 +++++++--------------- 1 file changed, 7 insertions(+), 15 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 005c7b0..1df37d9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9998,7 +9998,7 @@ package body Sem_Ch13 is -- Do not generate predicate bodies within a generic unit. The -- expressions have been analyzed already, and the bodies play - -- no role if not within an executable unit. However, if a statc + -- no role if not within an executable unit. However, if a static -- predicate is present it must be processed for legality checks -- such as case coverage in an expression. @@ -14914,7 +14914,7 @@ package body Sem_Ch13 is Find_Direct_Name (N); Set_Entity (N, Empty); - -- The name is component association needs no resolution. + -- The name is component association needs no resolution elsif Nkind (N) = N_Component_Association then Dummy := Resolve_Name (Expression (N)); @@ -14936,10 +14936,6 @@ package body Sem_Ch13 is -- Start of processing for Resolve_Aspect_Expressions begin - if No (ASN) then - return; - end if; - while Present (ASN) loop if Nkind (ASN) = N_Aspect_Specification and then Entity (ASN) = E then declare @@ -14976,16 +14972,12 @@ package body Sem_Ch13 is -- discriminants of the type. if No (Predicate_Function (E)) then - declare - FDecl : constant Node_Id := - Build_Predicate_Function_Declaration (E); - pragma Unreferenced (FDecl); + Discard_Node + (Build_Predicate_Function_Declaration (E)); - begin - Push_Type (E); - Resolve_Aspect_Expression (Expr); - Pop_Type (E); - end; + Push_Type (E); + Resolve_Aspect_Expression (Expr); + Pop_Type (E); end if; when Pre_Post_Aspects => -- cgit v1.1 From 1668564fdefee11a2f455766f310baf8d5b2e1af Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Dec 2020 11:57:21 -0500 Subject: [Ada] Code cleanup gcc/ada/ * libgnat/a-ztcoio.adb: Remove unused with clause. --- gcc/ada/libgnat/a-ztcoio.adb | 2 -- 1 file changed, 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb index 5103191..9efad03b 100644 --- a/gcc/ada/libgnat/a-ztcoio.adb +++ b/gcc/ada/libgnat/a-ztcoio.adb @@ -37,8 +37,6 @@ with System.Val_LLF; use System.Val_LLF; with System.WCh_Con; use System.WCh_Con; with System.WCh_WtS; use System.WCh_WtS; -with Ada.Unchecked_Conversion; - package body Ada.Wide_Wide_Text_IO.Complex_IO is use Complex_Types; -- cgit v1.1 From e36ee1b4df7197b6e7542bb67004b1fcf09714ce Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Dec 2020 10:34:37 -0500 Subject: [Ada] Spurious warning on postcondition and result gcc/ada/ * sem_util.adb (Check_Result_And_Post_State): Replace custom Has_In_Out_Parameter with existing Has_Out_Or_In_Out_Parameter flag which corresponds exactly to what we need. --- gcc/ada/sem_util.adb | 30 ++---------------------------- 1 file changed, 2 insertions(+), 28 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b7b622d..c4fe191 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4701,10 +4701,6 @@ package body Sem_Util is -- and post-state. Prag is a [refined] postcondition or a contract-cases -- pragma. Result_Seen is set when the pragma mentions attribute 'Result - function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean; - -- Determine whether subprogram Subp_Id contains at least one IN OUT - -- formal parameter. - ------------------------------------------- -- Check_Result_And_Post_State_In_Pragma -- ------------------------------------------- @@ -5093,28 +5089,6 @@ package body Sem_Util is end if; end Check_Result_And_Post_State_In_Pragma; - -------------------------- - -- Has_In_Out_Parameter -- - -------------------------- - - function Has_In_Out_Parameter (Subp_Id : Entity_Id) return Boolean is - Formal : Entity_Id; - - begin - -- Traverse the formals looking for an IN OUT parameter - - Formal := First_Formal (Subp_Id); - while Present (Formal) loop - if Ekind (Formal) = E_In_Out_Parameter then - return True; - end if; - - Next_Formal (Formal); - end loop; - - return False; - end Has_In_Out_Parameter; - -- Local variables Items : constant Node_Id := Contract (Subp_Id); @@ -5194,10 +5168,10 @@ package body Sem_Util is null; -- Regardless of whether the function has postconditions or contract - -- cases, or whether they mention attribute 'Result, an IN OUT formal + -- cases, or whether they mention attribute 'Result, an [IN] OUT formal -- parameter is always treated as a result. - elsif Has_In_Out_Parameter (Spec_Id) then + elsif Has_Out_Or_In_Out_Parameter (Spec_Id) then null; -- The function has both a postcondition and contract cases and they do -- cgit v1.1 From 56adf813f4e23d95d92385dee9b31e5e0d476abd Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 22 Dec 2020 10:02:29 -0500 Subject: [Ada] No_Implicit_Loops restriction and pragma Assert gcc/ada/ * tbuild.adb (Make_Implicit_Loop_Statement): Disable restriction checking on dead paths. --- gcc/ada/tbuild.adb | 43 ++++++++++++++++++++++++++++++++++++------- 1 file changed, 36 insertions(+), 7 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 3b33ee7..6febaa7 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -35,6 +35,7 @@ with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -348,14 +349,42 @@ package body Tbuild is Has_Created_Identifier : Boolean := False; End_Label : Node_Id := Empty) return Node_Id is - begin - Check_Restriction (No_Implicit_Loops, Node); + P : Node_Id; + Check_Restrictions : Boolean := True; + begin + -- Do not check restrictions if the implicit loop statement is part + -- of a dead branch: False and then ... + -- This will occur in particular as part of the expansion of pragma + -- Assert when assertions are disabled. + + P := Parent (Node); + while Present (P) loop + if Nkind (P) = N_And_Then then + if Nkind (Left_Opnd (P)) = N_Identifier + and then Entity (Left_Opnd (P)) = Standard_False + then + Check_Restrictions := False; + exit; + end if; - if Present (Iteration_Scheme) - and then Nkind (Iteration_Scheme) /= N_Iterator_Specification - and then Present (Condition (Iteration_Scheme)) - then - Check_Restriction (No_Implicit_Conditionals, Node); + -- Prevent the search from going too far + + elsif Is_Body_Or_Package_Declaration (P) then + exit; + end if; + + P := Parent (P); + end loop; + + if Check_Restrictions then + Check_Restriction (No_Implicit_Loops, Node); + + if Present (Iteration_Scheme) + and then Nkind (Iteration_Scheme) /= N_Iterator_Specification + and then Present (Condition (Iteration_Scheme)) + then + Check_Restriction (No_Implicit_Conditionals, Node); + end if; end if; return Make_Loop_Statement (Sloc (Node), -- cgit v1.1 From d56fbda96a7c34ad897b9cc871242047fe19393c Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 23 Dec 2020 11:35:19 +0100 Subject: [Ada] Code and style cleanups for CUDA gcc/ada/ * exp_prag.adb (Expand_Pragma_CUDA_Execute): Refill comments; remove periods after single-line comments; use procedural variant of Next_Entity. * gnat_cuda.adb: Refill comments; remove periods after single-line comments; replace calls to UI_From_Int with constants; change iteration bounds so they match the comments. * sem_prag.adb (Analyze_Pragma): Add checks for malformed pragma CUDA_Kernel aggregate; simplify processing of pragma CUDA_Global with Check_Arg_Count; sync comment with code for CUDA_Global. --- gcc/ada/exp_prag.adb | 33 ++++++++++++++++----------------- gcc/ada/gnat_cuda.adb | 41 ++++++++++++++++++++--------------------- gcc/ada/sem_prag.adb | 11 ++++++----- 3 files changed, 42 insertions(+), 43 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index d616fb6..ca1b084 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -771,7 +771,7 @@ package body Exp_Prag is function Get_Nth_Arg_Type (Subprogram : Entity_Id; N : Positive) return Entity_Id; - -- Returns the type of the Nth argument of Subprogram. + -- Returns the type of the Nth argument of Subprogram function To_Addresses (Elmts : Elist_Id) return List_Id; -- Returns a new list containing each element of Elmts wrapped in an @@ -821,9 +821,9 @@ package body Exp_Prag is Init_Val : Node_Id) return Node_Id is -- Expressions for each component of the returned Dim3 - Dim_X : Node_Id; - Dim_Y : Node_Id; - Dim_Z : Node_Id; + Dim_X : Node_Id; + Dim_Y : Node_Id; + Dim_Z : Node_Id; -- Type of CUDA.Internal.Dim3 - inferred from -- RE_Push_Call_Configuration to avoid needing changes in GNAT when @@ -835,12 +835,13 @@ package body Exp_Prag is First_Component : Entity_Id := First_Entity (RTE (RE_Dim3)); Second_Component : Entity_Id := Next_Entity (First_Component); Third_Component : Entity_Id := Next_Entity (Second_Component); + begin - -- Sem_prag.adb ensured that Init_Val is either a Dim3, an - -- aggregate of three Any_Integers or Any_Integer. + -- Sem_prag.adb ensured that Init_Val is either a Dim3, an aggregate + -- of three Any_Integers or Any_Integer. - -- If Init_Val is a Dim3, use each of its components. + -- If Init_Val is a Dim3, use each of its components if Etype (Init_Val) = RTE (RE_Dim3) then Dim_X := Make_Selected_Component (Loc, @@ -862,7 +863,7 @@ package body Exp_Prag is Dim_Y := Next (Dim_X); Dim_Z := Next (Dim_Y); - -- Otherwise, we know it is an integer and the rest defaults to 1. + -- Otherwise, we know it is an integer and the rest defaults to 1 else Dim_X := Init_Val; @@ -1011,14 +1012,13 @@ package body Exp_Prag is Default_Val => Make_Null (Loc)); end Build_Stream_Declaration; - ------------------------ - -- Etype_Or_Dim3 -- - ------------------------ + ------------------- + -- Etype_Or_Dim3 -- + ------------------- function Etype_Or_Dim3 (N : Node_Id) return Node_Id is begin - if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) - then + if Nkind (N) = N_Aggregate and then Is_Composite_Type (Etype (N)) then return New_Occurrence_Of (RTE (RE_Dim3), Sloc (N)); end if; @@ -1036,7 +1036,7 @@ package body Exp_Prag is Argument : Entity_Id := First_Entity (Subprogram); begin for J in 2 .. N loop - Argument := Next_Entity (Argument); + Next_Entity (Argument); end loop; return Etype (Argument); @@ -1098,8 +1098,7 @@ package body Exp_Prag is Object_Definition => Etype_Or_Dim3 (Block_Dimensions), Expression => Block_Dimensions); - -- List holding the entities of the copies of Procedure_Call's - -- arguments. + -- List holding the entities of the copies of Procedure_Call's arguments Kernel_Arg_Copies : constant Elist_Id := New_Elmt_List; @@ -1114,7 +1113,7 @@ package body Exp_Prag is Pop_Call : Node_Id; Push_Call : Node_Id; - -- Declaration of all temporaries required for CUDA API Calls. + -- Declaration of all temporaries required for CUDA API Calls Blk_Decls : constant List_Id := New_List; diff --git a/gcc/ada/gnat_cuda.adb b/gcc/ada/gnat_cuda.adb index 39a55e6..6670bb8 100644 --- a/gcc/ada/gnat_cuda.adb +++ b/gcc/ada/gnat_cuda.adb @@ -68,8 +68,8 @@ package body GNAT_CUDA is function Get_CUDA_Kernels (Pack_Id : Entity_Id) return Elist_Id; -- Returns an Elist of all procedures marked with pragma CUDA_Global that - -- are declared within package body Pack_Body. Returns No_Elist if - -- Pack_Id does not contain such procedures. + -- are declared within package body Pack_Body. Returns No_Elist if Pack_Id + -- does not contain such procedures. procedure Set_CUDA_Kernels (Pack_Id : Entity_Id; @@ -249,7 +249,7 @@ package body GNAT_CUDA is -- function. New_Stmt : Node_Id; - -- Temporary variable to hold the various newly-created nodes. + -- Temporary variable to hold the various newly-created nodes Kernel_Elmt : Elmt_Id; Kernel_Id : Entity_Id; @@ -266,8 +266,7 @@ package body GNAT_CUDA is while Present (Kernel_Elmt) loop Kernel_Id := Node (Kernel_Elmt); - New_Stmt := - Build_Kernel_Name_Declaration (Kernel_Id); + New_Stmt := Build_Kernel_Name_Declaration (Kernel_Id); Append (New_Stmt, Pack_Decls); Analyze (New_Stmt); @@ -366,7 +365,7 @@ package body GNAT_CUDA is Make_Aggregate (Loc, Expressions => New_List ( Make_Integer_Literal (Loc, UI_From_Int (16#466243b1#)), - Make_Integer_Literal (Loc, UI_From_Int (1)), + Make_Integer_Literal (Loc, Uint_1), Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Bin_Id, Loc), Attribute_Name => Name_Address), @@ -452,39 +451,39 @@ package body GNAT_CUDA is is Args : constant List_Id := New_List; begin - -- First argument: the handle of the fat binary. + -- First argument: the handle of the fat binary Append (New_Occurrence_Of (Bin, Loc), Args); - -- Second argument: the host address of the function that is - -- marked with CUDA_Global. + -- Second argument: the host address of the function that is marked + -- with CUDA_Global. Append_To (Args, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Kernel, Loc), Attribute_Name => Name_Address)); - -- Third argument, the name of the function on the host. + -- Third argument, the name of the function on the host Append (New_Occurrence_Of (Kernel_Name, Loc), Args); - -- Fourth argument, the name of the function on the device. + -- Fourth argument, the name of the function on the device Append (New_Occurrence_Of (Kernel_Name, Loc), Args); -- Fith argument: -1. Meaning unknown - this has been copied from -- LLVM. - Append (Make_Integer_Literal (Loc, UI_From_Int (-1)), Args); + Append (Make_Integer_Literal (Loc, Uint_Minus_1), Args); - -- Args 6, 7, 8, 9, 10: Null pointers. Again, meaning unknown. + -- Args 6, 7, 8, 9, 10: Null pointers. Again, meaning unknown - for Arg_Count in 1 .. 5 loop + for Arg_Count in 6 .. 10 loop Append_To (Args, New_Occurrence_Of (RTE (RE_Null_Address), Loc)); end loop; - -- Build the call to CUDARegisterFunction, passing the argument - -- list we just built. + -- Build the call to CUDARegisterFunction, passing the argument list + -- we just built. return Make_Procedure_Call_Statement (Loc, @@ -498,21 +497,21 @@ package body GNAT_CUDA is Loc : constant Source_Ptr := Sloc (N); Spec_Id : constant Node_Id := Corresponding_Spec (N); - -- The specification of the package we're adding a cuda init func to. + -- The specification of the package we're adding a cuda init func to Pack_Decls : constant List_Id := Declarations (N); CUDA_Node_List : constant Elist_Id := Get_CUDA_Kernels (Spec_Id); - -- CUDA nodes that belong to the package. + -- CUDA nodes that belong to the package CUDA_Init_Func : Entity_Id; - -- Entity of the cuda init func. + -- Entity of the cuda init func Fat_Binary : Entity_Id; - -- Entity of the fat binary of N. Bound to said fat binary by a pragma. + -- Entity of the fat binary of N. Bound to said fat binary by a pragma Fat_Binary_Handle : Entity_Id; - -- Entity of the result of passing the fat binary wrapper to. + -- Entity of the result of passing the fat binary wrapper to -- CUDA.Register_Fat_Binary. Fat_Binary_Wrapper : Entity_Id; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a1d645e..7647b6d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14725,6 +14725,8 @@ package body Sem_Prag is end if; if Nkind (N) = N_Aggregate + and then not Null_Record_Present (N) + and then No (Component_Associations (N)) and then List_Length (Expressions (N)) = 3 then Expr := First (Expressions (N)); @@ -14746,7 +14748,7 @@ package body Sem_Prag is Shared_Memory : Node_Id; Stream : Node_Id; - -- Start of processing for CUDA_Execute + -- Start of processing for CUDA_Execute begin GNAT_Pragma; @@ -14755,7 +14757,7 @@ package body Sem_Prag is Analyze_And_Resolve (Kernel_Call); if Nkind (Kernel_Call) /= N_Function_Call - or else Etype (Kernel_Call) /= Standard_Void_Type + or else Etype (Kernel_Call) /= Standard_Void_Type then -- In `pragma CUDA_Execute (Kernel_Call (...), ...)`, -- GNAT sees Kernel_Call as an N_Function_Call since @@ -14796,7 +14798,7 @@ package body Sem_Prag is -- CUDA_Global -- ----------------- - -- pragma CUDA_Global (IDENTIFIER); + -- pragma CUDA_Global ([Entity =>] IDENTIFIER); when Pragma_CUDA_Global => CUDA_Global : declare Arg_Node : Node_Id; @@ -14804,8 +14806,7 @@ package body Sem_Prag is Pack_Id : Entity_Id; begin GNAT_Pragma; - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (1); + Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Entity); Check_Arg_Is_Local_Name (Arg1); -- cgit v1.1 From 6537318f79694a218b1d4816fbe86dc59694abe5 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 22 Dec 2020 19:46:37 -0500 Subject: [Ada] Crash on aggregate in function call in object declaration gcc/ada/ * exp_aggr.adb (Expand_Array_Aggregate): If the parent node of the aggregate is a subprogram call there is no target in which to build the aggregate, and it has to be expanded into component assignments. --- gcc/ada/exp_aggr.adb | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c719b02..fb5b302 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5700,7 +5700,7 @@ package body Exp_Aggr is function Safe_Left_Hand_Side (N : Node_Id) return Boolean; -- In addition to Maybe_In_Place_OK, in order for an aggregate to be -- built directly into the target of the assignment it must be free - -- of side effects. + -- of side effects. N is the LHS of an assignment. ---------------------------- -- Build_Constrained_Type -- @@ -6661,9 +6661,13 @@ package body Exp_Aggr is Set_Expansion_Delayed (N); return; - -- In the remaining cases the aggregate is the RHS of an assignment + -- In the remaining cases the aggregate appears in the RHS of an + -- assignment, which may be part of the expansion of an object + -- delaration. If the aggregate is an actual in a call, itself + -- possibly in a RHS, building it in the target is not possible. elsif Maybe_In_Place_OK + and then Nkind (Parent_Node) not in N_Subprogram_Call and then Safe_Left_Hand_Side (Name (Parent_Node)) then Tmp := Name (Parent_Node); -- cgit v1.1 From 5b48ea9dacdae9edae491d72b5db8864109a48a1 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Tue, 22 Dec 2020 09:58:43 -0500 Subject: [Ada] Spurious accessibility error on call in return statement gcc/ada/ * sem_util.adb (In_Return_Value): Modified to detect when implicit dereference is specified on the return type of a function call within the expression being checked. --- gcc/ada/sem_util.adb | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c4fe191..7b24a40 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14329,6 +14329,17 @@ package body Sem_Util is when N_Function_Call => if not In_Function_Call then In_Function_Call := True; + + -- When the function return type has implicit dereference + -- specified we know it cannot directly contribute to the + -- return value. + + if Present (Etype (Par)) + and then Has_Implicit_Dereference + (Get_Full_View (Etype (Par))) + then + return False; + end if; else return False; end if; -- cgit v1.1 From 3ffe57d4b11ca8daab277d94c86db2b95feafa9d Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Wed, 23 Dec 2020 13:06:22 -0500 Subject: [Ada] Expansion in _postconditions confusing CodePeer gcc/ada/ * contracts.adb (Build_Postconditions_Procedure): Remove internally generated if statement used to control finalization actions. * exp_ch6.adb (Add_Return, Expand_Non_Function_Return, Expand_Simple_Function_Return): Add if statement around _postconditions to control finalization. * exp_ch7.adb (Build_Finalizer): Likewise. * sem_prag.adb (Find_Related_Declaration_Or_Body): Add case to handle Context itself being a handled sequence of statements. --- gcc/ada/contracts.adb | 28 +++++++++-------------- gcc/ada/exp_ch6.adb | 62 +++++++++++++++++++++++++++++++++++++++------------ gcc/ada/exp_ch7.adb | 17 ++++++++++---- gcc/ada/sem_prag.adb | 9 ++++++-- 4 files changed, 78 insertions(+), 38 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 29557ec..f42a950 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -2367,6 +2367,10 @@ package body Contracts is -- postconditions until finalization has been performed when cleanup -- actions are present. + -- NOTE: This flag could be made into a predicate since we should be + -- able at compile time to recognize when finalization and cleanup + -- actions occur, but in practice this is not possible ??? + -- Generate: -- -- Postcond_Enabled : Boolean := True; @@ -2405,16 +2409,16 @@ package body Contracts is -- the postconditions: this would cause confusing debug info to be -- produced, interfering with coverage-analysis tools. - -- Also, wrap the postcondition checks in a conditional which can be - -- used to delay their evaluation when clean-up actions are present. + -- NOTE: Coverage-analysis and static-analysis tools rely on the + -- postconditions procedure being free of internally generated code + -- since some of these tools, like CodePeer, treat _postconditions + -- as original source. -- Generate: -- -- procedure _postconditions is -- begin - -- if Postcond_Enabled and then Return_Success_For_Postcond then - -- [Stmts]; - -- end if; + -- [Stmts]; -- end; Proc_Bod := @@ -2425,19 +2429,7 @@ package body Contracts is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, End_Label => Make_Identifier (Loc, Chars (Proc_Id)), - Statements => New_List ( - Make_If_Statement (Loc, - Condition => - Make_And_Then (Loc, - Left_Opnd => - New_Occurrence_Of - (Defining_Identifier - (Postcond_Enabled_Decl), Loc), - Right_Opnd => - New_Occurrence_Of - (Defining_Identifier - (Return_Success_Decl), Loc)), - Then_Statements => Stmts)))); + Statements => Stmts)); Insert_After_And_Analyze (Last_Decl, Proc_Bod); end Build_Postconditions_Procedure; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 6b14656..cc6c177 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6246,7 +6246,8 @@ package body Exp_Ch6 is -- has contract assertions that need to be verified on exit. -- Also, mark the successful return to signal that postconditions - -- need to be evaluated when finalization occurs. + -- need to be evaluated when finalization occurs by setting + -- Return_Success_For_Postcond to be True. if Ekind (Spec_Id) = E_Procedure and then Present (Postconditions_Proc (Spec_Id)) @@ -6254,19 +6255,30 @@ package body Exp_Ch6 is -- Generate: -- -- Return_Success_For_Postcond := True; - -- _postconditions; + -- if Postcond_Enabled then + -- _postconditions; + -- end if; Insert_Action (Stmt, Make_Assignment_Statement (Loc, Name => New_Occurrence_Of - (Get_Return_Success_For_Postcond (Spec_Id), Loc), + (Get_Return_Success_For_Postcond (Spec_Id), Loc), Expression => New_Occurrence_Of (Standard_True, Loc))); + -- Wrap the call to _postconditions within a test of the + -- Postcond_Enabled flag to delay postcondition evaluation + -- until after finalization when required. + Insert_Action (Stmt, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Postconditions_Proc (Spec_Id), Loc))); + Make_If_Statement (Loc, + Condition => + New_Occurrence_Of (Get_Postcond_Enabled (Spec_Id), Loc), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Postconditions_Proc (Spec_Id), Loc))))); end if; -- Ada 2020 (AI12-0279): append the call to 'Yield unless this is @@ -6699,7 +6711,9 @@ package body Exp_Ch6 is -- Generate: -- -- Return_Success_For_Postcond := True; - -- _postconditions; + -- if Postcond_Enabled then + -- _postconditions; + -- end if; Insert_Action (N, Make_Assignment_Statement (Loc, @@ -6708,9 +6722,19 @@ package body Exp_Ch6 is (Get_Return_Success_For_Postcond (Scope_Id), Loc), Expression => New_Occurrence_Of (Standard_True, Loc))); + -- Wrap the call to _postconditions within a test of the + -- Postcond_Enabled flag to delay postcondition evaluation until + -- after finalization when required. + Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc))); + Make_If_Statement (Loc, + Condition => + New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Postconditions_Proc (Scope_Id), Loc))))); end if; -- Ada 2020 (AI12-0279) @@ -7621,6 +7645,9 @@ package body Exp_Ch6 is -- Generate: -- -- Return_Success_For_Postcond := True; + -- if Postcond_Enabled then + -- _Postconditions ([exp]); + -- end if; Insert_Action (Exp, Make_Assignment_Statement (Loc, @@ -7629,13 +7656,20 @@ package body Exp_Ch6 is (Get_Return_Success_For_Postcond (Scope_Id), Loc), Expression => New_Occurrence_Of (Standard_True, Loc))); - -- Generate call to _Postconditions + -- Wrap the call to _postconditions within a test of the + -- Postcond_Enabled flag to delay postcondition evaluation until + -- after finalization when required. Insert_Action (Exp, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Postconditions_Proc (Scope_Id), Loc), - Parameter_Associations => New_List (New_Copy_Tree (Exp)))); + Make_If_Statement (Loc, + Condition => + New_Occurrence_Of (Get_Postcond_Enabled (Scope_Id), Loc), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (Postconditions_Proc (Scope_Id), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Exp)))))); end if; -- Ada 2005 (AI-251): If this return statement corresponds with an diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0315458..7b2676d 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3795,7 +3795,9 @@ package body Exp_Ch7 is -- -- Perform postcondition checks after general finalization, but -- -- before finalization of 'Old related objects. -- - -- if not Raised_Finalization_Exception then + -- if not Raised_Finalization_Exception + -- and then Return_Success_For_Postcond + -- then -- begin -- -- Re-enable postconditions and check them -- @@ -3973,7 +3975,9 @@ package body Exp_Ch7 is -- Generate: -- - -- if not Raised_Finalization_Exception then + -- if not Raised_Finalization_Exception + -- and then Return_Success_For_Postcond + -- then -- begin -- Postcond_Enabled := True; -- _postconditions [(Result_Obj_For_Postcond[.all])]; @@ -3988,10 +3992,15 @@ package body Exp_Ch7 is Append_To (Fin_Controller_Stmts, Make_If_Statement (Loc, Condition => - Make_Op_Not (Loc, + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Not (Loc, + Right_Opnd => + New_Occurrence_Of + (Raised_Finalization_Exception_Id, Loc)), Right_Opnd => New_Occurrence_Of - (Raised_Finalization_Exception_Id, Loc)), + (Get_Return_Success_For_Postcond (Def_Ent), Loc)), Then_Statements => New_List ( Make_Block_Statement (Loc, Handled_Statement_Sequence => diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 7647b6d..6e209d4 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -30689,14 +30689,19 @@ package body Sem_Prag is elsif Nkind (Context) = N_Entry_Body then return Context; - -- The pragma appears inside the statements of a subprogram body. This - -- placement is the result of subprogram contract expansion. + -- The pragma appears inside the statements of a subprogram body at + -- some nested level. elsif Is_Statement (Context) and then Present (Enclosing_HSS (Context)) then return Parent (Enclosing_HSS (Context)); + -- The pragma appears directly in the statements of a subprogram body + + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then + return Parent (Context); + -- The pragma appears inside the declarative part of a package body elsif Nkind (Context) = N_Package_Body then -- cgit v1.1 From 3fcdd5264de355acf01d30b7af6edd614080f1d3 Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Wed, 23 Dec 2020 20:21:13 -0500 Subject: [Ada] Spurious warning about premature use of selected component gcc/ada/ * sem_warn.adb (Check_References): Do not emit warning on a selected component when enclosing type has no discriminant and type of component has partial initialization. --- gcc/ada/sem_warn.adb | 11 +++++++++++ 1 file changed, 11 insertions(+) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index b5275a8..0be6b39 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1523,6 +1523,17 @@ package body Sem_Warn is -- uninitialized component to get a better message. elsif Nkind (Parent (UR)) = N_Selected_Component then + -- Suppress possibly superfluous warning if component + -- is known to exist and is partially initialized. + + if not Has_Discriminants (Etype (E1)) + and then + Is_Partially_Initialized_Type + (Etype (Parent (UR)), False) + then + goto Continue; + end if; + Error_Msg_Node_2 := Selector_Name (Parent (UR)); if not Comes_From_Source (Parent (UR)) then -- cgit v1.1 From c695d23dde02fbc5c748c7182d223813a4bcab4d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 23 Dec 2020 10:40:30 +0100 Subject: [Ada] Remove confusing warning on type export gcc/ada/ * sem_prag.adb (Set_Exported): Do not warn on exporting a type. --- gcc/ada/sem_prag.adb | 4 ---- 1 file changed, 4 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 6e209d4..5192843 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -10934,10 +10934,6 @@ package body Sem_Prag is end if; end if; - if Warn_On_Export_Import and then Is_Type (E) then - Error_Msg_NE ("exporting a type has no effect?x?", Arg, E); - end if; - if Warn_On_Export_Import and Inside_A_Generic then Error_Msg_NE ("all instances of& will have the same external name?x?", -- cgit v1.1 From 0bfa2f3cc26612e9b814184bda45a13d98634ea0 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Wed, 23 Dec 2020 18:51:43 +0100 Subject: [Ada] Remove leading and trailing spaces in error messages gcc/ada/ * exp_disp.adb, sem_aggr.adb, sem_cat.adb, sem_ch10.adb, sem_ch12.adb, sem_ch3.adb, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch8.adb, sem_ch9.adb, sem_prag.adb, sem_res.adb: Remove extra leading and trailing space in error messages. --- gcc/ada/exp_disp.adb | 2 +- gcc/ada/sem_aggr.adb | 2 +- gcc/ada/sem_cat.adb | 2 +- gcc/ada/sem_ch10.adb | 2 +- gcc/ada/sem_ch12.adb | 2 +- gcc/ada/sem_ch3.adb | 14 +++++++------- gcc/ada/sem_ch4.adb | 2 +- gcc/ada/sem_ch5.adb | 4 ++-- gcc/ada/sem_ch6.adb | 10 +++++----- gcc/ada/sem_ch8.adb | 4 ++-- gcc/ada/sem_ch9.adb | 6 +++--- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 2 +- 13 files changed, 27 insertions(+), 27 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 14f25db..991e4d3 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4011,7 +4011,7 @@ package body Exp_Disp is Error_Msg_NE ("\which is a component of untagged type& in the profile " & "of primitive & of type % that is frozen by the " - & "declaration ", N, Typ); + & "declaration", N, Typ); end if; end if; end Check_Premature_Freezing; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index b94f369..5fa1051 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -4743,7 +4743,7 @@ package body Sem_Aggr is then Error_Msg_NE ("aggregate not available for type& whose ancestor " - & "has unknown discriminants ", N, Typ); + & "has unknown discriminants", N, Typ); end if; if Has_Unknown_Discriminants (Typ) diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 242f1d2..ea02ecd 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -275,7 +275,7 @@ package body Sem_Cat is and then Is_Preelaborated (Depended_Entity) then Error_Msg_NE - ("<