From 75ef962565fe3f763a5e087399b6dd69fa200ced Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 22 Oct 2010 10:00:18 +0000 Subject: [PATCH] 2010-10-22 Thomas Quinot * exp_ch5.adb, sem_ch5.adb, sinfo.ads, snames.ads-tmpl, par-ch5.adb: Minor reformatting. 2010-10-22 Geert Bosch * stand.ads: Fix typo in comment. 2010-10-22 Ed Schonberg * sem_ch6.adb: Enable in-out parameter for functions. 2010-10-22 Ed Schonberg * sem_ch4.adb (Analyze_Quantified_Expression): Handle properly loop iterators that are transformed into container iterators after analysis. * exp_ch4.adb (Expand_N_Quantified_Expression): Handle properly both iterator forms before rewriting as a loop. 2010-10-22 Brett Porter * a-locale.adb, a-locale.ads, locales.c: New files. * Makefile.rtl: Add a-locale * gcc-interface/Makefile.in: Add locales.c git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165812 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 26 ++++++ gcc/ada/Makefile.rtl | 1 + gcc/ada/a-locale.adb | 65 +++++++++++++++ gcc/ada/a-locale.ads | 31 ++++++++ gcc/ada/exp_ch4.adb | 33 ++++++-- gcc/ada/exp_ch5.adb | 161 ++++++++++++++++++++------------------ gcc/ada/gcc-interface/Makefile.in | 9 ++- gcc/ada/locales.c | 56 +++++++++++++ gcc/ada/par-ch5.adb | 17 ++-- gcc/ada/sem_ch4.adb | 26 +++++- gcc/ada/sem_ch5.adb | 54 +++++++------ gcc/ada/sem_ch6.adb | 14 +++- gcc/ada/sinfo.ads | 25 +++--- gcc/ada/snames.ads-tmpl | 2 +- gcc/ada/stand.ads | 6 +- 15 files changed, 385 insertions(+), 141 deletions(-) create mode 100644 gcc/ada/a-locale.adb create mode 100644 gcc/ada/a-locale.ads create mode 100644 gcc/ada/locales.c diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 04e8a0ec7bb..7b62fc22d1c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2010-10-22 Thomas Quinot + + * exp_ch5.adb, sem_ch5.adb, sinfo.ads, snames.ads-tmpl, par-ch5.adb: + Minor reformatting. + +2010-10-22 Geert Bosch + + * stand.ads: Fix typo in comment. + +2010-10-22 Ed Schonberg + + * sem_ch6.adb: Enable in-out parameter for functions. + +2010-10-22 Ed Schonberg + + * sem_ch4.adb (Analyze_Quantified_Expression): Handle properly loop + iterators that are transformed into container iterators after analysis. + * exp_ch4.adb (Expand_N_Quantified_Expression): Handle properly both + iterator forms before rewriting as a loop. + +2010-10-22 Brett Porter + + * a-locale.adb, a-locale.ads, locales.c: New files. + * Makefile.rtl: Add a-locale + * gcc-interface/Makefile.in: Add locales.c + 2010-10-22 Robert Dewar * sem_util.ads, sem_util.adb, sem_aux.ads, sem_aux.adb diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 4989e794370..229724c2b1c 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -158,6 +158,7 @@ GNATRTL_NONTASKING_OBJS= \ a-llitio$(objext) \ a-lliwti$(objext) \ a-llizti$(objext) \ + a-locale$(objext) \ a-ncelfu$(objext) \ a-ngcefu$(objext) \ a-ngcoty$(objext) \ diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb new file mode 100644 index 00000000000..64c51256ad1 --- /dev/null +++ b/gcc/ada/a-locale.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O C A L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +package body Ada.Locales is + + type Lower_4 is array (1 .. 4) of Character range 'a' .. 'z'; + type Upper_4 is array (1 .. 4) of Character range 'A' .. 'Z'; + + -------------- + -- Language -- + -------------- + + function Language return Language_Code is + procedure C_Get_Language_Code (P : Address); + pragma Import (C, C_Get_Language_Code); + F : Lower_4; + begin + C_Get_Language_Code (F (1)'Address); + return Language_Code (F (1 .. 3)); + end Language; + + ------------- + -- Country -- + ------------- + + function Country return Country_Code is + procedure C_Get_Country_Code (P : Address); + pragma Import (C, C_Get_Country_Code); + F : Upper_4; + begin + C_Get_Country_Code (F (1)'Address); + return Country_Code (F (1 .. 2)); + end Country; + +end Ada.Locales; diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads new file mode 100644 index 00000000000..629f367bb6c --- /dev/null +++ b/gcc/ada/a-locale.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O C A L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Locales is + pragma Preelaborate (Locales); + pragma Remote_Types (Locales); + + type Language_Code is array (1 .. 3) of Character range 'a' .. 'z'; + type Country_Code is array (1 .. 2) of Character range 'A' .. 'Z'; + + Language_Unknown : constant Language_Code := "und"; + Country_Unknown : constant Country_Code := "ZZ"; + + function Language return Language_Code; + function Country return Country_Code; + +end Ada.Locales; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 613e9c831b6..31a43db6ba1 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7428,13 +7428,13 @@ package body Exp_Ch4 is 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; + Actions : List_Id; + Decl : Node_Id; + I_Scheme : Node_Id; + Test : Node_Id; + Tnn : Entity_Id; -- We expand: @@ -7460,6 +7460,9 @@ package body Exp_Ch4 is -- end if; -- end loop; + -- In both cases, the iteration may be over a container, in which + -- case it is given by an iterator specification, not a loop. + begin Actions := New_List; Tnn := Make_Temporary (Loc, 'T'); @@ -7496,14 +7499,28 @@ package body Exp_Ch4 is Make_Exit_Statement (Loc))); end if; + if Present (Loop_Parameter_Specification (N)) then + I_Scheme := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Loop_Parameter_Specification (N)); + else + I_Scheme := + Make_Iteration_Scheme (Loc, + Iterator_Specification => Iterator_Specification (N)); + end if; + Append_To (Actions, Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => Iterator), + Iteration_Scheme => I_Scheme, Statements => New_List (Test), End_Label => Empty)); + -- The components of the scheme have already been analyzed, and the + -- loop index declaration has been processed. + + Set_Analyzed (Iteration_Scheme (Last (Actions))); + Rewrite (N, Make_Expression_With_Actions (Loc, Expression => New_Occurrence_Of (Tnn, Loc), diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 48e6238fac7..b0a4d496223 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -104,8 +104,8 @@ package body Exp_Ch5 is -- might be filled with components from child types). procedure Expand_Iterator_Loop (N : Node_Id); - -- Expand loops over arrays and containers that use the form "for X of C" - -- with an optional subtype mark, and "for Y in C". + -- Expand loop over arrays and containers that uses the form "for X of C" + -- with an optional subtype mark, or "for Y in C". function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; -- Generate the necessary code for controlled and tagged assignment, that @@ -2773,71 +2773,77 @@ package body Exp_Ch5 is if Of_Present (I_Spec) then Cursor := Make_Temporary (Loc, 'C'); - -- For Elem of Arr loop .. + -- for Elem of Arr loop ... declare Decl : constant Node_Id := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, - Subtype_Mark => + Subtype_Mark => New_Occurrence_Of (Component_Type (Typ), Loc), - Name => Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (Container, Loc), - Expressions => - New_List (New_Occurrence_Of (Cursor, Loc)))); + Name => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (Container, Loc), + Expressions => + New_List (New_Occurrence_Of (Cursor, Loc)))); begin Stats := Statements (N); Prepend (Decl, Stats); - New_Loop := Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Cursor, - Discrete_Subtype_Definition => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Container, Loc), - Attribute_Name => Name_Range), - Reverse_Present => Reverse_Present (I_Spec))), - Statements => Stats, - End_Label => Empty); + New_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Cursor, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Container, Loc), + Attribute_Name => Name_Range), + Reverse_Present => Reverse_Present (I_Spec))), + Statements => Stats, + End_Label => Empty); end; else - -- For Index in Array loop - -- - -- The cursor (index into the array) is the source Id. + -- for Index in Array loop ... + + -- The cursor (index into the array) is the source Id Cursor := Id; - New_Loop := Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Cursor, - Discrete_Subtype_Definition => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Container, Loc), - Attribute_Name => Name_Range), - Reverse_Present => Reverse_Present (I_Spec))), - Statements => Statements (N), - End_Label => Empty); + New_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Cursor, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Container, Loc), + Attribute_Name => Name_Range), + Reverse_Present => Reverse_Present (I_Spec))), + Statements => Statements (N), + End_Label => Empty); end if; else - -- Iterators over containers. In both cases these require a - -- cursor of the proper type. + -- Iterators over containers. In both cases these require a cursor of + -- the proper type. -- Cursor : P.Cursor_Type := Container.First; -- while Cursor /= P.No_Element loop - -- -- for the "of" form, the element name renames - -- -- the element denoted by the cursor. - -- Obj : P.Element_Type renames Element (Cursor); + -- -- For the "of" form, the element name renames the element + -- -- designated by the cursor. + -- Statements; -- P.Next (Cursor); -- end loop; @@ -2879,28 +2885,28 @@ package body Exp_Ch5 is -- C : Cursor_Type := Container.First; - Cursor_Decl := Make_Object_Declaration (Loc, - Defining_Identifier => Cursor, - Object_Definition => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pack, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Cursor)), - Expression => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Container, Loc), - Selector_Name => Make_Identifier (Loc, Name_Init))); + Cursor_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Cursor, + Object_Definition => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => Make_Identifier (Loc, Name_Cursor)), + Expression => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Container, Loc), + Selector_Name => Make_Identifier (Loc, Name_Init))); Insert_Action (N, Cursor_Decl); -- while C /= No_Element loop Cond := Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Cursor, Loc), - Right_Opnd => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pack, Loc), - Selector_Name => Make_Identifier (Loc, - Chars => Name_No_Element))); + Left_Opnd => New_Occurrence_Of (Cursor, Loc), + Right_Opnd => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => + Make_Identifier (Loc, Chars => Name_No_Element))); if Of_Present (I_Spec) then @@ -2909,39 +2915,44 @@ package body Exp_Ch5 is Renaming_Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, - Subtype_Mark => New_Occurrence_Of (Element_Type, Loc), - Name => Make_Indexed_Component (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pack, Loc), - Selector_Name => - Make_Identifier (Loc, Chars => Name_Element)), - Expressions => - New_List (New_Occurrence_Of (Cursor, Loc)))); + Subtype_Mark => + New_Occurrence_Of (Element_Type, Loc), + Name => + Make_Indexed_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => + Make_Identifier (Loc, Chars => Name_Element)), + Expressions => + New_List (New_Occurrence_Of (Cursor, Loc)))); Prepend (Renaming_Decl, Stats); end if; - -- For both iterator forms, add call to Next to advance cursor. + -- For both iterator forms, add call to step operation (Next or + -- Previous) to advance cursor. Append_To (Stats, Make_Procedure_Call_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Pack, Loc), - Selector_Name => Make_Identifier (Loc, Name_Step)), + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Pack, Loc), + Selector_Name => Make_Identifier (Loc, Name_Step)), Parameter_Associations => New_List (New_Occurrence_Of (Cursor, Loc)))); New_Loop := Make_Loop_Statement (Loc, Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Condition => Cond), - Statements => Stats, - End_Label => Empty); + Make_Iteration_Scheme (Loc, Condition => Cond), + Statements => Stats, + End_Label => Empty); end; end if; -- Set_Analyzed (I_Spec); + -- Why is this commented out??? + Rewrite (N, New_Loop); Analyze (N); end Expand_Iterator_Loop; diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 31693bc2534..f4a5c235f0d 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -2215,13 +2215,13 @@ endif LIBGNAT_SRCS = adadecode.c adadecode.h adaint.c adaint.h \ argv.c cio.c cstreams.c errno.c exit.c cal.c ctrl_c.c env.c env.h \ arit64.c raise.h raise.c sysdep.c aux-io.c init.c initialize.c \ - seh_init.c final.c tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c \ - expect.c mkdir.c socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS) + locales.c seh_init.c final.c tracebak.c tb-alvms.c tb-alvxw.c \ + tb-gcc.c expect.c mkdir.c socket.c gsocket.h targext.c $(EXTRA_LIBGNAT_SRCS) LIBGNAT_OBJS = adadecode.o adaint.o argv.o cio.o cstreams.o ctrl_c.o \ errno.o exit.o env.o raise.o sysdep.o aux-io.o init.o initialize.o \ - seh_init.o cal.o arit64.o final.o tracebak.o expect.o mkdir.o \ - socket.o targext.o $(EXTRA_LIBGNAT_OBJS) + locales.o seh_init.o cal.o arit64.o final.o tracebak.o expect.o \ + mkdir.o socket.o targext.o $(EXTRA_LIBGNAT_OBJS) # NOTE ??? - when the -I option for compiling Ada code is made to work, # the library installation will change and there will be a @@ -2757,6 +2757,7 @@ exit.o : adaint.h exit.c expect.o : expect.c final.o : final.c link.o : link.c +locales.o : locales.c mkdir.o : mkdir.c socket.o : socket.c gsocket.h sysdep.o : sysdep.c diff --git a/gcc/ada/locales.c b/gcc/ada/locales.c new file mode 100644 index 00000000000..ba649e2b08b --- /dev/null +++ b/gcc/ada/locales.c @@ -0,0 +1,56 @@ +/**************************************************************************** + * * + * GNAT COMPILER COMPONENTS * + * * + * L O C A L E S * + * * + * C Implementation File * + * * + * Copyright (C) 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- * + * ware Foundation; either version 3, or (at your option) any later ver- * + * sion. GNAT is distributed in the hope that it will be useful, but WITH- * + * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * + * or FITNESS FOR A PARTICULAR PURPOSE. * + * * + * As a special exception under Section 7 of GPL version 3, you are granted * + * additional permissions described in the GCC Runtime Library Exception, * + * version 3.1, as published by the Free Software Foundation. * + * * + * You should have received a copy of the GNU General Public License and * + * a copy of the GCC Runtime Library Exception along with this program; * + * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * + * . * + * * + * GNAT was originally developed by the GNAT team at New York University. * + * Extensive contributions were provided by Ada Core Technologies Inc. * + * * + ****************************************************************************/ + +/* This file provides OS-dependent support for the Ada.Locales package. */ + +typedef char char4 [4]; + +/* + c_get_language_code needs to fill in the Alpha-3 encoding of the + language code (3 lowercase letters). That shoud be "und" if the + language is unknown. [see Ada.Locales] +*/ +void c_get_language_code (char4 p) { + char *r = "und"; + for (; *r != '\0'; p++, r++) + *p = *r; +} + +/* + c_get_country_code needs to fill in the Alpha-2 encoding of the + country code (2 uppercase letters). That shoud be "ZZ" if the + country is unknown. [see Ada.Locales] +*/ +void c_get_country_code (char4 p) { + char *r = "ZZ"; + for (; *r != '\0'; p++, r++) + *p = *r; +} diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index e6f28c9efba..de5883a281b 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1571,8 +1571,7 @@ package body Ch5 is Iter_Scheme_Node := New_Node (N_Iteration_Scheme, Token_Ptr); Spec := P_Loop_Parameter_Specification; if Nkind (Spec) = N_Loop_Parameter_Specification then - Set_Loop_Parameter_Specification - (Iter_Scheme_Node, Spec); + Set_Loop_Parameter_Specification (Iter_Scheme_Node, Spec); else Set_Iterator_Specification (Iter_Scheme_Node, Spec); end if; @@ -1701,18 +1700,16 @@ package body Ch5 is Save_Scan_State (Scan_State); ID_Node := P_Defining_Identifier (C_In); - -- If the next token is OF it indicates the Ada2012 iterator. If the - -- next token is a colon, the iterator includes a subtype indication - -- for the bound variable of the iteration. Otherwise we parse the - -- construct as a loop parameter specification. Note that the form: + -- If the next token is OF, it indicates an Ada 2012 iterator. If the + -- next token is a colon, this is also an Ada 2012 iterator, including a + -- subtype indication for the loop parameter. Otherwise we parse the + -- construct as a loop parameter specification. Note that the form -- "for A in B" is ambiguous, and must be resolved semantically: if B -- is a discrete subtype this is a loop specification, but if it is an -- expression it is an iterator specification. Ambiguity is resolved -- during analysis of the loop parameter specification. - if Token = Tok_Of - or else Token = Tok_Colon - then + if Token = Tok_Of or else Token = Tok_Colon then return P_Iterator_Specification (ID_Node); end if; @@ -1765,8 +1762,10 @@ package body Ch5 is if Token = Tok_Of then Set_Of_Present (Node1); Scan; -- past OF + elsif Token = Tok_In then Scan; -- past IN + else return Error; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 2c4bbe79037..ab33375d533 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3198,12 +3198,32 @@ package body Sem_Ch4 is Set_Etype (Ent, Standard_Void_Type); Set_Parent (Ent, N); - Iterator := - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => Loop_Parameter_Specification (N)); + if Present (Loop_Parameter_Specification (N)) then + Iterator := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Loop_Parameter_Specification (N)); + else + Iterator := + Make_Iteration_Scheme (Loc, + Iterator_Specification => + Iterator_Specification (N)); + end if; Push_Scope (Ent); + Set_Parent (Iterator, N); Analyze_Iteration_Scheme (Iterator); + + -- The loop specification may have been converted into an + -- iterator specification during its analysis. Update the + -- quantified node accordingly. + + if Present (Iterator_Specification (Iterator)) then + Set_Iterator_Specification + (N, Iterator_Specification (Iterator)); + Set_Loop_Parameter_Specification (N, Empty); + end if; + Analyze (Condition (N)); End_Scope; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index a303807a80d..a4963be815d 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1809,16 +1809,20 @@ package body Sem_Ch5 is and then not Is_Type (Entity (DS))) then - -- this is an iterator specification. Rewrite as - -- such and analyze. + -- This is an iterator specification. Rewrite as such + -- and analyze. declare I_Spec : constant Node_Id := - Make_Iterator_Specification (Sloc (LP), - Defining_Identifier => Relocate_Node (Id), - Name => Relocate_Node (DS), - Subtype_Indication => Empty, - Reverse_Present => Reverse_Present (LP)); + Make_Iterator_Specification (Sloc (LP), + Defining_Identifier => + Relocate_Node (Id), + Name => + Relocate_Node (DS), + Subtype_Indication => + Empty, + Reverse_Present => + Reverse_Present (LP)); begin Set_Iterator_Specification (N, I_Spec); @@ -1833,8 +1837,8 @@ package body Sem_Ch5 is return; end if; - -- The subtype indication may denote the completion - -- of an incomplete type declaration. + -- The subtype indication may denote the completion of an + -- incomplete type declaration. if Is_Entity_Name (DS) and then Present (Entity (DS)) @@ -1854,8 +1858,8 @@ package body Sem_Ch5 is Make_Index (DS, LP); - Set_Ekind (Id, E_Loop_Parameter); - Set_Etype (Id, Etype (DS)); + Set_Ekind (Id, E_Loop_Parameter); + Set_Etype (Id, Etype (DS)); -- Treat a range as an implicit reference to the type, to -- inhibit spurious warnings. @@ -1879,9 +1883,7 @@ package body Sem_Ch5 is -- instances, because in practice they tend to be dubious -- in these cases. - if Nkind (DS) = N_Range - and then Comes_From_Source (N) - then + if Nkind (DS) = N_Range and then Comes_From_Source (N) then declare L : constant Node_Id := Low_Bound (DS); H : constant Node_Id := High_Bound (DS); @@ -1893,9 +1895,9 @@ package body Sem_Ch5 is (L, H, Assume_Valid => True) = GT then -- Suppress the warning if inside a generic - -- template or instance, since in practice - -- they tend to be dubious in these cases since - -- they can result from intended parametrization. + -- template or instance, since in practice they + -- tend to be dubious in these cases since they can + -- result from intended parametrization. if not Inside_A_Generic and then not In_Instance @@ -1937,20 +1939,20 @@ package body Sem_Ch5 is -- In either case, suppress warnings in the body of -- the loop, since it is likely that these warnings -- will be inappropriate if the loop never actually - -- executes, which is unlikely. + -- executes, which is likely. Set_Suppress_Loop_Warnings (Parent (N)); -- The other case for a warning is a reverse loop - -- where the upper bound is the integer literal - -- zero or one, and the lower bound can be positive. + -- where the upper bound is the integer literal zero + -- or one, and the lower bound can be positive. -- For example, we have -- for J in reverse N .. 1 loop - -- In practice, this is very likely to be a case - -- of reversing the bounds incorrectly in the range. + -- In practice, this is very likely to be a case of + -- reversing the bounds incorrectly in the range. elsif Reverse_Present (LP) and then Nkind (Original_Node (H)) = @@ -2002,13 +2004,13 @@ package body Sem_Ch5 is end if; else - -- Iteration over a container. + -- Iteration over a container Set_Ekind (Def_Id, E_Loop_Parameter); if Of_Present (N) then - -- Find the Element_Type in the package instance that defines - -- the container type. + -- Find the Element_Type in the package instance that defines the + -- container type. Ent := First_Entity (Scope (Typ)); while Present (Ent) loop @@ -2022,7 +2024,7 @@ package body Sem_Ch5 is else - -- Find the Cursor type in similar fashion. + -- Find the Cursor type in similar fashion Ent := First_Entity (Scope (Typ)); while Present (Ent) loop diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index f5853685f0b..88918f3d179 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9365,8 +9365,18 @@ package body Sem_Ch6 is if Ekind (Scope (Formal_Id)) = E_Function or else Ekind (Scope (Formal_Id)) = E_Generic_Function then - Error_Msg_N ("functions can only have IN parameters", Spec); - Set_Ekind (Formal_Id, E_In_Parameter); + + if Ada_Version >= Ada_2012 then + if In_Present (Spec) then + Set_Ekind (Formal_Id, E_In_Out_Parameter); + else + Set_Ekind (Formal_Id, E_Out_Parameter); + end if; + + else + Error_Msg_N ("functions can only have IN parameters", Spec); + Set_Ekind (Formal_Id, E_In_Parameter); + end if; elsif In_Present (Spec) then Set_Ekind (Formal_Id, E_In_Out_Parameter); diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 2b145cca14c..3608ad88dcf 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1545,7 +1545,7 @@ package Sinfo is -- Initialize_Scalars and Normalize_Scalars. -- Of_Present (Flag16) - -- Present in N_Iterastor_Specification nodes, to mark the Ada2012 iterator + -- Present in N_Iterator_Specification nodes, to mark the Ada 2012 iterator -- form over arrays and containers. -- Original_Discriminant (Node2-Sem) @@ -3826,14 +3826,17 @@ package Sinfo is --------------------------------- -- QUANTIFIED_EXPRESSION ::= - -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE | - -- for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE + -- for QUANTIFIER LOOP_PARAMETER_SPECIFICATION => PREDICATE + -- | for QUANTIFIER ITERATOR_SPECIFICATION => PREDICATE -- -- QUANTIFIER ::= all | some + -- At most one of (Iterator_Specification, Loop_Parameter_Specification) + -- is present at a time, in which case the other one is empty. + -- N_Quantified_Expression -- Sloc points to FOR - -- Iterator_Specification (Node2) (set to Empty if not Present) + -- Iterator_Specification (Node2) -- Loop_Parameter_Specification (Node4) -- Condition (Node1) -- All_Present (Flag15) @@ -4169,11 +4172,13 @@ package Sinfo is -------------------------- -- ITERATION_SCHEME ::= - -- while CONDITION | for LOOP_PARAMETER_SPECIFICATION | - -- for ITERATOR_SPECIFICATION + -- while CONDITION + -- | for LOOP_PARAMETER_SPECIFICATION + -- | for ITERATOR_SPECIFICATION - -- Only one of (Iterator_Specification, Loop_Parameter_Specification) - -- is present at a time, the other one is empty. + -- At most one of (Iterator_Specification, Loop_Parameter_Specification) + -- is present at a time, in which case the other one is empty. Both are + -- empty in the case of a WHILE loop. -- Gigi restriction: This expander ensures that the type of the -- Condition field is always Standard.Boolean, even if the type @@ -4183,7 +4188,7 @@ package Sinfo is -- Sloc points to WHILE or FOR -- Condition (Node1) (set to Empty if FOR case) -- Condition_Actions (List3-Sem) - -- Iterator_Specification (Node2) (set to Empty if not Present) + -- Iterator_Specification (Node2) (set to Empty if WHILE case) -- Loop_Parameter_Specification (Node4) (set to Empty if WHILE case) --------------------------------------- @@ -4205,7 +4210,7 @@ package Sinfo is -- ITERATOR_SPECIFICATION ::= -- DEFINING_IDENTIFIER in [reverse] NAME - -- DEFINING_IDENTIFIER [: SUBTYPE_INDICATION] of [reverse] NAME + -- | DEFINING_IDENTIFIER [: SUBTYPE_INDICATION] of [reverse] NAME -- N_Iterator_Specification -- Sloc points to defining identifier diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 91f50e46712..1a5eb033e1e 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1198,7 +1198,7 @@ package Snames is Name_Unaligned_Valid : constant Name_Id := N + $; - -- Names used to implement iterators over predefined containers. + -- Names used to implement iterators over predefined containers Name_Cursor : constant Name_Id := N + $; Name_Element : constant Name_Id := N + $; diff --git a/gcc/ada/stand.ads b/gcc/ada/stand.ads index f2fadccad8e..46bbe4cb8d3 100644 --- a/gcc/ada/stand.ads +++ b/gcc/ada/stand.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -413,9 +413,9 @@ package Stand is Universal_Real : Entity_Id; -- Entity for universal real type. The bounds of this type correspond to - -- to the largest supported real type (i.e. Long_Long_Real). It is the + -- to the largest supported real type (i.e. Long_Long_Float). It is the -- type used for runtime calculations in type universal real. Note that - -- this type is always IEEE format, even if Long_Long_Real is Vax_Float + -- this type is always IEEE format, even if Long_Long_Float is Vax_Float -- (and in that case the bounds don't correspond exactly). Universal_Fixed : Entity_Id; -- 2.11.0