From 2af58f67b743ad50326b0a93dde262515d2145b8 Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:37:08 +0000 Subject: [PATCH] 2007-08-14 Robert Dewar Ed Schonberg * inline.adb, types.ads, inline.ads, frontend.adb, alloc.ads: Suppress unmodified in-out parameter warning in some cases This patch is a also fairly significant change to the way suppressible checks are handled. * checks.ads, checks.adb (Install_Null_Excluding_Check): No check needed for access to concurrent record types generated by the expander. (Generate_Range_Check): When generating a temporary to capture the value of a conversion that requires a range check, set the type of the temporary before rewriting the node, so that the type is always properly placed for back-end use. (Apply_Float_Conversion_Check): Handle case where the conversion is truncating. (Get_Discriminal): Code reformatting. Climb the scope stack looking for a protected type in order to examine its discriminants. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127410 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/alloc.ads | 8 +- gcc/ada/checks.adb | 253 +++++++++++++++++++++++++++++++++++---------------- gcc/ada/checks.ads | 60 ++++++++---- gcc/ada/frontend.adb | 5 +- gcc/ada/inline.adb | 1 - gcc/ada/inline.ads | 23 ++++- gcc/ada/types.ads | 205 +++++++++++++++++++++-------------------- 7 files changed, 350 insertions(+), 205 deletions(-) diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index 4d00671..317d3ff 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -63,15 +63,15 @@ package Alloc is Elmts_Initial : constant := 1_200; -- Elists Elmts_Increment : constant := 100; - Entity_Suppress_Initial : constant := 100; -- Sem - Entity_Suppress_Increment : constant := 200; - Inlined_Bodies_Initial : constant := 50; -- Inline Inlined_Bodies_Increment : constant := 200; Inlined_Initial : constant := 100; -- Inline Inlined_Increment : constant := 100; + In_Out_Warnings_Initial : constant := 100; -- Sem_Warn + In_Out_Warnings_Increment : constant := 100; + Interp_Map_Initial : constant := 200; -- Sem_Type Interp_Map_Increment : constant := 100; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ca05495..027f5cb 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -36,7 +36,6 @@ with Elists; use Elists; with Eval_Fat; use Eval_Fat; with Freeze; use Freeze; with Lib; use Lib; -with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -220,7 +219,7 @@ package body Checks is -- routine. The Do_Static flag indicates that only a static check is -- to be done. - type Check_Type is (Access_Check, Division_Check); + type Check_Type is new Check_Id range Access_Check .. Division_Check; function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean; -- This function is used to see if an access or division by zero check is -- needed. The check is to be applied to a single variable appearing in the @@ -543,12 +542,12 @@ package body Checks is ("?specified address for& may be inconsistent with alignment ", Aexp, E); Error_Msg_FE - ("\?program execution may be erroneous ('R'M 13.3(27))", + ("\?program execution may be erroneous (RM 13.3(27))", Aexp, E); end if; end Compile_Time_Bad_Alignment; - -- Start of processing for Apply_Address_Check + -- Start of processing for Apply_Address_Clause_Check begin -- First obtain expression from address clause @@ -637,7 +636,7 @@ package body Checks is -- maximum alignment is one, since the check will always succeed. -- Note: we do not check for checks suppressed here, since that check - -- was done in Sem_Ch13 when the address clause was proceeds. We are + -- was done in Sem_Ch13 when the address clause was processed. We are -- only called if checks were not suppressed. The reason for this is -- that we have to delay the call to Apply_Alignment_Check till freeze -- time (so that all types etc are elaborated), but we have to check @@ -953,7 +952,7 @@ package body Checks is -- No checks necessary if expression statically null - if Nkind (N) = N_Null then + if Known_Null (N) then if Can_Never_Be_Null (Typ) then Install_Null_Excluding_Check (N); end if; @@ -1007,7 +1006,7 @@ package body Checks is -- unconstrained subtype (through instantiation). If this is a -- discriminated component assigned in the expansion of an aggregate -- in an initialization, the check must be suppressed. This unusual - -- situation requires a predicate of its own (see 7503-008). + -- situation requires a predicate of its own. ---------------------------------------- -- Is_Aliased_Unconstrained_Component -- @@ -1064,7 +1063,7 @@ package body Checks is -- incomplete, then the access value must be null and we suppress the -- check. - if Nkind (N) = N_Null then + if Known_Null (N) then return; elsif Is_Access_Type (S_Typ) then @@ -1388,28 +1387,38 @@ package body Checks is -- to perform a range check in the floating-point domain instead, however: -- (1) The bounds may not be known at compile time - -- (2) The check must take into account possible rounding. + -- (2) The check must take into account rounding or truncation. -- (3) The range of type I may not be exactly representable in F. - -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may - -- not be in range, depending on the sign of I'First and I'Last. + -- (4) For the rounding case, The end-points I'First - 0.5 and + -- I'Last + 0.5 may or may not be in range, depending on the + -- sign of I'First and I'Last. -- (5) X may be a NaN, which will fail any comparison - -- The following steps take care of these issues converting X: + -- The following steps correctly convert X with rounding: -- (1) If either I'First or I'Last is not known at compile time, use -- I'Base instead of I in the next three steps and perform a -- regular range check against I'Range after conversion. -- (2) If I'First - 0.5 is representable in F then let Lo be that -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be - -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words, - -- take one of the closest floating-point numbers to T, and see if - -- it is in range or not. + -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First). + -- In other words, take one of the closest floating-point numbers + -- (which is an integer value) to I'First, and see if it is in + -- range or not. -- (3) If I'Last + 0.5 is representable in F then let Hi be that value -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be - -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last). + -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last). -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo) -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi) + -- For the truncating case, replace steps (2) and (3) as follows: + -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK + -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let + -- Lo_OK be True. + -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK + -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let + -- Hi_OK be False + procedure Apply_Float_Conversion_Check (Ck_Node : Node_Id; Target_Typ : Entity_Id) @@ -1421,9 +1430,16 @@ package body Checks is Target_Base : constant Entity_Id := Implementation_Base_Type (Target_Typ); - Max_Bound : constant Uint := UI_Expon - (Machine_Radix (Expr_Type), - Machine_Mantissa (Expr_Type) - 1) - 1; + Par : constant Node_Id := Parent (Ck_Node); + pragma Assert (Nkind (Par) = N_Type_Conversion); + -- Parent of check node, must be a type conversion + + Truncate : constant Boolean := Float_Truncate (Par); + Max_Bound : constant Uint := + UI_Expon + (Machine_Radix (Expr_Type), + Machine_Mantissa (Expr_Type) - 1) - 1; + -- Largest bound, so bound plus or minus half is a machine number of F Ifirst, Ilast : Uint; @@ -1449,10 +1465,7 @@ package body Checks is -- to prevent overflow during conversion and then perform a -- regular range check against the (dynamic) bounds. - Par : constant Node_Id := Parent (Ck_Node); - pragma Assert (Target_Base /= Target_Typ); - pragma Assert (Nkind (Par) = N_Type_Conversion); Temp : constant Entity_Id := Make_Defining_Identifier (Loc, @@ -1489,9 +1502,18 @@ package body Checks is -- Check against lower bound - if abs (Ifirst) < Max_Bound then + if Truncate and then Ifirst > 0 then + Lo := Pred (Expr_Type, UR_From_Uint (Ifirst)); + Lo_OK := False; + + elsif Truncate then + Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1)); + Lo_OK := True; + + elsif abs (Ifirst) < Max_Bound then Lo := UR_From_Uint (Ifirst) - Ureal_Half; Lo_OK := (Ifirst > 0); + else Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node); Lo_OK := (Lo >= UR_From_Uint (Ifirst)); @@ -1515,7 +1537,15 @@ package body Checks is -- Check against higher bound - if abs (Ilast) < Max_Bound then + if Truncate and then Ilast < 0 then + Hi := Succ (Expr_Type, UR_From_Uint (Ilast)); + Lo_OK := False; + + elsif Truncate then + Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1)); + Hi_OK := True; + + elsif abs (Ilast) < Max_Bound then Hi := UR_From_Uint (Ilast) + Ureal_Half; Hi_OK := (Ilast < 0); else @@ -1636,17 +1666,25 @@ package body Checks is -- Start of processing for Apply_Scalar_Range_Check begin - if Inside_A_Generic then - return; + -- Return if check obviously not needed - -- Return if check obviously not needed. Note that we do not check for - -- the expander being inactive, since this routine does not insert any - -- code, but it does generate useful warnings sometimes, which we would - -- like even if we are in semantics only mode. + if + -- Not needed inside generic - elsif Target_Typ = Any_Type - or else not Is_Scalar_Type (Target_Typ) - or else Raises_Constraint_Error (Expr) + Inside_A_Generic + + -- Not needed if previous error + + or else Target_Typ = Any_Type + or else Nkind (Expr) = N_Error + + -- Not needed for non-scalar type + + or else not Is_Scalar_Type (Target_Typ) + + -- Not needed if we know node raises CE already + + or else Raises_Constraint_Error (Expr) then return; end if; @@ -2498,11 +2536,11 @@ package body Checks is return True; end if; - -- Right operand of test mus be key value (zero or null) + -- Right operand of test must be key value (zero or null) case Check is when Access_Check => - if Nkind (R) /= N_Null then + if not Known_Null (R) then return True; end if; @@ -2512,6 +2550,9 @@ package body Checks is then return True; end if; + + when others => + raise Program_Error; end case; -- Here we have the optimizable case, warn if not short-circuited @@ -2526,6 +2567,9 @@ package body Checks is Error_Msg_N ("Constraint_Error may be raised (zero divide)?", Parent (Nod)); + + when others => + raise Program_Error; end case; if K = N_Op_And then @@ -2682,29 +2726,27 @@ package body Checks is if K /= N_Function_Specification then Expr := Expression (N); - if Present (Expr) - and then Nkind (Expr) = N_Null - then + if Present (Expr) and then Known_Null (Expr) then case K is when N_Component_Declaration | N_Discriminant_Specification => Apply_Compile_Time_Constraint_Error (N => Expr, - Msg => "(Ada 2005) NULL not allowed " & + Msg => "(Ada 2005) null not allowed " & "in null-excluding components?", Reason => CE_Null_Not_Allowed); when N_Object_Declaration => Apply_Compile_Time_Constraint_Error (N => Expr, - Msg => "(Ada 2005) NULL not allowed " & + Msg => "(Ada 2005) null not allowed " & "in null-excluding objects?", Reason => CE_Null_Not_Allowed); when N_Parameter_Specification => Apply_Compile_Time_Constraint_Error (N => Expr, - Msg => "(Ada 2005) NULL not allowed " & + Msg => "(Ada 2005) null not allowed " & "in null-excluding formals?", Reason => CE_Null_Not_Allowed); @@ -4459,6 +4501,12 @@ package body Checks is Reason => Reason))); Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + + -- Set the type of N, because the declaration for Tnn might not + -- be analyzed yet, as is the case if N appears within a record + -- declaration, as a discriminant constraint or expression. + + Set_Etype (N, Target_Base_Type); end; -- At this stage, we know that we have two scalar types, which are @@ -4626,6 +4674,32 @@ package body Checks is end if; end Generate_Range_Check; + ------------------ + -- Get_Check_Id -- + ------------------ + + function Get_Check_Id (N : Name_Id) return Check_Id is + begin + -- For standard check name, we can do a direct computation + + if N in First_Check_Name .. Last_Check_Name then + return Check_Id (N - (First_Check_Name - 1)); + + -- For non-standard names added by pragma Check_Name, search table + + else + for J in All_Checks + 1 .. Check_Names.Last loop + if Check_Names.Table (J) = N then + return J; + end if; + end loop; + end if; + + -- No matching name found + + return No_Check_Id; + end Get_Check_Id; + --------------------- -- Get_Discriminal -- --------------------- @@ -4636,20 +4710,6 @@ package body Checks is Sc : Entity_Id; begin - -- The entity E is the type of a private component of the protected - -- type, or the type of a renaming of that component within a protected - -- operation of that type. - - Sc := Scope (E); - - if Ekind (Sc) /= E_Protected_Type then - Sc := Scope (Sc); - - if Ekind (Sc) /= E_Protected_Type then - return Bound; - end if; - end if; - -- The bound can be a bona fide parameter of a protected operation, -- rather than a prival encoded as an in-parameter. @@ -4657,17 +4717,48 @@ package body Checks is return Bound; end if; + -- Climb the scope stack looking for an enclosing protected type. If + -- we run out of scopes, return the bound itself. + + Sc := Scope (E); + while Present (Sc) loop + if Sc = Standard_Standard then + return Bound; + + elsif Ekind (Sc) = E_Protected_Type then + exit; + end if; + + Sc := Scope (Sc); + end loop; + D := First_Discriminant (Sc); + while Present (D) loop + if Chars (D) = Chars (Bound) then + return New_Occurrence_Of (Discriminal (D), Loc); + end if; - while Present (D) - and then Chars (D) /= Chars (Bound) - loop Next_Discriminant (D); end loop; - return New_Occurrence_Of (Discriminal (D), Loc); + return Bound; end Get_Discriminal; + ---------------------- + -- Get_Range_Checks -- + ---------------------- + + function Get_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Warn_Node : Node_Id := Empty) return Check_Result + is + begin + return Selected_Range_Checks + (Ck_Node, Target_Typ, Source_Typ, Warn_Node); + end Get_Range_Checks; + ------------------ -- Guard_Access -- ------------------ @@ -4717,6 +4808,12 @@ package body Checks is for J in Determine_Range_Cache_N'Range loop Determine_Range_Cache_N (J) := Empty; end loop; + + Check_Names.Init; + + for J in Int range 1 .. All_Checks loop + Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1)); + end loop; end Initialize; ------------------------- @@ -4952,6 +5049,18 @@ package body Checks is return; end if; + -- No check needed for access to concurrent record types generated by + -- the expander. This is not just an optimization (though it does indeed + -- remove junk checks). It also avoids generation of junk warnings. + + if Nkind (N) in N_Has_Chars + and then Chars (N) = Name_uObject + and then Is_Concurrent_Record_Type + (Directly_Designated_Type (Etype (N))) + then + return; + end if; + -- Otherwise install access check Insert_Action (N, @@ -5050,22 +5159,6 @@ package body Checks is return Scope_Suppress (Overflow_Check); end if; end Overflow_Checks_Suppressed; - - ----------------- - -- Range_Check -- - ----------------- - - function Range_Check - (Ck_Node : Node_Id; - Target_Typ : Entity_Id; - Source_Typ : Entity_Id := Empty; - Warn_Node : Node_Id := Empty) return Check_Result - is - begin - return Selected_Range_Checks - (Ck_Node, Target_Typ, Source_Typ, Warn_Node); - end Range_Check; - ----------------------------- -- Range_Checks_Suppressed -- ----------------------------- @@ -5357,7 +5450,7 @@ package body Checks is Next_Index (Indx_Type); end loop; - Get_Index_Bounds (Indx_Type, Lo, Hi); + Get_Index_Bounds (Indx_Type, Lo, Hi); if Nkind (Lo) = N_Identifier and then Ekind (Entity (Lo)) = E_In_Parameter @@ -5542,9 +5635,9 @@ package body Checks is T_Typ := Designated_Type (T_Typ); Do_Access := True; - -- A simple optimization + -- A simple optimization for the null case - if Nkind (Ck_Node) = N_Null then + if Known_Null (Ck_Node) then return Ret_Result; end if; end if; @@ -6193,9 +6286,9 @@ package body Checks is T_Typ := Designated_Type (T_Typ); Do_Access := True; - -- A simple optimization + -- A simple optimization for the null case - if Nkind (Ck_Node) = N_Null then + if Known_Null (Ck_Node) then return Ret_Result; end if; end if; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index d981c3b..18cb6e7 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -36,8 +36,10 @@ -- This always occurs whether checks are suppressed or not. Dynamic range -- checks are, of course, not inserted if checks are suppressed. -with Types; use Types; -with Uintp; use Uintp; +with Namet; use Namet; +with Table; +with Types; use Types; +with Uintp; use Uintp; package Checks is @@ -383,16 +385,28 @@ package Checks is -- values (i.e. the underlying integer value is used). type Check_Result is private; - -- Type used to return result of Range_Check call, for later use in + -- Type used to return result of Get_Range_Checks call, for later use in -- call to Insert_Range_Checks procedure. + function Get_Range_Checks + (Ck_Node : Node_Id; + Target_Typ : Entity_Id; + Source_Typ : Entity_Id := Empty; + Warn_Node : Node_Id := Empty) return Check_Result; + -- Like Apply_Range_Check, except it does not modify anything. Instead + -- it returns an encapsulated result of the check operations for later + -- use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its + -- Sloc is used, in the static case, for the generated warning or error. + -- Additionally, it is used rather than Expr (or Low/High_Bound of Expr) + -- in constructing the check. + procedure Append_Range_Checks (Checks : Check_Result; Stmts : List_Id; Suppress_Typ : Entity_Id; Static_Sloc : Source_Ptr; Flag_Node : Node_Id); - -- Called to append range checks as returned by a call to Range_Check. + -- Called to append range checks as returned by a call to Get_Range_Checks. -- Stmts is a list to which either the dynamic check is appended or the -- raise Constraint_Error statement is appended (for static checks). -- Static_Sloc is the Sloc at which the raise CE node points, Flag_Node is @@ -406,7 +420,7 @@ package Checks is Static_Sloc : Source_Ptr := No_Location; Flag_Node : Node_Id := Empty; Do_Before : Boolean := False); - -- Called to insert range checks as returned by a call to Range_Check. + -- Called to insert range checks as returned by a call to Get_Range_Checks. -- Node is the node after which either the dynamic check is inserted or -- the raise Constraint_Error statement is inserted (for static checks). -- Suppress_Typ is the type to check to determine if checks are suppressed. @@ -417,19 +431,6 @@ package Checks is -- inserted after, if Do_Before is True, the check is inserted before -- Node. - function Range_Check - (Ck_Node : Node_Id; - Target_Typ : Entity_Id; - Source_Typ : Entity_Id := Empty; - Warn_Node : Node_Id := Empty) - return Check_Result; - -- Like Apply_Range_Check, except it does not modify anything. Instead - -- it returns an encapsulated result of the check operations for later - -- use in a call to Insert_Range_Checks. If Warn_Node is non-empty, its - -- Sloc is used, in the static case, for the generated warning or error. - -- Additionally, it is used rather than Expr (or Low/High_Bound of Expr) - -- in constructing the check. - ----------------------- -- Expander Routines -- ----------------------- @@ -659,6 +660,29 @@ package Checks is -- If N is an N_Range node, then Ensure_Valid is called on its bounds, -- if validity checking of operands is enabled. + ----------------------------- + -- Handling of Check Names -- + ----------------------------- + + -- The following table contains Name_Id's for recognized checks. The first + -- entries (corresponding to the values of the subtype Predefined_Check_Id) + -- contain the Name_Id values for the checks that are predefined, including + -- All_Checks (see Types). Remaining entries are those that are introduced + -- by pragma Check_Names. + + package Check_Names is new Table.Table ( + Table_Component_Type => Name_Id, + Table_Index_Type => Check_Id, + Table_Low_Bound => 1, + Table_Initial => 30, + Table_Increment => 200, + Table_Name => "Name_Check_Names"); + + function Get_Check_Id (N : Name_Id) return Check_Id; + -- Function to search above table for matching name. If found returns the + -- corresponding Check_Id value in the range 1 .. Check_Name.Last. If not + -- found returns No_Check_Id. + private type Check_Result is array (Positive range 1 .. 2) of Node_Id; diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index cc5c2cb..7c6676c 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -322,9 +322,10 @@ begin Lib.List; end if; - -- Output any messages for unreferenced entities + -- Output waiting warning messages - Output_Unreferenced_Messages; + Sem_Warn.Output_Non_Modifed_In_Out_Warnings; + Sem_Warn.Output_Unreferenced_Messages; Sem_Warn.Check_Unused_Withs; end if; end if; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index c9b43ba..597c975 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -957,7 +957,6 @@ package body Inline is -- set (that's why we can't simply use a FOR loop here). J := 0; - while J <= Pending_Instantiations.Last and then Serious_Errors_Detected = 0 loop diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads index 115e633..4b80f77 100644 --- a/gcc/ada/inline.ads +++ b/gcc/ada/inline.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -37,8 +37,9 @@ -- Frontend, and thus are not mutually recursive. with Alloc; +with Sem; use Sem; with Table; -with Types; use Types; +with Types; use Types; package Inline is @@ -51,7 +52,7 @@ package Inline is -- global data structure, and the bodies constructed by means of a separate -- analysis and expansion step. - -- See full description in body of Sem_Ch12 for details + -- See full description in body of Sem_Ch12 for more details type Pending_Body_Info is record Inst_Node : Node_Id; @@ -68,6 +69,22 @@ package Inline is -- The semantic unit within which the instantiation is found. Must -- be restored when compiling the body, to insure that internal enti- -- ties use the same counter and are unique over spec and body. + + Scope_Suppress : Suppress_Array; + Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr; + -- Save suppress information at the point of instantiation. Used to + -- properly inherit check status active at this point (see RM 11.5 + -- (7.2/2), AI95-00224-01): + -- + -- "If a checking pragma applies to a generic instantiation, then the + -- checking pragma also applies to the instance. If a checking pragma + -- applies to a call to a subprogram that has a pragma Inline applied + -- to it, then the checking pragma also applies to the inlined + -- subprogram body". + -- + -- This means we have to capture this information from the current scope + -- at the point of instantiation. + end record; package Pending_Instantiations is new Table.Table ( diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 6fe6011..4d5ebfc 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -31,13 +31,13 @@ -- -- ------------------------------------------------------------------------------ --- This package contains host independent type definitions which are used --- in more than one unit in the compiler. They are gathered here for easy +-- This package contains host independent type definitions which are used in +-- more than one unit in the compiler. They are gathered here for easy -- reference, though in some cases the full description is found in the --- relevant module which implements the definition. The main reason that --- they are not in their "natural" specs is that this would cause a lot --- of inter-spec dependencies, and in particular some awkward circular --- dependencies would have to be dealt with. +-- relevant module which implements the definition. The main reason that they +-- are not in their "natural" specs is that this would cause a lot of inter- +-- spec dependencies, and in particular some awkward circular dependencies +-- would have to be dealt with. -- WARNING: There is a C version of this package. Any changes to this source -- file must be properly reflected in the C header file types.h declarations. @@ -108,9 +108,9 @@ package Types is -- Line terminator characters (LF, VT, FF, CR) -- -- This definition is dubious now that we have two more wide character - -- sequences that constitute a line terminator. Every reference to - -- this subtype needs checking to make sure the wide character case - -- is handled appropriately. ??? + -- sequences that constitute a line terminator. Every reference to this + -- subtype needs checking to make sure the wide character case is handled + -- appropriately. ??? subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); @@ -134,9 +134,9 @@ package Types is -- Types Used for Text Buffer Handling -- ----------------------------------------- - -- We can't use type String for text buffers, since we must use the - -- standard 32-bit integer as an index value, since we count on all - -- index values being the same size. + -- We can not use type String for text buffers, since we must use the + -- standard 32-bit integer as an index value, since we count on all index + -- values being the same size. type Text_Ptr is new Int; -- Type used for subscripts in text buffer @@ -167,9 +167,9 @@ package Types is type Physical_Line_Number is range 1 .. Int'Last; for Physical_Line_Number'Size use 32; - -- Line number type, used for storing physical line numbers (i.e. - -- line numbers in the physical file being compiled, unaffected by - -- the presence of source reference pragmas. + -- Line number type, used for storing physical line numbers (i.e. line + -- numbers in the physical file being compiled, unaffected by the presence + -- of source reference pragmas. type Column_Number is range 0 .. 32767; for Column_Number'Size use 16; @@ -183,20 +183,20 @@ package Types is subtype Source_Buffer is Text_Buffer; -- Type used to store text of a source file . The buffer for the main -- source (the source specified on the command line) has a lower bound - -- starting at zero. Subsequent subsidiary sources have lower bounds - -- which are one greater than the previous upper bound. + -- starting at zero. Subsequent subsidiary sources have lower bounds which + -- are one greater than the previous upper bound. subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); -- This is a virtual type used as the designated type of the access -- type Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; - -- Pointer to source buffer. We use virtual origin addressing for - -- source buffers, with thin pointers. The pointer points to a virtual - -- instance of type Big_Source_Buffer, where the actual type is in fact - -- of type Source_Buffer. The address is adjusted so that the virtual - -- origin addressing works correctly. See Osint.Read_Source_Buffer for - -- further details. + -- Pointer to source buffer. We use virtual origin addressing for source + -- buffers, with thin pointers. The pointer points to a virtual instance + -- of type Big_Source_Buffer, where the actual type is in fact of type + -- Source_Buffer. The address is adjusted so that the virtual origin + -- addressing works correctly. See Osint.Read_Source_Buffer for further + -- details. subtype Source_Ptr is Text_Ptr; -- Type used to represent a source location, which is a subscript of a @@ -215,10 +215,10 @@ package Types is -- mode and the corresponding source line in -gnatD mode). Standard_Location : constant Source_Ptr := -2; - -- Used for all nodes in the representation of package Standard other - -- than nodes representing the contents of Standard.ASCII. Note that - -- testing for <= Standard_Location tests for both Standard_Location - -- and for Standard_ASCII_Location. + -- Used for all nodes in the representation of package Standard other than + -- nodes representing the contents of Standard.ASCII. Note that testing for + -- a value being <= Standard_Location tests for both Standard_Location and + -- for Standard_ASCII_Location. Standard_ASCII_Location : constant Source_Ptr := -3; -- Used for all nodes in the presentation of package Standard.ASCII @@ -266,13 +266,13 @@ package Types is -- List_Id and Node_Id values (see further description below). List_High_Bound : constant := 0; - -- Maximum List_Id subscript value. This allows up to 100 million list - -- Id values, which is in practice infinite, and there is no need to - -- check the range. The range overlaps the node range by one element - -- (with value zero), which is used both for the Empty node, and for - -- indicating no list. The fact that the same value is used is convenient - -- because it means that the default value of Empty applies to both nodes - -- and lists, and also is more efficient to test for. + -- Maximum List_Id subscript value. This allows up to 100 million list Id + -- values, which is in practice infinite, and there is no need to check the + -- range. The range overlaps the node range by one element (with value + -- zero), which is used both for the Empty node, and for indicating no + -- list. The fact that the same value is used is convenient because it + -- means that the default value of Empty applies to both nodes and lists, + -- and also is more efficient to test for. Node_Low_Bound : constant := 0; -- The tree Id values start at zero, because we use zero for Empty (to @@ -413,10 +413,10 @@ package Types is ------------------------------ -- List_Id values are used to identify node lists in the tree. They are - -- subscripts into the Lists table declared in package Tree. Note that - -- the special value Error_List is a subscript in this table, but the - -- value No_List is *not* a valid subscript, and any attempt to apply - -- list operations to No_List will cause a (detected) error. + -- subscripts into the Lists table declared in package Tree. Note that the + -- special value Error_List is a subscript in this table, but the value + -- No_List is *not* a valid subscript, and any attempt to apply list + -- operations to No_List will cause a (detected) error. type List_Id is range List_Low_Bound .. List_High_Bound; -- Type used to identify a node list @@ -439,10 +439,10 @@ package Types is -- Types for Elists Package -- ------------------------------ - -- Element list Id values are used to identify element lists stored in - -- the tree (see package Tree for further details). They are formed by - -- adding a bias (Element_List_Bias) to subscript values in the same - -- array that is used for node list headers. + -- Element list Id values are used to identify element lists stored in the + -- tree (see package Tree for further details). They are formed by adding a + -- bias (Element_List_Bias) to subscript values in the same array that is + -- used for node list headers. type Elist_Id is range Elist_Low_Bound .. Elist_High_Bound; -- Type used to identify an element list (Elist header table subscript) @@ -471,8 +471,8 @@ package Types is -- Types for Stringt Package -- ------------------------------- - -- String_Id values are used to identify entries in the strings table. - -- They are subscripts into the strings table defined in package Strings. + -- String_Id values are used to identify entries in the strings table. They + -- are subscripts into the strings table defined in package Strings. -- Note that with only a few exceptions, which are clearly documented, the -- type String_Id should be regarded as a private type. In particular it is @@ -492,15 +492,15 @@ package Types is -- Character Code Type -- ------------------------- - -- The type Char is used for character data internally in the compiler, - -- but character codes in the source are represented by the Char_Code - -- type. Each character literal in the source is interpreted as being one - -- of the 16#8000_0000 possible Wide_Wide_Character codes, and a unique - -- Integer Value is assigned, corresponding to the UTF_32 value, which - -- also correspondds to the POS value in the Wide_Wide_Character type, - -- and also corresponds to the POS value in the Wide_Character and - -- Character types for values that are in appropriate range. String - -- literals are similarly interpreted as a sequence of such codes. + -- The type Char is used for character data internally in the compiler, but + -- character codes in the source are represented by the Char_Code type. + -- Each character literal in the source is interpreted as being one of the + -- 16#8000_0000 possible Wide_Wide_Character codes, and a unique Integer + -- Value is assigned, corresponding to the UTF_32 value, which also + -- correspondds to the POS value in the Wide_Wide_Character type, and also + -- corresponds to the POS value in the Wide_Character and Character types + -- for values that are in appropriate range. String literals are similarly + -- interpreted as a sequence of such codes. type Char_Code_Base is mod 2 ** 32; for Char_Code_Base'Size use 32; @@ -530,7 +530,7 @@ package Types is pragma Inline (Get_Character); -- For a character C that is in Character range (see above function), this -- function returns the corresponding Character value. It is an error to - -- call Get_Character if C is not in C haracter range + -- call Get_Character if C is not in Character range. function Get_Wide_Character (C : Char_Code) return Wide_Character; -- For a character C that is in Wide_Character range (see above function), @@ -596,11 +596,10 @@ package Types is -- Type used to represent time stamp Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' '); - -- Type used to represent an empty or missing time stamp. Looks less - -- than any real time stamp if two time stamps are compared. Note that - -- although this is not a private type, clients should not rely on the - -- exact way in which this string is represented, and instead should - -- use the subprograms below. + -- Value representing an empty or missing time stamp. Looks less than any + -- real time stamp if two time stamps are compared. Note that although this + -- is not private, clients should not rely on the exact way in which this + -- string is represented, and instead should use the subprograms below. Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0'); -- This is used for dummy time stamp values used in the D lines for @@ -611,14 +610,15 @@ package Types is function ">=" (Left, Right : Time_Stamp_Type) return Boolean; function "<" (Left, Right : Time_Stamp_Type) return Boolean; function ">" (Left, Right : Time_Stamp_Type) return Boolean; - -- Comparison functions on time stamps. Note that two time stamps - -- are defined as being equal if they have the same day/month/year - -- and the hour/minutes/seconds values are within 2 seconds of one - -- another. This deals with rounding effects in library file time - -- stamps caused by copying operations during installation. We have - -- particularly noticed that WinNT seems susceptible to such changes. - -- Note: the Empty_Time_Stamp value looks equal to itself, and less - -- than any non-empty time stamp value. + -- Comparison functions on time stamps. Note that two time stamps are + -- defined as being equal if they have the same day/month/year and the + -- hour/minutes/seconds values are within 2 seconds of one another. This + -- deals with rounding effects in library file time stamps caused by + -- copying operations during installation. We have particularly noticed + -- that WinNT seems susceptible to such changes. + -- + -- Note : the Empty_Time_Stamp value looks equal to itself, and less than + -- any non-empty time stamp value. procedure Split_Time_Stamp (TS : Time_Stamp_Type; @@ -644,21 +644,32 @@ package Types is -- Types used for Pragma Suppress Management -- ----------------------------------------------- - type Check_Id is - (Access_Check, - Accessibility_Check, - Alignment_Check, - Discriminant_Check, - Division_Check, - Elaboration_Check, - Index_Check, - Length_Check, - Overflow_Check, - Range_Check, - Storage_Check, - Tag_Check, - Validity_Check, - All_Checks); + type Check_Id is new Nat; + -- Type used to represent a check id + + No_Check_Id : constant := 0; + -- Check_Id value used to indicate no check + + Access_Check : constant := 1; + Accessibility_Check : constant := 2; + Alignment_Check : constant := 3; + Discriminant_Check : constant := 4; + Division_Check : constant := 5; + Elaboration_Check : constant := 6; + Index_Check : constant := 7; + Length_Check : constant := 8; + Overflow_Check : constant := 9; + Range_Check : constant := 10; + Storage_Check : constant := 11; + Tag_Check : constant := 12; + Validity_Check : constant := 13; + -- Values used to represent individual predefined checks + + All_Checks : constant := 14; + -- Value used to represent All_Checks value + + subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks; + -- Subtype for predefined checks, including All_Checks -- The following array contains an entry for each recognized check name -- for pragma Suppress. It is used to represent current settings of scope @@ -672,7 +683,7 @@ package Types is -- We recognize only an explicit suppress of Elaboration_Check as a signal -- that the static elaboration checking should skip a compile time check. - type Suppress_Array is array (Check_Id) of Boolean; + type Suppress_Array is array (Predefined_Check_Id) of Boolean; pragma Pack (Suppress_Array); -- To add a new check type to GNAT, the following steps are required: @@ -691,19 +702,19 @@ package Types is -- throughout the compiler or in other GNAT tools. Unrecoverable_Error : exception; - -- This exception is raised to immediately terminate the compilation - -- of the current source program. Used in situations where things are - -- bad enough that it doesn't seem worth continuing (e.g. max errors - -- reached, or a required file is not found). Also raised when the - -- compiler finds itself in trouble after an error (see Comperr). + -- This exception is raised to immediately terminate the compilation of the + -- current source program. Used in situations where things are bad enough + -- that it doesn't seem worth continuing (e.g. max errors reached, or a + -- required file is not found). Also raised when the compiler finds itself + -- in trouble after an error (see Comperr). Terminate_Program : exception; -- This exception is raised to immediately terminate the tool being - -- executed. Each tool where this exception may be raised must have - -- a single exception handler that contains only a null statement and - -- that is the last statement of the program. If needed, procedure - -- Set_Exit_Status is called with the appropriate exit status before - -- raising Terminate_Program. + -- executed. Each tool where this exception may be raised must have a + -- single exception handler that contains only a null statement and that is + -- the last statement of the program. If needed, procedure Set_Exit_Status + -- is called with the appropriate exit status before raising + -- Terminate_Program. --------------------------------- -- Parameter Mechanism Control -- @@ -722,10 +733,10 @@ package Types is -- Run-Time Exception Codes -- ------------------------------ - -- When the code generator generates a run-time exception, it provides - -- a reason code which is one of the following. This reason code is used - -- to select the appropriate run-time routine to be called, determining - -- both the exception to be raised, and the message text to be added. + -- When the code generator generates a run-time exception, it provides a + -- reason code which is one of the following. This reason code is used to + -- select the appropriate run-time routine to be called, determining both + -- the exception to be raised, and the message text to be added. -- The prefix CE/PE/SE indicates the exception to be raised -- CE = Constraint_Error -- 2.7.4