From: Arnaud Charlet Date: Mon, 1 Aug 2011 15:45:30 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4230bdb759b717d87186ccb1df225f241322386b;p=gcc.git [multiple changes] 2011-08-01 Vincent Celier * s-parame-vms-ia64.ads: Fix typo in comment Minor reformatting * s-parame-vms-restrict.ads: Removed, unused. 2011-08-01 Javier Miranda * exp_ch3.adb (Is_Variable_Size_Array): Remove local subprogram Is_Constant_Bound. * sem_ch3.adb (Constrain_Index): Remove side effects in the evaluation of the bounds. * sem_ch3.ads, sem_ch3.adb (Is_Constant_Bound): New extended version of the subprogram that was previously located inside function Exp_Ch3.Is_Variable_Size_Array. Moved here since it is shared by routines of sem_ch3 and exp_ch3. * sem_aux.ads (Constant_Value): Fix typo in comment. * checks.adb (Generate_Index_Checks): New implementation which, for array objects with constant bounds, generates the runtime check referencing the bounds of the array type. For other cases this routine provides its previous behavior obtaining such values from the array object. * sem_res.adb (Set_Slice_Subtype): Link a copied range subtree with its parent type. * atree.adb (New_Copy): Reset flag Is_Overloaded in the new copy since we cannot have semantic interpretations of the new node. From-SVN: r177051 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b3e29a1a847..dcbdad8c4a9 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2011-08-01 Vincent Celier + + * s-parame-vms-ia64.ads: Fix typo in comment + Minor reformatting + * s-parame-vms-restrict.ads: Removed, unused. + +2011-08-01 Javier Miranda + + * exp_ch3.adb + (Is_Variable_Size_Array): Remove local subprogram Is_Constant_Bound. + * sem_ch3.adb + (Constrain_Index): Remove side effects in the evaluation of the bounds. + * sem_ch3.ads, sem_ch3.adb + (Is_Constant_Bound): New extended version of the subprogram that was + previously located inside function Exp_Ch3.Is_Variable_Size_Array. + Moved here since it is shared by routines of sem_ch3 and exp_ch3. + * sem_aux.ads (Constant_Value): Fix typo in comment. + * checks.adb (Generate_Index_Checks): New implementation which, for + array objects with constant bounds, generates the runtime check + referencing the bounds of the array type. For other cases this routine + provides its previous behavior obtaining such values from the array + object. + * sem_res.adb (Set_Slice_Subtype): Link a copied range subtree with its + parent type. + * atree.adb (New_Copy): Reset flag Is_Overloaded in the new copy since + we cannot have semantic interpretations of the new node. + 2011-08-01 Ed Schonberg * sem_ch6.adb (Fully_Conformant_Expressions): handle quantified diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 5426fab7d02..7852d1de1d5 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -1202,6 +1202,13 @@ package body Atree is Nodes.Table (New_Id).Rewrite_Ins := False; pragma Debug (New_Node_Debugging_Output (New_Id)); + -- Clear Is_Overloaded since we cannot have semantic interpretations + -- of this new node + + if Nkind (Source) in N_Subexpr then + Set_Is_Overloaded (New_Id, False); + end if; + -- Always clear Has_Aspects, the caller must take care of copying -- aspects if this is required for the particular situation. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 46a966827fc..e45f013fd2e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4556,75 +4556,171 @@ package body Checks is --------------------------- procedure Generate_Index_Checks (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - A : constant Node_Id := Prefix (N); - Sub : Node_Id; - Ind : Nat; - Num : List_Id; + + function Entity_Of_Prefix return Entity_Id; + -- Returns the entity of the prefix of N (or Empty if not found) + + function Entity_Of_Prefix return Entity_Id is + P : Node_Id := Prefix (N); + begin + while not Is_Entity_Name (P) loop + if not Nkind_In (P, N_Selected_Component, + N_Indexed_Component) + then + return Empty; + end if; + + P := Prefix (P); + end loop; + + return Entity (P); + end Entity_Of_Prefix; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + A : constant Node_Id := Prefix (N); + A_Ent : constant Entity_Id := Entity_Of_Prefix; + Sub : Node_Id; begin - -- Ignore call if index checks suppressed for array object or type + -- Ignore call if the prefix is not an array since we have a serious + -- error in the sources. Ignore it also if index checks are suppressed + -- for array object or type. - if (Is_Entity_Name (A) and then Index_Checks_Suppressed (Entity (A))) + if not Is_Array_Type (Etype (A)) + or else (Present (A_Ent) + and then Index_Checks_Suppressed (A_Ent)) or else Index_Checks_Suppressed (Etype (A)) then return; end if; - -- Generate the checks + -- Generate a raise of constraint error with the appropriate reason and + -- a condition of the form: + + -- Base_Type(Sub) not in array'range (subscript) + + -- Note that the reason we generate the conversion to the base type here + -- is that we definitely want the range check to take place, even if it + -- looks like the subtype is OK. Optimization considerations that allow + -- us to omit the check have already been taken into account in the + -- setting of the Do_Range_Check flag earlier on. Sub := First (Expressions (N)); - Ind := 1; - while Present (Sub) loop + + -- Handle string literals + + if Ekind (Etype (A)) = E_String_Literal_Subtype then if Do_Range_Check (Sub) then Set_Do_Range_Check (Sub, False); - -- Force evaluation except for the case of a simple name of a - -- non-volatile entity. + -- For string literals we obtain the bounds of the string from the + -- associated subtype. - if not Is_Entity_Name (Sub) - or else Treat_As_Volatile (Entity (Sub)) - then - Force_Evaluation (Sub); - end if; + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => + Convert_To (Base_Type (Etype (Sub)), + Duplicate_Subexpr_Move_Checks (Sub)), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Etype (A), Loc), + Attribute_Name => Name_Range)), + Reason => CE_Index_Check_Failed)); + end if; - -- Generate a raise of constraint error with the appropriate - -- reason and a condition of the form: + -- General case - -- Base_Type(Sub) not in array'range (subscript) + else + declare + A_Idx : Node_Id := Empty; + A_Range : Node_Id; + Ind : Nat; + Num : List_Id; + Range_N : Node_Id; - -- Note that the reason we generate the conversion to the base - -- type here is that we definitely want the range check to take - -- place, even if it looks like the subtype is OK. Optimization - -- considerations that allow us to omit the check have already - -- been taken into account in the setting of the Do_Range_Check - -- flag earlier on. + begin + A_Idx := First_Index (Etype (A)); + Ind := 1; + while Present (Sub) loop + if Do_Range_Check (Sub) then + Set_Do_Range_Check (Sub, False); - if Ind = 1 then - Num := No_List; - else - Num := New_List (Make_Integer_Literal (Loc, Ind)); - end if; + -- Force evaluation except for the case of a simple name of + -- a non-volatile entity. - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Not_In (Loc, - Left_Opnd => - Convert_To (Base_Type (Etype (Sub)), - Duplicate_Subexpr_Move_Checks (Sub)), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr_Move_Checks (A, Name_Req => True), - Attribute_Name => Name_Range, - Expressions => Num)), - Reason => CE_Index_Check_Failed)); - end if; + if not Is_Entity_Name (Sub) + or else Treat_As_Volatile (Entity (Sub)) + then + Force_Evaluation (Sub); + end if; - Ind := Ind + 1; - Next (Sub); - end loop; + if Nkind (A_Idx) = N_Range then + A_Range := A_Idx; + + elsif Nkind (A_Idx) = N_Identifier + or else Nkind (A_Idx) = N_Expanded_Name + then + A_Range := Scalar_Range (Entity (A_Idx)); + + else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication); + A_Range := Range_Expression (Constraint (A_Idx)); + end if; + + -- For array objects with constant bounds we can generate + -- the index check using the bounds of the type of the index + + if Present (A_Ent) + and then Ekind (A_Ent) = E_Variable + and then Is_Constant_Bound (Low_Bound (A_Range)) + and then Is_Constant_Bound (High_Bound (A_Range)) + then + Range_N := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Etype (A_Idx), Loc), + Attribute_Name => Name_Range); + + -- For arrays with non-constant bounds we cannot generate + -- the index check using the bounds of the type of the index + -- since it may reference discriminants of some enclosing + -- type. We obtain the bounds directly from the prefix + -- object. + + else + if Ind = 1 then + Num := No_List; + else + Num := New_List (Make_Integer_Literal (Loc, Ind)); + end if; + + Range_N := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (A, Name_Req => True), + Attribute_Name => Name_Range, + Expressions => Num); + end if; + + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => + Convert_To (Base_Type (Etype (Sub)), + Duplicate_Subexpr_Move_Checks (Sub)), + Right_Opnd => Range_N), + Reason => CE_Index_Check_Failed)); + end if; + + A_Idx := Next_Index (A_Idx); + Ind := Ind + 1; + Next (Sub); + end loop; + end; + end if; end Generate_Index_Checks; -------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 4ee02b78041..c1e83bbb42a 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7580,37 +7580,8 @@ package body Exp_Ch3 is ---------------------------- function Is_Variable_Size_Array (E : Entity_Id) return Boolean is - - function Is_Constant_Bound (Exp : Node_Id) return Boolean; - -- To simplify handling of array components. Determines whether the - -- given bound is constant (a constant or enumeration literal, or an - -- integer literal) as opposed to per-object, through an expression - -- or a discriminant. - - ----------------------- - -- Is_Constant_Bound -- - ----------------------- - - function Is_Constant_Bound (Exp : Node_Id) return Boolean is - begin - if Nkind (Exp) = N_Integer_Literal then - return True; - else - return - Is_Entity_Name (Exp) - and then Present (Entity (Exp)) - and then - (Ekind (Entity (Exp)) = E_Constant - or else Ekind (Entity (Exp)) = E_Enumeration_Literal); - end if; - end Is_Constant_Bound; - - -- Local variables - Idx : Node_Id; - -- Start of processing for Is_Variable_Sized_Array - begin pragma Assert (Is_Array_Type (E)); diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads index 89c49ba7bea..8612e4283c1 100644 --- a/gcc/ada/s-parame-vms-ia64.ads +++ b/gcc/ada/s-parame-vms-ia64.ads @@ -114,11 +114,10 @@ package System.Parameters is subtype C_Address is System.Address range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1; for C_Address'Object_Size use ptr_bits; - -- Number of bits in Interaces.C pointers, normally a standard address, + -- Number of bits in Interfaces.C pointers, normally a standard address, -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. - -- System.Aux_DEC.Short_Address can't be used because of elaboration - -- circularity. + -- with legacy code. System.Aux_DEC.Short_Address can't be used because of + -- elaboration circularity. C_Malloc_Linkname : constant String := "__gnat_malloc32"; -- Name of runtime function used to allocate such a pointer diff --git a/gcc/ada/s-parame-vms-restrict.ads b/gcc/ada/s-parame-vms-restrict.ads deleted file mode 100644 index 7c3cbd67794..00000000000 --- a/gcc/ada/s-parame-vms-restrict.ads +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2010, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version for restricted tasking - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -with System.Aux_DEC; - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Ratio is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Ratio : constant Ratio := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ptr_bits : constant := 32; - subtype C_Address is System.Short_Address; - -- Number of bits in Interaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. - - C_Malloc_Linkname : constant String := "__gnat_malloc32"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := True; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := True; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 512; - -- This constant specifies the maximum number of characters to allow in an - -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the - -- default minimum of 200 to allow for the length of chained VMS condition - -- handling messages. - -end System.Parameters; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index e54016c9971..21acc70abc0 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -97,7 +97,7 @@ package Sem_Aux is -- Returns the argument unchanged if it is not one of these cases. function Constant_Value (Ent : Entity_Id) return Node_Id; - -- Id is a variable, constant, named integer, or named real entity. This + -- Ent is a variable, constant, named integer, or named real entity. This -- call obtains the initialization expression for the entity. Will return -- Empty for for a deferred constant whose full view is not available or -- in some other cases of internal entities, which cannot be treated as diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index c101d93c602..fe23c3be837 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -11449,6 +11449,15 @@ package body Sem_Ch3 is Resolve_Discrete_Subtype_Indication (S, T); R := Range_Expression (Constraint (S)); + -- Capture values of bounds and generate temporaries for them if + -- needed, since checks may cause duplication of the expressions + -- which must not be reevaluated. + + if Expander_Active then + Force_Evaluation (Low_Bound (R)); + Force_Evaluation (High_Bound (R)); + end if; + elsif Nkind (S) = N_Discriminant_Association then -- Syntactically valid in subtype indication @@ -15534,6 +15543,31 @@ package body Sem_Ch3 is return Assoc_List; end Inherit_Components; + ----------------------- + -- Is_Constant_Bound -- + ----------------------- + + function Is_Constant_Bound (Exp : Node_Id) return Boolean is + begin + if Compile_Time_Known_Value (Exp) then + return True; + + elsif Is_Entity_Name (Exp) + and then Present (Entity (Exp)) + then + return Is_Constant_Object (Entity (Exp)) + or else Ekind (Entity (Exp)) = E_Enumeration_Literal; + + elsif Nkind (Exp) in N_Binary_Op then + return Is_Constant_Bound (Left_Opnd (Exp)) + and then Is_Constant_Bound (Right_Opnd (Exp)) + and then Scope (Entity (Exp)) = Standard_Standard; + + else + return False; + end if; + end Is_Constant_Bound; + ----------------------- -- Is_Null_Extension -- ----------------------- diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 46605b3716c..064b0f76ce6 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -170,6 +170,12 @@ package Sem_Ch3 is -- Given a discriminant somewhere in the Typ_For_Constraint tree and a -- Constraint, return the value of that discriminant. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; + -- Determines whether the given bound is a compile-time known value, or a + -- constant entity, or an enumeration literal, or an expression composed + -- of constant-bound subexpressions which are evaluated by means of + -- standard operators. + function Is_Null_Extension (T : Entity_Id) return Boolean; -- Returns True if the tagged type T has an N_Full_Type_Declaration that -- is a null extension, meaning that it has an extension part without any diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ce5323d85cd..2b44924825a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9478,6 +9478,7 @@ package body Sem_Res is -- scheme). Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); + Set_Parent (Scalar_Range (Index_Subtype), Index_Subtype); Set_Etype (Index_Subtype, Index_Type); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type));