summaryrefslogtreecommitdiff
path: root/gcc/ada/prj-attr.adb
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2004-09-13 10:18:42 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2004-09-13 10:18:42 +0000
commit44d43e97acb586d2eb6efaee9f3092e069a1642f (patch)
treeb660d80503dd74c8b52af273fa1a7b3c2af763e6 /gcc/ada/prj-attr.adb
parent976bf0956590a27721a30d3d734c740ea65b5cdd (diff)
downloadgcc-44d43e97acb586d2eb6efaee9f3092e069a1642f.tar.gz
2004-09-09 Vincent Celier <celier@gnat.com>
* a-direct.ads: Add pragma Ada_05 (Directory_Entry_Type): Give default value to component Kind to avoid not initialized warnings. * a-direct.adb (Current_Directory): Remove directory separator at the end. (Delete_Directory, Delete_Tree): Raise Name_Error if Directory is not an existing directory. (Fetch_Next_Entry): Give default value to variable Kind to avoid warning (Size (String)): Function C_Size returns Long_Integer, not File_Size. Convert the result to File_Size. * prj.ads: (Project_Error): New exception * prj-attr.adb: Except in procedure Initialize, Fail comes from Prj.Com, not from Osint. (Attrs, Package_Attributes): Tables moved to private part of spec (Add_Attribute, Add_Unknown_Package): Moved to new child package Prj.Attr.PM. (Register_New_Package (Name, Attributes), Register_New_Attribute): Raise Prj.Project_Error after call to Fail. (Register_New_Package (Name, Id)): Set Id to Empty_Package after calling Fail. Check that package name is not already in use. * prj-attr.ads: Comment updates to indicate that all subprograms may be used by tools, not only by the project manager, and to indicate that exception Prj.Prj_Error may be raised in case of problem. (Add_Unknown_Package, Add_Attribute): Moved to new child package Prj.Attr.PM. (Attrs, Package_Attributes): Table instantiations moved from the body to the private part to be accessible from Prj.Attr.PM body. * prj-dect.adb (Parse_Package_Declaration): Call Add_Unknown_Package from new package Prj.Attr.PM. (Parse_Attribute_Declaration): Call Add_Attribute from new package Prj.Attr.PM. * Makefile.in: Add prj-attr-pm.o to gnatmake object list * gnatbind.adb (Gnatbind): Correct warning message (Elaboration_Check instead of Elaboration_Checks). * a-calend.adb: Minor reformatting 2004-09-09 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> * gigi.h (maybe_pad_type): New declaration. (create_subprog_type): New arg RETURNS_BY_TARGET_PTR. * ada-tree.h: (TYPE_RETURNS_BY_TARGET_PTR_P): New macro. * cuintp.c: Convert to use buildN. * decl.c (maybe_pad_type): No longer static. (gnat_to_gnu_entity, case E_Function): Handle case of returning by target pointer. Convert to use buildN. * trans.c (call_to_gnu): Add arg GNU_TARGET; support TYPE_RETURNS_BY_TARGET_PTR_P. All callers changed. (gnat_to_gnu, case N_Assignment_Statement): Call call_to_gnu if call on RHS. (gnat_to_gnu, case N_Return): Handle TYPE_RETURN_BY_TARGET_PTR_P. (gnat_gimplify_expr, case ADDR_EXPR): New case. Convert to use buildN. * utils2.c (gnat_build_constructor): Also set TREE_INVARIANT and TREE_READONLY for const. Convert to use buildN. * utils.c (create_subprog_type): New operand RETURNS_BY_TARGET_PTR. (create_var_decl): Refine when TREE_STATIC is set. Convert to use buildN. 2004-09-09 Gary Dismukes <dismukes@gnat.com> * gnat_ugn.texi: Delete text relating to checking of ali and object consistency. * a-except.adb (Rcheck_*): Add pragmas No_Return for each of these routines. 2004-09-09 Jose Ruiz <ruiz@act-europe.fr> * gnat_ugn.texi: Add Detect_Blocking to the list of configuration pragmas recognized by GNAT. * gnat_rm.texi: Document pragma Detect_Blocking. * s-solita.adb (Timed_Delay_T): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. * s-taprob.adb (Lock): When pragma Detect_Blocking is active increase the protected action nesting level. (Lock_Read_Only): When pragma Detect_Blocking is active increase the protected action nesting level. (Unlock): When pragma Detect_Blocking is active decrease the protected action nesting level. * s-taskin.adb (Initialize_ATCB): Initialize to 0 the Protected_Action_Nesting. * s-taskin.ads: Adding the field Protected_Action_Nesting to the Common_ATCB record. It contains the dynamic level of protected action nesting for each task. It is needed for checking whether potentially blocking operations are called from protected operations. (Detect_Blocking): Adding a Boolean constant reflecting whether pragma Detect_Blocking is active or not in the partition. * s-tasren.adb (Call_Simple): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. (Task_Entry_Call): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. (Timed_Task_Entry_Call): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. * s-tassta.adb (Abort_Tasks): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. * s-tpoben.adb (Lock_Entries): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation, and increase the protected action nesting level. (Lock_Read_Only_Entries): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation, and increase the protected action nesting level. (Unlock_Entries): When pragma Detect_Blocking is active decrease the protected action nesting level. * s-tposen.adb (Lock_Entry): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation, and increase the protected action nesting level. (Lock_Read_Only_Entry): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation, and increase the protected action nesting level. (Protected_Single_Entry_Call): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. (Timed_Protected_Single_Entry_Call): When pragma Detect_Blocking is active, raise Program_Error if called from a protected operation. (Unlock_Entry): When pragma Detect_Blocking is active decrease the protected action nesting level. * sem_util.adb (Check_Potentially_Blocking_Operation): Remove the insertion of the statement raising Program_Error. The run time contains the required machinery for handling that. * sem_util.ads: Change comment associated to procedure Check_Potentially_Blocking_Operation. This procedure does not insert a call for raising the exception because that is currently done by the run time. * raise.h (__gnat_set_globals): Pass the detect_blocking parameter. * init.c: Add the global variable __gl_detect_blocking that indicates whether pragma Detect_Blocking is active (1) or not (0). Needed for making the pragma available at run time. (__gnat_set_globals): Pass and update the detect_blocking parameter. * lib-writ.adb (Write_ALI): Set the DB flag in the ali file if pragma Detect_Blocking is active. * lib-writ.ads: Document the Detect_Blocking flag (DB) in ali files. * ali.adb (Scan_ALI): Set the Detect_Blocking value to true if the flag DB is found in the ali file. Any unit compiled with pragma Detect_Blocking active forces its effect in the whole partition. * a-retide.adb (Delay_Until): Raise Program_Error if pragma Detect_Blocking is active and delay is called from a protected operation. * bindgen.adb (Gen_Adainit_Ada): When generating the call to __gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma Detect_Blocking is active (0 otherwise). (Gen_Adainit_C): When generating the call to __gnat_set_globals, pass 1 as Detect_Blocking parameter if pragma Detect_Blocking is active (0 otherwise). 2004-09-09 Thomas Quinot <quinot@act-europe.fr> * gnat_rm.texi: Rename GNAT.Perfect_Hash.Generators to GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash package. * s-parint.ads, s-parint.adb (Get_RAS_Info): New subprogram. (Register_Receiving_Stub): Add Subp_Info formal parameter. Update API in placeholder implemetation of s-parint to reflect changes in distribution runtime library. * sem_ch3.adb (Expand_Derived_Record): Rename to Expand_Record_Extension. * sem_disp.adb (Check_Controlling_Formals): Improve error message for primitive operations of potentially distributed object types that have non-controlling anonymous access formals. * sem_dist.ads, sem_dist.adb (Build_RAS_Primitive_Specification): New subprogram. New implementation of expansion for remote access-to-subprogram types, based on the RACW infrastructure. This version of sem_dist is compatible with PolyORB/DSA as well as GLADE. * sem_prag.adb (Analyze_Pragma, case Pragma_Asynchronous): For a pragma Asynchrronous that applies to a remote access-to-subprogram type, mark the underlying RACW type as asynchronous. * link.c: FreeBSD uses GNU ld: set __gnat_objlist_file_supported and __gnat_using_gnu_linker to 1. * Makefile.rtl, impunit.adb, g-perhas.ads, g-pehage.ads, g-pehage.adb: Rename GNAT.Perfect_Hash.Generators to GNAT.Perfect_Hash_Generators, and remove the empty GNAT.Perfect_Hash package. * atree.adb: Minor reformatting * exp_ch3.adb (Expand_Derived_Record): Rename to Expand_Record_Extension. (Build_Record_Init_Proc.Build_Assignment): The default expression in a component declaration must remain attached at that point in the tree so New_Copy_Tree copies it if the enclosing record type is derived. It is therefore necessary to take a copy of the expression when building the corresponding assignment statement in the init proc. As a side effect, in the case of a derived record type, we now see the original expression, without any rewriting that could have occurred during expansion of the ancestor type's init proc, and we do not need to go back to Original_Node. * exp_ch3.ads (Expand_Derived_Record): Rename to Expand_Record_Extension. * exp_dist.ads, exp_dist.adb (Underlying_RACW_Type): New subprogram. Returns the RACW type used to implement a remote access-to-subprogram type. (Add_RAS_Proxy_And_Analyze, Build_Remote_Subprogram_Proxy_Type): New subprograms. Used to create a proxy tagged object for a remote subprogram. The proxy object is used as the designated object for RAS values on the same partition (unless All_Calls_Remote applies). (Build_Get_Unique_RP_Call): New subprogram. Build a call to System.Partition_Interface.Get_Unique_Remote_Pointer. (Add_RAS_Access_TSS, Add_RAS_Dereference_TSS): Renamed from Add_RAS_*_Attribute. (Add_Receiving_Stubs_To_Declarations): Generate a table of local subprograms. New implementation of expansion for remote access-to-subprogram types, based on the RACW infrastructure. * exp_dist.ads (Copy_Specification): Update comment to note that this function can copy the specification from either a subprogram specification or an access-to-subprogram type definition. 2004-09-09 Ed Schonberg <schonberg@gnat.com> * sem_type.adb (Disambiguate): Handle properly an accidental ambiguity in an instance, between an explicit subprogram an one inherited from a type derived from an actual. * exp_ch6.adb (Expand_N_Subprogram_Body): If polling is enabled, do not add a polling call if the subprogram is to be inlined by the back-end, to avoid repeated calls with multiple inlinings. * checks.adb (Apply_Alignment_Check): If the expression in the address clause is a call whose name is not a static entity (e.g. a dispatching call), treat as dynamic. 2004-09-09 Robert Dewar <dewar@gnat.com> * g-trasym.ads: Minor reformatting * exp_ch3.adb (Component_Needs_Simple_Initialization): Don't except packed arrays, since unused bits are expected to be zero for a comparison. 2004-09-09 Eric Botcazou <ebotcazou@act-europe.fr> * exp_pakd.ads: Fix an inacurracy and a couple of typos in the head comment. 2004-09-09 Pascal Obry <obry@gnat.com> * mdll.ads, mdll.adb (Build_Dynamic_Library): New parameter Map_File to enable map file generation. Add the right option to generate the map file if Map_File is set to True. * gnatdll.adb (Gen_Map_File): New variable. (Syntax): Add info about new -m (Map_File) option. (Parse_Command_Line): Add support for -m option. (gnatdll): Pass Gen_Map_File to Build_Dynamic_Library calls. Minor reformatting. 2004-09-09 Laurent Pautet <pautet@act-europe.fr> * gnatls.adb: Add a very verbose mode -V. Such mode is required by the new gnatdist implementation. Define a subpackage isolating the output routines specific to this verbose mode. 2004-09-09 Joel Brobecker <brobecker@gnat.com> * Makefile.rtl: (GNATRTL_NONTASKING_OBJS): Add g-dynhta. * gnat_ugn.texi (Main Subprograms): Fix typo. Deduced, not deducted. 2004-09-09 Cyrille Comar <comar@act-europe.fr> * opt.adb (Set_Opt_Config_Switches): Use Ada_Version_Runtime to compile internal unit. * opt.ads: Add Ada_Version_Runtime constant used to decide which version of the language is used to compile the run time. 2004-09-09 Arnaud Charlet <charlet@act-europe.fr> * sem_util.adb (Requires_Transient_Scope): Re-enable handling of variable length temporaries for function return now that the back-end and gigi support it. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@87435 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/prj-attr.adb')
-rw-r--r--gcc/ada/prj-attr.adb124
1 files changed, 31 insertions, 93 deletions
diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb
index 2127e35067c..324b7dcde30 100644
--- a/gcc/ada/prj-attr.adb
+++ b/gcc/ada/prj-attr.adb
@@ -24,8 +24,9 @@
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
-with Osint; use Osint;
+with Namet; use Namet;
+with Osint;
+with Prj.Com; use Prj.Com;
with Table;
with System.Case_Util; use System.Case_Util;
@@ -39,11 +40,13 @@ package body Prj.Attr is
-- Package names are preceded by 'P'
-- Attribute names are preceded by two letters:
+
-- The first letter is one of
-- 'S' for Single
-- 's' for Single with optional index
-- 'L' for List
-- 'l' for List of strings with optional indexes
+
-- The second letter is one of
-- 'V' for single variable
-- 'A' for associative array
@@ -186,90 +189,9 @@ package body Prj.Attr is
Initialized : Boolean := False;
-- A flag to avoid multiple initialization
- ----------------
- -- Attributes --
- ----------------
-
- type Attribute_Record is record
- Name : Name_Id;
- Var_Kind : Variable_Kind;
- Optional_Index : Boolean;
- Attr_Kind : Attribute_Kind;
- Next : Attr_Node_Id;
- end record;
- -- Data for an attribute
-
- package Attrs is
- new Table.Table (Table_Component_Type => Attribute_Record,
- Table_Index_Type => Attr_Node_Id,
- Table_Low_Bound => First_Attribute,
- Table_Initial => Attributes_Initial,
- Table_Increment => Attributes_Increment,
- Table_Name => "Prj.Attr.Attrs");
- -- The table of the attributes
-
- --------------
- -- Packages --
- --------------
-
- type Package_Record is record
- Name : Name_Id;
- Known : Boolean := True;
- First_Attribute : Attr_Node_Id;
- end record;
- -- Data for a package
-
- package Package_Attributes is
- new Table.Table (Table_Component_Type => Package_Record,
- Table_Index_Type => Pkg_Node_Id,
- Table_Low_Bound => First_Package,
- Table_Initial => Packages_Initial,
- Table_Increment => Packages_Increment,
- Table_Name => "Prj.Attr.Packages");
- -- The table of the packages
-
function Name_Id_Of (Name : String) return Name_Id;
-- Returns the Name_Id for Name in lower case
- -------------------
- -- Add_Attribute --
- -------------------
-
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id)
- is
- begin
- -- Only add the attribute if the package is already defined
-
- if To_Package /= Empty_Package then
- Attrs.Increment_Last;
- Attrs.Table (Attrs.Last) :=
- (Name => Attribute_Name,
- Var_Kind => Undefined,
- Optional_Index => False,
- Attr_Kind => Unknown,
- Next =>
- Package_Attributes.Table (To_Package.Value).First_Attribute);
- Package_Attributes.Table (To_Package.Value).First_Attribute :=
- Attrs.Last;
- Attribute_Node := (Value => Attrs.Last);
- end if;
- end Add_Attribute;
-
- -------------------------
- -- Add_Unknown_Package --
- -------------------------
-
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is
- begin
- Package_Attributes.Increment_Last;
- Id := (Value => Package_Attributes.Last);
- Package_Attributes.Table (Id.Value) :=
- (Name => Name, Known => False, First_Attribute => Empty_Attr);
- end Add_Unknown_Package;
-
-----------------------
-- Attribute_Kind_Of --
-----------------------
@@ -307,6 +229,7 @@ package body Prj.Attr is
Starting_At : Attribute_Node_Id) return Attribute_Node_Id
is
Id : Attr_Node_Id := Starting_At.Value;
+
begin
while Id /= Empty_Attr
and then Attrs.Table (Id).Name /= Name
@@ -386,7 +309,7 @@ package body Prj.Attr is
for Index in First_Package .. Package_Attributes.Last loop
if Package_Name = Package_Attributes.Table (Index).Name then
- Fail ("duplicate name """,
+ Osint.Fail ("duplicate name """,
Initialization_Data (Start .. Finish - 1),
""" in predefined packages.");
end if;
@@ -438,14 +361,14 @@ package body Prj.Attr is
Attr_Kind := Case_Insensitive_Associative_Array;
when 'b' =>
- if File_Names_Case_Sensitive then
+ if Osint.File_Names_Case_Sensitive then
Attr_Kind := Associative_Array;
else
Attr_Kind := Case_Insensitive_Associative_Array;
end if;
when 'c' =>
- if File_Names_Case_Sensitive then
+ if Osint.File_Names_Case_Sensitive then
Attr_Kind := Optional_Index_Associative_Array;
else
Attr_Kind :=
@@ -480,7 +403,7 @@ package body Prj.Attr is
for Index in First_Attribute .. Attrs.Last - 1 loop
if Attribute_Name = Attrs.Table (Index).Name then
- Fail ("duplicate attribute """,
+ Osint.Fail ("duplicate attribute """,
Initialization_Data (Start .. Finish - 1),
""" in " & Attribute_Location);
end if;
@@ -581,11 +504,13 @@ package body Prj.Attr is
begin
if Name'Length = 0 then
Fail ("cannot register an attribute with no name");
+ raise Project_Error;
end if;
if In_Package = Empty_Package then
Fail ("attempt to add attribute """, Name,
""" to an undefined package");
+ raise Project_Error;
end if;
Attr_Name := Name_Id_Of (Name);
@@ -603,7 +528,7 @@ package body Prj.Attr is
Get_Name_String
(Package_Attributes.Table (In_Package.Value).Name) &
"""");
- exit;
+ raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
@@ -613,7 +538,7 @@ package body Prj.Attr is
-- If Index_Is_File_Name, change the attribute kind if necessary
- if Index_Is_File_Name and then not File_Names_Case_Sensitive then
+ if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
case Attr_Kind is
when Associative_Array =>
Real_Attr_Kind := Case_Insensitive_Associative_Array;
@@ -645,14 +570,26 @@ package body Prj.Attr is
--------------------------
procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
- Pkg_Name : Name_Id;
+ Pkg_Name : Name_Id;
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
+ Id := Empty_Package;
+ return;
end if;
Pkg_Name := Name_Id_Of (Name);
+
+ for Index in Package_Attributes.First .. Package_Attributes.Last loop
+ if Package_Attributes.Table (Index).Name = Pkg_Name then
+ Fail ("cannot register a package with a non unique name""",
+ Name, """");
+ Id := Empty_Package;
+ return;
+ end if;
+ end loop;
+
Package_Attributes.Increment_Last;
Id := (Value => Package_Attributes.Last);
Package_Attributes.Table (Package_Attributes.Last) :=
@@ -672,6 +609,7 @@ package body Prj.Attr is
begin
if Name'Length = 0 then
Fail ("cannot register a package with no name");
+ raise Project_Error;
end if;
Pkg_Name := Name_Id_Of (Name);
@@ -680,7 +618,7 @@ package body Prj.Attr is
if Package_Attributes.Table (Index).Name = Pkg_Name then
Fail ("cannot register a package with a non unique name""",
Name, """");
- exit;
+ raise Project_Error;
end if;
end loop;
@@ -692,7 +630,7 @@ package body Prj.Attr is
if Attrs.Table (Curr_Attr).Name = Attr_Name then
Fail ("duplicate attribute name """, Attributes (Index).Name,
""" in new package """ & Name & """");
- exit;
+ raise Project_Error;
end if;
Curr_Attr := Attrs.Table (Curr_Attr).Next;
@@ -701,7 +639,7 @@ package body Prj.Attr is
Attr_Kind := Attributes (Index).Attr_Kind;
if Attributes (Index).Index_Is_File_Name
- and then not File_Names_Case_Sensitive
+ and then not Osint.File_Names_Case_Sensitive
then
case Attr_Kind is
when Associative_Array =>