with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Ch7; use Exp_Ch7;
with Exp_Dist; use Exp_Dist;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
procedure Ada_2005_Pragma;
-- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
-- Ada 95 mode, these are implementation defined pragmas, so should be
- -- caught by the No_Implementation_Pragmas restriction
+ -- caught by the No_Implementation_Pragmas restriction.
+
+ procedure Ada_2012_Pragma;
+ -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
+ -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
+ -- should be caught by the No_Implementation_Pragmas restriction.
procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada
procedure Check_At_Most_N_Arguments (N : Nat);
-- Check there are no more than N arguments present
- procedure Check_Component (Comp : Node_Id);
- -- Examine Unchecked_Union component for correct use of per-object
+ procedure Check_Component
+ (Comp : Node_Id;
+ UU_Typ : Entity_Id;
+ In_Variant_Part : Boolean := False);
+ -- Examine an Unchecked_Union component for correct use of per-object
-- constrained subtypes, and for restrictions on finalizable components.
+ -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
+ -- should be set when Comp comes from a record variant.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set by
-- and to library level instantiations), and they are simply ignored,
-- which is implemented by rewriting them as null statements.
- procedure Check_Variant (Variant : Node_Id);
- -- Check Unchecked_Union variant for lack of nested variants and
- -- presence of at least one component.
+ procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id);
+ -- Check an Unchecked_Union variant for lack of nested variants and
+ -- presence of at least one component. UU_Typ is the related Unchecked_
+ -- Union type.
procedure Error_Pragma (Msg : String);
pragma No_Return (Error_Pragma);
end if;
end Ada_2005_Pragma;
+ ---------------------
+ -- Ada_2012_Pragma --
+ ---------------------
+
+ procedure Ada_2012_Pragma is
+ begin
+ if Ada_Version <= Ada_05 then
+ Check_Restriction (No_Implementation_Pragmas, N);
+ end if;
+ end Ada_2012_Pragma;
+
--------------------------
-- Check_Ada_83_Warning --
--------------------------
-- Check_Component --
---------------------
- procedure Check_Component (Comp : Node_Id) is
- begin
- if Nkind (Comp) = N_Component_Declaration then
- declare
- Sindic : constant Node_Id :=
- Subtype_Indication (Component_Definition (Comp));
- Typ : constant Entity_Id :=
- Etype (Defining_Identifier (Comp));
- begin
- if Nkind (Sindic) = N_Subtype_Indication then
+ procedure Check_Component
+ (Comp : Node_Id;
+ UU_Typ : Entity_Id;
+ In_Variant_Part : Boolean := False)
+ is
+ Comp_Id : constant Entity_Id := Defining_Identifier (Comp);
+ Sindic : constant Node_Id :=
+ Subtype_Indication (Component_Definition (Comp));
+ Typ : constant Entity_Id := Etype (Comp_Id);
- -- Ada 2005 (AI-216): If a component subtype is subject to
- -- a per-object constraint, then the component type shall
- -- be an Unchecked_Union.
+ function Inside_Generic_Body (Id : Entity_Id) return Boolean;
+ -- Determine whether entity Id appears inside a generic body
- if Has_Per_Object_Constraint (Defining_Identifier (Comp))
- and then
- not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
- then
- Error_Msg_N ("component subtype subject to per-object" &
- " constraint must be an Unchecked_Union", Comp);
- end if;
- end if;
+ -------------------------
+ -- Inside_Generic_Body --
+ -------------------------
- if Is_Controlled (Typ) then
- Error_Msg_N
- ("component of unchecked union cannot be controlled", Comp);
+ function Inside_Generic_Body (Id : Entity_Id) return Boolean is
+ S : Entity_Id := Id;
- elsif Has_Task (Typ) then
- Error_Msg_N
- ("component of unchecked union cannot have tasks", Comp);
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Ekind (S) = E_Generic_Package
+ and then In_Package_Body (S)
+ then
+ return True;
end if;
- end;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end Inside_Generic_Body;
+
+ -- Start of processing for Check_Component
+
+ begin
+ -- Ada 2005 (AI-216): If a component subtype is subject to a per-
+ -- object constraint, then the component type shall be an Unchecked_
+ -- Union.
+
+ if Nkind (Sindic) = N_Subtype_Indication
+ and then Has_Per_Object_Constraint (Comp_Id)
+ and then not Is_Unchecked_Union (Etype (Subtype_Mark (Sindic)))
+ then
+ Error_Msg_N
+ ("component subtype subject to per-object constraint " &
+ "must be an Unchecked_Union", Comp);
+
+ -- Ada 2012 (AI05-0026): For an unchecked union type declared within
+ -- the body of a generic unit, or within the body of any of its
+ -- descendant library units, no part of the type of a component
+ -- declared in a variant_part of the unchecked union type shall be of
+ -- a formal private type or formal private extension declared within
+ -- the formal part of the generic unit.
+
+ elsif Ada_Version >= Ada_2012
+ and then Inside_Generic_Body (UU_Typ)
+ and then In_Variant_Part
+ and then Is_Private_Type (Typ)
+ and then Is_Generic_Type (Typ)
+ then
+ Error_Msg_N
+ ("component of Unchecked_Union cannot be of generic type", Comp);
+
+ elsif Needs_Finalization (Typ) then
+ Error_Msg_N
+ ("component of Unchecked_Union cannot be controlled", Comp);
+
+ elsif Has_Task (Typ) then
+ Error_Msg_N
+ ("component of Unchecked_Union cannot have tasks", Comp);
end if;
end Check_Component;
-- Check_Variant --
-------------------
- procedure Check_Variant (Variant : Node_Id) is
+ procedure Check_Variant (Variant : Node_Id; UU_Typ : Entity_Id) is
Clist : constant Node_Id := Component_List (Variant);
Comp : Node_Id;
Comp := First (Component_Items (Clist));
while Present (Comp) loop
- Check_Component (Comp);
+ Check_Component (Comp, UU_Typ, In_Variant_Part => True);
Next (Comp);
end loop;
end Check_Variant;
-- entity (if declared in the same unit) is inlined.
if Is_Subprogram (Subp) then
- while Present (Alias (Inner_Subp)) loop
- Inner_Subp := Alias (Inner_Subp);
- end loop;
+ Inner_Subp := Ultimate_Alias (Inner_Subp);
if In_Same_Source_Unit (Subp, Inner_Subp) then
Set_Inline_Flags (Inner_Subp);
Restriction_Warnings (R_Id) := False;
end if;
+ -- Check for obsolescent restrictions in Ada 2005 mode
+
+ if not Warn
+ and then Ada_Version >= Ada_2005
+ and then (R_Id = No_Asynchronous_Control
+ or else
+ R_Id = No_Unchecked_Deallocation
+ or else
+ R_Id = No_Unchecked_Conversion)
+ then
+ Check_Restriction (No_Obsolescent_Features, N);
+ end if;
+
-- A very special case that must be processed here: pragma
-- Restrictions (No_Exceptions) turns off all run-time
-- checking. This is a bit dubious in terms of the formal
-- a specified entity (given as the second argument of the pragma)
else
+ -- This is obsolescent in Ada 2005 mode
+
+ if Ada_Version >= Ada_2005 then
+ Check_Restriction (No_Obsolescent_Features, Arg2);
+ end if;
+
Check_Optional_Identifier (Arg2, Name_On);
E_Id := Expression (Arg2);
Analyze (E_Id);
-- form created by the parser.
procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is
- Class : Node_Id;
- Param : Node_Id;
+ Class : Node_Id;
+ Param : Node_Id;
Mech_Name_Id : Name_Id;
procedure Bad_Class;
elsif Chars (Mech_Name) = Name_Descriptor then
Check_VMS (Mech_Name);
- Set_Mechanism (Ent, By_Descriptor);
+
+ -- Descriptor => Short_Descriptor if pragma was given
+
+ if Short_Descriptors then
+ Set_Mechanism (Ent, By_Short_Descriptor);
+ else
+ Set_Mechanism (Ent, By_Descriptor);
+ end if;
+
return;
elsif Chars (Mech_Name) = Name_Short_Descriptor then
-- Note: this form is parsed as an indexed component
elsif Nkind (Mech_Name) = N_Indexed_Component then
-
Class := First (Expressions (Mech_Name));
if Nkind (Prefix (Mech_Name)) /= N_Identifier
Bad_Mechanism;
else
Mech_Name_Id := Chars (Prefix (Mech_Name));
+
+ -- Change Descriptor => Short_Descriptor if pragma was given
+
+ if Mech_Name_Id = Name_Descriptor
+ and then Short_Descriptors
+ then
+ Mech_Name_Id := Name_Short_Descriptor;
+ end if;
end if;
-- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) |
-- Note: this form is parsed as a function call
elsif Nkind (Mech_Name) = N_Function_Call then
-
Param := First (Parameter_Associations (Mech_Name));
if Nkind (Name (Mech_Name)) /= N_Identifier
Bad_Class;
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBS
+ and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Descriptor_UBS);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBSB
+ and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_UBA
+ and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Descriptor_UBA);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_S
+ and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Descriptor_S);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_SB
+ and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Descriptor_SB);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_A
+ and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Descriptor_A);
elsif Mech_Name_Id = Name_Descriptor
- and then Chars (Class) = Name_NCA
+ and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Descriptor_NCA);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBS
+ and then Chars (Class) = Name_UBS
then
Set_Mechanism (Ent, By_Short_Descriptor_UBS);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBSB
+ and then Chars (Class) = Name_UBSB
then
Set_Mechanism (Ent, By_Short_Descriptor_UBSB);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_UBA
+ and then Chars (Class) = Name_UBA
then
Set_Mechanism (Ent, By_Short_Descriptor_UBA);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_S
+ and then Chars (Class) = Name_S
then
Set_Mechanism (Ent, By_Short_Descriptor_S);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_SB
+ and then Chars (Class) = Name_SB
then
Set_Mechanism (Ent, By_Short_Descriptor_SB);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_A
+ and then Chars (Class) = Name_A
then
Set_Mechanism (Ent, By_Short_Descriptor_A);
elsif Mech_Name_Id = Name_Short_Descriptor
- and then Chars (Class) = Name_NCA
+ and then Chars (Class) = Name_NCA
then
Set_Mechanism (Ent, By_Short_Descriptor_NCA);
-- said this was a configuration pragma, but we did not check and
-- are hesitant to add the check now.
- -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
- -- or Ada 95, so we must check if we are in Ada 2005 mode.
+ -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
+ -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
+ -- or Ada 2012 mode.
if Ada_Version >= Ada_05 then
Check_Valid_Configuration_Pragma;
-- pragma Ada_2005;
-- pragma Ada_2005 (LOCAL_NAME):
- -- Note: these pragma also have some specific processing in Par.Prag
+ -- Note: these pragmas also have some specific processing in Par.Prag
-- because we want to set the Ada 2005 version mode during parsing.
when Pragma_Ada_05 | Pragma_Ada_2005 => declare
end if;
end;
+ ---------------------
+ -- Ada_12/Ada_2012 --
+ ---------------------
+
+ -- pragma Ada_12;
+ -- pragma Ada_12 (LOCAL_NAME);
+
+ -- pragma Ada_2012;
+ -- pragma Ada_2012 (LOCAL_NAME):
+
+ -- Note: these pragmas also have some specific processing in Par.Prag
+ -- because we want to set the Ada 2012 version mode during parsing.
+
+ when Pragma_Ada_12 | Pragma_Ada_2012 => declare
+ E_Id : Node_Id;
+
+ begin
+ GNAT_Pragma;
+
+ if Arg_Count = 1 then
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ Set_Is_Ada_2012_Only (Entity (E_Id));
+
+ else
+ Check_Arg_Count (0);
+
+ -- For Ada_2012 we unconditionally enforce the documented
+ -- configuration pragma placement, since we do not want to
+ -- tolerate mixed modes in a unit involving Ada 2012. That
+ -- would cause real difficulties for those cases where there
+ -- are incompatibilities between Ada 95 and Ada 2012. We could
+ -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
+
+ Check_Valid_Configuration_Pragma;
+
+ -- Now set Ada 2012 mode
+
+ Ada_Version := Ada_12;
+ Ada_Version_Explicit := Ada_12;
+ end if;
+ end;
+
----------------------
-- All_Calls_Remote --
----------------------
if Prag_Id = Pragma_Atomic_Components then
Set_Has_Atomic_Components (E);
-
- if Is_Packed (E) then
- Set_Is_Packed (E, False);
-
- Error_Pragma_Arg
- ("?Pack canceled, cannot pack atomic components",
- Arg1);
- end if;
end if;
else
Def_Id := Entity (Id);
+ -- Check if already defined as constructor
+
+ if Is_Constructor (Def_Id) then
+ Error_Msg_N
+ ("?duplicate argument for pragma 'C'P'P_Constructor", Arg1);
+ return;
+ end if;
+
if Ekind (Def_Id) = E_Function
and then (Is_CPP_Class (Etype (Def_Id))
or else (Is_Class_Wide_Type (Etype (Def_Id))
if Chars (Expression (Arg1)) = Name_On then
Extensions_Allowed := True;
+ Ada_Version := Ada_Version_Type'Last;
+
else
Extensions_Allowed := False;
+ Ada_Version := Ada_Version_Explicit;
end if;
--------------
else
-- In VMS, the effect of IDENT is achieved by passing
- -- IDENTIFICATION=name as a --for-linker switch.
+ -- --identification=name as a --for-linker switch.
if OpenVMS_On_Target then
Start_String;
Store_String_Chars
- ("--for-linker=IDENTIFICATION=");
+ ("--for-linker=--identification=");
String_To_Name_Buffer (Strval (Str));
Store_String_Chars (Name_Buffer (1 .. Name_Len));
-- associated with a with'd package.
Replace_Linker_Option_String
- (End_String, "--for-linker=IDENTIFICATION=");
+ (End_String, "--for-linker=--identification=");
end if;
Set_Ident_String (Current_Sem_Unit, Str);
end;
end Ident;
- --------------------------
- -- Implemented_By_Entry --
- --------------------------
+ -----------------
+ -- Implemented --
+ -----------------
- -- pragma Implemented_By_Entry (DIRECT_NAME);
+ -- pragma Implemented (procedure_LOCAL_NAME, implementation_kind);
+ -- implementation_kind ::= By_Entry | By_Protected_Procedure | By_Any
- when Pragma_Implemented_By_Entry => Implemented_By_Entry : declare
- Ent : Entity_Id;
+ when Pragma_Implemented => Implemented : declare
+ Proc_Id : Entity_Id;
+ Typ : Entity_Id;
begin
- Ada_2005_Pragma;
- Check_Arg_Count (1);
+ Ada_2012_Pragma;
+ Check_Arg_Count (2);
Check_No_Identifiers;
Check_Arg_Is_Identifier (Arg1);
Check_Arg_Is_Local_Name (Arg1);
- Ent := Entity (Expression (Arg1));
+ Check_Arg_Is_One_Of
+ (Arg2, Name_By_Any, Name_By_Entry, Name_By_Protected_Procedure);
+
+ -- Extract the name of the local procedure
+
+ Proc_Id := Entity (Expression (Arg1));
- -- Pragma Implemented_By_Entry must be applied only to protected
- -- synchronized or task interface primitives.
+ -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
+ -- primitive procedure of a synchronized tagged type.
- if (Ekind (Ent) /= E_Function
- and then Ekind (Ent) /= E_Procedure)
- or else not Present (First_Formal (Ent))
- or else not Is_Concurrent_Interface (Etype (First_Formal (Ent)))
+ if Ekind (Proc_Id) = E_Procedure
+ and then Is_Primitive (Proc_Id)
+ and then Present (First_Formal (Proc_Id))
then
- Error_Pragma_Arg
- ("pragma % must be applied to a concurrent interface " &
- "primitive", Arg1);
+ Typ := Etype (First_Formal (Proc_Id));
- else
- if Einfo.Implemented_By_Entry (Ent)
- and then Warn_On_Redundant_Constructs
+ if Is_Tagged_Type (Typ)
+ and then
+
+ -- Check for a protected, a synchronized or a task interface
+
+ ((Is_Interface (Typ)
+ and then Is_Synchronized_Interface (Typ))
+
+ -- Check for a protected type or a task type that implements
+ -- an interface.
+
+ or else
+ (Is_Concurrent_Record_Type (Typ)
+ and then Present (Interfaces (Typ)))
+
+ -- Check for a private record extension with keyword
+ -- "synchronized".
+
+ or else
+ (Ekind_In (Typ, E_Record_Type_With_Private,
+ E_Record_Subtype_With_Private)
+ and then Synchronized_Present (Parent (Typ))))
then
- Error_Pragma ("?duplicate pragma%!");
+ null;
else
- Set_Implemented_By_Entry (Ent);
+ Error_Pragma_Arg
+ ("controlling formal must be of synchronized " &
+ "tagged type", Arg1);
+ return;
end if;
+
+ -- Procedures declared inside a protected type must be accepted
+
+ elsif Ekind (Proc_Id) = E_Procedure
+ and then Is_Protected_Type (Scope (Proc_Id))
+ then
+ null;
+
+ -- The first argument is not a primitive procedure
+
+ else
+ Error_Pragma_Arg
+ ("pragma % must be applied to a primitive procedure", Arg1);
+ return;
end if;
- end Implemented_By_Entry;
- -----------------------
+ -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
+ -- By_Protected_Procedure to the primitive procedure of a task
+ -- interface.
+
+ if Chars (Arg2) = Name_By_Protected_Procedure
+ and then Is_Interface (Typ)
+ and then Is_Task_Interface (Typ)
+ then
+ Error_Pragma_Arg
+ ("implementation kind By_Protected_Procedure cannot be " &
+ "applied to a task interface primitive", Arg2);
+ return;
+ end if;
+
+ Record_Rep_Item (Proc_Id, N);
+ end Implemented;
+
+ ----------------------
-- Implicit_Packing --
- -----------------------
+ ----------------------
-- pragma Implicit_Packing;
Arg_First_Optional_Parameter => First_Optional_Parameter);
end Import_Valued_Procedure;
+ -----------------
+ -- Independent --
+ -----------------
+
+ -- pragma Independent (LOCAL_NAME);
+
+ when Pragma_Independent => Independent : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ Check_Ada_83_Warning;
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+ D := Declaration_Node (E);
+ K := Nkind (D);
+
+ if Is_Type (E) then
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ else
+ Check_First_Subtype (Arg1);
+ end if;
+
+ elsif K = N_Object_Declaration
+ or else (K = N_Component_Declaration
+ and then Original_Record_Component (E) = E)
+ then
+ if Rep_Item_Too_Late (E, N) then
+ return;
+ end if;
+
+ else
+ Error_Pragma_Arg
+ ("inappropriate entity for pragma%", Arg1);
+ end if;
+
+ Independence_Checks.Append ((N, E));
+ end Independent;
+
+ ----------------------------
+ -- Independent_Components --
+ ----------------------------
+
+ -- pragma Atomic_Components (array_LOCAL_NAME);
+
+ -- This processing is shared by Volatile_Components
+
+ when Pragma_Independent_Components => Independent_Components : declare
+ E_Id : Node_Id;
+ E : Entity_Id;
+ D : Node_Id;
+ K : Node_Kind;
+
+ begin
+ Check_Ada_83_Warning;
+ Ada_2012_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Expression (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+
+ if Rep_Item_Too_Early (E, N)
+ or else
+ Rep_Item_Too_Late (E, N)
+ then
+ return;
+ end if;
+
+ D := Declaration_Node (E);
+ K := Nkind (D);
+
+ if (K = N_Full_Type_Declaration
+ and then (Is_Array_Type (E) or else Is_Record_Type (E)))
+ or else
+ ((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
+ and then Nkind (D) = N_Object_Declaration
+ and then Nkind (Object_Definition (D)) =
+ N_Constrained_Array_Definition)
+ then
+ Independence_Checks.Append ((N, E));
+
+ else
+ Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
+ end if;
+ end Independent_Components;
+
------------------------
-- Initialize_Scalars --
------------------------
when Pragma_Inline_Always =>
GNAT_Pragma;
- Process_Inline (True);
+
+ -- Pragma always active unless in CodePeer mode, since this causes
+ -- walk order issues.
+
+ if not CodePeer_Mode then
+ Process_Inline (True);
+ end if;
--------------------
-- Inline_Generic --
Check_At_Most_N_Arguments (4);
Process_Import_Or_Interface;
+ -- In Ada 2005, the permission to use Interface (a reserved word)
+ -- as a pragma name is considered an obsolescent feature.
+
+ if Ada_Version >= Ada_2005 then
+ Check_Restriction
+ (No_Obsolescent_Features, Pragma_Identifier (N));
+ end if;
+
--------------------
-- Interface_Name --
--------------------
-- pragma Optimize_Alignment (Time | Space | Off);
- when Pragma_Optimize_Alignment =>
+ when Pragma_Optimize_Alignment => Optimize_Alignment : begin
GNAT_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
-- switch will get reset anyway at the start of each unit.
Optimize_Alignment_Local := True;
+ end Optimize_Alignment;
+
+ -------------
+ -- Ordered --
+ -------------
+
+ -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
+
+ when Pragma_Ordered => Ordered : declare
+ Assoc : constant Node_Id := Arg1;
+ Type_Id : Node_Id;
+ Typ : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Type_Id := Expression (Assoc);
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ if not Is_Enumeration_Type (Typ) then
+ Error_Pragma ("pragma% must specify enumeration type");
+ end if;
+
+ Check_First_Subtype (Arg1);
+ Set_Has_Pragma_Ordered (Base_Type (Typ));
+ end Ordered;
----------
-- Pack --
Assoc : constant Node_Id := Arg1;
Type_Id : Node_Id;
Typ : Entity_Id;
+ Ctyp : Entity_Id;
+ Ignore : Boolean := False;
begin
Check_No_Identifiers;
-- Array type
elsif Is_Array_Type (Typ) then
+ Ctyp := Component_Type (Typ);
- -- Pack not allowed for aliased or atomic components
+ -- Ignore pack that does nothing
- if Has_Aliased_Components (Base_Type (Typ)) then
- Error_Pragma
- ("pragma% ignored, cannot pack aliased components?");
-
- elsif Has_Atomic_Components (Typ)
- or else Is_Atomic (Component_Type (Typ))
+ if Known_Static_Esize (Ctyp)
+ and then Known_Static_RM_Size (Ctyp)
+ and then Esize (Ctyp) = RM_Size (Ctyp)
+ and then Addressable (Esize (Ctyp))
then
- Error_Pragma
- ("?pragma% ignored, cannot pack atomic components");
+ Ignore := True;
end if;
- -- If we had an explicit component size given, then we do not
- -- let Pack override this given size. We also give a warning
- -- that Pack is being ignored unless we can tell for sure that
- -- the Pack would not have had any effect anyway.
+ -- Process OK pragma Pack. Note that if there is a separate
+ -- component clause present, the Pack will be cancelled. This
+ -- processing is in Freeze.
- if Has_Component_Size_Clause (Typ) then
- if Known_Static_RM_Size (Component_Type (Typ))
- and then
- RM_Size (Component_Type (Typ)) = Component_Size (Typ)
- then
- null;
- else
- Error_Pragma
- ("?pragma% ignored, explicit component size given");
- end if;
-
- -- If no prior array component size given, Pack is effective
-
- else
- if not Rep_Item_Too_Late (Typ, N) then
+ if not Rep_Item_Too_Late (Typ, N) then
- -- In the context of static code analysis, we do not need
- -- complex front-end expansions related to pragma Pack,
- -- so disable handling of pragma Pack in this case.
+ -- In the context of static code analysis, we do not need
+ -- complex front-end expansions related to pragma Pack,
+ -- so disable handling of pragma Pack in this case.
- if CodePeer_Mode then
- null;
+ if CodePeer_Mode then
+ null;
- -- For normal non-VM target, do the packing
+ -- For normal non-VM target, do the packing
- elsif VM_Target = No_VM then
+ elsif VM_Target = No_VM then
+ if not Ignore then
Set_Is_Packed (Base_Type (Typ));
- Set_Has_Pragma_Pack (Base_Type (Typ));
- Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ Set_Has_Non_Standard_Rep (Base_Type (Typ));
+ end if;
- -- If we ignore the pack, then warn about this, except
- -- that we suppress the warning in GNAT mode.
+ Set_Has_Pragma_Pack (Base_Type (Typ));
- elsif not GNAT_Mode then
- Error_Pragma
- ("?pragma% ignored in this configuration");
- end if;
+ -- If we ignore the pack for VM_Targets, then warn about
+ -- this, except suppress the warning in GNAT mode.
+
+ elsif not GNAT_Mode then
+ Error_Pragma
+ ("?pragma% ignored in this configuration");
end if;
end if;
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
- -- set to Ada_05 in a predefined unit), we need to know the
+ -- set to Ada_12 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_05 then
-- This is one of the few cases where we need to test the value of
-- Ada_Version_Explicit rather than Ada_Version (which is always
- -- set to Ada_05 in a predefined unit), we need to know the
+ -- set to Ada_12 in a predefined unit), we need to know the
-- explicit version set to know if this pragma is active.
if Ada_Version_Explicit >= Ada_05 then
Set_Is_Shared_Passive (Cunit_Ent);
end Shared_Passive;
+ -----------------------
+ -- Short_Descriptors --
+ -----------------------
+
+ -- pragma Short_Descriptors;
+
+ when Pragma_Short_Descriptors =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Short_Descriptors := True;
+
----------------------
-- Source_File_Name --
----------------------
Comp := First (Component_Items (Clist));
while Present (Comp) loop
- Check_Component (Comp);
+ Check_Component (Comp, Typ);
Next (Comp);
end loop;
Variant := First (Variants (Vpart));
while Present (Variant) loop
- Check_Variant (Variant);
+ Check_Variant (Variant, Typ);
Next (Variant);
end loop;
end if;
elsif not Is_Static_String_Expression (Arg1) then
Error_Pragma_Arg
("argument of pragma% must be On/Off or " &
- "static string expression", Arg2);
+ "static string expression", Arg1);
-- One argument string expression case
raise Program_Error;
end case;
+ -- AI05-0144: detect dangerous order dependence. Disabled for now,
+ -- until AI is formally approved.
+
+ -- Check_Order_Dependence;
+
exception
when Pragma_Exit => null;
end Analyze_Pragma;
Pragma_Ada_95 => -1,
Pragma_Ada_05 => -1,
Pragma_Ada_2005 => -1,
+ Pragma_Ada_12 => -1,
+ Pragma_Ada_2012 => -1,
Pragma_All_Calls_Remote => -1,
Pragma_Annotate => -1,
Pragma_Assert => -1,
Pragma_Finalize_Storage_Only => 0,
Pragma_Float_Representation => 0,
Pragma_Ident => -1,
- Pragma_Implemented_By_Entry => -1,
+ Pragma_Implemented => -1,
Pragma_Implicit_Packing => 0,
Pragma_Import => +2,
Pragma_Import_Exception => 0,
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
+ Pragma_Independent => 0,
+ Pragma_Independent_Components => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
Pragma_Optimize_Alignment => -1,
+ Pragma_Ordered => 0,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
Pragma_Share_Generic => -1,
Pragma_Shared => -1,
Pragma_Shared_Passive => -1,
+ Pragma_Short_Descriptors => 0,
Pragma_Source_File_Name => -1,
Pragma_Source_File_Name_Project => -1,
Pragma_Source_Reference => -1,
OSDN Git Service
