From patchwork Tue Oct 19 12:30:18 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68328 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 4E706B6EF1 for ; Tue, 19 Oct 2010 23:30:44 +1100 (EST) Received: (qmail 31937 invoked by alias); 19 Oct 2010 12:30:37 -0000 Received: (qmail 31892 invoked by uid 22791); 19 Oct 2010 12:30:32 -0000 X-SWARE-Spam-Status: No, hits=-1.2 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 19 Oct 2010 12:30:22 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 141D8CB01FC; Tue, 19 Oct 2010 14:30:19 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id jMN+KZwfbS5P; Tue, 19 Oct 2010 14:30:19 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id EA781CB027F; Tue, 19 Oct 2010 14:30:18 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id CC1BDD9BB5; Tue, 19 Oct 2010 14:30:18 +0200 (CEST) Date: Tue, 19 Oct 2010 14:30:18 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Implementation of quantified expressions Message-ID: <20101019123018.GA3187@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch implements part of the Ada2012 quantified expressions machinery. Iterator forms over arrays are supported. Execution of the following in Ada2012 mode must yield: YES FALSE TRUE TRUE TRUE --- with Text_IO; use Text_IO; procedure Proc is type Ar is array (1..10) of integer; Thing : Ar := (others => 0); function Change (X : integer) return Boolean is begin if Thing (X) >= 0 then Thing (X) := -1; return True; else return False; end if; end Change; begin if (for all I in thing'range => Thing (I) = 0) then Put_Line ("YES"); end if; Thing (5 ) := -111; Put_Line (Boolean'Image (for all J in thing'range => Thing (J) > 0)); Put_Line (Boolean'Image (for some J in thing'range => Thing (J) < 0)); while (for some I in thing'range => Change (I)) loop null; end loop; Put_Line (Boolean'Image (for all K in thing'range => Thing (K) < 0)); Thing := (0,1,2,3,4,5,6,7,8,9); Put_Line (Boolean'Image (for all I in Thing'first.. Thing'last - 1=> Thing (I) < THing (I+1))); end; Tested on x86_64-pc-linux-gnu, committed on trunk 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. Index: sem_ch5.adb =================================================================== --- sem_ch5.adb (revision 165687) +++ sem_ch5.adb (working copy) @@ -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 -- ------------------------ Index: sem_ch5.ads =================================================================== --- sem_ch5.ads (revision 165687) +++ sem_ch5.ads (working copy) @@ -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); Index: exp_util.adb =================================================================== --- exp_util.adb (revision 165694) +++ exp_util.adb (working copy) @@ -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 | Index: sinfo.adb =================================================================== --- sinfo.adb (revision 165687) +++ sinfo.adb (working copy) @@ -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; Index: sinfo.ads =================================================================== --- sinfo.ads (revision 165687) +++ sinfo.ads (working copy) @@ -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) Index: sem.adb =================================================================== --- sem.adb (revision 165687) +++ sem.adb (working copy) @@ -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); Index: par-ch4.adb =================================================================== --- par-ch4.adb (revision 165692) +++ par-ch4.adb (working copy) @@ -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 -- --------------------------- Index: sem_res.adb =================================================================== --- sem_res.adb (revision 165694) +++ sem_res.adb (working copy) @@ -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 -- ------------------- Index: expander.adb =================================================================== --- expander.adb (revision 165687) +++ expander.adb (working copy) @@ -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); Index: scans.adb =================================================================== --- scans.adb (revision 165687) +++ scans.adb (working copy) @@ -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); Index: scans.ads =================================================================== --- scans.ads (revision 165687) +++ scans.ads (working copy) @@ -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 Index: par.adb =================================================================== --- par.adb (revision 165687) +++ par.adb (working copy) @@ -703,6 +703,10 @@ function Par (Configuration_Pragmas : Bo 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 : Bo 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. Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 165696) +++ exp_ch4.adb (working copy) @@ -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 -- --------------------------------- Index: exp_ch4.ads =================================================================== --- exp_ch4.ads (revision 165687) +++ exp_ch4.ads (working copy) @@ -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); Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 165687) +++ sem_ch4.adb (working copy) @@ -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 -- ------------------- Index: sem_ch4.ads =================================================================== --- sem_ch4.ads (revision 165687) +++ sem_ch4.ads (working copy) @@ -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); Index: scn.adb =================================================================== --- scn.adb (revision 165687) +++ scn.adb (working copy) @@ -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; Index: sprint.adb =================================================================== --- sprint.adb (revision 165687) +++ sprint.adb (working copy) @@ -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 Index: par-ch3.adb =================================================================== --- par-ch3.adb (revision 165687) +++ par-ch3.adb (working copy) @@ -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; Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 165694) +++ snames.ads-tmpl (working copy) @@ -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 + $; Index: par-ch5.adb =================================================================== --- par-ch5.adb (revision 165687) +++ par-ch5.adb (working copy) @@ -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;