+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * atree.ads, atree.adb (Node30): New function.
+ (Set_Node30): New procedure.
+ (Num_Extension_Nodes): Change to 5 (activate new fields/flags).
+ * atree.h: Add macros for Field30 and Node30.
+ * einfo.ads, einfo.adb: Move some fields to avoid duplexing.
+ * treepr.adb (Print_Entity_Information): Print fields 30-35.
+
+2013-01-29 Robert Dewar <dewar@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case Interface): Consider to
+ be a violation of No_Obsolescent_Features even in Ada 95. Also
+ generates a warning in -gnatwj mode.
+ (Analyze_Pragma, case Interface_Name): Generates a warning in -gnatwj
+ mode.
+ * gnat_ugn.texi: Additional documentation on -gnatwj and pragma
+ Interface[_Name].
+
+2013-01-29 Vincent Celier <celier@adacore.com>
+
+ * snames.ads-tmpl: Add new standard name Trailing_Switches.
+
+2013-01-29 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_disp.adb (Check_Controlling_Type): If a designated type T
+ of an anonymous access type is a limited view of a tagged type,
+ it can be a controlling type only if the subprogram is in the
+ same scope as T.
+
+2013-01-29 Vincent Celier <celier@adacore.com>
+
+ * gnatcmd.adb: Use the project where the config pragmas file is
+ declared to get its path.
+
+2013-01-29 Vincent Celier <celier@adacore.com>
+
+ * prj-attr.adb: New attribute Linker'Trailing_Switches.
+
2013-01-22 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (gnat_to_gnu) <N_Expression_With_Actions>: Do
-- entries in this table. Normal programs won't use it at all.
type Paren_Count_Entry is record
- Nod : Node_Id;
+ Nod : Node_Id;
-- The node to which this count applies
Count : Nat range 3 .. Nat'Last;
return Node_Id (Nodes.Table (N + 4).Field11);
end Node29;
+ function Node30 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 5).Field6);
+ end Node30;
+
function List1 (N : Node_Id) return List_Id is
begin
pragma Assert (N <= Nodes.Last);
Nodes.Table (N + 4).Field11 := Union_Id (Val);
end Set_Node29;
+ procedure Set_Node30 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 5).Field6 := Union_Id (Val);
+ end Set_Node30;
+
procedure Set_List1 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N <= Nodes.Last);
-- Size of Entities --
----------------------
- -- Currently entities are composed of 5 sequentially allocated 32-byte
+ -- Currently entities are composed of 6 sequentially allocated 32-byte
-- nodes, considered as a single record. The following definition gives
-- the number of extension nodes.
- Num_Extension_Nodes : Int := 4;
- -- This value is increased by one if debug flag -gnatd.N is set
+ Num_Extension_Nodes : Int := 5;
+ -- This value is increased by one if debug flag -gnatd.N is set. This is
+ -- for testing performance impact of adding a new extension node.
----------------------------------------
-- Definitions of Fields in Tree Node --
function Node29 (N : Node_Id) return Node_Id;
pragma Inline (Node29);
+ function Node30 (N : Node_Id) return Node_Id;
+ pragma Inline (Node30);
+
function List1 (N : Node_Id) return List_Id;
pragma Inline (List1);
procedure Set_Node29 (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node29);
+ procedure Set_Node30 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node30);
+
procedure Set_List1 (N : Node_Id; Val : List_Id);
pragma Inline (Set_List1);
* *
* C Header File *
* *
- * 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- *
#define Field27(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field9)
#define Field28(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field10)
#define Field29(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.field11)
+#define Field30(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.field6)
#define Node1(N) Field1 (N)
#define Node2(N) Field2 (N)
#define Node27(N) Field27 (N)
#define Node28(N) Field28 (N)
#define Node29(N) Field29 (N)
+#define Node30(N) Field30 (N)
#define List1(N) Field1 (N)
#define List2(N) Field2 (N)
-- Esize Uint12
-- Next_Inlined_Subprogram Node12
- -- Corresponding_Equality Node13
-- Component_Clause Node13
-- Elaboration_Entity Node13
-- Extra_Accessibility Node13
-- Overridden_Operation Node26
-- Package_Instantiation Node26
-- Relative_Deadline_Variable Node26
- -- Static_Initialization Node26
-- Current_Use_Clause Node27
-- Related_Type Node27
-- Subprograms_For_Type Node29
- -- (unused) Node30
+ -- Corresponding_Equality Node30
+ -- Static_Initialization Node30
-- (unused) Node31
(Ekind (Id) = E_Function
and then not Comes_From_Source (Id)
and then Chars (Id) = Name_Op_Ne);
- return Node13 (Id);
+ return Node30 (Id);
end Corresponding_Equality;
function Corresponding_Protected_Entry (Id : E) return E is
begin
pragma Assert
(Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
- return Node26 (Id);
+ return Node30 (Id);
end Static_Initialization;
function Stored_Constraint (Id : E) return L is
(Ekind (Id) = E_Function
and then not Comes_From_Source (Id)
and then Chars (Id) = Name_Op_Ne);
- Set_Node13 (Id, V);
+ Set_Node30 (Id, V);
end Set_Corresponding_Equality;
procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
begin
pragma Assert
(Ekind (Id) = E_Procedure and then not Is_Dispatching_Operation (Id));
- Set_Node26 (Id, V);
+ Set_Node30 (Id, V);
end Set_Static_Initialization;
procedure Set_Stored_Constraint (Id : E; V : L) is
Write_Str ("Component_Clause");
when E_Function =>
- if not Comes_From_Source (Id)
- and then
- Chars (Id) = Name_Op_Ne
- then
- Write_Str ("Corresponding_Equality");
-
- elsif Comes_From_Source (Id) then
- Write_Str ("Elaboration_Entity");
-
- else
- Write_Str ("Field13??");
- end if;
+ Write_Str ("Elaboration_Entity");
when E_Procedure |
E_Package |
when E_Procedure |
E_Function =>
- if Ekind (Id) = E_Procedure
- and then not Is_Dispatching_Operation (Id)
- then
- Write_Str ("Static_Initialization");
- else
- Write_Str ("Overridden_Operation");
- end if;
+ Write_Str ("Overridden_Operation");
when others =>
Write_Str ("Field26??");
end case;
end Write_Field28_Name;
+ ------------------------
+ -- Write_Field29_Name --
+ ------------------------
+
procedure Write_Field29_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
end case;
end Write_Field29_Name;
+ ------------------------
+ -- Write_Field30_Name --
+ ------------------------
+
+ procedure Write_Field30_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when E_Function =>
+ Write_Str ("Corresponding_Equality");
+
+ when E_Procedure =>
+ Write_Str ("Static_Initialization");
+
+ when others =>
+ Write_Str ("Field30??");
+ end case;
+ end Write_Field30_Name;
+
+ ------------------------
+ -- Write_Field31_Name --
+ ------------------------
+
+ procedure Write_Field31_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field31??");
+ end case;
+ end Write_Field31_Name;
+
+ ------------------------
+ -- Write_Field32_Name --
+ ------------------------
+
+ procedure Write_Field32_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field32??");
+ end case;
+ end Write_Field32_Name;
+
+ ------------------------
+ -- Write_Field33_Name --
+ ------------------------
+
+ procedure Write_Field33_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field33??");
+ end case;
+ end Write_Field33_Name;
+
+ ------------------------
+ -- Write_Field34_Name --
+ ------------------------
+
+ procedure Write_Field34_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field34??");
+ end case;
+ end Write_Field34_Name;
+
+ ------------------------
+ -- Write_Field35_Name --
+ ------------------------
+
+ procedure Write_Field35_Name (Id : Entity_Id) is
+ begin
+ case Ekind (Id) is
+ when others =>
+ Write_Str ("Field35??");
+ end case;
+ end Write_Field35_Name;
+
-------------------------
-- Iterator Procedures --
-------------------------
-- used to constrain a discriminant of the parent type. Points to the
-- corresponding discriminant in the parent type. Otherwise it is Empty.
--- Corresponding_Equality (Node13)
+-- Corresponding_Equality (Node30)
-- Defined in function entities for implicit inequality operators.
-- Denotes the explicit or derived equality operation that creates
-- the implicit inequality. Note that this field is not present in
-- all types declared in the package, and that a warning must be emitted
-- for those types to which static initialization is not available.
--- Static_Initialization (Node26)
+-- Static_Initialization (Node30)
-- Defined in initialization procedures for types whose objects can be
-- initialized statically. The value of this attribute is a positional
-- aggregate whose components are compile-time static values. Used
-- Handler_Records (List10) (non-generic case only)
-- Protected_Body_Subprogram (Node11)
-- Next_Inlined_Subprogram (Node12)
- -- Corresponding_Equality (Node13) (implicit /= only)
- -- Elaboration_Entity (Node13) (all other cases)
+ -- Elaboration_Entity (Node13) (not implicit /=)
-- First_Optional_Parameter (Node14) (non-generic case only)
-- DT_Position (Uint15)
-- DTC_Entity (Node16)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Subprograms_For_Type (Node29)
+ -- Corresponding_Equality (Node30) (implicit /= only)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Default_Expressions_Processed (Flag108)
-- Protection_Object (Node23) (for concurrent kind)
-- Contract (Node24)
-- Interface_Alias (Node25)
- -- Static_Initialization (Node26) (init_proc only)
-- Overridden_Operation (Node26) (never for init proc)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
+ -- Static_Initialization (Node30) (init_proc only)
-- Body_Needed_For_SAL (Flag40)
-- Delay_Cleanups (Flag114)
-- Discard_Names (Flag88)
procedure Write_Field27_Name (Id : Entity_Id);
procedure Write_Field28_Name (Id : Entity_Id);
procedure Write_Field29_Name (Id : Entity_Id);
+ procedure Write_Field30_Name (Id : Entity_Id);
+ procedure Write_Field31_Name (Id : Entity_Id);
+ procedure Write_Field32_Name (Id : Entity_Id);
+ procedure Write_Field33_Name (Id : Entity_Id);
+ procedure Write_Field34_Name (Id : Entity_Id);
+ procedure Write_Field35_Name (Id : Entity_Id);
-- These routines are used in Treepr to output a nice symbolic name for
-- the given field, depending on the Ekind. No blanks or end of lines are
-- output, just the characters of the field name.
GNAT features that have been provided in past versions but which
have been superseded (typically by features in the new Ada standard).
For example, @code{pragma Ravenscar} will be flagged since its
-function is replaced by @code{pragma Profile(Ravenscar)}.
+function is replaced by @code{pragma Profile(Ravenscar)}, and
+@code{pragma Interface_Name} will be flagged since its function
+is replaced by @code{pragma Import}.
Note that this warning option functions differently from the
restriction @code{No_Obsolescent_Features} in two respects.
then
declare
Path : constant String :=
- Absolute_Path
- (Path_Name_Type (Variable.Value), Project);
+ Absolute_Path
+ (Path_Name_Type (Variable.Value),
+ Variable.Project);
begin
Add_To_Carg_Switches
(new String'("-gnatec=" & Path));
then
declare
Path : constant String :=
- Absolute_Path
- (Path_Name_Type (Variable.Value), Project);
+ Absolute_Path
+ (Path_Name_Type (Variable.Value),
+ Variable.Project);
begin
Add_To_Carg_Switches
(new String'("-gnatec=" & Path));
"Ladefault_switches#" &
"LcOleading_switches#" &
"LcOswitches#" &
+ "LcOtrailing_switches#" &
"LVlinker_options#" &
"SVmap_file_option#" &
elsif From_With_Type (Designated_Type (T))
and then Present (Non_Limited_View (Designated_Type (T)))
+ and then Scope (Designated_Type (T)) = Scope (Subp)
then
if Is_First_Subtype (Non_Limited_View (Designated_Type (T))) then
Tagged_Type := Non_Limited_View (Designated_Type (T));
Process_Import_Or_Interface;
-- In Ada 2005, the permission to use Interface (a reserved word)
- -- as a pragma name is considered an obsolescent feature.
+ -- as a pragma name is considered an obsolescent feature, and this
+ -- pragma was already obsolescent in Ada 95.
- if Ada_Version >= Ada_2005 then
+ if Ada_Version >= Ada_95 then
Check_Restriction
(No_Obsolescent_Features, Pragma_Identifier (N));
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("pragma Interface is an obsolescent feature?j?", N);
+ Error_Msg_N
+ ("|use pragma Import instead?j?", N);
+ end if;
end if;
--------------------
Id := Get_Pragma_Arg (Arg1);
Analyze (Id);
+ -- This is obsolete from Ada 95 on, but it is an implementation
+ -- defined pragma, so we do not consider that it violates the
+ -- restriction (No_Obsolescent_Features).
+
+ if Ada_Version >= Ada_95 then
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("pragma Interface_Name is an obsolescent feature?j?", N);
+ Error_Msg_N
+ ("|use pragma Import instead?j?", N);
+ end if;
+ end if;
+
if not Is_Entity_Name (Id) then
Error_Pragma_Arg
("first argument for pragma% must be entity name", Arg1);
Name_Toolchain_Description : constant Name_Id := N + $;
Name_Toolchain_Version : constant Name_Id := N + $;
Name_Trailing_Required_Switches : constant Name_Id := N + $;
+ Name_Trailing_Switches : constant Name_Id := N + $;
Name_Runtime_Library_Dir : constant Name_Id := N + $;
Name_Runtime_Source_Dir : constant Name_Id := N + $;
Print_Eol;
end if;
+ if Field_Present (Field30 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field30_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field30 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field31 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field31_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field31 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field32 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field32_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field32 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field33 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field33_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field33 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field34 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field34_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field34 (Ent));
+ Print_Eol;
+ end if;
+
+ if Field_Present (Field35 (Ent)) then
+ Print_Str (Prefix);
+ Write_Field35_Name (Ent);
+ Write_Str (" = ");
+ Print_Field (Field35 (Ent));
+ Print_Eol;
+ end if;
+
Write_Entity_Flags (Ent, Prefix);
end Print_Entity_Info;
projects / gcc.git / commitdiff