+2010-10-19 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb, exp_ch4.ads (Expand_Quantified_Expression): New procedure
+ * exp_util.adb (Insert_Actions): Include Quantified_Expression.
+ * expander.adb: Call Expand_Qualified_Expression.
+ * par.adb: New procedure P_Quantified_Expression. Make
+ P_Loop_Parameter_Specification global for use in quantified expressions.
+ * par-ch3.adb (P_Subtype_Mark_Resync): Allow "some" as an identifier if
+ version < Ada2012.
+ * par-ch4.adb: New procedure P_Quantified_Expression.
+ * par-ch5.adb: P_Loop_Parameter_Specification is now global.
+ * scans.adb, scans.ads: Introduce token Some. For now leave as
+ unreserved.
+ * scn.adb (Scan_Reserved_Identifier): For earlier versions of Ada,
+ treat Some as a regular identifier.
+ * sem.adb: Call Analyze_Quantified_Expression.
+ * sem_ch4.adb, sem_ch4.ads: New procedure Analyze_Quantified_Expression.
+ * sem_ch5.adb, sem_ch5.ads: Analyze_Iteration_Scheme is public, for use
+ in quantified expressions.
+ * sem_res.adb: New procedure Resolve_Qualified_Expression.
+ * sinfo.adb, sinfo.ads: New node N_Quantified_Expression
+ * snames.ads-tmpl: New name Some.
+ * sprint.adb: Output quantified_expression.
+
+2010-10-19 Robert Dewar <dewar@adacore.com>
+
+ * a-exexda.adb: Minor reformatting
+ Minor code reorganization.
+
2010-10-19 Robert Dewar <dewar@adacore.com>
* sem_eval.adb: Minor reformatting.
-------------------
procedure Append_Number (Number : Integer) is
- Val : Integer := Number;
- Size : Integer := 1;
+ Val : Integer;
+ Size : Integer;
+
begin
if Number <= 0 then
return;
-- Compute the number of needed characters
+ Size := 1;
+ Val := Number;
while Val > 0 loop
Val := Val / 10;
Size := Size + 1;
end if;
end Append_Number;
+ -- Start of processing for Set_Exception_C_Msg
+
begin
Exception_Propagation.Setup_Exception (Excep, Excep);
Excep.Exception_Raised := False;
end if;
end Expand_N_Qualified_Expression;
+ ------------------------------------
+ -- Expand_N_Quantified_Expression --
+ ------------------------------------
+
+ procedure Expand_N_Quantified_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Iterator : constant Node_Id := Loop_Parameter_Specification (N);
+ Cond : constant Node_Id := Condition (N);
+
+ Actions : List_Id;
+ Decl : Node_Id;
+ Test : Node_Id;
+ Tnn : Entity_Id;
+
+ -- We expand
+ -- for all X in range => Cond
+ -- into
+ -- R := True;
+ -- for all X in range loop
+ -- if not Cond then
+ -- R := False;
+ -- exit;
+ -- end if;
+ -- end loop;
+ --
+ -- Conversely, an existentially quantified expression becomes:
+ --
+ -- R := False;
+ -- for all X in range loop
+ -- if Cond then
+ -- R := True;
+ -- exit;
+ -- end if;
+ -- end loop;
+
+ begin
+ Actions := New_List;
+ Tnn := Make_Temporary (Loc, 'T');
+ Decl := Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc));
+
+ Append_To (Actions, Decl);
+
+ if All_Present (N) then
+ Set_Expression (Decl, New_Occurrence_Of (Standard_True, Loc));
+
+ Test :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc, Relocate_Node (Cond)),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Tnn, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc)),
+ Make_Exit_Statement (Loc)));
+ else
+ Set_Expression (Decl, New_Occurrence_Of (Standard_False, Loc));
+
+ Test :=
+ Make_If_Statement (Loc,
+ Condition => Relocate_Node (Cond),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Tnn, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc)),
+ Make_Exit_Statement (Loc)));
+ end if;
+
+ Append_To (Actions,
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification => Iterator),
+ Statements => New_List (Test),
+ End_Label => Empty));
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => New_Occurrence_Of (Tnn, Loc),
+ Actions => Actions));
+
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end Expand_N_Quantified_Expression;
+
---------------------------------
-- Expand_N_Selected_Component --
---------------------------------
procedure Expand_N_Op_Xor (N : Node_Id);
procedure Expand_N_Or_Else (N : Node_Id);
procedure Expand_N_Qualified_Expression (N : Node_Id);
+ procedure Expand_N_Quantified_Expression (N : Node_Id);
procedure Expand_N_Selected_Component (N : Node_Id);
procedure Expand_N_Slice (N : Node_Id);
procedure Expand_N_Type_Conversion (N : Node_Id);
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
+ N_Quantified_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
when N_Qualified_Expression =>
Expand_N_Qualified_Expression (N);
+ when N_Quantified_Expression =>
+ Expand_N_Quantified_Expression (N);
+
when N_Raise_Statement =>
Expand_N_Raise_Statement (N);
Discard_Junk_Node (P_Array_Type_Definition);
return Error;
+ -- If Some becomes a keyword, the following is needed to make it
+ -- acceptable in older versions of Ada.
+
+ elsif Token = Tok_Some
+ and then Ada_Version < Ada_2012
+ then
+ Scan_Reserved_Identifier (False);
+ Scan;
+ return Token_Node;
+
else
Type_Node := P_Qualified_Simple_Name_Resync;
Error_Msg
("expect identifier in parameter association",
Sloc (Expr_Node));
- Scan; -- past arrow.
+ Scan; -- past arrow
elsif not Comma_Present then
T_Right_Paren;
T_Right_Paren;
return Expr_Node;
+ -- Quantified expression case
+
+ elsif Token = Tok_For then
+ Expr_Node := P_Quantified_Expression;
+ T_Right_Paren;
+ return Expr_Node;
+
-- Note: the mechanism used here of rescanning the initial expression
-- is distinctly unpleasant, but it saves a lot of fiddling in scanning
-- out the discrete choice list.
-- that doesn't belong to us!
if Token in Token_Class_Eterm then
- Error_Msg_AP ("expecting expression or component association");
- exit;
+
+ -- If Some becomes a keyword, the following is needed to make it
+ -- acceptable in older versions of Ada.
+
+ if Token = Tok_Some
+ and then Ada_Version < Ada_2012
+ then
+ Scan_Reserved_Identifier (False);
+ else
+ Error_Msg_AP
+ ("expecting expression or component association");
+ exit;
+ end if;
end if;
-- Deal with misused box
end P_Expression;
-- This function is identical to the normal P_Expression, except that it
- -- also permits the appearence of a case of conditional expression without
- -- the usual surrounding parentheses.
+ -- also permits the appearance of a case, conditional, or quantified
+ -- expression without the usual surrounding parentheses.
function P_Expression_If_OK return Node_Id is
begin
if Token = Tok_Case then
return P_Case_Expression;
+
elsif Token = Tok_If then
return P_Conditional_Expression;
+
+ elsif Token = Tok_For then
+ return P_Quantified_Expression;
+
else
return P_Expression;
end if;
end if;
end P_Expression_Or_Range_Attribute;
- -- Version that allows a non-parenthesized case or conditional expression
+ -- Version that allows a non-parenthesized case, conditional, or quantified
+ -- expression
function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
begin
if Token = Tok_Case then
return P_Case_Expression;
+
elsif Token = Tok_If then
return P_Conditional_Expression;
+
+ elsif Token = Tok_For then
+ return P_Quantified_Expression;
+
else
return P_Expression_Or_Range_Attribute;
end if;
-- NUMERIC_LITERAL | null
-- | STRING_LITERAL | AGGREGATE
-- | NAME | QUALIFIED_EXPRESSION
- -- | ALLOCATOR | (EXPRESSION)
+ -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION
-- Error recovery: can raise Error_Resync
return P_Identifier;
end if;
+ -- For [all | some] indicates a quantified expression
+
+ when Tok_For =>
+
+ if Token_Is_At_Start_Of_Line then
+ Error_Msg_AP ("misplaced loop");
+ return Error;
+
+ elsif Ada_Version >= Ada_2012 then
+ Error_Msg_SC ("quantified expression must be parenthesized");
+ return P_Quantified_Expression;
+
+ else
+
+ -- Otherwise treat as misused identifier
+
+ return P_Identifier;
+ end if;
+
-- Anything else is illegal as the first token of a primary, but
-- we test for a reserved identifier so that it is treated nicely
end loop;
end P_Primary;
+ -------------------------------
+ -- 4.4 Quantified_Expression --
+ -------------------------------
+
+ -- QUANTIFIED_EXPRESSION ::=
+ -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
+ -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
+
+ function P_Quantified_Expression return Node_Id is
+ Node1 : Node_Id;
+
+ begin
+ Scan; -- past FOR
+
+ Node1 := New_Node (N_Quantified_Expression, Prev_Token_Ptr);
+
+ if Token = Tok_All then
+ Set_All_Present (Node1);
+
+ -- We treat Some as a non-reserved keyword, so it appears to
+ -- the scanner as an identifier. If Some is made into a reserved
+ -- work, the check below is against Tok_Some.
+
+ elsif Token /= Tok_Identifier
+ or else Chars (Token_Node) /= Name_Some
+ then
+ Error_Msg_AP ("missing quantifier");
+ raise Error_Resync;
+ end if;
+
+ Scan;
+ Set_Loop_Parameter_Specification (Node1, P_Loop_Parameter_Specification);
+ if Token = Tok_Arrow then
+ Scan;
+ Set_Condition (Node1, P_Expression);
+ return Node1;
+ else
+ Error_Msg_AP ("missing arrow");
+ raise Error_Resync;
+ end if;
+ end P_Quantified_Expression;
+
---------------------------
-- 4.5 Logical Operator --
---------------------------
function P_Goto_Statement return Node_Id;
function P_If_Statement return Node_Id;
function P_Label return Node_Id;
- function P_Loop_Parameter_Specification return Node_Id;
function P_Null_Statement return Node_Id;
function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
function P_Qualified_Expression (Subtype_Mark : Node_Id) return Node_Id;
-- This routine scans out a qualified expression when the caller has
-- already scanned out the name and apostrophe of the construct.
+
+ function P_Quantified_Expression return Node_Id;
+ -- This routine scans out a quantified expression when the caller has
+ -- already scanned out the keyword "for" of the construct.
end Ch4;
-------------
function P_Condition return Node_Id;
-- Scan out and return a condition
+ function P_Loop_Parameter_Specification return Node_Id;
+ -- Used in loop constructs and quantified expressions.
+
function P_Statement_Name (Name_Node : Node_Id) return Node_Id;
-- Given a node representing a name (which is a call), converts it
-- to the syntactically corresponding procedure call statement.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
Set_Reserved (Name_Reverse, Tok_Reverse);
Set_Reserved (Name_Select, Tok_Select);
Set_Reserved (Name_Separate, Tok_Separate);
+
+ -- We choose to make Some into a non-reserved word, so it is handled
+ -- like a regular identifier in most contexts. Uncomment the following
+ -- line if a pedantic Ada2012 mode is required.
+
+ -- Set_Reserved (Name_Some, Tok_Some);
+
Set_Reserved (Name_Subtype, Tok_Subtype);
Set_Reserved (Name_Tagged, Tok_Tagged);
Set_Reserved (Name_Task, Tok_Task);
Tok_Record, -- RECORD Eterm, Sterm
Tok_Renames, -- RENAMES Eterm, Sterm
Tok_Reverse, -- REVERSE Eterm, Sterm
+ Tok_Some, -- SOME Eterm, Sterm
Tok_Tagged, -- TAGGED Eterm, Sterm
Tok_Then, -- THEN Eterm, Sterm
Token_Name := Name_Find;
if not Used_As_Identifier (Token) or else Force_Msg then
- Error_Msg_Name_1 := Token_Name;
- Error_Msg_SC ("reserved word* cannot be used as identifier!");
- Used_As_Identifier (Token) := True;
+
+ -- If "some" is made into a reseverd work in Ada2012, the following
+ -- check will make it into a regular identifer in earlier versions
+ -- of the language.
+
+ if Token = Tok_Some
+ and then Ada_Version < Ada_2012
+ then
+ null;
+ else
+ Error_Msg_Name_1 := Token_Name;
+ Error_Msg_SC ("reserved word* cannot be used as identifier!");
+ Used_As_Identifier (Token) := True;
+ end if;
end if;
Token := Tok_Identifier;
when N_Qualified_Expression =>
Analyze_Qualified_Expression (N);
+ when N_Quantified_Expression =>
+ Analyze_Quantified_Expression (N);
+
when N_Raise_Statement =>
Analyze_Raise_Statement (N);
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
Set_Etype (N, T);
end Analyze_Qualified_Expression;
+ -----------------------------------
+ -- Analyze_Quantified_Expression --
+ -----------------------------------
+
+ procedure Analyze_Quantified_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (N), 'L');
+
+ Iterator : Node_Id;
+ begin
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, N);
+
+ Iterator :=
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification => Loop_Parameter_Specification (N));
+
+ Push_Scope (Ent);
+ Analyze_Iteration_Scheme (Iterator);
+ Analyze (Condition (N));
+ End_Scope;
+ Set_Etype (N, Standard_Boolean);
+ end Analyze_Quantified_Expression;
+
-------------------
-- Analyze_Range --
-------------------
procedure Analyze_Negation (N : Node_Id);
procedure Analyze_Null (N : Node_Id);
procedure Analyze_Qualified_Expression (N : Node_Id);
+ procedure Analyze_Quantified_Expression (N : Node_Id);
procedure Analyze_Range (N : Node_Id);
procedure Analyze_Reference (N : Node_Id);
procedure Analyze_Selected_Component (N : Node_Id);
-- messages. This variable is recursively saved on entry to processing the
-- construct, and restored on exit.
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Analyze_Iteration_Scheme (N : Node_Id);
-
------------------------
-- Analyze_Assignment --
------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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_Goto_Statement (N : Node_Id);
procedure Analyze_If_Statement (N : Node_Id);
procedure Analyze_Implicit_Label_Declaration (N : Node_Id);
+ procedure Analyze_Iteration_Scheme (N : Node_Id);
procedure Analyze_Label (N : Node_Id);
procedure Analyze_Loop_Statement (N : Node_Id);
procedure Analyze_Null_Statement (N : Node_Id);
procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Range (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id);
when N_Qualified_Expression
=> Resolve_Qualified_Expression (N, Ctx_Type);
+ when N_Quantified_Expression
+ => Resolve_Quantified_Expression (N, Ctx_Type);
+
when N_Raise_xxx_Error
=> Set_Etype (N, Ctx_Type);
Eval_Qualified_Expression (N);
end Resolve_Qualified_Expression;
+ -----------------------------------
+ -- Resolve_Quantified_Expression --
+ -----------------------------------
+
+ procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is
+ begin
+ -- The loop structure is already resolved during its analysis, only the
+ -- resolution of the condition needs to be done.
+
+ Resolve (Condition (N), Typ);
+ end Resolve_Quantified_Expression;
+
-------------------
-- Resolve_Range --
-------------------
pragma Assert (False
or else NT (N).Nkind = N_Access_Definition
or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Use_Type_Clause);
return Flag15 (N);
end All_Present;
or else NT (N).Nkind = N_Exit_Statement
or else NT (N).Nkind = N_If_Statement
or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Raise_Constraint_Error
or else NT (N).Nkind = N_Raise_Program_Error
or else NT (N).Nkind = N_Raise_Storage_Error
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Iteration_Scheme);
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression);
return Node4 (N);
end Loop_Parameter_Specification;
pragma Assert (False
or else NT (N).Nkind = N_Access_Definition
or else NT (N).Nkind = N_Access_To_Object_Definition
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Use_Type_Clause);
Set_Flag15 (N, Val);
end Set_All_Present;
or else NT (N).Nkind = N_Exit_Statement
or else NT (N).Nkind = N_If_Statement
or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression
or else NT (N).Nkind = N_Raise_Constraint_Error
or else NT (N).Nkind = N_Raise_Program_Error
or else NT (N).Nkind = N_Raise_Storage_Error
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Iteration_Scheme);
+ or else NT (N).Nkind = N_Iteration_Scheme
+ or else NT (N).Nkind = N_Quantified_Expression);
Set_Node4_With_Parent (N, Val);
end Set_Loop_Parameter_Specification;
-- point operands if the Treat_Fixed_As_Integer flag is set and will
-- thus treat these nodes in identical manner, ignoring small values.
+ ---------------------------------
+ -- 4.5.9 Quantified Expression --
+ ---------------------------------
+
+ -- QUANTIFIED_EXPRESSION ::=
+ -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE |
+ -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE
+ --
+ -- QUANTIFIER ::= all | some
+
+ -- N_Quantified_Expression
+ -- Sloc points to token for
+ -- Loop_Parameter_Specification (Node4)
+ -- Condition (Node1)
+ -- All_Present (Flag15)
+
--------------------------
-- 4.6 Type Conversion --
--------------------------
N_Null,
N_Procedure_Call_Statement,
N_Qualified_Expression,
+ N_Quantified_Expression,
-- N_Raise_xxx_Error, N_Subexpr, N_Has_Etype
4 => True, -- Subtype_Mark (Node4)
5 => False), -- Etype (Node5-Sem)
+ N_Quantified_Expression =>
+ (1 => True, -- Condition (Node1)
+ 2 => False, -- unused
+ 3 => False, -- unused
+ 4 => True, -- Loop_Parameter_Specification (Node4)
+ 5 => False), -- Etype (Node5-Sem)
+
N_Allocator =>
(1 => False, -- Storage_Pool (Node1-Sem)
2 => False, -- Procedure_To_Call (Node2-Sem)
Name_Reverse : constant Name_Id := N + $;
Name_Select : constant Name_Id := N + $;
Name_Separate : constant Name_Id := N + $;
+ Name_Some : constant Name_Id := N + $;
Name_Subtype : constant Name_Id := N + $;
Name_Task : constant Name_Id := N + $;
Name_Terminate : constant Name_Id := N + $;
Write_Char (')');
end if;
+ when N_Quantified_Expression =>
+ Write_Str (" for");
+
+ if All_Present (Node) then
+ Write_Str (" all ");
+ else
+ Write_Str (" some ");
+ end if;
+
+ Sprint_Node (Loop_Parameter_Specification (Node));
+ Write_Str (" => ");
+ Sprint_Node (Condition (Node));
+
when N_Raise_Constraint_Error =>
-- This node can be used either as a subexpression or as a
OSDN Git Service
