with Nmake; use Nmake;
with Output; use Output;
with Opt; use Opt;
-with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Scans; use Scans;
with Scn; use Scn;
Decl : Node_Id;
begin
+ -- Unchecked_Union components do not require component subtypes
+
+ if Is_Unchecked_Union (T) then
+ return Empty;
+ end if;
+
Subt :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
S : Entity_Id;
- Loc : constant Source_Ptr := Sloc (N);
begin
- -- N is one of the potentially blocking operations listed in
- -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
- -- before N if the context is a protected action. Otherwise, only issue
- -- a warning, since some users are relying on blocking operations
- -- inside protected objects.
- -- Indirect blocking through a subprogram call
- -- cannot be diagnosed statically without interprocedural analysis,
- -- so we do not attempt to do it here.
+ -- N is one of the potentially blocking operations listed in 9.5.1(8).
+ -- When pragma Detect_Blocking is active, the run time will raise
+ -- Program_Error. Here we only issue a warning, since we generally
+ -- support the use of potentially blocking operations in the absence
+ -- of the pragma.
- S := Scope (Current_Scope);
+ -- Indirect blocking through a subprogram call cannot be diagnosed
+ -- statically without interprocedural analysis, so we do not attempt
+ -- to do it here.
+ S := Scope (Current_Scope);
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
- if Restricted_Profile then
- Insert_Before_And_Analyze (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Potentially_Blocking_Operation));
- Error_Msg_N ("potentially blocking operation, " &
- " Program Error will be raised at run time?", N);
-
- else
- Error_Msg_N
- ("potentially blocking operation in protected operation?", N);
- end if;
+ Error_Msg_N
+ ("potentially blocking operation in protected operation?", N);
return;
end if;
C := First_Component (T);
while Present (C) loop
- if Is_Limited_Type (Etype (C)) then
+ if Is_Limited_Type (Etype (C))
+ and then Comes_From_Source (C)
+ then
Error_Msg_Node_2 := T;
Error_Msg_NE ("\component& of type& has limited type", N, C);
Explain_Limited_Type (Etype (C), N);
Next_Component (C);
end loop;
- -- It's odd if the loop falls through, but this is only an extra
- -- error message, so we just let it go and ignore the situation.
-
+ -- The type may be declared explicitly limited, even if no component
+ -- of it is limited, in which case we fall out of the loop.
return;
end if;
end Explain_Limited_Type;
-- because the discriminant is not available. The restrictions on
-- Unchecked_Union are designed to make sure that this is OK.
- elsif Is_Unchecked_Union (Utyp) then
+ elsif Is_Unchecked_Union (Base_Type (Utyp)) then
return Typ;
-- Here for the unconstrained case, we must find actual subtype
while Present (Discr) loop
if Nkind (Parent (Discr)) = N_Discriminant_Specification then
Discr_Val := Expression (Parent (Discr));
- if not Is_OK_Static_Expression (Discr_Val) then
- return False;
- else
+
+ if Present (Discr_Val)
+ and then Is_OK_Static_Expression (Discr_Val)
+ then
Append_To (Constraints,
Make_Component_Association (Loc,
Choices => New_List (New_Occurrence_Of (Discr, Loc)),
Expression => New_Copy (Discr_Val)));
-
+ else
+ return False;
end if;
else
return False;
-- scope because the back end otherwise tries to allocate a
-- variable length temporary for the particular variant.
- -- ??? With tree-ssa, the back-end does not (yet) support these
- -- types either, so disable this optimization for now.
-
- if Has_Discriminants (Typ) then
+ if Opt.GCC_Version = 2
+ and then Has_Discriminants (Typ)
+ then
return True;
-- For GCC 3, or for a non-discriminated record in GCC 2, we are
OSDN Git Service
