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 --
---------------------
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 --
-------------------------
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;
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 = \
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 \
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 \
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)
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))
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;
-- 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
-- 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;
-- 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);
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
then
return True;
- elsif
- Nkind (Anc) = N_Qualified_Expression
- then
+ elsif Nkind (Anc) = N_Qualified_Expression then
return Valid_Limited_Ancestor (Expression (Anc));
else
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)))
-- 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);
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
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
-- (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;
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
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
projects / platform / upstream / gcc.git / commitdiff