+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, exp_util.adb, sem_prag.adb, freeze.adb, sem_util.adb:
+ Minor reformatting.
+
+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * scng.adb (Scan): Handle '@' appropriately.
+ * sem_ch5.adb: Code cleanup.
+
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* freeze.adb (Check_Expression_Function): Do not check for the
Adjust_Sloc : Boolean;
Needs_Wrapper : out Boolean)
is
-
function Replace_Entity (N : Node_Id) return Traverse_Result;
-- Replace reference to formal of inherited operation or to primitive
-- operation of root type, with corresponding entity for derived type,
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
- -- If the entity is an overridden primitive, we must build
- -- a wrapper for the current inherited operation.
+ -- If the entity is an overridden primitive, we must build a
+ -- wrapper for the current inherited operation.
if Is_Subprogram (New_E) then
Needs_Wrapper := True;
A_Post : Node_Id;
A_Pre : Node_Id;
Decls : List_Id;
+ Needs_Wrapper : Boolean;
+ New_Prag : Node_Id;
Op_Node : Elmt_Id;
Par_Prim : Entity_Id;
Par_Type : Entity_Id;
- New_Prag : Node_Id;
Prim : Entity_Id;
- Needs_Wrapper : Boolean;
begin
Op_Node := First_Elmt (Prim_Ops);
-- require a wrapper to handle inherited conditions that call other
-- primitives, so that LSP can be verified/enforced.
- -- Wrapper construction TBD.
-
Op_Node := First_Elmt (Prim_Ops);
while Present (Op_Node) loop
Decls := Empty_List;
-- controlling actuals are conversions to the corresponding type
-- in the parent primitive:
- -- procedure New_Prim (F1 : T1.; ...) is
- -- pragma Check (Precondition, Expr);
- -- begin
- -- Par_Prim (Par_Type (F1) ..);
- -- end;
- --
- -- If the primitive is a function the statement is a call.
+ -- procedure New_Prim (F1 : T1.; ...) is
+ -- pragma Check (Precondition, Expr);
+ -- begin
+ -- Par_Prim (Par_Type (F1) ..);
+ -- end;
+
+ -- If the primitive is a function the statement is a call
declare
Loc : constant Source_Ptr := Sloc (R);
- Formal : Entity_Id;
Actuals : List_Id;
+ Call : Node_Id;
+ Formal : Entity_Id;
New_F_Spec : Node_Id;
New_Formal : Entity_Id;
New_Proc : Node_Id;
New_Spec : Node_Id;
- Call : Node_Id;
begin
- Actuals := Empty_List;
- New_Spec := Build_Overriding_Spec (Par_Prim, R);
+ Actuals := Empty_List;
+ New_Spec := Build_Overriding_Spec (Par_Prim, R);
Formal := First_Formal (Par_Prim);
New_F_Spec := First (Parameter_Specifications (New_Spec));
while Present (Formal) loop
New_Formal := Defining_Identifier (New_F_Spec);
- -- If controlling argument, add conversion.
+ -- If controlling argument, add conversion
if Etype (Formal) = Par_Type then
Append_To (Actuals,
end loop;
if Ekind (Par_Prim) = E_Procedure then
- Call := Make_Procedure_Call_Statement (Loc,
- Parameter_Associations => Actuals,
- Name => New_Occurrence_Of (Par_Prim, Loc));
+ Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Par_Prim, Loc),
+ Parameter_Associations => Actuals);
else
- Call := Make_Simple_Return_Statement (Loc,
+ Call :=
+ Make_Simple_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
- Parameter_Associations => Actuals,
- Name => New_Occurrence_Of (Par_Prim, Loc)));
+ Name =>
+ New_Occurrence_Of (Par_Prim, Loc),
+ Parameter_Associations => Actuals));
end if;
- New_Proc := Make_Subprogram_Body (Loc,
- Specification => New_Spec,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call),
- End_Label => Make_Identifier (Loc, Chars (Prim))));
+ New_Proc :=
+ Make_Subprogram_Body (Loc,
+ Specification => New_Spec,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call),
+ End_Label => Make_Identifier (Loc, Chars (Prim))));
Insert_After (Parent (R), New_Proc);
Analyze (New_Proc);
-- T'Digits'Img. Strings literals are included for things like
-- "abs"'Address. Other literals are included to give better error
-- behavior for illegal cases like 123'Img.
+ -- In Ada2020 a target name (i.e. @) is a valid prefix of an
+ -- attribute, and functions like a name.
if Prev_Token = Tok_Identifier
or else Prev_Token = Tok_Right_Paren
or else Prev_Token = Tok_Delta
or else Prev_Token = Tok_Digits
or else Prev_Token = Tok_Project
+ or else Prev_Token = Tok_At_Sign
or else Prev_Token in Token_Class_Literal
then
Token := Tok_Apostrophe;
end if;
while Present (Disc) loop
- -- If no further associations return the discriminant, value
- -- will be found on the second pass.
+
+ -- If no further associations return the discriminant, value will
+ -- be found on the second pass.
if No (Assoc) then
return Result;
Resolve (Rhs, T1);
- -- If the right-hand side contains target names, expansion has been
- -- disabled to prevent expansion that might move target names out of
- -- 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
- Expander_Mode_Restore;
- end if;
-
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
<<Leave>>
Current_LHS := Empty;
Restore_Ghost_Mode (Mode);
+
+ -- If the right-hand side contains target names, expansion has been
+ -- disabled to prevent expansion that might move target names out of
+ -- 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
+ Expander_Mode_Restore;
+ end if;
end Analyze_Assignment;
-----------------------------
Inher_Id : Entity_Id := Empty;
Keep_Pragma_Id : Boolean := False) return Node_Id
is
- Needs_Wrapper : Boolean;
- pragma Unreferenced (Needs_Wrapper);
-
function Suppress_Reference (N : Node_Id) return Traverse_Result;
-- Detect whether node N references a formal parameter subject to
-- pragma Unreferenced. If this is the case, set Comes_From_Source
-- Local variables
- Loc : constant Source_Ptr := Sloc (Prag);
- Prag_Nam : constant Name_Id := Pragma_Name (Prag);
- Check_Prag : Node_Id;
- Msg_Arg : Node_Id;
- Nam : Name_Id;
+ Loc : constant Source_Ptr := Sloc (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name (Prag);
+ Check_Prag : Node_Id;
+ Msg_Arg : Node_Id;
+ Nam : Name_Id;
+
+ Needs_Wrapper : Boolean;
+ pragma Unreferenced (Needs_Wrapper);
-- Start of processing for Build_Pragma_Check_Equivalent
-- Build the inherited class-wide condition
Build_Class_Wide_Expression
- (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True,
- Needs_Wrapper => Needs_Wrapper);
+ (Prag => Check_Prag,
+ Subp => Subp_Id,
+ Par_Subp => Inher_Id,
+ Adjust_Sloc => True,
+ Needs_Wrapper => Needs_Wrapper);
-- If not an inherited condition simply copy the original pragma
Formal_Spec : Node_Id;
Formal_Type : Node_Id;
New_Spec : Node_Id;
+
begin
New_Spec := Copy_Subprogram_Spec (Spec);
+
Formal_Spec := First (Parameter_Specifications (New_Spec));
while Present (Formal_Spec) loop
Formal_Type := Parameter_Type (Formal_Spec);
+
if Is_Entity_Name (Formal_Type)
and then Entity (Formal_Type) = Par_Typ
then
Rewrite (Formal_Type, New_Occurrence_Of (Typ, Loc));
end if;
- -- Nothing needs to be done for access parameters.
+ -- Nothing needs to be done for access parameters
Next (Formal_Spec);
end loop;
-- names.
when N_Explicit_Dereference =>
- return not Nkind_In
- (Original_Node (N), N_If_Expression, N_Case_Expression);
+ return not Nkind_In (Original_Node (N), N_Case_Expression,
+ N_If_Expression);
-- A view conversion of a tagged object is an object reference
projects / gcc.git / commitdiff