mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-03 08:50:31 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2017-01-23  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb,
	sem_ch3.adb, sem_ch5.adb, sem_ch5.ads, sem_util.adb, sinfo.ads: Minor
	reformatting.
	* exp_ch9.adb: minor style fix in comment.

2017-01-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch4.adb (Analyze_Allocator): Handle properly a type derived
	for a limited record extension with unknown discriminants whose
	full view has no discriminants.

2017-01-23  Yannick Moy  <moy@adacore.com>

	* exp_spark.adb: Alphabetize with clauses.

From-SVN: r244788
This commit is contained in:
Arnaud Charlet 2017-01-23 12:54:05 +01:00
parent 0f83b0444c
commit d43584ca12
14 changed files with 254 additions and 194 deletions

17
gcc/ada/ChangeLog

@ -1,3 +1,20 @@
2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb,
sem_ch3.adb, sem_ch5.adb, sem_ch5.ads, sem_util.adb, sinfo.ads: Minor
reformatting.
* exp_ch9.adb: minor style fix in comment.
2017-01-23 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Allocator): Handle properly a type derived
for a limited record extension with unknown discriminants whose
full view has no discriminants.
2017-01-23 Yannick Moy <moy@adacore.com>
* exp_spark.adb: Alphabetize with clauses.
2017-01-23 Yannick Moy <moy@adacore.com>
* sem_util.adb (Has_Enabled_Property): Treat

177
gcc/ada/exp_ch5.adb

@ -75,15 +75,15 @@ package body Exp_Ch5 is
-- of formal container iterators.
function Change_Of_Representation (N : Node_Id) return Boolean;
-- Determine if the right hand side of assignment N is a type conversion
-- Determine if the right-hand side of assignment N is a type conversion
-- which requires a change of representation. Called only for the array
-- and record cases.
procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id);
-- N is an assignment which assigns an array value. This routine process
-- the various special cases and checks required for such assignments,
-- including change of representation. Rhs is normally simply the right
-- hand side of the assignment, except that if the right hand side is a
-- including change of representation. Rhs is normally simply the right-
-- hand side of the assignment, except that if the right-hand side is a
-- type conversion or a qualified expression, then the RHS is the actual
-- expression inside any such type conversions or qualifications.
@ -98,14 +98,14 @@ package body Exp_Ch5 is
-- N is an assignment statement which assigns an array value. This routine
-- expands the assignment into a loop (or nested loops for the case of a
-- multi-dimensional array) to do the assignment component by component.
-- Larray and Rarray are the entities of the actual arrays on the left
-- hand and right hand sides. L_Type and R_Type are the types of these
-- arrays (which may not be the same, due to either sliding, or to a
-- change of representation case). Ndim is the number of dimensions and
-- the parameter Rev indicates if the loops run normally (Rev = False),
-- or reversed (Rev = True). The value returned is the constructed
-- loop statement. Auxiliary declarations are inserted before node N
-- using the standard Insert_Actions mechanism.
-- Larray and Rarray are the entities of the actual arrays on the left-hand
-- and right-hand sides. L_Type and R_Type are the types of these arrays
-- (which may not be the same, due to either sliding, or to a change of
-- representation case). Ndim is the number of dimensions and the parameter
-- Rev indicates if the loops run normally (Rev = False), or reversed
-- (Rev = True). The value returned is the constructed loop statement.
-- Auxiliary declarations are inserted before node N using the standard
-- Insert_Actions mechanism.
procedure Expand_Assign_Record (N : Node_Id);
-- N is an assignment of an untagged record value. This routine handles
@ -359,7 +359,7 @@ package body Exp_Ch5 is
begin
-- Deal with length check. Note that the length check is done with
-- respect to the right hand side as given, not a possible underlying
-- respect to the right-hand side as given, not a possible underlying
-- renamed object, since this would generate incorrect extra checks.
Apply_Length_Check (Rhs, L_Type);
@ -420,8 +420,8 @@ package body Exp_Ch5 is
end if;
-- We certainly must use a loop for change of representation and also
-- we use the operand of the conversion on the right hand side as the
-- effective right hand side (the component types must match in this
-- we use the operand of the conversion on the right-hand side as the
-- effective right-hand side (the component types must match in this
-- situation).
if Crep then
@ -717,7 +717,7 @@ package body Exp_Ch5 is
Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs));
Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs));
-- If both left and right hand arrays are entity names, and refer
-- If both left- and right-hand arrays are entity names, and refer
-- to different entities, then we know that the move is safe (the
-- two storage areas are completely disjoint).
@ -1004,7 +1004,7 @@ package body Exp_Ch5 is
then
-- Call TSS procedure for array assignment, passing the
-- explicit bounds of right and left hand sides.
-- explicit bounds of right- and left-hand sides.
declare
Proc : constant Entity_Id :=
@ -1080,7 +1080,7 @@ package body Exp_Ch5 is
-- end loop;
-- end;
-- Here Rev is False, and Tm1Xn are the subscript types for the right hand
-- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
-- side. The declarations of R2b and R4b are inserted before the original
-- assignment statement.
@ -1276,7 +1276,7 @@ package body Exp_Ch5 is
L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
begin
-- If change of representation, then extract the real right hand side
-- If change of representation, then extract the real right-hand side
-- from the type conversion, and proceed with component-wise assignment,
-- since the two types are not the same as far as the back end is
-- concerned.
@ -1340,7 +1340,7 @@ package body Exp_Ch5 is
-- Given C, the entity for a discriminant or component, build an
-- assignment for the corresponding field values. The flag U_U
-- signals the presence of an Unchecked_Union and forces the usage
-- of the inferred discriminant value of C as the right hand side
-- of the inferred discriminant value of C as the right-hand side
-- of the assignment.
function Make_Field_Assigns (CI : List_Id) return List_Id;
@ -1452,7 +1452,7 @@ package body Exp_Ch5 is
begin
-- In the case of an Unchecked_Union, use the discriminant
-- constraint value as on the right hand side of the assignment.
-- constraint value as on the right-hand side of the assignment.
if U_U then
Expr :=
@ -1617,14 +1617,15 @@ package body Exp_Ch5 is
-------------------------------------
procedure Expand_Assign_With_Target_Names (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
LHS : constant Node_Id := Name (N);
RHS : constant Node_Id := Expression (N);
LHS : constant Node_Id := Name (N);
LHS_Typ : constant Entity_Id := Etype (LHS);
Loc : constant Source_Ptr := Sloc (N);
RHS : constant Node_Id := Expression (N);
Ent : Entity_Id;
-- The entity of the left-hand side
New_RHS : Node_Id;
function Replace_Target (N : Node_Id) return Traverse_Result;
function Replace_Target (N : Node_Id) return Traverse_Result;
-- Replace occurrences of the target name by the proper entity: either
-- the entity of the LHS in simple cases, or the formal of the
-- constructed procedure otherwise.
@ -1633,7 +1634,7 @@ package body Exp_Ch5 is
-- Replace_Target --
--------------------
function Replace_Target (N : Node_Id) return Traverse_Result is
function Replace_Target (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) = N_Target_Name then
Rewrite (N, New_Occurrence_Of (Ent, Sloc (N)));
@ -1645,74 +1646,104 @@ package body Exp_Ch5 is
procedure Replace_Target_Name is new Traverse_Proc (Replace_Target);
begin
-- Local variables
New_RHS : Node_Id;
Proc_Id : Entity_Id;
-- Start of processing for Expand_Assign_With_Target_Names
begin
New_RHS := New_Copy_Tree (RHS);
-- The left-hand side is a direct name
if Is_Entity_Name (LHS)
and then not Is_Renaming_Of_Object (Entity (LHS))
and then not Is_Renaming_Of_Object (Entity (LHS))
then
Ent := Entity (LHS);
Replace_Target_Name (New_RHS);
-- Generate:
-- LHS := ... LHS ...;
Rewrite (N,
Make_Assignment_Statement (Loc,
Name => Relocate_Node (LHS),
Name => Relocate_Node (LHS),
Expression => New_RHS));
-- The left-hand side is not a direct name, but is side-effect free.
-- Capture its value in a temporary to avoid multiple evaluations.
elsif Side_Effect_Free (LHS) then
Ent := Make_Temporary (Loc, 'T');
Replace_Target_Name (New_RHS);
-- Generate:
-- T : LHS_Typ := LHS;
Insert_Before_And_Analyze (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => New_Occurrence_Of (Etype (LHS), Loc),
Object_Definition => New_Occurrence_Of (LHS_Typ, Loc),
Expression => New_Copy_Tree (LHS)));
Replace_Target_Name (New_RHS);
-- Generate:
-- LHS := ... T ...;
Rewrite (N,
Make_Assignment_Statement (Loc,
Name => Relocate_Node (LHS),
Name => Relocate_Node (LHS),
Expression => New_RHS));
-- Otherwise wrap the whole assignment statement in a procedure with an
-- IN OUT parameter. The original assignment then becomes a call to the
-- procedure with the left-hand side as an actual.
else
Ent := Make_Temporary (Loc, 'T');
Replace_Target_Name (New_RHS);
declare
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('P'));
Formals : constant List_Id := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Ent,
In_Present => True,
Out_Present => True,
Parameter_Type => New_Occurrence_Of (Etype (LHS), Loc)));
Spec : constant Node_Id :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => Formals);
Subp_Body : Node_Id;
Call : Node_Id;
begin
Replace_Target_Name (New_RHS);
-- Generate:
-- procedure P (T : in out LHS_Typ) is
-- begin
-- T := ... T ...;
-- end P;
Subp_Body :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Expression => New_RHS))));
Proc_Id := Make_Temporary (Loc, 'P');
Insert_Before_And_Analyze (N, Subp_Body);
Call := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => New_List (Relocate_Node (LHS)));
Rewrite (N, Call);
end;
Insert_Before_And_Analyze (N,
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc_Id,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Ent,
In_Present => True,
Out_Present => True,
Parameter_Type =>
New_Occurrence_Of (LHS_Typ, Loc)))),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Expression => New_RHS)))));
-- Generate:
-- P (LHS);
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (Relocate_Node (LHS))));
end if;
-- Analyze rewritten node, either as assignment or procedure call.
-- Analyze rewritten node, either as assignment or procedure call
Analyze (N);
end Expand_Assign_With_Target_Names;
@ -1762,9 +1793,7 @@ package body Exp_Ch5 is
-- Separate expansion if RHS contain target names. Note that assignment
-- may already have been expanded if RHS is aggregate.
if Nkind (N) = N_Assignment_Statement
and then Has_Target_Names (N)
then
if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then
Expand_Assign_With_Target_Names (N);
return;
end if;
@ -1922,7 +1951,7 @@ package body Exp_Ch5 is
-- where the reference was not expanded in the original tree,
-- since it was on the left side of an assignment. But in the
-- pre-assignment statement (the object definition), BPAR_Expr
-- will end up on the right hand side, and must be reexpanded. To
-- will end up on the right-hand side, and must be reexpanded. To
-- achieve this, we reset the analyzed flag of all selected and
-- indexed components down to the actual indexed component for
-- the packed array.
@ -2273,7 +2302,7 @@ package body Exp_Ch5 is
begin
-- In the controlled case, we ensure that function calls are
-- evaluated before finalizing the target. In all cases, it makes
-- the expansion easier if the side-effects are removed first.
-- the expansion easier if the side effects are removed first.
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
@ -2599,7 +2628,7 @@ package body Exp_Ch5 is
if Validity_Checks_On
and then Validity_Check_Copies
then
-- Skip this if left hand side is an array or record component
-- Skip this if left-hand side is an array or record component
-- and elementary component validity checks are suppressed.
if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component)
@ -4810,7 +4839,7 @@ package body Exp_Ch5 is
if not Ctrl_Act then
null;
-- The left hand side is an uninitialized temporary object
-- The left-hand side is an uninitialized temporary object
elsif Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L))

2
gcc/ada/exp_ch9.adb

@ -8727,7 +8727,7 @@ package body Exp_Ch9 is
function Static_Component_Size (Comp : Entity_Id) return Boolean;
-- When compiling under the Ravenscar profile, private components must
-- have a static size, or else a protected object will require heap
-- have a static size, or else a protected object will require heap
-- allocation, violating the corresponding restriction. It is preferable
-- to make this check here, because it provides a better error message
-- than the back-end, which refers to the object as a whole.

6
gcc/ada/exp_spark.adb

@ -33,14 +33,14 @@ with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Sem_Eval; use Sem_Eval;
with Stand; use Stand;
with Uintp; use Uintp;
package body Exp_SPARK is

6
gcc/ada/freeze.adb

@ -1332,8 +1332,6 @@ package body Freeze is
-------------------------------
procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is
Decl : Node_Id;
function Find_Constant (Nod : Node_Id) return Traverse_Result;
-- Function to search for deferred constant
@ -1376,6 +1374,10 @@ package body Freeze is
procedure Check_Deferred is new Traverse_Proc (Find_Constant);
-- Local variables
Decl : Node_Id;
-- Start of processing for Check_Expression_Function
begin

13
gcc/ada/par-ch4.adb

@ -232,6 +232,7 @@ package body Ch4 is
-- Loop through designators in qualified name
-- AI12-0125 : target_name
if Token = Tok_At_Sign then
Scan_Reserved_Identifier (Force_Msg => False);
end if;
@ -2331,15 +2332,15 @@ package body Ch4 is
-- Come here at end of simple expression, where we do a couple of
-- special checks to improve error recovery.
-- Special test to improve error recovery. If the current token
-- is a period, then someone is trying to do selection on something
-- that is not a name, e.g. a qualified expression.
-- Special test to improve error recovery. If the current token is a
-- period, then someone is trying to do selection on something that is
-- not a name, e.g. a qualified expression.
if Token = Tok_Dot then
Error_Msg_SC ("prefix for selection is not a name");
-- If qualified expression, comment and continue, otherwise
-- something is pretty nasty so do an Error_Resync call.
-- If qualified expression, comment and continue, otherwise something
-- is pretty nasty so do an Error_Resync call.
if Ada_Version < Ada_2012
and then Nkind (Node1) = N_Qualified_Expression
@ -2797,7 +2798,7 @@ package body Ch4 is
Error_Msg_SC ("parentheses required for unary minus");
Scan; -- past minus
when Tok_At_Sign => -- AI12-0125 : target_name
when Tok_At_Sign => -- AI12-0125 : target_name
if Ada_Version < Ada_2020 then
Error_Msg_SC ("target name is an Ada 2020 extension");
Error_Msg_SC ("\compile with -gnatX");

4
gcc/ada/scng.adb

@ -158,9 +158,9 @@ package body Scng is
| Tok_And
| Tok_Apostrophe
| Tok_Array
| Tok_At_Sign
| Tok_Asterisk
| Tok_At
| Tok_At_Sign
| Tok_Body
| Tok_Box
| Tok_Char_Literal
@ -1618,6 +1618,7 @@ package body Scng is
else
-- AI12-0125-03 : @ is target_name
Accumulate_Checksum ('@');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_At_Sign;
@ -2438,6 +2439,7 @@ package body Scng is
-- Invalid graphic characters
-- Note that '@' is handled elsewhere, because following AI12-125
-- it denotes the target_name of an assignment.
when '#' | '$' | '?' | '`' | '\' | '^' | '~' =>
-- If Set_Special_Character has been called for this character,

160
gcc/ada/sem_ch13.adb

@ -352,16 +352,16 @@ package body Sem_Ch13 is
-----------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
Comp : Node_Id;
CC : Node_Id;
Max_Machine_Scalar_Size : constant Uint :=
UI_From_Int
(Standard_Long_Long_Integer_Size);
-- We use this as the maximum machine scalar size
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
CC : Node_Id;
Comp : Node_Id;
Num_CC : Natural;
SSU : constant Uint := UI_From_Int (System_Storage_Unit);
begin
-- Processing here used to depend on Ada version: the behavior was
@ -380,12 +380,12 @@ package body Sem_Ch13 is
-- same byte offset and processing them together. Same approach is still
-- valid in later versions including Ada 2012.
-- This first loop through components does two things. First it
-- deals with the case of components with component clauses whose
-- length is greater than the maximum machine scalar size (either
-- accepting them or rejecting as needed). Second, it counts the
-- number of components with component clauses whose length does
-- not exceed this maximum for later processing.
-- This first loop through components does two things. First it deals
-- with the case of components with component clauses whose length is
-- greater than the maximum machine scalar size (either accepting them
-- or rejecting as needed). Second, it counts the number of components
-- with component clauses whose length does not exceed this maximum for
-- later processing.
Num_CC := 0;
Comp := First_Component_Or_Discriminant (R);
@ -402,8 +402,8 @@ package body Sem_Ch13 is
if Lbit >= Max_Machine_Scalar_Size then
-- This is allowed only if first bit is zero, and
-- last bit + 1 is a multiple of storage unit size.
-- This is allowed only if first bit is zero, and last bit
-- + 1 is a multiple of storage unit size.
if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
@ -435,28 +435,25 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := Lbit + 1;
Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
Error_Msg_F
("\last bit + 1 (^) exceeds maximum machine "
& "scalar size (^)",
First_Bit (CC));
("\last bit + 1 (^) exceeds maximum machine scalar "
& "size (^)", First_Bit (CC));
if (Lbit + 1) mod SSU /= 0 then
Error_Msg_Uint_1 := SSU;
Error_Msg_F
("\and is not a multiple of Storage_Unit (^) "
& "(RM 13.5.1(10))",
First_Bit (CC));
& "(RM 13.5.1(10))", First_Bit (CC));
else
Error_Msg_Uint_1 := Fbit;
Error_Msg_F
("\and first bit (^) is non-zero "
& "(RM 13.4.1(10))",
First_Bit (CC));
& "(RM 13.4.1(10))", First_Bit (CC));
end if;
end if;
-- OK case of machine scalar related component clause,
-- For now, just count them.
-- OK case of machine scalar related component clause. For now,
-- just count them.
else
Num_CC := Num_CC + 1;
@ -467,16 +464,14 @@ package body Sem_Ch13 is
Next_Component_Or_Discriminant (Comp);
end loop;
-- We need to sort the component clauses on the basis of the
-- Position values in the clause, so we can group clauses with
-- the same Position together to determine the relevant machine
-- scalar size.
-- We need to sort the component clauses on the basis of the Position
-- values in the clause, so we can group clauses with the same Position
-- together to determine the relevant machine scalar size.
Sort_CC : declare
Comps : array (0 .. Num_CC) of Entity_Id;
-- Array to collect component and discriminant entities. The
-- data starts at index 1, the 0'th entry is for the sort
-- routine.
-- Array to collect component and discriminant entities. The data
-- starts at index 1, the 0'th entry is for the sort routine.
function CP_Lt (Op1, Op2 : Natural) return Boolean;
-- Compare routine for Sort
@ -486,25 +481,26 @@ package body Sem_Ch13 is
package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
MaxL : Uint;
-- Maximum last bit value of any component in this set
MSS : Uint;
-- Corresponding machine scalar size
Start : Natural;
Stop : Natural;
-- Start and stop positions in the component list of the set of
-- components with the same starting position (that constitute
-- components in a single machine scalar).
MaxL : Uint;
-- Maximum last bit value of any component in this set
MSS : Uint;
-- Corresponding machine scalar size
-----------
-- CP_Lt --
-----------
function CP_Lt (Op1, Op2 : Natural) return Boolean is
begin
return Position (Component_Clause (Comps (Op1))) <
return
Position (Component_Clause (Comps (Op1))) <
Position (Component_Clause (Comps (Op2)));
end CP_Lt;
@ -529,12 +525,12 @@ package body Sem_Ch13 is
CC : constant Node_Id := Component_Clause (Comp);
begin
-- Collect only component clauses whose last bit is less
-- than machine scalar size. Any component clause whose
-- last bit exceeds this value does not take part in
-- machine scalar layout considerations. The test for
-- Error_Posted makes sure we exclude component clauses
-- for which we already posted an error.
-- Collect only component clauses whose last bit is less than
-- machine scalar size. Any component clause whose last bit
-- exceeds this value does not take part in machine scalar
-- layout considerations. The test for Error_Posted makes sure
-- we exclude component clauses for which we already posted an
-- error.
if Present (CC)
and then not Error_Posted (Last_Bit (CC))
@ -553,10 +549,10 @@ package body Sem_Ch13 is
Sorting.Sort (Num_CC);
-- We now have all the components whose size does not exceed
-- the max machine scalar value, sorted by starting position.
-- In this loop we gather groups of clauses starting at the
-- same position, to process them in accordance with AI-133.
-- We now have all the components whose size does not exceed the max
-- machine scalar value, sorted by starting position. In this loop we
-- gather groups of clauses starting at the same position, to process
-- them in accordance with AI-133.
Stop := 0;
while Stop < Num_CC loop
@ -583,14 +579,14 @@ package body Sem_Ch13 is
end if;
end loop;
-- Now we have a group of component clauses from Start to
-- Stop whose positions are identical, and MaxL is the
-- maximum last bit value of any of these components.
-- Now we have a group of component clauses from Start to Stop
-- whose positions are identical, and MaxL is the maximum last
-- bit value of any of these components.
-- We need to determine the corresponding machine scalar
-- size. This loop assumes that machine scalar sizes are
-- even, and that each possible machine scalar has twice
-- as many bits as the next smaller one.
-- We need to determine the corresponding machine scalar size.
-- This loop assumes that machine scalar sizes are even, and that
-- each possible machine scalar has twice as many bits as the next
-- smaller one.
MSS := Max_Machine_Scalar_Size;
while MSS mod 2 = 0
@ -600,10 +596,9 @@ package body Sem_Ch13 is
MSS := MSS / 2;
end loop;
-- Here is where we fix up the Component_Bit_Offset value
-- to account for the reverse bit order. Some examples of
-- what needs to be done for the case of a machine scalar
-- size of 8 are:
-- Here is where we fix up the Component_Bit_Offset value to
-- account for the reverse bit order. Some examples of what needs
-- to be done for the case of a machine scalar size of 8 are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
@ -617,8 +612,8 @@ package body Sem_Ch13 is
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
-- The rule is that the first bit is obtained by subtracting
-- the old ending bit from machine scalar size - 1.
-- The rule is that the first bit is obtained by subtracting the
-- old ending bit from machine scalar size - 1.
for C in Start .. Stop loop
declare
@ -634,19 +629,19 @@ package body Sem_Ch13 is
if Warn_On_Reverse_Bit_Order then
Error_Msg_Uint_1 := MSS;
Error_Msg_N
("info: reverse bit order in machine " &
"scalar of length^?V?", First_Bit (CC));
("info: reverse bit order in machine scalar of "
& "length^?V?", First_Bit (CC));
Error_Msg_Uint_1 := NFB;
Error_Msg_Uint_2 := NLB;
if Bytes_Big_Endian then
Error_Msg_NE
("\big-endian range for component "
& "& is ^ .. ^?V?", First_Bit (CC), Comp);
("\big-endian range for component & is ^ .. ^?V?",
First_Bit (CC), Comp);
else
Error_Msg_NE
("\little-endian range for component"
& "& is ^ .. ^?V?", First_Bit (CC), Comp);
("\little-endian range for component & is ^ .. ^?V?",
First_Bit (CC), Comp);
end if;
end if;
@ -663,8 +658,8 @@ package body Sem_Ch13 is
------------------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id) is
Comp : Node_Id;
CC : Node_Id;
Comp : Node_Id;
begin
-- For Ada 95, we just renumber bits within a storage unit. We do the
@ -707,8 +702,8 @@ package body Sem_Ch13 is
and then CSZ mod System_Storage_Unit = 0
then
Error_Msg_N
("info: multi-byte field specified with "
& "non-standard Bit_Order?V?", CLC);
("info: multi-byte field specified with non-standard "
& "Bit_Order?V?", CLC);
if Bytes_Big_Endian then
Error_Msg_N
@ -724,11 +719,11 @@ package body Sem_Ch13 is
else
Error_Msg_N
("attempt to specify non-contiguous field "
& "not permitted", CLC);
("attempt to specify non-contiguous field not "
& "permitted", CLC);
Error_Msg_N
("\caused by non-standard Bit_Order "
& "specified in legacy Ada 95 mode", CLC);
("\caused by non-standard Bit_Order specified in "
& "legacy Ada 95 mode", CLC);
end if;
-- Case where field fits in one storage unit
@ -740,14 +735,14 @@ package body Sem_Ch13 is
and then Warn_On_Reverse_Bit_Order
then
Error_Msg_N
("info: Bit_Order clause does not affect " &
"byte ordering?V?", Pos);
("info: Bit_Order clause does not affect byte "
& "ordering?V?", Pos);
Error_Msg_Uint_1 :=
Intval (Pos) + Intval (FB) /
System_Storage_Unit;
Error_Msg_N
("info: position normalized to ^ before bit " &
"order interpreted?V?", Pos);
("info: position normalized to ^ before bit order "
& "interpreted?V?", Pos);
end if;
-- Here is where we fix up the Component_Bit_Offset value
@ -769,16 +764,13 @@ package body Sem_Ch13 is
-- The rule is that the first bit is is obtained by
-- subtracting the old ending bit from storage_unit - 1.
Set_Component_Bit_Offset
(Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
Set_Component_Bit_Offset (Comp,
(Storage_Unit_Offset * System_Storage_Unit) +
(System_Storage_Unit - 1) -
(Start_Bit + CSZ - 1));
Set_Normalized_First_Bit
(Comp,
Component_Bit_Offset (Comp) mod
System_Storage_Unit);
Set_Normalized_First_Bit (Comp,
Component_Bit_Offset (Comp) mod System_Storage_Unit);
end if;
end;
end if;

11
gcc/ada/sem_ch3.adb

@ -2634,12 +2634,11 @@ package body Sem_Ch3 is
elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
-- Check for an edge case that may cause premature freezing of a
-- private type.
-- If there is an type which depends on a private type from an
-- enclosing package that is in the same scope as a non-completing
-- expression function then we cannot freeze here.
-- Check for an edge case that may cause premature freezing of
-- a private type. If there is a type which depends on another
-- private type from an enclosing package that is in the same
-- scope as a non-completing expression function then we cannot
-- freeze here.
Ignore_Freezing := False;

17
gcc/ada/sem_ch4.adb

@ -716,6 +716,23 @@ package body Sem_Ch4 is
then
null;
-- An unusual case arises when the parent of a derived type is
-- a limited record extension with unknown discriminants, and
-- its full view has no discriminants.
--
-- A more general fix might be to create the proper underlying
-- type for such a derived type, but it is a record type with
-- no private attributes, so this required extending the
-- meaning of this attribute. ???
elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private
and then Present (Underlying_Type (Etype (Type_Id)))
and then
not Has_Discriminants (Underlying_Type (Etype (Type_Id)))
and then not Comes_From_Source (Parent (N))
then
null;
elsif Is_Class_Wide_Type (Type_Id) then
Error_Msg_N
("initialization required in class-wide allocation", N);

8
gcc/ada/sem_ch5.adb

@ -284,7 +284,8 @@ package body Sem_Ch5 is
-- Start of processing for Analyze_Assignment
begin
-- Save LHS for use in target names (AI12-125).
-- Save LHS for use in target names (AI12-125)
Current_LHS := Lhs;
Mark_Coextensions (N, Rhs);
@ -574,9 +575,7 @@ package body Sem_Ch5 is
-- the context of the assignment statement. Restore the expander mode
-- now so that assignment statement can be properly expanded.
if Nkind (N) = N_Assignment_Statement
and then Has_Target_Names (N)
then
if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then
Expander_Mode_Restore;
end if;
@ -3543,6 +3542,7 @@ package body Sem_Ch5 is
if No (Current_LHS) then
Error_Msg_N ("target name can only appear within an assignment", N);
Set_Etype (N, Any_Type);
else
Set_Has_Target_Names (Parent (Current_LHS));
Set_Etype (N, Etype (Current_LHS));

2
gcc/ada/sem_ch5.ads

@ -41,8 +41,8 @@ package Sem_Ch5 is
procedure Analyze_Loop_Parameter_Specification (N : Node_Id);
procedure Analyze_Loop_Statement (N : Node_Id);
procedure Analyze_Null_Statement (N : Node_Id);
procedure Analyze_Target_Name (N : Node_Id);
procedure Analyze_Statements (L : List_Id);
procedure Analyze_Target_Name (N : Node_Id);
procedure Analyze_Label_Entity (E : Entity_Id);
-- This procedure performs direct analysis of the label entity E. It

17
gcc/ada/sem_util.adb

@ -9140,16 +9140,16 @@ package body Sem_Util is
begin
-- Protected objects always have the properties Async_Readers and
-- Async_Writers. (SPARK RM 7.1.2(16))
-- Async_Writers (SPARK RM 7.1.2(16)).
if Property = Name_Async_Readers
or else Property = Name_Async_Writers
then
return True;
-- Protected objects that have Part_Of components also inherit
-- their properties Effective_Reads and Effective_Writes. (SPARK
-- RM 7.1.2(16))
-- Protected objects that have Part_Of components also inherit their
-- properties Effective_Reads and Effective_Writes
-- (SPARK RM 7.1.2(16)).
elsif Present (Constits) then
Constit_Elmt := First_Elmt (Constits);
@ -9352,8 +9352,9 @@ package body Sem_Util is
-- (SPARK RM 7.1.2(16))
if Is_Protected_Type (Etype (Item_Id)) then
return Property = Name_Async_Readers
or else Property = Name_Async_Writers;
return
Property = Name_Async_Readers
or else Property = Name_Async_Writers;
else
return True;
end if;
@ -9377,8 +9378,8 @@ package body Sem_Util is
-- By default, protected objects only have the properties Async_Readers
-- and Async_Writers. If they have Part_Of components, they also inherit
-- their properties Effective_Reads and Effective_Writes. (SPARK RM
-- 7.1.2(16))
-- their properties Effective_Reads and Effective_Writes
-- (SPARK RM 7.1.2(16)).
elsif Ekind (Item_Id) = E_Protected_Object then
return Protected_Object_Has_Enabled_Property;

8
gcc/ada/sinfo.ads

@ -1538,15 +1538,15 @@ package Sinfo is
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
-- Has_Target_Names (Flag8-Sem)
-- Present in assignment statements. Indicates that the RHS contains
-- target names (see AI12-0125-3) and must be expanded accordingly.
-- Has_Wide_Character (Flag11-Sem)
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Character range but within Wide_Character range)
-- appears in the string. Used to implement pragma preference rules.
-- Has_Target_Names (Flag8-Sem)
-- Present in assignment statements. Indicates that the RHS contains
-- target names (see AI12-0125-3) and must be expanded accordingly.
-- Has_Wide_Wide_Character (Flag13-Sem)
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Wide_Character range) appears in the string. Used to