diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-07-15 20:34:43 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-07-15 20:34:43 +0000 |
| commit | 8f71d067d407ba3a635f9c4e161ef27487f5c237 (patch) | |
| tree | 42274aa36e810d3b5f8091bed03b3cb361cda56e /gcc/ada | |
| parent | eca4df545439699956a77f4638c59943e35a17b4 (diff) | |
| download | gcc-8f71d067d407ba3a635f9c4e161ef27487f5c237.tar.gz | |
2004-07-15 Robert Dewar <dewar@gnat.com>
* makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor
reformatting
* gnat_ugn.texi: Add instantiation of direct_io or sequential_io with
access values as an example of a warning.
* gnat_rm.texi: Document new attribute Has_Access_Values
* gnat-style.texi: Document that box comments belong on nested
subprograms
* sem_util.ads (Has_Access_Values): Improved documentation
* s-finimp.ads, s-finimp.adb: Fix spelling error in comment
* sem_prag.adb (Check_Duplicated_Export_Name): New procedure
(Process_Interface_Name): Call to this new procedure
(Set_Extended_Import_Export_External_Name): Call to this new procedure
* s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment
* a-direio.ads, a-sequio.ads: Warn if Element_Type has access values
* einfo.ads: Minor comment typo fixed
2004-07-15 Jose Ruiz <ruiz@act-europe.fr>
* snames.adb: Add _atcb.
* snames.ads: Add Name_uATCB.
* s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated
(in the expanded code) when using the restricted run time.
* s-tarest.ads (Create_Restricted_Task): Created_Task transformed into
a in parameter in order to allow ATCBs to be preallocated (in the
expanded code).
* s-taskin.adb (Initialize_ATCB): T converted into a in parameter in
order to allow ATCBs to be preallocated. In case of error, the ATCB is
deallocated in System.Tasking.Stages.
* s-taskin.ads (Initialize_ATCB): T converted into a in parameter in
order to allow ATCBs to be preallocated.
* s-tassta.adb (Create_Task): In case of error the ATCB is deallocated
here. It was previously done in Initialize_ATCB.
* rtsfind.ads: Make the Ada_Task_Control_Block visible.
* exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the
Restricted run time.
* exp_ch3.adb: When using the Restricted run time, pass the
preallocated Ada_Task_Control_Block when creating a task.
2004-07-15 Ed Schonberg <schonberg@gnat.com>
* sem_util.adb (Normalize_Actuals): If there are no actuals on a
function call that is itself an actual in an enclosing call, diagnose
problem here rather than assuming that resolution will catch it.
* sem_ch7.adb (Analyze_Package_Specification): If the specification is
the local copy of a generic unit for a formal package, and the generic
is a child unit, install private part of ancestors before compiling
private part of spec.
* sem_cat.adb (Validate_Categorization_Dependency): Simplify code to
use scope entities rather than tree structures, to handle properly
parent units that are instances rewritten as bodies for inlining
purposes.
* sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent,
Remove_Parents): Handle properly a parent unit that is an
instantiation, when the unit has been rewritten as a body for inlining
purposes.
* par.adb (Goto_List): Global variable to collect goto statements in a
given unit, for use in detecting natural loops.
* par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for
use in detecting natural loops.
* par-labl.adb (Find_Natural_Loops): Recognize loops create by
backwards goto's, and rewrite as a infinite loop, to improve locality
of temporaries.
* exp_util.adb (Force_Evaluation): Recognize a left-hand side
subcomponent that includes an indexed reference, to prevent the
generation of copies that would miscompile the desired assignment
statement.
(Build_Task_Image_Decls): Add a numeric suffix to
generated name for string variable, to avoid spurious conflicts with
the name of the type of a single protected object.
* exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a
loop with an explicit exit statement, to avoid generating an
out-of-range value with 'Succ leading to spurious constraint_errors
when compiling with -gnatVo.
2004-07-15 Thomas Quinot <quinot@act-europe.fr>
* sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it
might not be analyzed yet, even if its Etype is already set (case of an
unchecked conversion built using Unchecked_Convert_To, for example).
If the prefix has already been analyzed, this will be a nop anyway.
* exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a
controller type, or an assignment of a record type with controlled
components, copy only user data, and leave the finalization chain
pointers untouched.
2004-07-15 Vincent Celier <celier@gnat.com>
* make.adb (Collect_Arguments): Improve error message when attempting
to compile a source not part of any project, when -x is not used.
* prj.ads: (Defined_Variable_Kind): New subtype
* prj-attr.adb (Register_New_Package): Two new procedures to register
a package with or without its attributes.
(Register_New_Attribute): Mew procedure to register a new attribute in a
package.
New attribute oriented subprograms: Attribute_Node_Id_Of,
Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
Next_Attribute.
New package oriented subprograms: Package_Node_Id_Of,
Add_Unknown_Package, First_Attribute_Of, Add_Attribute.
* prj-attr.ads (Attribute_Node_Id): Now a private, self initialized
type.
(Package_Node_Id): Now a private, self initialized type
(Register_New_Package): New procedure to register a package with its
attributes.
New attribute oriented subprograms: Attribute_Node_Id_Of,
Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of,
Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of,
Next_Attribute.
New package oriented subprograms: Package_Node_Id_Of,
Add_Unknown_Package, First_Attribute_Of, Add_Attribute.
* prj-dect.adb (Parse_Attribute_Declaration,
Parse_Package_Declaration): Adapt to new spec of Prj.Attr.
* prj-makr.adb (Make): Parse existing project file before creating
other files. Fail if there was an error during parsing.
* prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to
new spec of Prj.Attr.
* prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt
to new spec of Prj.Attr.
2004-07-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu>
* utils2.c: Fix typo in comment.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@84774 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
48 files changed, 2683 insertions, 1241 deletions
diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb index dab584ed908..a62a7e0e821 100644 --- a/gcc/ada/9drpc.adb +++ b/gcc/ada/9drpc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -1009,7 +1009,7 @@ package body System.RPC is Partition_ID'Image (Partition)); Garbage_Collector.Allocate (Anonymous); - -- We substracted the size of the header from the size of the + -- We subtracted the size of the header from the size of the -- global message in order to provide immediatly Params size Anonymous.Element.Start diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ad44ea54c0..5b5a0e9eade 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,4 +1,164 @@ -Wed Jul 14 23:16:59 2004 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> +2004-07-15 Robert Dewar <dewar@gnat.com> + + * makegpr.adb, s-secsta.ads, sem_ch3.adb, sem_case.adb: Minor + reformatting + + * gnat_ugn.texi: Add instantiation of direct_io or sequential_io with + access values as an example of a warning. + + * gnat_rm.texi: Document new attribute Has_Access_Values + + * gnat-style.texi: Document that box comments belong on nested + subprograms + + * sem_util.ads (Has_Access_Values): Improved documentation + + * s-finimp.ads, s-finimp.adb: Fix spelling error in comment + + * sem_prag.adb (Check_Duplicated_Export_Name): New procedure + (Process_Interface_Name): Call to this new procedure + (Set_Extended_Import_Export_External_Name): Call to this new procedure + + * s-mastop-x86.adb, 9drpc.adb: Fix spelling error in comment + + * a-direio.ads, a-sequio.ads: Warn if Element_Type has access values + + * einfo.ads: Minor comment typo fixed + +2004-07-15 Jose Ruiz <ruiz@act-europe.fr> + + * snames.adb: Add _atcb. + + * snames.ads: Add Name_uATCB. + + * s-tarest.adb (Create_Restricted_Task): ATCBs are always preallocated + (in the expanded code) when using the restricted run time. + + * s-tarest.ads (Create_Restricted_Task): Created_Task transformed into + a in parameter in order to allow ATCBs to be preallocated (in the + expanded code). + + * s-taskin.adb (Initialize_ATCB): T converted into a in parameter in + order to allow ATCBs to be preallocated. In case of error, the ATCB is + deallocated in System.Tasking.Stages. + + * s-taskin.ads (Initialize_ATCB): T converted into a in parameter in + order to allow ATCBs to be preallocated. + + * s-tassta.adb (Create_Task): In case of error the ATCB is deallocated + here. It was previously done in Initialize_ATCB. + + * rtsfind.ads: Make the Ada_Task_Control_Block visible. + + * exp_ch9.adb: Preallocate the Ada_Task_Control_Block when using the + Restricted run time. + + * exp_ch3.adb: When using the Restricted run time, pass the + preallocated Ada_Task_Control_Block when creating a task. + +2004-07-15 Ed Schonberg <schonberg@gnat.com> + + * sem_util.adb (Normalize_Actuals): If there are no actuals on a + function call that is itself an actual in an enclosing call, diagnose + problem here rather than assuming that resolution will catch it. + + * sem_ch7.adb (Analyze_Package_Specification): If the specification is + the local copy of a generic unit for a formal package, and the generic + is a child unit, install private part of ancestors before compiling + private part of spec. + + * sem_cat.adb (Validate_Categorization_Dependency): Simplify code to + use scope entities rather than tree structures, to handle properly + parent units that are instances rewritten as bodies for inlining + purposes. + + * sem_ch10.adb (Get_Parent_Entity, Implicit_With_On_Parent, + Remove_Parents): Handle properly a parent unit that is an + instantiation, when the unit has been rewritten as a body for inlining + purposes. + + * par.adb (Goto_List): Global variable to collect goto statements in a + given unit, for use in detecting natural loops. + + * par-ch5.adb (P_Goto_Statement): Add goto to global Goto_List, for + use in detecting natural loops. + + * par-labl.adb (Find_Natural_Loops): Recognize loops create by + backwards goto's, and rewrite as a infinite loop, to improve locality + of temporaries. + + * exp_util.adb (Force_Evaluation): Recognize a left-hand side + subcomponent that includes an indexed reference, to prevent the + generation of copies that would miscompile the desired assignment + statement. + (Build_Task_Image_Decls): Add a numeric suffix to + generated name for string variable, to avoid spurious conflicts with + the name of the type of a single protected object. + + * exp_ch4.adb (Expand_Array_Equality): If indices are distinct, use a + loop with an explicit exit statement, to avoid generating an + out-of-range value with 'Succ leading to spurious constraint_errors + when compiling with -gnatVo. + +2004-07-15 Thomas Quinot <quinot@act-europe.fr> + + * sem_ch4.adb (Analyze_Slice): Always call Analyze on the prefix: it + might not be analyzed yet, even if its Etype is already set (case of an + unchecked conversion built using Unchecked_Convert_To, for example). + If the prefix has already been analyzed, this will be a nop anyway. + + * exp_ch5.adb (Make_Tag_Ctrl_Assignment): For an assignment of a + controller type, or an assignment of a record type with controlled + components, copy only user data, and leave the finalization chain + pointers untouched. + +2004-07-15 Vincent Celier <celier@gnat.com> + + * make.adb (Collect_Arguments): Improve error message when attempting + to compile a source not part of any project, when -x is not used. + + * prj.ads: (Defined_Variable_Kind): New subtype + + * prj-attr.adb (Register_New_Package): Two new procedures to register + a package with or without its attributes. + (Register_New_Attribute): Mew procedure to register a new attribute in a + package. + New attribute oriented subprograms: Attribute_Node_Id_Of, + Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of, + Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of, + Next_Attribute. + New package oriented subprograms: Package_Node_Id_Of, + Add_Unknown_Package, First_Attribute_Of, Add_Attribute. + + * prj-attr.ads (Attribute_Node_Id): Now a private, self initialized + type. + (Package_Node_Id): Now a private, self initialized type + (Register_New_Package): New procedure to register a package with its + attributes. + New attribute oriented subprograms: Attribute_Node_Id_Of, + Attribute_Kind_Of, Set_Attribute_Kind_Of, Attribute_Name_Of, + Variable_Kind_Of, Set_Variable_Kind_Of, Optional_Index_Of, + Next_Attribute. + New package oriented subprograms: Package_Node_Id_Of, + Add_Unknown_Package, First_Attribute_Of, Add_Attribute. + + * prj-dect.adb (Parse_Attribute_Declaration, + Parse_Package_Declaration): Adapt to new spec of Prj.Attr. + + * prj-makr.adb (Make): Parse existing project file before creating + other files. Fail if there was an error during parsing. + + * prj-proc.adb (Add_Attributes, Process_Declarative_Items): Adapt to + new spec of Prj.Attr. + + * prj-strt.adb (Attribute_Reference, Parse_Variable_Reference): Adapt + to new spec of Prj.Attr. + +2004-07-15 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> + + * utils2.c: Fix typo in comment. + +2004-07-14 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> * trans.c (add_decl_expr): Clear TREE_READONLY if clear DECL_INITIAL. * utils.c (unchecked_convert): Don't do two VIEW_CONVERT_EXPRs. diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads index 6137c336610..8526d298997 100644 --- a/gcc/ada/a-direio.ads +++ b/gcc/ada/a-direio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-1999 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -45,6 +45,10 @@ generic package Ada.Direct_IO is + pragma Compile_Time_Warning + (Element_Type'Has_Access_Values, + "?Element_Type for Direct_'I'O instance has access values"); + type File_Type is limited private; type File_Mode is (In_File, Inout_File, Out_File); @@ -54,9 +58,9 @@ package Ada.Direct_IO is -- used in this package and System.File_IO. for File_Mode use - (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) - Inout_File => 1, -- System.File_IO.File_Mode'Pos (Inout_File); - Out_File => 2); -- System.File_IO.File_Mode'Pos (Out_File) + (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) + Inout_File => 1, -- System.File_IO.File_Mode'Pos (Inout_File); + Out_File => 2); -- System.File_IO.File_Mode'Pos (Out_File) type Count is range 0 .. System.Direct_IO.Count'Last; diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads index 56753685951..f3a50b65d9c 100644 --- a/gcc/ada/a-sequio.ads +++ b/gcc/ada/a-sequio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -44,6 +44,10 @@ generic package Ada.Sequential_IO is + pragma Compile_Time_Warning + (Element_Type'Has_Access_Values, + "?Element_Type for Sequential_'I'O instance has access values"); + type File_Type is limited private; type File_Mode is (In_File, Out_File, Append_File); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 289bdabb89f..86de4bc819d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -596,7 +596,7 @@ package Einfo is -- If the IF/ELSIF condition has the form "[NOT] OBJ RELOP VAL", -- where OBJ is a reference to an entity with a Current_Value field, -- RELOP is one of the six relational operators, and VAL is a compile- --- time known valoue, then the Current_Value field if OBJ is set to +-- time known value, then the Current_Value field if OBJ is set to -- point to the N_If_Statement or N_Elsif_Part node of the relevant -- construct. For more details on this usage, see the procedure -- Exp_Util.Get_Current_Value_Condition. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 335a07ccd15..3fec8c15780 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2080,6 +2080,25 @@ package body Exp_Ch3 is -- to bind any interrupt (signal) entries. if Is_Task_Record_Type (Rec_Type) then + + -- In the case of the restricted run time the ATCB has already + -- been preallocated. + + if Restricted_Profile then + Append_To (Statement_List, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => Make_Identifier (Loc, Name_uTask_Id)), + Expression => Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uInit), + Selector_Name => + Make_Identifier (Loc, Name_uATCB)), + Attribute_Name => Name_Unchecked_Access))); + end if; + Append_To (Statement_List, Make_Task_Create_Call (Rec_Type)); declare diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index a9d26bda986..7e51ca3ed9c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -877,21 +877,27 @@ package body Exp_Ch4 is -- end if; -- declare - -- B1 : Index_T1 := B'first (1) + -- A1 : Index_T1 := A'first (1); + -- B1 : Index_T1 := B'first (1); -- begin - -- for A1 in A'range (1) loop + -- loop -- declare - -- B2 : Index_T2 := B'first (2) + -- A2 : Index_T2 := A'first (2); + -- B2 : Index_T2 := B'first (2); -- begin - -- for A2 in A'range (2) loop + -- loop -- if A (A1, A2) /= B (B1, B2) then -- return False; -- end if; + -- exit when A2 = A'last (2); + -- A2 := Index_T2'succ (A2); -- B2 := Index_T2'succ (B2); -- end loop; -- end; + -- exit when A1 = A'last (1); + -- A1 := Index_T1'succ (A1); -- B1 := Index_T1'succ (B1); -- end loop; -- end; @@ -905,6 +911,10 @@ package body Exp_Ch4 is -- has a bound depending on a discriminant, then we use the base type -- since otherwise we have an escaped discriminant in the function. + -- If both arrays are constrained and have the same bounds, we can + -- generate a loop with an explicit iteration scheme using a 'Range + -- attribute over the first array. + function Expand_Array_Equality (Nod : Node_Id; Lhs : Node_Id; @@ -949,27 +959,29 @@ package body Exp_Ch4 is -- This procedure returns the following code -- -- declare - -- Bn : Index_T := B'First (n); + -- Bn : Index_T := B'First (N); -- begin - -- for An in A'range (n) loop + -- loop -- xxx + -- exit when An = A'Last (N); + -- An := Index_T'Succ (An) -- Bn := Index_T'Succ (Bn) -- end loop; -- end; -- - -- Note: we don't need Bn or the declare block when the index types - -- of the two arrays are constrained and identical. + -- If both indices are constrained and identical, the procedure + -- returns a simpler loop: + -- + -- for An in A'Range (N) loop + -- xxx + -- end loop -- - -- where N is the value of "n" in the above code. Index is the + -- N is the dimension for which we are generating a loop. Index is the -- N'th index node, whose Etype is Index_Type_n in the above code. -- The xxx statement is either the loop or declare for the next -- dimension or if this is the last dimension the comparison -- of corresponding components of the arrays. -- - -- Note: if the index types are identical and constrained, we - -- need only one index, so we generate only An and we do not - -- need the declare block. - -- -- The actual way the code works is to return the comparison -- of corresponding components for the N+1 call. That's neater! @@ -1119,6 +1131,24 @@ package body Exp_Ch4 is Handle_One_Dimension (N + 1, Next_Index (Index))); if Need_Separate_Indexes then + -- Generate guard for loop, followed by increments of indices. + + Append_To (Stm_List, + Make_Exit_Statement (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Reference_To (An, Loc), + Right_Opnd => Arr_Attr (A, Name_Last, N)))); + + Append_To (Stm_List, + Make_Assignment_Statement (Loc, + Name => New_Reference_To (An, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Index_T, Loc), + Attribute_Name => Name_Succ, + Expressions => New_List (New_Reference_To (An, Loc))))); + Append_To (Stm_List, Make_Assignment_Statement (Loc, Name => New_Reference_To (Bn, Loc), @@ -1129,34 +1159,44 @@ package body Exp_Ch4 is Expressions => New_List (New_Reference_To (Bn, Loc))))); end if; - Loop_Stm := - Make_Implicit_Loop_Statement (Nod, - Statements => Stm_List, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => An, - Discrete_Subtype_Definition => - Arr_Attr (A, Name_Range, N)))); - - -- If separate indexes, need a declare block to declare Bn + -- If separate indexes, we need a declare block for An and Bn, + -- and a loop without an iteration scheme. if Need_Separate_Indexes then + Loop_Stm := + Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); + return Make_Block_Statement (Loc, Declarations => New_List ( Make_Object_Declaration (Loc, + Defining_Identifier => An, + Object_Definition => New_Reference_To (Index_T, Loc), + Expression => Arr_Attr (A, Name_First, N)), + + Make_Object_Declaration (Loc, Defining_Identifier => Bn, Object_Definition => New_Reference_To (Index_T, Loc), Expression => Arr_Attr (B, Name_First, N))), + Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Loop_Stm))); - -- If no separate indexes, return loop statement on its own + -- If no separate indexes, return loop statement with explicit + -- iteration scheme on its own else + Loop_Stm := + Make_Implicit_Loop_Statement (Nod, + Statements => Stm_List, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => An, + Discrete_Subtype_Definition => + Arr_Attr (A, Name_Range, N)))); return Loop_Stm; end if; end Handle_One_Dimension; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 8bbcb091826..083c6c291a7 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -52,6 +52,7 @@ with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; with Validsw; use Validsw; @@ -97,7 +98,7 @@ package body Exp_Ch5 is -- of representation. function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id; - -- Generate the necessary code for controlled and Tagged assignment, + -- Generate the necessary code for controlled and tagged assignment, -- that is to say, finalization of the target before, adjustement of -- the target after and save and restore of the tag and finalization -- pointers which are not 'part of the value' and must not be changed @@ -3031,12 +3032,7 @@ package body Exp_Ch5 is Res : List_Id; Tag_Tmp : Entity_Id; - Prev_Tmp : Entity_Id; - Next_Tmp : Entity_Id; - Ctrl_Ref : Node_Id; - Ctrl_Ref2 : Node_Id := Empty; - Prev_Tmp2 : Entity_Id := Empty; -- prevent warning - Next_Tmp2 : Entity_Id := Empty; -- prevent warning + Original_Size, Range_Type, Opaque_Type : Entity_Id; begin Res := New_List; @@ -3074,8 +3070,6 @@ package body Exp_Ch5 is With_Detach => New_Reference_To (Standard_False, Loc))); end if; - Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); - -- Save the Tag in a local variable Tag_Tmp if Save_Tag then @@ -3097,102 +3091,263 @@ package body Exp_Ch5 is Tag_Tmp := Empty; end if; - -- Save the Finalization Pointers in local variables Prev_Tmp and - -- Next_Tmp. For objects with Has_Controlled_Component set, these - -- pointers are in the Record_Controller and if it is also - -- Is_Controlled, we need to save the object pointers as well. + -- We really need a comment here ??? if Ctrl_Act then - Ctrl_Ref := Duplicate_Subexpr_No_Checks (L); - if Has_Controlled_Component (T) then - Ctrl_Ref := - Make_Selected_Component (Loc, - Prefix => Ctrl_Ref, - Selector_Name => - New_Reference_To (Controller_Component (T), Loc)); + -- subtype G is Storage_Offset range 1 .. Expr'Size - if Is_Controlled (T) then - Ctrl_Ref2 := Duplicate_Subexpr_No_Checks (L); - end if; - end if; - - Prev_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + Original_Size := + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); Append_To (Res, Make_Object_Declaration (Loc, - Defining_Identifier => Prev_Tmp, + Defining_Identifier => Original_Size, + Constant_Present => True, + Object_Definition => New_Occurrence_Of ( + RTE (RE_Storage_Offset), Loc), + Expression => + Make_Op_Divide (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (L), + Attribute_Name => Name_Size), + Right_Opnd => Make_Integer_Literal (Loc, + Intval => System_Storage_Unit)))); + + Range_Type := + Make_Defining_Identifier (Loc, + New_Internal_Name ('G')); - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + Append_To (Res, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Range_Type, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Storage_Offset), Loc), + Constraint => Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, 1), + High_Bound => New_Occurrence_Of ( + Original_Size, Loc)))))); + + -- subtype S is Storage_Array (G) - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref), - Selector_Name => Make_Identifier (Loc, Name_Prev)))); + Append_To (Res, + Make_Subtype_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')), + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Reference_To (RTE (RE_Storage_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (New_Reference_To (Range_Type, Loc)))))); + + -- type A is access S + + Opaque_Type := Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + Append_To (Res, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Opaque_Type, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of ( + Defining_Identifier (Last (Res)), Loc)))); - Next_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + -- Give a label name to this declare block, and add comments here??? - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Next_Tmp, + declare + Prev_Ref : Node_Id; - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + First_After_Root : Node_Id := Empty; + -- Index of first byte to be copied (used to skip + -- Root_Controlled in controlled objects). - Expression => - Make_Selected_Component (Loc, + Last_Before_Hole : Node_Id := Empty; + -- Index of last byte to be copied before outermost record + -- controller data. + + Hole_Length : Node_Id := Empty; + -- Length of record controller data (Prev and Next pointers) + + First_After_Hole : Node_Id := Empty; + -- Index of first byte to be copied after outermost record + -- controller data. + + function Build_Slice + (Rec : Entity_Id; + Lo, Hi : Node_Id) return Node_Id; + -- Function specs must have comments, saying what all the + -- parameters are and what the function does ??? + + ----------------- + -- Build_Slice -- + ----------------- + + function Build_Slice + (Rec : Node_Id; + Lo, Hi : Node_Id) return Node_Id + is + Lo_Bound, Hi_Bound : Node_Id; + + Opaque : constant Node_Id := + Unchecked_Convert_To (Opaque_Type, + Make_Attribute_Reference (Loc, + Prefix => Rec, + Attribute_Name => Name_Address)); + -- Comment required, what is this??? + + begin + -- Comments required in this body ??? + + if No (Lo) then + Lo_Bound := Make_Integer_Literal (Loc, 1); + else + Lo_Bound := Lo; + end if; + + if No (Hi) then + Hi_Bound := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Range_Type, Loc), + Attribute_Name => Name_Last); + else + Hi_Bound := Hi; + end if; + + return Make_Slice (Loc, Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref)), - Selector_Name => Make_Identifier (Loc, Name_Next)))); + Opaque, + Discrete_Range => Make_Range (Loc, + Lo_Bound, Hi_Bound)); + end Build_Slice; - if Present (Ctrl_Ref2) then - Prev_Tmp2 := - Make_Defining_Identifier (Loc, New_Internal_Name ('B')); + -- Start of processing for ??? (name of block) - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Prev_Tmp2, + begin + First_After_Root := Make_Integer_Literal (Loc, 1); - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + -- Comment ??? - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref2), - Selector_Name => Make_Identifier (Loc, Name_Prev)))); + if Is_Controlled (T) then + First_After_Root := + Make_Op_Add (Loc, + First_After_Root, + Make_Op_Divide (Loc, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Root_Controlled), Loc), + Attribute_Name => Name_Size), + Make_Integer_Literal (Loc, System_Storage_Unit))); + end if; - Next_Tmp2 := - Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + if Has_Controlled_Component (T) then - Append_To (Res, - Make_Object_Declaration (Loc, - Defining_Identifier => Next_Tmp2, + -- The record controller Prev and Next pointers must be left + -- intact in the target object, not copied. Compute the bounds + -- of the hole to be skipped in copying the objecct. - Object_Definition => - New_Reference_To (RTE (RE_Finalizable_Ptr), Loc), + Prev_Ref := + Make_Selected_Component (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Duplicate_Subexpr_No_Checks (L), + Selector_Name => + New_Reference_To (Controller_Component (T), Loc)), + Selector_Name => Make_Identifier (Loc, Name_Prev)); - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref2)), - Selector_Name => Make_Identifier (Loc, Name_Next)))); - end if; + -- Last index before hole - -- If not controlled type, then Prev_Tmp and Ctrl_Ref unused + Last_Before_Hole := + Make_Defining_Identifier (Loc, + New_Internal_Name ('L')); - else - Prev_Tmp := Empty; - Ctrl_Ref := Empty; - end if; + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => Last_Before_Hole, + Object_Definition => New_Occurrence_Of ( + RTE (RE_Storage_Offset), Loc), + Constant_Present => True, + Expression => Make_Op_Add (Loc, + Make_Attribute_Reference (Loc, + Prefix => Prev_Ref, + Attribute_Name => Name_Position), + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Prefix (Prev_Ref)), + Attribute_Name => Name_Position)))); - -- Do the Assignment + -- Hole length + + Hole_Length := + Make_Op_Multiply (Loc, + Make_Integer_Literal (Loc, Uint_2), + Make_Op_Divide (Loc, + Make_Attribute_Reference (Loc, + Prefix => + New_Copy_Tree (Prev_Ref), + Attribute_Name => + Name_Size), + Make_Integer_Literal (Loc, System_Storage_Unit))); + + -- First index after hole + + First_After_Hole := + Make_Defining_Identifier (Loc, + New_Internal_Name ('F')); + + Append_To (Res, + Make_Object_Declaration (Loc, + Defining_Identifier => First_After_Hole, + Object_Definition => New_Occurrence_Of ( + RTE (RE_Storage_Offset), Loc), + Constant_Present => True, + Expression => + Make_Op_Add (Loc, + Make_Op_Add (Loc, + New_Occurrence_Of (Last_Before_Hole, Loc), + Hole_Length), + Make_Integer_Literal (Loc, 1)))); + + Last_Before_Hole := New_Occurrence_Of (Last_Before_Hole, Loc); + First_After_Hole := New_Occurrence_Of (First_After_Hole, Loc); + end if; - Append_To (Res, Relocate_Node (N)); + -- More comments needed everywhere ??? + + Append_To (Res, Make_Assignment_Statement (Loc, + Name => Build_Slice (Duplicate_Subexpr_No_Checks (L), + First_After_Root, + Last_Before_Hole), + + Expression => Build_Slice (Expression (N), + First_After_Root, + New_Copy_Tree (Last_Before_Hole)))); + + + if Present (First_After_Hole) then + Remove_Side_Effects (Expression (N)); + Append_To (Res, Make_Assignment_Statement (Loc, + Name => Build_Slice (Duplicate_Subexpr_No_Checks (L), + First_After_Hole, + Empty), + Expression => Build_Slice (New_Copy_Tree (Expression (N)), + New_Copy_Tree (First_After_Hole), + Empty))); + end if; + end; + + else + Append_To (Res, Relocate_Node (N)); + end if; -- Restore the Tag @@ -3206,55 +3361,8 @@ package body Exp_Ch5 is Expression => New_Reference_To (Tag_Tmp, Loc))); end if; - -- Restore the finalization pointers - - if Ctrl_Act then - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref)), - Selector_Name => Make_Identifier (Loc, Name_Prev)), - Expression => New_Reference_To (Prev_Tmp, Loc))); - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref)), - Selector_Name => Make_Identifier (Loc, Name_Next)), - Expression => New_Reference_To (Next_Tmp, Loc))); - - if Present (Ctrl_Ref2) then - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref2)), - Selector_Name => Make_Identifier (Loc, Name_Prev)), - Expression => New_Reference_To (Prev_Tmp2, Loc))); - - Append_To (Res, - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_Finalizable), - New_Copy_Tree (Ctrl_Ref2)), - Selector_Name => Make_Identifier (Loc, Name_Next)), - Expression => New_Reference_To (Next_Tmp2, Loc))); - end if; - end if; - - -- Adjust the target after the assignment when controlled. (not in - -- the init proc since it is an initialization more than an - -- assignment) + -- Adjust the target after the assignment when controlled (not in the + -- init proc since it is an initialization more than an assignment). if Ctrl_Act then Append_List_To (Res, @@ -3268,6 +3376,8 @@ package body Exp_Ch5 is return Res; exception + -- Could use comment here ??? + when RE_Not_Available => return Empty_List; end Make_Tag_Ctrl_Assignment; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index d93ed9ba0dc..1b07efaf321 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -7226,6 +7226,29 @@ package body Exp_Ch9 is Subtype_Indication => New_Reference_To (RTE (RO_ST_Task_Id), Loc)))); + -- Declare static ATCB (that is, created by the expander) if we + -- are using the Restricted run time. + + if Restricted_Profile then + Append_To (Cdecls, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uATCB), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => True, + Subtype_Indication => Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of + (RTE (RE_Ada_Task_Control_Block), Loc), + + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0))))))); + + end if; + -- Add components for entry families Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 9d1c78bbe1e..a823520971a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -624,12 +624,14 @@ package body Exp_Util is if Nkind (Id_Ref) = N_Identifier or else Nkind (Id_Ref) = N_Defining_Identifier then - -- For a simple variable, the image of the task is the name - -- of the variable. + -- For a simple variable, the image of the task is built from + -- the name of the variable. To avoid possible conflict with + -- the anonymous type created for a single protected object, + -- add a numeric suffix. T_Id := Make_Defining_Identifier (Loc, - New_External_Name (Chars (Id_Ref), 'T')); + New_External_Name (Chars (Id_Ref), 'T', 1)); Get_Name_String (Chars (Id_Ref)); @@ -1331,7 +1333,10 @@ package body Exp_Util is Par := Exp; while Present (Par) - and then Nkind (Par) = N_Selected_Component + and then + (Nkind (Par) = N_Selected_Component + or else + Nkind (Par) = N_Indexed_Component) loop if Nkind (Parent (Par)) = N_Assignment_Statement and then Par = Name (Parent (Par)) diff --git a/gcc/ada/gnat-style.texi b/gcc/ada/gnat-style.texi index ee425de5f29..366650c7431 100644 --- a/gcc/ada/gnat-style.texi +++ b/gcc/ada/gnat-style.texi @@ -716,7 +716,10 @@ format: @noindent Note that the name in the header is preceded by a single space, -not two spaces as for other comments. +not two spaces as for other comments. These headers are used on +nested subprograms as well as outer level subprograms. They may +also be used as headers for sections of comments, or collections +of declarations that are related. @item Every subprogram body must have a preceding @syntax{subprogram_declaration}. diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index b47abe1e75e..ea278f14cf9 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -202,6 +202,7 @@ Implementation Defined Attributes * Enum_Rep:: * Epsilon:: * Fixed_Value:: +* Has_Access_Values:: * Has_Discriminants:: * Img:: * Integer_Value:: @@ -4000,6 +4001,7 @@ consideration, you should minimize the use of these attributes. * Enum_Rep:: * Epsilon:: * Fixed_Value:: +* Has_Access_Values:: * Has_Discriminants:: * Img:: * Integer_Value:: @@ -4305,6 +4307,19 @@ that there are full range checks, to ensure that the result is in range. This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. +@node Has_Access_Values +@unnumberedsec Has_Access_Values +@cindex Access values, testing for +@findex Has_Access_Values +@noindent +The prefix of the @code{Has_Access_Values} attribute is a type. The result +is a Boolean value which is True if the is an access type, or is a composite +type with a component (at any nesting depth) that is an access type, and is +False otherwise. +The intended use of this attribute is in conjunction with generic +definitions. If the attribute is applied to a generic private type, it +indicates whether or not the corresponding actual type has access values. + @node Has_Discriminants @unnumberedsec Has_Discriminants @cindex Discriminants, testing for diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 8c358847036..4162ea2037e 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -4419,6 +4419,9 @@ Unreachable code Fixed-point type declarations with a null range @item +Direct_IO or Sequential_IO instantiated with a type that has access values + +@item Variables that are never assigned a value @item diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index a931f14234b..8cc960a9bf5 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -1728,8 +1728,9 @@ package body Make is if Arguments_Project = No_Project then if not External_Unit_Compilation_Allowed then - Make_Failed ("external source, not part of any projects, " & - "cannot be compiled (", Source_File_Name, ")"); + Make_Failed ("external source (", Source_File_Name, + ") is not part of any project; cannot be " & + "compiled without gnatmake switch -x"); end if; -- If it is allowed, simply add the saved gcc switches diff --git a/gcc/ada/makegpr.adb b/gcc/ada/makegpr.adb index 61f96f251ff..5594bbaa2c0 100644 --- a/gcc/ada/makegpr.adb +++ b/gcc/ada/makegpr.adb @@ -1222,6 +1222,7 @@ package body Makegpr is Global_Archive_Exists := Last_Argument > First_Object; if Global_Archive_Exists then + -- If the archive is built, then linking will need to occur -- unconditionally. @@ -1230,9 +1231,7 @@ package body Makegpr is -- Spawn the archive builder (ar) Saved_Last_Argument := Last_Argument; - Last_Argument := First_Object + Max_In_Archives; - loop if Last_Argument > Saved_Last_Argument then Last_Argument := Saved_Last_Argument; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 8a19316112b..71324884f77 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -1877,6 +1877,7 @@ package body Ch5 is Goto_Node := New_Node (N_Goto_Statement, Token_Ptr); Scan; -- past GOTO (or TO) Set_Name (Goto_Node, P_Qualified_Simple_Name_Resync); + Append_Elmt (Goto_Node, Goto_List); No_Constraint; TF_Semicolon; return Goto_Node; diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb index 835be36e337..2fd70e5c09c 100644 --- a/gcc/ada/par-labl.adb +++ b/gcc/ada/par-labl.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -51,6 +51,11 @@ procedure Labl is -- Checks the rule in RM-5.1(11), which requires distinct identifiers -- for all the labels in a given body. + procedure Find_Natural_Loops; + -- Recognizes loops created by backward gotos, and rewrites the + -- corresponding statements into a proper loop, for optimization + -- purposes (for example, to control reclaiming local storage). + --------------------------- -- Check_Distinct_Labels -- --------------------------- @@ -145,6 +150,329 @@ procedure Labl is return Result; end Find_Enclosing_Body_Or_Block; + ------------------------ + -- Find_Natural_Loops -- + ------------------------ + + procedure Find_Natural_Loops is + Node_List : constant Elist_Id := New_Elmt_List; + N : Elmt_Id; + Succ : Elmt_Id; + + function Goto_Id (Goto_Node : Node_Id) return Name_Id; + -- Find Name_Id of goto statement, which may be an expanded name. + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean; + -- A label and a goto are candidates for a loop if the names match, + -- and both nodes appear in the same body. In addition, both must + -- appear in the same statement list. If they are not in the same + -- statement list, the goto is from within an nested structure, and + -- the label is not a header. We ignore the case where the goto is + -- within a conditional structure, and capture only infinite loops. + + procedure Merge; + -- Merge labels and goto statements in order of increasing sloc value. + -- Discard labels of loop and block statements. + + procedure No_Header (N : Elmt_Id); + -- The label N is known not to be a loop header. Scan forward and + -- remove all subsequent goto's that may have this node as a target. + + procedure Process_Goto (N : Elmt_Id); + -- N is a forward jump. Scan forward and remove all subsequent goto's + -- that may have the same target, to preclude spurious loops. + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id); + -- Given a label and a backwards goto, rewrite intervening statements + -- as a loop. Remove the label from the node list, and rewrite the + -- goto with the body of the new loop. + + procedure Try_Loop (N : Elmt_Id); + -- N is a label that may be a loop header. Scan forward to find some + -- backwards goto with which to make a loop. Do nothing if there is + -- an intervening label that is not part of a loop, or more than one + -- goto with this target. + + ------------- + -- Goto_Id -- + ------------- + + function Goto_Id (Goto_Node : Node_Id) return Name_Id is + begin + if Nkind (Name (Goto_Node)) = N_Identifier then + return Chars (Name (Goto_Node)); + + elsif Nkind (Name (Goto_Node)) = N_Selected_Component then + return Chars (Selector_Name (Name (Goto_Node))); + else + + -- In case of error, return Id that can't match anything + + return Name_Null; + end if; + end Goto_Id; + + ------------- + -- Matches -- + ------------- + + function Matches + (Label_Node : Node_Id; + Goto_Node : Node_Id) return Boolean + is + begin + return Chars (Identifier (Label_Node)) = Goto_Id (Goto_Node) + and then Find_Enclosing_Body (Label_Node) = + Find_Enclosing_Body (Goto_Node); + end Matches; + + ----------- + -- Merge -- + ----------- + + procedure Merge is + L1 : Elmt_Id; + G1 : Elmt_Id; + + begin + L1 := First_Elmt (Label_List); + G1 := First_Elmt (Goto_List); + + while Present (L1) + and then Present (G1) + loop + if Sloc (Node (L1)) < Sloc (Node (G1)) then + + -- Optimization: remove labels of loops and blocks, which + -- play no role in what follows. + + if Nkind (Node (L1)) /= N_Loop_Statement + and then Nkind (Node (L1)) /= N_Block_Statement + then + Append_Elmt (Node (L1), Node_List); + end if; + + Next_Elmt (L1); + + else + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end if; + end loop; + + while Present (L1) loop + Append_Elmt (Node (L1), Node_List); + Next_Elmt (L1); + end loop; + + while Present (G1) loop + Append_Elmt (Node (G1), Node_List); + Next_Elmt (G1); + end loop; + end Merge; + + --------------- + -- No_Header -- + --------------- + + procedure No_Header (N : Elmt_Id) is + S1, S2 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + S2 := Next_Elmt (S1); + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + Remove_Elmt (Node_List, S1); + end if; + + S1 := S2; + end loop; + end No_Header; + + ------------------ + -- Process_Goto -- + ------------------ + + procedure Process_Goto (N : Elmt_Id) is + Goto1 : constant Node_Id := Node (N); + Goto2 : Node_Id; + S, S1 : Elmt_Id; + + begin + S := Next_Elmt (N); + + while Present (S) loop + S1 := Next_Elmt (S); + Goto2 := Node (S); + + if Nkind (Goto2) = N_Goto_Statement + and then Goto_Id (Goto1) = Goto_Id (Goto2) + and then Find_Enclosing_Body (Goto1) = + Find_Enclosing_Body (Goto2) + then + + -- Goto2 may have the same target, remove it from + -- consideration. + + Remove_Elmt (Node_List, S); + end if; + + S := S1; + end loop; + end Process_Goto; + + --------------------- + -- Rewrite_As_Loop -- + --------------------- + + procedure Rewrite_As_Loop + (Loop_Header : Node_Id; + Loop_End : Node_Id) + is + Loop_Body : constant List_Id := New_List; + Loop_Stmt : constant Node_Id := + New_Node (N_Loop_Statement, Sloc (Loop_Header)); + Stat : Node_Id; + Next_Stat : Node_Id; + begin + Stat := Next (Loop_Header); + while Stat /= Loop_End loop + Next_Stat := Next (Stat); + Remove (Stat); + Append (Stat, Loop_Body); + Stat := Next_Stat; + end loop; + + Set_Statements (Loop_Stmt, Loop_Body); + Set_Identifier (Loop_Stmt, Identifier (Loop_Header)); + + Remove (Loop_Header); + Rewrite (Loop_End, Loop_Stmt); + Error_Msg_N + ("code between label and backwards goto rewritten as loop?", + Loop_End); + end Rewrite_As_Loop; + + -------------- + -- Try_Loop -- + -------------- + + procedure Try_Loop (N : Elmt_Id) is + Source : Elmt_Id; + Found : Boolean := False; + S1 : Elmt_Id; + + begin + S1 := Next_Elmt (N); + while Present (S1) loop + if Nkind (Node (S1)) = N_Goto_Statement + and then Matches (Node (N), Node (S1)) + then + if not Found then + if Parent (Node (N)) = Parent (Node (S1)) then + Source := S1; + Found := True; + + else + -- The goto is within some nested structure + + No_Header (N); + return; + end if; + + else + -- More than one goto with the same target + + No_Header (N); + return; + end if; + + elsif Nkind (Node (S1)) = N_Label + and then not Found + then + -- Intervening label before possible end of loop. Current + -- label is not a candidate. This is conservative, because + -- the label might not be the target of any jumps, but not + -- worth dealing with useless labels! + + No_Header (N); + return; + + else + -- If the node is a loop_statement, it corresponds to a + -- label-goto pair rewritten as a loop. Continue forward scan. + + null; + end if; + + Next_Elmt (S1); + end loop; + + if Found then + Rewrite_As_Loop (Node (N), Node (Source)); + Remove_Elmt (Node_List, N); + Remove_Elmt (Node_List, Source); + end if; + end Try_Loop; + + begin + -- Start of processing for Find_Natural_Loops + + Merge; + + N := First_Elmt (Node_List); + while Present (N) loop + Succ := Next_Elmt (N); + + if Nkind (Node (N)) = N_Label then + if No (Succ) then + exit; + + elsif Nkind (Node (Succ)) = N_Label then + Try_Loop (Succ); + + -- If a loop was found, the label has been removed, and + -- the following goto rewritten as the loop body. + + Succ := Next_Elmt (N); + + if Nkind (Node (Succ)) = N_Label then + + -- Following label was not removed, so current label + -- is not a candidate header. + + No_Header (N); + + else + + -- Following label was part of inner loop. Current + -- label is still a candidate. + + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (Succ)) = N_Goto_Statement then + Try_Loop (N); + Succ := Next_Elmt (N); + end if; + + elsif Nkind (Node (N)) = N_Goto_Statement then + Process_Goto (N); + Succ := Next_Elmt (N); + end if; + + N := Succ; + end loop; + end Find_Natural_Loops; + -- Start of processing for Par.Labl begin @@ -204,4 +532,6 @@ begin Next_Elmt (Next_Label_Elmt); end loop; + Find_Natural_Loops; + end Labl; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 23230235e35..89777065639 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -395,6 +395,11 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is SS_Whtm : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, T, F); SS_Unco : constant SS_Rec := SS_Rec'(F, F, F, F, F, F, F, T); + Goto_List : Elist_Id; + -- List of goto nodes appearing in the current compilation. Used to + -- recognize natural loops and convert them into bona fide loops for + -- optimization purposes. + Label_List : Elist_Id; -- List of label nodes for labels appearing in the current compilation. -- Used by Par.Labl to construct the corresponding implicit declarations. @@ -1260,6 +1265,7 @@ begin SIS_Entry_Active := False; Last_Resync_Point := No_Location; + Goto_List := New_Elmt_List; Label_List := New_Elmt_List; -- If in multiple unit per file mode, skip past ignored unit diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index f473b6c8816..2127e35067c 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -24,25 +24,26 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Namet; use Namet; -with Osint; use Osint; -with Output; use Output; +with Namet; use Namet; +with Osint; use Osint; +with Table; + +with System.Case_Util; use System.Case_Util; package body Prj.Attr is + -- Data for predefined attributes and packages + -- Names end with '#' -- Package names are preceded by 'P' - -- Attribute names are preceded by two letters - + -- 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 @@ -182,27 +183,188 @@ 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 -- + ----------------------- + + function Attribute_Kind_Of + (Attribute : Attribute_Node_Id) return Attribute_Kind + is + begin + if Attribute = Empty_Attribute then + return Unknown; + else + return Attrs.Table (Attribute.Value).Attr_Kind; + end if; + end Attribute_Kind_Of; + + ----------------------- + -- Attribute_Name_Of -- + ----------------------- + + function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is + begin + if Attribute = Empty_Attribute then + return No_Name; + else + return Attrs.Table (Attribute.Value).Name; + end if; + end Attribute_Name_Of; + + -------------------------- + -- Attribute_Node_Id_Of -- + -------------------------- + + function Attribute_Node_Id_Of + (Name : Name_Id; + 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 + loop + Id := Attrs.Table (Id).Next; + end loop; + + return (Value => Id); + end Attribute_Node_Id_Of; + ---------------- -- Initialize -- ---------------- procedure Initialize is - Start : Positive := Initialization_Data'First; - Finish : Positive := Start; - Current_Package : Package_Node_Id := Empty_Package; - Current_Attribute : Attribute_Node_Id := Empty_Attribute; - Is_An_Attribute : Boolean := False; - Kind_1 : Variable_Kind := Undefined; - Optional_Index : Boolean := False; - Kind_2 : Attribute_Kind := Single; - Package_Name : Name_Id := No_Name; - Attribute_Name : Name_Id := No_Name; - First_Attribute : Attribute_Node_Id := Attribute_First; + Start : Positive := Initialization_Data'First; + Finish : Positive := Start; + Current_Package : Pkg_Node_Id := Empty_Pkg; + Current_Attribute : Attr_Node_Id := Empty_Attr; + Is_An_Attribute : Boolean := False; + Var_Kind : Variable_Kind := Undefined; + Optional_Index : Boolean := False; + Attr_Kind : Attribute_Kind := Single; + Package_Name : Name_Id := No_Name; + Attribute_Name : Name_Id := No_Name; + First_Attribute : Attr_Node_Id := Attr.First_Attribute; + + function Attribute_Location return String; + -- Returns a string depending if we are in the project level attributes + -- or in the attributes of a package. + + ------------------------ + -- Attribute_Location -- + ------------------------ + + function Attribute_Location return String is + begin + if Package_Name = No_Name then + return "project level attributes"; + + else + return "attribute of package """ & + Get_Name_String (Package_Name) & """"; + end if; + end Attribute_Location; + + -- Start of processing for Initialize begin + -- Don't allow Initialize action to be repeated + + if Initialized then + return; + end if; + -- Make sure the two tables are empty - Attributes.Init; + Attrs.Init; Package_Attributes.Init; while Initialization_Data (Start) /= '#' loop @@ -219,42 +381,41 @@ package body Prj.Attr is Finish := Finish + 1; end loop; - Name_Len := Finish - Start; - Name_Buffer (1 .. Name_Len) := - To_Lower (Initialization_Data (Start .. Finish - 1)); - Package_Name := Name_Find; + Package_Name := + Name_Id_Of (Initialization_Data (Start .. Finish - 1)); - for Index in Package_First .. Package_Attributes.Last loop + for Index in First_Package .. Package_Attributes.Last loop if Package_Name = Package_Attributes.Table (Index).Name then - Write_Line ("Duplicate package name """ & - Initialization_Data (Start .. Finish - 1) & - """ in Prj.Attr body."); - raise Program_Error; + Fail ("duplicate name """, + Initialization_Data (Start .. Finish - 1), + """ in predefined packages."); end if; end loop; Is_An_Attribute := False; - Current_Attribute := Empty_Attribute; + Current_Attribute := Empty_Attr; Package_Attributes.Increment_Last; Current_Package := Package_Attributes.Last; - Package_Attributes.Table (Current_Package).Name := - Package_Name; + Package_Attributes.Table (Current_Package) := + (Name => Package_Name, + Known => True, + First_Attribute => Empty_Attr); Start := Finish + 1; when 'S' => - Kind_1 := Single; + Var_Kind := Single; Optional_Index := False; when 's' => - Kind_1 := Single; + Var_Kind := Single; Optional_Index := True; when 'L' => - Kind_1 := List; + Var_Kind := List; Optional_Index := False; when 'l' => - Kind_1 := List; + Var_Kind := List; Optional_Index := True; when others => @@ -268,26 +429,26 @@ package body Prj.Attr is Start := Start + 1; case Initialization_Data (Start) is when 'V' => - Kind_2 := Single; + Attr_Kind := Single; when 'A' => - Kind_2 := Associative_Array; + Attr_Kind := Associative_Array; when 'a' => - Kind_2 := Case_Insensitive_Associative_Array; + Attr_Kind := Case_Insensitive_Associative_Array; when 'b' => if File_Names_Case_Sensitive then - Kind_2 := Associative_Array; + Attr_Kind := Associative_Array; else - Kind_2 := Case_Insensitive_Associative_Array; + Attr_Kind := Case_Insensitive_Associative_Array; end if; when 'c' => if File_Names_Case_Sensitive then - Kind_2 := Optional_Index_Associative_Array; + Attr_Kind := Optional_Index_Associative_Array; else - Kind_2 := + Attr_Kind := Optional_Index_Case_Insensitive_Associative_Array; end if; @@ -302,47 +463,331 @@ package body Prj.Attr is Finish := Finish + 1; end loop; - Name_Len := Finish - Start; - Name_Buffer (1 .. Name_Len) := - To_Lower (Initialization_Data (Start .. Finish - 1)); - Attribute_Name := Name_Find; - Attributes.Increment_Last; + Attribute_Name := + Name_Id_Of (Initialization_Data (Start .. Finish - 1)); + Attrs.Increment_Last; - if Current_Attribute = Empty_Attribute then - First_Attribute := Attributes.Last; + if Current_Attribute = Empty_Attr then + First_Attribute := Attrs.Last; - if Current_Package /= Empty_Package then + if Current_Package /= Empty_Pkg then Package_Attributes.Table (Current_Package).First_Attribute - := Attributes.Last; + := Attrs.Last; end if; else -- Check that there are no duplicate attributes - for Index in First_Attribute .. Attributes.Last - 1 loop - if Attribute_Name = - Attributes.Table (Index).Name then - Write_Line ("Duplicate attribute name """ & - Initialization_Data (Start .. Finish - 1) & - """ in Prj.Attr body."); - raise Program_Error; + for Index in First_Attribute .. Attrs.Last - 1 loop + if Attribute_Name = Attrs.Table (Index).Name then + Fail ("duplicate attribute """, + Initialization_Data (Start .. Finish - 1), + """ in " & Attribute_Location); end if; end loop; - Attributes.Table (Current_Attribute).Next := - Attributes.Last; + Attrs.Table (Current_Attribute).Next := + Attrs.Last; end if; - Current_Attribute := Attributes.Last; - Attributes.Table (Current_Attribute) := + Current_Attribute := Attrs.Last; + Attrs.Table (Current_Attribute) := (Name => Attribute_Name, - Kind_1 => Kind_1, + Var_Kind => Var_Kind, Optional_Index => Optional_Index, - Kind_2 => Kind_2, - Next => Empty_Attribute); + Attr_Kind => Attr_Kind, + Next => Empty_Attr); Start := Finish + 1; end if; end loop; + + Initialized := True; end Initialize; + ---------------- + -- Name_Id_Of -- + ---------------- + + function Name_Id_Of (Name : String) return Name_Id is + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Name); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Find; + end Name_Id_Of; + + -------------------- + -- Next_Attribute -- + -------------------- + + function Next_Attribute + (After : Attribute_Node_Id) return Attribute_Node_Id + is + begin + if After = Empty_Attribute then + return Empty_Attribute; + else + return (Value => Attrs.Table (After.Value).Next); + end if; + end Next_Attribute; + + ----------------------- + -- Optional_Index_Of -- + ----------------------- + + function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is + begin + if Attribute = Empty_Attribute then + return False; + else + return Attrs.Table (Attribute.Value).Optional_Index; + end if; + end Optional_Index_Of; + + ------------------------ + -- Package_Node_Id_Of -- + ------------------------ + + function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is + begin + for Index in Package_Attributes.First .. Package_Attributes.Last loop + if Package_Attributes.Table (Index).Name = Name then + return (Value => Index); + end if; + end loop; + + -- If there is no package with this name, return Empty_Package + + return Empty_Package; + end Package_Node_Id_Of; + + ---------------------------- + -- Register_New_Attribute -- + ---------------------------- + + procedure Register_New_Attribute + (Name : String; + In_Package : Package_Node_Id; + Attr_Kind : Defined_Attribute_Kind; + Var_Kind : Defined_Variable_Kind; + Index_Is_File_Name : Boolean := False; + Opt_Index : Boolean := False) + is + Attr_Name : Name_Id; + First_Attr : Attr_Node_Id := Empty_Attr; + Curr_Attr : Attr_Node_Id; + Real_Attr_Kind : Attribute_Kind; + + begin + if Name'Length = 0 then + Fail ("cannot register an attribute with no name"); + end if; + + if In_Package = Empty_Package then + Fail ("attempt to add attribute """, Name, + """ to an undefined package"); + end if; + + Attr_Name := Name_Id_Of (Name); + + First_Attr := + Package_Attributes.Table (In_Package.Value).First_Attribute; + + -- Check if attribute name is a duplicate + + Curr_Attr := First_Attr; + while Curr_Attr /= Empty_Attr loop + if Attrs.Table (Curr_Attr).Name = Attr_Name then + Fail ("duplicate attribute name """, Name, + """ in package """ & + Get_Name_String + (Package_Attributes.Table (In_Package.Value).Name) & + """"); + exit; + end if; + + Curr_Attr := Attrs.Table (Curr_Attr).Next; + end loop; + + Real_Attr_Kind := Attr_Kind; + + -- If Index_Is_File_Name, change the attribute kind if necessary + + if Index_Is_File_Name and then not File_Names_Case_Sensitive then + case Attr_Kind is + when Associative_Array => + Real_Attr_Kind := Case_Insensitive_Associative_Array; + + when Optional_Index_Associative_Array => + Real_Attr_Kind := + Optional_Index_Case_Insensitive_Associative_Array; + + when others => + null; + end case; + end if; + + -- Add the new attribute + + Attrs.Increment_Last; + Attrs.Table (Attrs.Last) := + (Name => Attr_Name, + Var_Kind => Var_Kind, + Optional_Index => Opt_Index, + Attr_Kind => Real_Attr_Kind, + Next => First_Attr); + Package_Attributes.Table (In_Package.Value).First_Attribute := + Attrs.Last; + end Register_New_Attribute; + + -------------------------- + -- Register_New_Package -- + -------------------------- + + procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is + Pkg_Name : Name_Id; + + begin + if Name'Length = 0 then + Fail ("cannot register a package with no name"); + end if; + + Pkg_Name := Name_Id_Of (Name); + Package_Attributes.Increment_Last; + Id := (Value => Package_Attributes.Last); + Package_Attributes.Table (Package_Attributes.Last) := + (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr); + end Register_New_Package; + + procedure Register_New_Package + (Name : String; + Attributes : Attribute_Data_Array) + is + Pkg_Name : Name_Id; + Attr_Name : Name_Id; + First_Attr : Attr_Node_Id := Empty_Attr; + Curr_Attr : Attr_Node_Id; + Attr_Kind : Attribute_Kind; + + begin + if Name'Length = 0 then + Fail ("cannot register a package with no name"); + 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, """"); + exit; + end if; + end loop; + + for Index in Attributes'Range loop + Attr_Name := Name_Id_Of (Attributes (Index).Name); + + Curr_Attr := First_Attr; + while Curr_Attr /= Empty_Attr loop + if Attrs.Table (Curr_Attr).Name = Attr_Name then + Fail ("duplicate attribute name """, Attributes (Index).Name, + """ in new package """ & Name & """"); + exit; + end if; + + Curr_Attr := Attrs.Table (Curr_Attr).Next; + end loop; + + Attr_Kind := Attributes (Index).Attr_Kind; + + if Attributes (Index).Index_Is_File_Name + and then not File_Names_Case_Sensitive + then + case Attr_Kind is + when Associative_Array => + Attr_Kind := Case_Insensitive_Associative_Array; + + when Optional_Index_Associative_Array => + Attr_Kind := + Optional_Index_Case_Insensitive_Associative_Array; + + when others => + null; + end case; + end if; + + Attrs.Increment_Last; + Attrs.Table (Attrs.Last) := + (Name => Attr_Name, + Var_Kind => Attributes (Index).Var_Kind, + Optional_Index => Attributes (Index).Opt_Index, + Attr_Kind => Attr_Kind, + Next => First_Attr); + First_Attr := Attrs.Last; + end loop; + + Package_Attributes.Increment_Last; + Package_Attributes.Table (Package_Attributes.Last) := + (Name => Pkg_Name, Known => True, First_Attribute => First_Attr); + end Register_New_Package; + + --------------------------- + -- Set_Attribute_Kind_Of -- + --------------------------- + + procedure Set_Attribute_Kind_Of + (Attribute : Attribute_Node_Id; + To : Attribute_Kind) + is + begin + if Attribute /= Empty_Attribute then + Attrs.Table (Attribute.Value).Attr_Kind := To; + end if; + end Set_Attribute_Kind_Of; + + -------------------------- + -- Set_Variable_Kind_Of -- + -------------------------- + + procedure Set_Variable_Kind_Of + (Attribute : Attribute_Node_Id; + To : Variable_Kind) + is + begin + if Attribute /= Empty_Attribute then + Attrs.Table (Attribute.Value).Var_Kind := To; + end if; + end Set_Variable_Kind_Of; + + ---------------------- + -- Variable_Kind_Of -- + ---------------------- + + function Variable_Kind_Of + (Attribute : Attribute_Node_Id) return Variable_Kind + is + begin + if Attribute = Empty_Attribute then + return Undefined; + else + return Attrs.Table (Attribute.Value).Var_Kind; + end if; + end Variable_Kind_Of; + + ------------------------ + -- First_Attribute_Of -- + ------------------------ + + function First_Attribute_Of + (Pkg : Package_Node_Id) return Attribute_Node_Id + is + begin + if Pkg = Empty_Package then + return Empty_Attribute; + else + return + (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); + end if; + end First_Attribute_Of; + end Prj.Attr; diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads index 9ca7ded47c1..226d82440ed 100644 --- a/gcc/ada/prj-attr.ads +++ b/gcc/ada/prj-attr.ads @@ -24,16 +24,191 @@ -- -- ------------------------------------------------------------------------------ --- This package defines allowed packages and attributes in GNAT project files +-- This package defines packages and attributes in GNAT project files. +-- There are predefined packages and attributes. +-- It is also possible to define new packages with their attributes. with Types; use Types; -with Table; package Prj.Attr is - -- Define the allowed attributes + procedure Initialize; + -- Initialize the predefined project level attributes and the predefined + -- packages and their attribute. This procedure should be called by + -- Prj.Initialize. + + type Attribute_Kind is + (Unknown, + Single, + Associative_Array, + Optional_Index_Associative_Array, + Case_Insensitive_Associative_Array, + Optional_Index_Case_Insensitive_Associative_Array); + -- Characteristics of an attribute. Optional_Index indicates that there + -- may be an optional index in the index of the associative array, as in + -- for Switches ("files.ada" at 2) use ... + + subtype Defined_Attribute_Kind is Attribute_Kind + range Single .. Optional_Index_Case_Insensitive_Associative_Array; + -- Subset of Attribute_Kinds that may be used for the attributes that is + -- used when defining a new package. + + Max_Attribute_Name_Length : constant := 64; + -- The maximum length of attribute names + + subtype Attribute_Name_Length is + Positive range 1 .. Max_Attribute_Name_Length; + + type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record + Name : String (1 .. Name_Length); + -- The name of the attribute + + Attr_Kind : Defined_Attribute_Kind; + -- The type of the attribute + + Index_Is_File_Name : Boolean; + -- For associative arrays, indicate if the index is a file name, so + -- that the attribute kind may be modified depending on the case + -- sensitivity of file names. This is only taken into account when + -- Attr_Kind is Associative_Array or Optional_Index_Associative_Array. + + Opt_Index : Boolean; + -- True if there may be an optional index in the value of the index, + -- as in: + -- "file.ada" at 2 + -- ("main.adb", "file.ada" at 1) + + Var_Kind : Defined_Variable_Kind; + -- The attribute value kind: single or list + + end record; + -- Name and characteristics of an attribute in a package registered + -- explicitly with Register_New_Package (see below). + + type Attribute_Data_Array is array (Positive range <>) of Attribute_Data; + + procedure Register_New_Package + (Name : String; + Attributes : Attribute_Data_Array); + -- Add a new package with its attributes. + -- This procedure can only be called after Initialize, but before any + -- other call to a service of the Project Managers. + -- The name of the package must be unique. The names of the attributes + -- must be different. + + -- The following declarations are only for the Project Manager, that is + -- the packages of the Prj or MLib hierarchies. + + ---------------- + -- Attributes -- + ---------------- + + type Attribute_Node_Id is private; + -- The type to refers to an attribute, self-initialized + + Empty_Attribute : constant Attribute_Node_Id; + -- Indicates no attribute. Default value of Attribute_Node_Id objects. + + Attribute_First : constant Attribute_Node_Id; + -- First attribute node id of project level attributes + + function Attribute_Node_Id_Of + (Name : Name_Id; + Starting_At : Attribute_Node_Id) return Attribute_Node_Id; + -- Returns the node id of an attribute at the project level or in + -- a package. Starting_At indicates the first known attribute node where + -- to start the search. Returns Empty_Attribute if the attribute cannot + -- be found. + + function Attribute_Kind_Of + (Attribute : Attribute_Node_Id) return Attribute_Kind; + -- Returns the attribute kind of a known attribute. Returns Unknown if + -- Attribute is Empty_Attribute. + + procedure Set_Attribute_Kind_Of + (Attribute : Attribute_Node_Id; + To : Attribute_Kind); + -- Set the attribute kind of a known attribute. Does nothing if + -- Attribute is Empty_Attribute. + + function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id; + -- Returns the name of a known attribute. Returns No_Name if Attribute is + -- Empty_Attribute. - -- All these declarations are uncommented, they all need comments ??? + function Variable_Kind_Of + (Attribute : Attribute_Node_Id) return Variable_Kind; + -- Returns the variable kind of a known attribute. Returns Undefined if + -- Attribute is Empty_Attribute. + + procedure Set_Variable_Kind_Of + (Attribute : Attribute_Node_Id; + To : Variable_Kind); + -- Set the variable kind of a known attribute. Does nothing if Attribute is + -- Empty_Attribute. + + function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean; + -- Returns True if Attribute is a known attribute and may have an + -- optional index. Returns False otherwise. + + function Next_Attribute + (After : Attribute_Node_Id) return Attribute_Node_Id; + -- Returns the attribute that follow After in the list of project level + -- attributes or the list of attributes in a package. + -- Returns Empty_Attribute if After is either Empty_Attribute or is the + -- last of the list. + + -------------- + -- Packages -- + -------------- + + type Package_Node_Id is private; + -- Type to refer to a package, self initialized + + Empty_Package : constant Package_Node_Id; + -- Default value of Package_Node_Id objects + + procedure Register_New_Package (Name : String; Id : out Package_Node_Id); + -- Add a new package. Fails if the package has a duplicate name. + -- Initially, the new package has no attributes. Id may be used to add + -- attributes using procedure Register_New_Attribute below. + + procedure Register_New_Attribute + (Name : String; + In_Package : Package_Node_Id; + Attr_Kind : Defined_Attribute_Kind; + Var_Kind : Defined_Variable_Kind; + Index_Is_File_Name : Boolean := False; + Opt_Index : Boolean := False); + -- Add a new attribute to registered package In_Package. Fails if the + -- attribute has a duplicate name. See definition of type Attribute_Data + -- above for the meaning of parameters Attr_Kind, Var_Kind, + -- Index_Is_File_Name and Opt_Index. + + function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id; + -- Returns the package node id of the package with name Name. Returns + -- Empty_Package if there is no package with this name. + + procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id); + -- Add a new package. The Name cannot be the name of a predefined or + -- already registered package. + + function First_Attribute_Of + (Pkg : Package_Node_Id) return Attribute_Node_Id; + -- Returns the first attribute in the list of attributes of package Pkg. + -- Returns Empty_Attribute if Pkg is Empty_Package. + + procedure Add_Attribute + (To_Package : Package_Node_Id; + Attribute_Name : Name_Id; + Attribute_Node : out Attribute_Node_Id); + -- Add an attribute to the list for package To_Package. Attribute_Name + -- cannot be the name of an existing attribute of the package. + -- Does nothing if To_Package is Empty_Package. + +private + ---------------- + -- Attributes -- + ---------------- Attributes_Initial : constant := 50; Attributes_Increment : constant := 50; @@ -41,41 +216,29 @@ package Prj.Attr is Attribute_Node_Low_Bound : constant := 0; Attribute_Node_High_Bound : constant := 099_999_999; - type Attribute_Node_Id is + type Attr_Node_Id is range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound; + -- Index type for table Attrs in the body - First_Attribute_Node_Id : constant Attribute_Node_Id := - Attribute_Node_Low_Bound + 1; + type Attribute_Node_Id is record + Value : Attr_Node_Id := Attribute_Node_Low_Bound; + end record; + -- Full declaration of self-initialized private type - Empty_Attribute : constant Attribute_Node_Id := - Attribute_Node_Low_Bound; + Empty_Attr : constant Attr_Node_Id := Attribute_Node_Low_Bound; - type Attribute_Kind is - (Single, - Associative_Array, - Optional_Index_Associative_Array, - Case_Insensitive_Associative_Array, - Optional_Index_Case_Insensitive_Associative_Array); + Empty_Attribute : constant Attribute_Node_Id := (Value => Empty_Attr); - type Attribute_Record is record - Name : Name_Id; - Kind_1 : Variable_Kind; - Optional_Index : Boolean; - Kind_2 : Attribute_Kind; - Next : Attribute_Node_Id; - end record; + First_Attribute : constant Attr_Node_Id := Attribute_Node_Low_Bound + 1; - package Attributes is - new Table.Table (Table_Component_Type => Attribute_Record, - Table_Index_Type => Attribute_Node_Id, - Table_Low_Bound => First_Attribute_Node_Id, - Table_Initial => Attributes_Initial, - Table_Increment => Attributes_Increment, - Table_Name => "Prj.Attr.Attributes"); + First_Attribute_Node_Id : constant Attribute_Node_Id := + (Value => First_Attribute); Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id; - -- Define the allowed packages + -------------- + -- Packages -- + -------------- Packages_Initial : constant := 10; Packages_Increment : constant := 50; @@ -83,31 +246,24 @@ package Prj.Attr is Package_Node_Low_Bound : constant := 0; Package_Node_High_Bound : constant := 099_999_999; - type Package_Node_Id is + type Pkg_Node_Id is range Package_Node_Low_Bound .. Package_Node_High_Bound; + -- Index type for table Package_Attributes in the body - First_Package_Node_Id : constant Package_Node_Id := - Package_Node_Low_Bound + 1; + type Package_Node_Id is record + Value : Pkg_Node_Id := Package_Node_Low_Bound; + end record; + -- Full declaration of self-initialized private type - Empty_Package : constant Package_Node_Id := Package_Node_Low_Bound; + Empty_Pkg : constant Pkg_Node_Id := Package_Node_Low_Bound; - type Package_Record is record - Name : Name_Id; - First_Attribute : Attribute_Node_Id; - end record; + Empty_Package : constant Package_Node_Id := (Value => Empty_Pkg); - package Package_Attributes is - new Table.Table (Table_Component_Type => Package_Record, - Table_Index_Type => Package_Node_Id, - Table_Low_Bound => First_Package_Node_Id, - Table_Initial => Packages_Initial, - Table_Increment => Packages_Increment, - Table_Name => "Prj.Attr.Packages"); + First_Package : constant Pkg_Node_Id := Package_Node_Low_Bound + 1; - Package_First : constant Package_Node_Id := First_Package_Node_Id; + First_Package_Node_Id : constant Package_Node_Id := + (Value => First_Package); - procedure Initialize; - -- Initialize the two tables above (Attributes and Package_Attributes). - -- This procedure should be called by Prj.Initialize. + Package_First : constant Package_Node_Id := First_Package_Node_Id; end Prj.Attr; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index e87146279fd..8a9ebaaf90a 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -124,6 +124,8 @@ package body Prj.Dect is Full_Associative_Array : Boolean := False; Attribute_Name : Name_Id := No_Name; Optional_Index : Boolean := False; + Pkg_Id : Package_Node_Id := Empty_Package; + Warning : Boolean := False; begin Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration); @@ -150,27 +152,28 @@ package body Prj.Dect is -- Find the attribute - while Current_Attribute /= Empty_Attribute - and then - Attributes.Table (Current_Attribute).Name /= Token_Name - loop - Current_Attribute := Attributes.Table (Current_Attribute).Next; - end loop; + Current_Attribute := + Attribute_Node_Id_Of (Token_Name, First_Attribute); - -- If not a valid attribute name, issue an error, or a warning - -- if inside a package that does not need to be checked. + -- If the attribute cannot be found, create the attribute if inside + -- an unknown package. if Current_Attribute = Empty_Attribute then - declare - Message : constant String := - "undefined attribute """ & - Get_Name_String (Name_Of (Attribute)) & '"'; + if Current_Package /= Empty_Node + and then Expression_Kind_Of (Current_Package) = Ignored + then + Pkg_Id := Package_Id_Of (Current_Package); + Add_Attribute (Pkg_Id, Token_Name, Current_Attribute); + Error_Msg_Name_1 := Token_Name; + Error_Msg ("?unknown attribute {", Token_Ptr); - Warning : Boolean := - Current_Package /= Empty_Node - and then Current_Packages_To_Check /= All_Packages; + else + -- If not a valid attribute name, issue an error, or a warning + -- if inside a package that does not need to be checked. + + Warning := Current_Package /= Empty_Node and then + Current_Packages_To_Check /= All_Packages; - begin if Warning then -- Check that we are not in a package to check @@ -187,17 +190,19 @@ package body Prj.Dect is end loop; end if; + Error_Msg_Name_1 := Token_Name; + if Warning then - Error_Msg ('?' & Message, Token_Ptr); + Error_Msg ("?undefined attribute {", Token_Ptr); else - Error_Msg (Message, Token_Ptr); + Error_Msg ("undefined attribute {", Token_Ptr); end if; - end; + end if; -- Set, if appropriate the index case insensitivity flag - elsif Attributes.Table (Current_Attribute).Kind_2 in + elsif Attribute_Kind_Of (Current_Attribute) in Case_Insensitive_Associative_Array .. Optional_Index_Case_Insensitive_Associative_Array then @@ -209,7 +214,10 @@ package body Prj.Dect is -- Change obsolete names of attributes to the new names - case Name_Of (Attribute) is + if Current_Package /= Empty_Node + and then Expression_Kind_Of (Current_Package) /= Ignored + then + case Name_Of (Attribute) is when Snames.Name_Specification => Set_Name_Of (Attribute, To => Snames.Name_Spec); @@ -224,23 +232,28 @@ package body Prj.Dect is when others => null; - end case; + end case; + end if; -- Associative array attributes if Token = Tok_Left_Paren then -- If the attribute is not an associative array attribute, report - -- an error. + -- an error. If this information is still unknown, set the kind + -- to Associative_Array. if Current_Attribute /= Empty_Attribute - and then Attributes.Table (Current_Attribute).Kind_2 = Single + and then Attribute_Kind_Of (Current_Attribute) = Single then Error_Msg ("the attribute """ & Get_Name_String - (Attributes.Table (Current_Attribute).Name) & + (Attribute_Name_Of (Current_Attribute)) & """ cannot be an associative array", Location_Of (Attribute)); + + elsif Attribute_Kind_Of (Current_Attribute) = Unknown then + Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array); end if; Scan; -- past the left parenthesis @@ -251,7 +264,7 @@ package body Prj.Dect is Scan; -- past the literal string index if Token = Tok_At then - case Attributes.Table (Current_Attribute).Kind_2 is + case Attribute_Kind_Of (Current_Attribute) is when Optional_Index_Associative_Array | Optional_Index_Case_Insensitive_Associative_Array => Scan; @@ -299,9 +312,14 @@ package body Prj.Dect is if Current_Attribute /= Empty_Attribute and then - Attributes.Table (Current_Attribute).Kind_2 /= Single + Attribute_Kind_Of (Current_Attribute) /= Single then - Full_Associative_Array := True; + if Attribute_Kind_Of (Current_Attribute) = Unknown then + Set_Attribute_Kind_Of (Current_Attribute, To => Single); + + else + Full_Associative_Array := True; + end if; end if; end if; @@ -309,8 +327,8 @@ package body Prj.Dect is if Current_Attribute /= Empty_Attribute then Set_Expression_Kind_Of - (Attribute, To => Attributes.Table (Current_Attribute).Kind_1); - Optional_Index := Attributes.Table (Current_Attribute).Optional_Index; + (Attribute, To => Variable_Kind_Of (Current_Attribute)); + Optional_Index := Optional_Index_Of (Current_Attribute); end if; Expect (Tok_Use, "USE"); @@ -488,15 +506,22 @@ package body Prj.Dect is if Current_Attribute /= Empty_Attribute and then Expression /= Empty_Node - and then Attributes.Table (Current_Attribute).Kind_1 /= + and then Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression) then - Error_Msg - ("wrong expression kind for attribute """ & - Get_Name_String - (Attributes.Table (Current_Attribute).Name) & - """", - Expression_Location); + if Variable_Kind_Of (Current_Attribute) = Undefined then + Set_Variable_Kind_Of + (Current_Attribute, + To => Expression_Kind_Of (Expression)); + + else + Error_Msg + ("wrong expression kind for attribute """ & + Get_Name_String + (Attribute_Name_Of (Current_Attribute)) & + """", + Expression_Location); + end if; end if; end; end if; @@ -858,19 +883,15 @@ package body Prj.Dect is Set_Name_Of (Package_Declaration, To => Token_Name); - for Index in Package_Attributes.First .. Package_Attributes.Last loop - if Token_Name = Package_Attributes.Table (Index).Name then - First_Attribute := - Package_Attributes.Table (Index).First_Attribute; - Current_Package := Index; - exit; - end if; - end loop; + Current_Package := Package_Node_Id_Of (Token_Name); - if Current_Package = Empty_Package then + if Current_Package /= Empty_Package then + First_Attribute := First_Attribute_Of (Current_Package); + + else Error_Msg ("?""" & Get_Name_String (Name_Of (Package_Declaration)) & - """ is not an allowed package name", + """ is not a known package name", Token_Ptr); -- Set the package declaration to "ignored" so that it is not @@ -878,37 +899,40 @@ package body Prj.Dect is Set_Expression_Kind_Of (Package_Declaration, Ignored); - else - Set_Package_Id_Of (Package_Declaration, To => Current_Package); + -- Add the unknown package in the list of packages - declare - Current : Project_Node_Id := First_Package_Of (Current_Project); + Add_Unknown_Package (Token_Name, Current_Package); + end if; - begin - while Current /= Empty_Node - and then Name_Of (Current) /= Token_Name - loop - Current := Next_Package_In_Project (Current); - end loop; + Set_Package_Id_Of (Package_Declaration, To => Current_Package); - if Current /= Empty_Node then - Error_Msg - ("package """ & - Get_Name_String (Name_Of (Package_Declaration)) & - """ is declared twice in the same project", - Token_Ptr); + declare + Current : Project_Node_Id := First_Package_Of (Current_Project); - else - -- Add the package to the project list + begin + while Current /= Empty_Node + and then Name_Of (Current) /= Token_Name + loop + Current := Next_Package_In_Project (Current); + end loop; - Set_Next_Package_In_Project - (Package_Declaration, - To => First_Package_Of (Current_Project)); - Set_First_Package_Of - (Current_Project, To => Package_Declaration); - end if; - end; - end if; + if Current /= Empty_Node then + Error_Msg + ("package """ & + Get_Name_String (Name_Of (Package_Declaration)) & + """ is declared twice in the same project", + Token_Ptr); + + else + -- Add the package to the project list + + Set_Next_Package_In_Project + (Package_Declaration, + To => First_Package_Of (Current_Project)); + Set_First_Package_Of + (Current_Project, To => Package_Declaration); + end if; + end; -- Scan past the package name diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb index b6b66dd5195..671b3156835 100644 --- a/gcc/ada/prj-makr.adb +++ b/gcc/ada/prj-makr.adb @@ -664,6 +664,107 @@ package body Prj.Makr is Output_Name (1 .. Path_Last) := To_Lower (Path_Name (1 .. Path_Last)); Output_Name_Last := Path_Last - Project_File_Extension'Length; + -- If there is already a project file with the specified name, parse + -- it to get the components that are not automatically generated. + + if Is_Regular_File (Output_Name (1 .. Path_Last)) then + if Opt.Verbose_Mode then + Output.Write_Str ("Parsing already existing project file """); + Output.Write_Str (Output_Name (1 .. Output_Name_Last)); + Output.Write_Line (""""); + end if; + + Part.Parse + (Project => Project_Node, + Project_File_Name => Output_Name (1 .. Output_Name_Last), + Always_Errout_Finalize => False); + + -- Fail if parsing was not successful + + if Project_Node = Empty_Node then + Fail ("parsing of existing project file failed"); + + else + -- If parsing was successful, remove the components that are + -- automatically generated, if any, so that they will be + -- unconditionally added later. + + -- Remove the with clause for the naming project file + + declare + With_Clause : Project_Node_Id := + First_With_Clause_Of (Project_Node); + Previous : Project_Node_Id := Empty_Node; + + begin + while With_Clause /= Empty_Node loop + if Tree.Name_Of (With_Clause) = Project_Naming_Id then + if Previous = Empty_Node then + Set_First_With_Clause_Of + (Project_Node, + To => Next_With_Clause_Of (With_Clause)); + else + Set_Next_With_Clause_Of + (Previous, + To => Next_With_Clause_Of (With_Clause)); + end if; + + exit; + end if; + + Previous := With_Clause; + With_Clause := Next_With_Clause_Of (With_Clause); + end loop; + end; + + -- Remove attribute declarations of Source_Files, + -- Source_List_File, Source_Dirs, and the declaration of + -- package Naming, if they exist. + + declare + Declaration : Project_Node_Id := + First_Declarative_Item_Of + (Project_Declaration_Of + (Project_Node)); + Previous : Project_Node_Id := Empty_Node; + Current_Node : Project_Node_Id := Empty_Node; + + begin + while Declaration /= Empty_Node loop + Current_Node := Current_Item_Node (Declaration); + + if (Kind_Of (Current_Node) = N_Attribute_Declaration + and then + (Tree.Name_Of (Current_Node) = Name_Source_Files + or else Tree.Name_Of (Current_Node) = + Name_Source_List_File + or else Tree.Name_Of (Current_Node) = + Name_Source_Dirs)) + or else + (Kind_Of (Current_Node) = N_Package_Declaration + and then Tree.Name_Of (Current_Node) = Name_Naming) + then + if Previous = Empty_Node then + Set_First_Declarative_Item_Of + (Project_Declaration_Of (Project_Node), + To => Next_Declarative_Item (Declaration)); + + else + Set_Next_Declarative_Item + (Previous, + To => Next_Declarative_Item (Declaration)); + end if; + + else + Previous := Declaration; + end if; + + Declaration := Next_Declarative_Item (Declaration); + end loop; + end; + end if; + end if; + if Directory_Last /= 0 then Output_Name (1 .. Output_Name_Last - Directory_Last) := Output_Name (Directory_Last + 1 .. Output_Name_Last); @@ -833,104 +934,6 @@ package body Prj.Makr is Output.Write_Line (""""); end if; - -- If there is already a project file with the specified name, - -- parse it to get the components that are not automatically - -- generated. - - if Is_Regular_File (Output_Name (1 .. Output_Name_Last)) then - if Opt.Verbose_Mode then - Output.Write_Str ("Parsing already existing project file """); - Output.Write_Str (Output_Name (1 .. Output_Name_Last)); - Output.Write_Line (""""); - end if; - - Part.Parse - (Project => Project_Node, - Project_File_Name => Output_Name (1 .. Output_Name_Last), - Always_Errout_Finalize => False); - - -- If parsing was successful, remove the components that are - -- automatically generated, if any, so that they will be - -- unconditionally added later. - - if Project_Node /= Empty_Node then - - -- Remove the with clause for the naming project file - - declare - With_Clause : Project_Node_Id := - First_With_Clause_Of (Project_Node); - Previous : Project_Node_Id := Empty_Node; - - begin - while With_Clause /= Empty_Node loop - if Tree.Name_Of (With_Clause) = Project_Naming_Id then - if Previous = Empty_Node then - Set_First_With_Clause_Of - (Project_Node, - To => Next_With_Clause_Of (With_Clause)); - else - Set_Next_With_Clause_Of - (Previous, - To => Next_With_Clause_Of (With_Clause)); - end if; - - exit; - end if; - - Previous := With_Clause; - With_Clause := Next_With_Clause_Of (With_Clause); - end loop; - end; - - -- Remove attribute declarations of Source_Files, - -- Source_List_File, Source_Dirs, and the declaration of - -- package Naming, if they exist. - - declare - Declaration : Project_Node_Id := - First_Declarative_Item_Of - (Project_Declaration_Of - (Project_Node)); - Previous : Project_Node_Id := Empty_Node; - Current_Node : Project_Node_Id := Empty_Node; - - begin - while Declaration /= Empty_Node loop - Current_Node := Current_Item_Node (Declaration); - - if (Kind_Of (Current_Node) = N_Attribute_Declaration - and then - (Tree.Name_Of (Current_Node) = Name_Source_Files - or else Tree.Name_Of (Current_Node) = - Name_Source_List_File - or else Tree.Name_Of (Current_Node) = - Name_Source_Dirs)) - or else - (Kind_Of (Current_Node) = N_Package_Declaration - and then Tree.Name_Of (Current_Node) = Name_Naming) - then - if Previous = Empty_Node then - Set_First_Declarative_Item_Of - (Project_Declaration_Of (Project_Node), - To => Next_Declarative_Item (Declaration)); - - else - Set_Next_Declarative_Item - (Previous, - To => Next_Declarative_Item (Declaration)); - end if; - - else - Previous := Declaration; - end if; - - Declaration := Next_Declarative_Item (Declaration); - end loop; - end; - end if; - end if; - -- If there were no already existing project file, or if the parsing -- was unsuccessful, create an empty project node with the correct -- name and its project declaration node. diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 7cc17fddf81..5df87a08fa3 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -155,18 +155,15 @@ package body Prj.Proc is First : Attribute_Node_Id) is The_Attribute : Attribute_Node_Id := First; - Attribute_Data : Attribute_Record; begin while The_Attribute /= Empty_Attribute loop - Attribute_Data := Attributes.Table (The_Attribute); - - if Attribute_Data.Kind_2 = Single then + if Attribute_Kind_Of (The_Attribute) = Single then declare New_Attribute : Variable_Value; begin - case Attribute_Data.Kind_1 is + case Variable_Kind_Of (The_Attribute) is -- Undefined should not happen @@ -201,13 +198,13 @@ package body Prj.Proc is Variable_Elements.Increment_Last; Variable_Elements.Table (Variable_Elements.Last) := (Next => Decl.Attributes, - Name => Attribute_Data.Name, + Name => Attribute_Name_Of (The_Attribute), Value => New_Attribute); Decl.Attributes := Variable_Elements.Last; end; end if; - The_Attribute := Attributes.Table (The_Attribute).Next; + The_Attribute := Next_Attribute (After => The_Attribute); end loop; end Add_Attributes; @@ -1068,8 +1065,8 @@ package body Prj.Proc is Add_Attributes (Project, Packages.Table (New_Pkg).Decl, - Package_Attributes.Table - (Package_Id_Of (Current_Item)).First_Attribute); + First_Attribute_Of + (Package_Id_Of (Current_Item))); -- And process declarative items of the new package diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index d6a2efa3082..b11124a2e38 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -177,12 +177,8 @@ package body Prj.Strt is -- Check if the identifier is one of the attribute identifiers in the -- context (package or project level attributes). - while Current_Attribute /= Empty_Attribute - and then - Attributes.Table (Current_Attribute).Name /= Token_Name - loop - Current_Attribute := Attributes.Table (Current_Attribute).Next; - end loop; + Current_Attribute := + Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute); -- If the identifier is not allowed, report an error @@ -201,9 +197,9 @@ package body Prj.Strt is Set_Project_Node_Of (Reference, To => Current_Project); Set_Package_Node_Of (Reference, To => Current_Package); Set_Expression_Kind_Of - (Reference, To => Attributes.Table (Current_Attribute).Kind_1); + (Reference, To => Variable_Kind_Of (Current_Attribute)); Set_Case_Insensitive - (Reference, To => Attributes.Table (Current_Attribute).Kind_2 = + (Reference, To => Attribute_Kind_Of (Current_Attribute) = Case_Insensitive_Associative_Array); -- Scan past the attribute name @@ -212,7 +208,7 @@ package body Prj.Strt is -- If the attribute is an associative array, get the index - if Attributes.Table (Current_Attribute).Kind_2 /= Single then + if Attribute_Kind_Of (Current_Attribute) /= Single then Expect (Tok_Left_Paren, "`(`"); if Token = Tok_Left_Paren then @@ -651,15 +647,9 @@ package body Prj.Strt is -- First, look if it can be a package name - for Index in Package_First .. Package_Attributes.Last loop - if Package_Attributes.Table (Index).Name = - Names.Table (1).Name - then - First_Attribute := - Package_Attributes.Table (Index).First_Attribute; - exit; - end if; - end loop; + First_Attribute := + First_Attribute_Of + (Package_Node_Id_Of (Names.Table (1).Name)); -- Now, look if it can be a project name @@ -808,8 +798,8 @@ package body Prj.Strt is -- package. First_Attribute := - Package_Attributes.Table - (Package_Id_Of (The_Package)).First_Attribute; + First_Attribute_Of + (Package_Id_Of (The_Package)); end if; end if; end if; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index 6fbec9fb2c4..af6482dac76 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -161,7 +161,7 @@ package body Prj is function Empty_Project return Project_Data is begin - Initialize; + Prj.Initialize; return Project_Empty; end Empty_Project; @@ -415,7 +415,7 @@ package body Prj is function Standard_Naming_Data return Naming_Data is begin - Initialize; + Prj.Initialize; return Std_Naming_Data; end Standard_Naming_Data; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 327e500f76e..a67cb5685eb 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -240,6 +240,9 @@ package Prj is type Variable_Kind is (Undefined, List, Single); -- Different kinds of variables + subtype Defined_Variable_Kind is Variable_Kind range List .. Single; + -- The defined kinds of variables + Ignored : constant Variable_Kind := Single; -- Used to indicate that a package declaration must be ignored -- while processing the project tree (unknown package name). diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 7af5adcb1a7..40175dde5ef 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1274,6 +1274,8 @@ package Rtsfind is RE_Asynchronous_Call, -- System.Tasking RE_Timed_Call, -- System.Tasking + RE_Ada_Task_Control_Block, -- System.Tasking + RE_Task_List, -- System.Tasking RE_Accept_Alternative, -- System.Tasking @@ -2354,6 +2356,8 @@ package Rtsfind is RE_Asynchronous_Call => System_Tasking, RE_Timed_Call => System_Tasking, + RE_Ada_Task_Control_Block => System_Tasking, + RE_Task_List => System_Tasking, RE_Accept_Alternative => System_Tasking, diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb index dfeda6398af..a98196ace81 100644 --- a/gcc/ada/s-finimp.adb +++ b/gcc/ada/s-finimp.adb @@ -102,7 +102,7 @@ package body System.Finalization_Implementation is Object.My_Address - Object'Address; procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr); - -- Substract the offset to the pointer + -- Subtract the offset to the pointer procedure Reverse_Adjust (P : Finalizable_Ptr); -- Ajust the components in the reverse order in which they are stored diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads index d83670a48ea..660f4dd0f15 100644 --- a/gcc/ada/s-finimp.ads +++ b/gcc/ada/s-finimp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004 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- -- @@ -137,7 +137,7 @@ pragma Elaborate_Body (Finalization_Implementation); -- Initialize the field My_Address to the Object'Address procedure Adjust (Object : in out Record_Controller); - -- Adjust the components and their finalization pointers by substracting + -- Adjust the components and their finalization pointers by subtracting -- by the offset of the target and the source addresses of the assignment. -- Inherit Finalize from Limited_Record_Controller diff --git a/gcc/ada/s-mastop-x86.adb b/gcc/ada/s-mastop-x86.adb index 96ac1138d7e..bb3e04a70d7 100644 --- a/gcc/ada/s-mastop-x86.adb +++ b/gcc/ada/s-mastop-x86.adb @@ -469,7 +469,7 @@ package body System.Machine_State_Operations is return To_Address (MS.eip); else -- When doing a call the return address is pushed to the stack. - -- We want to return the call point address, so we substract + -- We want to return the call point address, so we subtract -- Asm_Call_Size from the return address. This value is set -- to 5 as an asm call takes 5 bytes on x86 architectures. diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads index b539a3b8670..12bcd655953 100644 --- a/gcc/ada/s-secsta.ads +++ b/gcc/ada/s-secsta.ads @@ -73,7 +73,7 @@ package System.Secondary_Stack is -- to System.Null_Address. type Mark_Id is private; - -- Type used to mark the stack. + -- Type used to mark the stack function SS_Mark return Mark_Id; -- Return the Mark corresponding to the current state of the stack diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index 3d4a0fdb892..be0c6619ac7 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -443,9 +443,8 @@ package body System.Tasking.Restricted.Stages is Elaborated : Access_Boolean; Chain : in out Activation_Chain; Task_Image : String; - Created_Task : out Task_Id) + Created_Task : Task_Id) is - T : Task_Id; Self_ID : constant Task_Id := STPO.Self; Base_Priority : System.Any_Priority; Success : Boolean; @@ -457,8 +456,6 @@ package body System.Tasking.Restricted.Stages is Base_Priority := System.Any_Priority (Priority); end if; - T := New_ATCB (0); - if Single_Lock then Lock_RTS; end if; @@ -470,7 +467,7 @@ package body System.Tasking.Restricted.Stages is Initialize_ATCB (Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority, - Task_Info, Size, T, Success); + Task_Info, Size, Created_Task, Success); -- If we do our job right then there should never be any failures, -- which was probably said about the Titanic; so just to be safe, @@ -486,11 +483,12 @@ package body System.Tasking.Restricted.Stages is raise Program_Error; end if; - T.Entry_Calls (1).Self := T; + Created_Task.Entry_Calls (1).Self := Created_Task; - T.Common.Task_Image_Len := - Integer'Min (T.Common.Task_Image'Length, Task_Image'Length); - T.Common.Task_Image (1 .. T.Common.Task_Image_Len) := Task_Image; + Created_Task.Common.Task_Image_Len := + Integer'Min (Created_Task.Common.Task_Image'Length, Task_Image'Length); + Created_Task.Common.Task_Image + (1 .. Created_Task.Common.Task_Image_Len) := Task_Image; Unlock (Self_ID); @@ -501,10 +499,9 @@ package body System.Tasking.Restricted.Stages is -- Create TSD as early as possible in the creation of a task, since it -- may be used by the operation of Ada code within the task. - SSL.Create_TSD (T.Common.Compiler_Data); - T.Common.Activation_Link := Chain.T_ID; - Chain.T_ID := T; - Created_Task := T; + SSL.Create_TSD (Created_Task.Common.Compiler_Data); + Created_Task.Common.Activation_Link := Chain.T_ID; + Chain.T_ID := Created_Task; end Create_Restricted_Task; --------------------------- diff --git a/gcc/ada/s-tarest.ads b/gcc/ada/s-tarest.ads index c2f5471aec6..b8ec7c73bdc 100644 --- a/gcc/ada/s-tarest.ads +++ b/gcc/ada/s-tarest.ads @@ -75,9 +75,12 @@ package System.Tasking.Restricted.Stages is -- task type t (discr : integer); -- tE : aliased boolean := false; -- tZ : size_type := unspecified_size; + -- type tV (discr : integer) is limited record -- _task_id : task_id; + -- _atcb : aliased system__tasking__ada_task_control_block (0); -- end record; + -- procedure tB (_task : access tV); -- freeze tV [ -- procedure tVIP (_init : in out tV; _master : master_id; @@ -86,26 +89,28 @@ package System.Tasking.Restricted.Stages is -- begin -- _init.discr := discr; -- _init._task_id := null; + -- system__tasking__ada_task_control_blockIP (_init._atcb, 0); + -- _init._task_id := _init._atcb'unchecked_access; -- create_restricted_task (unspecified_priority, tZ, -- unspecified_task_info, task_procedure_access!(tB'address), -- _init'address, tE'unchecked_access, _chain, _task_name, _init. -- _task_id); -- return; -- end tVIP; - -- ] -- _chain : aliased activation_chain; -- activation_chainIP (_chain); -- procedure tB (_task : access tV) is -- discr : integer renames _task.discr; - -- + -- procedure _clean is -- begin -- complete_restricted_task; -- finalize_list (F14b); -- return; -- end _clean; + -- begin -- ...declarations... -- complete_restricted_activation; @@ -131,7 +136,7 @@ package System.Tasking.Restricted.Stages is Elaborated : Access_Boolean; Chain : in out Activation_Chain; Task_Image : String; - Created_Task : out Task_Id); + Created_Task : Task_Id); -- Compiler interface only. Do not call from within the RTS. -- This must be called to create a new task. -- diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index f2ee75c0f13..a79db6afb69 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -38,9 +38,6 @@ pragma Polling (Off); with System.Task_Primitives.Operations; -- used for Self -with Unchecked_Deallocation; --- To recover from failure of ATCB initialization. - with System.Storage_Elements; -- Needed for initializing Stack_Info.Size @@ -51,9 +48,6 @@ package body System.Tasking is package STPO renames System.Task_Primitives.Operations; - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); - ---------- -- Self -- ---------- @@ -73,7 +67,7 @@ package body System.Tasking is Base_Priority : System.Any_Priority; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; - T : in out Task_Id; + T : Task_Id; Success : out Boolean) is begin T.Common.State := Unactivated; @@ -83,7 +77,6 @@ package body System.Tasking is STPO.Initialize_TCB (T, Success); if not Success then - Free (T); return; end if; diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 8e5616bf85f..5fd2c22c4ef 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -960,13 +960,13 @@ package System.Tasking is Base_Priority : System.Any_Priority; Task_Info : System.Task_Info.Task_Info_Type; Stack_Size : System.Parameters.Size_Type; - T : in out Task_Id; + T : Task_Id; Success : out Boolean); -- Initialize fields of a TCB and link into global TCB structures -- Call this only with abort deferred and holding RTS_Lock. + -- Need more documentation, mention T, and describe Success ??? private - Null_Task : constant Task_Id := null; type Activation_Chain is record diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index e3b4c951b3a..bdd30be27f6 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -109,6 +109,9 @@ with System.Standard_Library; with System.Traces.Tasking; -- used for Send_Trace_Info +with Unchecked_Deallocation; +-- To recover from failure of ATCB initialization. + package body System.Tasking.Stages is package STPO renames System.Task_Primitives.Operations; @@ -130,6 +133,9 @@ package body System.Tasking.Stages is -- Local Subprograms -- ----------------------- + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_Id); + procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_Id); -- This procedure outputs the task specific message for exception -- tracing purposes. @@ -569,6 +575,7 @@ package body System.Tasking.Stages is Base_Priority, Task_Info, Size, T, Success); if not Success then + Free (T); Unlock (Self_ID); Unlock_RTS; Initialization.Undefer_Abort_Nestable (Self_ID); diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index a6f8a7a35a2..b06ab1e2919 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -894,7 +894,7 @@ package body Sem_Case is function Number_Of_Choices (N : Node_Id) return Nat is Alt : Node_Id; - -- A case statement alternative or a record variant. + -- A case statement alternative or a record variant Choice : Node_Id; Count : Nat := 0; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index ea2f4ecccb1..44d5f597467 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -798,42 +798,18 @@ package body Sem_Cat is K = N_Subprogram_Renaming_Declaration) and then Present (Parent_Spec (N)) then - declare - Parent_Lib_U : constant Node_Id := Parent_Spec (N); - Parent_Kind : constant Node_Kind := - Nkind (Unit (Parent_Lib_U)); - Parent_Entity : Entity_Id; - - begin - if Parent_Kind = N_Package_Instantiation - or else Parent_Kind = N_Procedure_Instantiation - or else Parent_Kind = N_Function_Instantiation - or else Parent_Kind = N_Package_Renaming_Declaration - or else Parent_Kind in N_Generic_Renaming_Declaration - then - Parent_Entity := Defining_Entity (Unit (Parent_Lib_U)); - - else - Parent_Entity := - Defining_Entity (Specification (Unit (Parent_Lib_U))); - end if; - - Check_Categorization_Dependencies (E, Parent_Entity, N, False); + Check_Categorization_Dependencies (E, Scope (E), N, False); - -- Verify that public child of an RCI library unit - -- must also be an RCI library unit (RM E.2.3(15)). + -- Verify that public child of an RCI library unit + -- must also be an RCI library unit (RM E.2.3(15)). - if Is_Remote_Call_Interface (Parent_Entity) - and then not Private_Present (P) - and then not Is_Remote_Call_Interface (E) - then - Error_Msg_N - ("public child of rci unit must also be rci unit", N); - return; - end if; - end; + if Is_Remote_Call_Interface (Scope (E)) + and then not Private_Present (P) + and then not Is_Remote_Call_Interface (E) + then + Error_Msg_N ("public child of rci unit must also be rci unit", N); + end if; end if; - end Validate_Categorization_Dependency; -------------------------------- diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 444c0836975..d913aa6f59f 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2493,8 +2493,16 @@ package body Sem_Ch10 is function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is begin - if Nkind (Unit) = N_Package_Instantiation then + if Nkind (Unit) = N_Package_Body + and then Nkind (Original_Node (Unit)) = N_Package_Instantiation + then + return + Defining_Entity + (Specification (Instance_Spec (Original_Node (Unit)))); + + elsif Nkind (Unit) = N_Package_Instantiation then return Defining_Entity (Specification (Instance_Spec (Unit))); + else return Defining_Entity (Unit); end if; @@ -2510,7 +2518,9 @@ package body Sem_Ch10 is is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Parent_Spec (Child_Unit); - P_Unit : constant Node_Id := Unit (P); + + P_Unit : Node_Id := Unit (P); + P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); Withn : Node_Id; @@ -2562,6 +2572,16 @@ package body Sem_Ch10 is -- Start of processing for Implicit_With_On_Parent begin + -- The unit of the current compilation may be a package body + -- that replaces an instance node. In this case we need the + -- original instance node to construct the proper parent name. + + if Nkind (P_Unit) = N_Package_Body + and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation + then + P_Unit := Original_Node (P_Unit); + end if; + New_Nodes_OK := New_Nodes_OK + 1; Withn := Make_With_Clause (Loc, Name => Build_Unit_Name); @@ -4318,16 +4338,26 @@ package body Sem_Ch10 is procedure Remove_Parents (Lib_Unit : Node_Id) is P : Node_Id; P_Name : Entity_Id; + P_Spec : Node_Id := Empty; E : Entity_Id; Vis : constant Boolean := Scope_Stack.Table (Scope_Stack.Last).Previous_Visibility; begin if Is_Child_Spec (Lib_Unit) then - P := Unit (Parent_Spec (Lib_Unit)); - P_Name := Get_Parent_Entity (P); + P_Spec := Parent_Spec (Lib_Unit); - Remove_Context_Clauses (Parent_Spec (Lib_Unit)); + elsif Nkind (Lib_Unit) = N_Package_Body + and then Nkind (Original_Node (Lib_Unit)) = N_Package_Instantiation + then + P_Spec := Parent_Spec (Original_Node (Lib_Unit)); + end if; + + if Present (P_Spec) then + + P := Unit (P_Spec); + P_Name := Get_Parent_Entity (P); + Remove_Context_Clauses (P_Spec); End_Package_Scope (P_Name); Set_Is_Immediately_Visible (P_Name, Vis); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a85d8c5ddca..11d4c014c6a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -1238,7 +1238,7 @@ package body Sem_Ch3 is -- appear in the private part of a package, for a private type that has -- already been declared. - -- In this case, the discriminants (if any) must match. + -- In this case, the discriminants (if any) must match T := Find_Type_Name (N); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4e5b6cab027..f674ba6e005 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2990,12 +2990,8 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Slice begin - -- Analyze the prefix if not done already - - if No (Etype (P)) then - Analyze (P); - end if; + Analyze (P); Analyze (D); if Is_Overloaded (P) then diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 01c28d3315a..11be7c1df51 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -885,14 +885,31 @@ package body Sem_Ch7 is Public_Child := False; - if Present (Parent_Spec (Parent (N))) then - Generate_Parent_References; + declare + Par : Entity_Id; + Pack_Decl : Node_Id; + Par_Spec : Node_Id; - declare - Par : Entity_Id := Id; - Pack_Decl : Node_Id; + begin + Par := Id; + Par_Spec := Parent_Spec (Parent (N)); + + -- If the package is formal package of an enclosing generic, is is + -- transformed into a local generic declaration, and compiled to make + -- its spec available. We need to retrieve the original generic to + -- determine whether it is a child unit, and install its parents. + + if No (Par_Spec) + and then + Nkind (Original_Node (Parent (N))) = N_Formal_Package_Declaration + then + Par := Entity (Name (Original_Node (Parent (N)))); + Par_Spec := Parent_Spec (Unit_Declaration_Node (Par)); + end if; + + if Present (Par_Spec) then + Generate_Parent_References; - begin while Scope (Par) /= Standard_Standard and then Is_Public_Child (Id, Par) loop @@ -903,8 +920,8 @@ package body Sem_Ch7 is Pack_Decl := Unit_Declaration_Node (Par); Set_Use (Private_Declarations (Specification (Pack_Decl))); end loop; - end; - end if; + end if; + end; if Is_Compilation_Unit (Id) then Install_Private_With_Clauses (Id); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0434d67ae74..0ce72096ca9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -72,6 +72,7 @@ with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; with Stylesw; use Stylesw; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; @@ -138,6 +139,26 @@ package body Sem_Prag is -- design and implementation and are intended to be fully compatible -- with the use of these pragmas in the DEC Ada compiler. + -------------------------------------------- + -- Checking for Duplicated External Names -- + -------------------------------------------- + + -- It is suspicious if two separate Export pragmas use the same external + -- name. The following table is used to diagnose this situation so that + -- an appropriate warning can be issued. + + -- The Node_Id stored is for the N_String_Literal node created to + -- hold the value of the external name. The Sloc of this node is + -- used to cross-reference the location of the duplication. + + package Externals is new Table.Table ( + Table_Component_Type => Node_Id, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 100, + Table_Name => "Name_Externals"); + ------------------------------------- -- Local Subprograms and Variables -- ------------------------------------- @@ -308,6 +329,12 @@ package body Sem_Prag is procedure Check_At_Most_N_Arguments (N : Nat); -- Check there are no more than N arguments present + procedure Check_Duplicated_Export_Name (Nam : Node_Id); + -- Nam is an N_String_Literal node containing the external name set + -- by an Import or Export pragma (or extended Import or Export pragma). + -- This procedure checks for possible duplications if this is the + -- export case, and if found, issues an appropriate error message. + procedure Check_First_Subtype (Arg : Node_Id); -- Checks that Arg, whose expression is an entity name referencing -- a subtype, does not reference a type that is not a first subtype. @@ -896,6 +923,39 @@ package body Sem_Prag is end if; end Check_At_Most_N_Arguments; + ---------------------------------- + -- Check_Duplicated_Export_Name -- + ---------------------------------- + + procedure Check_Duplicated_Export_Name (Nam : Node_Id) is + String_Val : constant String_Id := Strval (Nam); + + begin + -- We are only interested in the export case, and in the case of + -- generics, it is the instance, not the template, that is the + -- problem (the template will generate a warning in any case). + + if not Inside_A_Generic + and then (Prag_Id = Pragma_Export + or else + Prag_Id = Pragma_Export_Procedure + or else + Prag_Id = Pragma_Export_Valued_Procedure + or else + Prag_Id = Pragma_Export_Function) + then + for J in Externals.First .. Externals.Last loop + if String_Equal (String_Val, Strval (Externals.Table (J))) then + Error_Msg_Sloc := Sloc (Externals.Table (J)); + Error_Msg_N ("external name duplicates name given#", Nam); + exit; + end if; + end loop; + + Externals.Append (Nam); + end if; + end Check_Duplicated_Export_Name; + ------------------------- -- Check_First_Subtype -- ------------------------- @@ -3275,9 +3335,7 @@ package body Sem_Prag is -- If there is no link name, just set the external name if No (Link_Nam) then - Set_Encoded_Interface_Name - (Get_Base_Subprogram (Subprogram_Def), - Adjust_External_Name_Case (Expr_Value_S (Ext_Nam))); + Link_Nam := Adjust_External_Name_Case (Expr_Value_S (Ext_Nam)); -- For the Link_Name case, the given literal is preceded by an -- asterisk, which indicates to GCC that the given name should @@ -3296,10 +3354,11 @@ package body Sem_Prag is Link_Nam := Make_String_Literal (Sloc (Link_Nam), End_String); - - Set_Encoded_Interface_Name - (Get_Base_Subprogram (Subprogram_Def), Link_Nam); end if; + + Set_Encoded_Interface_Name + (Get_Base_Subprogram (Subprogram_Def), Link_Nam); + Check_Duplicated_Export_Name (Link_Nam); end Process_Interface_Name; ----------------------------------------- @@ -3740,8 +3799,8 @@ package body Sem_Prag is else Set_Encoded_Interface_Name (Internal_Ent, New_Name); + Check_Duplicated_Export_Name (New_Name); end if; - end Set_Extended_Import_Export_External_Name; ------------------ diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 11da616f8ef..e8eadd2ebe0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5093,7 +5093,8 @@ package body Sem_Util is or else (Nkind (Parent (N)) = N_Function_Call or else - Nkind (Parent (N)) = N_Parameter_Association)) + Nkind (Parent (N)) = N_Parameter_Association)) + and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); else @@ -5763,29 +5764,40 @@ package body Sem_Util is then return True; - -- Record type. OK if none of the component types requires a transient - -- scope. Note that we already know that this is a definite type (i.e. - -- has discriminant defaults if it is a discriminated record). + -- Record type elsif Is_Record_Type (Typ) then - if Has_Discriminants (Typ) then + + -- In GCC 2, discriminated records always require a transient + -- scope because the back end otherwise tries to allocate a + -- variable length temporary for the particular variant. + + if Opt.GCC_Version = 2 + and then Has_Discriminants (Typ) + then return True; - end if; - declare - Comp : Entity_Id; - begin - Comp := First_Entity (Typ); - while Present (Comp) loop - if Requires_Transient_Scope (Etype (Comp)) then - return True; - else - Next_Entity (Comp); - end if; - end loop; - end; + -- For GCC 3, or for a non-discriminated record in GCC 2, we are + -- OK if none of the component types requires a transient scope. + -- Note that we already know that this is a definite type (i.e. + -- has discriminant defaults if it is a discriminated record). - return False; + else + declare + Comp : Entity_Id; + begin + Comp := First_Entity (Typ); + while Present (Comp) loop + if Requires_Transient_Scope (Etype (Comp)) then + return True; + else + Next_Entity (Comp); + end if; + end loop; + end; + + return False; + end if; -- String literal types never require transient scope diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 93e416535a4..b9cd266b0de 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -359,7 +359,10 @@ package Sem_Util is function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a - -- component (at any recursive level) that is an access type. + -- component (at any recursive level) that is an access type. This + -- is a conservative predicate, if it is not known whether or not + -- T contains access values (happens for generic formals in some + -- cases), then False is returned. function Has_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 5fbfdcaf3c7..864c2deecc0 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -65,6 +65,7 @@ package body Snames is "_abort_signal#" & "_alignment#" & "_assign#" & + "_atcb#" & "_chain#" & "_clean#" & "_controller#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 545a3d0f39b..cb3b9d77bcc 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -148,149 +148,150 @@ package Snames is Name_uAbort_Signal : constant Name_Id := N + 005; Name_uAlignment : constant Name_Id := N + 006; Name_uAssign : constant Name_Id := N + 007; - Name_uChain : constant Name_Id := N + 008; - Name_uClean : constant Name_Id := N + 009; - Name_uController : constant Name_Id := N + 010; - Name_uEntry_Bodies : constant Name_Id := N + 011; - Name_uExpunge : constant Name_Id := N + 012; - Name_uFinal_List : constant Name_Id := N + 013; - Name_uIdepth : constant Name_Id := N + 014; - Name_uInit : constant Name_Id := N + 015; - Name_uLocal_Final_List : constant Name_Id := N + 016; - Name_uMaster : constant Name_Id := N + 017; - Name_uObject : constant Name_Id := N + 018; - Name_uPriority : constant Name_Id := N + 019; - Name_uProcess_ATSD : constant Name_Id := N + 020; - Name_uSecondary_Stack : constant Name_Id := N + 021; - Name_uService : constant Name_Id := N + 022; - Name_uSize : constant Name_Id := N + 023; - Name_uTags : constant Name_Id := N + 024; - Name_uTask : constant Name_Id := N + 025; - Name_uTask_Id : constant Name_Id := N + 026; - Name_uTask_Info : constant Name_Id := N + 027; - Name_uTask_Name : constant Name_Id := N + 028; - Name_uTrace_Sp : constant Name_Id := N + 029; + Name_uATCB : constant Name_Id := N + 008; + Name_uChain : constant Name_Id := N + 009; + Name_uClean : constant Name_Id := N + 010; + Name_uController : constant Name_Id := N + 011; + Name_uEntry_Bodies : constant Name_Id := N + 012; + Name_uExpunge : constant Name_Id := N + 013; + Name_uFinal_List : constant Name_Id := N + 014; + Name_uIdepth : constant Name_Id := N + 015; + Name_uInit : constant Name_Id := N + 016; + Name_uLocal_Final_List : constant Name_Id := N + 017; + Name_uMaster : constant Name_Id := N + 018; + Name_uObject : constant Name_Id := N + 019; + Name_uPriority : constant Name_Id := N + 020; + Name_uProcess_ATSD : constant Name_Id := N + 021; + Name_uSecondary_Stack : constant Name_Id := N + 022; + Name_uService : constant Name_Id := N + 023; + Name_uSize : constant Name_Id := N + 024; + Name_uTags : constant Name_Id := N + 025; + Name_uTask : constant Name_Id := N + 026; + Name_uTask_Id : constant Name_Id := N + 027; + Name_uTask_Info : constant Name_Id := N + 028; + Name_uTask_Name : constant Name_Id := N + 029; + Name_uTrace_Sp : constant Name_Id := N + 030; -- Names of routines in Ada.Finalization, needed by expander - Name_Initialize : constant Name_Id := N + 030; - Name_Adjust : constant Name_Id := N + 031; - Name_Finalize : constant Name_Id := N + 032; + Name_Initialize : constant Name_Id := N + 031; + Name_Adjust : constant Name_Id := N + 032; + Name_Finalize : constant Name_Id := N + 033; -- Names of fields declared in System.Finalization_Implementation, -- needed by the expander when generating code for finalization. - Name_Next : constant Name_Id := N + 033; - Name_Prev : constant Name_Id := N + 034; + Name_Next : constant Name_Id := N + 034; + Name_Prev : constant Name_Id := N + 035; -- Names of TSS routines for implementation of DSA over PolyORB - Name_uTypeCode : constant Name_Id := N + 035; - Name_uFrom_Any : constant Name_Id := N + 036; - Name_uTo_Any : constant Name_Id := N + 037; + Name_uTypeCode : constant Name_Id := N + 036; + Name_uFrom_Any : constant Name_Id := N + 037; + Name_uTo_Any : constant Name_Id := N + 038; -- Names of allocation routines, also needed by expander - Name_Allocate : constant Name_Id := N + 038; - Name_Deallocate : constant Name_Id := N + 039; - Name_Dereference : constant Name_Id := N + 040; + Name_Allocate : constant Name_Id := N + 039; + Name_Deallocate : constant Name_Id := N + 040; + Name_Dereference : constant Name_Id := N + 041; -- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge) - First_Text_IO_Package : constant Name_Id := N + 041; - Name_Decimal_IO : constant Name_Id := N + 041; - Name_Enumeration_IO : constant Name_Id := N + 042; - Name_Fixed_IO : constant Name_Id := N + 043; - Name_Float_IO : constant Name_Id := N + 044; - Name_Integer_IO : constant Name_Id := N + 045; - Name_Modular_IO : constant Name_Id := N + 046; - Last_Text_IO_Package : constant Name_Id := N + 046; + First_Text_IO_Package : constant Name_Id := N + 042; + Name_Decimal_IO : constant Name_Id := N + 042; + Name_Enumeration_IO : constant Name_Id := N + 043; + Name_Fixed_IO : constant Name_Id := N + 044; + Name_Float_IO : constant Name_Id := N + 045; + Name_Integer_IO : constant Name_Id := N + 046; + Name_Modular_IO : constant Name_Id := N + 047; + Last_Text_IO_Package : constant Name_Id := N + 047; subtype Text_IO_Package_Name is Name_Id range First_Text_IO_Package .. Last_Text_IO_Package; -- Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO - Name_a_textio : constant Name_Id := N + 047; - Name_a_witeio : constant Name_Id := N + 048; + Name_a_textio : constant Name_Id := N + 048; + Name_a_witeio : constant Name_Id := N + 049; -- Some miscellaneous names used for error detection/recovery - Name_Const : constant Name_Id := N + 049; - Name_Error : constant Name_Id := N + 050; - Name_Go : constant Name_Id := N + 051; - Name_Put : constant Name_Id := N + 052; - Name_Put_Line : constant Name_Id := N + 053; - Name_To : constant Name_Id := N + 054; + Name_Const : constant Name_Id := N + 050; + Name_Error : constant Name_Id := N + 051; + Name_Go : constant Name_Id := N + 052; + Name_Put : constant Name_Id := N + 053; + Name_Put_Line : constant Name_Id := N + 054; + Name_To : constant Name_Id := N + 055; -- Names for packages that are treated specially by the compiler - Name_Finalization : constant Name_Id := N + 055; - Name_Finalization_Root : constant Name_Id := N + 056; - Name_Interfaces : constant Name_Id := N + 057; - Name_Standard : constant Name_Id := N + 058; - Name_System : constant Name_Id := N + 059; - Name_Text_IO : constant Name_Id := N + 060; - Name_Wide_Text_IO : constant Name_Id := N + 061; + Name_Finalization : constant Name_Id := N + 056; + Name_Finalization_Root : constant Name_Id := N + 057; + Name_Interfaces : constant Name_Id := N + 058; + Name_Standard : constant Name_Id := N + 059; + Name_System : constant Name_Id := N + 060; + Name_Text_IO : constant Name_Id := N + 061; + Name_Wide_Text_IO : constant Name_Id := N + 062; -- Names of implementations of the distributed systems annex - Name_No_DSA : constant Name_Id := N + 062; - Name_GLADE_DSA : constant Name_Id := N + 063; - Name_PolyORB_DSA : constant Name_Id := N + 064; + Name_No_DSA : constant Name_Id := N + 063; + Name_GLADE_DSA : constant Name_Id := N + 064; + Name_PolyORB_DSA : constant Name_Id := N + 065; -- Names of identifiers used in expanding distribution stubs - Name_Addr : constant Name_Id := N + 065; - Name_Async : constant Name_Id := N + 066; - Name_Get_Active_Partition_ID : constant Name_Id := N + 067; - Name_Get_RCI_Package_Receiver : constant Name_Id := N + 068; - Name_Get_RCI_Package_Ref : constant Name_Id := N + 069; - Name_Origin : constant Name_Id := N + 070; - Name_Params : constant Name_Id := N + 071; - Name_Partition : constant Name_Id := N + 072; - Name_Partition_Interface : constant Name_Id := N + 073; - Name_Ras : constant Name_Id := N + 074; - Name_Call : constant Name_Id := N + 075; - Name_RCI_Name : constant Name_Id := N + 076; - Name_Receiver : constant Name_Id := N + 077; - Name_Result : constant Name_Id := N + 078; - Name_Rpc : constant Name_Id := N + 079; - Name_Subp_Id : constant Name_Id := N + 080; - Name_Operation : constant Name_Id := N + 081; - Name_Argument : constant Name_Id := N + 082; - Name_Arg_Modes : constant Name_Id := N + 083; - Name_Handler : constant Name_Id := N + 084; - Name_Target : constant Name_Id := N + 085; - Name_Req : constant Name_Id := N + 086; - Name_Obj_TypeCode : constant Name_Id := N + 087; - Name_Stub : constant Name_Id := N + 088; + Name_Addr : constant Name_Id := N + 066; + Name_Async : constant Name_Id := N + 067; + Name_Get_Active_Partition_ID : constant Name_Id := N + 068; + Name_Get_RCI_Package_Receiver : constant Name_Id := N + 069; + Name_Get_RCI_Package_Ref : constant Name_Id := N + 070; + Name_Origin : constant Name_Id := N + 071; + Name_Params : constant Name_Id := N + 072; + Name_Partition : constant Name_Id := N + 073; + Name_Partition_Interface : constant Name_Id := N + 074; + Name_Ras : constant Name_Id := N + 075; + Name_Call : constant Name_Id := N + 076; + Name_RCI_Name : constant Name_Id := N + 077; + Name_Receiver : constant Name_Id := N + 078; + Name_Result : constant Name_Id := N + 079; + Name_Rpc : constant Name_Id := N + 080; + Name_Subp_Id : constant Name_Id := N + 081; + Name_Operation : constant Name_Id := N + 082; + Name_Argument : constant Name_Id := N + 083; + Name_Arg_Modes : constant Name_Id := N + 084; + Name_Handler : constant Name_Id := N + 085; + Name_Target : constant Name_Id := N + 086; + Name_Req : constant Name_Id := N + 087; + Name_Obj_TypeCode : constant Name_Id := N + 088; + Name_Stub : constant Name_Id := N + 089; -- Operator Symbol entries. The actual names have an upper case O at -- the start in place of the Op_ prefix (e.g. the actual name that -- corresponds to Name_Op_Abs is "Oabs". - First_Operator_Name : constant Name_Id := N + 089; - Name_Op_Abs : constant Name_Id := N + 089; -- "abs" - Name_Op_And : constant Name_Id := N + 090; -- "and" - Name_Op_Mod : constant Name_Id := N + 091; -- "mod" - Name_Op_Not : constant Name_Id := N + 092; -- "not" - Name_Op_Or : constant Name_Id := N + 093; -- "or" - Name_Op_Rem : constant Name_Id := N + 094; -- "rem" - Name_Op_Xor : constant Name_Id := N + 095; -- "xor" - Name_Op_Eq : constant Name_Id := N + 096; -- "=" - Name_Op_Ne : constant Name_Id := N + 097; -- "/=" - Name_Op_Lt : constant Name_Id := N + 098; -- "<" - Name_Op_Le : constant Name_Id := N + 099; -- "<=" - Name_Op_Gt : constant Name_Id := N + 100; -- ">" - Name_Op_Ge : constant Name_Id := N + 101; -- ">=" - Name_Op_Add : constant Name_Id := N + 102; -- "+" - Name_Op_Subtract : constant Name_Id := N + 103; -- "-" - Name_Op_Concat : constant Name_Id := N + 104; -- "&" - Name_Op_Multiply : constant Name_Id := N + 105; -- "*" - Name_Op_Divide : constant Name_Id := N + 106; -- "/" - Name_Op_Expon : constant Name_Id := N + 107; -- "**" - Last_Operator_Name : constant Name_Id := N + 107; + First_Operator_Name : constant Name_Id := N + 090; + Name_Op_Abs : constant Name_Id := N + 090; -- "abs" + Name_Op_And : constant Name_Id := N + 091; -- "and" + Name_Op_Mod : constant Name_Id := N + 092; -- "mod" + Name_Op_Not : constant Name_Id := N + 093; -- "not" + Name_Op_Or : constant Name_Id := N + 094; -- "or" + Name_Op_Rem : constant Name_Id := N + 095; -- "rem" + Name_Op_Xor : constant Name_Id := N + 096; -- "xor" + Name_Op_Eq : constant Name_Id := N + 097; -- "=" + Name_Op_Ne : constant Name_Id := N + 098; -- "/=" + Name_Op_Lt : constant Name_Id := N + 099; -- "<" + Name_Op_Le : constant Name_Id := N + 100; -- "<=" + Name_Op_Gt : constant Name_Id := N + 101; -- ">" + Name_Op_Ge : constant Name_Id := N + 102; -- ">=" + Name_Op_Add : constant Name_Id := N + 103; -- "+" + Name_Op_Subtract : constant Name_Id := N + 104; -- "-" + Name_Op_Concat : constant Name_Id := N + 105; -- "&" + Name_Op_Multiply : constant Name_Id := N + 106; -- "*" + Name_Op_Divide : constant Name_Id := N + 107; -- "/" + Name_Op_Expon : constant Name_Id := N + 108; -- "**" + Last_Operator_Name : constant Name_Id := N + 108; -- Names for all pragmas recognized by GNAT. The entries with the comment -- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95. @@ -313,64 +314,64 @@ package Snames is -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. - First_Pragma_Name : constant Name_Id := N + 108; + First_Pragma_Name : constant Name_Id := N + 109; -- Configuration pragmas are grouped at start - Name_Ada_83 : constant Name_Id := N + 108; -- GNAT - Name_Ada_95 : constant Name_Id := N + 109; -- GNAT - Name_Ada_05 : constant Name_Id := N + 110; -- GNAT - Name_C_Pass_By_Copy : constant Name_Id := N + 111; -- GNAT - Name_Compile_Time_Warning : constant Name_Id := N + 112; -- GNAT - Name_Component_Alignment : constant Name_Id := N + 113; -- GNAT - Name_Convention_Identifier : constant Name_Id := N + 114; -- GNAT - Name_Detect_Blocking : constant Name_Id := N + 115; -- Ada05 - Name_Discard_Names : constant Name_Id := N + 116; - Name_Elaboration_Checks : constant Name_Id := N + 117; -- GNAT - Name_Eliminate : constant Name_Id := N + 118; -- GNAT - Name_Explicit_Overriding : constant Name_Id := N + 119; - Name_Extend_System : constant Name_Id := N + 120; -- GNAT - Name_Extensions_Allowed : constant Name_Id := N + 121; -- GNAT - Name_External_Name_Casing : constant Name_Id := N + 122; -- GNAT - Name_Float_Representation : constant Name_Id := N + 123; -- GNAT - Name_Initialize_Scalars : constant Name_Id := N + 124; -- GNAT - Name_Interrupt_State : constant Name_Id := N + 125; -- GNAT - Name_License : constant Name_Id := N + 126; -- GNAT - Name_Locking_Policy : constant Name_Id := N + 127; - Name_Long_Float : constant Name_Id := N + 128; -- VMS - Name_No_Run_Time : constant Name_Id := N + 129; -- GNAT - Name_No_Strict_Aliasing : constant Name_Id := N + 130; -- GNAT - Name_Normalize_Scalars : constant Name_Id := N + 131; - Name_Polling : constant Name_Id := N + 132; -- GNAT - Name_Persistent_Data : constant Name_Id := N + 133; -- GNAT - Name_Persistent_Object : constant Name_Id := N + 134; -- GNAT - Name_Profile : constant Name_Id := N + 135; -- Ada05 - Name_Profile_Warnings : constant Name_Id := N + 136; -- GNAT - Name_Propagate_Exceptions : constant Name_Id := N + 137; -- GNAT - Name_Queuing_Policy : constant Name_Id := N + 138; - Name_Ravenscar : constant Name_Id := N + 139; - Name_Restricted_Run_Time : constant Name_Id := N + 140; - Name_Restrictions : constant Name_Id := N + 141; - Name_Restriction_Warnings : constant Name_Id := N + 142; -- GNAT - Name_Reviewable : constant Name_Id := N + 143; - Name_Source_File_Name : constant Name_Id := N + 144; -- GNAT - Name_Source_File_Name_Project : constant Name_Id := N + 145; -- GNAT - Name_Style_Checks : constant Name_Id := N + 146; -- GNAT - Name_Suppress : constant Name_Id := N + 147; - Name_Suppress_Exception_Locations : constant Name_Id := N + 148; -- GNAT - Name_Task_Dispatching_Policy : constant Name_Id := N + 149; - Name_Universal_Data : constant Name_Id := N + 150; -- AAMP - Name_Unsuppress : constant Name_Id := N + 151; -- GNAT - Name_Use_VADS_Size : constant Name_Id := N + 152; -- GNAT - Name_Validity_Checks : constant Name_Id := N + 153; -- GNAT - Name_Warnings : constant Name_Id := N + 154; -- GNAT - Last_Configuration_Pragma_Name : constant Name_Id := N + 154; + Name_Ada_83 : constant Name_Id := N + 109; -- GNAT + Name_Ada_95 : constant Name_Id := N + 110; -- GNAT + Name_Ada_05 : constant Name_Id := N + 111; -- GNAT + Name_C_Pass_By_Copy : constant Name_Id := N + 112; -- GNAT + Name_Compile_Time_Warning : constant Name_Id := N + 113; -- GNAT + Name_Component_Alignment : constant Name_Id := N + 114; -- GNAT + Name_Convention_Identifier : constant Name_Id := N + 115; -- GNAT + Name_Detect_Blocking : constant Name_Id := N + 116; -- Ada05 + Name_Discard_Names : constant Name_Id := N + 117; + Name_Elaboration_Checks : constant Name_Id := N + 118; -- GNAT + Name_Eliminate : constant Name_Id := N + 119; -- GNAT + Name_Explicit_Overriding : constant Name_Id := N + 120; + Name_Extend_System : constant Name_Id := N + 121; -- GNAT + Name_Extensions_Allowed : constant Name_Id := N + 122; -- GNAT + Name_External_Name_Casing : constant Name_Id := N + 123; -- GNAT + Name_Float_Representation : constant Name_Id := N + 124; -- GNAT + Name_Initialize_Scalars : constant Name_Id := N + 125; -- GNAT + Name_Interrupt_State : constant Name_Id := N + 126; -- GNAT + Name_License : constant Name_Id := N + 127; -- GNAT + Name_Locking_Policy : constant Name_Id := N + 128; + Name_Long_Float : constant Name_Id := N + 129; -- VMS + Name_No_Run_Time : constant Name_Id := N + 130; -- GNAT + Name_No_Strict_Aliasing : constant Name_Id := N + 131; -- GNAT + Name_Normalize_Scalars : constant Name_Id := N + 132; + Name_Polling : constant Name_Id := N + 133; -- GNAT + Name_Persistent_Data : constant Name_Id := N + 134; -- GNAT + Name_Persistent_Object : constant Name_Id := N + 135; -- GNAT + Name_Profile : constant Name_Id := N + 136; -- Ada05 + Name_Profile_Warnings : constant Name_Id := N + 137; -- GNAT + Name_Propagate_Exceptions : constant Name_Id := N + 138; -- GNAT + Name_Queuing_Policy : constant Name_Id := N + 139; + Name_Ravenscar : constant Name_Id := N + 140; + Name_Restricted_Run_Time : constant Name_Id := N + 141; + Name_Restrictions : constant Name_Id := N + 142; + Name_Restriction_Warnings : constant Name_Id := N + 143; -- GNAT + Name_Reviewable : constant Name_Id := N + 144; + Name_Source_File_Name : constant Name_Id := N + 145; -- GNAT + Name_Source_File_Name_Project : constant Name_Id := N + 146; -- GNAT + Name_Style_Checks : constant Name_Id := N + 147; -- GNAT + Name_Suppress : constant Name_Id := N + 148; + Name_Suppress_Exception_Locations : constant Name_Id := N + 149; -- GNAT + Name_Task_Dispatching_Policy : constant Name_Id := N + 150; + Name_Universal_Data : constant Name_Id := N + 151; -- AAMP + Name_Unsuppress : constant Name_Id := N + 152; -- GNAT + Name_Use_VADS_Size : constant Name_Id := N + 153; -- GNAT + Name_Validity_Checks : constant Name_Id := N + 154; -- GNAT + Name_Warnings : constant Name_Id := N + 155; -- GNAT + Last_Configuration_Pragma_Name : constant Name_Id := N + 155; -- Remaining pragma names - Name_Abort_Defer : constant Name_Id := N + 155; -- GNAT - Name_All_Calls_Remote : constant Name_Id := N + 156; - Name_Annotate : constant Name_Id := N + 157; -- GNAT + Name_Abort_Defer : constant Name_Id := N + 156; -- GNAT + Name_All_Calls_Remote : constant Name_Id := N + 157; + Name_Annotate : constant Name_Id := N + 158; -- GNAT -- Note: AST_Entry is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -378,78 +379,78 @@ package Snames is -- and Check_Pragma_Id correctly recognize and process Name_AST_Entry. -- AST_Entry is a VMS specific pragma. - Name_Assert : constant Name_Id := N + 158; -- GNAT - Name_Asynchronous : constant Name_Id := N + 159; - Name_Atomic : constant Name_Id := N + 160; - Name_Atomic_Components : constant Name_Id := N + 161; - Name_Attach_Handler : constant Name_Id := N + 162; - Name_Comment : constant Name_Id := N + 163; -- GNAT - Name_Common_Object : constant Name_Id := N + 164; -- GNAT - Name_Complex_Representation : constant Name_Id := N + 165; -- GNAT - Name_Controlled : constant Name_Id := N + 166; - Name_Convention : constant Name_Id := N + 167; - Name_CPP_Class : constant Name_Id := N + 168; -- GNAT - Name_CPP_Constructor : constant Name_Id := N + 169; -- GNAT - Name_CPP_Virtual : constant Name_Id := N + 170; -- GNAT - Name_CPP_Vtable : constant Name_Id := N + 171; -- GNAT - Name_Debug : constant Name_Id := N + 172; -- GNAT - Name_Elaborate : constant Name_Id := N + 173; -- Ada 83 - Name_Elaborate_All : constant Name_Id := N + 174; - Name_Elaborate_Body : constant Name_Id := N + 175; - Name_Export : constant Name_Id := N + 176; - Name_Export_Exception : constant Name_Id := N + 177; -- VMS - Name_Export_Function : constant Name_Id := N + 178; -- GNAT - Name_Export_Object : constant Name_Id := N + 179; -- GNAT - Name_Export_Procedure : constant Name_Id := N + 180; -- GNAT - Name_Export_Value : constant Name_Id := N + 181; -- GNAT - Name_Export_Valued_Procedure : constant Name_Id := N + 182; -- GNAT - Name_External : constant Name_Id := N + 183; -- GNAT - Name_Finalize_Storage_Only : constant Name_Id := N + 184; -- GNAT - Name_Ident : constant Name_Id := N + 185; -- VMS - Name_Import : constant Name_Id := N + 186; - Name_Import_Exception : constant Name_Id := N + 187; -- VMS - Name_Import_Function : constant Name_Id := N + 188; -- GNAT - Name_Import_Object : constant Name_Id := N + 189; -- GNAT - Name_Import_Procedure : constant Name_Id := N + 190; -- GNAT - Name_Import_Valued_Procedure : constant Name_Id := N + 191; -- GNAT - Name_Inline : constant Name_Id := N + 192; - Name_Inline_Always : constant Name_Id := N + 193; -- GNAT - Name_Inline_Generic : constant Name_Id := N + 194; -- GNAT - Name_Inspection_Point : constant Name_Id := N + 195; - Name_Interface : constant Name_Id := N + 196; -- Ada 83 - Name_Interface_Name : constant Name_Id := N + 197; -- GNAT - Name_Interrupt_Handler : constant Name_Id := N + 198; - Name_Interrupt_Priority : constant Name_Id := N + 199; - Name_Java_Constructor : constant Name_Id := N + 200; -- GNAT - Name_Java_Interface : constant Name_Id := N + 201; -- GNAT - Name_Keep_Names : constant Name_Id := N + 202; -- GNAT - Name_Link_With : constant Name_Id := N + 203; -- GNAT - Name_Linker_Alias : constant Name_Id := N + 204; -- GNAT - Name_Linker_Options : constant Name_Id := N + 205; - Name_Linker_Section : constant Name_Id := N + 206; -- GNAT - Name_List : constant Name_Id := N + 207; - Name_Machine_Attribute : constant Name_Id := N + 208; -- GNAT - Name_Main : constant Name_Id := N + 209; -- GNAT - Name_Main_Storage : constant Name_Id := N + 210; -- GNAT - Name_Memory_Size : constant Name_Id := N + 211; -- Ada 83 - Name_No_Return : constant Name_Id := N + 212; -- GNAT - Name_Obsolescent : constant Name_Id := N + 213; -- GNAT - Name_Optimize : constant Name_Id := N + 214; - Name_Optional_Overriding : constant Name_Id := N + 215; - Name_Overriding : constant Name_Id := N + 216; - Name_Pack : constant Name_Id := N + 217; - Name_Page : constant Name_Id := N + 218; - Name_Passive : constant Name_Id := N + 219; -- GNAT - Name_Preelaborate : constant Name_Id := N + 220; - Name_Priority : constant Name_Id := N + 221; - Name_Psect_Object : constant Name_Id := N + 222; -- VMS - Name_Pure : constant Name_Id := N + 223; - Name_Pure_Function : constant Name_Id := N + 224; -- GNAT - Name_Remote_Call_Interface : constant Name_Id := N + 225; - Name_Remote_Types : constant Name_Id := N + 226; - Name_Share_Generic : constant Name_Id := N + 227; -- GNAT - Name_Shared : constant Name_Id := N + 228; -- Ada 83 - Name_Shared_Passive : constant Name_Id := N + 229; + Name_Assert : constant Name_Id := N + 159; -- GNAT + Name_Asynchronous : constant Name_Id := N + 160; + Name_Atomic : constant Name_Id := N + 161; + Name_Atomic_Components : constant Name_Id := N + 162; + Name_Attach_Handler : constant Name_Id := N + 163; + Name_Comment : constant Name_Id := N + 164; -- GNAT + Name_Common_Object : constant Name_Id := N + 165; -- GNAT + Name_Complex_Representation : constant Name_Id := N + 166; -- GNAT + Name_Controlled : constant Name_Id := N + 167; + Name_Convention : constant Name_Id := N + 168; + Name_CPP_Class : constant Name_Id := N + 169; -- GNAT + Name_CPP_Constructor : constant Name_Id := N + 170; -- GNAT + Name_CPP_Virtual : constant Name_Id := N + 171; -- GNAT + Name_CPP_Vtable : constant Name_Id := N + 172; -- GNAT + Name_Debug : constant Name_Id := N + 173; -- GNAT + Name_Elaborate : constant Name_Id := N + 174; -- Ada 83 + Name_Elaborate_All : constant Name_Id := N + 175; + Name_Elaborate_Body : constant Name_Id := N + 176; + Name_Export : constant Name_Id := N + 177; + Name_Export_Exception : constant Name_Id := N + 178; -- VMS + Name_Export_Function : constant Name_Id := N + 179; -- GNAT + Name_Export_Object : constant Name_Id := N + 180; -- GNAT + Name_Export_Procedure : constant Name_Id := N + 181; -- GNAT + Name_Export_Value : constant Name_Id := N + 182; -- GNAT + Name_Export_Valued_Procedure : constant Name_Id := N + 183; -- GNAT + Name_External : constant Name_Id := N + 184; -- GNAT + Name_Finalize_Storage_Only : constant Name_Id := N + 185; -- GNAT + Name_Ident : constant Name_Id := N + 186; -- VMS + Name_Import : constant Name_Id := N + 187; + Name_Import_Exception : constant Name_Id := N + 188; -- VMS + Name_Import_Function : constant Name_Id := N + 189; -- GNAT + Name_Import_Object : constant Name_Id := N + 190; -- GNAT + Name_Import_Procedure : constant Name_Id := N + 191; -- GNAT + Name_Import_Valued_Procedure : constant Name_Id := N + 192; -- GNAT + Name_Inline : constant Name_Id := N + 193; + Name_Inline_Always : constant Name_Id := N + 194; -- GNAT + Name_Inline_Generic : constant Name_Id := N + 195; -- GNAT + Name_Inspection_Point : constant Name_Id := N + 196; + Name_Interface : constant Name_Id := N + 197; -- Ada 83 + Name_Interface_Name : constant Name_Id := N + 198; -- GNAT + Name_Interrupt_Handler : constant Name_Id := N + 199; + Name_Interrupt_Priority : constant Name_Id := N + 200; + Name_Java_Constructor : constant Name_Id := N + 201; -- GNAT + Name_Java_Interface : constant Name_Id := N + 202; -- GNAT + Name_Keep_Names : constant Name_Id := N + 203; -- GNAT + Name_Link_With : constant Name_Id := N + 204; -- GNAT + Name_Linker_Alias : constant Name_Id := N + 205; -- GNAT + Name_Linker_Options : constant Name_Id := N + 206; + Name_Linker_Section : constant Name_Id := N + 207; -- GNAT + Name_List : constant Name_Id := N + 208; + Name_Machine_Attribute : constant Name_Id := N + 209; -- GNAT + Name_Main : constant Name_Id := N + 210; -- GNAT + Name_Main_Storage : constant Name_Id := N + 211; -- GNAT + Name_Memory_Size : constant Name_Id := N + 212; -- Ada 83 + Name_No_Return : constant Name_Id := N + 213; -- GNAT + Name_Obsolescent : constant Name_Id := N + 214; -- GNAT + Name_Optimize : constant Name_Id := N + 215; + Name_Optional_Overriding : constant Name_Id := N + 216; + Name_Overriding : constant Name_Id := N + 217; + Name_Pack : constant Name_Id := N + 218; + Name_Page : constant Name_Id := N + 219; + Name_Passive : constant Name_Id := N + 220; -- GNAT + Name_Preelaborate : constant Name_Id := N + 221; + Name_Priority : constant Name_Id := N + 222; + Name_Psect_Object : constant Name_Id := N + 223; -- VMS + Name_Pure : constant Name_Id := N + 224; + Name_Pure_Function : constant Name_Id := N + 225; -- GNAT + Name_Remote_Call_Interface : constant Name_Id := N + 226; + Name_Remote_Types : constant Name_Id := N + 227; + Name_Share_Generic : constant Name_Id := N + 228; -- GNAT + Name_Shared : constant Name_Id := N + 229; -- Ada 83 + Name_Shared_Passive : constant Name_Id := N + 230; -- Note: Storage_Size is not in this list because its name matches the -- name of the corresponding attribute. However, it is included in the @@ -459,27 +460,27 @@ package Snames is -- Note: Storage_Unit is also omitted from the list because of a clash -- with an attribute name, and is treated similarly. - Name_Source_Reference : constant Name_Id := N + 230; -- GNAT - Name_Stream_Convert : constant Name_Id := N + 231; -- GNAT - Name_Subtitle : constant Name_Id := N + 232; -- GNAT - Name_Suppress_All : constant Name_Id := N + 233; -- GNAT - Name_Suppress_Debug_Info : constant Name_Id := N + 234; -- GNAT - Name_Suppress_Initialization : constant Name_Id := N + 235; -- GNAT - Name_System_Name : constant Name_Id := N + 236; -- Ada 83 - Name_Task_Info : constant Name_Id := N + 237; -- GNAT - Name_Task_Name : constant Name_Id := N + 238; -- GNAT - Name_Task_Storage : constant Name_Id := N + 239; -- VMS - Name_Thread_Body : constant Name_Id := N + 240; -- GNAT - Name_Time_Slice : constant Name_Id := N + 241; -- GNAT - Name_Title : constant Name_Id := N + 242; -- GNAT - Name_Unchecked_Union : constant Name_Id := N + 243; -- GNAT - Name_Unimplemented_Unit : constant Name_Id := N + 244; -- GNAT - Name_Unreferenced : constant Name_Id := N + 245; -- GNAT - Name_Unreserve_All_Interrupts : constant Name_Id := N + 246; -- GNAT - Name_Volatile : constant Name_Id := N + 247; - Name_Volatile_Components : constant Name_Id := N + 248; - Name_Weak_External : constant Name_Id := N + 249; -- GNAT - Last_Pragma_Name : constant Name_Id := N + 249; + Name_Source_Reference : constant Name_Id := N + 231; -- GNAT + Name_Stream_Convert : constant Name_Id := N + 232; -- GNAT + Name_Subtitle : constant Name_Id := N + 233; -- GNAT + Name_Suppress_All : constant Name_Id := N + 234; -- GNAT + Name_Suppress_Debug_Info : constant Name_Id := N + 235; -- GNAT + Name_Suppress_Initialization : constant Name_Id := N + 236; -- GNAT + Name_System_Name : constant Name_Id := N + 237; -- Ada 83 + Name_Task_Info : constant Name_Id := N + 238; -- GNAT + Name_Task_Name : constant Name_Id := N + 239; -- GNAT + Name_Task_Storage : constant Name_Id := N + 240; -- VMS + Name_Thread_Body : constant Name_Id := N + 241; -- GNAT + Name_Time_Slice : constant Name_Id := N + 242; -- GNAT + Name_Title : constant Name_Id := N + 243; -- GNAT + Name_Unchecked_Union : constant Name_Id := N + 244; -- GNAT + Name_Unimplemented_Unit : constant Name_Id := N + 245; -- GNAT + Name_Unreferenced : constant Name_Id := N + 246; -- GNAT + Name_Unreserve_All_Interrupts : constant Name_Id := N + 247; -- GNAT + Name_Volatile : constant Name_Id := N + 248; + Name_Volatile_Components : constant Name_Id := N + 249; + Name_Weak_External : constant Name_Id := N + 250; -- GNAT + Last_Pragma_Name : constant Name_Id := N + 250; -- Language convention names for pragma Convention/Export/Import/Interface -- Note that Name_C is not included in this list, since it was already @@ -490,105 +491,105 @@ package Snames is -- Entry and Protected, this is because these conventions cannot be -- specified by a pragma. - First_Convention_Name : constant Name_Id := N + 250; - Name_Ada : constant Name_Id := N + 250; - Name_Assembler : constant Name_Id := N + 251; - Name_COBOL : constant Name_Id := N + 252; - Name_CPP : constant Name_Id := N + 253; - Name_Fortran : constant Name_Id := N + 254; - Name_Intrinsic : constant Name_Id := N + 255; - Name_Java : constant Name_Id := N + 256; - Name_Stdcall : constant Name_Id := N + 257; - Name_Stubbed : constant Name_Id := N + 258; - Last_Convention_Name : constant Name_Id := N + 258; + First_Convention_Name : constant Name_Id := N + 251; + Name_Ada : constant Name_Id := N + 251; + Name_Assembler : constant Name_Id := N + 252; + Name_COBOL : constant Name_Id := N + 253; + Name_CPP : constant Name_Id := N + 254; + Name_Fortran : constant Name_Id := N + 255; + Name_Intrinsic : constant Name_Id := N + 256; + Name_Java : constant Name_Id := N + 257; + Name_Stdcall : constant Name_Id := N + 258; + Name_Stubbed : constant Name_Id := N + 259; + Last_Convention_Name : constant Name_Id := N + 259; -- The following names are preset as synonyms for Assembler - Name_Asm : constant Name_Id := N + 259; - Name_Assembly : constant Name_Id := N + 260; + Name_Asm : constant Name_Id := N + 260; + Name_Assembly : constant Name_Id := N + 261; -- The following names are preset as synonyms for C - Name_Default : constant Name_Id := N + 261; + Name_Default : constant Name_Id := N + 262; -- Name_Exernal (previously defined as pragma) -- The following names are present as synonyms for Stdcall - Name_DLL : constant Name_Id := N + 262; - Name_Win32 : constant Name_Id := N + 263; + Name_DLL : constant Name_Id := N + 263; + Name_Win32 : constant Name_Id := N + 264; -- Other special names used in processing pragmas - Name_As_Is : constant Name_Id := N + 264; - Name_Body_File_Name : constant Name_Id := N + 265; - Name_Boolean_Entry_Barriers : constant Name_Id := N + 266; - Name_Casing : constant Name_Id := N + 267; - Name_Code : constant Name_Id := N + 268; - Name_Component : constant Name_Id := N + 269; - Name_Component_Size_4 : constant Name_Id := N + 270; - Name_Copy : constant Name_Id := N + 271; - Name_D_Float : constant Name_Id := N + 272; - Name_Descriptor : constant Name_Id := N + 273; - Name_Dot_Replacement : constant Name_Id := N + 274; - Name_Dynamic : constant Name_Id := N + 275; - Name_Entity : constant Name_Id := N + 276; - Name_External_Name : constant Name_Id := N + 277; - Name_First_Optional_Parameter : constant Name_Id := N + 278; - Name_Form : constant Name_Id := N + 279; - Name_G_Float : constant Name_Id := N + 280; - Name_Gcc : constant Name_Id := N + 281; - Name_Gnat : constant Name_Id := N + 282; - Name_GPL : constant Name_Id := N + 283; - Name_IEEE_Float : constant Name_Id := N + 284; - Name_Internal : constant Name_Id := N + 285; - Name_Link_Name : constant Name_Id := N + 286; - Name_Lowercase : constant Name_Id := N + 287; - Name_Max_Entry_Queue_Depth : constant Name_Id := N + 288; - Name_Max_Entry_Queue_Length : constant Name_Id := N + 289; - Name_Max_Size : constant Name_Id := N + 290; - Name_Mechanism : constant Name_Id := N + 291; - Name_Mixedcase : constant Name_Id := N + 292; - Name_Modified_GPL : constant Name_Id := N + 293; - Name_Name : constant Name_Id := N + 294; - Name_NCA : constant Name_Id := N + 295; - Name_No : constant Name_Id := N + 296; - Name_On : constant Name_Id := N + 297; - Name_Parameter_Types : constant Name_Id := N + 298; - Name_Reference : constant Name_Id := N + 299; - Name_No_Dynamic_Attachment : constant Name_Id := N + 300; - Name_No_Dynamic_Interrupts : constant Name_Id := N + 301; - Name_No_Requeue : constant Name_Id := N + 302; - Name_No_Requeue_Statements : constant Name_Id := N + 303; - Name_No_Task_Attributes : constant Name_Id := N + 304; - Name_No_Task_Attributes_Package : constant Name_Id := N + 305; - Name_Restricted : constant Name_Id := N + 306; - Name_Result_Mechanism : constant Name_Id := N + 307; - Name_Result_Type : constant Name_Id := N + 308; - Name_Runtime : constant Name_Id := N + 309; - Name_SB : constant Name_Id := N + 310; - Name_Secondary_Stack_Size : constant Name_Id := N + 311; - Name_Section : constant Name_Id := N + 312; - Name_Semaphore : constant Name_Id := N + 313; - Name_Simple_Barriers : constant Name_Id := N + 314; - Name_Spec_File_Name : constant Name_Id := N + 315; - Name_Static : constant Name_Id := N + 316; - Name_Stack_Size : constant Name_Id := N + 317; - Name_Subunit_File_Name : constant Name_Id := N + 318; - Name_Task_Stack_Size_Default : constant Name_Id := N + 319; - Name_Task_Type : constant Name_Id := N + 320; - Name_Time_Slicing_Enabled : constant Name_Id := N + 321; - Name_Top_Guard : constant Name_Id := N + 322; - Name_UBA : constant Name_Id := N + 323; - Name_UBS : constant Name_Id := N + 324; - Name_UBSB : constant Name_Id := N + 325; - Name_Unit_Name : constant Name_Id := N + 326; - Name_Unknown : constant Name_Id := N + 327; - Name_Unrestricted : constant Name_Id := N + 328; - Name_Uppercase : constant Name_Id := N + 329; - Name_User : constant Name_Id := N + 330; - Name_VAX_Float : constant Name_Id := N + 331; - Name_VMS : constant Name_Id := N + 332; - Name_Working_Storage : constant Name_Id := N + 333; + Name_As_Is : constant Name_Id := N + 265; + Name_Body_File_Name : constant Name_Id := N + 266; + Name_Boolean_Entry_Barriers : constant Name_Id := N + 267; + Name_Casing : constant Name_Id := N + 268; + Name_Code : constant Name_Id := N + 269; + Name_Component : constant Name_Id := N + 270; + Name_Component_Size_4 : constant Name_Id := N + 271; + Name_Copy : constant Name_Id := N + 272; + Name_D_Float : constant Name_Id := N + 273; + Name_Descriptor : constant Name_Id := N + 274; + Name_Dot_Replacement : constant Name_Id := N + 275; + Name_Dynamic : constant Name_Id := N + 276; + Name_Entity : constant Name_Id := N + 277; + Name_External_Name : constant Name_Id := N + 278; + Name_First_Optional_Parameter : constant Name_Id := N + 279; + Name_Form : constant Name_Id := N + 280; + Name_G_Float : constant Name_Id := N + 281; + Name_Gcc : constant Name_Id := N + 282; + Name_Gnat : constant Name_Id := N + 283; + Name_GPL : constant Name_Id := N + 284; + Name_IEEE_Float : constant Name_Id := N + 285; + Name_Internal : constant Name_Id := N + 286; + Name_Link_Name : constant Name_Id := N + 287; + Name_Lowercase : constant Name_Id := N + 288; + Name_Max_Entry_Queue_Depth : constant Name_Id := N + 289; + Name_Max_Entry_Queue_Length : constant Name_Id := N + 290; + Name_Max_Size : constant Name_Id := N + 291; + Name_Mechanism : constant Name_Id := N + 292; + Name_Mixedcase : constant Name_Id := N + 293; + Name_Modified_GPL : constant Name_Id := N + 294; + Name_Name : constant Name_Id := N + 295; + Name_NCA : constant Name_Id := N + 296; + Name_No : constant Name_Id := N + 297; + Name_On : constant Name_Id := N + 298; + Name_Parameter_Types : constant Name_Id := N + 299; + Name_Reference : constant Name_Id := N + 300; + Name_No_Dynamic_Attachment : constant Name_Id := N + 301; + Name_No_Dynamic_Interrupts : constant Name_Id := N + 302; + Name_No_Requeue : constant Name_Id := N + 303; + Name_No_Requeue_Statements : constant Name_Id := N + 304; + Name_No_Task_Attributes : constant Name_Id := N + 305; + Name_No_Task_Attributes_Package : constant Name_Id := N + 306; + Name_Restricted : constant Name_Id := N + 307; + Name_Result_Mechanism : constant Name_Id := N + 308; + Name_Result_Type : constant Name_Id := N + 309; + Name_Runtime : constant Name_Id := N + 310; + Name_SB : constant Name_Id := N + 311; + Name_Secondary_Stack_Size : constant Name_Id := N + 312; + Name_Section : constant Name_Id := N + 313; + Name_Semaphore : constant Name_Id := N + 314; + Name_Simple_Barriers : constant Name_Id := N + 315; + Name_Spec_File_Name : constant Name_Id := N + 316; + Name_Static : constant Name_Id := N + 317; + Name_Stack_Size : constant Name_Id := N + 318; + Name_Subunit_File_Name : constant Name_Id := N + 319; + Name_Task_Stack_Size_Default : constant Name_Id := N + 320; + Name_Task_Type : constant Name_Id := N + 321; + Name_Time_Slicing_Enabled : constant Name_Id := N + 322; + Name_Top_Guard : constant Name_Id := N + 323; + Name_UBA : constant Name_Id := N + 324; + Name_UBS : constant Name_Id := N + 325; + Name_UBSB : constant Name_Id := N + 326; + Name_Unit_Name : constant Name_Id := N + 327; + Name_Unknown : constant Name_Id := N + 328; + Name_Unrestricted : constant Name_Id := N + 329; + Name_Uppercase : constant Name_Id := N + 330; + Name_User : constant Name_Id := N + 331; + Name_VAX_Float : constant Name_Id := N + 332; + Name_VMS : constant Name_Id := N + 333; + Name_Working_Storage : constant Name_Id := N + 334; -- Names of recognized attributes. The entries with the comment "Ada 83" -- are attributes that are defined in Ada 83, but not in Ada 95. These @@ -602,159 +603,159 @@ package Snames is -- The entries marked VMS are recognized only in OpenVMS implementations -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + 334; - Name_Abort_Signal : constant Name_Id := N + 334; -- GNAT - Name_Access : constant Name_Id := N + 335; - Name_Address : constant Name_Id := N + 336; - Name_Address_Size : constant Name_Id := N + 337; -- GNAT - Name_Aft : constant Name_Id := N + 338; - Name_Alignment : constant Name_Id := N + 339; - Name_Asm_Input : constant Name_Id := N + 340; -- GNAT - Name_Asm_Output : constant Name_Id := N + 341; -- GNAT - Name_AST_Entry : constant Name_Id := N + 342; -- VMS - Name_Bit : constant Name_Id := N + 343; -- GNAT - Name_Bit_Order : constant Name_Id := N + 344; - Name_Bit_Position : constant Name_Id := N + 345; -- GNAT - Name_Body_Version : constant Name_Id := N + 346; - Name_Callable : constant Name_Id := N + 347; - Name_Caller : constant Name_Id := N + 348; - Name_Code_Address : constant Name_Id := N + 349; -- GNAT - Name_Component_Size : constant Name_Id := N + 350; - Name_Compose : constant Name_Id := N + 351; - Name_Constrained : constant Name_Id := N + 352; - Name_Count : constant Name_Id := N + 353; - Name_Default_Bit_Order : constant Name_Id := N + 354; -- GNAT - Name_Definite : constant Name_Id := N + 355; - Name_Delta : constant Name_Id := N + 356; - Name_Denorm : constant Name_Id := N + 357; - Name_Digits : constant Name_Id := N + 358; - Name_Elaborated : constant Name_Id := N + 359; -- GNAT - Name_Emax : constant Name_Id := N + 360; -- Ada 83 - Name_Enum_Rep : constant Name_Id := N + 361; -- GNAT - Name_Epsilon : constant Name_Id := N + 362; -- Ada 83 - Name_Exponent : constant Name_Id := N + 363; - Name_External_Tag : constant Name_Id := N + 364; - Name_First : constant Name_Id := N + 365; - Name_First_Bit : constant Name_Id := N + 366; - Name_Fixed_Value : constant Name_Id := N + 367; -- GNAT - Name_Fore : constant Name_Id := N + 368; - Name_Has_Access_Values : constant Name_Id := N + 369; -- GNAT - Name_Has_Discriminants : constant Name_Id := N + 370; -- GNAT - Name_Identity : constant Name_Id := N + 371; - Name_Img : constant Name_Id := N + 372; -- GNAT - Name_Integer_Value : constant Name_Id := N + 373; -- GNAT - Name_Large : constant Name_Id := N + 374; -- Ada 83 - Name_Last : constant Name_Id := N + 375; - Name_Last_Bit : constant Name_Id := N + 376; - Name_Leading_Part : constant Name_Id := N + 377; - Name_Length : constant Name_Id := N + 378; - Name_Machine_Emax : constant Name_Id := N + 379; - Name_Machine_Emin : constant Name_Id := N + 380; - Name_Machine_Mantissa : constant Name_Id := N + 381; - Name_Machine_Overflows : constant Name_Id := N + 382; - Name_Machine_Radix : constant Name_Id := N + 383; - Name_Machine_Rounds : constant Name_Id := N + 384; - Name_Machine_Size : constant Name_Id := N + 385; -- GNAT - Name_Mantissa : constant Name_Id := N + 386; -- Ada 83 - Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 387; - Name_Maximum_Alignment : constant Name_Id := N + 388; -- GNAT - Name_Mechanism_Code : constant Name_Id := N + 389; -- GNAT - Name_Model_Emin : constant Name_Id := N + 390; - Name_Model_Epsilon : constant Name_Id := N + 391; - Name_Model_Mantissa : constant Name_Id := N + 392; - Name_Model_Small : constant Name_Id := N + 393; - Name_Modulus : constant Name_Id := N + 394; - Name_Null_Parameter : constant Name_Id := N + 395; -- GNAT - Name_Object_Size : constant Name_Id := N + 396; -- GNAT - Name_Partition_ID : constant Name_Id := N + 397; - Name_Passed_By_Reference : constant Name_Id := N + 398; -- GNAT - Name_Pool_Address : constant Name_Id := N + 399; - Name_Pos : constant Name_Id := N + 400; - Name_Position : constant Name_Id := N + 401; - Name_Range : constant Name_Id := N + 402; - Name_Range_Length : constant Name_Id := N + 403; -- GNAT - Name_Round : constant Name_Id := N + 404; - Name_Safe_Emax : constant Name_Id := N + 405; -- Ada 83 - Name_Safe_First : constant Name_Id := N + 406; - Name_Safe_Large : constant Name_Id := N + 407; -- Ada 83 - Name_Safe_Last : constant Name_Id := N + 408; - Name_Safe_Small : constant Name_Id := N + 409; -- Ada 83 - Name_Scale : constant Name_Id := N + 410; - Name_Scaling : constant Name_Id := N + 411; - Name_Signed_Zeros : constant Name_Id := N + 412; - Name_Size : constant Name_Id := N + 413; - Name_Small : constant Name_Id := N + 414; - Name_Storage_Size : constant Name_Id := N + 415; - Name_Storage_Unit : constant Name_Id := N + 416; -- GNAT - Name_Tag : constant Name_Id := N + 417; - Name_Target_Name : constant Name_Id := N + 418; -- GNAT - Name_Terminated : constant Name_Id := N + 419; - Name_To_Address : constant Name_Id := N + 420; -- GNAT - Name_Type_Class : constant Name_Id := N + 421; -- GNAT - Name_UET_Address : constant Name_Id := N + 422; -- GNAT - Name_Unbiased_Rounding : constant Name_Id := N + 423; - Name_Unchecked_Access : constant Name_Id := N + 424; - Name_Unconstrained_Array : constant Name_Id := N + 425; - Name_Universal_Literal_String : constant Name_Id := N + 426; -- GNAT - Name_Unrestricted_Access : constant Name_Id := N + 427; -- GNAT - Name_VADS_Size : constant Name_Id := N + 428; -- GNAT - Name_Val : constant Name_Id := N + 429; - Name_Valid : constant Name_Id := N + 430; - Name_Value_Size : constant Name_Id := N + 431; -- GNAT - Name_Version : constant Name_Id := N + 432; - Name_Wchar_T_Size : constant Name_Id := N + 433; -- GNAT - Name_Wide_Width : constant Name_Id := N + 434; - Name_Width : constant Name_Id := N + 435; - Name_Word_Size : constant Name_Id := N + 436; -- GNAT + First_Attribute_Name : constant Name_Id := N + 335; + Name_Abort_Signal : constant Name_Id := N + 335; -- GNAT + Name_Access : constant Name_Id := N + 336; + Name_Address : constant Name_Id := N + 337; + Name_Address_Size : constant Name_Id := N + 338; -- GNAT + Name_Aft : constant Name_Id := N + 339; + Name_Alignment : constant Name_Id := N + 340; + Name_Asm_Input : constant Name_Id := N + 341; -- GNAT + Name_Asm_Output : constant Name_Id := N + 342; -- GNAT + Name_AST_Entry : constant Name_Id := N + 343; -- VMS + Name_Bit : constant Name_Id := N + 344; -- GNAT + Name_Bit_Order : constant Name_Id := N + 345; + Name_Bit_Position : constant Name_Id := N + 346; -- GNAT + Name_Body_Version : constant Name_Id := N + 347; + Name_Callable : constant Name_Id := N + 348; + Name_Caller : constant Name_Id := N + 349; + Name_Code_Address : constant Name_Id := N + 350; -- GNAT + Name_Component_Size : constant Name_Id := N + 351; + Name_Compose : constant Name_Id := N + 352; + Name_Constrained : constant Name_Id := N + 353; + Name_Count : constant Name_Id := N + 354; + Name_Default_Bit_Order : constant Name_Id := N + 355; -- GNAT + Name_Definite : constant Name_Id := N + 356; + Name_Delta : constant Name_Id := N + 357; + Name_Denorm : constant Name_Id := N + 358; + Name_Digits : constant Name_Id := N + 359; + Name_Elaborated : constant Name_Id := N + 360; -- GNAT + Name_Emax : constant Name_Id := N + 361; -- Ada 83 + Name_Enum_Rep : constant Name_Id := N + 362; -- GNAT + Name_Epsilon : constant Name_Id := N + 363; -- Ada 83 + Name_Exponent : constant Name_Id := N + 364; + Name_External_Tag : constant Name_Id := N + 365; + Name_First : constant Name_Id := N + 366; + Name_First_Bit : constant Name_Id := N + 367; + Name_Fixed_Value : constant Name_Id := N + 368; -- GNAT + Name_Fore : constant Name_Id := N + 369; + Name_Has_Access_Values : constant Name_Id := N + 370; -- GNAT + Name_Has_Discriminants : constant Name_Id := N + 371; -- GNAT + Name_Identity : constant Name_Id := N + 372; + Name_Img : constant Name_Id := N + 373; -- GNAT + Name_Integer_Value : constant Name_Id := N + 374; -- GNAT + Name_Large : constant Name_Id := N + 375; -- Ada 83 + Name_Last : constant Name_Id := N + 376; + Name_Last_Bit : constant Name_Id := N + 377; + Name_Leading_Part : constant Name_Id := N + 378; + Name_Length : constant Name_Id := N + 379; + Name_Machine_Emax : constant Name_Id := N + 380; + Name_Machine_Emin : constant Name_Id := N + 381; + Name_Machine_Mantissa : constant Name_Id := N + 382; + Name_Machine_Overflows : constant Name_Id := N + 383; + Name_Machine_Radix : constant Name_Id := N + 384; + Name_Machine_Rounds : constant Name_Id := N + 385; + Name_Machine_Size : constant Name_Id := N + 386; -- GNAT + Name_Mantissa : constant Name_Id := N + 387; -- Ada 83 + Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 388; + Name_Maximum_Alignment : constant Name_Id := N + 389; -- GNAT + Name_Mechanism_Code : constant Name_Id := N + 390; -- GNAT + Name_Model_Emin : constant Name_Id := N + 391; + Name_Model_Epsilon : constant Name_Id := N + 392; + Name_Model_Mantissa : constant Name_Id := N + 393; + Name_Model_Small : constant Name_Id := N + 394; + Name_Modulus : constant Name_Id := N + 395; + Name_Null_Parameter : constant Name_Id := N + 396; -- GNAT + Name_Object_Size : constant Name_Id := N + 397; -- GNAT + Name_Partition_ID : constant Name_Id := N + 398; + Name_Passed_By_Reference : constant Name_Id := N + 399; -- GNAT + Name_Pool_Address : constant Name_Id := N + 400; + Name_Pos : constant Name_Id := N + 401; + Name_Position : constant Name_Id := N + 402; + Name_Range : constant Name_Id := N + 403; + Name_Range_Length : constant Name_Id := N + 404; -- GNAT + Name_Round : constant Name_Id := N + 405; + Name_Safe_Emax : constant Name_Id := N + 406; -- Ada 83 + Name_Safe_First : constant Name_Id := N + 407; + Name_Safe_Large : constant Name_Id := N + 408; -- Ada 83 + Name_Safe_Last : constant Name_Id := N + 409; + Name_Safe_Small : constant Name_Id := N + 410; -- Ada 83 + Name_Scale : constant Name_Id := N + 411; + Name_Scaling : constant Name_Id := N + 412; + Name_Signed_Zeros : constant Name_Id := N + 413; + Name_Size : constant Name_Id := N + 414; + Name_Small : constant Name_Id := N + 415; + Name_Storage_Size : constant Name_Id := N + 416; + Name_Storage_Unit : constant Name_Id := N + 417; -- GNAT + Name_Tag : constant Name_Id := N + 418; + Name_Target_Name : constant Name_Id := N + 419; -- GNAT + Name_Terminated : constant Name_Id := N + 420; + Name_To_Address : constant Name_Id := N + 421; -- GNAT + Name_Type_Class : constant Name_Id := N + 422; -- GNAT + Name_UET_Address : constant Name_Id := N + 423; -- GNAT + Name_Unbiased_Rounding : constant Name_Id := N + 424; + Name_Unchecked_Access : constant Name_Id := N + 425; + Name_Unconstrained_Array : constant Name_Id := N + 426; + Name_Universal_Literal_String : constant Name_Id := N + 427; -- GNAT + Name_Unrestricted_Access : constant Name_Id := N + 428; -- GNAT + Name_VADS_Size : constant Name_Id := N + 429; -- GNAT + Name_Val : constant Name_Id := N + 430; + Name_Valid : constant Name_Id := N + 431; + Name_Value_Size : constant Name_Id := N + 432; -- GNAT + Name_Version : constant Name_Id := N + 433; + Name_Wchar_T_Size : constant Name_Id := N + 434; -- GNAT + Name_Wide_Width : constant Name_Id := N + 435; + Name_Width : constant Name_Id := N + 436; + Name_Word_Size : constant Name_Id := N + 437; -- GNAT -- Attributes that designate attributes returning renamable functions, -- i.e. functions that return other than a universal value. - First_Renamable_Function_Attribute : constant Name_Id := N + 437; - Name_Adjacent : constant Name_Id := N + 437; - Name_Ceiling : constant Name_Id := N + 438; - Name_Copy_Sign : constant Name_Id := N + 439; - Name_Floor : constant Name_Id := N + 440; - Name_Fraction : constant Name_Id := N + 441; - Name_Image : constant Name_Id := N + 442; - Name_Input : constant Name_Id := N + 443; - Name_Machine : constant Name_Id := N + 444; - Name_Max : constant Name_Id := N + 445; - Name_Min : constant Name_Id := N + 446; - Name_Model : constant Name_Id := N + 447; - Name_Pred : constant Name_Id := N + 448; - Name_Remainder : constant Name_Id := N + 449; - Name_Rounding : constant Name_Id := N + 450; - Name_Succ : constant Name_Id := N + 451; - Name_Truncation : constant Name_Id := N + 452; - Name_Value : constant Name_Id := N + 453; - Name_Wide_Image : constant Name_Id := N + 454; - Name_Wide_Value : constant Name_Id := N + 455; - Last_Renamable_Function_Attribute : constant Name_Id := N + 455; + First_Renamable_Function_Attribute : constant Name_Id := N + 438; + Name_Adjacent : constant Name_Id := N + 438; + Name_Ceiling : constant Name_Id := N + 439; + Name_Copy_Sign : constant Name_Id := N + 440; + Name_Floor : constant Name_Id := N + 441; + Name_Fraction : constant Name_Id := N + 442; + Name_Image : constant Name_Id := N + 443; + Name_Input : constant Name_Id := N + 444; + Name_Machine : constant Name_Id := N + 445; + Name_Max : constant Name_Id := N + 446; + Name_Min : constant Name_Id := N + 447; + Name_Model : constant Name_Id := N + 448; + Name_Pred : constant Name_Id := N + 449; + Name_Remainder : constant Name_Id := N + 450; + Name_Rounding : constant Name_Id := N + 451; + Name_Succ : constant Name_Id := N + 452; + Name_Truncation : constant Name_Id := N + 453; + Name_Value : constant Name_Id := N + 454; + Name_Wide_Image : constant Name_Id := N + 455; + Name_Wide_Value : constant Name_Id := N + 456; + Last_Renamable_Function_Attribute : constant Name_Id := N + 456; -- Attributes that designate procedures - First_Procedure_Attribute : constant Name_Id := N + 456; - Name_Output : constant Name_Id := N + 456; - Name_Read : constant Name_Id := N + 457; - Name_Write : constant Name_Id := N + 458; - Last_Procedure_Attribute : constant Name_Id := N + 458; + First_Procedure_Attribute : constant Name_Id := N + 457; + Name_Output : constant Name_Id := N + 457; + Name_Read : constant Name_Id := N + 458; + Name_Write : constant Name_Id := N + 459; + Last_Procedure_Attribute : constant Name_Id := N + 459; -- Remaining attributes are ones that return entities - First_Entity_Attribute_Name : constant Name_Id := N + 459; - Name_Elab_Body : constant Name_Id := N + 459; -- GNAT - Name_Elab_Spec : constant Name_Id := N + 460; -- GNAT - Name_Storage_Pool : constant Name_Id := N + 461; + First_Entity_Attribute_Name : constant Name_Id := N + 460; + Name_Elab_Body : constant Name_Id := N + 460; -- GNAT + Name_Elab_Spec : constant Name_Id := N + 461; -- GNAT + Name_Storage_Pool : constant Name_Id := N + 462; -- These attributes are the ones that return types - First_Type_Attribute_Name : constant Name_Id := N + 462; - Name_Base : constant Name_Id := N + 462; - Name_Class : constant Name_Id := N + 463; - Last_Type_Attribute_Name : constant Name_Id := N + 463; - Last_Entity_Attribute_Name : constant Name_Id := N + 463; - Last_Attribute_Name : constant Name_Id := N + 463; + First_Type_Attribute_Name : constant Name_Id := N + 463; + Name_Base : constant Name_Id := N + 463; + Name_Class : constant Name_Id := N + 464; + Last_Type_Attribute_Name : constant Name_Id := N + 464; + Last_Entity_Attribute_Name : constant Name_Id := N + 464; + Last_Attribute_Name : constant Name_Id := N + 464; -- Names of recognized locking policy identifiers @@ -762,10 +763,10 @@ package Snames is -- name (e.g. C for Ceiling_Locking). If new policy names are added, -- the first character must be distinct. - First_Locking_Policy_Name : constant Name_Id := N + 464; - Name_Ceiling_Locking : constant Name_Id := N + 464; - Name_Inheritance_Locking : constant Name_Id := N + 465; - Last_Locking_Policy_Name : constant Name_Id := N + 465; + First_Locking_Policy_Name : constant Name_Id := N + 465; + Name_Ceiling_Locking : constant Name_Id := N + 465; + Name_Inheritance_Locking : constant Name_Id := N + 466; + Last_Locking_Policy_Name : constant Name_Id := N + 466; -- Names of recognized queuing policy identifiers. @@ -773,10 +774,10 @@ package Snames is -- name (e.g. F for FIFO_Queuing). If new policy names are added, -- the first character must be distinct. - First_Queuing_Policy_Name : constant Name_Id := N + 466; - Name_FIFO_Queuing : constant Name_Id := N + 466; - Name_Priority_Queuing : constant Name_Id := N + 467; - Last_Queuing_Policy_Name : constant Name_Id := N + 467; + First_Queuing_Policy_Name : constant Name_Id := N + 467; + Name_FIFO_Queuing : constant Name_Id := N + 467; + Name_Priority_Queuing : constant Name_Id := N + 468; + Last_Queuing_Policy_Name : constant Name_Id := N + 468; -- Names of recognized task dispatching policy identifiers @@ -784,194 +785,194 @@ package Snames is -- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names -- are added, the first character must be distinct. - First_Task_Dispatching_Policy_Name : constant Name_Id := N + 468; - Name_FIFO_Within_Priorities : constant Name_Id := N + 468; - Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 468; + First_Task_Dispatching_Policy_Name : constant Name_Id := N + 469; + Name_FIFO_Within_Priorities : constant Name_Id := N + 469; + Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 469; -- Names of recognized checks for pragma Suppress - First_Check_Name : constant Name_Id := N + 469; - Name_Access_Check : constant Name_Id := N + 469; - Name_Accessibility_Check : constant Name_Id := N + 470; - Name_Discriminant_Check : constant Name_Id := N + 471; - Name_Division_Check : constant Name_Id := N + 472; - Name_Elaboration_Check : constant Name_Id := N + 473; - Name_Index_Check : constant Name_Id := N + 474; - Name_Length_Check : constant Name_Id := N + 475; - Name_Overflow_Check : constant Name_Id := N + 476; - Name_Range_Check : constant Name_Id := N + 477; - Name_Storage_Check : constant Name_Id := N + 478; - Name_Tag_Check : constant Name_Id := N + 479; - Name_All_Checks : constant Name_Id := N + 480; - Last_Check_Name : constant Name_Id := N + 480; + First_Check_Name : constant Name_Id := N + 470; + Name_Access_Check : constant Name_Id := N + 470; + Name_Accessibility_Check : constant Name_Id := N + 471; + Name_Discriminant_Check : constant Name_Id := N + 472; + Name_Division_Check : constant Name_Id := N + 473; + Name_Elaboration_Check : constant Name_Id := N + 474; + Name_Index_Check : constant Name_Id := N + 475; + Name_Length_Check : constant Name_Id := N + 476; + Name_Overflow_Check : constant Name_Id := N + 477; + Name_Range_Check : constant Name_Id := N + 478; + Name_Storage_Check : constant Name_Id := N + 479; + Name_Tag_Check : constant Name_Id := N + 480; + Name_All_Checks : constant Name_Id := N + 481; + Last_Check_Name : constant Name_Id := N + 481; -- Names corresponding to reserved keywords, excluding those already -- declared in the attribute list (Access, Delta, Digits, Range). - Name_Abort : constant Name_Id := N + 481; - Name_Abs : constant Name_Id := N + 482; - Name_Accept : constant Name_Id := N + 483; - Name_And : constant Name_Id := N + 484; - Name_All : constant Name_Id := N + 485; - Name_Array : constant Name_Id := N + 486; - Name_At : constant Name_Id := N + 487; - Name_Begin : constant Name_Id := N + 488; - Name_Body : constant Name_Id := N + 489; - Name_Case : constant Name_Id := N + 490; - Name_Constant : constant Name_Id := N + 491; - Name_Declare : constant Name_Id := N + 492; - Name_Delay : constant Name_Id := N + 493; - Name_Do : constant Name_Id := N + 494; - Name_Else : constant Name_Id := N + 495; - Name_Elsif : constant Name_Id := N + 496; - Name_End : constant Name_Id := N + 497; - Name_Entry : constant Name_Id := N + 498; - Name_Exception : constant Name_Id := N + 499; - Name_Exit : constant Name_Id := N + 500; - Name_For : constant Name_Id := N + 501; - Name_Function : constant Name_Id := N + 502; - Name_Generic : constant Name_Id := N + 503; - Name_Goto : constant Name_Id := N + 504; - Name_If : constant Name_Id := N + 505; - Name_In : constant Name_Id := N + 506; - Name_Is : constant Name_Id := N + 507; - Name_Limited : constant Name_Id := N + 508; - Name_Loop : constant Name_Id := N + 509; - Name_Mod : constant Name_Id := N + 510; - Name_New : constant Name_Id := N + 511; - Name_Not : constant Name_Id := N + 512; - Name_Null : constant Name_Id := N + 513; - Name_Of : constant Name_Id := N + 514; - Name_Or : constant Name_Id := N + 515; - Name_Others : constant Name_Id := N + 516; - Name_Out : constant Name_Id := N + 517; - Name_Package : constant Name_Id := N + 518; - Name_Pragma : constant Name_Id := N + 519; - Name_Private : constant Name_Id := N + 520; - Name_Procedure : constant Name_Id := N + 521; - Name_Raise : constant Name_Id := N + 522; - Name_Record : constant Name_Id := N + 523; - Name_Rem : constant Name_Id := N + 524; - Name_Renames : constant Name_Id := N + 525; - Name_Return : constant Name_Id := N + 526; - Name_Reverse : constant Name_Id := N + 527; - Name_Select : constant Name_Id := N + 528; - Name_Separate : constant Name_Id := N + 529; - Name_Subtype : constant Name_Id := N + 530; - Name_Task : constant Name_Id := N + 531; - Name_Terminate : constant Name_Id := N + 532; - Name_Then : constant Name_Id := N + 533; - Name_Type : constant Name_Id := N + 534; - Name_Use : constant Name_Id := N + 535; - Name_When : constant Name_Id := N + 536; - Name_While : constant Name_Id := N + 537; - Name_With : constant Name_Id := N + 538; - Name_Xor : constant Name_Id := N + 539; + Name_Abort : constant Name_Id := N + 482; + Name_Abs : constant Name_Id := N + 483; + Name_Accept : constant Name_Id := N + 484; + Name_And : constant Name_Id := N + 485; + Name_All : constant Name_Id := N + 486; + Name_Array : constant Name_Id := N + 487; + Name_At : constant Name_Id := N + 488; + Name_Begin : constant Name_Id := N + 489; + Name_Body : constant Name_Id := N + 490; + Name_Case : constant Name_Id := N + 491; + Name_Constant : constant Name_Id := N + 492; + Name_Declare : constant Name_Id := N + 493; + Name_Delay : constant Name_Id := N + 494; + Name_Do : constant Name_Id := N + 495; + Name_Else : constant Name_Id := N + 496; + Name_Elsif : constant Name_Id := N + 497; + Name_End : constant Name_Id := N + 498; + Name_Entry : constant Name_Id := N + 499; + Name_Exception : constant Name_Id := N + 500; + Name_Exit : constant Name_Id := N + 501; + Name_For : constant Name_Id := N + 502; + Name_Function : constant Name_Id := N + 503; + Name_Generic : constant Name_Id := N + 504; + Name_Goto : constant Name_Id := N + 505; + Name_If : constant Name_Id := N + 506; + Name_In : constant Name_Id := N + 507; + Name_Is : constant Name_Id := N + 508; + Name_Limited : constant Name_Id := N + 509; + Name_Loop : constant Name_Id := N + 510; + Name_Mod : constant Name_Id := N + 511; + Name_New : constant Name_Id := N + 512; + Name_Not : constant Name_Id := N + 513; + Name_Null : constant Name_Id := N + 514; + Name_Of : constant Name_Id := N + 515; + Name_Or : constant Name_Id := N + 516; + Name_Others : constant Name_Id := N + 517; + Name_Out : constant Name_Id := N + 518; + Name_Package : constant Name_Id := N + 519; + Name_Pragma : constant Name_Id := N + 520; + Name_Private : constant Name_Id := N + 521; + Name_Procedure : constant Name_Id := N + 522; + Name_Raise : constant Name_Id := N + 523; + Name_Record : constant Name_Id := N + 524; + Name_Rem : constant Name_Id := N + 525; + Name_Renames : constant Name_Id := N + 526; + Name_Return : constant Name_Id := N + 527; + Name_Reverse : constant Name_Id := N + 528; + Name_Select : constant Name_Id := N + 529; + Name_Separate : constant Name_Id := N + 530; + Name_Subtype : constant Name_Id := N + 531; + Name_Task : constant Name_Id := N + 532; + Name_Terminate : constant Name_Id := N + 533; + Name_Then : constant Name_Id := N + 534; + Name_Type : constant Name_Id := N + 535; + Name_Use : constant Name_Id := N + 536; + Name_When : constant Name_Id := N + 537; + Name_While : constant Name_Id := N + 538; + Name_With : constant Name_Id := N + 539; + Name_Xor : constant Name_Id := N + 540; -- Names of intrinsic subprograms -- Note: Asm is missing from this list, since Asm is a legitimate -- convention name. So is To_Adress, which is a GNAT attribute. - First_Intrinsic_Name : constant Name_Id := N + 540; - Name_Divide : constant Name_Id := N + 540; - Name_Enclosing_Entity : constant Name_Id := N + 541; - Name_Exception_Information : constant Name_Id := N + 542; - Name_Exception_Message : constant Name_Id := N + 543; - Name_Exception_Name : constant Name_Id := N + 544; - Name_File : constant Name_Id := N + 545; - Name_Import_Address : constant Name_Id := N + 546; - Name_Import_Largest_Value : constant Name_Id := N + 547; - Name_Import_Value : constant Name_Id := N + 548; - Name_Is_Negative : constant Name_Id := N + 549; - Name_Line : constant Name_Id := N + 550; - Name_Rotate_Left : constant Name_Id := N + 551; - Name_Rotate_Right : constant Name_Id := N + 552; - Name_Shift_Left : constant Name_Id := N + 553; - Name_Shift_Right : constant Name_Id := N + 554; - Name_Shift_Right_Arithmetic : constant Name_Id := N + 555; - Name_Source_Location : constant Name_Id := N + 556; - Name_Unchecked_Conversion : constant Name_Id := N + 557; - Name_Unchecked_Deallocation : constant Name_Id := N + 558; - Name_To_Pointer : constant Name_Id := N + 559; - Last_Intrinsic_Name : constant Name_Id := N + 559; + First_Intrinsic_Name : constant Name_Id := N + 541; + Name_Divide : constant Name_Id := N + 541; + Name_Enclosing_Entity : constant Name_Id := N + 542; + Name_Exception_Information : constant Name_Id := N + 543; + Name_Exception_Message : constant Name_Id := N + 544; + Name_Exception_Name : constant Name_Id := N + 545; + Name_File : constant Name_Id := N + 546; + Name_Import_Address : constant Name_Id := N + 547; + Name_Import_Largest_Value : constant Name_Id := N + 548; + Name_Import_Value : constant Name_Id := N + 549; + Name_Is_Negative : constant Name_Id := N + 550; + Name_Line : constant Name_Id := N + 551; + Name_Rotate_Left : constant Name_Id := N + 552; + Name_Rotate_Right : constant Name_Id := N + 553; + Name_Shift_Left : constant Name_Id := N + 554; + Name_Shift_Right : constant Name_Id := N + 555; + Name_Shift_Right_Arithmetic : constant Name_Id := N + 556; + Name_Source_Location : constant Name_Id := N + 557; + Name_Unchecked_Conversion : constant Name_Id := N + 558; + Name_Unchecked_Deallocation : constant Name_Id := N + 559; + Name_To_Pointer : constant Name_Id := N + 560; + Last_Intrinsic_Name : constant Name_Id := N + 560; -- Reserved words used only in Ada 95 - First_95_Reserved_Word : constant Name_Id := N + 560; - Name_Abstract : constant Name_Id := N + 560; - Name_Aliased : constant Name_Id := N + 561; - Name_Protected : constant Name_Id := N + 562; - Name_Until : constant Name_Id := N + 563; - Name_Requeue : constant Name_Id := N + 564; - Name_Tagged : constant Name_Id := N + 565; - Last_95_Reserved_Word : constant Name_Id := N + 565; + First_95_Reserved_Word : constant Name_Id := N + 561; + Name_Abstract : constant Name_Id := N + 561; + Name_Aliased : constant Name_Id := N + 562; + Name_Protected : constant Name_Id := N + 563; + Name_Until : constant Name_Id := N + 564; + Name_Requeue : constant Name_Id := N + 565; + Name_Tagged : constant Name_Id := N + 566; + Last_95_Reserved_Word : constant Name_Id := N + 566; subtype Ada_95_Reserved_Words is Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word; -- Miscellaneous names used in semantic checking - Name_Raise_Exception : constant Name_Id := N + 566; + Name_Raise_Exception : constant Name_Id := N + 567; -- Additional reserved words in GNAT Project Files -- Note that Name_External is already previously declared - Name_Binder : constant Name_Id := N + 567; - Name_Body_Suffix : constant Name_Id := N + 568; - Name_Builder : constant Name_Id := N + 569; - Name_Compiler : constant Name_Id := N + 570; - Name_Cross_Reference : constant Name_Id := N + 571; - Name_Default_Switches : constant Name_Id := N + 572; - Name_Exec_Dir : constant Name_Id := N + 573; - Name_Executable : constant Name_Id := N + 574; - Name_Executable_Suffix : constant Name_Id := N + 575; - Name_Extends : constant Name_Id := N + 576; - Name_Finder : constant Name_Id := N + 577; - Name_Global_Configuration_Pragmas : constant Name_Id := N + 578; - Name_Gnatls : constant Name_Id := N + 579; - Name_Gnatstub : constant Name_Id := N + 580; - Name_Implementation : constant Name_Id := N + 581; - Name_Implementation_Exceptions : constant Name_Id := N + 582; - Name_Implementation_Suffix : constant Name_Id := N + 583; - Name_Languages : constant Name_Id := N + 584; - Name_Library_Dir : constant Name_Id := N + 585; - Name_Library_Auto_Init : constant Name_Id := N + 586; - Name_Library_GCC : constant Name_Id := N + 587; - Name_Library_Interface : constant Name_Id := N + 588; - Name_Library_Kind : constant Name_Id := N + 589; - Name_Library_Name : constant Name_Id := N + 590; - Name_Library_Options : constant Name_Id := N + 591; - Name_Library_Reference_Symbol_File : constant Name_Id := N + 592; - Name_Library_Src_Dir : constant Name_Id := N + 593; - Name_Library_Symbol_File : constant Name_Id := N + 594; - Name_Library_Symbol_Policy : constant Name_Id := N + 595; - Name_Library_Version : constant Name_Id := N + 596; - Name_Linker : constant Name_Id := N + 597; - Name_Local_Configuration_Pragmas : constant Name_Id := N + 598; - Name_Locally_Removed_Files : constant Name_Id := N + 599; - Name_Metrics : constant Name_Id := N + 600; - Name_Naming : constant Name_Id := N + 601; - Name_Object_Dir : constant Name_Id := N + 602; - Name_Pretty_Printer : constant Name_Id := N + 603; - Name_Project : constant Name_Id := N + 604; - Name_Separate_Suffix : constant Name_Id := N + 605; - Name_Source_Dirs : constant Name_Id := N + 606; - Name_Source_Files : constant Name_Id := N + 607; - Name_Source_List_File : constant Name_Id := N + 608; - Name_Spec : constant Name_Id := N + 609; - Name_Spec_Suffix : constant Name_Id := N + 610; - Name_Specification : constant Name_Id := N + 611; - Name_Specification_Exceptions : constant Name_Id := N + 612; - Name_Specification_Suffix : constant Name_Id := N + 613; - Name_Switches : constant Name_Id := N + 614; + Name_Binder : constant Name_Id := N + 568; + Name_Body_Suffix : constant Name_Id := N + 569; + Name_Builder : constant Name_Id := N + 570; + Name_Compiler : constant Name_Id := N + 571; + Name_Cross_Reference : constant Name_Id := N + 572; + Name_Default_Switches : constant Name_Id := N + 573; + Name_Exec_Dir : constant Name_Id := N + 574; + Name_Executable : constant Name_Id := N + 575; + Name_Executable_Suffix : constant Name_Id := N + 576; + Name_Extends : constant Name_Id := N + 577; + Name_Finder : constant Name_Id := N + 578; + Name_Global_Configuration_Pragmas : constant Name_Id := N + 579; + Name_Gnatls : constant Name_Id := N + 580; + Name_Gnatstub : constant Name_Id := N + 581; + Name_Implementation : constant Name_Id := N + 582; + Name_Implementation_Exceptions : constant Name_Id := N + 583; + Name_Implementation_Suffix : constant Name_Id := N + 584; + Name_Languages : constant Name_Id := N + 585; + Name_Library_Dir : constant Name_Id := N + 586; + Name_Library_Auto_Init : constant Name_Id := N + 587; + Name_Library_GCC : constant Name_Id := N + 588; + Name_Library_Interface : constant Name_Id := N + 589; + Name_Library_Kind : constant Name_Id := N + 590; + Name_Library_Name : constant Name_Id := N + 591; + Name_Library_Options : constant Name_Id := N + 592; + Name_Library_Reference_Symbol_File : constant Name_Id := N + 593; + Name_Library_Src_Dir : constant Name_Id := N + 594; + Name_Library_Symbol_File : constant Name_Id := N + 595; + Name_Library_Symbol_Policy : constant Name_Id := N + 596; + Name_Library_Version : constant Name_Id := N + 597; + Name_Linker : constant Name_Id := N + 598; + Name_Local_Configuration_Pragmas : constant Name_Id := N + 599; + Name_Locally_Removed_Files : constant Name_Id := N + 600; + Name_Metrics : constant Name_Id := N + 601; + Name_Naming : constant Name_Id := N + 602; + Name_Object_Dir : constant Name_Id := N + 603; + Name_Pretty_Printer : constant Name_Id := N + 604; + Name_Project : constant Name_Id := N + 605; + Name_Separate_Suffix : constant Name_Id := N + 606; + Name_Source_Dirs : constant Name_Id := N + 607; + Name_Source_Files : constant Name_Id := N + 608; + Name_Source_List_File : constant Name_Id := N + 609; + Name_Spec : constant Name_Id := N + 610; + Name_Spec_Suffix : constant Name_Id := N + 611; + Name_Specification : constant Name_Id := N + 612; + Name_Specification_Exceptions : constant Name_Id := N + 613; + Name_Specification_Suffix : constant Name_Id := N + 614; + Name_Switches : constant Name_Id := N + 615; -- Other miscellaneous names used in front end - Name_Unaligned_Valid : constant Name_Id := N + 615; + Name_Unaligned_Valid : constant Name_Id := N + 616; -- Mark last defined name for consistency check in Snames body - Last_Predefined_Name : constant Name_Id := N + 615; + Last_Predefined_Name : constant Name_Id := N + 616; subtype Any_Operator_Name is Name_Id range First_Operator_Name .. Last_Operator_Name; diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c index 85b0a7452ff..2daefa3a552 100644 --- a/gcc/ada/utils2.c +++ b/gcc/ada/utils2.c @@ -774,7 +774,7 @@ build_binary_op (enum tree_code op_code, tree result_type, case ARRAY_RANGE_REF: /* First convert the right operand to its base type. This will - prevent unneed signedness conversions when sizetype is wider than + prevent unneeded signedness conversions when sizetype is wider than integer. */ right_operand = convert (right_base_type, right_operand); right_operand = convert (TYPE_DOMAIN (left_type), right_operand); |