-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
end if;
end if;
+ -- Object is marked pure if it is in a pure scope
+
Set_Is_Pure (Id, Is_Pure (Current_Scope));
-- If deferred constant, make sure context is appropriate. We detect
Set_Etype (Id, Act_T);
+ -- Object is marked to be treated as volatile if type is volatile and
+ -- we clear the Current_Value setting that may have been set above.
+
+ if Treat_As_Volatile (Etype (Id)) then
+ Set_Treat_As_Volatile (Id);
+ Set_Current_Value (Id, Empty);
+ end if;
+
-- Deal with controlled types
if Has_Controlled_Component (Etype (Id))
procedure Check_Pragma_Implemented (Subp : Entity_Id) is
Iface_Alias : constant Entity_Id := Interface_Alias (Subp);
Impl_Kind : constant Name_Id := Implementation_Kind (Iface_Alias);
+ Subp_Alias : constant Entity_Id := Alias (Subp);
Contr_Typ : Entity_Id;
+ Impl_Subp : Entity_Id;
begin
-- Subp must have an alias since it is a hidden entity used to link
-- an interface subprogram to its overriding counterpart.
- pragma Assert (Present (Alias (Subp)));
+ pragma Assert (Present (Subp_Alias));
+
+ -- Handle aliases to synchronized wrappers
+
+ Impl_Subp := Subp_Alias;
+
+ if Is_Primitive_Wrapper (Impl_Subp) then
+ Impl_Subp := Wrapped_Entity (Impl_Subp);
+ end if;
-- Extract the type of the controlling formal
- Contr_Typ := Etype (First_Formal (Alias (Subp)));
+ Contr_Typ := Etype (First_Formal (Subp_Alias));
if Is_Concurrent_Record_Type (Contr_Typ) then
Contr_Typ := Corresponding_Concurrent_Type (Contr_Typ);
-- be implemented by an entry.
if Impl_Kind = Name_By_Entry
- and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Entry
+ and then Ekind (Impl_Subp) /= E_Entry
then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
("type & must implement abstract subprogram & with an entry",
- Alias (Subp), Contr_Typ);
+ Subp_Alias, Contr_Typ);
elsif Impl_Kind = Name_By_Protected_Procedure then
Error_Msg_Node_2 := Contr_Typ;
Error_Msg_NE
("interface subprogram & cannot be implemented by a " &
- "primitive procedure of task type &", Alias (Subp),
+ "primitive procedure of task type &", Subp_Alias,
Iface_Alias);
-- An interface subprogram whose implementation kind is By_
-- Protected_Procedure must be implemented by a procedure.
- elsif Is_Primitive_Wrapper (Alias (Subp))
- and then Ekind (Wrapped_Entity (Alias (Subp))) /= E_Procedure
- then
+ elsif Ekind (Impl_Subp) /= E_Procedure then
Error_Msg_Node_2 := Iface_Alias;
Error_Msg_NE
("type & must implement abstract subprogram & with a " &
- "procedure", Alias (Subp), Contr_Typ);
+ "procedure", Subp_Alias, Contr_Typ);
end if;
end if;
end Check_Pragma_Implemented;
-- Ada 2012 (AI05-0030): The implementation kinds of an overridden
-- and overriding subprogram are different. In general this is an
-- error except when the implementation kind of the overridden
- -- subprograms is By_Any.
+ -- subprograms is By_Any or Optional.
if Iface_Kind /= Subp_Kind
and then Iface_Kind /= Name_By_Any
+ and then Iface_Kind /= Name_Optional
then
if Iface_Kind = Name_By_Entry then
Error_Msg_N
then
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
- Set_Etype (Class_Wide_Type (Id), Id);
+
+ -- If the incomplete type is completed by a private declaration
+ -- the class-wide type remains associated with the incomplete
+ -- type, to prevent order-of-elaboration issues in gigi, else
+ -- we associate the class-wide type with the known full view.
+
+ if Nkind (N) /= N_Private_Type_Declaration then
+ Set_Etype (Class_Wide_Type (Id), Id);
+ end if;
end if;
-- Case of full declaration of private type
Spec : constant Entity_Id := Real_Range_Specification (Def);
begin
+ -- Check specified "digits" constraint
+
if Digs_Val > Digits_Value (E) then
return False;
end if;
+ -- Avoid types not matching pragma Float_Representation, if present
+
+ if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary)
+ or else
+ (Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native)
+ then
+ return False;
+ end if;
+
+ -- Check for matching range, if specified
+
if Present (Spec) then
if Expr_Value_R (Type_Low_Bound (E)) >
Expr_Value_R (Low_Bound (Spec))
then
return True;
- -- If we are in the body of an instantiation, the component is visible
- -- if the parent type is non-private, or in an enclosing scope. The
- -- scope stack is not present when analyzing an instance body, so we
- -- must inspect the chain of scopes explicitly.
+ -- In the body of an instantiation, no need to check for the visibility
+ -- of a component.
elsif In_Instance_Body then
- if not Is_Private_Type (Scope (C)) then
- return True;
-
- else
- declare
- S : Entity_Id;
-
- begin
- S := Current_Scope;
- while Present (S)
- and then S /= Standard_Standard
- loop
- if S = Type_Scope then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
-
- return False;
- end;
- end if;
+ return True;
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
-- Start of processing for Modular_Type_Declaration
begin
+ -- If the mod expression is (exactly) 2 * literal, where literal is
+ -- 64 or less,then almost certainly the * was meant to be **. Warn!
+
+ if Warn_On_Suspicious_Modulus_Value
+ and then Nkind (Mod_Expr) = N_Op_Multiply
+ and then Nkind (Left_Opnd (Mod_Expr)) = N_Integer_Literal
+ and then Intval (Left_Opnd (Mod_Expr)) = Uint_2
+ and then Nkind (Right_Opnd (Mod_Expr)) = N_Integer_Literal
+ and then Intval (Right_Opnd (Mod_Expr)) <= Uint_64
+ then
+ Error_Msg_N ("suspicious MOD value, was '*'* intended'??", Mod_Expr);
+ end if;
+
+ -- Proceed with analysis of mod expression
+
Analyze_And_Resolve (Mod_Expr, Any_Integer);
Set_Etype (T, T);
Set_Ekind (T, E_Modular_Integer_Type);
if Has_Predicates (Priv_T) then
Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
- Set_Has_Predicates (Priv_T);
+ Set_Has_Predicates (Full_T);
end if;
end Process_Full_View;
OSDN Git Service
