+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
-- 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.
-- 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
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);
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
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).
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 :=
-- 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.
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.
-- 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;
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 :=
-------------------------------------
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);
- Ent : Entity_Id;
+ 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);
- New_RHS : Node_Id;
+ Ent : Entity_Id;
+ -- The entity of the left-hand side
- 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.
-- 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)));
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))));
-
- 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;
+ Proc_Id := Make_Temporary (Loc, 'P');
+
+ 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;
-- 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;
-- 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.
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);
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)
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))
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.
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
-------------------------------
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
procedure Check_Deferred is new Traverse_Proc (Find_Constant);
+ -- Local variables
+
+ Decl : Node_Id;
+
-- Start of processing for Check_Expression_Function
begin
-- Loop through designators in qualified name
-- AI12-0125 : target_name
+
if Token = Tok_At_Sign then
Scan_Reserved_Identifier (Force_Msg => False);
end if;
-- 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
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");
| Tok_And
| Tok_Apostrophe
| Tok_Array
- | Tok_At_Sign
| Tok_Asterisk
| Tok_At
+ | Tok_At_Sign
| Tok_Body
| Tok_Box
| Tok_Char_Literal
else
-- AI12-0125-03 : @ is target_name
+
Accumulate_Checksum ('@');
Scan_Ptr := Scan_Ptr + 1;
Token := Tok_At_Sign;
-- 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,
-----------------------------------------
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
-- 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);
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
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;
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
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;
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))
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
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
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
-- 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
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;
------------------------------------------------
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
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
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
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
-- 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;
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;
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);
-- 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);
-- 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;
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));
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
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);
-- (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;
-- 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;
-- 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
projects / thirdparty / gcc.git / commitdiff
