diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 52 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.adb | 129 | ||||
| -rw-r--r-- | gcc/ada/exp_atag.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 78 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/frontend.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Make-lang.in | 32 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 1 | ||||
| -rw-r--r-- | gcc/ada/gnatlink.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/opt.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/opt.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/osint.adb | 89 | ||||
| -rw-r--r-- | gcc/ada/osint.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_scil.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 26 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 3 |
19 files changed, 468 insertions, 124 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index ee3c5e2..3808ff7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,57 @@ 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 * prj-tree.adb: Minor reformatting diff --git a/gcc/ada/exp_atag.adb b/gcc/ada/exp_atag.adb index 314258c..d5cdf0b 100644 --- a/gcc/ada/exp_atag.adb +++ b/gcc/ada/exp_atag.adb @@ -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)), - Selector_Name => - New_Reference_To (RTE_Record_Component (RE_Idepth), Loc)), - - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => Build_TSD (Loc, Duplicate_Subexpr (Typ_Tag_Node)), + Prefix => New_Reference_To (Obj_TSD, Loc), Selector_Name => - New_Reference_To (RTE_Record_Component (RE_Idepth), Loc))); - end Build_Pos; + New_Reference_To + (RTE_Record_Component (RE_Idepth), Loc)), - -- Start of processing for Build_CW_Membership + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Typ_TSD, Loc), + Selector_Name => + New_Reference_To + (RTE_Record_Component (RE_Idepth), Loc))))); - 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; diff --git a/gcc/ada/exp_atag.ads b/gcc/ada/exp_atag.ads index 42ec476..1fa243c 100644 --- a/gcc/ada/exp_atag.ads +++ b/gcc/ada/exp_atag.ads @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index dd74a15..4f0ef91 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 => diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 8f41a63..da6cf5a 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -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. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 535ec4c..bd1748b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 | diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 3285acc..5832a2c 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -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. diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 19e3505..d57c1f0 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -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 \ diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index d14305e..eff9683 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -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 (); diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index eb19250..201e11d 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -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; diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb index aec6d77..a152896 100644 --- a/gcc/ada/opt.adb +++ b/gcc/ada/opt.adb @@ -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; diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 16e2b10..1bb837a 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -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; diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 57df5ea..523852a 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -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 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 - (Canonical_Name'Length <= Suffix'Length - or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1 - .. Canonical_Name'Last) /= Suffix) + 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); diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index 38ae795..f4993ef 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -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; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 071d38f..caa73a0 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -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; diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index cd4e66b..977c07d 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -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); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index dd4aaaf..dcb20e8 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 2e666c4..88655485 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 7ad11e0..cc9d5a0 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -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]"); |