+2014-01-21 Robert Dewar <dewar@adacore.com>
+
+ * checks.adb, sem_util.ads, sem_ch4.adb: Minor reformatting.
+ * gcc-interface/Makefile.in: clean up target pairs.
+
+2014-01-21 Pascal Obry <obry@adacore.com>
+
+ * projects.texi: Minor typo fix.
+
+2014-01-21 Thomas Quinot <quinot@adacore.com>
+
+ * freeze.adb (Check_Component_Storage_Order): If a record type
+ has an explicit Scalar_Storage_Order attribute definition clause,
+ reject any component that itself is of a composite type and does
+ not have one.
+
+2014-01-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch10.adb (Generate_Parent_Reference): Make public so it
+ can be used to generate proper cross-reference information for
+ the parent units of proper bodies.
+
+2014-01-21 Thomas Quinot <quinot@adacore.com>
+
+ * exp_pakd.adb (Expand_Packed_Element_Set,
+ Expand_Packed_Element_Reference): No byte swapping required in
+ the front-end for the case of a reverse storage order array,
+ as this is now handled uniformly in the back-end. However we
+ still need to swap back an extracted element if it is itself a
+ nested composite with reverse storage order.
+
2014-01-21 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_External_Property): Add processing for "others".
-- the ability to emit constraint error warning for static expressions
-- even when we are not generating code.
+ -- The above is modified in gnatprove mode to ensure that proper check
+ -- flags are always placed, even if expansion is off.
+
-------------------------------------
-- Suppression of Redundant Checks --
-------------------------------------
else
Dref :=
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Disc_Ent)));
+ Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
Set_Is_In_Discriminant_Check (Dref);
end if;
Evolve_Or_Else (Cond,
Make_Op_Ne (Loc,
- Left_Opnd => Dref,
+ Left_Opnd => Dref,
Right_Opnd => Dval));
Next_Elmt (Disc);
function Left_Expression (Op : Node_Id) return Node_Id is
LE : Node_Id := Left_Opnd (Op);
begin
- while Nkind_In (LE,
- N_Qualified_Expression,
- N_Type_Conversion,
- N_Expression_With_Actions)
+ while Nkind_In (LE, N_Qualified_Expression,
+ N_Type_Conversion,
+ N_Expression_With_Actions)
loop
LE := Expression (LE);
end loop;
exit when (N = Right_Opnd (P)
or else
(Is_List_Member (N)
- and then List_Containing (N) = Actions (P)))
+ and then List_Containing (N) = Actions (P)))
and then Nkind (Left_Expression (P)) = N_Op_Ne;
end if;
-- Left operand of test must match original variable
- if Nkind (L) not in N_Has_Entity
- or else Entity (L) /= Entity (Nod)
- then
+ if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then
return True;
end if;
else
Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
+
if Debug_Flag_CC then
w ("Conditional_Statements_End: Num_Saved_Checks = ",
Num_Saved_Checks);
then
Lor := Lo_Left / Lo_Right;
Hir := Hi_Left / Lo_Right;
-
else
OK1 := False;
end if;
end if;
-- If we get an exception, then something went wrong, probably because of
- -- an error in the structure of the tree due to an incorrect program. Or it
- -- may be a bug in the optimization circuit. In either case the safest
+ -- an error in the structure of the tree due to an incorrect program. Or
+ -- it may be a bug in the optimization circuit. In either case the safest
-- thing is simply to set the check flag unconditionally.
exception
-- No check if range checks suppressed for type of node
- if Present (Etype (N))
- and then Range_Checks_Suppressed (Etype (N))
- then
+ if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then
return;
-- No check if node is an entity name, and range checks are suppressed
elsif Is_Entity_Name (N)
and then (Range_Checks_Suppressed (Entity (N))
- or else Range_Checks_Suppressed (Etype (Entity (N))))
+ or else Range_Checks_Suppressed (Etype (Entity (N))))
then
return;
-- formal is not OUT). This test also filters out the
-- generic case.
- if Is_Non_Empty_List (L)
- and then Is_Subprogram (E)
- then
+ if Is_Non_Empty_List (L) and then Is_Subprogram (E) then
+
-- This is the loop through parameters, looking for an
-- OUT parameter for which we are the argument.
-- Integer and character literals always have valid values, where
-- appropriate these will be range checked in any case.
- elsif Nkind (Expr) = N_Integer_Literal
- or else
- Nkind (Expr) = N_Character_Literal
- then
+ elsif Nkind_In (Expr, N_Integer_Literal, N_Character_Literal) then
return True;
-- Real literals are assumed to be valid in VM targets
- elsif VM_Target /= No_VM
- and then Nkind (Expr) = N_Real_Literal
- then
+ elsif VM_Target /= No_VM and then Nkind (Expr) = N_Real_Literal then
return True;
-- If we have a type conversion or a qualification of a known valid
-- value, then the result will always be valid.
- elsif Nkind (Expr) = N_Type_Conversion
- or else
- Nkind (Expr) = N_Qualified_Expression
- then
+ elsif Nkind_In (Expr, N_Type_Conversion, N_Qualified_Expression) then
return Expr_Known_Valid (Expression (Expr));
-- The result of any operator is always considered valid, since we
elsif Nkind (Expr) in N_Op then
if Is_Floating_Point_Type (Typ)
and then Validity_Check_Floating_Point
- and then
- (Nkind (Parent (Expr)) = N_Assignment_Statement
- or else Nkind (Parent (Expr)) = N_Function_Call
- or else Nkind (Parent (Expr)) = N_Parameter_Association)
+ and then (Nkind_In (Parent (Expr), N_Assignment_Statement,
+ N_Function_Call,
+ N_Parameter_Association))
then
return False;
else
for J in reverse 1 .. Num_Saved_Checks loop
declare
SC : Saved_Check renames Saved_Checks (J);
-
begin
if SC.Killed = False
and then SC.Entity = Ent
-- Force evaluation of the prefix, so that it does not get evaluated
-- twice (once for the check, once for the actual reference). Such a
- -- double evaluation is always a potential source of inefficiency,
- -- and is functionally incorrect in the volatile case, or when the
- -- prefix may have side-effects. An entity or a component of an
- -- entity requires no evaluation.
+ -- double evaluation is always a potential source of inefficiency, and
+ -- is functionally incorrect in the volatile case, or when the prefix
+ -- may have side-effects. A non-volatile entity or a component of a
+ -- non-volatile entity requires no evaluation.
if Is_Entity_Name (Pref) then
if Treat_As_Volatile (Entity (Pref)) then
end if;
elsif Treat_As_Volatile (Etype (Pref)) then
- Force_Evaluation (Pref, Name_Req => True);
+ Force_Evaluation (Pref, Name_Req => True);
elsif Nkind (Pref) = N_Selected_Component
and then Is_Entity_Name (Prefix (Pref))
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Discr_Fct, Loc),
+ Name => New_Occurrence_Of (Discr_Fct, Loc),
Parameter_Associations => Args),
Reason => CE_Discriminant_Check_Failed));
end Generate_Discriminant_Check;
-- for array object or type.
if not Is_Array_Type (Etype (A))
- or else (Present (A_Ent)
- and then Index_Checks_Suppressed (A_Ent))
+ or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent))
or else Index_Checks_Suppressed (Etype (A))
then
return;
else
pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
- and then Is_Unsigned_Type (Target_Base_Type));
+ and then Is_Unsigned_Type (Target_Base_Type));
-- If the source is signed and the target is unsigned, then we
-- know that the target is not shorter than the source (otherwise
Right_Opnd =>
New_Occurrence_Of (Target_Type, Loc))),
- Reason => Reason)),
+ Reason => Reason)),
Suppress => All_Checks);
-- Set the Etype explicitly, because Insert_Actions may have
while Present (Sc) loop
if Sc = Standard_Standard then
return Bound;
-
elsif Ekind (Sc) = E_Protected_Type then
exit;
end if;
Warn_Node : Node_Id := Empty) return Check_Result
is
begin
- return Selected_Range_Checks
- (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
+ return
+ Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
end Get_Range_Checks;
------------------
if Nkind (Ck_Node) = N_Allocator then
return Cond;
+
else
return
Make_And_Then (Loc,
if Is_Entity_Name (Exp)
and then Nkind (Parent (Entity (Exp))) =
- N_Object_Renaming_Declaration
+ N_Object_Renaming_Declaration
then
declare
Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
return False;
end if;
- -- If we are in a case expression, and not part of the
- -- expression, then we return False, since a particular
- -- dependent expression may not always be elaborated
+ -- If within a case expression, and not part of the expression,
+ -- then return False, since a particular dependent expression
+ -- may not always be elaborated
if Nkind (P) = N_Case_Expression
and then N /= Expression (P)
return False;
end if;
- -- While traversing the parent chain, we find that N
- -- belongs to a statement, thus it may never appear in
- -- a declarative region.
+ -- While traversing the parent chain, if node N belongs to a
+ -- statement, then it may never appear in a declarative region.
if Nkind (P) in N_Statement_Other_Than_Procedure_Call
or else Nkind (P) = N_Procedure_Call_Statement
if Known_Null (N) then
- -- Avoid generating warning message inside init procs
+ -- Avoid generating warning message inside init procs. In SPARK mode
+ -- we can go ahead and call Apply_Compile_Time_Constraint_Error
+ -- since it will be truned into an error in any case.
- if not Inside_Init_Proc then
+ if not Inside_Init_Proc or else SPARK_Mode = On then
Apply_Compile_Time_Constraint_Error
(N, "null value not allowed here??", CE_Access_Check_Failed);
else
end if;
-- If we don't have a binary operator, all we have to do is to set
- -- the Hi/Lo range, so we are done
+ -- the Hi/Lo range, so we are done.
return;
-- If we have an arithmetic operator we make recursive calls on the
-- operands to get the ranges (and to properly process the subtree
- -- that lies below us!)
+ -- that lies below us).
Minimize_Eliminate_Overflows
(Right_Opnd (N), Rlo, Rhi, Top_Level => False);
begin
if Present (N) then
- -- For now, ignore attempt to place more than 2 checks ???
+ -- For now, ignore attempt to place more than two checks ???
+ -- This is really worrisome, are we really discarding checks ???
if Num_Checks = 2 then
return;
then
HB := T_HB;
Known_HB := True;
-
else
Known_HB := False;
end if;
-- and replace the literal with a raise constraint error
-- expression. As usual, skip this for access types
- elsif Compile_Time_Known_Value (Ck_Node)
- and then not Do_Access
- then
+ elsif Compile_Time_Known_Value (Ck_Node) and then not Do_Access then
declare
LB : constant Node_Id := Type_Low_Bound (T_Typ);
UB : constant Node_Id := Type_High_Bound (T_Typ);
and then Checks_May_Be_Suppressed (E)
then
return Is_Check_Suppressed (E, Tag_Check);
+ else
+ return Scope_Suppress.Suppress (Tag_Check);
end if;
-
- return Scope_Suppress.Suppress (Tag_Check);
end Tag_Checks_Suppressed;
--------------------------
-- contains the value. Otherwise Rhs_Val_Known is set False, and
-- the Rhs_Val is undefined.
- Require_Byte_Swapping : Boolean := False;
- -- True if byte swapping required, for the Reverse_Storage_Order case
- -- when the packed array is a free-standing object. (If it is part
- -- of a composite type, and therefore potentially not aligned on a byte
- -- boundary, the swapping is done by the back-end).
-
function Get_Shift return Node_Id;
-- Function used to get the value of Shift, making sure that it
-- gets duplicated if the function is called more than once.
-- array type on Obj to get lost. So we save the type of Obj, and
-- make sure it is reset properly.
- declare
- T : constant Entity_Id := Etype (Obj);
- begin
- New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True);
- New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
- Set_Etype (Obj, T);
- Set_Etype (New_Lhs, T);
- Set_Etype (New_Rhs, T);
-
- if Reverse_Storage_Order (Base_Type (Atyp))
- and then Esize (T) > 8
- and then not In_Reverse_Storage_Order_Object (Obj)
- then
- Require_Byte_Swapping := True;
- New_Rhs := Byte_Swap (New_Rhs,
- Left_Justify => Bytes_Big_Endian,
- Right_Justify => not Bytes_Big_Endian);
- end if;
- end;
+ New_Lhs := Duplicate_Subexpr (Obj, Name_Req => True);
+ New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
-- First we deal with the "and"
Set_Etype (New_Rhs, Etype (Left_Opnd (New_Rhs)));
end if;
- -- If New_Rhs has been byte swapped, need to convert Or_Rhs
- -- to the return type of the byte swapping function now.
-
- if Require_Byte_Swapping then
- Or_Rhs := Unchecked_Convert_To (Etype (New_Rhs), Or_Rhs);
- end if;
-
New_Rhs :=
Make_Op_Or (Loc,
Left_Opnd => New_Rhs,
end;
end if;
- if Require_Byte_Swapping then
- Set_Etype (New_Rhs, Etype (Obj));
- New_Rhs :=
- Unchecked_Convert_To (Etype (Obj),
- Byte_Swap (New_Rhs,
- Left_Justify => not Bytes_Big_Endian,
- Right_Justify => Bytes_Big_Endian));
- end if;
-
-- Now do the rewrite
Rewrite (N,
Lit : Node_Id;
Arg : Node_Id;
- Byte_Swapped : Boolean;
- -- Set true if bytes were swapped for the purpose of extracting the
- -- element, in which case we must swap back if the component type is
- -- a composite type with reverse scalar storage order.
-
begin
-- If the node is an actual in a call, the prefix has not been fully
-- expanded, to account for the additional expansion for in-out actuals
Lit := Make_Integer_Literal (Loc, Cmask);
Set_Print_In_Hex (Lit);
- -- Byte swapping required for the Reverse_Storage_Order case, but
- -- only for a free-standing object (see note on Require_Byte_Swapping
- -- in Expand_Bit_Packed_Element_Set).
-
- if Reverse_Storage_Order (Atyp)
- and then Esize (Atyp) > 8
- and then not In_Reverse_Storage_Order_Object (Obj)
- then
- Obj := Byte_Swap (Obj,
- Left_Justify => Bytes_Big_Endian,
- Right_Justify => not Bytes_Big_Endian);
- Byte_Swapped := True;
-
- else
- Byte_Swapped := False;
- end if;
-
-- We generate a shift right to position the field, followed by a
-- masking operation to extract the bit field, and we finally do an
-- unchecked conversion to convert the result to the required target.
Make_Op_And (Loc,
Left_Opnd => Make_Shift_Right (Obj, Shift),
Right_Opnd => Lit);
-
- -- Swap back if necessary
-
Set_Etype (Arg, Ctyp);
- if Byte_Swapped
+ -- Component extraction is performed on a native endianness scalar
+ -- value: if Atyp has reverse storage order, then it has been byte
+ -- swapped, and if the component being extracted is itself of a
+ -- composite type with reverse storage order, then we need to swap
+ -- it back to its expected endianness after extraction.
+
+ if Reverse_Storage_Order (Atyp)
+ and then Esize (Atyp) > 8
and then (Is_Record_Type (Ctyp) or else Is_Array_Type (Ctyp))
and then Reverse_Storage_Order (Ctyp)
then
-- Set True for the record case, when Comp starts on a byte boundary
-- (in which case it is allowed to have different storage order).
+ Comp_SSO_Differs : Boolean;
+ -- Set True when the component is a nested composite, and it does not
+ -- have the same scalar storage order as Encl_Type.
+
Component_Aliased : Boolean;
begin
-- attribute on Comp_Type if composite.
elsif Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then
+ Comp_SSO_Differs :=
+ Reverse_Storage_Order (Encl_Type)
+ /=
+ Reverse_Storage_Order (Comp_Type);
+
if Present (Comp) and then Chars (Comp) = Name_uParent then
- if Reverse_Storage_Order (Encl_Type)
- /=
- Reverse_Storage_Order (Comp_Type)
- then
+ if Comp_SSO_Differs then
Error_Msg_N
("record extension must have same scalar storage order as "
& "parent", Err_Node);
end if;
- elsif No (ADC) then
+ elsif No (Comp_ADC) then
Error_Msg_N ("nested composite must have explicit scalar "
& "storage order", Err_Node);
- elsif (Reverse_Storage_Order (Encl_Type)
- /=
- Reverse_Storage_Order (Comp_Type))
- and then not Comp_Byte_Aligned
- then
- Error_Msg_N
- ("type of non-byte-aligned component must have same scalar "
- & "storage order as enclosing composite", Err_Node);
+ elsif Comp_SSO_Differs then
+
+ -- Component SSO differs from enclosing composite:
+
+ -- Reject if component is a packed array, as it may be represented
+ -- as a scalar internally.
+
+ if Is_Packed (Comp_Type) then
+ Error_Msg_N
+ ("type of packed component must have same scalar "
+ & "storage order as enclosing composite", Err_Node);
+
+ -- Reject if not byte aligned
+
+ elsif not Comp_Byte_Aligned then
+ Error_Msg_N
+ ("type of non-byte-aligned component must have same scalar "
+ & "storage order as enclosing composite", Err_Node);
+
+ end if;
end if;
-- Enclosing type has explicit SSO, non-composite component must not
s-vxwext.adb<s-vxwext-rtp.adb \
s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \
system.ads<system-vxworks-$(ARCH_STR)-rtp.ads
-
- EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
else
ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
system.ads<system-vxworks-$(ARCH_STR)-rtp.ads
- EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
EXTRA_LIBGNAT_OBJS+=affinity.o
else
ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
system.ads<system-vxworks-ppc.ads
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-vxwexc.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_LIBGNAT_OBJS+=sigtramp-ppcvxw.o
endif
endif
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-vxwexc.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=sigtramp-ppcvxw.o
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_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o sigtramp-ppcvxw.o
LIBGNAT_TARGET_PAIRS = \
a-elchha.adb<a-elchha-vxworks-ppc-full.adb \
a-intnam.ads<a-intnam-vxworks.ads \
- a-sytaco.ads<1asytaco.ads \
- a-sytaco.adb<1asytaco.adb \
+ a-numaux.ads<a-numaux-vxworks.ads \
g-io.adb<g-io-vxworks-ppc-cert.adb \
s-inmaop.adb<s-inmaop-vxworks.adb \
s-interr.adb<s-interr-hwint.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-taprop.adb<s-taprop-vxworks.adb \
s-tasinf.ads<s-tasinf-vxworks.ads \
s-taspri.ads<s-taspri-vxworks.ads \
s-vxwext.adb<s-vxwext-noints.adb \
s-vxwext.ads<s-vxwext-vthreads.ads \
s-vxwork.ads<s-vxwork-x86.ads \
+ system.ads<system-vxworks-x86.ads \
$(ATOMICS_TARGET_PAIRS) \
- $(X86_TARGET_PAIRS) \
- system.ads<system-vxworks-x86.ads
+ $(ATOMICS_BUILTINS_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-vxwexc.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_LIBGNAT_OBJS+=vx_stack_info.o # sigtramp-ppcvxw.o
+ GNATRTL_SOCKETS_OBJS =
+
# Extra pairs for the vthreads runtime
ifeq ($(strip $(filter-out vthreads,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \
system.ads<system-vxworks-x86-rtp.ads
- EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
else
ifeq ($(strip $(filter-out rtp-smp, $(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
system.ads<system-vxworks-x86-rtp.ads
- EXTRA_GNATRTL_NONTASKING_OBJS=s-vxwexc.o
EXTRA_LIBGNAT_OBJS+=affinity.o
else
ifeq ($(strip $(filter-out kernel-smp, $(THREAD_KIND))),)
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-vxwexc.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
endif
endif
EXTRA_GNATRTL_TASKING_OBJS += s-vxwork.o s-vxwext.o
s-po32gl.adb s-po32gl.ads \
s-stache.adb s-stache.ads \
s-thread.ads \
- s-vxwexc.adb s-vxwexc.ads s-vxwext.adb s-vxwext.ads \
+ s-vxwext.adb s-vxwext.ads \
s-win32.ads s-winext.ads \
g-regist.adb g-regist.ads g-sse.ads g-ssvety.ads \
i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \
@b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the
package @code{Builder}.
@item ^Gnatls^Gnatls^
- This package the options to use when invoking @command{gnatls} via the
- @command{gnat} driver.
+ This package specifies the options to use when invoking @command{gnatls}
+ via the @command{gnat} driver.
@item ^Gnatstub^Gnatstub^
This package specifies the options used when calling the tool
@command{gnatstub} via the @command{gnat} driver. Its attributes
-- N is the compilation unit whose list of context items receives the
-- implicit with_clauses.
+ procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
+ -- Generate cross-reference information for the parents of child units
+ -- and of subunits. N is a defining_program_unit_name, and P_Id is the
+ -- immediate parent scope.
+
function Get_Parent_Entity (Unit : Node_Id) return Entity_Id;
-- Get defining entity of parent unit of a child unit. In most cases this
-- is the defining entity of the unit, but for a child instance whose
-- Spec_Context_Items to that of the spec. Parent packages are not
-- examined for documentation purposes.
- procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id);
- -- Generate cross-reference information for the parents of child units.
- -- N is a defining_program_unit_name, and P_Id is the immediate parent.
-
---------------------------
-- Check_Redundant_Withs --
---------------------------
end loop;
end Check_Redundant_Withs;
- --------------------------------
- -- Generate_Parent_References --
- --------------------------------
-
- procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
- Pref : Node_Id;
- P_Name : Entity_Id := P_Id;
-
- begin
- Pref := Name (Parent (Defining_Entity (N)));
-
- if Nkind (Pref) = N_Expanded_Name then
-
- -- Done already, if the unit has been compiled indirectly as
- -- part of the closure of its context because of inlining.
-
- return;
- end if;
-
- while Nkind (Pref) = N_Selected_Component loop
- Change_Selected_Component_To_Expanded_Name (Pref);
- Set_Entity (Pref, P_Name);
- Set_Etype (Pref, Etype (P_Name));
- Generate_Reference (P_Name, Pref, 'r');
- Pref := Prefix (Pref);
- P_Name := Scope (P_Name);
- end loop;
-
- -- The guard here on P_Name is to handle the error condition where
- -- the parent unit is missing because the file was not found.
-
- if Present (P_Name) then
- Set_Entity (Pref, P_Name);
- Set_Etype (Pref, Etype (P_Name));
- Generate_Reference (P_Name, Pref, 'r');
- Style.Check_Identifier (Pref, P_Name);
- end if;
- end Generate_Parent_References;
-
-- Start of processing for Analyze_Compilation_Unit
begin
if Nkind (Defining_Unit_Name (Specification (Unit_Node))) =
N_Defining_Program_Unit_Name
then
- Generate_Parent_References (
- Specification (Unit_Node),
- Scope (Defining_Entity (Unit (Lib_Unit))));
+ Generate_Parent_References
+ (Specification (Unit_Node),
+ Scope (Defining_Entity (Unit (Lib_Unit))));
end if;
end if;
-- Set the entities of all parents in the program_unit_name
- Generate_Parent_References (
- Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
+ Generate_Parent_References
+ (Unit_Node, Get_Parent_Entity (Unit (Parent_Spec (Unit_Node))));
end if;
-- All components of the context: with-clauses, library unit, ancestors
end if;
end if;
+ Generate_Parent_References (Unit (N), Par_Unit);
Analyze (Proper_Body (Unit (N)));
Remove_Context (N);
end if;
end Expand_With_Clause;
+ --------------------------------
+ -- Generate_Parent_References --
+ --------------------------------
+
+ procedure Generate_Parent_References (N : Node_Id; P_Id : Entity_Id) is
+ Pref : Node_Id;
+ P_Name : Entity_Id := P_Id;
+
+ begin
+ if Nkind (N) = N_Subunit then
+ Pref := Name (N);
+ else
+ Pref := Name (Parent (Defining_Entity (N)));
+ end if;
+
+ if Nkind (Pref) = N_Expanded_Name then
+
+ -- Done already, if the unit has been compiled indirectly as
+ -- part of the closure of its context because of inlining.
+
+ return;
+ end if;
+
+ while Nkind (Pref) = N_Selected_Component loop
+ Change_Selected_Component_To_Expanded_Name (Pref);
+ Set_Entity (Pref, P_Name);
+ Set_Etype (Pref, Etype (P_Name));
+ Generate_Reference (P_Name, Pref, 'r');
+ Pref := Prefix (Pref);
+ P_Name := Scope (P_Name);
+ end loop;
+
+ -- The guard here on P_Name is to handle the error condition where
+ -- the parent unit is missing because the file was not found.
+
+ if Present (P_Name) then
+ Set_Entity (Pref, P_Name);
+ Set_Etype (Pref, Etype (P_Name));
+ Generate_Reference (P_Name, Pref, 'r');
+ Style.Check_Identifier (Pref, P_Name);
+ end if;
+ end Generate_Parent_References;
+
-----------------------
-- Get_Parent_Entity --
-----------------------
Set_Etype (Sel, Etype (Comp));
Set_Etype (N, Etype (Comp));
- -- Emit appropriate message. Gigi will replace the node
- -- subsequently with the appropriate Raise.
+ -- Emit appropriate message. The node will be replaced
+ -- by an appropriate raise statement.
- -- In SPARK mode, this is made into an error to simplify
- -- the processing of the formal verification backend.
+ -- Note that in SPARK mode, as with all calls to apply a
+ -- compile time constraint error, this will be made into
+ -- an error to simplify the processing of the formal
+ -- verification backend.
- Error_Msg_Warn := SPARK_Mode /= On;
Apply_Compile_Time_Constraint_Error
- (N, "component not present in }<<",
+ (N, "component not present in }??",
CE_Discriminant_Check_Failed,
Ent => Prefix_Type, Rep => False);
-- is present, this is used instead. Warn is normally False. If it is
-- True then the message is treated as a warning even though it does
-- not end with a ? (this is used when the caller wants to parameterize
- -- whether an error or warning is given.
+ -- whether an error or warning is given).
function Async_Readers_Enabled (Id : Entity_Id) return Boolean;
-- Given the entity of an abstract state or a variable, determine whether
git://gcc.gnu.org / gcc.git / commitdiff