+2014-07-18 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch3.adb, g-memdum.ads, i-cstrea.ads: Minor reformatting.
+
+2014-07-18 Robert Dewar <dewar@adacore.com>
+
+ * einfo.adb (Has_Static_Predicate): New function.
+ (Set_Has_Static_Predicate): New procedure.
+ * einfo.ads (Has_Static_Predicate): New flag.
+ * sem_ch13.adb (Is_Predicate_Static): New function
+ (Build_Predicate_Functions): Use Is_Predicate_Static to reorganize
+ (Add_Call): Minor change in Sloc of generated expression
+ (Add_Predicates): Remove setting of Static_Pred, no longer used.
+ * sem_ch4.adb (Has_Static_Predicate): Removed this function,
+ replace by use of the entity flag Has_Static_Predicate_Aspect.
+ * sem_eval.adb (Eval_Static_Predicate_Check): Check real case
+ and issue warning that predicate is not checked for now.
+ * sem_eval.ads (Eval_Static_Predicate_Check): Fix comments in
+ spec.
+ * sem_util.adb (Check_Expression_Against_Static_Predicate):
+ Carry out check for any case where there is a static predicate,
+ and output appropriate message.
+ * sinfo.ads: Minor comment corrections.
+
+2014-07-18 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Expand_Freeze_Record_Type): If the type is derived
+ from an untagged private type whose full view is tagged, the type
+ is marked tagged for layout reasons, but it has no dispatch table,
+ so Set_All_DT_Position must not be called.
+ * exp_ch13.adb: If the freeze node is for a type internal to a
+ record declaration, as is the case for a class-wide subtype
+ of a parent component, the relevant scope is the scope of the
+ enclosing record.
+
2014-07-18 Thomas Quinot <quinot@adacore.com>
* g-memdum.adb, g-memdum.ads: Code clean ups.
-- Has_Aliased_Components Flag135
-- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
- -- Is_Packed_Array_Impl_Type Flag138
+ -- Is_Packed_Array_Impl_Type Flag138
-- Has_Biased_Representation Flag139
-- Has_Complex_Representation Flag140
-- SPARK_Aux_Pragma_Inherited Flag266
-- Has_Shift_Operator Flag267
-- Is_Independent Flag268
+ -- Has_Static_Predicate Flag269
-- (unused) Flag1
-- (unused) Flag2
-- (unused) Flag3
- -- (unused) Flag269
-- (unused) Flag270
-- (unused) Flag271
return Flag211 (Id);
end Has_Static_Discriminants;
+ function Has_Static_Predicate (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag269 (Id);
+ end Has_Static_Predicate;
+
function Has_Static_Predicate_Aspect (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
Set_Flag211 (Id, V);
end Set_Has_Static_Discriminants;
+ procedure Set_Has_Static_Predicate (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag269 (Id, V);
+ end Set_Has_Static_Predicate;
+
procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
W ("Has_Specified_Stream_Read", Flag192 (Id));
W ("Has_Specified_Stream_Write", Flag193 (Id));
W ("Has_Static_Discriminants", Flag211 (Id));
+ W ("Has_Static_Predicate", Flag269 (Id));
W ("Has_Static_Predicate_Aspect", Flag259 (Id));
W ("Has_Storage_Size_Clause", Flag23 (Id));
W ("Has_Stream_Size_Clause", Flag184 (Id));
W ("Is_Optional_Parameter", Flag134 (Id));
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
- W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
+ W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Predicate_Function", Flag255 (Id));
W ("Is_Predicate_Function_M", Flag256 (Id));
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect
--- applies to the type. Note that we can tell if a dynamic predicate is
--- present by looking at Has_Predicates and Static_Predicate, but that
--- could have come from a Predicate aspect or pragma, and we need to
--- record the difference so that we can use the right set of check
--- policies to figure out if the predicate is active.
+-- was explicitly applied to the type. Generally we treat predicates as
+-- static if possible, regardless of whether they are specified using
+-- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate
+-- can be treated as static (i.e. its expression is predicate-static),
+-- then the flag Has_Static_Predicate will be set True. But there are
+-- cases where legality is affected by the presence of an explicit
+-- Dynamic_Predicate aspect. For example, even if a predicate looks
+-- static, you can't use it in a case statement if there is an explicit
+-- Dynamic_Predicate aspect specified. So test Has_Static_Predicate if
+-- you just want to know if the predicate can be evaluated statically,
+-- but test Has_Dynamic_Predicate_Aspect to enforce legality rules about
+-- the use of dynamic predicates.
-- Has_Entries (synthesized)
-- Applies to concurrent types. True if any entries are declared
-- case of a variant record, the component list can be trimmed down to
-- include only the components corresponding to these discriminants.
+-- Has_Static_Predicate (Flag269)
+-- Defined in all types and subtypes. Set if the type (which must be
+-- a discrete, real, or string subtype) has a static predicate, i.e. a
+-- predicate whose expression is predicate-static. This can result from
+-- use of a Predicate, Static_Predicate or Dynamic_Predicate aspect. We
+-- can distinguish these cases by testing Has_Static_Predicate_Aspect
+-- and Has_Dynamic_Predicate_Aspect. See description of the latter flag
+-- for further information on dynamic predicates which are also static.
+
-- Has_Static_Predicate_Aspect (Flag259)
-- Defined in all types and subtypes. Set if a Static_Predicate aspect
-- applies to the type. Note that we can tell if a static predicate is
--- present by looking at Has_Predicates and Static_Predicate, but that
--- could have come from a Predicate aspect or pragma, and we need to
--- record the difference so that we can use the right set of check
--- policies to figure out if the predicate is active.
+-- present by looking at Has_Static_Predicate, but this could have come
+-- from a Predicate aspect or pragma or even from a Dynamic_Predicate
+-- aspect. When we need to know the difference (e.g. to know what set of
+-- check policies apply, use this flag and Has_Dynamic_Predicate_Aspect
+-- to determine which case we have.
-- Has_Storage_Size_Clause (Flag23) [implementation base type only]
-- Defined in task types and access types. It is set if a Storage_Size
-- the corresponding parameter entities in the spec.
-- Static_Predicate (List25)
--- Defined in discrete types/subtypes with predicates (Has_Predicates
--- set). Set if the type/subtype has a static predicate. Points to a
--- list of expression and N_Range nodes that represent the predicate
--- in canonical form. The canonical form has entries sorted in ascending
--- order, with duplicates eliminated, and adjacent ranges coalesced, so
--- that there is always a gap in the values between successive entries.
--- The entries in this list are fully analyzed and typed with the base
--- type of the subtype. Note that all entries are static and have values
--- within the subtype range.
+-- Defined in discrete types/subtypes with static predicates (with the
+-- two flags Has_Predicates set and Has_Static_Predicate set). Set if the
+-- type/subtype has a static predicate. Points to a list of expression
+-- and N_Range nodes that represent the predicate in canonical form. The
+-- canonical form has entries sorted in ascending order, with duplicates
+-- eliminated, and adjacent ranges coalesced, so that there is always a
+-- gap in the values between successive entries. The entries in this list
+-- are fully analyzed and typed with the base type of the subtype. Note
+-- that all entries are static and have values within the subtype range.
-- Status_Flag_Or_Transient_Decl (Node15)
-- Defined in variables and constants. Applies to objects that require
-- Has_Specified_Stream_Output (Flag191)
-- Has_Specified_Stream_Read (Flag192)
-- Has_Specified_Stream_Write (Flag193)
+ -- Has_Static_Predicate (Flag269)
-- Has_Static_Predicate_Aspect (Flag259)
-- Has_Task (Flag30) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
function Has_Specified_Stream_Read (Id : E) return B;
function Has_Specified_Stream_Write (Id : E) return B;
function Has_Static_Discriminants (Id : E) return B;
+ function Has_Static_Predicate (Id : E) return B;
function Has_Static_Predicate_Aspect (Id : E) return B;
function Has_Storage_Size_Clause (Id : E) return B;
function Has_Stream_Size_Clause (Id : E) return B;
procedure Set_Has_Specified_Stream_Read (Id : E; V : B := True);
procedure Set_Has_Specified_Stream_Write (Id : E; V : B := True);
procedure Set_Has_Static_Discriminants (Id : E; V : B := True);
+ procedure Set_Has_Static_Predicate (Id : E; V : B := True);
procedure Set_Has_Static_Predicate_Aspect (Id : E; V : B := True);
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
pragma Inline (Has_Specified_Stream_Read);
pragma Inline (Has_Specified_Stream_Write);
pragma Inline (Has_Static_Discriminants);
+ pragma Inline (Has_Static_Predicate);
pragma Inline (Has_Static_Predicate_Aspect);
pragma Inline (Has_Storage_Size_Clause);
pragma Inline (Has_Stream_Size_Clause);
pragma Inline (Set_Has_Specified_Stream_Read);
pragma Inline (Set_Has_Specified_Stream_Write);
pragma Inline (Set_Has_Static_Discriminants);
+ pragma Inline (Set_Has_Static_Predicate);
pragma Inline (Set_Has_Static_Predicate_Aspect);
pragma Inline (Set_Has_Storage_Size_Clause);
pragma Inline (Set_Has_Stream_Size_Clause);
return;
end if;
+ -- The entity may be a subtype declared for a constrained record
+ -- component, in which case the relevant scope is the scope of
+ -- the record. This happens for class-wide subtypes created for
+ -- a constrained type extension with inherited discriminants.
+
+ if Is_Type (E_Scope)
+ and then Ekind (E_Scope) not in Concurrent_Kind
+ then
+ E_Scope := Scope (E_Scope);
+ end if;
+
-- Remember that we are processing a freezing entity and its freezing
-- nodes. This flag (non-zero = set) is used to avoid the need of
-- climbing through the tree while processing the freezing actions (ie.
elsif Is_Scalar_Type (Component_Type (Etype (Comp)))
and then
- (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
+ (not Compile_Time_Known_Value (Type_Low_Bound (Comp_Type))
or else
not Compile_Time_Known_Value (Type_High_Bound (Comp_Type)))
then
-- to the appropriate formal parameter.
if Nkind (Arg) = N_Identifier
- and then Ekind (Entity (Arg)) = E_Discriminant
+ and then Ekind (Entity (Arg)) = E_Discriminant
then
Arg := New_Occurrence_Of (Discriminal (Entity (Arg)), Loc);
-- Append it to the list
if Nkind (Arg) = N_Identifier
- and then Ekind (Entity (Arg)) = E_Discriminant
+ and then Ekind (Entity (Arg)) = E_Discriminant
then
Append_To (Args,
New_Occurrence_Of (Discriminal (Entity (Arg)), Loc));
Ins_Nod := First (Body_Stmts);
while Present (Next (Ins_Nod))
- and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
- or else not Is_Init_Proc (Name (Ins_Nod)))
+ and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
+ or else not Is_Init_Proc (Name (Ins_Nod)))
loop
Next (Ins_Nod);
end loop;
return False;
elsif (Has_Discriminants (Rec_Id)
- and then not Is_Unchecked_Union (Rec_Id))
+ and then not Is_Unchecked_Union (Rec_Id))
or else Is_Tagged_Type (Rec_Id)
or else Is_Concurrent_Record_Type (Rec_Id)
or else Has_Task (Rec_Id)
Typ : constant Entity_Id := Etype (Comp);
begin
- if Is_Array_Type (Typ)
- and then Is_Itype (Typ)
- then
+ if Is_Array_Type (Typ) and then Is_Itype (Typ) then
Ref := Make_Itype_Reference (Loc);
Set_Itype (Ref, Typ);
Append_Freeze_Action (Rec_Type, Ref);
-- The aggregate may have been rewritten as a Raise node, in which
-- case there are no relevant itypes.
- if Present (Agg)
- and then Nkind (Agg) = N_Aggregate
- then
+ if Present (Agg) and then Nkind (Agg) = N_Aggregate then
Set_Static_Initialization (Proc_Id, Agg);
declare
and then Is_Library_Level_Entity (Def_Id)
and then Is_Library_Level_Tagged_Type (Base_Typ)
and then (Ekind (Base_Typ) = E_Record_Type
- or else Ekind (Base_Typ) = E_Protected_Type
- or else Ekind (Base_Typ) = E_Task_Type)
+ or else Ekind (Base_Typ) = E_Protected_Type
+ or else Ekind (Base_Typ) = E_Task_Type)
and then not Has_Dispatch_Table (Base_Typ)
then
declare
if Has_Non_Null_Base_Init_Proc (Typ)
- -- Suppress call if No_Initialization set on declaration
+ -- Suppress call if No_Initialization set on declaration
- and then not No_Initialization (N)
+ and then not No_Initialization (N)
- -- Suppress call for special case of value type for VM
+ -- Suppress call for special case of value type for VM
- and then not Is_Value_Type (Typ)
+ and then not Is_Value_Type (Typ)
- -- Suppress call if initialization suppressed for the type
+ -- Suppress call if initialization suppressed for the type
- and then not Initialization_Suppressed (Typ)
+ and then not Initialization_Suppressed (Typ)
then
-- Return without initializing when No_Default_Initialization
-- applies. Note that the actual restriction check occurs later,
and then not
(Nkind (Obj_Def) = N_Identifier
- and then
- Present (Equivalent_Type (Entity (Obj_Def))))
+ and then Present (Equivalent_Type (Entity (Obj_Def))))
then
pragma Assert (Is_Class_Wide_Type (Typ));
-- case, the expansion of the return statement will take care of
-- creating the object (via allocator) and initializing it.
- if Is_Return_Object (Def_Id)
- and then Is_Limited_View (Typ)
- then
+ if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then
null;
elsif Tagged_Type_Expansion then
and then Interface_Present_In_Ancestor (Expr_Typ, Typ)
and then (Expr_Typ = Etype (Expr_Typ)
or else not
- Is_Variable_Size_Record (Etype (Expr_Typ)))
+ Is_Variable_Size_Record (Etype (Expr_Typ)))
then
-- Copy the object
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_Id,
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (Expr_Typ, Loc),
- Expression =>
- Relocate_Node (Expr_N)));
+ Expression => Relocate_Node (Expr_N)));
-- Statically reference the tag associated with the
-- interface
Tag_Comp :=
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
Selector_Name =>
New_Occurrence_Of
(Find_Interface_Tag (Expr_Typ, Iface), Loc));
-- is too much trouble ???
if (Is_Possibly_Unaligned_Slice (Expr)
- or else (Is_Possibly_Unaligned_Object (Expr)
- and then not Represented_As_Scalar (Etype (Expr))))
+ or else (Is_Possibly_Unaligned_Object (Expr)
+ and then not Represented_As_Scalar (Etype (Expr))))
and then not (Is_Array_Type (Etype (Expr))
- and then not Is_Constrained (Etype (Expr)))
+ and then not Is_Constrained (Etype (Expr)))
then
declare
Stat : constant Node_Id :=
if Is_Itype (Base)
and then Nkind (Associated_Node_For_Itype (Base)) =
N_Object_Declaration
- and then (Present (Expression (Associated_Node_For_Itype (Base)))
- or else
- No_Initialization (Associated_Node_For_Itype (Base)))
+ and then
+ (Present (Expression (Associated_Node_For_Itype (Base)))
+ or else No_Initialization (Associated_Node_For_Itype (Base)))
then
null;
-- initialize scalars mode, and these types are treated specially
-- and do not need initialization procedures.
- elsif Root_Type (Base) = Standard_String
+ elsif Root_Type (Base) = Standard_String
or else Root_Type (Base) = Standard_Wide_String
or else Root_Type (Base) = Standard_Wide_Wide_String
then
-- Normalize_Scalars and there better be a public Init_Proc for it.
elsif (Present (Init_Proc (Component_Type (Base)))
- and then No (Base_Init_Proc (Base)))
+ and then No (Base_Init_Proc (Base)))
or else (Init_Or_Norm_Scalars and then Base = Typ)
or else Is_Public (Typ)
then
or else Is_Tagged_Type (Etype (Def_Id))
then
Set_All_DT_Position (Def_Id);
+
+ -- If this is a type derived from an untagged private type whose
+ -- full view is tagged, the type is marked tagged for layout
+ -- reasons, but it has no dispatch table.
+
+ elsif Is_Derived_Type (Def_Id)
+ and then Is_Private_Type (Etype (Def_Id))
+ and then not Is_Tagged_Type (Etype (Def_Id))
+ then
+ return;
end if;
-- Create and decorate the tags. Suppress their creation when
if Is_Tagged_Type (Def_Id)
and then not Is_Interface (Def_Id)
then
- -- Do not add the body of predefined primitives in case of
- -- CPP tagged type derivations that have convention CPP.
+ -- Do not add the body of predefined primitives in case of CPP tagged
+ -- type derivations that have convention CPP.
if Is_CPP_Class (Root_Type (Def_Id))
and then Convention (Def_Id) = Convention_CPP
then
null;
- -- Do not add the body of predefined primitives in case of
- -- CIL and Java tagged types.
+ -- Do not add the body of predefined primitives in case of CIL and
+ -- Java tagged types.
elsif Convention (Def_Id) = Convention_CIL
or else Convention (Def_Id) = Convention_Java
end;
end if;
- -- Check whether individual components have a defined invariant,
- -- and add the corresponding component invariant checks.
+ -- Check whether individual components have a defined invariant, and add
+ -- the corresponding component invariant checks.
Insert_Component_Invariant_Checks
(N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N));
-- Start of processing for Get_Simple_Init_Val
begin
- -- For a private type, we should always have an underlying type
- -- (because this was already checked in Needs_Simple_Initialization).
- -- What we do is to get the value for the underlying type and then do
- -- an Unchecked_Convert to the private type.
+ -- For a private type, we should always have an underlying type (because
+ -- this was already checked in Needs_Simple_Initialization). What we do
+ -- is to get the value for the underlying type and then do an unchecked
+ -- conversion to the private type.
if Is_Private_Type (T) then
Val := Get_Simple_Init_Val (Underlying_Type (T), N, Size);
-- A special case, if the underlying value is null, then qualify it
- -- with the underlying type, so that the null is properly typed
+ -- with the underlying type, so that the null is properly typed.
-- Similarly, if it is an aggregate it must be qualified, because an
-- unchecked conversion does not provide a context for it.
return Result;
-- Scalars with Default_Value aspect. The first subtype may now be
- -- private, so retrieve value from underlying type.
+ -- private, so retrieve value from underlying type.
elsif Is_Scalar_Type (T) and then Has_Default_Aspect (T) then
if Is_Private_Type (First_Subtype (T)) then
else
return First_Rep_Item (T) /= First_Rep_Item (Root_Type (T));
- -- May need a more precise check here: the First_Rep_Item may
- -- be a stream attribute, which does not affect the representation
- -- of the type ???
+ -- May need a more precise check here: the First_Rep_Item may be a
+ -- stream attribute, which does not affect the representation of the
+ -- type ???
+
end if;
end Has_New_Non_Standard_Rep;
if Ekind (Comp) = E_Discriminant
or else
(Nkind (Parent (Comp)) = N_Component_Declaration
- and then Present (Expression (Parent (Comp))))
+ and then Present (Expression (Parent (Comp))))
then
Warning_Needed := True;
exit;
Formals : List_Id;
begin
- -- First parameter is always _Init : in out typ. Note that we need
- -- this to be in/out because in the case of the task record value,
- -- there are default record fields (_Priority, _Size, -Task_Info)
- -- that may be referenced in the generated initialization routine.
+ -- First parameter is always _Init : in out typ. Note that we need this
+ -- to be in/out because in the case of the task record value, there
+ -- are default record fields (_Priority, _Size, -Task_Info) that may
+ -- be referenced in the generated initialization routine.
Formals := New_List (
Make_Parameter_Specification (Loc,
Offset_To_Top_Comp : Entity_Id := Empty;
begin
- -- Initialize the pointer to the secondary DT associated with the
- -- interface.
+ -- Initialize pointer to secondary DT associated with the interface
if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
Append_To (Stmts_List,
(DT_Offset_To_Top_Func (Tag_Comp), Loc),
Attribute_Name => Name_Address)))));
- -- In this case the next component stores the value of the
- -- offset to the top.
+ -- In this case the next component stores the value of the offset
+ -- to the top.
Offset_To_Top_Comp := Next_Entity (Tag_Comp);
pragma Assert (Present (Offset_To_Top_Comp));
then
exit when
(Is_Record_Type (Comp_Typ)
- and then Is_Variable_Size_Record
- (Base_Type (Comp_Typ)))
+ and then Is_Variable_Size_Record
+ (Base_Type (Comp_Typ)))
or else
(Is_Array_Type (Comp_Typ)
- and then Is_Variable_Size_Array (Comp_Typ));
+ and then Is_Variable_Size_Array (Comp_Typ));
end if;
Next_Entity (Comp);
while Present (Elmt) loop
Prim := Node (Elmt);
- if Is_User_Defined_Equality (Prim)
- and then No (Alias (Prim))
- then
+ if Is_User_Defined_Equality (Prim) and then No (Alias (Prim)) then
if No (Renaming_Prim) then
pragma Assert (No (Eq_Prim));
Eq_Prim := Prim;
elsif Consider_IS_NS
and then
- (Root_Type (T) = Standard_String
- or else Root_Type (T) = Standard_Wide_String
- or else Root_Type (T) = Standard_Wide_Wide_String)
+ (Root_Type (T) = Standard_String or else
+ Root_Type (T) = Standard_Wide_String or else
+ Root_Type (T) = Standard_Wide_Wide_String)
and then
(not Is_Itype (T)
or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate)
-- attribute has been specified or Write (resp. Read) is available for
-- an ancestor type. The last condition only applies under Ada 2005.
- if Is_Limited_Type (Typ)
- and then Is_Tagged_Type (Typ)
- then
+ if Is_Limited_Type (Typ) and then Is_Tagged_Type (Typ) then
if Operation = TSS_Stream_Read then
Has_Predefined_Or_Specified_Stream_Attribute :=
Has_Specified_Stream_Read (Typ);
-- like the AAMP, where the storage unit is not 8 bits). The output is one
-- or more lines in the following format, which is for the case of 32-bit
-- addresses (64-bit addresses are handled appropriately):
-
+ --
-- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
-
+ --
-- All but the last line have 16 bytes. A question mark is used in the
-- string data to indicate a non-printable character.
-- If Prefix is set to Absolute_Address, the output is identical to the
-- above version, each line starting with the absolute address of the
-- first dumped storage element.
-
+ --
-- If Prefix is set to Offset, then instead each line starts with the
-- indication of the offset relative to Addr:
-
+ --
-- 00: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
-
+ --
-- Finally if Prefix is set to None, the prefix is suppressed altogether,
-- and only the memory contents are displayed:
-
+ --
-- 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
end GNAT.Memory_Dump;
-- Control of Text/Binary Mode --
---------------------------------
- -- If text_translation_required is true, then the following functions may
- -- be used to dynamically switch a file from binary to text mode or vice
- -- versa. These functions have no effect if text_translation_required is
- -- false (i.e. in normal unix mode). Use fileno to get a stream handle.
-
procedure set_binary_mode (handle : int);
procedure set_text_mode (handle : int);
-
- -- set_wide_text_mode is as set_text_mode but switches the translation to
- -- 16-bit wide-character instead of 8-bit character. Again, this routine
- -- has no effect if text_translation_required is false. On Windows this
- -- is used to have proper 16-bit wide-string output on the console for
- -- example.
+ -- If text_translation_required is true, then these two functions may
+ -- be used to dynamically switch a file from binary to text mode or vice
+ -- versa. These functions have no effect if text_translation_required is
+ -- false (e.g. in normal unix mode). Use fileno to get a stream handle.
procedure set_wide_text_mode (handle : int);
+ -- This is similar to set_text_mode but switches the translation to 16-bit
+ -- wide-character instead of 8-bit character. Again, this routine has no
+ -- effect if text_translation_required is false. On Windows this is used
+ -- to have proper 16-bit wide-string output on the console for example.
----------------------------
-- Full Path Name support --
-- that do not specify a representation characteristic are operational
-- attributes.
+ function Is_Predicate_Static
+ (Expr : Node_Id;
+ Nam : Name_Id) return Boolean;
+ -- Given predicate expression Expr, tests if Expr is predicate-static in
+ -- the sense of the rules in (RM 3.2.4 (15-24)). Occurrences of the type
+ -- name in the predicate expression have been replaced by references to
+ -- an identifier whose Chars field is Nam. This name is unique, so any
+ -- identifier with Chars matching Nam must be a reference to the type.
+ -- Returns True if the expression is predicate-static and False otherwise,
+ -- but is not in the business of setting flags or issuing error messages.
+ --
+ -- Only scalar types can have static predicates, so False is always
+ -- returned for non-scalar types.
+ --
+ -- Note: the RM seems to suggest that string types can also have static
+ -- predicates. But that really makes lttle sense as very few useful
+ -- predicates can be constructed for strings. Remember that:
+ --
+ -- "ABC" < "DEF"
+ --
+ -- is not a static expression. So even though the clearly faulty RM wording
+ -- allows the following:
+ --
+ -- subtype S is String with Static_Predicate => S < "DEF"
+ --
+ -- We can't allow this, otherwise we have predicate-static applying to a
+ -- larger class than static expressions, which was never intended.
+
procedure New_Stream_Subprogram
(N : Node_Id;
Ent : Entity_Id;
Raise_Expression_Present : Boolean := False;
-- Set True if Expr has at least one Raise_Expression
- Static_Predic : Node_Id := Empty;
- -- Set to N_Pragma node for a static predicate if one is encountered
-
procedure Add_Call (T : Entity_Id);
-- Includes a call to the predicate function for type T in Expr if T
-- has predicates and Predicate_Function (T) is non-empty.
if No (Expr) then
Expr := Exp;
+
else
Expr :=
- Make_And_Then (Loc,
+ Make_And_Then (Sloc (Expr),
Left_Opnd => Relocate_Node (Expr),
Right_Opnd => Exp);
end if;
if Nkind (Ritem) = N_Pragma
and then Pragma_Name (Ritem) = Name_Predicate
then
- -- Save the static predicate of the type for diagnostics and
- -- error reporting purposes.
-
- if Present (Corresponding_Aspect (Ritem))
- and then Chars (Identifier (Corresponding_Aspect (Ritem))) =
- Name_Static_Predicate
- then
- Static_Predic := Ritem;
- end if;
-
-- Acquire arguments
Arg1 := First (Pragma_Argument_Associations (Ritem));
end;
end if;
- if Is_Discrete_Type (Typ) then
+ -- See if we have a static predicate. Note that the answer may be
+ -- yes even if we have an explicit Dynamic_Predicate present.
- -- Attempt to build a static predicate for a discrete subtype.
- -- This action may fail because the actual expression may not be
- -- static. Note that the presence of an inherited or explicitly
- -- declared dynamic predicate is orthogonal to this check because
- -- we are only interested in the static predicate.
+ declare
+ PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name);
+ EN : Node_Id;
- Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
+ begin
+ -- Case where we have a predicate static aspect
- -- Emit an error when the predicate is categorized as static
- -- but its expression is dynamic.
+ if PS then
- if Present (Static_Predic)
- and then No (Static_Predicate (Typ))
- then
- Error_Msg_F
- ("expression does not have required form for "
- & "static predicate",
- Next (First (Pragma_Argument_Associations
- (Static_Predic))));
- end if;
+ -- We don't set Has_Static_Predicate_Aspect, since we can have
+ -- any of the three cases (Predicate, Dynamic_Predicate, or
+ -- Static_Predicate) generating a predicate with an expression
+ -- that is predicate static. We just indicate that we have a
+ -- predicate that can be treated as static.
- -- If a static predicate applies on other types, that's an error:
- -- either the type is scalar but non-static, or it's not even a
- -- scalar type. We do not issue an error on generated types, as
- -- these may be duplicates of the same error on a source type.
+ Set_Has_Static_Predicate (Typ);
- elsif Present (Static_Predic) and then Comes_From_Source (Typ) then
- if Is_Real_Type (Typ) then
- Error_Msg_FE
- ("static predicates not implemented for real type&",
- Typ, Typ);
+ -- For discrete subtype, build the static predicate list
- elsif Is_Scalar_Type (Typ) then
- Error_Msg_FE
- ("static predicate not allowed for non-static type&",
- Typ, Typ);
+ if Is_Discrete_Type (Typ) then
+ Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
+
+ -- If we don't get a static predicate list, it means that we
+ -- have a case where this is not possible, most typically in
+ -- the case where we inherit a dynamic predicate. We do not
+ -- consider this an error, we just leave the predicate as
+ -- dynamic. But if we do succeed in building the list, then
+ -- we mark the predicate as static.
+
+ if No (Static_Predicate (Typ)) then
+ Set_Has_Static_Predicate (Typ, False);
+ end if;
+ end if;
+
+ -- Case of dynamic predicate (expression is not predicate-static)
else
- Error_Msg_FE
- ("static predicate not allowed for non-scalar type&",
- Typ, Typ);
+ -- Again, we don't set Has_Dynamic_Predicate_Aspect, since that
+ -- is only set if we have an explicit Dynamic_Predicate aspect
+ -- given. Here we may simply have a Predicate aspect where the
+ -- expression happens not to be predicate-static.
+
+ -- Emit an error when the predicate is categorized as static
+ -- but its expression is not predicate-static.
+
+ -- First a little fiddling to get a nice location for the
+ -- message. If the expression is of the form (A and then B),
+ -- then use the left operand for the Sloc. This avoids getting
+ -- confused by a call to a higher level predicate with a less
+ -- convenient source location.
+
+ EN := Expr;
+ while Nkind (EN) = N_And_Then loop
+ EN := Left_Opnd (EN);
+ end loop;
+
+ -- Now post appropriate message
+
+ if Has_Static_Predicate_Aspect (Typ) then
+ if Is_Scalar_Type (Typ) then
+ Error_Msg_F
+ ("expression is not predicate-static (RM 4.3.2(16-22))",
+ EN);
+ else
+ Error_Msg_FE
+ ("static predicate not allowed for non-scalar type&",
+ EN, Typ);
+ end if;
+ end if;
end if;
- end if;
+ end;
end if;
end Build_Predicate_Functions;
end if;
end Is_Operational_Item;
+ -------------------------
+ -- Is_Predicate_Static --
+ -------------------------
+
+ function Is_Predicate_Static
+ (Expr : Node_Id;
+ Nam : Name_Id) return Boolean
+ is
+ function All_Static_Case_Alternatives (L : List_Id) return Boolean;
+ -- Given a list of case expression alternatives, returns True if
+ -- all the alternative are static (have all static choices, and a
+ -- static expression).
+
+ function All_Static_Choices (L : List_Id) return Boolean;
+ -- Returns true if all elements of the list are ok static choices
+ -- as defined below for Is_Static_Choice. Used for case expression
+ -- alternatives and for the right operand of a membership test.
+
+ function Is_Static_Choice (N : Node_Id) return Boolean;
+ -- Returns True if N represents a static choice (static subtype, or
+ -- static subtype indication, or static expression or static range).
+ --
+ -- Note that this is a bit more inclusive than we actually need
+ -- (in particular membership tests do not allow the use of subtype
+ -- indications. But that doesn't matter, we have already checked
+ -- that the construct is legal to get this far.
+
+ function Is_Type_Ref (N : Node_Id) return Boolean;
+ pragma Inline (Is_Type_Ref);
+ -- Returns if True if N is a reference to the type for the predicate in
+ -- the expression (i.e. if it is an identifier whose Chars field matches
+ -- the Nam given in the call). N must not be parenthesized, if the type
+ -- name appears in parens, this routine will return False.
+
+ ----------------------------------
+ -- All_Static_Case_Alternatives --
+ ----------------------------------
+
+ function All_Static_Case_Alternatives (L : List_Id) return Boolean is
+ N : Node_Id;
+
+ begin
+ N := First (L);
+ while Present (N) loop
+ if not (All_Static_Choices (Discrete_Choices (N))
+ and then Is_OK_Static_Expression (Expression (N)))
+ then
+ return False;
+ end if;
+
+ Next (N);
+ end loop;
+
+ return True;
+ end All_Static_Case_Alternatives;
+
+ ------------------------
+ -- All_Static_Choices --
+ ------------------------
+
+ function All_Static_Choices (L : List_Id) return Boolean is
+ N : Node_Id;
+
+ begin
+ N := First (L);
+ while Present (N) loop
+ if not Is_Static_Choice (N) then
+ return False;
+ end if;
+
+ Next (N);
+ end loop;
+
+ return True;
+ end All_Static_Choices;
+
+ ----------------------
+ -- Is_Static_Choice --
+ ----------------------
+
+ function Is_Static_Choice (N : Node_Id) return Boolean is
+ begin
+ return Is_OK_Static_Expression (N)
+ or else (Is_Entity_Name (N) and then Is_Type (Entity (N))
+ and then Is_OK_Static_Subtype (Entity (N)))
+ or else (Nkind (N) = N_Subtype_Indication
+ and then Is_OK_Static_Subtype (Entity (N)))
+ or else (Nkind (N) = N_Range and then Is_OK_Static_Range (N));
+ end Is_Static_Choice;
+
+ -----------------
+ -- Is_Type_Ref --
+ -----------------
+
+ function Is_Type_Ref (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Identifier
+ and then Chars (N) = Nam
+ and then Paren_Count (N) = 0;
+ end Is_Type_Ref;
+
+ -- Start of processing for Is_Predicate_Static
+
+ begin
+ -- Only scalar types can be predicate static
+
+ if not Is_Scalar_Type (Etype (Expr)) then
+ return False;
+ end if;
+
+ -- Predicate_Static means one of the following holds. Numbers are the
+ -- corresponding paragraph numbers in (RM 3.2.4(16-22)).
+
+ -- 16: A static expression
+
+ if Is_OK_Static_Expression (Expr) then
+ return True;
+
+ -- 17: A membership test whose simple_expression is the current
+ -- instance, and whose membership_choice_list meets the requirements
+ -- for a static membership test.
+
+ elsif Nkind (Expr) in N_Membership_Test
+ and then ((Present (Right_Opnd (Expr))
+ and then Is_Static_Choice (Right_Opnd (Expr)))
+ or else
+ (Present (Alternatives (Expr))
+ and then All_Static_Choices (Alternatives (Expr))))
+ then
+ return True;
+
+ -- 18. A case_expression whose selecting_expression is the current
+ -- instance, and whose dependent expressions are static expressions.
+
+ elsif Nkind (Expr) = N_Case_Expression
+ and then Is_Type_Ref (Expression (Expr))
+ and then All_Static_Case_Alternatives (Alternatives (Expr))
+ then
+ return True;
+
+ -- 19. A call to a predefined equality or ordering operator, where one
+ -- operand is the current instance, and the other is a static
+ -- expression.
+
+ elsif Nkind (Expr) in N_Op_Compare
+ and then ((Is_Type_Ref (Left_Opnd (Expr))
+ and then Is_OK_Static_Expression (Right_Opnd (Expr)))
+ or else
+ (Is_Type_Ref (Right_Opnd (Expr))
+ and then Is_OK_Static_Expression (Left_Opnd (Expr))))
+ then
+ return True;
+
+ -- 20. A call to a predefined boolean logical operator, where each
+ -- operand is predicate-static.
+
+ elsif (Nkind_In (Expr, N_Op_And, N_Op_Or, N_Op_Xor)
+ and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
+ and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
+ or else
+ (Nkind (Expr) = N_Op_Not
+ and then Is_Predicate_Static (Right_Opnd (Expr), Nam))
+ then
+ return True;
+
+ -- 21. A short-circuit control form where both operands are
+ -- predicate-static.
+
+ elsif Nkind (Expr) in N_Short_Circuit
+ and then Is_Predicate_Static (Left_Opnd (Expr), Nam)
+ and then Is_Predicate_Static (Right_Opnd (Expr), Nam)
+ then
+ return True;
+
+ -- 22. A parenthesized predicate-static expression. This does not
+ -- require any special test, since we just ignore paren levels in
+ -- all the cases above.
+
+ -- One more test that is an implementation artifact caused by the fact
+ -- that we are analyzing not the original expresesion, but the generated
+ -- expression in the body of the predicate function. This can include
+ -- refereces to inherited predicates, so that the expression we are
+ -- processing looks like:
+
+ -- expression and then xxPredicate (typ (Inns))
+
+ -- Where the call is to a Predicate function for an inherited predicate.
+ -- We simply ignore such a call (which could be to either a dynamic or
+ -- a static predicate, but remember that we can have Static_Predicate
+ -- for a non-static subtype).
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Is_Predicate_Function (Entity (Name (Expr)))
+ then
+ return True;
+
+ -- That's an exhaustive list of tests, all other cases are not
+ -- predicate static, so we return False.
+
+ else
+ return False;
+ end if;
+ end Is_Predicate_Static;
+
---------------------
-- Kill_Rep_Clause --
---------------------
Base_Type (Full_View (Id_Type)) = Base_Type (Parent_Type))
or else
(Ada_Version >= Ada_2012
- and then Ekind (Id_Type) = E_Incomplete_Type
- and then Full_View (Id_Type) = Parent_Type)
+ and then Ekind (Id_Type) = E_Incomplete_Type
+ and then Full_View (Id_Type) = Parent_Type)
then
-- Constraint checks on formals are generated during expansion,
-- based on the signature of the original subprogram. The bounds
-----------------------------
procedure Analyze_Case_Expression (N : Node_Id) is
- function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean;
- -- Determine whether subtype Subtyp has aspect Static_Predicate
-
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
-- the case expression has a non static choice.
Process_Associated_Node => No_OP);
use Case_Choices_Checking;
- --------------------------
- -- Has_Static_Predicate --
- --------------------------
-
- function Has_Static_Predicate (Subtyp : Entity_Id) return Boolean is
- Item : Node_Id;
-
- begin
- Item := First_Rep_Item (Subtyp);
- while Present (Item) loop
- if Nkind (Item) = N_Aspect_Specification
- and then Chars (Identifier (Item)) = Name_Static_Predicate
- then
- return True;
- end if;
-
- Next_Rep_Item (Item);
- end loop;
-
- return False;
- end Has_Static_Predicate;
-
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
-- to bogus errors.
if Is_Static_Subtype (Exp_Type)
- and then Has_Static_Predicate (Exp_Type)
+ and then Has_Static_Predicate_Aspect (Exp_Type)
and then In_Spec_Expression
then
null;
Typ : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
- Pred : constant List_Id := Static_Predicate (Typ);
- Test : Node_Id;
begin
- if No (Pred) then
- return True;
- end if;
+ -- Discrete type case
+
+ if Is_Discrete_Type (Typ) then
+ declare
+ Pred : constant List_Id := Static_Predicate (Typ);
+ Test : Node_Id;
- -- The static predicate is a list of alternatives in the proper format
- -- for an Ada 2012 membership test. If the argument is a literal, the
- -- membership test can be evaluated statically. The caller transforms
- -- a result of False into a static contraint error.
+ begin
+ pragma Assert (Present (Pred));
+
+ -- The static predicate is a list of alternatives in the proper
+ -- format for an Ada 2012 membership test. If the argument is a
+ -- literal, the membership test can be evaluated statically. This
+ -- is easier than running a full intepretation of the predicate
+ -- expression, and more efficient in some cases.
+
+ Test :=
+ Make_In (Loc,
+ Left_Opnd => New_Copy_Tree (N),
+ Right_Opnd => Empty,
+ Alternatives => Pred);
+ Analyze_And_Resolve (Test, Standard_Boolean);
+
+ return Nkind (Test) = N_Identifier
+ and then Entity (Test) = Standard_True;
+ end;
- Test :=
- Make_In (Loc,
- Left_Opnd => New_Copy_Tree (N),
- Right_Opnd => Empty,
- Alternatives => Pred);
- Analyze_And_Resolve (Test, Standard_Boolean);
+ -- Real type case
- return Nkind (Test) = N_Identifier
- and then Entity (Test) = Standard_True;
+ else
+ pragma Assert (Is_Real_Type (Typ));
+ Error_Msg_N ("??real predicate not applied", N);
+ return True;
+ end if;
end Eval_Static_Predicate_Check;
-------------------------
-- In general we take a pessimistic view. False does not mean the value
-- could not be known at compile time, but True means that absolutely
-- definition it is known at compile time and it is safe to call
- -- Expr_Value on the expression Op.
+ -- Expr_Value[_XX] on the expression Op.
--
-- Note that we don't define precisely the set of expressions that return
-- True. Callers should not make any assumptions regarding the value that
procedure Eval_Unchecked_Conversion (N : Node_Id);
function Eval_Static_Predicate_Check
- (N : Node_Id;
- Typ : Entity_Id) return Boolean;
- -- Evaluate a static predicate check applied to a scalar literal
+ (N : Node_Id;
+ Typ : Entity_Id) return Boolean;
+ -- Evaluate a static predicate check applied to a known at compile time
+ -- value N, which can be of a discrete, real or string type. The caller
+ -- has checked that a static predicate does apply to Typ.
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
begin
-- When the predicate is static and the value of the expression is known
-- at compile time, evaluate the predicate check. A type is non-static
- -- when it has aspect Dynamic_Predicate.
+ -- when it has aspect Dynamic_Predicate, but if the dynamic predicate
+ -- was predicate-static, we still check it statically. After all this
+ -- is only a warning, not an error.
if Compile_Time_Known_Value (Expr)
and then Has_Predicates (Typ)
- and then Is_Discrete_Type (Typ)
- and then Present (Static_Predicate (Typ))
- and then not Has_Dynamic_Predicate_Aspect (Typ)
+ and then Has_Static_Predicate (Typ)
then
-- Either -gnatc is enabled or the expression is ok
then
null;
- -- The expression is prohibited by the static predicate
+ -- The expression is prohibited by the static predicate. There has
+ -- been some debate if this is an illegality (in the case where
+ -- the static predicate was explicitly given as such), but that
+ -- discussion decided this was not illegal, just a warning situation.
else
Error_Msg_NE
- ("??static expression fails static predicate check on &",
- Expr, Typ);
+ ("??static expression fails predicate check on &", Expr, Typ);
end if;
end if;
end Check_Expression_Against_Static_Predicate;
-- to deal with, and diagnose a simple expression other than a name for
-- the right operand. This simplifies error recovery in the parser.
- -- The Alternatives field below is present only if there is more
- -- than one Membership_Choice present (which is legitimate only in
- -- Ada 2012 mode) in which case Right_Opnd is Empty, and Alternatives
- -- contains the list of choices. In the tree passed to the back end,
- -- Alternatives is always No_List, and Right_Opnd is set (i.e. the
- -- expansion circuitry expands out the complex set membership case
- -- using simple membership operations).
+ -- The Alternatives field below is present only if there is more than
+ -- one Membership_Choice present (which is legitimate only in Ada 2012
+ -- mode) in which case Right_Opnd is Empty, and Alternatives contains
+ -- the list of choices. In the tree passed to the back end, Alternatives
+ -- is always No_List, and Right_Opnd is set (i.e. the expansion circuit
+ -- expands out the complex set membership case using simple membership
+ -- and equality operations).
-- Should we rename Alternatives here to Membership_Choices ???
-- CASE_EXPRESSION ::=
-- case SELECTING_EXPRESSION is
-- CASE_EXPRESSION_ALTERNATIVE
- -- {CASE_EXPRESSION_ALTERNATIVE}
+ -- {,CASE_EXPRESSION_ALTERNATIVE}
-- Note that the Alternatives cannot include pragmas (this contrasts
-- with the situation of case statements where pragmas are allowed).
projects / platform / upstream / linaro-gcc.git / commitdiff