+2011-08-01 Vincent Celier <celier@adacore.com>
+
+ * s-parame-vms-ia64.ads: Fix typo in comment
+ Minor reformatting
+ * s-parame-vms-restrict.ads: Removed, unused.
+
+2011-08-01 Javier Miranda <miranda@adacore.com>
+
+ * 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 <schonberg@adacore.com>
* sem_ch6.adb (Fully_Conformant_Expressions): handle quantified
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.
---------------------------
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;
--------------------------
----------------------------
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));
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
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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 --
--- <http://www.gnu.org/licenses/>. --
--- --
--- 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;
-- 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
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
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 --
-----------------------
-- 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
-- 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));
OSDN Git Service
