diff options
Diffstat (limited to 'gcc/ada/sem_ch13.adb')
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 181 |
1 files changed, 82 insertions, 99 deletions
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index f7be890..a4c97cd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -442,11 +442,6 @@ package body Sem_Ch13 is Off : Boolean; -- Whether the address is offset within Y in the second case - - Alignment_Checks_Suppressed : Boolean; - -- Whether alignment checks are suppressed by an active scope suppress - -- setting. We need to save the value in order to be able to reuse it - -- after the back end has been run. end record; package Address_Clause_Checks is new Table.Table ( @@ -457,26 +452,6 @@ package body Sem_Ch13 is Table_Increment => 200, Table_Name => "Address_Clause_Checks"); - function Alignment_Checks_Suppressed - (ACCR : Address_Clause_Check_Record) return Boolean; - -- Return whether the alignment check generated for the address clause - -- is suppressed. - - --------------------------------- - -- Alignment_Checks_Suppressed -- - --------------------------------- - - function Alignment_Checks_Suppressed - (ACCR : Address_Clause_Check_Record) return Boolean - is - begin - if Checks_May_Be_Suppressed (ACCR.X) then - return Is_Check_Suppressed (ACCR.X, Alignment_Check); - else - return ACCR.Alignment_Checks_Suppressed; - end if; - end Alignment_Checks_Suppressed; - ----------------------------------------- -- Adjust_Record_For_Reverse_Bit_Order -- ----------------------------------------- @@ -2192,12 +2167,10 @@ package body Sem_Ch13 is Pragma_Name : Name_Id) return Node_Id; -- This is a wrapper for Make_Pragma used for converting aspects -- to pragmas. It takes care of Sloc (set from Loc) and building - -- the pragma identifier from the given name. In addition the flag - -- Class_Present is set from the aspect node, as well as - -- Is_Ignored. This routine also sets the - -- From_Aspect_Specification in the resulting pragma node to True, - -- and sets Corresponding_Aspect to point to the aspect. The - -- resulting pragma is assigned to Aitem. + -- the pragma identifier from the given name. In addition + -- Class_Present and Is_Ignored are set from the aspect node. + -- This routine also sets From_Aspect_Specification to True, + -- and sets Corresponding_Aspect to point to the aspect. ------------------------------- -- Analyze_Aspect_Convention -- @@ -4839,12 +4812,10 @@ package body Sem_Ch13 is when Aspect_Annotate | Aspect_GNAT_Annotate => declare - Args : List_Id; - Pargs : List_Id; - Arg : Node_Id; - + Pargs : constant List_Id := New_List; -- pragma args begin - -- The argument can be a single identifier + -- The argument can be a single identifier; add it to + -- Pargs. if Nkind (Expr) = N_Identifier then @@ -4856,11 +4827,12 @@ package body Sem_Ch13 is Set_Paren_Count (Expr, 0); - -- Add the single item to the list - - Args := New_List (Expr); + Append_To (Pargs, + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))); - -- Otherwise we must have an aggregate + -- Otherwise we must have an aggregate; add all + -- expressions to Pargs. elsif Nkind (Expr) = N_Aggregate then @@ -4879,9 +4851,16 @@ package body Sem_Ch13 is ("redundant parentheses", Expr); end if; - -- List of arguments is list of aggregate expressions - - Args := Expressions (Expr); + declare + Arg : Node_Id := First (Expressions (Expr)); + begin + while Present (Arg) loop + Append_To (Pargs, + Make_Pragma_Argument_Association (Sloc (Arg), + Expression => Relocate_Node (Arg))); + Next (Arg); + end loop; + end; -- Anything else is illegal @@ -4890,17 +4869,6 @@ package body Sem_Ch13 is goto Continue; end if; - -- Prepare pragma arguments - - Pargs := New_List; - Arg := First (Args); - while Present (Arg) loop - Append_To (Pargs, - Make_Pragma_Argument_Association (Sloc (Arg), - Expression => Relocate_Node (Arg))); - Next (Arg); - end loop; - Append_To (Pargs, Make_Pragma_Argument_Association (Sloc (Ent), Chars => Name_Entity, @@ -5041,16 +5009,6 @@ package body Sem_Ch13 is Analyze_Aspect_Implicit_Dereference; goto Continue; - when Aspect_Constructor => - if not All_Extensions_Allowed then - Error_Msg_Name_1 := Nam; - Error_Msg_GNAT_Extension ("aspect %", Loc); - goto Continue; - end if; - - Set_Constructor_Name (E, Expr); - Set_Needs_Construction (E); - -- Dimension when Aspect_Dimension => @@ -7096,11 +7054,15 @@ package body Sem_Ch13 is end if; end; - -- Entity has delayed freeze, so we will generate an + -- The entity has delayed freeze, so we will generate an -- alignment check at the freeze point unless suppressed. + -- We will unconditionally generate it when the alignment + -- is specified in addition to the address, to compensate + -- for the check being suppressed by default on machines + -- that do not need strict alignment of memory accesses. - if not Range_Checks_Suppressed (U_Ent) - and then not Alignment_Checks_Suppressed (U_Ent) + if not Alignment_Checks_Suppressed (U_Ent) + or else Present (Alignment_Clause (U_Ent)) then Set_Check_Address_Alignment (N); end if; @@ -7139,7 +7101,7 @@ package body Sem_Ch13 is Set_Has_Alignment_Clause (U_Ent); -- Tagged type case, check for attempt to set alignment to a - -- value greater than Max_Align, and reset if so. + -- value greater than Maximum_Alignment, and reset if so. if Is_Tagged_Type (U_Ent) and then Align > Max_Align then Error_Msg_N @@ -7175,6 +7137,14 @@ package body Sem_Ch13 is if Is_Array_Type (U_Ent) then Set_Alignment (Base_Type (U_Ent), Align); end if; + + -- See the Attribute_Address case above for the rationale + + if not Is_Type (U_Ent) + and then Present (Address_Clause (U_Ent)) + then + Set_Check_Address_Alignment (Address_Clause (U_Ent)); + end if; end if; end Alignment; @@ -7844,7 +7814,7 @@ package body Sem_Ch13 is end if; end if; - -- For Object'Size, set Esize only + -- For objects, set Esize only else if Is_Elementary_Type (Etyp) @@ -7858,26 +7828,37 @@ package body Sem_Ch13 is Error_Msg_Uint_2 := UI_From_Int (System_Max_Integer_Size); Error_Msg_N - ("size for primitive object must be a power of 2 in " - & "the range ^-^", N); - end if; + ("size for elementary object must be a power of 2 " + & "in the range ^-^", N); - Set_Esize (U_Ent, Size); - end if; + -- As per RM 13.1(25/5), only a confirming size clause + -- (i.e. Size = Type'Object_Size) for aliased objects + -- of elementary types is required to be supported. + -- We reject nonconfirming clauses for these objects. - -- As of RM 13.1, only confirming size - -- (i.e. (Size = Esize (Etyp))) for aliased object of - -- elementary type must be supported. - -- GNAT rejects nonconfirming size for such object. + elsif Is_Aliased (U_Ent) + and then Is_Elementary_Type (Etyp) + and then Size /= Esize (Etyp) + then + Error_Msg_N + ("nonconfirming Size for aliased object is not " + & "supported", N); - if Is_Aliased (U_Ent) - and then Is_Elementary_Type (Etyp) - and then Known_Esize (U_Ent) - and then Size /= Esize (Etyp) - then - Error_Msg_N - ("nonconfirming Size for aliased object is not " - & "supported", N); + -- We also reject nonconfirming clauses for (nonaliased) + -- objects of floating-point types because smaller sizes + -- would require integer operations to access the objects + -- and larger sizes would require integer operations to + -- manipulate the padding bits. + + elsif Is_Floating_Point_Type (Etyp) + and then Size /= Esize (Etyp) + then + Error_Msg_N + ("nonconfirming Size for floating-point object is " + & "not supported", N); + end if; + + Set_Esize (U_Ent, Size); end if; -- Handle extension aspect 'Size'Class which allows for @@ -8501,7 +8482,15 @@ package body Sem_Ch13 is if Etype (Expression (N)) = Any_Type then return; elsif not Is_RTE (Etype (Expression (N)), RE_Asm_Insn) then - Error_Msg_N ("incorrect type for code statement", N); + + -- Only emit an error message when not running in Relaxed RM + -- Semantics. This enables GNATSAS' GNAT Warnings engine to work on + -- VADS codebases. + + if not (Check_Semantics_Only_Mode and then Relaxed_RM_Semantics) then + Error_Msg_N ("incorrect type for code statement", N); + end if; + return; end if; @@ -11753,8 +11742,7 @@ package body Sem_Ch13 is -- name, so we need to verify that one of these interpretations is -- the one available at the freeze point. - elsif A_Id in Aspect_Constructor - | Aspect_Destructor + elsif A_Id in Aspect_Destructor | Aspect_Input | Aspect_Output | Aspect_Read @@ -12050,8 +12038,7 @@ package body Sem_Ch13 is -- Special case, the expression of these aspects is just an entity -- that does not need any resolution, so just analyze. - when Aspect_Constructor - | Aspect_Input + when Aspect_Input | Aspect_Output | Aspect_Put_Image | Aspect_Read @@ -16670,9 +16657,8 @@ package body Sem_Ch13 is Y : Entity_Id; Off : Boolean) is - ACS : constant Boolean := Scope_Suppress.Suppress (Alignment_Check); begin - Address_Clause_Checks.Append ((N, X, A, Y, Off, ACS)); + Address_Clause_Checks.Append ((N, X, A, Y, Off)); end Register_Address_Clause_Check; ------------------------ @@ -17357,9 +17343,6 @@ package body Sem_Ch13 is => null; - when Aspect_Constructor => - null; - when Aspect_Dynamic_Predicate | Aspect_Ghost_Predicate | Aspect_Predicate @@ -18183,7 +18166,7 @@ package body Sem_Ch13 is elsif Ekind (E) = E_Function then return No (First_Formal (E)) or else - (Is_Signed_Integer_Type (Etype (First_Formal (E))) + (Has_Overflow_Operations (Etype (First_Formal (E))) and then No (Next_Formal (First_Formal (E)))); else return False; @@ -19125,7 +19108,7 @@ package body Sem_Ch13 is -- Check for known value not multiple of alignment if No (ACCR.Y) then - if not Alignment_Checks_Suppressed (ACCR) + if Check_Address_Alignment (ACCR.N) and then X_Alignment /= 0 and then ACCR.A mod X_Alignment /= 0 then @@ -19170,7 +19153,7 @@ package body Sem_Ch13 is -- Note: we do not check the alignment if we gave a size -- warning, since it would likely be redundant. - elsif not Alignment_Checks_Suppressed (ACCR) + elsif Check_Address_Alignment (ACCR.N) and then Y_Alignment /= Uint_0 and then (Y_Alignment < X_Alignment |