From a961aa79587ca417a9920cd2ba4df4d3144fd26d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 19 Oct 2010 14:29:25 +0200 Subject: [PATCH] [multiple changes] 2010-10-19 Ed Schonberg * 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 * a-exexda.adb: Minor reformatting Minor code reorganization. From-SVN: r165698 --- gcc/ada/ChangeLog | 29 +++++++++++ gcc/ada/a-exexda.adb | 9 +++- gcc/ada/exp_ch4.adb | 85 ++++++++++++++++++++++++++++++++ gcc/ada/exp_ch4.ads | 1 + gcc/ada/exp_util.adb | 1 + gcc/ada/expander.adb | 3 ++ gcc/ada/par-ch3.adb | 10 ++++ gcc/ada/par-ch4.adb | 104 +++++++++++++++++++++++++++++++++++++--- gcc/ada/par-ch5.adb | 1 - gcc/ada/par.adb | 7 +++ gcc/ada/scans.adb | 9 +++- gcc/ada/scans.ads | 1 + gcc/ada/scn.adb | 17 +++++-- gcc/ada/sem.adb | 3 ++ gcc/ada/sem_ch4.adb | 27 +++++++++++ gcc/ada/sem_ch4.ads | 1 + gcc/ada/sem_ch5.adb | 6 --- gcc/ada/sem_ch5.ads | 3 +- gcc/ada/sem_res.adb | 16 +++++++ gcc/ada/sinfo.adb | 10 +++- gcc/ada/sinfo.ads | 24 ++++++++++ gcc/ada/snames.ads-tmpl | 1 + gcc/ada/sprint.adb | 13 +++++ 23 files changed, 358 insertions(+), 23 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 88a3415d7618..9eb7c45c8665 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2010-10-19 Ed Schonberg + + * 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 + + * a-exexda.adb: Minor reformatting + Minor code reorganization. + 2010-10-19 Robert Dewar * sem_eval.adb: Minor reformatting. diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb index e6a006e0b9bc..63ab461a9faa 100644 --- a/gcc/ada/a-exexda.adb +++ b/gcc/ada/a-exexda.adb @@ -574,8 +574,9 @@ package body Exception_Data is ------------------- procedure Append_Number (Number : Integer) is - Val : Integer := Number; - Size : Integer := 1; + Val : Integer; + Size : Integer; + begin if Number <= 0 then return; @@ -583,6 +584,8 @@ package body Exception_Data is -- Compute the number of needed characters + Size := 1; + Val := Number; while Val > 0 loop Val := Val / 10; Size := Size + 1; @@ -606,6 +609,8 @@ package body Exception_Data is end if; end Append_Number; + -- Start of processing for Set_Exception_C_Msg + begin Exception_Propagation.Setup_Exception (Excep, Excep); Excep.Exception_Raised := False; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ce1730e12324..04fd5c07f7da 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7393,6 +7393,91 @@ package body Exp_Ch4 is 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 -- --------------------------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index 745ce294d6ad..804365806a6b 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -66,6 +66,7 @@ package Exp_Ch4 is 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); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index af1cfc45b4dc..ac67366d6bcf 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2877,6 +2877,7 @@ package body Exp_Util is N_Push_Program_Error_Label | N_Push_Storage_Error_Label | N_Qualified_Expression | + N_Quantified_Expression | N_Range | N_Range_Constraint | N_Real_Literal | diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index cc2122dd6e60..23d2aef834b7 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -364,6 +364,9 @@ package body Expander is 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); diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 27a9cfc8cf18..126fb4ab0cf3 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1137,6 +1137,16 @@ package body Ch3 is 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; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 5069fd155637..b679e2033487 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -648,7 +648,7 @@ package body Ch4 is Error_Msg ("expect identifier in parameter association", Sloc (Expr_Node)); - Scan; -- past arrow. + Scan; -- past arrow elsif not Comma_Present then T_Right_Paren; @@ -1214,6 +1214,13 @@ package body Ch4 is 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. @@ -1415,8 +1422,19 @@ package body Ch4 is -- 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 @@ -1616,15 +1634,20 @@ package body Ch4 is 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; @@ -1720,14 +1743,20 @@ package body Ch4 is 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; @@ -2285,7 +2314,7 @@ package body Ch4 is -- NUMERIC_LITERAL | null -- | STRING_LITERAL | AGGREGATE -- | NAME | QUALIFIED_EXPRESSION - -- | ALLOCATOR | (EXPRESSION) + -- | ALLOCATOR | (EXPRESSION) | QUANTIFIED_EXPRESSION -- Error recovery: can raise Error_Resync @@ -2436,6 +2465,25 @@ package body Ch4 is 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 @@ -2457,6 +2505,48 @@ package body Ch4 is 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 -- --------------------------- diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 04e1005e593e..15e290eee7f8 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -38,7 +38,6 @@ package body Ch5 is 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; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 86998322552a..4f360ca43f2d 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -703,6 +703,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is 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; ------------- @@ -713,6 +717,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is 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. diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb index 3be0eb6bdd3b..7f6b808a5652 100644 --- a/gcc/ada/scans.adb +++ b/gcc/ada/scans.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -118,6 +118,13 @@ package body Scans is 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); diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads index 7d891190b6bd..fcf474bc8194 100644 --- a/gcc/ada/scans.ads +++ b/gcc/ada/scans.ads @@ -130,6 +130,7 @@ package Scans is 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 diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb index eb6a97810d0a..fb38d225b263 100644 --- a/gcc/ada/scn.adb +++ b/gcc/ada/scn.adb @@ -472,9 +472,20 @@ package body Scn is 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; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 42b835694133..42447c2357f9 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -470,6 +470,9 @@ package body Sem is when N_Qualified_Expression => Analyze_Qualified_Expression (N); + when N_Quantified_Expression => + Analyze_Quantified_Expression (N); + when N_Raise_Statement => Analyze_Raise_Statement (N); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 37efac8781d8..a96bcecd8108 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -46,6 +46,7 @@ with Sem_Aux; use Sem_Aux; 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; @@ -3176,6 +3177,32 @@ package body Sem_Ch4 is 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 -- ------------------- diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index e5c646f9bb8c..340f1f7c04a2 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -42,6 +42,7 @@ package Sem_Ch4 is 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); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index f74d24e3b061..2de95d873a8d 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -70,12 +70,6 @@ package body Sem_Ch5 is -- 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 -- ------------------------ diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index 4fa2246bee91..48e9764f61a4 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -34,6 +34,7 @@ package Sem_Ch5 is 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); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c05bda9e9507..cc8ac857b56b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -192,6 +192,7 @@ package body Sem_Res is 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); @@ -2698,6 +2699,9 @@ package body Sem_Res is 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); @@ -7767,6 +7771,18 @@ package body Sem_Res is 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 -- ------------------- diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index dfa77a9453ce..dd09e4c5c207 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -224,6 +224,7 @@ package body Sinfo is 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; @@ -512,6 +513,7 @@ package body Sinfo is 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 @@ -1988,7 +1990,8 @@ package body Sinfo is (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; @@ -3219,6 +3222,7 @@ package body Sinfo is 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; @@ -3507,6 +3511,7 @@ package body Sinfo is 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 @@ -4975,7 +4980,8 @@ package body Sinfo is (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; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index fa1d6dd8ee2f..556bffad1f31 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3817,6 +3817,22 @@ package Sinfo is -- 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 -- -------------------------- @@ -7447,6 +7463,7 @@ package Sinfo is N_Null, N_Procedure_Call_Statement, N_Qualified_Expression, + N_Quantified_Expression, -- N_Raise_xxx_Error, N_Subexpr, N_Has_Etype @@ -10473,6 +10490,13 @@ package Sinfo is 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) diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 9d886a2a7ec7..57f40a5593cc 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -985,6 +985,7 @@ package Snames is 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 + $; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index ada95bcf784f..e2bb1734c8b2 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2626,6 +2626,19 @@ package body Sprint is 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