From ebd34478e30a770aa741cf345f08278090770ded Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 26 Jan 2010 10:42:04 +0100 Subject: [PATCH] [multiple changes] 2010-01-26 Robert Dewar * s-commun.ads, s-osprim-mingw.adb, s-stchop-vxworks.adb, sem_aggr.adb, s-vxwext.adb, sem_ch10.adb, sem_eval.adb, sem_prag.adb: Minor reformatting. 2010-01-26 Vasiliy Fofanov * g-regist.adb, g-regist.ads (For_Every_Key): New generic procedure that allows to iterate over all subkeys of a key. 2010-01-26 Ed Falis * sysdep.c: enable NFS for VxWorks MILS * env.c: enable __gnat_environ for VxWorks MILS * gcc-interface/Makefile.in: Add VxWorks MILS target pairs. From-SVN: r156233 --- gcc/ada/ChangeLog | 17 +++++ gcc/ada/env.c | 12 ++-- gcc/ada/g-regist.adb | 79 +++++++++++++++++++++++- gcc/ada/g-regist.ads | 16 +++++ gcc/ada/gcc-interface/Makefile.in | 58 ++++++++++++++++-- gcc/ada/s-commun.ads | 1 + gcc/ada/s-osprim-mingw.adb | 4 ++ gcc/ada/s-stchop-vxworks.adb | 5 +- gcc/ada/s-vxwext.adb | 3 - gcc/ada/sem_aggr.adb | 126 +++++++++++++++++++------------------- gcc/ada/sem_ch10.adb | 4 ++ gcc/ada/sem_eval.adb | 4 +- gcc/ada/sem_prag.adb | 7 +-- gcc/ada/sysdep.c | 4 +- 14 files changed, 254 insertions(+), 86 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a4399d2..2beda29 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2010-01-26 Robert Dewar + + * s-commun.ads, s-osprim-mingw.adb, s-stchop-vxworks.adb, sem_aggr.adb, + s-vxwext.adb, sem_ch10.adb, sem_eval.adb, sem_prag.adb: Minor + reformatting. + +2010-01-26 Vasiliy Fofanov + + * g-regist.adb, g-regist.ads (For_Every_Key): New generic procedure + that allows to iterate over all subkeys of a key. + +2010-01-26 Ed Falis + + * sysdep.c: enable NFS for VxWorks MILS + * env.c: enable __gnat_environ for VxWorks MILS + * gcc-interface/Makefile.in: Add VxWorks MILS target pairs. + 2010-01-25 Bob Duff * sem_aggr.adb (Resolve_Array_Aggregate): Check for the case where this diff --git a/gcc/ada/env.c b/gcc/ada/env.c index d948697..c8b49eb 100644 --- a/gcc/ada/env.c +++ b/gcc/ada/env.c @@ -52,7 +52,8 @@ #include #endif -#if defined (__vxworks) && ! (defined (__RTP__) || defined (__COREOS__)) +#if defined (__vxworks) \ + && ! (defined (__RTP__) || defined (__COREOS__) || defined (__VXWORKSMILS__)) #include "envLib.h" extern char** ppGlobalEnviron; #endif @@ -198,7 +199,8 @@ __gnat_setenv (char *name, char *value) char ** __gnat_environ (void) { -#if defined (VMS) || defined (RTX) || defined (VTHREADS) +#if defined (VMS) || defined (RTX) \ + || (defined (VTHREADS) && ! defined (__VXWORKSMILS__)) /* Not implemented */ return NULL; #elif defined (__APPLE__) @@ -210,9 +212,11 @@ __gnat_environ (void) extern char **_environ; return _environ; #else -#if ! (defined (__vxworks) && ! (defined (__RTP__) || defined (__COREOS__))) +#if ! (defined (__vxworks) \ + && ! (defined (__RTP__) || defined (__COREOS__) \ + || defined (__VXWORKSMILS__))) /* in VxWorks kernel mode environ is macro and not a variable */ - /* same thing on 653 in the CoreOS */ + /* same thing on 653 in the CoreOS and for VxWorks MILS vThreads */ extern char **environ; #endif return environ; diff --git a/gcc/ada/g-regist.adb b/gcc/ada/g-regist.adb index c04248e..44dd8db 100644 --- a/gcc/ada/g-regist.adb +++ b/gcc/ada/g-regist.adb @@ -122,6 +122,13 @@ package body GNAT.Registry is cbData : DWORD) return LONG; pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA"); + function RegEnumKey + (Key : HKEY; + dwIndex : DWORD; + lpName : Address; + cchName : DWORD) return LONG; + pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA"); + --------------------- -- Local Constants -- --------------------- @@ -231,6 +238,75 @@ package body GNAT.Registry is Check_Result (Result, "Delete_Value " & Sub_Key); end Delete_Value; + ------------------- + -- For_Every_Key -- + ------------------- + + procedure For_Every_Key + (From_Key : HKEY; + Recursive : Boolean := False) + is + procedure Recursive_For_Every_Key + (From_Key : HKEY; + Recursive : Boolean := False; + Quit : in out Boolean); + + procedure Recursive_For_Every_Key + (From_Key : HKEY; + Recursive : Boolean := False; + Quit : in out Boolean) + is + + use type LONG; + use type ULONG; + + Index : ULONG := 0; + Result : LONG; + + Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size); + pragma Warnings (Off, Sub_Key); + + Size_Sub_Key : aliased ULONG; + Sub_Hkey : HKEY; + + function Current_Name return String; + + function Current_Name return String is + begin + return Interfaces.C.To_Ada (Sub_Key); + end Current_Name; + + begin + loop + Size_Sub_Key := Sub_Key'Length; + + Result := + RegEnumKey + (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key); + + exit when not (Result = ERROR_SUCCESS); + + Action (Natural (Index) + 1, From_Key, Current_Name, Quit); + + exit when Quit; + + if Recursive then + Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key)); + Recursive_For_Every_Key (Sub_Hkey, True, Quit); + Close_Key (Sub_Hkey); + end if; + + exit when Quit; + + Index := Index + 1; + end loop; + end Recursive_For_Every_Key; + + Quit : Boolean := False; + begin + Recursive_For_Every_Key (From_Key, Recursive, Quit); + end For_Every_Key; + ------------------------- -- For_Every_Key_Value -- ------------------------- @@ -394,7 +470,8 @@ package body GNAT.Registry is if Type_Value = REG_EXPAND_SZ and then Expand then return Directory_Operations.Expand_Path - (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS); + (Value (1 .. Integer (Size_Value - 1)), + Directory_Operations.DOS); else return Value (1 .. Integer (Size_Value - 1)); end if; diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads index d7488a9..52dc6aa 100644 --- a/gcc/ada/g-regist.ads +++ b/gcc/ada/g-regist.ads @@ -110,6 +110,19 @@ package GNAT.Registry is generic with procedure Action + (Index : Positive; + Key : HKEY; + Key_Name : String; + Quit : in out Boolean); + procedure For_Every_Key (From_Key : HKEY; Recursive : Boolean := False); + -- Iterates over all the keys registered under From_Key, recursively if + -- Recursive is set to True. Index will be set to 1 for the first key and + -- will be incremented by one in each iteration. The current key of an + -- iteration is set in Key, and its name - in Key_Name. Quit can be set + -- to True to stop iteration; its initial value is False. + + generic + with procedure Action (Index : Positive; Sub_Key : String; Value : String; @@ -126,6 +139,9 @@ package GNAT.Registry is -- with this case. Furthermore, if Expand is set to True and the Sub_Key -- is a REG_EXPAND_SZ the returned value will have the %name% variables -- replaced by the corresponding environment variable value. + -- + -- This iterator can be used in conjunction with For_Every_Key in + -- order to analyze all subkeys and values of a given registry key. private diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 41fd39a..53200a3 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -536,7 +536,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) EXTRA_LIBGNAT_OBJS+=vx_stack_info.o endif -# vxworksae / vxworks 653 +# vxworks 653 ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) # target pairs for vthreads runtime LIBGNAT_TARGET_PAIRS = \ @@ -599,8 +599,59 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) endif endif -# vxworksae / vxworks 653 for x86 (vxsim) -ifeq ($(strip $(filter-out %86 wrs vxworksae,$(targ))),) +# vxworks MILS +ifeq ($(strip $(filter-out powerpc% wrs vxworksmils,$(targ))),) + # target pairs for vthreads runtime + LIBGNAT_TARGET_PAIRS = \ + a-intnam.ads 0 then @@ -2179,7 +2178,7 @@ package body Sem_Aggr is -- bounds. if Present (Aggregate_Bounds (N)) and then not Others_Allowed then - Aggr_Low := Low_Bound (Aggregate_Bounds (N)); + Aggr_Low := Low_Bound (Aggregate_Bounds (N)); Aggr_High := High_Bound (Aggregate_Bounds (N)); end if; @@ -2208,20 +2207,20 @@ package body Sem_Aggr is -- There are two cases to consider: - -- a) If the ancestor part is a type mark, the components needed are - -- the difference between the components of the expected type and the + -- a) If the ancestor part is a type mark, the components needed are the + -- difference between the components of the expected type and the -- components of the given type mark. - -- b) If the ancestor part is an expression, it must be unambiguous, - -- and once we have its type we can also compute the needed components - -- as in the previous case. In both cases, if the ancestor type is not - -- the immediate ancestor, we have to build this ancestor recursively. + -- b) If the ancestor part is an expression, it must be unambiguous, and + -- once we have its type we can also compute the needed components as in + -- the previous case. In both cases, if the ancestor type is not the + -- immediate ancestor, we have to build this ancestor recursively. - -- In both cases discriminants of the ancestor type do not play a - -- role in the resolution of the needed components, because inherited - -- discriminants cannot be used in a type extension. As a result we can - -- compute independently the list of components of the ancestor type and - -- of the expected type. + -- In both cases discriminants of the ancestor type do not play a role in + -- the resolution of the needed components, because inherited discriminants + -- cannot be used in a type extension. As a result we can compute + -- independently the list of components of the ancestor type and of the + -- expected type. procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is A : constant Node_Id := Ancestor_Part (N); @@ -2231,8 +2230,8 @@ package body Sem_Aggr is function Valid_Limited_Ancestor (Anc : Node_Id) return Boolean; -- If the type is limited, verify that the ancestor part is a legal - -- expression (aggregate or function call, including 'Input)) that - -- does not require a copy, as specified in 7.5 (2). + -- expression (aggregate or function call, including 'Input)) that does + -- not require a copy, as specified in 7.5(2). function Valid_Ancestor_Type return Boolean; -- Verify that the type of the ancestor part is a non-private ancestor @@ -2257,9 +2256,7 @@ package body Sem_Aggr is then return True; - elsif - Nkind (Anc) = N_Qualified_Expression - then + elsif Nkind (Anc) = N_Qualified_Expression then return Valid_Limited_Ancestor (Expression (Anc)); else @@ -2281,9 +2278,9 @@ package body Sem_Aggr is return True; -- The base type of the parent type may appear as a private - -- extension if it is declared as such in a parent unit of - -- the current one. For consistency of the subsequent analysis - -- use the partial view for the ancestor part. + -- extension if it is declared as such in a parent unit of the + -- current one. For consistency of the subsequent analysis use + -- the partial view for the ancestor part. elsif Is_Private_Type (Etype (Imm_Type)) and then Present (Full_View (Etype (Imm_Type))) @@ -2305,8 +2302,8 @@ package body Sem_Aggr is -- Start of processing for Resolve_Extension_Aggregate begin - -- Analyze the ancestor part and account for the case where it's - -- a parameterless function call. + -- Analyze the ancestor part and account for the case where it is a + -- parameterless function call. Analyze (A); Check_Parameterless_Call (A); @@ -2410,14 +2407,14 @@ package body Sem_Aggr is and then Nkind (Original_Node (A)) = N_Function_Call then -- If the ancestor part is a dispatching call, it appears - -- statically to be a legal ancestor, but it yields any - -- member of the class, and it is not possible to determine - -- whether it is an ancestor of the extension aggregate (much - -- less which ancestor). It is not possible to determine the - -- required components of the extension part. + -- statically to be a legal ancestor, but it yields any member + -- of the class, and it is not possible to determine whether + -- it is an ancestor of the extension aggregate (much less + -- which ancestor). It is not possible to determine the + -- components of the extension part. - -- This check implements AI-306, which in fact was motivated - -- by an ACT query to the ARG after this test was added. + -- This check implements AI-306, which in fact was motivated by + -- an AdaCore query to the ARG after this test was added. Error_Msg_N ("ancestor part must be statically tagged", A); else @@ -2444,16 +2441,16 @@ package body Sem_Aggr is Component_Elmt : Elmt_Id; Components : constant Elist_Id := New_Elmt_List; - -- Components is the list of the record components whose value must - -- be provided in the aggregate. This list does include discriminants. + -- Components is the list of the record components whose value must be + -- provided in the aggregate. This list does include discriminants. New_Assoc_List : constant List_Id := New_List; New_Assoc : Node_Id; -- New_Assoc_List is the newly built list of N_Component_Association -- nodes. New_Assoc is one such N_Component_Association node in it. - -- Please note that while Assoc and New_Assoc contain the same - -- kind of nodes, they are used to iterate over two different - -- N_Component_Association lists. + -- Note that while Assoc and New_Assoc contain the same kind of nodes, + -- they are used to iterate over two different N_Component_Association + -- lists. Others_Etype : Entity_Id := Empty; -- This variable is used to save the Etype of the last record component @@ -2464,7 +2461,7 @@ package body Sem_Aggr is -- (b) make sure the type of all the components whose value is -- subsumed by the others choice are the same. -- - -- This variable is updated as a side effect of function Get_Value + -- This variable is updated as a side effect of function Get_Value. Is_Box_Present : Boolean := False; Others_Box : Boolean := False; @@ -2480,40 +2477,43 @@ package body Sem_Aggr is Expr : Node_Id; Assoc_List : List_Id; Is_Box_Present : Boolean := False); - -- Builds a new N_Component_Association node which associates - -- Component to expression Expr and adds it to the association - -- list being built, either New_Assoc_List, or the association - -- being built for an inner aggregate. + -- Builds a new N_Component_Association node which associates Component + -- to expression Expr and adds it to the association list being built, + -- either New_Assoc_List, or the association being built for an inner + -- aggregate. function Discr_Present (Discr : Entity_Id) return Boolean; -- If aggregate N is a regular aggregate this routine will return True. -- Otherwise, if N is an extension aggregate, Discr is a discriminant - -- whose value may already have been specified by N's ancestor part, - -- this routine checks whether this is indeed the case and if so - -- returns False, signaling that no value for Discr should appear in the - -- N's aggregate part. Also, in this case, the routine appends to + -- whose value may already have been specified by N's ancestor part. + -- This routine checks whether this is indeed the case and if so returns + -- False, signaling that no value for Discr should appear in N's + -- aggregate part. Also, in this case, the routine appends -- New_Assoc_List Discr the discriminant value specified in the ancestor -- part. + -- Can't parse previous sentence, appends what where??? function Get_Value (Compon : Node_Id; From : List_Id; Consider_Others_Choice : Boolean := False) return Node_Id; - -- Given a record component stored in parameter Compon, the - -- following function returns its value as it appears in the list - -- From, which is a list of N_Component_Association nodes. If no - -- component association has a choice for the searched component, - -- the value provided by the others choice is returned, if there - -- is one and Consider_Others_Choice is set to true. Otherwise - -- Empty is returned. If there is more than one component association - -- giving a value for the searched record component, an error message - -- is emitted and the first found value is returned. + -- Given a record component stored in parameter Compon, the following + -- function returns its value as it appears in the list From, which is + -- a list of N_Component_Association nodes. + -- What is this referring to??? There is no "following function" in + -- sight??? + -- If no component association has a choice for the searched component, + -- the value provided by the others choice is returned, if there is one, + -- and Consider_Others_Choice is set to true. Otherwise Empty is + -- returned. If there is more than one component association giving a + -- value for the searched record component, an error message is emitted + -- and the first found value is returned. -- -- If Consider_Others_Choice is set and the returned expression comes -- from the others choice, then Others_Etype is set as a side effect. - -- An error message is emitted if the components taking their value - -- from the others choice do not have same type. + -- An error message is emitted if the components taking their value from + -- the others choice do not have same type. procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id); -- Analyzes and resolves expression Expr against the Etype of the @@ -2613,7 +2613,7 @@ package body Sem_Aggr is D := First_Discriminant (Ancestor_Typ); while Present (D) loop - -- If Ancestor has already specified Disc value than insert its + -- If Ancestor has already specified Disc value then insert its -- value in the final aggregate. if Original_Record_Component (D) = Orig_Discr then diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 2f61408..8a53d58 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4015,6 +4015,10 @@ package body Sem_Ch10 is -- a with_clause on the same unit as a private with-clause -- on a parent, in which case child unit is visible. + ---------------- + -- In_Context -- + ---------------- + function In_Context return Boolean is begin Clause := diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index c63a1cc..f38e059 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1915,9 +1915,7 @@ package body Sem_Eval is -- are error cases where this is not the case), then see if we -- can do a constant evaluation of the array reference. - if Is_Array_Type (Atyp) - and then Atyp /= Any_Composite - then + if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then if Ekind (Atyp) = E_String_Literal_Subtype then Lbd := String_Literal_Low_Bound (Atyp); else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 1e742e5..d49ebd1 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5265,16 +5265,15 @@ package body Sem_Prag is if Is_Entity_Name (Exp) then null; - -- Determine the string type from the presence - -- Wide (_Wide) characters. + -- For string literals, we assume Standard_String as the + -- type, unless the string contains wide or wide_wide + -- characters. elsif Nkind (Exp) = N_String_Literal then if Has_Wide_Wide_Character (Exp) then Resolve (Exp, Standard_Wide_Wide_String); - elsif Has_Wide_Character (Exp) then Resolve (Exp, Standard_Wide_String); - else Resolve (Exp, Standard_String); end if; diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 13a11cc..5af4299 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -37,7 +37,7 @@ #if ! defined (__VXWORKSMILS__) #include "dosFsLib.h" #endif -#if ! defined (__RTP__) && ! defined (VTHREADS) +#if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) # include "nfsLib.h" #endif #include "selectLib.h" @@ -990,7 +990,7 @@ __gnat_is_file_not_found_error (int errno_val) { #if ! defined (__VXWORKSMILS__) case S_dosFsLib_FILE_NOT_FOUND: #endif -#if ! defined (__RTP__) && ! defined (VTHREADS) +#if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) case S_nfsLib_NFSERR_NOENT: #endif #endif -- 2.7.4