+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * scans.ads: New token At_Sign. Remove '@' from list of illegal
+ characters for future version of the language. '@' is legal name.
+ * scng.ads, scng.adb (Scan): Handle '@' appropriately.
+ * scn.adb (Scan_Reserved_Identifier): An occurrence of '@'
+ denotes a Target_Name.
+ * par-ch4.adb (P_Name, P_Primary): Handle Target_Name.
+ * sinfo.ads, sinfo.adb (N_Target_Name): New non-terminal node.
+ (Has_Target_Names): New flag on N_Assignment_Statement, to
+ indicate that RHS has occurrences of N_Target_Name.
+ * sem.adb: Call Analyze_Target_Name.
+ * sem_ch5.ads, sem_ch5.adb (Analyze_Target_Name): New subpogram.
+ (urrent_LHS): Global variable that denotes LHS of assignment,
+ used in the analysis of Target_Name nodes.
+ * sem_res.adb (Resolve_Target_Name): New procedure.
+ * exp_ch5.adb (Expand_Assign_With_Target_Names): (AI12-0125):
+ N is an assignment statement whose RHS contains occurences of @
+ that designate the value of the LHS of the assignment. If the
+ LHS is side-effect free the target names can be replaced with
+ a copy of the LHS; otherwise the semantics of the assignment
+ is described in terms of a procedure with an in-out parameter,
+ and expanded as such.
+ (Expand_N_Assignment_Statement): Call
+ Expand_Assign_With_Target_Names when needed.
+ * exp_util.adb (Insert_Actions): Take into account N_Target_Name.
+ * sprint.adb: Handle N_Target_Name.
+
2017-01-23 Eric Botcazou <ebotcazou@adacore.com>
* checks.adb: Minor fix in comment.
-- clause (this last case is required because holes in the tagged type
-- might be filled with components from child types).
+ procedure Expand_Assign_With_Target_Names (N : Node_Id);
+ -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
+ -- of @ that designate the value of the LHS of the assignment. If the LHS
+ -- is side-effect free the target names can be replaced with a copy of the
+ -- LHS; otherwise the semantics of the assignment is described in terms of
+ -- a procedure with an in-out parameter, and expanded as such.
+
procedure Expand_Formal_Container_Loop (N : Node_Id);
-- Use the primitives specified in an Iterable aspect to expand a loop
-- over a so-called formal container, primarily for SPARK usage.
end;
end Expand_Assign_Record;
+ -------------------------------------
+ -- Expand_Assign_With_Target_Names --
+ -------------------------------------
+
+ 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;
+
+ New_RHS : Node_Id;
+
+ 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
+ begin
+ if Nkind (N) = N_Target_Name then
+ Rewrite (N, New_Occurrence_Of (Ent, Sloc (N)));
+ end if;
+
+ Set_Analyzed (N, False);
+ return OK;
+ end Replace_Target;
+
+ procedure Replace_Target_Name is new Traverse_Proc (Replace_Target);
+
+ begin
+
+ New_RHS := New_Copy_Tree (RHS);
+
+ if Is_Entity_Name (LHS)
+ and then not Is_Renaming_Of_Object (Entity (LHS))
+ then
+ Ent := Entity (LHS);
+ Replace_Target_Name (New_RHS);
+ Rewrite (N,
+ Make_Assignment_Statement (Loc,
+ Name => Relocate_Node (LHS),
+ Expression => New_RHS));
+
+ elsif Side_Effect_Free (LHS) then
+ Ent := Make_Temporary (Loc, 'T');
+ Insert_Before_And_Analyze (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent,
+ Object_Definition => New_Occurrence_Of (Etype (LHS), Loc),
+ Expression => New_Copy_Tree (LHS)));
+ Replace_Target_Name (New_RHS);
+ Rewrite (N,
+ Make_Assignment_Statement (Loc,
+ Name => Relocate_Node (LHS),
+ Expression => New_RHS));
+
+ else
+ Ent := Make_Temporary (Loc, 'T');
+
+ 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);
+
+ 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;
+ end if;
+
+ -- Analyze rewritten node, either as assignment or procedure call.
+
+ Analyze (N);
+ end Expand_Assign_With_Target_Names;
+
-----------------------------------
-- Expand_N_Assignment_Statement --
-----------------------------------
Check_Valid_Lvalue_Subscripts (Lhs);
end if;
+ -- 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
+ Expand_Assign_With_Target_Names (N);
+ return;
+ end if;
+
-- Ada 2005 (AI-327): Handle assignment to priority of protected object
-- Rewrite an assignment to X'Priority into a run-time call
| N_String_Literal
| N_Subtype_Indication
| N_Subunit
+ | N_Target_Name
| N_Task_Definition
| N_Terminate_Alternative
| N_Triggering_Alternative
-------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- | INDEXED_COMPONENT | SLICE
-- | SELECTED_COMPONENT | ATTRIBUTE
-- | TYPE_CONVERSION | FUNCTION_CALL
- -- | CHARACTER_LITERAL
+ -- | CHARACTER_LITERAL | TARGET_NAME
-- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
-- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
+ -- TARGET_NAME ::= @ (AI12-0125-3: abbreviation for LHS)
+
-- Note: syntactically a procedure call looks just like a function call,
-- so this routine is in practice used to scan out procedure calls as well.
end if;
-- Loop through designators in qualified name
+ -- AI12-0125 : target_name
+ if Token = Tok_At_Sign then
+ Scan_Reserved_Identifier (Force_Msg => False);
+ end if;
Name_Node := Token_Node;
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
+ if not Extensions_Allowed then
+ Error_Msg_SC ("target name is an Ada 2020 extension");
+ Error_Msg_SC ("\compile with -gnatX");
+ end if;
+
+ Node1 := P_Name;
+ return Node1;
+
-- Anything else is illegal as the first token of a primary, but
-- we test for some common errors, to improve error messages.
Tok_Identifier, -- identifier Name, Lit_Or_Name, Desig
+ Tok_At_Sign, -- @ AI12-0125-3 : target name
+
Tok_Double_Asterisk, -- **
Tok_Ampersand, -- & Binary_Addop
-- also when scanning project files (where it is needed because of ???)
Tok_Special,
- -- Used only in preprocessor scanning (to represent one of the
- -- characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The
+ -- AI12-0125-03 : target name as abbreviation for LHS
+
+ -- Otherwise used only in preprocessor scanning (to represent one of
+ -- the characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The
-- character value itself is stored in Scans.Special_Character.
Tok_SPARK_Hide,
-- of Pascal style not equal operator).
subtype Token_Class_Name is
- Token_Type range Tok_Char_Literal .. Tok_Identifier;
+ Token_Type range Tok_Char_Literal .. Tok_At_Sign;
-- First token of name (4.1),
-- (identifier, char literal, operator symbol)
+ -- Includes '@' after Ada2012 corrigendum.
subtype Token_Class_Desig is
- Token_Type range Tok_Operator_Symbol .. Tok_Identifier;
+ Token_Type range Tok_Operator_Symbol .. Tok_At_Sign;
-- Token which can be a Designator (identifier, operator symbol)
subtype Token_Class_Namext is
-- file being compiled. This CRC includes only program tokens, and
-- excludes comments.
+ Limited_Checksum : Word := 0;
+ -- Used to accumulate a CRC representing significant tokens in the
+ -- limited view of a package, i.e. visible type names and related
+ -- tagged indicators.
+
First_Non_Blank_Location : Source_Ptr := No_Location; -- init for -gnatVa
-- Location of first non-blank character on the line containing the
-- current token (i.e. the location of the character whose column number
-- Wide_Character).
Special_Character : Character;
+ -- AI12-0125-03 : '@' as target name is handled elsewhere.
-- Valid only when Token = Tok_Special. Returns one of the characters
- -- '#', '$', '?', '@', '`', '\', '^', '~', or '_'.
+ -- '#', '$', '?', '`', '\', '^', '~', or '_'.
--
-- Why only this set? What about wide characters???
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Token_Chars : constant String := Token_Type'Image (Token);
begin
+ -- AI12-0125 : '@' denotes the target_name, i.e. serves as an
+ -- abbreviation for the LHS of an assignment.
+
+ if Token = Tok_At_Sign then
+ Token_Node := New_Node (N_Target_Name, Token_Ptr);
+ return;
+ end if;
+
-- We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
-- This code extracts the xxx and makes an identifier out of it.
| Tok_And
| Tok_Apostrophe
| Tok_Array
+ | Tok_At_Sign
| Tok_Asterisk
| Tok_At
| Tok_Body
| Tok_Array
| Tok_Asterisk
| Tok_At
+ | Tok_At_Sign
| Tok_Body
| Tok_Box
| Tok_Char_Literal
return;
end if;
+ when '@' =>
+ if not Extensions_Allowed then
+ Error_Illegal_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ else
+ -- AI12-0125-03 : @ is target_name
+ Accumulate_Checksum ('@');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_At_Sign;
+ return;
+ end if;
+
-- Asterisk (can be multiplication operator or double asterisk which
-- is the exponentiation compound delimiter).
Error_Illegal_Character;
-- Invalid graphic characters
-
- when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
+ -- 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,
-- set Scans.Special_Character and return a Special token.
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- either a keyword or an identifier. See also package Casing.
procedure Set_Special_Character (C : Character);
- -- Indicate that one of the following character '#', '$', '?', '@', '`',
+ -- Indicate that one of the following character '#', '$', '?', '`',
-- '\', '^', '_' or '~', when found is a Special token.
+ -- AI12-0125-03 : target name (ES) is not in this list because '@' is
+ -- handled as a special token as abbreviation of LHS of assignment.
procedure Reset_Special_Characters;
-- Indicate that there is no characters that are Special tokens., which
when N_Subunit =>
Analyze_Subunit (N);
+ when N_Target_Name =>
+ Analyze_Target_Name (N);
+
when N_Task_Body =>
Analyze_Task_Body (N);
package body Sem_Ch5 is
+ Current_LHS : Node_Id := Empty;
+ -- Holds the left-hand side of the assignment statement being analyzed.
+ -- Used to determine the type of a target_name appearing on the RHS, for
+ -- AI12-0125 and the use of '@' as an abbreviation for the LHS.
+
Unblocked_Exit_Count : Nat := 0;
-- This variable is used when processing if statements, case statements,
-- and block statements. It counts the number of exit points that are not
-- Start of processing for Analyze_Assignment
begin
+ -- Save LHS for use in target names (AI12-125).
+ Current_LHS := Lhs;
+
Mark_Coextensions (N, Rhs);
-- Analyze the target of the assignment first in case the expression
-- Now we can complete the resolution of the right hand side
Set_Assignment_Type (Lhs, T1);
+
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);
Analyze_Dimension (N);
<<Leave>>
+ Current_LHS := Empty;
Restore_Ghost_Mode (Mode);
end Analyze_Assignment;
null;
end Analyze_Null_Statement;
+ -------------------------
+ -- Analyze_Target_Name --
+ -------------------------
+
+ procedure Analyze_Target_Name (N : Node_Id) is
+ begin
+ 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));
+
+ -- Disable expansion for the rest of the analysis of the current
+ -- right-hand side. The enclosing assignment statement will be
+ -- rewritten during expansion, together with occurrences of the
+ -- target name.
+
+ if Expander_Active then
+ Expander_Mode_Save_And_Set (False);
+ end if;
+ end if;
+ end Analyze_Target_Name;
+
------------------------
-- Analyze_Statements --
------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
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_Label_Entity (E : Entity_Id);
procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id);
procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id);
when N_String_Literal =>
Resolve_String_Literal (N, Ctx_Type);
+ when N_Target_Name =>
+ Resolve_Target_Name (N, Ctx_Type);
+
when N_Type_Conversion =>
Resolve_Type_Conversion (N, Ctx_Type);
end;
end Resolve_String_Literal;
+ -------------------------
+ -- Resolve_Target_Name --
+ -------------------------
+
+ procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id) is
+ begin
+ Set_Etype (N, Typ);
+ end Resolve_Target_Name;
+
-----------------------------
-- Resolve_Type_Conversion --
-----------------------------
return Flag5 (N);
end Has_Storage_Size_Pragma;
+ function Has_Target_Names
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ return Flag8 (N);
+ end Has_Target_Names;
+
function Has_Wide_Character
(N : Node_Id) return Boolean is
begin
Set_Flag5 (N, Val);
end Set_Has_Storage_Size_Pragma;
+ procedure Set_Has_Target_Names
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ Set_Flag8 (N, Val);
+ end Set_Has_Target_Names;
+
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True) is
begin
-- 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
-- Forwards_OK (Flag5-Sem)
-- Backwards_OK (Flag6-Sem)
-- No_Ctrl_Actions (Flag7-Sem)
+ -- Has_Target_Names (Flag8-Sem)
-- Componentwise_Assignment (Flag14-Sem)
-- Suppress_Assignment_Checks (Flag18-Sem)
-- case the front end must generate an extra temporary and initialize
-- this temporary as required (the temporary itself is not atomic).
+ ------------------
+ -- Target_Name --
+ ------------------
+
+ -- N_Target_Name
+ -- Sloc points to @
+ -- Etype (Node5-Sem)
+
+ -- Note (Ada 2020): node is used during analysis as a placeholder for
+ -- the value of the LHS of the enclosing assignment statement. Node is
+ -- eventually rewritten together with enclosing assignment, and backends
+ -- are not aware of it.
+
-----------------------
-- 5.3 If Statement --
-----------------------
N_Reference,
N_Selected_Component,
N_Slice,
+ N_Target_Name,
N_Type_Conversion,
N_Unchecked_Expression,
N_Unchecked_Type_Conversion,
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
+ function Has_Target_Names
+ (N : Node_Id) return Boolean; -- Flag8
+
function Has_Wide_Character
(N : Node_Id) return Boolean; -- Flag11
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
+ procedure Set_Has_Target_Names
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True); -- Flag11
4 => False, -- unused
5 => False), -- unused
+ N_Target_Name =>
+ (1 => False, -- unused
+ 2 => False, -- unused
+ 3 => False, -- unused
+ 4 => False, -- unused
+ 5 => False), -- Etype (Node5-Sem)
+
N_If_Statement =>
(1 => True, -- Condition (Node1)
2 => True, -- Then_Statements (List2)
pragma Inline (Has_Private_View);
pragma Inline (Has_Relative_Deadline_Pragma);
pragma Inline (Has_Storage_Size_Pragma);
+ pragma Inline (Has_Target_Names);
pragma Inline (Has_Wide_Character);
pragma Inline (Has_Wide_Wide_Character);
pragma Inline (Header_Size_Added);
pragma Inline (Set_Has_Self_Reference);
pragma Inline (Set_Has_SP_Choice);
pragma Inline (Set_Has_Storage_Size_Pragma);
+ pragma Inline (Set_Has_Target_Names);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
pragma Inline (Set_Header_Size_Added);
Extra_Blank_Line;
Sprint_Node (Proper_Body (Node));
+ when N_Target_Name =>
+ Write_Char ('@');
+
when N_Task_Body =>
Write_Indent_Str_Sloc ("task body ");
Write_Id (Defining_Identifier (Node));
projects / gcc.git / commitdiff