-- type whose inherited alignment is no longer appropriate for the new
-- size value. In this case, we reset the Alignment to unknown.
- procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
- -- If Typ has predicates (indicated by Has_Predicates being set for Typ),
- -- then either there are pragma Predicate entries on the rep chain for the
- -- type (note that Predicate aspects are converted to pragma Predicate), or
- -- there are inherited aspects from a parent type, or ancestor subtypes.
- -- This procedure builds the spec and body for the Predicate function that
- -- tests these predicates. N is the freeze node for the type. The spec of
- -- the function is inserted before the freeze node, and the body of the
- -- function is inserted after the freeze node. If the predicate expression
- -- has at least one Raise_Expression, then this procedure also builds the
- -- M version of the predicate function for use in membership tests.
-
- procedure Build_Static_Predicate
+ procedure Build_Discrete_Static_Predicate
(Typ : Entity_Id;
Expr : Node_Id;
Nam : Name_Id);
-- list is stored in Static_Predicate (Typ), and the Expr is rewritten as
-- a canonicalized membership operation.
+ procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
+ -- If Typ has predicates (indicated by Has_Predicates being set for Typ),
+ -- then either there are pragma Predicate entries on the rep chain for the
+ -- type (note that Predicate aspects are converted to pragma Predicate), or
+ -- there are inherited aspects from a parent type, or ancestor subtypes.
+ -- This procedure builds the spec and body for the Predicate function that
+ -- tests these predicates. N is the freeze node for the type. The spec of
+ -- the function is inserted before the freeze node, and the body of the
+ -- function is inserted after the freeze node. If the predicate expression
+ -- has at least one Raise_Expression, then this procedure also builds the
+ -- M version of the predicate function for use in membership tests.
+
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
-- Called if both Storage_Pool and Storage_Size attribute definition
-- clauses (SP and SS) are present for entity Ent. Issue error message.
end if;
end Analyze_Record_Representation_Clause;
- -------------------------------------------
- -- Build_Invariant_Procedure_Declaration --
- -------------------------------------------
+ -------------------------------------
+ -- Build_Discrete_Static_Predicate --
+ -------------------------------------
- function Build_Invariant_Procedure_Declaration
- (Typ : Entity_Id) return Node_Id
+ procedure Build_Discrete_Static_Predicate
+ (Typ : Entity_Id;
+ Expr : Node_Id;
+ Nam : Name_Id)
is
- Loc : constant Source_Ptr := Sloc (Typ);
- Object_Entity : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
- Spec : Node_Id;
- SId : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Expr);
- begin
- Set_Etype (Object_Entity, Typ);
+ Non_Static : exception;
+ -- Raised if something non-static is found
- -- Check for duplicate definiations.
+ Btyp : constant Entity_Id := Base_Type (Typ);
- if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
- return Empty;
- end if;
+ BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp));
+ BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
+ -- Low bound and high bound value of base type of Typ
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Invariant"));
- Set_Has_Invariants (Typ);
- Set_Ekind (SId, E_Procedure);
- Set_Is_Invariant_Procedure (SId);
- Set_Invariant_Procedure (Typ, SId);
+ TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
+ THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
+ -- Low bound and high bound values of static subtype Typ
- Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))));
+ type REnt is record
+ Lo, Hi : Uint;
+ end record;
+ -- One entry in a Rlist value, a single REnt (range entry) value denotes
+ -- one range from Lo to Hi. To represent a single value range Lo = Hi =
+ -- value.
- return Make_Subprogram_Declaration (Loc, Specification => Spec);
- end Build_Invariant_Procedure_Declaration;
+ type RList is array (Nat range <>) of REnt;
+ -- A list of ranges. The ranges are sorted in increasing order, and are
+ -- disjoint (there is a gap of at least one value between each range in
+ -- the table). A value is in the set of ranges in Rlist if it lies
+ -- within one of these ranges.
- -------------------------------
- -- Build_Invariant_Procedure --
- -------------------------------
+ False_Range : constant RList :=
+ RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
+ -- An empty set of ranges represents a range list that can never be
+ -- satisfied, since there are no ranges in which the value could lie,
+ -- so it does not lie in any of them. False_Range is a canonical value
+ -- for this empty set, but general processing should test for an Rlist
+ -- with length zero (see Is_False predicate), since other null ranges
+ -- may appear which must be treated as False.
- -- The procedure that is constructed here has the form
+ True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
+ -- Range representing True, value must be in the base range
- -- procedure typInvariant (Ixxx : typ) is
- -- begin
- -- pragma Check (Invariant, exp, "failed invariant from xxx");
- -- pragma Check (Invariant, exp, "failed invariant from xxx");
- -- ...
- -- pragma Check (Invariant, exp, "failed inherited invariant from xxx");
- -- ...
- -- end typInvariant;
+ function "and" (Left : RList; Right : RList) return RList;
+ -- And's together two range lists, returning a range list. This is a set
+ -- intersection operation.
- procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
- Stmts : List_Id;
- Spec : Node_Id;
- SId : Entity_Id;
- PDecl : Node_Id;
- PBody : Node_Id;
+ function "or" (Left : RList; Right : RList) return RList;
+ -- Or's together two range lists, returning a range list. This is a set
+ -- union operation.
- Nam : Name_Id;
- -- Name for Check pragma, usually Invariant, but might be Type_Invariant
- -- if we come from a Type_Invariant aspect, we make sure to build the
- -- Check pragma with the right name, so that Check_Policy works right.
+ function "not" (Right : RList) return RList;
+ -- Returns complement of a given range list, i.e. a range list
+ -- representing all the values in TLo .. THi that are not in the input
+ -- operand Right.
- Visible_Decls : constant List_Id := Visible_Declarations (N);
- Private_Decls : constant List_Id := Private_Declarations (N);
+ function Build_Val (V : Uint) return Node_Id;
+ -- Return an analyzed N_Identifier node referencing this value, suitable
+ -- for use as an entry in the Static_Predicate list. This node is typed
+ -- with the base type.
- procedure Add_Invariants (T : Entity_Id; Inherit : Boolean);
- -- Appends statements to Stmts for any invariants in the rep item chain
- -- of the given type. If Inherit is False, then we only process entries
- -- on the chain for the type Typ. If Inherit is True, then we ignore any
- -- Invariant aspects, but we process all Invariant'Class aspects, adding
- -- "inherited" to the exception message and generating an informational
- -- message about the inheritance of an invariant.
+ function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
+ -- Return an analyzed N_Range node referencing this range, suitable for
+ -- use as an entry in the Static_Predicate list. This node is typed with
+ -- the base type.
- Object_Name : Name_Id;
- -- Name for argument of invariant procedure
+ function Get_RList (Exp : Node_Id) return RList;
+ -- This is a recursive routine that converts the given expression into a
+ -- list of ranges, suitable for use in building the static predicate.
- Object_Entity : Node_Id;
- -- The entity of the formal for the procedure
+ function Is_False (R : RList) return Boolean;
+ pragma Inline (Is_False);
+ -- Returns True if the given range list is empty, and thus represents a
+ -- False list of ranges that can never be satisfied.
- --------------------
- -- Add_Invariants --
- --------------------
+ function Is_True (R : RList) return Boolean;
+ -- Returns True if R trivially represents the True predicate by having a
+ -- single range from BLo to BHi.
- procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is
- Ritem : Node_Id;
- Arg1 : Node_Id;
- Arg2 : Node_Id;
- Arg3 : Node_Id;
- Exp : Node_Id;
- Loc : Source_Ptr;
- Assoc : List_Id;
- Str : String_Id;
+ 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).
- procedure Replace_Type_Reference (N : Node_Id);
- -- Replace a single occurrence N of the subtype name with a reference
- -- to the formal of the predicate function. N can be an identifier
- -- referencing the subtype, or a selected component, representing an
- -- appropriately qualified occurrence of the subtype name.
+ function Lo_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value or low bound of range.
- procedure Replace_Type_References is
- new Replace_Type_References_Generic (Replace_Type_Reference);
- -- Traverse an expression replacing all occurrences of the subtype
- -- name with appropriate references to the object that is the formal
- -- parameter of the predicate function. Note that we must ensure
- -- that the type and entity information is properly set in the
- -- replacement node, since we will do a Preanalyze call of this
- -- expression without proper visibility of the procedure argument.
+ function Hi_Val (N : Node_Id) return Uint;
+ -- Given static expression or static range from a Static_Predicate list,
+ -- gets expression value of high bound of range.
- ----------------------------
- -- Replace_Type_Reference --
- ----------------------------
+ function Membership_Entry (N : Node_Id) return RList;
+ -- Given a single membership entry (range, value, or subtype), returns
+ -- the corresponding range list. Raises Static_Error if not static.
- -- Note: See comments in Add_Predicates.Replace_Type_Reference
- -- regarding handling of Sloc and Comes_From_Source.
+ function Membership_Entries (N : Node_Id) return RList;
+ -- Given an element on an alternatives list of a membership operation,
+ -- returns the range list corresponding to this entry and all following
+ -- entries (i.e. returns the "or" of this list of values).
- procedure Replace_Type_Reference (N : Node_Id) is
- begin
+ function Stat_Pred (Typ : Entity_Id) return RList;
+ -- Given a type, if it has a static predicate, then return the predicate
+ -- as a range list, otherwise raise Non_Static.
- -- Add semantic information to node to be rewritten, for ASIS
- -- navigation needs.
+ -----------
+ -- "and" --
+ -----------
- if Nkind (N) = N_Identifier then
- Set_Entity (N, T);
- Set_Etype (N, T);
+ function "and" (Left : RList; Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
- elsif Nkind (N) = N_Selected_Component then
- Analyze (Prefix (N));
- Set_Entity (Selector_Name (N), T);
- Set_Etype (Selector_Name (N), T);
- end if;
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
- -- Invariant'Class, replace with T'Class (obj)
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
- if Class_Present (Ritem) then
- Rewrite (N,
- Make_Type_Conversion (Sloc (N),
- Subtype_Mark =>
- Make_Attribute_Reference (Sloc (N),
- Prefix => New_Occurrence_Of (T, Sloc (N)),
- Attribute_Name => Name_Class),
- Expression => Make_Identifier (Sloc (N), Object_Name)));
+ begin
+ -- If either range is True, return the other
- Set_Entity (Expression (N), Object_Entity);
- Set_Etype (Expression (N), Typ);
+ if Is_True (Left) then
+ return Right;
+ elsif Is_True (Right) then
+ return Left;
+ end if;
- -- Invariant, replace with obj
+ -- If either range is False, return False
- else
- Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
- Set_Entity (N, Object_Entity);
- Set_Etype (N, Typ);
- end if;
+ if Is_False (Left) or else Is_False (Right) then
+ return False_Range;
+ end if;
- Set_Comes_From_Source (N, True);
- end Replace_Type_Reference;
+ -- Loop to remove entries at start that are disjoint, and thus just
+ -- get discarded from the result entirely.
- -- Start of processing for Add_Invariants
+ loop
+ -- If no operands left in either operand, result is false
- begin
- Ritem := First_Rep_Item (T);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Invariant
- then
- Arg1 := First (Pragma_Argument_Associations (Ritem));
- Arg2 := Next (Arg1);
- Arg3 := Next (Arg2);
+ if SLeft > Left'Last or else SRight > Right'Last then
+ return False_Range;
- Arg1 := Get_Pragma_Arg (Arg1);
- Arg2 := Get_Pragma_Arg (Arg2);
+ -- Discard first left operand entry if disjoint with right
- -- For Inherit case, ignore Invariant, process only Class case
+ elsif Left (SLeft).Hi < Right (SRight).Lo then
+ SLeft := SLeft + 1;
- if Inherit then
- if not Class_Present (Ritem) then
- goto Continue;
- end if;
+ -- Discard first right operand entry if disjoint with left
- -- For Inherit false, process only item for right type
+ elsif Right (SRight).Hi < Left (SLeft).Lo then
+ SRight := SRight + 1;
- else
- if Entity (Arg1) /= Typ then
- goto Continue;
- end if;
- end if;
+ -- Otherwise we have an overlapping entry
- if No (Stmts) then
- Stmts := Empty_List;
- end if;
+ else
+ exit;
+ end if;
+ end loop;
- Exp := New_Copy_Tree (Arg2);
+ -- Now we have two non-null operands, and first entries overlap. The
+ -- first entry in the result will be the overlapping part of these
+ -- two entries.
- -- Preserve sloc of original pragma Invariant
+ FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
+ Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
- Loc := Sloc (Ritem);
+ -- Now we can remove the entry that ended at a lower value, since its
+ -- contribution is entirely contained in Fent.
- -- We need to replace any occurrences of the name of the type
- -- with references to the object, converted to type'Class in
- -- the case of Invariant'Class aspects.
+ if Left (SLeft).Hi <= Right (SRight).Hi then
+ SLeft := SLeft + 1;
+ else
+ SRight := SRight + 1;
+ end if;
- Replace_Type_References (Exp, Chars (T));
+ -- Compute result by concatenating this first entry with the "and" of
+ -- the remaining parts of the left and right operands. Note that if
+ -- either of these is empty, "and" will yield empty, so that we will
+ -- end up with just Fent, which is what we want in that case.
- -- If this invariant comes from an aspect, find the aspect
- -- specification, and replace the saved expression because
- -- we need the subtype references replaced for the calls to
- -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
- -- and Check_Aspect_At_End_Of_Declarations.
+ return
+ FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
+ end "and";
- if From_Aspect_Specification (Ritem) then
- declare
- Aitem : Node_Id;
+ -----------
+ -- "not" --
+ -----------
- begin
- -- Loop to find corresponding aspect, note that this
- -- must be present given the pragma is marked delayed.
+ function "not" (Right : RList) return RList is
+ begin
+ -- Return True if False range
- -- Note: in practice Next_Rep_Item (Ritem) is Empty so
- -- this loop does nothing. Furthermore, why isn't this
- -- simply Corresponding_Aspect ???
+ if Is_False (Right) then
+ return True_Range;
+ end if;
- Aitem := Next_Rep_Item (Ritem);
- while Present (Aitem) loop
- if Nkind (Aitem) = N_Aspect_Specification
- and then Aspect_Rep_Item (Aitem) = Ritem
- then
- Set_Entity
- (Identifier (Aitem), New_Copy_Tree (Exp));
- exit;
- end if;
+ -- Return False if True range
- Aitem := Next_Rep_Item (Aitem);
- end loop;
- end;
- end if;
+ if Is_True (Right) then
+ return False_Range;
+ end if;
- -- Now we need to preanalyze the expression to properly capture
- -- the visibility in the visible part. The expression will not
- -- be analyzed for real until the body is analyzed, but that is
- -- at the end of the private part and has the wrong visibility.
+ -- Here if not trivial case
- Set_Parent (Exp, N);
- Preanalyze_Assert_Expression (Exp, Standard_Boolean);
+ declare
+ Result : RList (1 .. Right'Length + 1);
+ -- May need one more entry for gap at beginning and end
- -- In ASIS mode, even if assertions are not enabled, we must
- -- analyze the original expression in the aspect specification
- -- because it is part of the original tree.
+ Count : Nat := 0;
+ -- Number of entries stored in Result
- if ASIS_Mode and then From_Aspect_Specification (Ritem) then
- declare
- Inv : constant Node_Id :=
- Expression (Corresponding_Aspect (Ritem));
- begin
- Replace_Type_References (Inv, Chars (T));
- Preanalyze_Assert_Expression (Inv, Standard_Boolean);
- end;
- end if;
+ begin
+ -- Gap at start
- -- Get name to be used for Check pragma
+ if Right (Right'First).Lo > TLo then
+ Count := Count + 1;
+ Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
+ end if;
- if not From_Aspect_Specification (Ritem) then
- Nam := Name_Invariant;
- else
- Nam := Chars (Identifier (Corresponding_Aspect (Ritem)));
- end if;
+ -- Gaps between ranges
- -- Build first two arguments for Check pragma
+ for J in Right'First .. Right'Last - 1 loop
+ Count := Count + 1;
+ Result (Count) := REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
+ end loop;
- Assoc :=
- New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Chars => Nam)),
- Make_Pragma_Argument_Association (Loc,
- Expression => Exp));
+ -- Gap at end
- -- Add message if present in Invariant pragma
+ if Right (Right'Last).Hi < THi then
+ Count := Count + 1;
+ Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
+ end if;
- if Present (Arg3) then
- Str := Strval (Get_Pragma_Arg (Arg3));
+ return Result (1 .. Count);
+ end;
+ end "not";
- -- If inherited case, and message starts "failed invariant",
- -- change it to be "failed inherited invariant".
+ ----------
+ -- "or" --
+ ----------
- if Inherit then
- String_To_Name_Buffer (Str);
+ function "or" (Left : RList; Right : RList) return RList is
+ FEnt : REnt;
+ -- First range of result
- if Name_Buffer (1 .. 16) = "failed invariant" then
- Insert_Str_In_Name_Buffer ("inherited ", 8);
- Str := String_From_Name_Buffer;
- end if;
- end if;
+ SLeft : Nat := Left'First;
+ -- Start of rest of left entries
- Append_To (Assoc,
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_String_Literal (Loc, Str)));
- end if;
+ SRight : Nat := Right'First;
+ -- Start of rest of right entries
- -- Add Check pragma to list of statements
+ begin
+ -- If either range is True, return True
- Append_To (Stmts,
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Name_Check),
- Pragma_Argument_Associations => Assoc));
+ if Is_True (Left) or else Is_True (Right) then
+ return True_Range;
+ end if;
- -- If Inherited case and option enabled, output info msg. Note
- -- that we know this is a case of Invariant'Class.
+ -- If either range is False (empty), return the other
- if Inherit and Opt.List_Inherited_Aspects then
- Error_Msg_Sloc := Sloc (Ritem);
- Error_Msg_N
- ("info: & inherits `Invariant''Class` aspect from #?L?",
- Typ);
- end if;
- end if;
+ if Is_False (Left) then
+ return Right;
+ elsif Is_False (Right) then
+ return Left;
+ end if;
- <<Continue>>
- Next_Rep_Item (Ritem);
- end loop;
- end Add_Invariants;
+ -- Initialize result first entry from left or right operand depending
+ -- on which starts with the lower range.
- -- Start of processing for Build_Invariant_Procedure
+ if Left (SLeft).Lo < Right (SRight).Lo then
+ FEnt := Left (SLeft);
+ SLeft := SLeft + 1;
+ else
+ FEnt := Right (SRight);
+ SRight := SRight + 1;
+ end if;
- begin
- Stmts := No_List;
- PDecl := Empty;
- PBody := Empty;
- SId := Empty;
+ -- This loop eats ranges from left and right operands that are
+ -- contiguous with the first range we are gathering.
- -- If the aspect specification exists for some view of the type, the
- -- declaration for the procedure has been created.
+ loop
+ -- Eat first entry in left operand if contiguous or overlapped by
+ -- gathered first operand of result.
- if Has_Invariants (Typ) then
- SId := Invariant_Procedure (Typ);
- end if;
+ if SLeft <= Left'Last
+ and then Left (SLeft).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
+ SLeft := SLeft + 1;
- if Present (SId) then
- PDecl := Unit_Declaration_Node (SId);
- else
- PDecl := Build_Invariant_Procedure_Declaration (Typ);
- end if;
+ -- Eat first entry in right operand if contiguous or overlapped by
+ -- gathered right operand of result.
- -- Recover formal of procedure, for use in the calls to invariant
- -- functions (including inherited ones).
+ elsif SRight <= Right'Last
+ and then Right (SRight).Lo <= FEnt.Hi + 1
+ then
+ FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
+ SRight := SRight + 1;
- Object_Entity :=
- Defining_Identifier
- (First (Parameter_Specifications (Specification (PDecl))));
- Object_Name := Chars (Object_Entity);
+ -- All done if no more entries to eat
- -- Add invariants for the current type
+ else
+ exit;
+ end if;
+ end loop;
- Add_Invariants (Typ, Inherit => False);
+ -- Obtain result as the first entry we just computed, concatenated
+ -- to the "or" of the remaining results (if one operand is empty,
+ -- this will just concatenate with the other
- -- Add invariants for parent types
+ return
+ FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
+ end "or";
- declare
- Current_Typ : Entity_Id;
- Parent_Typ : Entity_Id;
+ -----------------
+ -- Build_Range --
+ -----------------
+ function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
+ Result : Node_Id;
begin
- Current_Typ := Typ;
- loop
- Parent_Typ := Etype (Current_Typ);
-
- if Is_Private_Type (Parent_Typ)
- and then Present (Full_View (Base_Type (Parent_Typ)))
- then
- Parent_Typ := Full_View (Base_Type (Parent_Typ));
- end if;
-
- exit when Parent_Typ = Current_Typ;
+ Result :=
+ Make_Range (Loc,
+ Low_Bound => Build_Val (Lo),
+ High_Bound => Build_Val (Hi));
+ Set_Etype (Result, Btyp);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Range;
- Current_Typ := Parent_Typ;
- Add_Invariants (Current_Typ, Inherit => True);
- end loop;
- end;
+ ---------------
+ -- Build_Val --
+ ---------------
- -- Build the procedure if we generated at least one Check pragma
+ function Build_Val (V : Uint) return Node_Id is
+ Result : Node_Id;
- if Stmts /= No_List then
- Spec := Copy_Separate_Tree (Specification (PDecl));
+ begin
+ if Is_Enumeration_Type (Typ) then
+ Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
+ else
+ Result := Make_Integer_Literal (Loc, V);
+ end if;
- PBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
+ Set_Etype (Result, Btyp);
+ Set_Is_Static_Expression (Result);
+ Set_Analyzed (Result);
+ return Result;
+ end Build_Val;
- -- Insert procedure declaration and spec at the appropriate points.
- -- If declaration is already analyzed, it was processed by the
- -- generated pragma.
+ ---------------
+ -- Get_RList --
+ ---------------
- if Present (Private_Decls) then
+ function Get_RList (Exp : Node_Id) return RList is
+ Op : Node_Kind;
+ Val : Uint;
- -- The spec goes at the end of visible declarations, but they have
- -- already been analyzed, so we need to explicitly do the analyze.
+ begin
+ -- Static expression can only be true or false
- if not Analyzed (PDecl) then
- Append_To (Visible_Decls, PDecl);
- Analyze (PDecl);
+ if Is_OK_Static_Expression (Exp) then
+ if Expr_Value (Exp) = 0 then
+ return False_Range;
+ else
+ return True_Range;
end if;
+ end if;
- -- The body goes at the end of the private declarations, which we
- -- have not analyzed yet, so we do not need to perform an explicit
- -- analyze call. We skip this if there are no private declarations
- -- (this is an error that will be caught elsewhere);
-
- Append_To (Private_Decls, PBody);
+ -- Otherwise test node type
- -- If the invariant appears on the full view of a type, the
- -- analysis of the private part is complete, and we must
- -- analyze the new body explicitly.
+ Op := Nkind (Exp);
- if In_Private_Part (Current_Scope) then
- Analyze (PBody);
- end if;
+ case Op is
- -- If there are no private declarations this may be an error that
- -- will be diagnosed elsewhere. However, if this is a non-private
- -- type that inherits invariants, it needs no completion and there
- -- may be no private part. In this case insert invariant procedure
- -- at end of current declarative list, and analyze at once, given
- -- that the type is about to be frozen.
+ -- And
- elsif not Is_Private_Type (Typ) then
- Append_To (Visible_Decls, PDecl);
- Append_To (Visible_Decls, PBody);
- Analyze (PDecl);
- Analyze (PBody);
- end if;
- end if;
- end Build_Invariant_Procedure;
+ when N_Op_And | N_And_Then =>
+ return Get_RList (Left_Opnd (Exp))
+ and
+ Get_RList (Right_Opnd (Exp));
- -------------------------------
- -- Build_Predicate_Functions --
- -------------------------------
+ -- Or
- -- The procedures that are constructed here have the form:
+ when N_Op_Or | N_Or_Else =>
+ return Get_RList (Left_Opnd (Exp))
+ or
+ Get_RList (Right_Opnd (Exp));
- -- function typPredicate (Ixxx : typ) return Boolean is
- -- begin
- -- return
- -- exp1 and then exp2 and then ...
- -- and then typ1Predicate (typ1 (Ixxx))
- -- and then typ2Predicate (typ2 (Ixxx))
- -- and then ...;
- -- end typPredicate;
+ -- Not
- -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
- -- this is the point at which these expressions get analyzed, providing the
- -- required delay, and typ1, typ2, are entities from which predicates are
- -- inherited. Note that we do NOT generate Check pragmas, that's because we
- -- use this function even if checks are off, e.g. for membership tests.
+ when N_Op_Not =>
+ return not Get_RList (Right_Opnd (Exp));
- -- If the expression has at least one Raise_Expression, then we also build
- -- the typPredicateM version of the function, in which any occurrence of a
- -- Raise_Expression is converted to "return False".
+ -- Comparisons of type with static value
- procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
+ when N_Op_Compare =>
- Expr : Node_Id;
- -- This is the expression for the result of the function. It is
- -- is build by connecting the component predicates with AND THEN.
+ -- Type is left operand
- Expr_M : Node_Id;
- -- This is the corresponding return expression for the Predicate_M
- -- function. It differs in that raise expressions are marked for
- -- special expansion (see Process_REs).
+ if Is_Type_Ref (Left_Opnd (Exp))
+ and then Is_OK_Static_Expression (Right_Opnd (Exp))
+ then
+ Val := Expr_Value (Right_Opnd (Exp));
- Object_Name : constant Name_Id := New_Internal_Name ('I');
- -- Name for argument of Predicate procedure. Note that we use the same
- -- name for both predicate procedure. That way the reference within the
- -- predicate expression is the same in both functions.
+ -- Typ is right operand
- Object_Entity : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars => Object_Name);
- -- Entity for argument of Predicate procedure
+ elsif Is_Type_Ref (Right_Opnd (Exp))
+ and then Is_OK_Static_Expression (Left_Opnd (Exp))
+ then
+ Val := Expr_Value (Left_Opnd (Exp));
- Object_Entity_M : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars => Object_Name);
- -- Entity for argument of Predicate_M procedure
+ -- Invert sense of comparison
- Raise_Expression_Present : Boolean := False;
- -- Set True if Expr has at least one Raise_Expression
+ case Op is
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Ge;
+ when others => null;
+ end case;
- Static_Predic : Node_Id := Empty;
- -- Set to N_Pragma node for a static predicate if one is encountered
+ -- Other cases are non-static
- 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.
+ else
+ raise Non_Static;
+ end if;
- procedure Add_Predicates;
- -- Appends expressions for any Predicate pragmas in the rep item chain
- -- Typ to Expr. Note that we look only at items for this exact entity.
- -- Inheritance of predicates for the parent type is done by calling the
- -- Predicate_Function of the parent type, using Add_Call above.
+ -- Construct range according to comparison operation
- function Test_RE (N : Node_Id) return Traverse_Result;
- -- Used in Test_REs, tests one node for being a raise expression, and if
- -- so sets Raise_Expression_Present True.
+ case Op is
+ when N_Op_Eq =>
+ return RList'(1 => REnt'(Val, Val));
- procedure Test_REs is new Traverse_Proc (Test_RE);
- -- Tests to see if Expr contains any raise expressions
+ when N_Op_Ge =>
+ return RList'(1 => REnt'(Val, BHi));
- function Process_RE (N : Node_Id) return Traverse_Result;
- -- Used in Process REs, tests if node N is a raise expression, and if
- -- so, marks it to be converted to return False.
+ when N_Op_Gt =>
+ return RList'(1 => REnt'(Val + 1, BHi));
- procedure Process_REs is new Traverse_Proc (Process_RE);
- -- Marks any raise expressions in Expr_M to return False
+ when N_Op_Le =>
+ return RList'(1 => REnt'(BLo, Val));
- --------------
- -- Add_Call --
- --------------
+ when N_Op_Lt =>
+ return RList'(1 => REnt'(BLo, Val - 1));
- procedure Add_Call (T : Entity_Id) is
- Exp : Node_Id;
+ when N_Op_Ne =>
+ return RList'(REnt'(BLo, Val - 1), REnt'(Val + 1, BHi));
- begin
- if Present (T) and then Present (Predicate_Function (T)) then
- Set_Has_Predicates (Typ);
+ when others =>
+ raise Program_Error;
+ end case;
- -- Build the call to the predicate function of T
+ -- Membership (IN)
- Exp :=
- Make_Predicate_Call
- (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
-
- -- Add call to evolving expression, using AND THEN if needed
+ when N_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
- if No (Expr) then
- Expr := Exp;
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Exp);
- end if;
+ if Present (Right_Opnd (Exp)) then
+ return Membership_Entry (Right_Opnd (Exp));
+ else
+ return Membership_Entries (First (Alternatives (Exp)));
+ end if;
- -- Output info message on inheritance if required. Note we do not
- -- give this information for generic actual types, since it is
- -- unwelcome noise in that case in instantiations. We also
- -- generally suppress the message in instantiations, and also
- -- if it involves internal names.
+ -- Negative membership (NOT IN)
- if Opt.List_Inherited_Aspects
- and then not Is_Generic_Actual_Type (Typ)
- and then Instantiation_Depth (Sloc (Typ)) = 0
- and then not Is_Internal_Name (Chars (T))
- and then not Is_Internal_Name (Chars (Typ))
- then
- Error_Msg_Sloc := Sloc (Predicate_Function (T));
- Error_Msg_Node_2 := T;
- Error_Msg_N ("info: & inherits predicate from & #?L?", Typ);
- end if;
- end if;
- end Add_Call;
+ when N_Not_In =>
+ if not Is_Type_Ref (Left_Opnd (Exp)) then
+ raise Non_Static;
+ end if;
- --------------------
- -- Add_Predicates --
- --------------------
+ if Present (Right_Opnd (Exp)) then
+ return not Membership_Entry (Right_Opnd (Exp));
+ else
+ return not Membership_Entries (First (Alternatives (Exp)));
+ end if;
- procedure Add_Predicates is
- Ritem : Node_Id;
- Arg1 : Node_Id;
- Arg2 : Node_Id;
+ -- Function call, may be call to static predicate
- procedure Replace_Type_Reference (N : Node_Id);
- -- Replace a single occurrence N of the subtype name with a reference
- -- to the formal of the predicate function. N can be an identifier
- -- referencing the subtype, or a selected component, representing an
- -- appropriately qualified occurrence of the subtype name.
+ when N_Function_Call =>
+ if Is_Entity_Name (Name (Exp)) then
+ declare
+ Ent : constant Entity_Id := Entity (Name (Exp));
+ begin
+ if Is_Predicate_Function (Ent)
+ or else
+ Is_Predicate_Function_M (Ent)
+ then
+ return Stat_Pred (Etype (First_Formal (Ent)));
+ end if;
+ end;
+ end if;
- procedure Replace_Type_References is
- new Replace_Type_References_Generic (Replace_Type_Reference);
- -- Traverse an expression changing every occurrence of an identifier
- -- whose name matches the name of the subtype with a reference to
- -- the formal parameter of the predicate function.
+ -- Other function call cases are non-static
- ----------------------------
- -- Replace_Type_Reference --
- ----------------------------
+ raise Non_Static;
- procedure Replace_Type_Reference (N : Node_Id) is
- begin
- Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
- -- Use the Sloc of the usage name, not the defining name
+ -- Qualified expression, dig out the expression
- Set_Etype (N, Typ);
- Set_Entity (N, Object_Entity);
+ when N_Qualified_Expression =>
+ return Get_RList (Expression (Exp));
- -- We want to treat the node as if it comes from source, so that
- -- ASIS will not ignore it
+ when N_Case_Expression =>
+ declare
+ Alt : Node_Id;
+ Choices : List_Id;
+ Dep : Node_Id;
- Set_Comes_From_Source (N, True);
- end Replace_Type_Reference;
+ begin
+ if not Is_Entity_Name (Expression (Expr))
+ or else Etype (Expression (Expr)) /= Typ
+ then
+ Error_Msg_N
+ ("expression must denaote subtype", Expression (Expr));
+ return False_Range;
+ end if;
- -- Start of processing for Add_Predicates
+ -- Collect discrete choices in all True alternatives
- begin
- Ritem := First_Rep_Item (Typ);
- while Present (Ritem) loop
- 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.
+ Choices := New_List;
+ Alt := First (Alternatives (Exp));
+ while Present (Alt) loop
+ Dep := Expression (Alt);
- if Present (Corresponding_Aspect (Ritem))
- and then Chars (Identifier (Corresponding_Aspect (Ritem))) =
- Name_Static_Predicate
- then
- Static_Predic := Ritem;
- end if;
+ if not Is_Static_Expression (Dep) then
+ raise Non_Static;
- -- Acquire arguments
+ elsif Is_True (Expr_Value (Dep)) then
+ Append_List_To (Choices,
+ New_Copy_List (Discrete_Choices (Alt)));
+ end if;
- Arg1 := First (Pragma_Argument_Associations (Ritem));
- Arg2 := Next (Arg1);
+ Next (Alt);
+ end loop;
- Arg1 := Get_Pragma_Arg (Arg1);
- Arg2 := Get_Pragma_Arg (Arg2);
+ return Membership_Entries (First (Choices));
+ end;
- -- See if this predicate pragma is for the current type or for
- -- its full view. A predicate on a private completion is placed
- -- on the partial view beause this is the visible entity that
- -- is frozen.
+ -- Expression with actions: if no actions, dig out expression
- if Entity (Arg1) = Typ
- or else Full_View (Entity (Arg1)) = Typ
- then
- -- We have a match, this entry is for our subtype
+ when N_Expression_With_Actions =>
+ if Is_Empty_List (Actions (Exp)) then
+ return Get_RList (Expression (Exp));
+ else
+ raise Non_Static;
+ end if;
- -- We need to replace any occurrences of the name of the
- -- type with references to the object.
+ -- Xor operator
- Replace_Type_References (Arg2, Chars (Typ));
+ when N_Op_Xor =>
+ return (Get_RList (Left_Opnd (Exp))
+ and not Get_RList (Right_Opnd (Exp)))
+ or (Get_RList (Right_Opnd (Exp))
+ and not Get_RList (Left_Opnd (Exp)));
- -- If this predicate comes from an aspect, find the aspect
- -- specification, and replace the saved expression because
- -- we need the subtype references replaced for the calls to
- -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
- -- and Check_Aspect_At_End_Of_Declarations.
+ -- Any other node type is non-static
- if From_Aspect_Specification (Ritem) then
- declare
- Aitem : Node_Id;
+ when others =>
+ raise Non_Static;
+ end case;
+ end Get_RList;
- begin
- -- Loop to find corresponding aspect, note that this
- -- must be present given the pragma is marked delayed.
+ ------------
+ -- Hi_Val --
+ ------------
- Aitem := Next_Rep_Item (Ritem);
- loop
- if Nkind (Aitem) = N_Aspect_Specification
- and then Aspect_Rep_Item (Aitem) = Ritem
- then
- Set_Entity
- (Identifier (Aitem), New_Copy_Tree (Arg2));
- exit;
- end if;
+ function Hi_Val (N : Node_Id) return Uint is
+ begin
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
+ else
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (High_Bound (N));
+ end if;
+ end Hi_Val;
- Aitem := Next_Rep_Item (Aitem);
- end loop;
- end;
- end if;
+ --------------
+ -- Is_False --
+ --------------
- -- Now we can add the expression
+ function Is_False (R : RList) return Boolean is
+ begin
+ return R'Length = 0;
+ end Is_False;
- if No (Expr) then
- Expr := Relocate_Node (Arg2);
+ -------------
+ -- Is_True --
+ -------------
- -- There already was a predicate, so add to it
+ function Is_True (R : RList) return Boolean is
+ begin
+ return R'Length = 1
+ and then R (R'First).Lo = BLo
+ and then R (R'First).Hi = BHi;
+ end Is_True;
- else
- Expr :=
- Make_And_Then (Loc,
- Left_Opnd => Relocate_Node (Expr),
- Right_Opnd => Relocate_Node (Arg2));
- end if;
- end if;
- end if;
+ -----------------
+ -- Is_Type_Ref --
+ -----------------
- Next_Rep_Item (Ritem);
- end loop;
- end Add_Predicates;
+ function Is_Type_Ref (N : Node_Id) return Boolean is
+ begin
+ return Nkind (N) = N_Identifier and then Chars (N) = Nam;
+ end Is_Type_Ref;
- ----------------
- -- Process_RE --
- ----------------
+ ------------
+ -- Lo_Val --
+ ------------
- function Process_RE (N : Node_Id) return Traverse_Result is
+ function Lo_Val (N : Node_Id) return Uint is
begin
- if Nkind (N) = N_Raise_Expression then
- Set_Convert_To_Return_False (N);
- return Skip;
+ if Is_Static_Expression (N) then
+ return Expr_Value (N);
else
- return OK;
+ pragma Assert (Nkind (N) = N_Range);
+ return Expr_Value (Low_Bound (N));
end if;
- end Process_RE;
+ end Lo_Val;
- -------------
- -- Test_RE --
- -------------
+ ------------------------
+ -- Membership_Entries --
+ ------------------------
- function Test_RE (N : Node_Id) return Traverse_Result is
+ function Membership_Entries (N : Node_Id) return RList is
begin
- if Nkind (N) = N_Raise_Expression then
- Raise_Expression_Present := True;
- return Abandon;
+ if No (Next (N)) then
+ return Membership_Entry (N);
else
- return OK;
+ return Membership_Entry (N) or Membership_Entries (Next (N));
end if;
- end Test_RE;
+ end Membership_Entries;
- -- Start of processing for Build_Predicate_Functions
+ ----------------------
+ -- Membership_Entry --
+ ----------------------
- begin
- -- Return if already built or if type does not have predicates
+ function Membership_Entry (N : Node_Id) return RList is
+ Val : Uint;
+ SLo : Uint;
+ SHi : Uint;
- if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
- then
- return;
- end if;
+ begin
+ -- Range case
- -- Prepare to construct predicate expression
+ if Nkind (N) = N_Range then
+ if not Is_Static_Expression (Low_Bound (N))
+ or else
+ not Is_Static_Expression (High_Bound (N))
+ then
+ raise Non_Static;
+ else
+ SLo := Expr_Value (Low_Bound (N));
+ SHi := Expr_Value (High_Bound (N));
+ return RList'(1 => REnt'(SLo, SHi));
+ end if;
- Expr := Empty;
+ -- Static expression case
- -- Add Predicates for the current type
+ elsif Is_Static_Expression (N) then
+ Val := Expr_Value (N);
+ return RList'(1 => REnt'(Val, Val));
- Add_Predicates;
+ -- Identifier (other than static expression) case
- -- Add predicates for ancestor if present
+ else pragma Assert (Nkind (N) = N_Identifier);
- declare
- Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
- begin
- if Present (Atyp) then
- Add_Call (Atyp);
- end if;
- end;
+ -- Type case
- -- Case where predicates are present
+ if Is_Type (Entity (N)) then
- if Present (Expr) then
+ -- If type has predicates, process them
- -- Test for raise expression present
+ if Has_Predicates (Entity (N)) then
+ return Stat_Pred (Entity (N));
- Test_REs (Expr);
+ -- For static subtype without predicates, get range
- -- If raise expression is present, capture a copy of Expr for use
- -- in building the predicateM function version later on. For this
- -- copy we replace references to Object_Entity by Object_Entity_M.
+ elsif Is_Static_Subtype (Entity (N)) then
+ SLo := Expr_Value (Type_Low_Bound (Entity (N)));
+ SHi := Expr_Value (Type_High_Bound (Entity (N)));
+ return RList'(1 => REnt'(SLo, SHi));
- if Raise_Expression_Present then
- declare
- Map : constant Elist_Id := New_Elmt_List;
- begin
- Append_Elmt (Object_Entity, Map);
- Append_Elmt (Object_Entity_M, Map);
- Expr_M := New_Copy_Tree (Expr, Map => Map);
- end;
- end if;
+ -- Any other type makes us non-static
- -- Build the main predicate function
+ else
+ raise Non_Static;
+ end if;
- declare
- SId : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- -- The entity for the the function spec
+ -- Any other kind of identifier in predicate (e.g. a non-static
+ -- expression value) means this is not a static predicate.
- SIdB : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- -- The entity for the function body
+ else
+ raise Non_Static;
+ end if;
+ end if;
+ end Membership_Entry;
- Spec : Node_Id;
- FDecl : Node_Id;
- FBody : Node_Id;
+ ---------------
+ -- Stat_Pred --
+ ---------------
- begin
- -- Build function declaration
+ function Stat_Pred (Typ : Entity_Id) return RList is
+ begin
+ -- Not static if type does not have static predicates
- Set_Ekind (SId, E_Function);
- Set_Is_Internal (SId);
- Set_Is_Predicate_Function (SId);
- Set_Predicate_Function (Typ, SId);
+ if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then
+ raise Non_Static;
+ end if;
- -- The predicate function is shared between views of a type
+ -- Otherwise we convert the predicate list to a range list
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Set_Predicate_Function (Full_View (Typ), SId);
- end if;
+ declare
+ Result : RList (1 .. List_Length (Static_Predicate (Typ)));
+ P : Node_Id;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ begin
+ P := First (Static_Predicate (Typ));
+ for J in Result'Range loop
+ Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
+ Next (P);
+ end loop;
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ return Result;
+ end;
+ end Stat_Pred;
- -- Build function body
+ -- Start of processing for Build_Discrete_Static_Predicate
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SIdB,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ begin
+ -- Analyze the expression to see if it is a static predicate
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => Expr))));
+ declare
+ Ranges : constant RList := Get_RList (Expr);
+ -- Range list from expression if it is static
- -- Insert declaration before freeze node and body after
+ Plist : List_Id;
- Insert_Before_And_Analyze (N, FDecl);
- Insert_After_And_Analyze (N, FBody);
- end;
+ begin
+ -- Convert range list into a form for the static predicate. In the
+ -- Ranges array, we just have raw ranges, these must be converted
+ -- to properly typed and analyzed static expressions or range nodes.
- -- Test for raise expressions present and if so build M version
+ -- Note: here we limit ranges to the ranges of the subtype, so that
+ -- a predicate is always false for values outside the subtype. That
+ -- seems fine, such values are invalid anyway, and considering them
+ -- to fail the predicate seems allowed and friendly, and furthermore
+ -- simplifies processing for case statements and loops.
- if Raise_Expression_Present then
+ Plist := New_List;
+
+ for J in Ranges'Range loop
declare
- SId : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "PredicateM"));
- -- The entity for the the function spec
+ Lo : Uint := Ranges (J).Lo;
+ Hi : Uint := Ranges (J).Hi;
- SIdB : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "PredicateM"));
- -- The entity for the function body
+ begin
+ -- Ignore completely out of range entry
- Spec : Node_Id;
- FDecl : Node_Id;
- FBody : Node_Id;
- BTemp : Entity_Id;
+ if Hi < TLo or else Lo > THi then
+ null;
- begin
- -- Mark any raise expressions for special expansion
+ -- Otherwise process entry
- Process_REs (Expr_M);
+ else
+ -- Adjust out of range value to subtype range
- -- Build function declaration
+ if Lo < TLo then
+ Lo := TLo;
+ end if;
- Set_Ekind (SId, E_Function);
- Set_Is_Predicate_Function_M (SId);
- Set_Predicate_Function_M (Typ, SId);
+ if Hi > THi then
+ Hi := THi;
+ end if;
- -- The predicate function is shared between views of a type
+ -- Convert range into required form
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Set_Predicate_Function_M (Full_View (Typ), SId);
+ Append_To (Plist, Build_Range (Lo, Hi));
end if;
+ end;
+ end loop;
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity_M,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ -- Processing was successful and all entries were static, so now we
+ -- can store the result as the predicate list.
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
+ Set_Static_Predicate (Typ, Plist);
- -- Build function body
+ -- The processing for static predicates put the expression into
+ -- canonical form as a series of ranges. It also eliminated
+ -- duplicates and collapsed and combined ranges. We might as well
+ -- replace the alternatives list of the right operand of the
+ -- membership test with the static predicate list, which will
+ -- usually be more efficient.
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SIdB,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Object_Name),
- Parameter_Type =>
- New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
+ declare
+ New_Alts : constant List_Id := New_List;
+ Old_Node : Node_Id;
+ New_Node : Node_Id;
- -- Build the body, we declare the boolean expression before
- -- doing the return, because we are not really confident of
- -- what happens if a return appears within a return.
+ begin
+ Old_Node := First (Plist);
+ while Present (Old_Node) loop
+ New_Node := New_Copy (Old_Node);
- BTemp :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('B'));
+ if Nkind (New_Node) = N_Range then
+ Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
+ Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
+ end if;
- FBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
+ Append_To (New_Alts, New_Node);
+ Next (Old_Node);
+ end loop;
- Declarations => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => BTemp,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => Expr_M)),
+ -- If empty list, replace by False
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression => New_Occurrence_Of (BTemp, Loc)))));
+ if Is_Empty_List (New_Alts) then
+ Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
- -- Insert declaration before freeze node and body after
+ -- Else replace by set membership test
- Insert_Before_And_Analyze (N, FDecl);
- Insert_After_And_Analyze (N, FBody);
- end;
- end if;
+ else
+ Rewrite (Expr,
+ Make_In (Loc,
+ Left_Opnd => Make_Identifier (Loc, Nam),
+ Right_Opnd => Empty,
+ Alternatives => New_Alts));
- if Is_Scalar_Type (Typ) then
+ -- Resolve new expression in function context
- -- Attempt to build a static predicate for a discrete or a real
- -- 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.
+ Install_Formals (Predicate_Function (Typ));
+ Push_Scope (Predicate_Function (Typ));
+ Analyze_And_Resolve (Expr, Standard_Boolean);
+ Pop_Scope;
+ end if;
+ end;
+ end;
- if Ekind_In (Typ, E_Decimal_Fixed_Point_Subtype,
- E_Enumeration_Subtype,
- E_Floating_Point_Subtype,
- E_Modular_Integer_Subtype,
- E_Ordinary_Fixed_Point_Subtype,
- E_Signed_Integer_Subtype)
- then
- Build_Static_Predicate (Typ, Expr, Object_Name);
+ -- If non-static, return doing nothing
- -- Emit an error when the predicate is categorized as static
- -- but its expression is dynamic.
+ exception
+ when Non_Static =>
+ return;
+ end Build_Discrete_Static_Predicate;
- 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;
- end if;
+ -------------------------------------------
+ -- Build_Invariant_Procedure_Declaration --
+ -------------------------------------------
- -- 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.
+ function Build_Invariant_Procedure_Declaration
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Object_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ Spec : Node_Id;
+ SId : Entity_Id;
- elsif Present (Static_Predic) and then Comes_From_Source (Typ) then
- if Is_Scalar_Type (Typ) then
- Error_Msg_FE
- ("static predicate not allowed for non-static type&",
- Typ, Typ);
- else
- Error_Msg_FE
- ("static predicate not allowed for non-scalar type&",
- Typ, Typ);
- end if;
- end if;
+ begin
+ Set_Etype (Object_Entity, Typ);
+
+ -- Check for duplicate definiations.
+
+ if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
+ return Empty;
end if;
- end Build_Predicate_Functions;
- ----------------------------
- -- Build_Static_Predicate --
- ----------------------------
+ SId :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Invariant"));
+ Set_Has_Invariants (Typ);
+ Set_Ekind (SId, E_Procedure);
+ Set_Is_Invariant_Procedure (SId);
+ Set_Invariant_Procedure (Typ, SId);
- procedure Build_Static_Predicate
- (Typ : Entity_Id;
- Expr : Node_Id;
- Nam : Name_Id)
- is
- Loc : constant Source_Ptr := Sloc (Expr);
+ Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))));
- Non_Static : exception;
- -- Raised if something non-static is found
+ return Make_Subprogram_Declaration (Loc, Specification => Spec);
+ end Build_Invariant_Procedure_Declaration;
+
+ -------------------------------
+ -- Build_Invariant_Procedure --
+ -------------------------------
+
+ -- The procedure that is constructed here has the form
+
+ -- procedure typInvariant (Ixxx : typ) is
+ -- begin
+ -- pragma Check (Invariant, exp, "failed invariant from xxx");
+ -- pragma Check (Invariant, exp, "failed invariant from xxx");
+ -- ...
+ -- pragma Check (Invariant, exp, "failed inherited invariant from xxx");
+ -- ...
+ -- end typInvariant;
+
+ procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Stmts : List_Id;
+ Spec : Node_Id;
+ SId : Entity_Id;
+ PDecl : Node_Id;
+ PBody : Node_Id;
- Btyp : constant Entity_Id := Base_Type (Typ);
+ Nam : Name_Id;
+ -- Name for Check pragma, usually Invariant, but might be Type_Invariant
+ -- if we come from a Type_Invariant aspect, we make sure to build the
+ -- Check pragma with the right name, so that Check_Policy works right.
- BLo : constant Uint := Expr_Value (Type_Low_Bound (Btyp));
- BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
- -- Low bound and high bound value of base type of Typ
+ Visible_Decls : constant List_Id := Visible_Declarations (N);
+ Private_Decls : constant List_Id := Private_Declarations (N);
- TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
- THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
- -- Low bound and high bound values of static subtype Typ
+ procedure Add_Invariants (T : Entity_Id; Inherit : Boolean);
+ -- Appends statements to Stmts for any invariants in the rep item chain
+ -- of the given type. If Inherit is False, then we only process entries
+ -- on the chain for the type Typ. If Inherit is True, then we ignore any
+ -- Invariant aspects, but we process all Invariant'Class aspects, adding
+ -- "inherited" to the exception message and generating an informational
+ -- message about the inheritance of an invariant.
- type REnt is record
- Lo, Hi : Uint;
- end record;
- -- One entry in a Rlist value, a single REnt (range entry) value denotes
- -- one range from Lo to Hi. To represent a single value range Lo = Hi =
- -- value.
+ Object_Name : Name_Id;
+ -- Name for argument of invariant procedure
- type RList is array (Nat range <>) of REnt;
- -- A list of ranges. The ranges are sorted in increasing order, and are
- -- disjoint (there is a gap of at least one value between each range in
- -- the table). A value is in the set of ranges in Rlist if it lies
- -- within one of these ranges.
+ Object_Entity : Node_Id;
+ -- The entity of the formal for the procedure
- False_Range : constant RList :=
- RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
- -- An empty set of ranges represents a range list that can never be
- -- satisfied, since there are no ranges in which the value could lie,
- -- so it does not lie in any of them. False_Range is a canonical value
- -- for this empty set, but general processing should test for an Rlist
- -- with length zero (see Is_False predicate), since other null ranges
- -- may appear which must be treated as False.
+ --------------------
+ -- Add_Invariants --
+ --------------------
- True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
- -- Range representing True, value must be in the base range
+ procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is
+ Ritem : Node_Id;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
+ Arg3 : Node_Id;
+ Exp : Node_Id;
+ Loc : Source_Ptr;
+ Assoc : List_Id;
+ Str : String_Id;
- function "and" (Left : RList; Right : RList) return RList;
- -- And's together two range lists, returning a range list. This is a set
- -- intersection operation.
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single occurrence N of the subtype name with a reference
+ -- to the formal of the predicate function. N can be an identifier
+ -- referencing the subtype, or a selected component, representing an
+ -- appropriately qualified occurrence of the subtype name.
- function "or" (Left : RList; Right : RList) return RList;
- -- Or's together two range lists, returning a range list. This is a set
- -- union operation.
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
+ -- Traverse an expression replacing all occurrences of the subtype
+ -- name with appropriate references to the object that is the formal
+ -- parameter of the predicate function. Note that we must ensure
+ -- that the type and entity information is properly set in the
+ -- replacement node, since we will do a Preanalyze call of this
+ -- expression without proper visibility of the procedure argument.
- function "not" (Right : RList) return RList;
- -- Returns complement of a given range list, i.e. a range list
- -- representing all the values in TLo .. THi that are not in the input
- -- operand Right.
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
- function Build_Val (V : Uint) return Node_Id;
- -- Return an analyzed N_Identifier node referencing this value, suitable
- -- for use as an entry in the Static_Predicate list. This node is typed
- -- with the base type.
+ -- Note: See comments in Add_Predicates.Replace_Type_Reference
+ -- regarding handling of Sloc and Comes_From_Source.
- function Build_Range (Lo : Uint; Hi : Uint) return Node_Id;
- -- Return an analyzed N_Range node referencing this range, suitable for
- -- use as an entry in the Static_Predicate list. This node is typed with
- -- the base type.
+ procedure Replace_Type_Reference (N : Node_Id) is
+ begin
- function Get_RList (Exp : Node_Id) return RList;
- -- This is a recursive routine that converts the given expression into a
- -- list of ranges, suitable for use in building the static predicate.
+ -- Add semantic information to node to be rewritten, for ASIS
+ -- navigation needs.
- function Is_False (R : RList) return Boolean;
- pragma Inline (Is_False);
- -- Returns True if the given range list is empty, and thus represents a
- -- False list of ranges that can never be satisfied.
+ if Nkind (N) = N_Identifier then
+ Set_Entity (N, T);
+ Set_Etype (N, T);
- function Is_True (R : RList) return Boolean;
- -- Returns True if R trivially represents the True predicate by having a
- -- single range from BLo to BHi.
+ elsif Nkind (N) = N_Selected_Component then
+ Analyze (Prefix (N));
+ Set_Entity (Selector_Name (N), T);
+ Set_Etype (Selector_Name (N), T);
+ end if;
- 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).
+ -- Invariant'Class, replace with T'Class (obj)
- function Lo_Val (N : Node_Id) return Uint;
- -- Given static expression or static range from a Static_Predicate list,
- -- gets expression value or low bound of range.
+ if Class_Present (Ritem) then
+ Rewrite (N,
+ Make_Type_Conversion (Sloc (N),
+ Subtype_Mark =>
+ Make_Attribute_Reference (Sloc (N),
+ Prefix => New_Occurrence_Of (T, Sloc (N)),
+ Attribute_Name => Name_Class),
+ Expression => Make_Identifier (Sloc (N), Object_Name)));
- function Hi_Val (N : Node_Id) return Uint;
- -- Given static expression or static range from a Static_Predicate list,
- -- gets expression value of high bound of range.
+ Set_Entity (Expression (N), Object_Entity);
+ Set_Etype (Expression (N), Typ);
- function Membership_Entry (N : Node_Id) return RList;
- -- Given a single membership entry (range, value, or subtype), returns
- -- the corresponding range list. Raises Static_Error if not static.
+ -- Invariant, replace with obj
- function Membership_Entries (N : Node_Id) return RList;
- -- Given an element on an alternatives list of a membership operation,
- -- returns the range list corresponding to this entry and all following
- -- entries (i.e. returns the "or" of this list of values).
+ else
+ Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
+ Set_Entity (N, Object_Entity);
+ Set_Etype (N, Typ);
+ end if;
- function Stat_Pred (Typ : Entity_Id) return RList;
- -- Given a type, if it has a static predicate, then return the predicate
- -- as a range list, otherwise raise Non_Static.
+ Set_Comes_From_Source (N, True);
+ end Replace_Type_Reference;
- -----------
- -- "and" --
- -----------
+ -- Start of processing for Add_Invariants
- function "and" (Left : RList; Right : RList) return RList is
- FEnt : REnt;
- -- First range of result
+ begin
+ Ritem := First_Rep_Item (T);
+ while Present (Ritem) loop
+ if Nkind (Ritem) = N_Pragma
+ and then Pragma_Name (Ritem) = Name_Invariant
+ then
+ Arg1 := First (Pragma_Argument_Associations (Ritem));
+ Arg2 := Next (Arg1);
+ Arg3 := Next (Arg2);
- SLeft : Nat := Left'First;
- -- Start of rest of left entries
+ Arg1 := Get_Pragma_Arg (Arg1);
+ Arg2 := Get_Pragma_Arg (Arg2);
- SRight : Nat := Right'First;
- -- Start of rest of right entries
+ -- For Inherit case, ignore Invariant, process only Class case
- begin
- -- If either range is True, return the other
+ if Inherit then
+ if not Class_Present (Ritem) then
+ goto Continue;
+ end if;
- if Is_True (Left) then
- return Right;
- elsif Is_True (Right) then
- return Left;
- end if;
+ -- For Inherit false, process only item for right type
- -- If either range is False, return False
+ else
+ if Entity (Arg1) /= Typ then
+ goto Continue;
+ end if;
+ end if;
- if Is_False (Left) or else Is_False (Right) then
- return False_Range;
- end if;
+ if No (Stmts) then
+ Stmts := Empty_List;
+ end if;
- -- Loop to remove entries at start that are disjoint, and thus just
- -- get discarded from the result entirely.
+ Exp := New_Copy_Tree (Arg2);
- loop
- -- If no operands left in either operand, result is false
+ -- Preserve sloc of original pragma Invariant
- if SLeft > Left'Last or else SRight > Right'Last then
- return False_Range;
+ Loc := Sloc (Ritem);
- -- Discard first left operand entry if disjoint with right
+ -- We need to replace any occurrences of the name of the type
+ -- with references to the object, converted to type'Class in
+ -- the case of Invariant'Class aspects.
- elsif Left (SLeft).Hi < Right (SRight).Lo then
- SLeft := SLeft + 1;
+ Replace_Type_References (Exp, Chars (T));
- -- Discard first right operand entry if disjoint with left
+ -- If this invariant comes from an aspect, find the aspect
+ -- specification, and replace the saved expression because
+ -- we need the subtype references replaced for the calls to
+ -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
+ -- and Check_Aspect_At_End_Of_Declarations.
- elsif Right (SRight).Hi < Left (SLeft).Lo then
- SRight := SRight + 1;
+ if From_Aspect_Specification (Ritem) then
+ declare
+ Aitem : Node_Id;
- -- Otherwise we have an overlapping entry
+ begin
+ -- Loop to find corresponding aspect, note that this
+ -- must be present given the pragma is marked delayed.
- else
- exit;
- end if;
- end loop;
+ -- Note: in practice Next_Rep_Item (Ritem) is Empty so
+ -- this loop does nothing. Furthermore, why isn't this
+ -- simply Corresponding_Aspect ???
- -- Now we have two non-null operands, and first entries overlap. The
- -- first entry in the result will be the overlapping part of these
- -- two entries.
+ Aitem := Next_Rep_Item (Ritem);
+ while Present (Aitem) loop
+ if Nkind (Aitem) = N_Aspect_Specification
+ and then Aspect_Rep_Item (Aitem) = Ritem
+ then
+ Set_Entity
+ (Identifier (Aitem), New_Copy_Tree (Exp));
+ exit;
+ end if;
- FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo),
- Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi));
+ Aitem := Next_Rep_Item (Aitem);
+ end loop;
+ end;
+ end if;
- -- Now we can remove the entry that ended at a lower value, since its
- -- contribution is entirely contained in Fent.
+ -- Now we need to preanalyze the expression to properly capture
+ -- the visibility in the visible part. The expression will not
+ -- be analyzed for real until the body is analyzed, but that is
+ -- at the end of the private part and has the wrong visibility.
- if Left (SLeft).Hi <= Right (SRight).Hi then
- SLeft := SLeft + 1;
- else
- SRight := SRight + 1;
- end if;
+ Set_Parent (Exp, N);
+ Preanalyze_Assert_Expression (Exp, Standard_Boolean);
- -- Compute result by concatenating this first entry with the "and" of
- -- the remaining parts of the left and right operands. Note that if
- -- either of these is empty, "and" will yield empty, so that we will
- -- end up with just Fent, which is what we want in that case.
+ -- In ASIS mode, even if assertions are not enabled, we must
+ -- analyze the original expression in the aspect specification
+ -- because it is part of the original tree.
- return
- FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
- end "and";
+ if ASIS_Mode and then From_Aspect_Specification (Ritem) then
+ declare
+ Inv : constant Node_Id :=
+ Expression (Corresponding_Aspect (Ritem));
+ begin
+ Replace_Type_References (Inv, Chars (T));
+ Preanalyze_Assert_Expression (Inv, Standard_Boolean);
+ end;
+ end if;
- -----------
- -- "not" --
- -----------
+ -- Get name to be used for Check pragma
- function "not" (Right : RList) return RList is
- begin
- -- Return True if False range
+ if not From_Aspect_Specification (Ritem) then
+ Nam := Name_Invariant;
+ else
+ Nam := Chars (Identifier (Corresponding_Aspect (Ritem)));
+ end if;
- if Is_False (Right) then
- return True_Range;
- end if;
+ -- Build first two arguments for Check pragma
- -- Return False if True range
+ Assoc :=
+ New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Chars => Nam)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Exp));
- if Is_True (Right) then
- return False_Range;
- end if;
+ -- Add message if present in Invariant pragma
- -- Here if not trivial case
+ if Present (Arg3) then
+ Str := Strval (Get_Pragma_Arg (Arg3));
- declare
- Result : RList (1 .. Right'Length + 1);
- -- May need one more entry for gap at beginning and end
+ -- If inherited case, and message starts "failed invariant",
+ -- change it to be "failed inherited invariant".
- Count : Nat := 0;
- -- Number of entries stored in Result
+ if Inherit then
+ String_To_Name_Buffer (Str);
- begin
- -- Gap at start
+ if Name_Buffer (1 .. 16) = "failed invariant" then
+ Insert_Str_In_Name_Buffer ("inherited ", 8);
+ Str := String_From_Name_Buffer;
+ end if;
+ end if;
- if Right (Right'First).Lo > TLo then
- Count := Count + 1;
- Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1);
- end if;
+ Append_To (Assoc,
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_String_Literal (Loc, Str)));
+ end if;
- -- Gaps between ranges
+ -- Add Check pragma to list of statements
- for J in Right'First .. Right'Last - 1 loop
- Count := Count + 1;
- Result (Count) :=
- REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1);
- end loop;
+ Append_To (Stmts,
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Name_Check),
+ Pragma_Argument_Associations => Assoc));
- -- Gap at end
+ -- If Inherited case and option enabled, output info msg. Note
+ -- that we know this is a case of Invariant'Class.
- if Right (Right'Last).Hi < THi then
- Count := Count + 1;
- Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi);
+ if Inherit and Opt.List_Inherited_Aspects then
+ Error_Msg_Sloc := Sloc (Ritem);
+ Error_Msg_N
+ ("info: & inherits `Invariant''Class` aspect from #?L?",
+ Typ);
+ end if;
end if;
- return Result (1 .. Count);
- end;
- end "not";
+ <<Continue>>
+ Next_Rep_Item (Ritem);
+ end loop;
+ end Add_Invariants;
- ----------
- -- "or" --
- ----------
+ -- Start of processing for Build_Invariant_Procedure
- function "or" (Left : RList; Right : RList) return RList is
- FEnt : REnt;
- -- First range of result
+ begin
+ Stmts := No_List;
+ PDecl := Empty;
+ PBody := Empty;
+ SId := Empty;
- SLeft : Nat := Left'First;
- -- Start of rest of left entries
+ -- If the aspect specification exists for some view of the type, the
+ -- declaration for the procedure has been created.
- SRight : Nat := Right'First;
- -- Start of rest of right entries
+ if Has_Invariants (Typ) then
+ SId := Invariant_Procedure (Typ);
+ end if;
- begin
- -- If either range is True, return True
+ if Present (SId) then
+ PDecl := Unit_Declaration_Node (SId);
+ else
+ PDecl := Build_Invariant_Procedure_Declaration (Typ);
+ end if;
- if Is_True (Left) or else Is_True (Right) then
- return True_Range;
- end if;
+ -- Recover formal of procedure, for use in the calls to invariant
+ -- functions (including inherited ones).
- -- If either range is False (empty), return the other
+ Object_Entity :=
+ Defining_Identifier
+ (First (Parameter_Specifications (Specification (PDecl))));
+ Object_Name := Chars (Object_Entity);
- if Is_False (Left) then
- return Right;
- elsif Is_False (Right) then
- return Left;
- end if;
+ -- Add invariants for the current type
- -- Initialize result first entry from left or right operand depending
- -- on which starts with the lower range.
+ Add_Invariants (Typ, Inherit => False);
- if Left (SLeft).Lo < Right (SRight).Lo then
- FEnt := Left (SLeft);
- SLeft := SLeft + 1;
- else
- FEnt := Right (SRight);
- SRight := SRight + 1;
- end if;
+ -- Add invariants for parent types
- -- This loop eats ranges from left and right operands that are
- -- contiguous with the first range we are gathering.
+ declare
+ Current_Typ : Entity_Id;
+ Parent_Typ : Entity_Id;
+ begin
+ Current_Typ := Typ;
loop
- -- Eat first entry in left operand if contiguous or overlapped by
- -- gathered first operand of result.
+ Parent_Typ := Etype (Current_Typ);
- if SLeft <= Left'Last
- and then Left (SLeft).Lo <= FEnt.Hi + 1
+ if Is_Private_Type (Parent_Typ)
+ and then Present (Full_View (Base_Type (Parent_Typ)))
then
- FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
- SLeft := SLeft + 1;
+ Parent_Typ := Full_View (Base_Type (Parent_Typ));
+ end if;
- -- Eat first entry in right operand if contiguous or overlapped by
- -- gathered right operand of result.
+ exit when Parent_Typ = Current_Typ;
- elsif SRight <= Right'Last
- and then Right (SRight).Lo <= FEnt.Hi + 1
- then
- FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
- SRight := SRight + 1;
+ Current_Typ := Parent_Typ;
+ Add_Invariants (Current_Typ, Inherit => True);
+ end loop;
+ end;
- -- All done if no more entries to eat
+ -- Build the procedure if we generated at least one Check pragma
- else
- exit;
- end if;
- end loop;
+ if Stmts /= No_List then
+ Spec := Copy_Separate_Tree (Specification (PDecl));
- -- Obtain result as the first entry we just computed, concatenated
- -- to the "or" of the remaining results (if one operand is empty,
- -- this will just concatenate with the other
+ PBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- return
- FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
- end "or";
+ -- Insert procedure declaration and spec at the appropriate points.
+ -- If declaration is already analyzed, it was processed by the
+ -- generated pragma.
- -----------------
- -- Build_Range --
- -----------------
+ if Present (Private_Decls) then
- function Build_Range (Lo : Uint; Hi : Uint) return Node_Id is
- Result : Node_Id;
+ -- The spec goes at the end of visible declarations, but they have
+ -- already been analyzed, so we need to explicitly do the analyze.
- begin
- Result :=
- Make_Range (Loc,
- Low_Bound => Build_Val (Lo),
- High_Bound => Build_Val (Hi));
- Set_Etype (Result, Btyp);
- Set_Analyzed (Result);
+ if not Analyzed (PDecl) then
+ Append_To (Visible_Decls, PDecl);
+ Analyze (PDecl);
+ end if;
- return Result;
- end Build_Range;
+ -- The body goes at the end of the private declarations, which we
+ -- have not analyzed yet, so we do not need to perform an explicit
+ -- analyze call. We skip this if there are no private declarations
+ -- (this is an error that will be caught elsewhere);
- ---------------
- -- Build_Val --
- ---------------
+ Append_To (Private_Decls, PBody);
- function Build_Val (V : Uint) return Node_Id is
- Result : Node_Id;
+ -- If the invariant appears on the full view of a type, the
+ -- analysis of the private part is complete, and we must
+ -- analyze the new body explicitly.
- begin
- if Is_Enumeration_Type (Typ) then
- Result := Get_Enum_Lit_From_Pos (Typ, V, Loc);
- else
- Result := Make_Integer_Literal (Loc, V);
- end if;
+ if In_Private_Part (Current_Scope) then
+ Analyze (PBody);
+ end if;
- Set_Etype (Result, Btyp);
- Set_Is_Static_Expression (Result);
- Set_Analyzed (Result);
- return Result;
- end Build_Val;
+ -- If there are no private declarations this may be an error that
+ -- will be diagnosed elsewhere. However, if this is a non-private
+ -- type that inherits invariants, it needs no completion and there
+ -- may be no private part. In this case insert invariant procedure
+ -- at end of current declarative list, and analyze at once, given
+ -- that the type is about to be frozen.
- ---------------
- -- Get_RList --
- ---------------
+ elsif not Is_Private_Type (Typ) then
+ Append_To (Visible_Decls, PDecl);
+ Append_To (Visible_Decls, PBody);
+ Analyze (PDecl);
+ Analyze (PBody);
+ end if;
+ end if;
+ end Build_Invariant_Procedure;
- function Get_RList (Exp : Node_Id) return RList is
- Op : Node_Kind;
- Val : Uint;
+ -------------------------------
+ -- Build_Predicate_Functions --
+ -------------------------------
- begin
- -- Static expression can only be true or false
+ -- The procedures that are constructed here have the form:
- if Is_OK_Static_Expression (Exp) then
+ -- function typPredicate (Ixxx : typ) return Boolean is
+ -- begin
+ -- return
+ -- exp1 and then exp2 and then ...
+ -- and then typ1Predicate (typ1 (Ixxx))
+ -- and then typ2Predicate (typ2 (Ixxx))
+ -- and then ...;
+ -- end typPredicate;
- -- For False
+ -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that
+ -- this is the point at which these expressions get analyzed, providing the
+ -- required delay, and typ1, typ2, are entities from which predicates are
+ -- inherited. Note that we do NOT generate Check pragmas, that's because we
+ -- use this function even if checks are off, e.g. for membership tests.
- if Expr_Value (Exp) = 0 then
- return False_Range;
- else
- return True_Range;
- end if;
- end if;
+ -- If the expression has at least one Raise_Expression, then we also build
+ -- the typPredicateM version of the function, in which any occurrence of a
+ -- Raise_Expression is converted to "return False".
- -- Otherwise test node type
+ procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
- Op := Nkind (Exp);
+ Expr : Node_Id;
+ -- This is the expression for the result of the function. It is
+ -- is build by connecting the component predicates with AND THEN.
- case Op is
+ Expr_M : Node_Id;
+ -- This is the corresponding return expression for the Predicate_M
+ -- function. It differs in that raise expressions are marked for
+ -- special expansion (see Process_REs).
- -- And
+ Object_Name : constant Name_Id := New_Internal_Name ('I');
+ -- Name for argument of Predicate procedure. Note that we use the same
+ -- name for both predicate procedure. That way the reference within the
+ -- predicate expression is the same in both functions.
- when N_Op_And | N_And_Then =>
- return Get_RList (Left_Opnd (Exp))
- and
- Get_RList (Right_Opnd (Exp));
+ Object_Entity : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => Object_Name);
+ -- Entity for argument of Predicate procedure
- -- Or
+ Object_Entity_M : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Chars => Object_Name);
+ -- Entity for argument of Predicate_M procedure
- when N_Op_Or | N_Or_Else =>
- return Get_RList (Left_Opnd (Exp))
- or
- Get_RList (Right_Opnd (Exp));
+ Raise_Expression_Present : Boolean := False;
+ -- Set True if Expr has at least one Raise_Expression
- -- Not
+ Static_Predic : Node_Id := Empty;
+ -- Set to N_Pragma node for a static predicate if one is encountered
- when N_Op_Not =>
- return not Get_RList (Right_Opnd (Exp));
+ 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.
- -- Comparisons of type with static value
+ procedure Add_Predicates;
+ -- Appends expressions for any Predicate pragmas in the rep item chain
+ -- Typ to Expr. Note that we look only at items for this exact entity.
+ -- Inheritance of predicates for the parent type is done by calling the
+ -- Predicate_Function of the parent type, using Add_Call above.
- when N_Op_Compare =>
+ function Test_RE (N : Node_Id) return Traverse_Result;
+ -- Used in Test_REs, tests one node for being a raise expression, and if
+ -- so sets Raise_Expression_Present True.
- -- Type is left operand
+ procedure Test_REs is new Traverse_Proc (Test_RE);
+ -- Tests to see if Expr contains any raise expressions
- if Is_Type_Ref (Left_Opnd (Exp))
- and then Is_OK_Static_Expression (Right_Opnd (Exp))
- then
- Val := Expr_Value (Right_Opnd (Exp));
+ function Process_RE (N : Node_Id) return Traverse_Result;
+ -- Used in Process REs, tests if node N is a raise expression, and if
+ -- so, marks it to be converted to return False.
- -- Typ is right operand
+ procedure Process_REs is new Traverse_Proc (Process_RE);
+ -- Marks any raise expressions in Expr_M to return False
- elsif Is_Type_Ref (Right_Opnd (Exp))
- and then Is_OK_Static_Expression (Left_Opnd (Exp))
- then
- Val := Expr_Value (Left_Opnd (Exp));
+ --------------
+ -- Add_Call --
+ --------------
- -- Invert sense of comparison
+ procedure Add_Call (T : Entity_Id) is
+ Exp : Node_Id;
- case Op is
- when N_Op_Gt => Op := N_Op_Lt;
- when N_Op_Lt => Op := N_Op_Gt;
- when N_Op_Ge => Op := N_Op_Le;
- when N_Op_Le => Op := N_Op_Ge;
- when others => null;
- end case;
+ begin
+ if Present (T) and then Present (Predicate_Function (T)) then
+ Set_Has_Predicates (Typ);
- -- Other cases are non-static
+ -- Build the call to the predicate function of T
- else
- raise Non_Static;
- end if;
+ Exp :=
+ Make_Predicate_Call
+ (T, Convert_To (T, Make_Identifier (Loc, Object_Name)));
- -- Construct range according to comparison operation
+ -- Add call to evolving expression, using AND THEN if needed
- case Op is
- when N_Op_Eq =>
- return RList'(1 => REnt'(Val, Val));
+ if No (Expr) then
+ Expr := Exp;
+ else
+ Expr :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Expr),
+ Right_Opnd => Exp);
+ end if;
- when N_Op_Ge =>
- return RList'(1 => REnt'(Val, BHi));
+ -- Output info message on inheritance if required. Note we do not
+ -- give this information for generic actual types, since it is
+ -- unwelcome noise in that case in instantiations. We also
+ -- generally suppress the message in instantiations, and also
+ -- if it involves internal names.
- when N_Op_Gt =>
- return RList'(1 => REnt'(Val + 1, BHi));
+ if Opt.List_Inherited_Aspects
+ and then not Is_Generic_Actual_Type (Typ)
+ and then Instantiation_Depth (Sloc (Typ)) = 0
+ and then not Is_Internal_Name (Chars (T))
+ and then not Is_Internal_Name (Chars (Typ))
+ then
+ Error_Msg_Sloc := Sloc (Predicate_Function (T));
+ Error_Msg_Node_2 := T;
+ Error_Msg_N ("info: & inherits predicate from & #?L?", Typ);
+ end if;
+ end if;
+ end Add_Call;
- when N_Op_Le =>
- return RList'(1 => REnt'(BLo, Val));
+ --------------------
+ -- Add_Predicates --
+ --------------------
- when N_Op_Lt =>
- return RList'(1 => REnt'(BLo, Val - 1));
+ procedure Add_Predicates is
+ Ritem : Node_Id;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
- when N_Op_Ne =>
- return RList'(REnt'(BLo, Val - 1),
- REnt'(Val + 1, BHi));
+ procedure Replace_Type_Reference (N : Node_Id);
+ -- Replace a single occurrence N of the subtype name with a reference
+ -- to the formal of the predicate function. N can be an identifier
+ -- referencing the subtype, or a selected component, representing an
+ -- appropriately qualified occurrence of the subtype name.
- when others =>
- raise Program_Error;
- end case;
+ procedure Replace_Type_References is
+ new Replace_Type_References_Generic (Replace_Type_Reference);
+ -- Traverse an expression changing every occurrence of an identifier
+ -- whose name matches the name of the subtype with a reference to
+ -- the formal parameter of the predicate function.
- -- Membership (IN)
+ ----------------------------
+ -- Replace_Type_Reference --
+ ----------------------------
- when N_In =>
- if not Is_Type_Ref (Left_Opnd (Exp)) then
- raise Non_Static;
- end if;
+ procedure Replace_Type_Reference (N : Node_Id) is
+ begin
+ Rewrite (N, Make_Identifier (Sloc (N), Object_Name));
+ -- Use the Sloc of the usage name, not the defining name
- if Present (Right_Opnd (Exp)) then
- return Membership_Entry (Right_Opnd (Exp));
- else
- return Membership_Entries (First (Alternatives (Exp)));
- end if;
+ Set_Etype (N, Typ);
+ Set_Entity (N, Object_Entity);
- -- Negative membership (NOT IN)
+ -- We want to treat the node as if it comes from source, so that
+ -- ASIS will not ignore it
- when N_Not_In =>
- if not Is_Type_Ref (Left_Opnd (Exp)) then
- raise Non_Static;
- end if;
+ Set_Comes_From_Source (N, True);
+ end Replace_Type_Reference;
- if Present (Right_Opnd (Exp)) then
- return not Membership_Entry (Right_Opnd (Exp));
- else
- return not Membership_Entries (First (Alternatives (Exp)));
- end if;
+ -- Start of processing for Add_Predicates
- -- Function call, may be call to static predicate
+ begin
+ Ritem := First_Rep_Item (Typ);
+ while Present (Ritem) loop
+ 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.
- when N_Function_Call =>
- if Is_Entity_Name (Name (Exp)) then
- declare
- Ent : constant Entity_Id := Entity (Name (Exp));
- begin
- if Is_Predicate_Function (Ent)
- or else
- Is_Predicate_Function_M (Ent)
- then
- return Stat_Pred (Etype (First_Formal (Ent)));
- end if;
- end;
+ if Present (Corresponding_Aspect (Ritem))
+ and then Chars (Identifier (Corresponding_Aspect (Ritem))) =
+ Name_Static_Predicate
+ then
+ Static_Predic := Ritem;
end if;
- -- Other function call cases are non-static
-
- raise Non_Static;
+ -- Acquire arguments
- -- Qualified expression, dig out the expression
+ Arg1 := First (Pragma_Argument_Associations (Ritem));
+ Arg2 := Next (Arg1);
- when N_Qualified_Expression =>
- return Get_RList (Expression (Exp));
+ Arg1 := Get_Pragma_Arg (Arg1);
+ Arg2 := Get_Pragma_Arg (Arg2);
- when N_Case_Expression =>
- declare
- Alt : Node_Id;
- Choices : List_Id;
- Dep : Node_Id;
+ -- See if this predicate pragma is for the current type or for
+ -- its full view. A predicate on a private completion is placed
+ -- on the partial view beause this is the visible entity that
+ -- is frozen.
- begin
- if not Is_Entity_Name (Expression (Expr))
- or else Etype (Expression (Expr)) /= Typ
+ if Entity (Arg1) = Typ
+ or else Full_View (Entity (Arg1)) = Typ
then
- Error_Msg_N
- ("expression must denaote subtype", Expression (Expr));
- return False_Range;
- end if;
+ -- We have a match, this entry is for our subtype
- -- Collect discrete choices in all True alternatives
+ -- We need to replace any occurrences of the name of the
+ -- type with references to the object.
- Choices := New_List;
- Alt := First (Alternatives (Exp));
- while Present (Alt) loop
- Dep := Expression (Alt);
+ Replace_Type_References (Arg2, Chars (Typ));
- if not Is_Static_Expression (Dep) then
- raise Non_Static;
+ -- If this predicate comes from an aspect, find the aspect
+ -- specification, and replace the saved expression because
+ -- we need the subtype references replaced for the calls to
+ -- Preanalyze_Spec_Expressin in Check_Aspect_At_Freeze_Point
+ -- and Check_Aspect_At_End_Of_Declarations.
- elsif Is_True (Expr_Value (Dep)) then
- Append_List_To (Choices,
- New_Copy_List (Discrete_Choices (Alt)));
- end if;
+ if From_Aspect_Specification (Ritem) then
+ declare
+ Aitem : Node_Id;
- Next (Alt);
- end loop;
+ begin
+ -- Loop to find corresponding aspect, note that this
+ -- must be present given the pragma is marked delayed.
- return Membership_Entries (First (Choices));
- end;
+ Aitem := Next_Rep_Item (Ritem);
+ loop
+ if Nkind (Aitem) = N_Aspect_Specification
+ and then Aspect_Rep_Item (Aitem) = Ritem
+ then
+ Set_Entity
+ (Identifier (Aitem), New_Copy_Tree (Arg2));
+ exit;
+ end if;
- -- Expression with actions: if no actions, dig out expression
+ Aitem := Next_Rep_Item (Aitem);
+ end loop;
+ end;
+ end if;
- when N_Expression_With_Actions =>
- if Is_Empty_List (Actions (Exp)) then
- return Get_RList (Expression (Exp));
- else
- raise Non_Static;
- end if;
+ -- Now we can add the expression
- -- Xor operator
+ if No (Expr) then
+ Expr := Relocate_Node (Arg2);
- when N_Op_Xor =>
- return (Get_RList (Left_Opnd (Exp))
- and not Get_RList (Right_Opnd (Exp)))
- or (Get_RList (Right_Opnd (Exp))
- and not Get_RList (Left_Opnd (Exp)));
+ -- There already was a predicate, so add to it
- -- Any other node type is non-static
+ else
+ Expr :=
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (Expr),
+ Right_Opnd => Relocate_Node (Arg2));
+ end if;
+ end if;
+ end if;
- when others =>
- raise Non_Static;
- end case;
- end Get_RList;
+ Next_Rep_Item (Ritem);
+ end loop;
+ end Add_Predicates;
- ------------
- -- Hi_Val --
- ------------
+ ----------------
+ -- Process_RE --
+ ----------------
- function Hi_Val (N : Node_Id) return Uint is
+ function Process_RE (N : Node_Id) return Traverse_Result is
begin
- if Is_Static_Expression (N) then
- return Expr_Value (N);
+ if Nkind (N) = N_Raise_Expression then
+ Set_Convert_To_Return_False (N);
+ return Skip;
else
- pragma Assert (Nkind (N) = N_Range);
- return Expr_Value (High_Bound (N));
+ return OK;
end if;
- end Hi_Val;
-
- --------------
- -- Is_False --
- --------------
-
- function Is_False (R : RList) return Boolean is
- begin
- return R'Length = 0;
- end Is_False;
+ end Process_RE;
-------------
- -- Is_True --
+ -- Test_RE --
-------------
- function Is_True (R : RList) return Boolean is
+ function Test_RE (N : Node_Id) return Traverse_Result is
begin
- return R'Length = 1
- and then R (R'First).Lo = BLo
- and then R (R'First).Hi = BHi;
- end Is_True;
+ if Nkind (N) = N_Raise_Expression then
+ Raise_Expression_Present := True;
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Test_RE;
- -----------------
- -- Is_Type_Ref --
- -----------------
+ -- Start of processing for Build_Predicate_Functions
- function Is_Type_Ref (N : Node_Id) return Boolean is
- begin
- return Nkind (N) = N_Identifier and then Chars (N) = Nam;
- end Is_Type_Ref;
+ begin
+ -- Return if already built or if type does not have predicates
- ------------
- -- Lo_Val --
- ------------
+ if not Has_Predicates (Typ)
+ or else Present (Predicate_Function (Typ))
+ then
+ return;
+ end if;
- function Lo_Val (N : Node_Id) return Uint is
- begin
- if Is_Static_Expression (N) then
- return Expr_Value (N);
- else
- pragma Assert (Nkind (N) = N_Range);
- return Expr_Value (Low_Bound (N));
- end if;
- end Lo_Val;
+ -- Prepare to construct predicate expression
- ------------------------
- -- Membership_Entries --
- ------------------------
+ Expr := Empty;
- function Membership_Entries (N : Node_Id) return RList is
- begin
- if No (Next (N)) then
- return Membership_Entry (N);
- else
- return Membership_Entry (N) or Membership_Entries (Next (N));
- end if;
- end Membership_Entries;
+ -- Add Predicates for the current type
- ----------------------
- -- Membership_Entry --
- ----------------------
+ Add_Predicates;
- function Membership_Entry (N : Node_Id) return RList is
- Val : Uint;
- SLo : Uint;
- SHi : Uint;
+ -- Add predicates for ancestor if present
+ declare
+ Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
begin
- -- Range case
-
- if Nkind (N) = N_Range then
- if not Is_Static_Expression (Low_Bound (N))
- or else
- not Is_Static_Expression (High_Bound (N))
- then
- raise Non_Static;
- else
- SLo := Expr_Value (Low_Bound (N));
- SHi := Expr_Value (High_Bound (N));
- return RList'(1 => REnt'(SLo, SHi));
- end if;
+ if Present (Atyp) then
+ Add_Call (Atyp);
+ end if;
+ end;
- -- Static expression case
+ -- Case where predicates are present
- elsif Is_Static_Expression (N) then
- Val := Expr_Value (N);
- return RList'(1 => REnt'(Val, Val));
+ if Present (Expr) then
- -- Identifier (other than static expression) case
+ -- Test for raise expression present
- else pragma Assert (Nkind (N) = N_Identifier);
+ Test_REs (Expr);
- -- Type case
+ -- If raise expression is present, capture a copy of Expr for use
+ -- in building the predicateM function version later on. For this
+ -- copy we replace references to Object_Entity by Object_Entity_M.
- if Is_Type (Entity (N)) then
+ if Raise_Expression_Present then
+ declare
+ Map : constant Elist_Id := New_Elmt_List;
+ begin
+ Append_Elmt (Object_Entity, Map);
+ Append_Elmt (Object_Entity_M, Map);
+ Expr_M := New_Copy_Tree (Expr, Map => Map);
+ end;
+ end if;
- -- If type has predicates, process them
+ -- Build the main predicate function
- if Has_Predicates (Entity (N)) then
- return Stat_Pred (Entity (N));
+ declare
+ SId : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ -- The entity for the the function spec
- -- For static subtype without predicates, get range
+ SIdB : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+ -- The entity for the function body
- elsif Is_Static_Subtype (Entity (N)) then
- SLo := Expr_Value (Type_Low_Bound (Entity (N)));
- SHi := Expr_Value (Type_High_Bound (Entity (N)));
- return RList'(1 => REnt'(SLo, SHi));
+ Spec : Node_Id;
+ FDecl : Node_Id;
+ FBody : Node_Id;
- -- Any other type makes us non-static
+ begin
+ -- Build function declaration
- else
- raise Non_Static;
- end if;
+ Set_Ekind (SId, E_Function);
+ Set_Is_Internal (SId);
+ Set_Is_Predicate_Function (SId);
+ Set_Predicate_Function (Typ, SId);
- -- Any other kind of identifier in predicate (e.g. a non-static
- -- expression value) means this is not a static predicate.
+ -- The predicate function is shared between views of a type
- else
- raise Non_Static;
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Set_Predicate_Function (Full_View (Typ), SId);
end if;
- end if;
- end Membership_Entry;
- ---------------
- -- Stat_Pred --
- ---------------
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
- function Stat_Pred (Typ : Entity_Id) return RList is
- begin
- -- Not static if type does not have static predicates
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
- if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then
- raise Non_Static;
- end if;
+ -- Build function body
- -- Otherwise we convert the predicate list to a range list
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SIdB,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
- declare
- Result : RList (1 .. List_Length (Static_Predicate (Typ)));
- P : Node_Id;
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => Expr))));
- begin
- P := First (Static_Predicate (Typ));
- for J in Result'Range loop
- Result (J) := REnt'(Lo_Val (P), Hi_Val (P));
- Next (P);
- end loop;
+ -- Insert declaration before freeze node and body after
- return Result;
+ Insert_Before_And_Analyze (N, FDecl);
+ Insert_After_And_Analyze (N, FBody);
end;
- end Stat_Pred;
-
- -- Start of processing for Build_Static_Predicate
- begin
- -- Now analyze the expression to see if it is a static predicate
+ -- Test for raise expressions present and if so build M version
- declare
- Ranges : constant RList := Get_RList (Expr);
- -- Range list from expression if it is static
+ if Raise_Expression_Present then
+ declare
+ SId : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "PredicateM"));
+ -- The entity for the the function spec
- Plist : List_Id;
+ SIdB : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "PredicateM"));
+ -- The entity for the function body
- begin
- -- Convert range list into a form for the static predicate. In the
- -- Ranges array, we just have raw ranges, these must be converted
- -- to properly typed and analyzed static expressions or range nodes.
+ Spec : Node_Id;
+ FDecl : Node_Id;
+ FBody : Node_Id;
+ BTemp : Entity_Id;
- -- Note: here we limit ranges to the ranges of the subtype, so that
- -- a predicate is always false for values outside the subtype. That
- -- seems fine, such values are invalid anyway, and considering them
- -- to fail the predicate seems allowed and friendly, and furthermore
- -- simplifies processing for case statements and loops.
+ begin
+ -- Mark any raise expressions for special expansion
- Plist := New_List;
+ Process_REs (Expr_M);
- for J in Ranges'Range loop
- declare
- Lo : Uint := Ranges (J).Lo;
- Hi : Uint := Ranges (J).Hi;
+ -- Build function declaration
- begin
- -- Ignore completely out of range entry
+ Set_Ekind (SId, E_Function);
+ Set_Is_Predicate_Function_M (SId);
+ Set_Predicate_Function_M (Typ, SId);
- if Hi < TLo or else Lo > THi then
- null;
+ -- The predicate function is shared between views of a type
- -- Otherwise process entry
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Set_Predicate_Function_M (Full_View (Typ), SId);
+ end if;
- else
- -- Adjust out of range value to subtype range
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SId,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Object_Entity_M,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
- if Lo < TLo then
- Lo := TLo;
- end if;
+ FDecl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Spec);
- if Hi > THi then
- Hi := THi;
- end if;
+ -- Build function body
- -- Convert range into required form
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => SIdB,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Object_Name),
+ Parameter_Type =>
+ New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
- Append_To (Plist, Build_Range (Lo, Hi));
- end if;
- end;
- end loop;
+ -- Build the body, we declare the boolean expression before
+ -- doing the return, because we are not really confident of
+ -- what happens if a return appears within a return.
- -- Processing was successful and all entries were static, so now we
- -- can store the result as the predicate list.
+ BTemp :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('B'));
- Set_Static_Predicate (Typ, Plist);
+ FBody :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec,
- -- The processing for static predicates put the expression into
- -- canonical form as a series of ranges. It also eliminated
- -- duplicates and collapsed and combined ranges. We might as well
- -- replace the alternatives list of the right operand of the
- -- membership test with the static predicate list, which will
- -- usually be more efficient.
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => BTemp,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => Expr_M)),
- declare
- New_Alts : constant List_Id := New_List;
- Old_Node : Node_Id;
- New_Node : Node_Id;
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (BTemp, Loc)))));
- begin
- Old_Node := First (Plist);
- while Present (Old_Node) loop
- New_Node := New_Copy (Old_Node);
+ -- Insert declaration before freeze node and body after
- if Nkind (New_Node) = N_Range then
- Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node)));
- Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
- end if;
+ Insert_Before_And_Analyze (N, FDecl);
+ Insert_After_And_Analyze (N, FBody);
+ end;
+ end if;
- Append_To (New_Alts, New_Node);
- Next (Old_Node);
- end loop;
+ if Is_Discrete_Type (Typ) then
- -- If empty list, replace by False
+ -- 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.
- if Is_Empty_List (New_Alts) then
- Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
+ Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
- -- Else replace by set membership test
+ -- Emit an error when the predicate is categorized as static
+ -- but its expression is dynamic.
- else
- Rewrite (Expr,
- Make_In (Loc,
- Left_Opnd => Make_Identifier (Loc, Nam),
- Right_Opnd => Empty,
- Alternatives => New_Alts));
+ 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;
- -- Resolve new expression in function context
+ -- 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.
- Install_Formals (Predicate_Function (Typ));
- Push_Scope (Predicate_Function (Typ));
- Analyze_And_Resolve (Expr, Standard_Boolean);
- Pop_Scope;
- end if;
- end;
- end;
+ 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);
- -- If non-static, return doing nothing
+ elsif Is_Scalar_Type (Typ) then
+ Error_Msg_FE
+ ("static predicate not allowed for non-static type&",
+ Typ, Typ);
- exception
- when Non_Static =>
- return;
- end Build_Static_Predicate;
+ else
+ Error_Msg_FE
+ ("static predicate not allowed for non-scalar type&",
+ Typ, Typ);
+ end if;
+ end if;
+ end if;
+ end Build_Predicate_Functions;
-----------------------------------------
-- Check_Aspect_At_End_Of_Declarations --
projects / thirdparty / gcc.git / commitdiff
