diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c6e49b6ddab..95b7d02d131 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,73 @@ +2015-05-26 Robert Dewar + + * sem_aggr.adb (Resolve_Array_Aggregate): Defend against + bad bounds. + * debug.adb: Document -gnatd.k. + * erroutc.adb (Set_Msg_Insertion_Line_Number): Implement -gnatd.k. + +2015-05-26 Robert Dewar + + * gnat1drv.adb (Gnat1drv): Provide new arguments for + Get_Target_Parameters. + * restrict.adb (Set_Restriction_No_Specification_Of_Aspect): + new procedure. + (Set_Restriction_No_Use_Of_Attribute): new procedure. + * restrict.ads (Set_Restriction_No_Specification_Of_Aspect): + new procedure. + (Set_Restriction_No_Use_Of_Attribute): new procedure. + * s-rident.ads (Integer_Parameter_Restrictions): New subtype. + * targparm.adb (Get_Target_Parameters): Allow new restriction + pragmas No_Specification_Of_Aspect No_Use_Of_Attribute + No_Use_Of_Pragma. + * targparm.ads: New parameters for Get_Target_Parameters. + * tbuild.adb (Set_NOD): New name for Set_RND. + (Set_NSA): New procedure. + (Set_NUA): New procedure. + (Set_NUP): New procedure. + * tbuild.ads (Make_SC): Minor reformatting. + (Set_NOD): New name for Set_RND. + (Set_NSA, Set_NUA, Set_NUP): New procedure. + +2015-05-26 Ed Schonberg + + * a-stwise.adb (Find_Token): If source'first is not positive, + an exception must be raised, as specified by RM 2005 A.4.3 + (68/1). This must be checked explicitly, given that run-time + files are normally compiled without constraint checks. + * a-stzsea.adb (Find_Token): Ditto. + +2015-05-26 Ed Schonberg + + * sem_util.ads sem_util.adb (Is_Current_Instance): New predicate + to fully implement RM 8.6 (17/3). which earlier only applied + to synchronized types. Used to preanalyze aspects that include + current instances of types, such as Predicate and Invariant. + * sem_res.adb (Resolve_Entity_Name): Use Is_Current_Instance. + * sem_ch13.adb (Add_Predicates): In ASIS mode, preserve original + expression of aspect and analyze it to provide proper type + information. + +2015-05-26 Robert Dewar + + * rtsfind.ads: Add entries for RE_Exn[_Long]_Float. + * s-exnllf.adb (Exn_Float): New function. + (Exn_Long_Float): New function. + (Exn_Long_Long_Float): Rewritten interface. + (Exp): New name for what used to be Exn_Long_Long_Float. + * s-exnllf.ads (Exn_Float): New function. + (Exn_Long_Float): New function. + +2015-05-26 Ed Schonberg + + * sem_ch8.adb (Find_Selected_Component): Do not emit an error + on a selected component when the prefix is a type name that is + a Current_Instance. + * einfo.ads: Minor grammar fix. + +2015-05-26 Doug Rupp + + * init.c [vxworks] (sysLib.h): Only for x86. + 2015-05-26 Doug Rupp * init-vxsim.c (CPU): define as __VXSIM_CPU__ diff --git a/gcc/ada/a-stwise.adb b/gcc/ada/a-stwise.adb index adc8e5f621a..09ac7830c8a 100644 --- a/gcc/ada/a-stwise.adb +++ b/gcc/ada/a-stwise.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -252,8 +252,18 @@ package body Ada.Strings.Wide_Search is -- Here if no token found - First := Source'First; - Last := 0; + -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if + -- Source'First is not positive and is assigned to First. Formulation + -- is slightly different in RM 2012, but the intent seems similar, so + -- we check explicitly for that condition. + + if Source'First not in Positive then + raise Constraint_Error; + + else + First := Source'First; + Last := 0; + end if; end Find_Token; ----------- diff --git a/gcc/ada/a-stzsea.adb b/gcc/ada/a-stzsea.adb index 31285fb264e..7b4f63507fd 100644 --- a/gcc/ada/a-stzsea.adb +++ b/gcc/ada/a-stzsea.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -253,8 +253,18 @@ package body Ada.Strings.Wide_Wide_Search is -- Here if no token found - First := Source'First; - Last := 0; + -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if + -- Source'First is not positive and is assigned to First. Formulation + -- is slightly different in RM 2012, but the intent seems similar, so + -- we check explicitly for that condition. + + if Source'First not in Positive then + raise Constraint_Error; + + else + First := Source'First; + Last := 0; + end if; end Find_Token; ----------- diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d3380747266..87e0de74dc6 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -101,7 +101,7 @@ package body Debug is -- d.h Minimize the creation of public internal symbols for concatenation -- d.i Ignore Warnings pragmas -- d.j Generate listing of frontend inlined calls - -- d.k + -- d.k Kill referenced run-time library unit line numbers -- d.l Use Ada 95 semantics for limited function returns -- d.m For -gnatl, print full source only for main unit -- d.n Print source file names @@ -534,6 +534,9 @@ package body Debug is -- be used in particular to disable Warnings (Off) to check if any of -- these statements are inappropriate. + -- d.k If an error message contains a reference to a location in an + -- internal unit, then suppress the line number in this reference. + -- d.j Generate listing of frontend inlined calls and inline calls passed -- to the backend. This is useful to locate skipped calls that must be -- inlined by the frontend. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7795bf933ad..845a83d392e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3952,7 +3952,7 @@ package Einfo is -- end and zero is a legitimate value for a type with one value. -- Root_Type (synthesized) --- Applies to all type entities. For class-wide types, return the root +-- Applies to all type entities. For class-wide types, returns the root -- type of the class covered by the CW type, otherwise returns the -- ultimate derivation ancestor of the given type. This function -- preserves the view, i.e. the Root_Type of a partial view is the diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 041158ae485..d74a3ee9834 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -34,6 +34,7 @@ with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; with Err_Vars; use Err_Vars; +with Fname; use Fname; with Namet; use Namet; with Opt; use Opt; with Output; use Output; @@ -1035,6 +1036,8 @@ package body Erroutc is procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is Sindex_Loc : Source_File_Index; Sindex_Flag : Source_File_Index; + Fname : File_Name_Type; + Int_File : Boolean; procedure Set_At; -- Outputs "at " unless last characters in buffer are " from ". Certain @@ -1083,22 +1086,25 @@ package body Erroutc is if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then Set_At; - Get_Name_String - (Reference_Name (Get_Source_File_Index (Loc))); + Fname := Reference_Name (Get_Source_File_Index (Loc)); + Int_File := Is_Internal_File_Name (Fname); + Get_Name_String (Fname); Set_Msg_Name_Buffer; - Set_Msg_Char (':'); + + if not (Int_File and Debug_Flag_Dot_K) then + Set_Msg_Char (':'); + Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); + end if; -- If in current file, add text "at line " else Set_At; Set_Msg_Str ("line "); + Int_File := False; + Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); end if; - -- Output line number for reference - - Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); - -- Deal with the instantiation case. We may have a reference to, -- e.g. a type, that is declared within a generic template, and -- what we are really referring to is the occurrence in an instance. diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 70df5633fbf..709cf2d9412 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -954,13 +954,20 @@ begin System_Source_File_Index := S; end if; + -- Call to get target parameters. Note that the actual interface + -- routines in Tbuild here. They can't be in this procedure + -- because of accessibility issues. + Targparm.Get_Target_Parameters (System_Text => Source_Text (S), Source_First => Source_First (S), Source_Last => Source_Last (S), Make_Id => Tbuild.Make_Id'Access, Make_SC => Tbuild.Make_SC'Access, - Set_RND => Tbuild.Set_RND'Access); + Set_NOD => Tbuild.Set_NOD'Access, + Set_NSA => Tbuild.Set_NSA'Access, + Set_NUA => Tbuild.Set_NUA'Access, + Set_NUP => Tbuild.Set_NUP'Access); -- Acquire configuration pragma information from Targparm diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 4731959b019..5f05258377c 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1694,15 +1694,17 @@ __gnat_install_handler () __gnat_handler_installed = 1; } -/*******************/ -/* VxWorks Section */ -/*******************/ +/*************************************/ +/* VxWorks Section (including Vx653) */ +/*************************************/ #elif defined(__vxworks) #include #include +#if defined (i386) || defined (__i386__) #include +#endif #ifndef __RTP__ #include diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb index 661a05ada53..2dae272ebbc 100644 --- a/gcc/ada/restrict.adb +++ b/gcc/ada/restrict.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; with Atree; use Atree; with Casing; use Casing; with Einfo; use Einfo; @@ -35,7 +34,6 @@ with Lib; use Lib; with Opt; use Opt; with Sinfo; use Sinfo; with Sinput; use Sinput; -with Snames; use Snames; with Stand; use Stand; with Uname; use Uname; @@ -111,6 +109,8 @@ package body Restrict is No_Use_Of_Pragma : array (Pragma_Id) of Source_Ptr := (others => No_Location); + -- Source location of pragma No_Use_Of_Pragma for given pragma, a value + -- of Sysstem_Location indicates occurrence in system.ads. No_Use_Of_Pragma_Warning : array (Pragma_Id) of Boolean := (others => False); @@ -1569,6 +1569,13 @@ package body Restrict is No_Specification_Of_Aspect_Set := True; end Set_Restriction_No_Specification_Of_Aspect; + procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is + begin + No_Specification_Of_Aspects (A_Id) := System_Location; + No_Specification_Of_Aspect_Warning (A_Id) := False; + No_Specification_Of_Aspect_Set := True; + end Set_Restriction_No_Specification_Of_Aspect; + ----------------------------------------- -- Set_Restriction_No_Use_Of_Attribute -- ----------------------------------------- @@ -1588,6 +1595,13 @@ package body Restrict is end if; end Set_Restriction_No_Use_Of_Attribute; + procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is + begin + No_Use_Of_Attribute_Set := True; + No_Use_Of_Attribute (A_Id) := System_Location; + No_Use_Of_Attribute_Warning (A_Id) := False; + end Set_Restriction_No_Use_Of_Attribute; + -------------------------------------- -- Set_Restriction_No_Use_Of_Pragma -- -------------------------------------- @@ -1607,6 +1621,13 @@ package body Restrict is end if; end Set_Restriction_No_Use_Of_Pragma; + procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is + begin + No_Use_Of_Pragma_Set := True; + No_Use_Of_Pragma_Warning (A_Id) := False; + No_Use_Of_Pragma (A_Id) := System_Location; + end Set_Restriction_No_Use_Of_Pragma; + -------------------------------- -- Check_SPARK_05_Restriction -- -------------------------------- diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads index e683a715480..4871b6ffe84 100644 --- a/gcc/ada/restrict.ads +++ b/gcc/ada/restrict.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -25,11 +25,13 @@ -- This package deals with the implementation of the Restrictions pragma -with Namet; use Namet; -with Rident; use Rident; +with Aspects; use Aspects; +with Namet; use Namet; +with Rident; use Rident; +with Snames; use Snames; with Table; -with Types; use Types; -with Uintp; use Uintp; +with Types; use Types; +with Uintp; use Uintp; package Restrict is @@ -463,6 +465,9 @@ package Restrict is -- case of a Restriction_Warnings pragma specifying this restriction and -- False for a Restrictions pragma specifying this restriction. + procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id); + -- Version used by Get_Target_Parameters (via Tbuild) + procedure Set_Restriction_No_Use_Of_Attribute (N : Node_Id; Warning : Boolean); @@ -470,6 +475,9 @@ package Restrict is -- No_Use_Of_Attribute. Caller has verified that this is a valid attribute -- designator. + procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id); + -- Version used by Get_Target_Parameters (via Tbuild) + procedure Set_Restriction_No_Use_Of_Entity (Entity : Node_Id; Warn : Boolean; @@ -488,6 +496,9 @@ package Restrict is -- N is the node id for the identifier in a pragma Restrictions for -- No_Use_Of_Pragma. Caller has verified that this is a valid pragma id. + procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id); + -- Version used in call from Get_Target_Parameters (via Tbuild). + function Tasking_Allowed return Boolean; pragma Inline (Tasking_Allowed); -- Tests if tasking operations are allowed by the current restrictions diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index f1a40821dd8..bc4674a6052 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -863,6 +863,8 @@ package Rtsfind is RE_Exn_Integer, -- System.Exn_Int + RE_Exn_Float, -- System.Exn_LLF + RE_Exn_Long_Float, -- System.Exn_LLF RE_Exn_Long_Long_Float, -- System.Exn_LLF RE_Exn_Long_Long_Integer, -- System.Exn_LLI @@ -2098,6 +2100,8 @@ package Rtsfind is RE_Exn_Integer => System_Exn_Int, + RE_Exn_Float => System_Exn_LLF, + RE_Exn_Long_Float => System_Exn_LLF, RE_Exn_Long_Long_Float => System_Exn_LLF, RE_Exn_Long_Long_Integer => System_Exn_LLI, diff --git a/gcc/ada/s-exnllf.adb b/gcc/ada/s-exnllf.adb index c6765e8fe9a..a4386e813f0 100644 --- a/gcc/ada/s-exnllf.adb +++ b/gcc/ada/s-exnllf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -29,8 +29,76 @@ -- -- ------------------------------------------------------------------------------ +-- Note: the reason for treating exponents in the range 0 .. 4 specially is +-- to ensure identical results to the static inline expansion in the case of +-- a compile time known exponent in this range. The use of Float'Machine and +-- Long_Float'Machine is to avoid unwanted extra precision in the results. + package body System.Exn_LLF is + function Exp + (Left : Long_Long_Float; + Right : Integer) return Long_Long_Float; + -- Common routine used if Right not in 0 .. 4 + + --------------- + -- Exn_Float -- + --------------- + + function Exn_Float + (Left : Float; + Right : Integer) return Float + is + Temp : Float; + begin + case Right is + when 0 => + return 1.0; + when 1 => + return Left; + when 2 => + return Float'Machine (Left * Left); + when 3 => + return Float'Machine (Left * Left * Left); + when 4 => + Temp := Float'Machine (Left * Left); + return Float'Machine (Temp * Temp); + when others => + return + Float'Machine + (Float (Exp (Long_Long_Float (Left), Right))); + end case; + end Exn_Float; + + -------------------- + -- Exn_Long_Float -- + -------------------- + + function Exn_Long_Float + (Left : Long_Float; + Right : Integer) return Long_Float + is + Temp : Long_Float; + begin + case Right is + when 0 => + return 1.0; + when 1 => + return Left; + when 2 => + return Long_Float'Machine (Left * Left); + when 3 => + return Long_Float'Machine (Left * Left * Left); + when 4 => + Temp := Long_Float'Machine (Left * Left); + return Long_Float'Machine (Temp * Temp); + when others => + return + Long_Float'Machine + (Long_Float (Exp (Long_Long_Float (Left), Right))); + end case; + end Exn_Long_Float; + ------------------------- -- Exn_Long_Long_Float -- ------------------------- @@ -38,6 +106,33 @@ package body System.Exn_LLF is function Exn_Long_Long_Float (Left : Long_Long_Float; Right : Integer) return Long_Long_Float + is + Temp : Long_Long_Float; + begin + case Right is + when 0 => + return 1.0; + when 1 => + return Left; + when 2 => + return Left * Left; + when 3 => + return Left * Left * Left; + when 4 => + Temp := Left * Left; + return Temp * Temp; + when others => + return Exp (Left, Right); + end case; + end Exn_Long_Long_Float; + + --------- + -- Exp -- + --------- + + function Exp + (Left : Long_Long_Float; + Right : Integer) return Long_Long_Float is Result : Long_Long_Float := 1.0; Factor : Long_Long_Float := Left; @@ -91,6 +186,6 @@ package body System.Exn_LLF is return 1.0 / Result; end; end if; - end Exn_Long_Long_Float; + end Exp; end System.Exn_LLF; diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads index ba2828277b7..dcbbae56f79 100644 --- a/gcc/ada/s-exnllf.ads +++ b/gcc/ada/s-exnllf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -29,11 +29,19 @@ -- -- ------------------------------------------------------------------------------ --- Long_Long_Float exponentiation (checks off) +-- [Long_[Long_]]Float exponentiation (checks off) package System.Exn_LLF is pragma Pure; + function Exn_Float + (Left : Float; + Right : Integer) return Float; + + function Exn_Long_Float + (Left : Long_Float; + Right : Integer) return Long_Float; + function Exn_Long_Long_Float (Left : Long_Long_Float; Right : Integer) return Long_Long_Float; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 3b777f706ca..7b18d2f4089 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -255,6 +255,11 @@ package System.Rident is No_Specification_Of_Aspect .. Max_Storage_At_Blocking; -- All restrictions that take a parameter + subtype Integer_Parameter_Restrictions is + Restriction_Id range + Max_Protected_Entries .. Max_Storage_At_Blocking; + -- All restrictions taking an integer parameter + subtype Checked_Parameter_Restrictions is All_Parameter_Restrictions range Max_Protected_Entries .. Max_Entry_Queue_Length; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index f841b422e50..5300d3ab87f 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -2304,6 +2304,16 @@ package body Sem_Aggr is if Others_Present then Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + -- Abandon processing if either bound is already signalled as + -- an error (prevents junk cascaded messages and blow ups). + + if Nkind (Aggr_Low) = N_Error + or else + Nkind (Aggr_High) = N_Error + then + return False; + end if; + -- No others clause present else @@ -2314,6 +2324,16 @@ package body Sem_Aggr is if Others_Allowed then Get_Index_Bounds (Index_Constr, Aggr_Low, Aggr_High); + -- Abandon processing if either bound is already signalled + -- as an error (stop junk cascaded messages and blow ups). + + if Nkind (Aggr_Low) = N_Error + or else + Nkind (Aggr_High) = N_Error + then + return False; + end if; + -- If others allowed, and no others present, then the array -- should cover all index values. If it does not, we will -- get a length check warning, but there is two cases where diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8e1dcc13d2b..cc0248aa469 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -8437,17 +8437,20 @@ package body Sem_Ch13 is begin Ritem := First_Rep_Item (Typ); + while Present (Ritem) loop if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate then - -- Acquire arguments + -- Acquire arguments. The expression itself is copied for use + -- in the predicate function, to preserve the orignal version + -- for ASIS use. Arg1 := First (Pragma_Argument_Associations (Ritem)); Arg2 := Next (Arg1); Arg1 := Get_Pragma_Arg (Arg1); - Arg2 := Get_Pragma_Arg (Arg2); + Arg2 := New_Copy_Tree (Get_Pragma_Arg (Arg2)); -- See if this predicate pragma is for the current type or for -- its full view. A predicate on a private completion is placed @@ -8472,9 +8475,20 @@ package body Sem_Ch13 is if From_Aspect_Specification (Ritem) then declare - Aitem : Node_Id; + Aitem : Node_Id; + Orig_Expr : constant Node_Id := + Expression (Corresponding_Aspect (Ritem)); begin + + -- For ASIS use, perform semantic analysis of the + -- original predicate expression, which is otherwise + -- not utilized. + + if ASIS_Mode then + Preanalyze_And_Resolve (Orig_Expr); + end if; + -- Loop to find corresponding aspect, note that this -- must be present given the pragma is marked delayed. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index aeda8544bbb..d353bc9018a 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6950,6 +6950,13 @@ package body Sem_Ch8 is if P_Name = Any_Id then null; + -- It is not an error if the prefix is the current instance of + -- type name, e.g. the expression of a type aspect, when it is + -- analyzed for ASIS use. + + elsif Is_Entity_Name (P) and then Is_Current_Instance (P) then + null; + elsif Ekind (P_Name) = E_Void then Premature_Usage (P); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index fe739341b8f..0e92867dcc6 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6991,18 +6991,12 @@ package body Sem_Res is Set_Entity_With_Checks (N, E); Eval_Entity_Name (N); - -- Case of subtype name appearing as an operand in expression + -- Case of (sub)type name appearing in a context where an expression + -- is expected. This is legal if occurrence is a current instance. + -- See RM 8.6 (17/3). elsif Is_Type (E) then - - -- Allow use of subtype if it is a concurrent type where we are - -- currently inside the body. This will eventually be expanded into a - -- call to Self (for tasks) or _object (for protected objects). Any - -- other use of a subtype is invalid. - - if Is_Concurrent_Type (E) - and then In_Open_Scopes (E) - then + if Is_Current_Instance (N) then null; -- Any other use is an error diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b2f6a5727da..0a5c8a4b3c0 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10951,6 +10951,46 @@ package body Sem_Util is and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; + ------------------------- + -- Is_Current_Instance -- + ------------------------- + + function Is_Current_Instance (N : Node_Id) return Boolean is + Typ : constant Entity_Id := Entity (N); + P : Node_Id; + + begin + -- Simplest case : entity is a concurrent type and we are currently + -- inside the body. This will eventually be expanded into a + -- call to Self (for tasks) or _object (for protected objects). + + if Is_Concurrent_Type (Typ) and then In_Open_Scopes (Typ) then + return True; + + else + -- Check whether the context is a (sub)type declaration for the + -- type entity. + + P := Parent (N); + while Present (P) loop + if Nkind_In (P, N_Full_Type_Declaration, + N_Private_Type_Declaration, + N_Subtype_Declaration) + and then Comes_From_Source (P) + and then Defining_Entity (P) = Typ + then + return True; + end if; + + P := Parent (P); + end loop; + end if; + + -- In any other context this is not a current occurence + + return False; + end Is_Current_Instance; + -------------------- -- Is_Declaration -- -------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f899e759c8f..02623722f27 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1237,6 +1237,12 @@ package Sem_Util is -- First determine whether type T is an interface and then check whether -- it is of protected, synchronized or task kind. + function Is_Current_Instance (N : Node_Id) return Boolean; + -- Predicate is true if N legally denotes a type name within its own + -- declaration. Prior to Ada 2012 this covered only synchronized type + -- declarations. In Ada2012 it also covers type and subtype declarations + -- with aspects: Invariant, Predicate, and Default_Initial_Condition. + function Is_Declaration (N : Node_Id) return Boolean; -- Determine whether arbitrary node N denotes a declaration diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 8824f4fc2ef..562eb74e8c3 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, 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- -- @@ -154,7 +154,10 @@ package body Targparm is procedure Get_Target_Parameters (Make_Id : Make_Id_Type := null; Make_SC : Make_SC_Type := null; - Set_RND : Set_RND_Type := null) + Set_NOD : Set_NOD_Type := null; + Set_NSA : Set_NSA_Type := null; + Set_NUA : Set_NUA_Type := null; + Set_NUP : Set_NUP_Type := null) is Text : Source_Buffer_Ptr; Hi : Source_Ptr; @@ -181,7 +184,10 @@ package body Targparm is Source_Last => Hi, Make_Id => Make_Id, Make_SC => Make_SC, - Set_RND => Set_RND); + Set_NOD => Set_NOD, + Set_NSA => Set_NSA, + Set_NUA => Set_NUA, + Set_NUP => Set_NUP); end Get_Target_Parameters; -- Version where caller supplies system.ads text @@ -192,7 +198,10 @@ package body Targparm is Source_Last : Source_Ptr; Make_Id : Make_Id_Type := null; Make_SC : Make_SC_Type := null; - Set_RND : Set_RND_Type := null) + Set_NOD : Set_NOD_Type := null; + Set_NSA : Set_NSA_Type := null; + Set_NUA : Set_NUA_Type := null; + Set_NUP : Set_NUP_Type := null) is P : Source_Ptr; -- Scans source buffer containing source of system.ads @@ -203,6 +212,48 @@ package body Targparm is Result : Boolean; -- Records boolean from system line + OK : Boolean; + -- Status result from Set_NUP/NSA/NUA call + + PR_Start : Source_Ptr; + -- Pointer to ( following pragma Restrictions + + procedure Collect_Name; + -- Scan a name starting at System_Text (P), and put Name in Name_Buffer, + -- with Name_Len being length, folded to lower case. On return P points + -- just past the last character (which should be a right paren). + + ------------------ + -- Collect_Name -- + ------------------ + + procedure Collect_Name is + begin + Name_Len := 0; + loop + if System_Text (P) in 'a' .. 'z' + or else + System_Text (P) = '_' + or else + System_Text (P) in '0' .. '9' + then + Name_Buffer (Name_Len + 1) := System_Text (P); + + elsif System_Text (P) in 'A' .. 'Z' then + Name_Buffer (Name_Len + 1) := + Character'Val (Character'Pos (System_Text (P)) + 32); + + else + exit; + end if; + + P := P + 1; + Name_Len := Name_Len + 1; + end loop; + end Collect_Name; + + -- Start of processing for Get_Target_Parameters + begin if Parameters_Obtained then return; @@ -261,6 +312,9 @@ package body Targparm is elsif System_Text (P .. P + 20) = "pragma Restrictions (" then P := P + 21; + PR_Start := P - 1; + + -- Boolean restrictions Rloop : for K in All_Boolean_Restrictions loop declare @@ -285,7 +339,9 @@ package body Targparm is null; end loop Rloop; - Ploop : for K in All_Parameter_Restrictions loop + -- Restrictions taking integer parameter + + Ploop : for K in Integer_Parameter_Restrictions loop declare Rname : constant String := All_Parameter_Restrictions'Image (K); @@ -400,23 +456,119 @@ package body Targparm is P := P + 1; end loop; - Set_RND (Unit); + Set_NOD (Unit); goto Line_Loop_Continue; end; + + -- No_Specification_Of_Aspect case + + elsif System_Text (P .. P + 29) = "No_Specification_Of_Aspect => " + then + P := P + 30; + + -- Skip this processing (and simply ignore the pragma), if + -- caller did not supply the subprogram we need to process + -- such lines. + + if Set_NSA = null then + goto Line_Loop_Continue; + end if; + + -- We have scanned + -- "pragma Restrictions (No_Specification_Of_Aspect =>" + + Collect_Name; + + if System_Text (P) /= ')' then + goto Bad_Restrictions_Pragma; + + else + Set_NSA (Name_Find, OK); + + if OK then + goto Line_Loop_Continue; + else + goto Bad_Restrictions_Pragma; + end if; + end if; + + -- No_Use_Of_Attribute case + + elsif System_Text (P .. P + 22) = "No_Use_Of_Attribute => " then + P := P + 23; + + -- Skip this processing (and simply ignore No_Use_Of_Attribute + -- lines) if caller did not supply the subprogram we need to + -- process such lines. + + if Set_NUA = null then + goto Line_Loop_Continue; + end if; + + -- We have scanned + -- "pragma Restrictions (No_Use_Of_Attribute =>" + + Collect_Name; + + if System_Text (P) /= ')' then + goto Bad_Restrictions_Pragma; + + else + Set_NUA (Name_Find, OK); + + if OK then + goto Line_Loop_Continue; + else + goto Bad_Restrictions_Pragma; + end if; + end if; + + -- No_Use_Of_Pragma case + + elsif System_Text (P .. P + 19) = "No_Use_Of_Pragma => " then + P := P + 20; + + -- Skip this processing (and simply ignore No_Use_Of_Pragma + -- lines) if caller did not supply the subprogram we need to + -- process such lines. + + if Set_NUP = null then + goto Line_Loop_Continue; + end if; + + -- We have scanned + -- "pragma Restrictions (No_Use_Of_Pragma =>" + + Collect_Name; + + if System_Text (P) /= ')' then + goto Bad_Restrictions_Pragma; + + else + Set_NUP (Name_Find, OK); + + if OK then + goto Line_Loop_Continue; + else + goto Bad_Restrictions_Pragma; + end if; + end if; end if; -- Here if unrecognizable restrictions pragma form + <> + Set_Standard_Error; Write_Line ("fatal error: system.ads is incorrectly formatted"); Write_Str ("unrecognized or incorrect restrictions pragma: "); - while System_Text (P) /= ')' - and then - System_Text (P) /= ASCII.LF + P := PR_Start; loop + exit when System_Text (P) = ASCII.LF; Write_Char (System_Text (P)); + exit when System_Text (P) = ')'; P := P + 1; end loop; diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads index 03dfb515349..18c6c577be6 100644 --- a/gcc/ada/targparm.ads +++ b/gcc/ada/targparm.ads @@ -615,28 +615,53 @@ package Targparm is -- selected component with Sloc value System_Location and given Prefix -- (Pre) and Selector (Sel) values. - type Set_RND_Type is access procedure (Unit : Node_Id); + type Set_NOD_Type is access procedure (Unit : Node_Id); -- Parameter type for Get_Target_Parameters that records a Restriction -- No_Dependence for the given unit (identifier or selected component). + type Set_NSA_Type is access procedure (Asp : Name_Id; OK : out Boolean); + -- Parameter type for Get_Target_Parameters that records a Restriction + -- No_Specificaztion_Of_Aspect. Asp is the pragma name. OK is set True + -- if this is an OK aspect name, and False if it is not an aspect name. + + type Set_NUA_Type is access procedure (Attr : Name_Id; OK : out Boolean); + -- Parameter type for Get_Target_Parameters that records a Restriction + -- No_Use_Of_Attribute. Prag is the attribute name. OK is set True if + -- this is an OK attribute name, and False if it is not an attribute name. + + type Set_NUP_Type is access procedure (Prag : Name_Id; OK : out Boolean); + -- Parameter type for Get_Target_Parameters that records a Restriction + -- No_Use_Of_Pragma. Prag is the pragma name. OK is set True if this is + -- an OK pragma name, and False if it is not a recognized pragma name. + procedure Get_Target_Parameters (System_Text : Source_Buffer_Ptr; Source_First : Source_Ptr; Source_Last : Source_Ptr; Make_Id : Make_Id_Type := null; Make_SC : Make_SC_Type := null; - Set_RND : Set_RND_Type := null); - -- Called at the start of execution to obtain target parameters from - -- the source of package System. The parameters provide the source - -- text to be scanned (in System_Text (Source_First .. Source_Last)). - -- if the three subprograms are left at their default value of null, - -- Get_Target_Parameters will ignore pragma Restrictions No_Dependence - -- lines, otherwise it will use these three subprograms to record them. + Set_NOD : Set_NOD_Type := null; + Set_NSA : Set_NSA_Type := null; + Set_NUA : Set_NUA_Type := null; + Set_NUP : Set_NUP_Type := null); + -- Called at the start of execution to obtain target parameters from the + -- source of package System. The parameters provide the source text to be + -- scanned (in System_Text (Source_First .. Source_Last)). if the three + -- subprograms Make_Id, Make_SC, and Set_NOD are left at their default + -- value of null, Get_Target_Parameters will ignore pragma Restrictions + -- No_Dependence lines, otherwise it will use these three subprograms to + -- record them. Similarly if Set_NUP is left at its default value of null, + -- then any occurrences of pragma Restrictions (No_Use_Of_Pragma => XXX) + -- will be ignored, otherwise it will use this procedure to record the + -- pragma. Similarly for the NSA and NUA cases. procedure Get_Target_Parameters (Make_Id : Make_Id_Type := null; Make_SC : Make_SC_Type := null; - Set_RND : Set_RND_Type := null); + Set_NOD : Set_NOD_Type := null; + Set_NSA : Set_NSA_Type := null; + Set_NUA : Set_NUA_Type := null; + Set_NUP : Set_NUP_Type := null); -- This version reads in system.ads using Osint. The idea is that the -- caller uses the first version if they have to read system.ads anyway -- (e.g. the compiler) and uses this simpler interface if system.ads is diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index cd535cf9ab5..a7c528391c1 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -24,6 +24,7 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Aspects; use Aspects; with Csets; use Csets; with Einfo; use Einfo; with Elists; use Elists; @@ -779,13 +780,56 @@ package body Tbuild is end OK_Convert_To; ------------- - -- Set_RND -- + -- Set_NOD -- ------------- - procedure Set_RND (Unit : Node_Id) is + procedure Set_NOD (Unit : Node_Id) is begin Set_Restriction_No_Dependence (Unit, Warn => False); - end Set_RND; + end Set_NOD; + + ------------- + -- Set_NSA -- + ------------- + + procedure Set_NSA (Asp : Name_Id; OK : out Boolean) is + Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp); + begin + if Asp_Id = No_Aspect then + OK := False; + else + OK := True; + Set_Restriction_No_Specification_Of_Aspect (Asp_Id); + end if; + end Set_NSA; + + ------------- + -- Set_NUA -- + ------------- + + procedure Set_NUA (Attr : Name_Id; OK : out Boolean) is + begin + if Is_Attribute_Name (Attr) then + OK := True; + Set_Restriction_No_Use_Of_Attribute (Get_Attribute_Id (Attr)); + else + OK := False; + end if; + end Set_NUA; + + ------------- + -- Set_NUP -- + ------------- + + procedure Set_NUP (Prag : Name_Id; OK : out Boolean) is + begin + if Is_Pragma_Name (Prag) then + OK := True; + Set_Restriction_No_Use_Of_Pragma (Get_Pragma_Id (Prag)); + else + OK := False; + end if; + end Set_NUP; -------------------------- -- Unchecked_Convert_To -- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 26869ba8dc8..632cff11180 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -347,9 +347,12 @@ package Tbuild is function Make_Id (Str : Text_Buffer) return Node_Id; function Make_SC (Pre, Sel : Node_Id) return Node_Id; - procedure Set_RND (Unit : Node_Id); + procedure Set_NOD (Unit : Node_Id); + procedure Set_NSA (Asp : Name_Id; OK : out Boolean); + procedure Set_NUA (Attr : Name_Id; OK : out Boolean); + procedure Set_NUP (Prag : Name_Id; OK : out Boolean); -- Subprograms for call to Get_Target_Parameters in Gnat1drv, see spec - -- of package Targparm for full description of these three subprograms. + -- of package Targparm for full description of these four subprograms. -- These have to be declared at the top level of a package (accessibility -- issues), and Gnat1drv is a procedure, so they can't go there.