diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 17 | ||||
| -rw-r--r-- | gcc/ada/env.c | 12 | ||||
| -rw-r--r-- | gcc/ada/g-regist.adb | 79 | ||||
| -rw-r--r-- | gcc/ada/g-regist.ads | 16 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 58 | ||||
| -rw-r--r-- | gcc/ada/s-commun.ads | 1 | ||||
| -rw-r--r-- | gcc/ada/s-osprim-mingw.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/s-stchop-vxworks.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/s-vxwext.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_aggr.adb | 126 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 7 | ||||
| -rw-r--r-- | 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 <dewar@adacore.com> + + * 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 <fofanov@adacore.com> + + * 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 <falis@adacore.com> + + * 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 <duff@adacore.com> * 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 <stdlib.h> #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<a-intnam-vxworks.ads \ + a-numaux.ads<a-numaux-vxworks.ads \ + g-io.adb<g-io-vxworks-ppc-cert.adb \ + g-io.ads<g-io-vxworks-ppc-cert.ads \ + s-inmaop.adb<s-inmaop-posix.adb \ + s-interr.adb<s-interr-hwint.adb \ + s-intman.ads<s-intman-vxworks.ads \ + s-intman.adb<s-intman-vxworks.adb \ + s-osinte.adb<s-osinte-vxworks.adb \ + s-osinte.ads<s-osinte-vxworks.ads \ + s-osprim.adb<s-osprim-vxworks.adb \ + s-parame.ads<s-parame-ae653.ads \ + s-parame.adb<s-parame-vxworks.adb \ + s-stchop.adb<s-stchop-vxworks.adb \ + s-stchop.ads<s-stchop-limit.ads \ + s-taprop.adb<s-taprop-vxworks.adb \ + s-tasinf.ads<s-tasinf-vxworks.ads \ + s-taspri.ads<s-taspri-vxworks.ads \ + s-thread.adb<s-thread-ae653.adb \ + s-tpopsp.adb<s-tpopsp-vxworks.adb \ + s-vxwork.ads<s-vxwork-ppc.ads \ + g-trasym.ads<g-trasym-unimplemented.ads \ + g-trasym.adb<g-trasym-unimplemented.adb \ + system.ads<system-vxworks-ppc.ads \ + $(DUMMY_SOCKETS_TARGET_PAIRS) + + TOOLS_TARGET_PAIRS=\ + mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \ + indepsw.adb<indepsw-gnu.adb + + EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o s-vxwexc.o + EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o + + EXTRA_LIBGNAT_SRCS+=vx_stack_info.c + EXTRA_LIBGNAT_OBJS+=vx_stack_info.o + GNATRTL_SOCKETS_OBJS = + + ifeq ($(strip $(filter-out yes,$(TRACE))),) + LIBGNAT_TARGET_PAIRS += \ + s-traces.adb<s-traces-default.adb \ + s-trafor.adb<s-trafor-default.adb \ + s-trafor.ads<s-trafor-default.ads \ + s-tratas.adb<s-tratas-default.adb \ + s-tfsetr.adb<s-tfsetr-vxworks.adb + endif +endif + +# vxworksae / vxworks 653 for x86 (vxsim) - ?? vxworksmils not implemented +ifeq ($(strip $(filter-out %86 wrs vxworksae vxworksmils,$(targ))),) # target pairs for kernel + vthreads runtime LIBGNAT_TARGET_PAIRS = \ a-elchha.adb<a-elchha-vxworks-ppc-full.adb \ @@ -623,7 +674,6 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(targ))),) s-taprop.adb<s-taprop-vxworks.adb \ s-tasinf.ads<s-tasinf-vxworks.ads \ s-taspri.ads<s-taspri-vxworks.ads \ - s-thread.adb<s-thread-ae653.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \ s-vxwext.adb<s-vxwext-noints.adb \ s-vxwext.ads<s-vxwext-vthreads.ads \ diff --git a/gcc/ada/s-commun.ads b/gcc/ada/s-commun.ads index a4e52d8..c59a2c7 100644 --- a/gcc/ada/s-commun.ads +++ b/gcc/ada/s-commun.ads @@ -41,6 +41,7 @@ package System.Communication is Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset; -- Compute the Last OUT parameter for the various Read / Receive -- subprograms: returns First + Count - 1. + -- -- When First = Stream_Element_Offset'First and Res = 0, Constraint_Error -- is raised. This is consistent with the semantics of stream operations -- as clarified in AI95-227. diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb index c818811..fc286e6 100644 --- a/gcc/ada/s-osprim-mingw.adb +++ b/gcc/ada/s-osprim-mingw.adb @@ -199,12 +199,14 @@ package body System.OS_Primitives is loop GetSystemTimeAsFileTime (Loc_Time'Access); + if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then pragma Assert (Standard.False, "Could not query high performance counter in Clock"); null; end if; + exit when Loc_Time /= Ctrl_Time; Loc_Ticks := Ctrl_Ticks; end loop; @@ -218,7 +220,9 @@ package body System.OS_Primitives is Base_Time := Loc_Time; Base_Ticks := Loc_Ticks; Current_Max := Elapsed; + -- Exit the loop when we have reached the expected precision + exit when Elapsed <= Max_Elapsed; end if; end loop; diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb index 152dc92..ffdba81 100644 --- a/gcc/ada/s-stchop-vxworks.adb +++ b/gcc/ada/s-stchop-vxworks.adb @@ -29,9 +29,10 @@ -- -- ------------------------------------------------------------------------------ --- This is the VxWorks version of this package. +-- This is the verson for VxWorks 5 and VxWorks MILS + -- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. This version is for VxWorks 5 and VxWorks MILS. +-- provided by s-stchop.adb. pragma Restrictions (No_Elaboration_Code); -- We want to guarantee the absence of elaboration code because the diff --git a/gcc/ada/s-vxwext.adb b/gcc/ada/s-vxwext.adb index a0f0e8a..710ff27 100644 --- a/gcc/ada/s-vxwext.adb +++ b/gcc/ada/s-vxwext.adb @@ -28,9 +28,6 @@ -- -- ------------------------------------------------------------------------------ --- This package provides vxworks specific support functions needed --- by System.OS_Interface. - -- This is the VxWorks 5 and VxWorks MILS version of this package package body System.VxWorks.Ext is diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 6c01779..3b0bda0 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -1936,9 +1936,8 @@ package body Sem_Aggr is and then Compile_Time_Known_Value (Choices_Low) and then Compile_Time_Known_Value (Choices_High) then - -- If the bounds have semantic errors, do not attempt - -- further resolution to prevent cascaded errors.. + -- further resolution to prevent cascaded errors. if Error_Posted (Choices_Low) or else Error_Posted (Choices_High) @@ -1955,7 +1954,7 @@ package body Sem_Aggr is Ent : Entity_Id; begin - -- Warning case one, missing values at start/end. Only + -- Warning case 1, missing values at start/end. Only -- do the check if the number of entries is too small. if (Enumeration_Pos (CHi) - Enumeration_Pos (CLo)) @@ -2067,14 +2066,14 @@ package body Sem_Aggr is Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); end if; - -- Ada 2005 (AI-287): In case of default initialized component + -- Ada 2005 (AI-287): In case of default initialized component, -- we delay the resolution to the expansion phase. if Box_Present (Assoc) then - -- Ada 2005 (AI-287): In case of default initialization - -- of a component the expander will generate calls to - -- the corresponding initialization subprogram. + -- Ada 2005 (AI-287): In case of default initialization of a + -- component the expander will generate calls to the + -- corresponding initialization subprogram. null; @@ -2162,7 +2161,7 @@ package body Sem_Aggr is -- Do not duplicate Aggr_High if Aggr_High = Aggr_Low + Nb_Elements -- since the addition node returned by Add is not yet analyzed. Attach - -- to tree and analyze first. Reset analyzed flag to insure it will get + -- to tree and analyze first. Reset analyzed flag to ensure it will get -- analyzed when it is a literal bound whose type must be properly set. if Others_Present or else Nb_Discrete_Choices > 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 |