OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2009-11-30  Vincent Celier  <celier@adacore.com>

	* gnatlink.adb (Process_Args): Call Executable_Name on argument of -o
	with Only_If_No_Suffix set to True.
	* osint.adb (Executable_Name): Do not add executable suffix if there is
	already a suffix and Only_If_No_Suffix is True.
	* osint.ads (Executable_Name): New Boolean parameter Only_If_No_Suffix,
	defaulted to False.

2009-11-30  Javier Miranda  <miranda@adacore.com>

	* exp_atag.adb (Build_TSD): Change argument name because the actual is
	now the address of a tag (instead of the tag). Update implementation
	accordingly.
	(Build_CW_Membership): New implementation. Converted into a procedure
	because it has an additional out mode parameter. Its implementation has
	been rewritten to improve the generated code but also to facilitate
	referencing the relocated object node in the caller.
	* exp_atag.ads (Build_CW_Membership): Update profile and documentation.
	* sinfo.ads (N_SCIL_Membership_Test) New_Node.
	(SCIL_Tag_Value): New field of N_SCIL_Membership_Test nodes.
	(Is_Syntactic_Field): Add entry of new node.
	(SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms.
	* sinfo.adb (SCIL_Related_Node, SCIL_Entity): Update assertions to
	handle N_SCIL_Membership_Test nodes.
	(SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms.
	* sem.adb (Analyze): Add null management for new node.
	* sem_scil.adb (Find_SCIL_Node): Add null management for new node.
	(Check_SCIL_Node): Add checks of N_SCIL_Membership_Test nodes.
	* exp_ch4.adb (Tagged_Membership): Change profile from function to
	procedure. Add generation of SCIL node associated with class-wide
	membership test.
	(Expand_N_In): Complete decoration of SCIL nodes.
	* exp_intr.adb (Expand_Dispatching_Constructor_Call): Tune call to
	Build_CW_Membership because its profile has been changed.
	* exp_util.adb (Insert_Actions): Add null management for new node.
	* sprint.adb (Sprint_Node_Actual): Handle new node.
	* gcc-interface/trans.c Add no processing for N_SCIL_Membership_Test
	nodes.
	* gcc-interface/Make-lang.in: Update dependencies.

2009-11-30  Ed Schonberg  <schonberg@adacore.com>

	* opt.ads: New flags Init_Or_Norm_Scalars_Config,
	Initialize_Scalars_Config, to capture the presence of the corresponding
	pragmas in a configuration file.
	* opt.adb (Register_, Save_, Set_, Restore_Opt_Configuration_Switches):
	handle new flags so that they are restored for each compilation unit.
	* frontend.adb: At the end of compilation, scan the context of the main
	unit to recover occurrences of pragma Initialize_Scalars, to annotate
	the ALI file accordingly.

From-SVN: r154792
This commit is contained in:
Arnaud Charlet 2009-11-30 12:55:21 +01:00
parent fd0d899b57
commit 828781519a
19 changed files with 468 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
gcc/ada/ChangeLog
View File

@ -1,3 +1,55 @@
2009-11-30 Vincent Celier <celier@adacore.com>
* gnatlink.adb (Process_Args): Call Executable_Name on argument of -o
with Only_If_No_Suffix set to True.
* osint.adb (Executable_Name): Do not add executable suffix if there is
already a suffix and Only_If_No_Suffix is True.
* osint.ads (Executable_Name): New Boolean parameter Only_If_No_Suffix,
defaulted to False.
2009-11-30 Javier Miranda <miranda@adacore.com>
* exp_atag.adb (Build_TSD): Change argument name because the actual is
now the address of a tag (instead of the tag). Update implementation
accordingly.
(Build_CW_Membership): New implementation. Converted into a procedure
because it has an additional out mode parameter. Its implementation has
been rewritten to improve the generated code but also to facilitate
referencing the relocated object node in the caller.
* exp_atag.ads (Build_CW_Membership): Update profile and documentation.
* sinfo.ads (N_SCIL_Membership_Test) New_Node.
(SCIL_Tag_Value): New field of N_SCIL_Membership_Test nodes.
(Is_Syntactic_Field): Add entry of new node.
(SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms.
* sinfo.adb (SCIL_Related_Node, SCIL_Entity): Update assertions to
handle N_SCIL_Membership_Test nodes.
(SCIL_Tag_Value/Set_SCIL_Tag_Value): New subprograms.
* sem.adb (Analyze): Add null management for new node.
* sem_scil.adb (Find_SCIL_Node): Add null management for new node.
(Check_SCIL_Node): Add checks of N_SCIL_Membership_Test nodes.
* exp_ch4.adb (Tagged_Membership): Change profile from function to
procedure. Add generation of SCIL node associated with class-wide
membership test.
(Expand_N_In): Complete decoration of SCIL nodes.
* exp_intr.adb (Expand_Dispatching_Constructor_Call): Tune call to
Build_CW_Membership because its profile has been changed.
* exp_util.adb (Insert_Actions): Add null management for new node.
* sprint.adb (Sprint_Node_Actual): Handle new node.
* gcc-interface/trans.c Add no processing for N_SCIL_Membership_Test
nodes.
* gcc-interface/Make-lang.in: Update dependencies.
2009-11-30 Ed Schonberg <schonberg@adacore.com>
* opt.ads: New flags Init_Or_Norm_Scalars_Config,
Initialize_Scalars_Config, to capture the presence of the corresponding
pragmas in a configuration file.
* opt.adb (Register_, Save_, Set_, Restore_Opt_Configuration_Switches):
handle new flags so that they are restored for each compilation unit.
* frontend.adb: At the end of compilation, scan the context of the main
unit to recover occurrences of pragma Initialize_Scalars, to annotate
the ALI file accordingly.
2009-11-30 Vincent Celier <celier@adacore.com>
* prj-tree.ads: Minor comment updates

129
gcc/ada/exp_atag.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
@ -53,12 +54,14 @@ package body Exp_Atag is
-- To_Dispatch_Table_Ptr
-- (To_Address (Tag_Node) - Tag_Node.Prims_Ptr'Position);
function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id;
function Build_TSD
(Loc : Source_Ptr;
Tag_Node_Addr : Node_Id) return Node_Id;
-- Build code that retrieves the address of the record containing the Type
-- Specific Data generated by GNAT.
--
-- Generate: To_Type_Specific_Data_Ptr
-- (To_Addr_Ptr (To_Address (Tag) - Typeinfo_Offset).all);
-- (To_Addr_Ptr (Tag_Node_Addr - Typeinfo_Offset).all);
------------------------------------------------
-- Build_Common_Dispatching_Select_Statements --
@ -140,39 +143,90 @@ package body Exp_Atag is
-- Build_CW_Membership --
-------------------------
function Build_CW_Membership
procedure Build_CW_Membership
(Loc : Source_Ptr;
Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id
Obj_Tag_Node : in out Node_Id;
Typ_Tag_Node : Node_Id;
Related_Nod : Node_Id;
New_Node : out Node_Id)
is
function Build_Pos return Node_Id;
-- Generate TSD (Obj_Tag).Idepth - TSD (Typ_Tag).Idepth;
Tag_Addr : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('D'));
Obj_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('D'));
Typ_TSD : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('D'));
Index : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('D'));
function Build_Pos return Node_Id is
begin
return
begin
-- Generate:
-- Tag_Addr : constant Tag := Address!(Obj_Tag);
-- Obj_TSD : constant Type_Specific_Data_Ptr
-- := Build_TSD (Tag_Addr);
-- Typ_TSD : constant Type_Specific_Data_Ptr
-- := Build_TSD (Address!(Typ_Tag));
-- Index : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth
-- Index > 0 and then Obj_TSD.Tags_Table (Index) = Typ'Tag
Insert_Action (Related_Nod,
Make_Object_Declaration (Loc,
Defining_Identifier => Tag_Addr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Address), Loc),
Expression => Unchecked_Convert_To
(RTE (RE_Address), Obj_Tag_Node)));
-- Unchecked_Convert_To relocates Obj_Tag_Node and therefore we must
-- update it.
Obj_Tag_Node := Expression (Expression (Parent (Tag_Addr)));
Insert_Action (Related_Nod,
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_TSD,
Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Type_Specific_Data_Ptr), Loc),
Expression => Build_TSD (Loc, New_Reference_To (Tag_Addr, Loc))));
Insert_Action (Related_Nod,
Make_Object_Declaration (Loc,
Defining_Identifier => Typ_TSD,
Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Type_Specific_Data_Ptr), Loc),
Expression => Build_TSD (Loc,
Unchecked_Convert_To (RTE (RE_Address),
Typ_Tag_Node))));
Insert_Action (Related_Nod,
Make_Object_Declaration (Loc,
Defining_Identifier => Index,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
Expression =>
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Duplicate_Subexpr (Obj_Tag_Node)),
Prefix => New_Reference_To (Obj_TSD, Loc),
Selector_Name =>
New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)),
New_Reference_To
(RTE_Record_Component (RE_Idepth), Loc)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)),
Selector_Name =>
New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)));
end Build_Pos;
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Typ_TSD, Loc),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Idepth), Loc)))));
-- Start of processing for Build_CW_Membership
begin
return
New_Node :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
Left_Opnd => Build_Pos,
Left_Opnd => New_Occurrence_Of (Index, Loc),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd =>
@ -181,12 +235,12 @@ package body Exp_Atag is
Make_Indexed_Component (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Obj_Tag_Node),
Prefix => New_Reference_To (Obj_TSD, Loc),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Tags_Table), Loc)),
Expressions =>
New_List (Build_Pos)),
New_List (New_Occurrence_Of (Index, Loc))),
Right_Opnd => Typ_Tag_Node));
end Build_CW_Membership;
@ -197,7 +251,8 @@ package body Exp_Atag is
function Build_DT
(Loc : Source_Ptr;
Tag_Node : Node_Id) return Node_Id is
Tag_Node : Node_Id) return Node_Id
is
begin
return
Make_Function_Call (Loc,
@ -217,7 +272,9 @@ package body Exp_Atag is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Prefix =>
Build_TSD (Loc,
Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Access_Level), Loc));
@ -390,7 +447,9 @@ package body Exp_Atag is
begin
return
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Prefix =>
Build_TSD (Loc,
Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Transportable), Loc));
@ -529,7 +588,9 @@ package body Exp_Atag is
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Build_TSD (Loc, Tag_Node),
Prefix =>
Build_TSD (Loc,
Unchecked_Convert_To (RTE (RE_Address), Tag_Node)),
Selector_Name =>
New_Reference_To
(RTE_Record_Component (RE_Size_Func), Loc)),
@ -572,7 +633,9 @@ package body Exp_Atag is
-- Build_TSD --
---------------
function Build_TSD (Loc : Source_Ptr; Tag_Node : Node_Id) return Node_Id is
function Build_TSD
(Loc : Source_Ptr;
Tag_Node_Addr : Node_Id) return Node_Id is
begin
return
Unchecked_Convert_To (RTE (RE_Type_Specific_Data_Ptr),
@ -590,9 +653,9 @@ package body Exp_Atag is
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
New_Reference_To
(RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
Tag_Node_Addr,
New_Reference_To
(RTE (RE_DT_Typeinfo_Ptr_Size), Loc))))));
end Build_TSD;
end Exp_Atag;

15
gcc/ada/exp_atag.ads
View File

@ -41,18 +41,23 @@ package Exp_Atag is
-- Ada 2005 (AI-345): Generate statements that are common between timed,
-- asynchronous, and conditional select expansion.
function Build_CW_Membership
procedure Build_CW_Membership
(Loc : Source_Ptr;
Obj_Tag_Node : Node_Id;
Typ_Tag_Node : Node_Id) return Node_Id;
Obj_Tag_Node : in out Node_Id;
Typ_Tag_Node : Node_Id;
Related_Nod : Node_Id;
New_Node : out Node_Id);
-- Build code that returns true if Obj_Tag is in Typ_Tag'Class. Each DT
-- has a table of ancestors and its inheritance level (Idepth). Obj is in
-- Typ'Class if Typ'Tag is found in the table of ancestors referenced by
-- Obj'Tag. Knowing the level of inheritance of both types, this can be
-- computed in constant time by the formula:
--
-- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth)
-- = Typ'tag
-- Index := TSD (Obj'Tag).Idepth - TSD (Typ'Tag).Idepth;
-- Index > 0 and then TSD (Obj'Tag).Tags_Table (Index) = Typ'Tag
--
-- Related_Nod is the node where the implicit declaration of variable Index
-- is inserted. Obj_Tag_Node is relocated.
function Build_Get_Access_Level
(Loc : Source_Ptr;

78
gcc/ada/exp_ch4.adb
View File

@ -205,7 +205,10 @@ package body Exp_Ch4 is
-- its expression. If N is neither comparison nor a type conversion, the
-- call has no effect.
function Tagged_Membership (N : Node_Id) return Node_Id;
procedure Tagged_Membership
(N : Node_Id;
SCIL_Node : out Node_Id;
Result : out Node_Id);
-- Construct the expression corresponding to the tagged membership test.
-- Deals with a second operand being (or not) a class-wide type.
@ -4503,10 +4506,12 @@ package body Exp_Ch4 is
else
declare
Typ : Entity_Id := Etype (Rop);
Is_Acc : constant Boolean := Is_Access_Type (Typ);
Obj : Node_Id := Lop;
Cond : Node_Id := Empty;
Typ : Entity_Id := Etype (Rop);
Is_Acc : constant Boolean := Is_Access_Type (Typ);
Cond : Node_Id := Empty;
New_N : Node_Id;
Obj : Node_Id := Lop;
SCIL_Node : Node_Id;
begin
Remove_Side_Effects (Obj);
@ -4521,8 +4526,19 @@ package body Exp_Ch4 is
-- normal tagged membership expansion is not what we want).
if Tagged_Type_Expansion then
Rewrite (N, Tagged_Membership (N));
Tagged_Membership (N, SCIL_Node, New_N);
Rewrite (N, New_N);
Analyze_And_Resolve (N, Rtyp);
-- Update decoration of relocated node referenced by the
-- SCIL node.
if Generate_SCIL
and then Present (SCIL_Node)
then
Set_SCIL_Related_Node (SCIL_Node, N);
Insert_Action (N, SCIL_Node);
end if;
end if;
return;
@ -9857,16 +9873,23 @@ package body Exp_Ch4 is
-- table of abstract interface types plus the ancestor table contained in
-- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
function Tagged_Membership (N : Node_Id) return Node_Id is
procedure Tagged_Membership
(N : Node_Id;
SCIL_Node : out Node_Id;
Result : out Node_Id)
is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
Left_Type : Entity_Id;
New_Node : Node_Id;
Right_Type : Entity_Id;
Obj_Tag : Node_Id;
begin
SCIL_Node := Empty;
-- Handle entities from the limited view
Left_Type := Available_View (Etype (Left));
@ -9914,7 +9937,8 @@ package body Exp_Ch4 is
(Typ => Left_Type,
Iface => Etype (Right_Type))))
then
return New_Reference_To (Standard_True, Loc);
Result := New_Reference_To (Standard_True, Loc);
return;
end if;
-- Ada 2005 (AI-251): Class-wide applied to interfaces
@ -9931,10 +9955,11 @@ package body Exp_Ch4 is
if not RTE_Available (RE_IW_Membership) then
Error_Msg_CRT
("dynamic membership test on interface types", N);
return Empty;
Result := Empty;
return;
end if;
return
Result :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
Parameter_Associations => New_List (
@ -9949,14 +9974,27 @@ package body Exp_Ch4 is
-- Ada 95: Normal case
else
return
Build_CW_Membership (Loc,
Obj_Tag_Node => Obj_Tag,
Typ_Tag_Node =>
New_Reference_To (
Node (First_Elmt
(Access_Disp_Table (Root_Type (Right_Type)))),
Loc));
Build_CW_Membership (Loc,
Obj_Tag_Node => Obj_Tag,
Typ_Tag_Node =>
New_Reference_To (
Node (First_Elmt
(Access_Disp_Table (Root_Type (Right_Type)))),
Loc),
Related_Nod => N,
New_Node => New_Node);
-- Generate the SCIL node for this class-wide membership test.
-- Done here because the previous call to Build_CW_Membership
-- relocates Obj_Tag.
if Generate_SCIL then
SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
end if;
Result := New_Node;
end if;
-- Right_Type is not a class-wide type
@ -9965,10 +10003,10 @@ package body Exp_Ch4 is
-- No need to check the tag of the object if Right_Typ is abstract
if Is_Abstract_Type (Right_Type) then
return New_Reference_To (Standard_False, Loc);
Result := New_Reference_To (Standard_False, Loc);
else
return
Result :=
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>

35
gcc/ada/exp_intr.adb
View File

@ -234,19 +234,28 @@ package body Exp_Intr is
-- the tag in the table of ancestor tags.
elsif not Is_Interface (Result_Typ) then
Insert_Action (N,
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Not (Loc,
Build_CW_Membership (Loc,
Obj_Tag_Node => Duplicate_Subexpr (Tag_Arg),
Typ_Tag_Node =>
New_Reference_To (
Node (First_Elmt (Access_Disp_Table (
Root_Type (Result_Typ)))), Loc))),
Then_Statements =>
New_List (Make_Raise_Statement (Loc,
New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
declare
Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
CW_Test_Node : Node_Id;
begin
Build_CW_Membership (Loc,
Obj_Tag_Node => Obj_Tag_Node,
Typ_Tag_Node =>
New_Reference_To (
Node (First_Elmt (Access_Disp_Table (
Root_Type (Result_Typ)))), Loc),
Related_Nod => N,
New_Node => CW_Test_Node);
Insert_Action (N,
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Not (Loc, CW_Test_Node),
Then_Statements =>
New_List (Make_Raise_Statement (Loc,
New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
end;
-- Call IW_Membership test if the Result_Type is an abstract interface
-- to look for the tag in the table of interface tags.

1
gcc/ada/exp_util.adb
View File

@ -2761,6 +2761,7 @@ package body Exp_Util is
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_SCIL_Tag_Init |
N_Selected_Component |
N_Signed_Integer_Type_Definition |

23
gcc/ada/frontend.adb
View File

@ -47,6 +47,7 @@ with Prepcomp;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Snames; use Snames;
with Sprint;
with Scn; use Scn;
with Sem; use Sem;
@ -381,6 +382,28 @@ begin
Sprint.Source_Dump;
-- Check again for configuration pragmas that appear in the context of
-- the main unit. These pragmas only affect the main unit, and the
-- corresponding flag is reset after each call to Semantics, but they
-- may affect the generated ali for the unit, and therefore the flag
-- must be set properly after compilation. Currently we only check for
-- Initialize_Scalars, but others should be checked: as well???
declare
Item : Node_Id;
begin
Item := First (Context_Items (Cunit (Main_Unit)));
while Present (Item) loop
if Nkind (Item) = N_Pragma
and then Pragma_Name (Item) = Name_Initialize_Scalars
then
Initialize_Scalars := True;
end if;
Next (Item);
end loop;
end;
-- If a mapping file has been specified by a -gnatem switch, update
-- it if there has been some sources that were not in the mappings.

32
gcc/ada/gcc-interface/Make-lang.in
View File

@ -1663,28 +1663,24 @@ ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/exp_atag.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \
ada/casing.ads ada/checks.ads ada/csets.ads ada/debug.ads ada/einfo.ads \
ada/einfo.adb ada/elists.ads ada/elists.adb ada/err_vars.ads \
ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_atag.ads \
ada/exp_atag.adb ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_dist.ads \
ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb ada/fname.ads \
ada/fname-uf.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \
ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/einfo.adb \
ada/elists.ads ada/elists.adb ada/err_vars.ads ada/errout.ads \
ada/erroutc.ads ada/exp_atag.ads ada/exp_atag.adb ada/exp_dist.ads \
ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \
ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/lib.ads \
ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nlists.adb \
ada/nmake.ads ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/sem.ads \
ada/sem_aux.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \
ada/sem_eval.ads ada/sem_res.ads ada/sem_scil.ads ada/sem_type.ads \
ada/sem_util.ads ada/sinfo.ads ada/sinfo.adb ada/sinput.ads \
ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
ada/s-exctab.ads ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads \
ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads ada/s-soflin.ads \
ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads ada/types.ads \
ada/sem_aux.ads ada/sem_ch7.ads ada/sem_dist.ads ada/sem_util.ads \
ada/sinfo.ads ada/sinfo.adb ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \
ada/s-rident.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
ada/tbuild.ads ada/tbuild.adb ada/tree_io.ads ada/types.ads \
ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/unchdeal.ads ada/urealp.ads
ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
ada/a-uncdea.ads ada/alloc.ads ada/atree.ads ada/atree.adb \

1
gcc/ada/gcc-interface/trans.c
View File

@ -5321,6 +5321,7 @@ gnat_to_gnu (Node_Id gnat_node)
case N_SCIL_Dispatch_Table_Object_Init:
case N_SCIL_Dispatch_Table_Tag_Init:
case N_SCIL_Dispatching_Call:
case N_SCIL_Membership_Test:
case N_SCIL_Tag_Init:
/* SCIL nodes require no processing for GCC. */
gnu_result = alloc_stmt_list ();

5
gcc/ada/gnatlink.adb
View File

@ -445,7 +445,10 @@ procedure Gnatlink is
Exit_With_Error ("Missing argument for -o");
end if;
Output_File_Name := new String'(Argument (Next_Arg));
Output_File_Name :=
new String'(Executable_Name
(Argument (Next_Arg),
Only_If_No_Suffix => True));
when 'R' =>
Opt.Run_Path_Option := False;

8
gcc/ada/opt.adb
View File

@ -56,6 +56,8 @@ package body Opt is
External_Name_Exp_Casing_Config := External_Name_Exp_Casing;
External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
Fast_Math_Config := Fast_Math;
Init_Or_Norm_Scalars_Config := Init_Or_Norm_Scalars;
Initialize_Scalars_Config := Initialize_Scalars;
Optimize_Alignment_Config := Optimize_Alignment;
Persistent_BSS_Mode_Config := Persistent_BSS_Mode;
Polling_Required_Config := Polling_Required;
@ -86,6 +88,8 @@ package body Opt is
External_Name_Exp_Casing := Save.External_Name_Exp_Casing;
External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
Fast_Math := Save.Fast_Math;
Init_Or_Norm_Scalars := Save.Init_Or_Norm_Scalars;
Initialize_Scalars := Save.Initialize_Scalars;
Optimize_Alignment := Save.Optimize_Alignment;
Optimize_Alignment_Local := Save.Optimize_Alignment_Local;
Persistent_BSS_Mode := Save.Persistent_BSS_Mode;
@ -111,6 +115,8 @@ package body Opt is
Save.External_Name_Exp_Casing := External_Name_Exp_Casing;
Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
Save.Fast_Math := Fast_Math;
Save.Init_Or_Norm_Scalars := Init_Or_Norm_Scalars;
Save.Initialize_Scalars := Initialize_Scalars;
Save.Optimize_Alignment := Optimize_Alignment;
Save.Optimize_Alignment_Local := Optimize_Alignment_Local;
Save.Persistent_BSS_Mode := Persistent_BSS_Mode;
@ -175,6 +181,8 @@ package body Opt is
External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
External_Name_Imp_Casing := External_Name_Imp_Casing_Config;
Fast_Math := Fast_Math_Config;
Init_Or_Norm_Scalars := Init_Or_Norm_Scalars_Config;
Initialize_Scalars := Initialize_Scalars_Config;
Optimize_Alignment := Optimize_Alignment_Config;
Optimize_Alignment_Local := False;
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;

14
gcc/ada/opt.ads
View File

@ -1551,6 +1551,18 @@ package Opt is
-- used to set the initial value of Fast_Math at the start of each new
-- compilation unit.
Init_Or_Norm_Scalars_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that is set by one
-- of the pragmas Initialize_Scalars or Normalize_Scalars.
Initialize_Scalars_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that is set by the
-- pragma Initialize_Scalars when it appears in the gnat.adc file.
-- This switch is not set when the pragma appears ahead of a given
-- unit, so it does not affect the compilation of other units.
Optimize_Alignment_Config : Character;
-- GNAT
-- This is the value of the configuration switch that controls the
@ -1699,6 +1711,8 @@ private
External_Name_Exp_Casing : External_Casing_Type;
External_Name_Imp_Casing : External_Casing_Type;
Fast_Math : Boolean;
Init_Or_Norm_Scalars : Boolean;
Initialize_Scalars : Boolean;
Optimize_Alignment : Character;
Optimize_Alignment_Local : Boolean;
Persistent_BSS_Mode : Boolean;

89
gcc/ada/osint.adb
View File

@ -793,8 +793,12 @@ package body Osint is
-- Executable_Name --
---------------------
function Executable_Name (Name : File_Name_Type) return File_Name_Type is
function Executable_Name
(Name : File_Name_Type;
Only_If_No_Suffix : Boolean := False) return File_Name_Type
is
Exec_Suffix : String_Access;
Add_Suffix : Boolean;
begin
if Name = No_File then
@ -808,40 +812,59 @@ package body Osint is
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
Get_Name_String (Name);
if Exec_Suffix'Length /= 0 then
declare
Buffer : String := Name_Buffer (1 .. Name_Len);
Add_Suffix := not Only_If_No_Suffix;
begin
-- Get the file name in canonical case to accept as is names
-- ending with ".EXE" on VMS and Windows.
if not Add_Suffix then
for J in 1 .. Name_Len loop
if Name_Buffer (J) = '.' then
Add_Suffix := True;
exit;
end if;
end loop;
end if;
Canonical_Case_File_Name (Buffer);
if Add_Suffix then
Get_Name_String (Name);
-- If Executable does not end with the executable suffix, add it
declare
Buffer : String := Name_Buffer (1 .. Name_Len);
if Buffer'Length <= Exec_Suffix'Length
or else
Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
/= Exec_Suffix.all
then
Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
Exec_Suffix.all;
Name_Len := Name_Len + Exec_Suffix'Length;
Free (Exec_Suffix);
return Name_Find;
end if;
end;
begin
-- Get the file name in canonical case to accept as is names
-- ending with ".EXE" on VMS and Windows.
Canonical_Case_File_Name (Buffer);
-- If Executable does not end with the executable suffix, add
-- it.
if Buffer'Length <= Exec_Suffix'Length
or else
Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
/= Exec_Suffix.all
then
Name_Buffer
(Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
Exec_Suffix.all;
Name_Len := Name_Len + Exec_Suffix'Length;
Free (Exec_Suffix);
return Name_Find;
end if;
end;
end if;
end if;
Free (Exec_Suffix);
return Name;
end Executable_Name;
function Executable_Name (Name : String) return String is
function Executable_Name
(Name : String;
Only_If_No_Suffix : Boolean := False) return String
is
Exec_Suffix : String_Access;
Add_Suffix : Boolean;
Canonical_Name : String := Name;
begin
@ -858,12 +881,22 @@ package body Osint is
begin
Free (Exec_Suffix);
Canonical_Case_File_Name (Canonical_Name);
Add_Suffix := not Only_If_No_Suffix;
if Suffix'Length /= 0
and then
(Canonical_Name'Length <= Suffix'Length
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
.. Canonical_Name'Last) /= Suffix)
if not Add_Suffix then
for J in 1 .. Name_Len loop
if Name_Buffer (J) = '.' then
Add_Suffix := True;
exit;
end if;
end loop;
end if;
if Suffix'Length = 0 and then
Add_Suffix and then
(Canonical_Name'Length <= Suffix'Length
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
.. Canonical_Name'Last) /= Suffix)
then
declare
Result : String (1 .. Name'Length + Suffix'Length);

8
gcc/ada/osint.ads
View File

@ -147,13 +147,17 @@ package Osint is
-- Strips the suffix (the last '.' and whatever comes after it) from Name.
-- Returns the stripped name.
function Executable_Name (Name : File_Name_Type) return File_Name_Type;
function Executable_Name
(Name : File_Name_Type;
Only_If_No_Suffix : Boolean := False) return File_Name_Type;
-- Given a file name it adds the appropriate suffix at the end so that
-- it becomes the name of the executable on the system at end. For
-- instance under DOS it adds the ".exe" suffix, whereas under UNIX no
-- suffix is added.
function Executable_Name (Name : String) return String;
function Executable_Name
(Name : String;
Only_If_No_Suffix : Boolean := False) return String;
-- Same as above, with String parameters
function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type;

1
gcc/ada/sem.adb
View File

@ -612,6 +612,7 @@ package body Sem is
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_SCIL_Tag_Init =>
null;

52
gcc/ada/sem_scil.adb
View File

@ -101,15 +101,58 @@ package body Sem_SCIL is
-- Check_SCIL_Node --
---------------------
-- Is this a good name for the function, given it only deals with
-- N_SCIL_Dispatching_Call case ???
function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
Ctrl_Tag : Node_Id;
Ctrl_Typ : Entity_Id;
begin
if Nkind (N) = N_SCIL_Dispatching_Call then
if Nkind (N) = N_SCIL_Membership_Test then
-- Check contents of the boolean expression associated with the
-- membership test.
pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier
and then Etype (SCIL_Related_Node (N)) = Standard_Boolean);
-- Check the entity identifier of the associated tagged type (that
-- is, in testing for membership in T'Class, the entity id of the
-- specific type T).
-- Note: When the SCIL node is generated the private and full-view
-- of the tagged types may have been swapped and hence the node
-- referenced by attribute SCIL_Entity may be the private view.
-- Therefore, in order to uniformily locate the full-view we use
-- attribute Underlying_Type.
pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N))));
-- Interface types are unsupported
pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N))));
-- Check the decoration of the expression that denotes the tag value
-- being tested
Ctrl_Tag := SCIL_Tag_Value (N);
case Nkind (Ctrl_Tag) is
-- For class-wide membership tests the SCIL tag value is the tag
-- of the tested object (i.e. Obj.Tag).
when N_Selected_Component =>
pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
null;
when others =>
pragma Assert (False);
null;
end case;
return Skip;
elsif Nkind (N) = N_SCIL_Dispatching_Call then
Ctrl_Tag := SCIL_Controlling_Tag (N);
-- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
@ -452,6 +495,7 @@ package body Sem_SCIL is
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_SCIL_Tag_Init
=>
pragma Assert (False);

20
gcc/ada/sinfo.adb
View File

@ -2556,6 +2556,7 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
return Node4 (N);
end SCIL_Entity;
@ -2567,10 +2568,19 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
return Node1 (N);
end SCIL_Related_Node;
function SCIL_Tag_Value
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_SCIL_Membership_Test);
return Node5 (N);
end SCIL_Tag_Value;
function SCIL_Target_Prim
(N : Node_Id) return Node_Id is
begin
@ -5416,6 +5426,7 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_SCIL_Entity;
@ -5427,10 +5438,19 @@ package body Sinfo is
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init
or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init
or else NT (N).Nkind = N_SCIL_Dispatching_Call
or else NT (N).Nkind = N_SCIL_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
Set_Node1 (N, Val); -- semantic field, no parent set
end Set_SCIL_Related_Node;
procedure Set_SCIL_Tag_Value
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_SCIL_Membership_Test);
Set_Node5 (N, Val); -- semantic field, no parent set
end Set_SCIL_Tag_Value;
procedure Set_SCIL_Target_Prim
(N : Node_Id; Val : Node_Id) is
begin

26
gcc/ada/sinfo.ads
View File

@ -1608,6 +1608,10 @@ package Sinfo is
-- Present in N_SCIL_Dispatching_Call nodes. Used to reference the
-- controlling tag of a dispatching call.
-- SCIL_Tag_Value (Node5-Sem)
-- Present in N_SCIL_Membership_Test nodes. Used to reference the tag
-- value that is being tested.
-- SCIL_Target_Prim (Node2-Sem)
-- Present in N_SCIL_Dispatching_Call nodes. Used to reference the tagged
-- type primitive associated with the SCIL node.
@ -6886,6 +6890,12 @@ package Sinfo is
-- SCIL_Entity (Node4-Sem)
-- SCIL_Controlling_Tag (Node5-Sem)
-- N_SCIL_Membership_Test
-- Sloc references the node of a membership test
-- SCIL_Related_Node (Node1-Sem)
-- SCIL_Tag_Value (Node5-Sem)
-- SCIL_Entity (Node4-Sem)
-- N_SCIL_Tag_Init
-- Sloc references the node of a tag component initialization
-- SCIL_Related_Node (Node1-Sem)
@ -7333,6 +7343,7 @@ package Sinfo is
N_SCIL_Dispatch_Table_Object_Init,
N_SCIL_Dispatch_Table_Tag_Init,
N_SCIL_Dispatching_Call,
N_SCIL_Membership_Test,
N_SCIL_Tag_Init,
-- Other nodes (not part of any subtype class)
@ -8390,6 +8401,9 @@ package Sinfo is
function SCIL_Related_Node
(N : Node_Id) return Node_Id; -- Node1
function SCIL_Tag_Value
(N : Node_Id) return Node_Id; -- Node5
function SCIL_Target_Prim
(N : Node_Id) return Node_Id; -- Node2
@ -9302,6 +9316,9 @@ package Sinfo is
procedure Set_SCIL_Related_Node
(N : Node_Id; Val : Node_Id); -- Node1
procedure Set_SCIL_Tag_Value
(N : Node_Id; Val : Node_Id); -- Node5
procedure Set_SCIL_Target_Prim
(N : Node_Id; Val : Node_Id); -- Node2
@ -11056,6 +11073,13 @@ package Sinfo is
4 => False, -- SCIL_Entity (Node4-Sem)
5 => False), -- SCIL_Controlling_Tag (Node5-Sem)
N_SCIL_Membership_Test =>
(1 => False, -- SCIL_Related_Node (Node1-Sem)
2 => False, -- unused
3 => False, -- unused
4 => False, -- SCIL_Entity (Node4-Sem)
5 => False), -- SCIL_Tag_Value (Node5-Sem)
N_SCIL_Tag_Init =>
(1 => False, -- SCIL_Related_Node (Node1-Sem)
2 => False, -- unused
@ -11364,6 +11388,7 @@ package Sinfo is
pragma Inline (SCIL_Controlling_Tag);
pragma Inline (SCIL_Entity);
pragma Inline (SCIL_Related_Node);
pragma Inline (SCIL_Tag_Value);
pragma Inline (SCIL_Target_Prim);
pragma Inline (Scope);
pragma Inline (Select_Alternatives);
@ -11664,6 +11689,7 @@ package Sinfo is
pragma Inline (Set_SCIL_Controlling_Tag);
pragma Inline (Set_SCIL_Entity);
pragma Inline (Set_SCIL_Related_Node);
pragma Inline (Set_SCIL_Tag_Value);
pragma Inline (Set_SCIL_Target_Prim);
pragma Inline (Set_Scope);
pragma Inline (Set_Select_Alternatives);

3
gcc/ada/sprint.adb
View File

@ -2652,6 +2652,9 @@ package body Sprint is
when N_SCIL_Dispatching_Call =>
Write_Indent_Str ("[N_SCIL_Dispatching_Node]");
when N_SCIL_Membership_Test =>
Write_Indent_Str ("[N_SCIL_Membership_Test]");
when N_SCIL_Tag_Init =>
Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]");