(Related_Nod : Node_Id;
N : Node_Id) return Entity_Id
is
- Loc : constant Source_Ptr := Sloc (Related_Nod);
Anon_Type : Entity_Id;
Anon_Scope : Entity_Id;
Desig_Type : Entity_Id;
- Decl : Entity_Id;
Enclosing_Prot_Type : Entity_Id := Empty;
begin
Anon_Scope := Scope (Defining_Entity (Related_Nod));
end if;
- else
- -- For access formals, access components, and access discriminants,
- -- the scope is that of the enclosing declaration,
+ -- For an access type definition, if the current scope is a child
+ -- unit it is the scope of the type.
+
+ elsif Is_Compilation_Unit (Current_Scope) then
+ Anon_Scope := Current_Scope;
+ -- For access formals, access components, and access discriminants, the
+ -- scope is that of the enclosing declaration,
+
+ else
Anon_Scope := Scope (Current_Scope);
end if;
Set_Can_Use_Internal_Rep
(Anon_Type, not Always_Compatible_Rep_On_Target);
- -- If the anonymous access is associated with a protected operation
+ -- If the anonymous access is associated with a protected operation,
-- create a reference to it after the enclosing protected definition
-- because the itype will be used in the subsequent bodies.
-- proper Master for the created tasks.
if Nkind (Related_Nod) = N_Object_Declaration
- and then Expander_Active
+ and then Expander_Active
then
if Is_Interface (Desig_Type)
and then Is_Limited_Record (Desig_Type)
elsif Has_Task (Desig_Type)
and then Comes_From_Source (Related_Nod)
- and then not Restriction_Active (No_Task_Hierarchy)
then
- if not Has_Master_Entity (Current_Scope) then
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uMaster),
- Constant_Present => True,
- Object_Definition =>
- New_Reference_To (RTE (RE_Master_Id), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Reference_To (RTE (RE_Current_Master), Loc)));
-
- Insert_Before (Related_Nod, Decl);
- Analyze (Decl);
-
- Set_Master_Id (Anon_Type, Defining_Identifier (Decl));
- Set_Has_Master_Entity (Current_Scope);
- else
- Build_Master_Renaming (Related_Nod, Anon_Type);
- end if;
+ Build_Master_Entity (Defining_Identifier (Related_Nod));
+ Build_Master_Renaming (Anon_Type);
end if;
end if;
(Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim);
+ if No (Prim) and then Serious_Errors_Detected > 0 then
+ goto Continue;
+ end if;
+
pragma Assert (Present (Prim));
-- Ada 2012 (AI05-0197): If the name of the covering primitive
Set_Has_Delayed_Freeze (New_Subp);
end if;
+ <<Continue>>
Next_Elmt (Elmt);
end loop;
Prag := Next_Pragma (Prag);
end loop;
+ Check_Subprogram_Contract (Sent);
+
Prag := Spec_TC_List (Contract (Sent));
while Present (Prag) loop
Analyze_TC_In_Decl_Part (Prag, Sent);
-- 2. Those generated by the Expression
- -- 3. Those used to constrained the Object Definition with the
- -- expression constraints when it is unconstrained
+ -- 3. Those used to constrain the Object Definition with the
+ -- expression constraints when the definition is unconstrained.
-- They must be generated in this order to avoid order of elaboration
-- issues. Thus the first step (after entering the name) is to analyze
if Present (Prev_Entity)
and then
+
-- If the homograph is an implicit subprogram, it is overridden
-- by the current declaration.
if Is_Indefinite_Subtype (T) then
+ -- In SPARK, a declaration of unconstrained type is allowed
+ -- only for constants of type string.
+
+ if Is_String_Type (T) and then not Constant_Present (N) then
+ Check_SPARK_Restriction
+ ("declaration of object of unconstrained type not allowed",
+ N);
+ end if;
+
-- Nothing to do in deferred constant case
if Constant_Present (N) and then No (E) then
-- Case of initialization present
else
- -- Not allowed in Ada 83
+ -- Check restrictions in Ada 83
if not Constant_Present (N) then
+
+ -- Unconstrained variables not allowed in Ada 83 mode
+
if Ada_Version = Ada_83
and then Comes_From_Source (Object_Definition (N))
then
Make_Index (Index, P, Related_Id, Nb_Index);
- -- In formal verification mode, create an explicit subtype for every
- -- index if not already a subtype_mark, and replace the existing type
- -- of index by this new type. Having a declaration for all type
- -- entities facilitates the task of the formal verification back-end.
-
- if ALFA_Mode
- and then not Nkind_In (Index, N_Identifier, N_Expanded_Name)
- then
- declare
- Loc : constant Source_Ptr := Sloc (Def);
- New_E : Entity_Id;
- Decl : Entity_Id;
- Sub_Ind : Node_Id;
-
- begin
- New_E :=
- New_External_Entity
- (E_Void, Current_Scope, Sloc (P), Related_Id, 'D',
- Nb_Index, 'T');
-
- if Nkind (Index) = N_Subtype_Indication then
- Sub_Ind := Relocate_Node (Index);
- else
- Sub_Ind :=
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Base_Type (Etype (Index)), Loc),
- Constraint =>
- Make_Range_Constraint (Loc,
- Range_Expression => Relocate_Node (Index)));
- end if;
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => New_E,
- Subtype_Indication => Sub_Ind);
-
- Insert_Action (Parent (Def), Decl);
- Set_Etype (Index, New_E);
- end;
- end if;
-
-- Check error of subtype with predicate for index type
Bad_Predicated_Subtype_Use
-- Process subtype indication if one is present
if Present (Component_Typ) then
-
- -- In formal verification mode, create an explicit subtype for the
- -- component type if not already a subtype_mark. Having a declaration
- -- for all type entities facilitates the task of the formal
- -- verification back-end.
-
- if ALFA_Mode
- and then Nkind (Component_Typ) = N_Subtype_Indication
- then
- declare
- Loc : constant Source_Ptr := Sloc (Def);
- Decl : Entity_Id;
-
- begin
- Element_Type :=
- New_External_Entity
- (E_Void, Current_Scope, Sloc (P), Related_Id, 'C', 0, 'T');
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Element_Type,
- Subtype_Indication => Relocate_Node (Component_Typ));
-
- Insert_Action (Parent (Def), Decl);
- end;
-
- else
- Element_Type :=
- Process_Subtype (Component_Typ, P, Related_Id, 'C');
- end if;
+ Element_Type := Process_Subtype (Component_Typ, P, Related_Id, 'C');
Set_Etype (Component_Typ, Element_Type);
Set_Last_Entity
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
-
- -- Update the scope of anonymous access types of discriminants and other
- -- components, to prevent scope anomalies in gigi, when the derivation
- -- appears in a scope nested within that of the parent.
-
- declare
- D : Entity_Id;
-
- begin
- D := First_Entity (Derived_Type);
- while Present (D) loop
- if Ekind_In (D, E_Discriminant, E_Component) then
- if Is_Itype (Etype (D))
- and then Ekind (Etype (D)) = E_Anonymous_Access_Type
- then
- Set_Scope (Etype (D), Current_Scope);
- end if;
- end if;
-
- Next_Entity (D);
- end loop;
- end;
end Build_Derived_Record_Type;
------------------------
-- The partial view of T may have been a private extension, for
-- which inherited functions dispatching on result are abstract.
-- If the full view is a null extension, there is no need for
- -- overriding in Ada2005, but wrappers need to be built for them
+ -- overriding in Ada 2005, but wrappers need to be built for them
-- (see exp_ch3, Build_Controlling_Function_Wrappers).
if Is_Null_Extension (T)
begin
E := Subp;
while Present (Alias (E)) loop
- Error_Msg_Sloc := Sloc (E);
- Error_Msg_NE
- ("\& has been inherited #", T, Subp);
+
+ -- Avoid reporting redundant errors on entities
+ -- inherited from interfaces
+
+ if Sloc (E) /= Sloc (T) then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_NE
+ ("\& has been inherited #", T, Subp);
+ end if;
+
E := Alias (E);
end loop;
-- The controlling formal of Subp must be of mode "out",
-- "in out" or an access-to-variable to be overridden.
- -- Error message below needs rewording (remember comma
- -- in -gnatj mode) ???
-
if Ekind (First_Formal (Subp)) = E_In_Parameter
and then Ekind (Subp) /= E_Function
then
- if not Is_Predefined_Dispatching_Operation (Subp) then
- Error_Msg_NE
- ("first formal of & must be of mode `OUT`, " &
- "`IN OUT` or access-to-variable", T, Subp);
- Error_Msg_N
- ("\to be overridden by protected procedure or " &
- "entry (RM 9.4(11.9/2))", T);
+ if not Is_Predefined_Dispatching_Operation (Subp)
+ and then Is_Protected_Type
+ (Corresponding_Concurrent_Type (T))
+ then
+ Error_Msg_PT (T, Subp);
end if;
-- Some other kind of overriding failure
-- type, so we must be sure not to overwrite these entries.
declare
+ Append : Boolean;
Item : Node_Id;
Next_Item : Node_Id;
-- is not done, as that would create a circularity.
elsif Item /= First_Rep_Item (Priv) then
+ Append := True;
+
loop
Next_Item := Next_Rep_Item (Item);
exit when No (Next_Item);
Item := Next_Item;
+
+ -- If the private view has aspect specifications, the full view
+ -- inherits them. Since these aspects may already have been
+ -- attached to the full view during derivation, do not append
+ -- them if already present.
+
+ if Item = First_Rep_Item (Priv) then
+ Append := False;
+ exit;
+ end if;
end loop;
-- And link the private type items at the end of the chain
- Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ if Append then
+ Set_Next_Rep_Item (Item, First_Rep_Item (Priv));
+ end if;
end if;
end;
Related_Id : Entity_Id;
Suffix : Character)
is
- T_Ent : Entity_Id := Entity (Subtype_Mark (SI));
+ -- Retrieve Base_Type to ensure getting to the concurrent type in the
+ -- case of a private subtype (needed when only doing semantic analysis).
+
+ T_Ent : Entity_Id := Base_Type (Entity (Subtype_Mark (SI)));
T_Val : Entity_Id;
begin
-- Check for case of a derived subprogram for the instantiation of a
-- formal derived tagged type, if so mark the subprogram as dispatching
- -- and inherit the dispatching attributes of the parent subprogram. The
+ -- and inherit the dispatching attributes of the actual subprogram. The
-- derived subprogram is effectively renaming of the actual subprogram,
-- so it needs to have the same attributes as the actual.
if Present (Actual_Subp)
- and then Is_Dispatching_Operation (Parent_Subp)
+ and then Is_Dispatching_Operation (Actual_Subp)
then
Set_Is_Dispatching_Operation (New_Subp);
- if Present (DTC_Entity (Parent_Subp)) then
- Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp));
- Set_DT_Position (New_Subp, DT_Position (Parent_Subp));
+ if Present (DTC_Entity (Actual_Subp)) then
+ Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
+ Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
end if;
end if;
Set_Has_Private_Declaration (Prev);
Set_Has_Private_Declaration (Id);
+ -- Preserve aspect and iterator flags that may have been set on
+ -- the partial view.
+
+ Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id));
+ Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id));
+
-- If no error, propagate freeze_node from private to full view.
-- It may have been generated for an early operational item.
end if;
end if;
+ if Present (Prev)
+ and then Nkind (Parent (Prev)) = N_Incomplete_Type_Declaration
+ and then Present (Premature_Use (Parent (Prev)))
+ then
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("\full declaration #", Premature_Use (Parent (Prev)));
+ end if;
+
return New_Id;
end if;
end Find_Type_Name;
elsif Def_Kind = N_Access_Definition then
T := Access_Definition (Related_Nod, Obj_Def);
- Set_Is_Local_Anonymous_Access (T);
+
+ Set_Is_Local_Anonymous_Access
+ (T,
+ V => (Ada_Version < Ada_2012)
+ or else (Nkind (P) /= N_Object_Declaration)
+ or else Is_Library_Level_Entity (Defining_Identifier (P)));
-- Otherwise, the object definition is just a subtype_mark
Plain_Discrim : Boolean := False;
Stored_Discrim : Boolean := False)
is
+ procedure Set_Anonymous_Type (Id : Entity_Id);
+ -- Id denotes the entity of an access discriminant or anonymous
+ -- access component. Set the type of Id to either the same type of
+ -- Old_C or create a new one depending on whether the parent and
+ -- the child types are in the same scope.
+
+ ------------------------
+ -- Set_Anonymous_Type --
+ ------------------------
+
+ procedure Set_Anonymous_Type (Id : Entity_Id) is
+ Old_Typ : constant Entity_Id := Etype (Old_C);
+
+ begin
+ if Scope (Parent_Base) = Scope (Derived_Base) then
+ Set_Etype (Id, Old_Typ);
+
+ -- The parent and the derived type are in two different scopes.
+ -- Reuse the type of the original discriminant / component by
+ -- copying it in order to preserve all attributes.
+
+ else
+ declare
+ Typ : constant Entity_Id := New_Copy (Old_Typ);
+
+ begin
+ Set_Etype (Id, Typ);
+
+ -- Since we do not generate component declarations for
+ -- inherited components, associate the itype with the
+ -- derived type.
+
+ Set_Associated_Node_For_Itype (Typ, Parent (Derived_Base));
+ Set_Scope (Typ, Derived_Base);
+ end;
+ end if;
+ end Set_Anonymous_Type;
+
+ -- Local variables and constants
+
New_C : constant Entity_Id := New_Copy (Old_C);
- Discrim : Entity_Id;
Corr_Discrim : Entity_Id;
+ Discrim : Entity_Id;
+
+ -- Start of processing for Inherit_Component
begin
pragma Assert (not Is_Tagged or else not Stored_Discrim);
Set_Original_Record_Component (New_C, New_C);
end if;
+ -- Set the proper type of an access discriminant
+
+ if Ekind (New_C) = E_Discriminant
+ and then Ekind (Etype (New_C)) = E_Anonymous_Access_Type
+ then
+ Set_Anonymous_Type (New_C);
+ end if;
+
-- If we have inherited a component then see if its Etype contains
-- references to Parent_Base discriminants. In this case, replace
-- these references with the constraints given in Discs. We do not
-- transformation in some error situations.
if Ekind (New_C) = E_Component then
- if (Is_Private_Type (Derived_Base)
- and then not Is_Generic_Type (Derived_Base))
+
+ -- Set the proper type of an anonymous access component
+
+ if Ekind (Etype (New_C)) = E_Anonymous_Access_Type then
+ Set_Anonymous_Type (New_C);
+
+ elsif (Is_Private_Type (Derived_Base)
+ and then not Is_Generic_Type (Derived_Base))
or else (Is_Empty_Elmt_List (Discs)
- and then not Expander_Active)
+ and then not Expander_Active)
then
Set_Etype (New_C, Etype (Old_C));
Set_Etype
(New_C,
Constrain_Component_Type
- (Old_C, Derived_Base, N, Parent_Base, Discs));
+ (Old_C, Derived_Base, N, Parent_Base, Discs));
end if;
end if;
elsif not Comes_From_Source (Original_Comp) then
return True;
- -- If we are in the body of an instantiation, the component is visible
- -- even when the parent type (possibly defined in an enclosing unit or
- -- in a parent unit) might not.
-
- elsif In_Instance_Body then
- return True;
-
-- Discriminants are always visible
elsif Ekind (Original_Comp) = E_Discriminant
then
return True;
+ -- If we are in the body of an instantiation, the component is visible
+ -- if the parent type is non-private, or in an enclosing scope. The
+ -- scope stack is not present when analyzing an instance body, so we
+ -- must inspect the chain of scopes explicitly.
+
+ elsif In_Instance_Body then
+ if not Is_Private_Type (Scope (C)) then
+ return True;
+
+ else
+ declare
+ S : Entity_Id;
+
+ begin
+ S := Current_Scope;
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if S = Type_Scope then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end;
+ end if;
+
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
-- component's containing type is not in an open scope and the original
-- function calls. The function call may have been given in prefixed
-- notation, in which case the original node is an indexed component.
-- If the function is parameterless, the original node was an explicit
- -- dereference.
+ -- dereference. The function may also be parameterless, in which case
+ -- the source node is just an identifier.
case Nkind (Original_Node (Exp)) is
when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
return True;
+ when N_Identifier =>
+ return Present (Entity (Original_Node (Exp)))
+ and then Ekind (Entity (Original_Node (Exp))) = E_Function;
+
when N_Qualified_Expression =>
return
OK_For_Limited_Init_In_05
when N_Attribute_Reference =>
return Attribute_Name (Original_Node (Exp)) = Name_Input;
+ -- For a conditional expression, all dependent expressions must be
+ -- legal constructs.
+
+ when N_Conditional_Expression =>
+ declare
+ Then_Expr : constant Node_Id :=
+ Next (First (Expressions (Original_Node (Exp))));
+ Else_Expr : constant Node_Id := Next (Then_Expr);
+ begin
+ return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
+ and then OK_For_Limited_Init_In_05 (Typ, Else_Expr);
+ end;
+
+ when N_Case_Expression =>
+ declare
+ Alt : Node_Id;
+
+ begin
+ Alt := First (Alternatives (Original_Node (Exp)));
+ while Present (Alt) loop
+ if not OK_For_Limited_Init_In_05 (Typ, Expression (Alt)) then
+ return False;
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ return True;
+ end;
+
when others =>
return False;
end case;
and then (Is_Limited_Type (Full_T)
or else Is_Limited_Composite (Full_T))
then
- Error_Msg_N
- ("completion of nonlimited type cannot be limited", Full_T);
- Explain_Limited_Type (Full_T, Full_T);
+ if In_Instance then
+ null;
+ else
+ Error_Msg_N
+ ("completion of nonlimited type cannot be limited", Full_T);
+ Explain_Limited_Type (Full_T, Full_T);
+ end if;
elsif Is_Abstract_Type (Full_T)
and then not Is_Abstract_Type (Priv_T)
-- Ada 2005 (AI-251): The partial view shall be a descendant of
-- an interface type if and only if the full type is descendant
- -- of the interface type (AARM 7.3 (7.3/2).
+ -- of the interface type (AARM 7.3 (7.3/2)).
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);
-- Look up tree to find an appropriate insertion point. We
-- can't just use insert_actions because later processing
- -- depends on the insertion node. Prior to Ada2012 the
+ -- depends on the insertion node. Prior to Ada 2012 the
-- insertion point could only be a declaration or a loop, but
-- quantified expressions can appear within any context in an
-- expression, and the insertion point can be any statement,
return Process_Subtype (S, Related_Nod, Related_Id, Suffix);
end if;
- -- Remaining processing depends on type
+ -- Remaining processing depends on type. Select on Base_Type kind to
+ -- ensure getting to the concrete type kind in the case of a private
+ -- subtype (needed when only doing semantic analysis).
- case Ekind (Subtype_Mark_Id) is
+ case Ekind (Base_Type (Subtype_Mark_Id)) is
when Access_Kind =>
Constrain_Access (Def_Id, S, Related_Nod);
-- do not know the exact end points at the time of the declaration. This
-- is true for three reasons:
- -- A size clause may affect the fudging of the end-points
- -- A small clause may affect the values of the end-points
- -- We try to include the end-points if it does not affect the size
-
- -- This means that the actual end-points must be established at the point
- -- when the type is frozen. Meanwhile, we first narrow the range as
- -- permitted (so that it will fit if necessary in a small specified size),
- -- and then build a range subtree with these narrowed bounds.
+ -- A size clause may affect the fudging of the end-points.
+ -- A small clause may affect the values of the end-points.
+ -- We try to include the end-points if it does not affect the size.
- -- Set_Fixed_Range constructs the range from real literal values, and sets
- -- the range as the Scalar_Range of the given fixed-point type entity.
+ -- This means that the actual end-points must be established at the
+ -- point when the type is frozen. Meanwhile, we first narrow the range
+ -- as permitted (so that it will fit if necessary in a small specified
+ -- size), and then build a range subtree with these narrowed bounds.
+ -- Set_Fixed_Range constructs the range from real literal values, and
+ -- sets the range as the Scalar_Range of the given fixed-point type entity.
-- The parent of this range is set to point to the entity so that it is
-- properly hooked into the tree (unlike normal Scalar_Range entries for
begin
Set_Scalar_Range (E, S);
Set_Parent (S, E);
+
+ -- Before the freeze point, the bounds of a fixed point are universal
+ -- and carry the corresponding type.
+
+ Set_Etype (Low_Bound (S), Universal_Real);
+ Set_Etype (High_Bound (S), Universal_Real);
end Set_Fixed_Range;
----------------------------------
-- Complete both implicit base and declared first subtype entities
Set_Etype (Implicit_Base, Base_Typ);
- Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
Set_Size_Info (Implicit_Base, (Base_Typ));
Set_RM_Size (Implicit_Base, RM_Size (Base_Typ));
Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
Set_Ekind (T, E_Signed_Integer_Subtype);
Set_Etype (T, Implicit_Base);
- -- In formal verification mode, override partially the decisions above
- -- to restrict base type's range to the minimum allowed by RM 3.5.4,
- -- namely the smallest symmetric range around zero with a possible extra
- -- negative value that contains the subtype range. Keep Size, RM_Size
- -- and First_Rep_Item info, which should not be relied upon in formal
- -- verification.
-
- if ALFA_Mode then
-
- -- If the range of the type is already symmetric with a possible
- -- extra negative value, leave it this way.
-
- if UI_Le (Lo_Val, Hi_Val)
- and then (UI_Eq (Lo_Val, UI_Negate (Hi_Val))
- or else
- UI_Eq (Lo_Val, UI_Sub (UI_Negate (Hi_Val), Uint_1)))
- then
- null;
+ -- In formal verification mode, restrict the base type's range to the
+ -- minimum allowed by RM 3.5.4, namely the smallest symmetric range
+ -- around zero with a possible extra negative value that contains the
+ -- subtype range. Keep Size, RM_Size and First_Rep_Item info, which
+ -- should not be relied upon in formal verification.
- else
- declare
- Sym_Hi_Val : Uint;
- Sym_Lo_Val : Uint;
- Decl : Node_Id;
- Dloc : constant Source_Ptr := Sloc (Def);
- Lbound : Node_Id;
- Ubound : Node_Id;
+ if Strict_Alfa_Mode then
+ declare
+ Sym_Hi_Val : Uint;
+ Sym_Lo_Val : Uint;
+ Dloc : constant Source_Ptr := Sloc (Def);
+ Lbound : Node_Id;
+ Ubound : Node_Id;
+ Bounds : Node_Id;
- begin
- -- If the subtype range is empty, the smallest base type range
- -- is the symmetric range around zero containing Lo_Val and
- -- Hi_Val.
+ begin
+ -- If the subtype range is empty, the smallest base type range
+ -- is the symmetric range around zero containing Lo_Val and
+ -- Hi_Val.
- if UI_Gt (Lo_Val, Hi_Val) then
- Sym_Hi_Val := UI_Max (UI_Abs (Lo_Val), UI_Abs (Hi_Val));
- Sym_Lo_Val := UI_Negate (Sym_Hi_Val);
+ if UI_Gt (Lo_Val, Hi_Val) then
+ Sym_Hi_Val := UI_Max (UI_Abs (Lo_Val), UI_Abs (Hi_Val));
+ Sym_Lo_Val := UI_Negate (Sym_Hi_Val);
-- Otherwise, if the subtype range is not empty and Hi_Val has
-- the largest absolute value, Hi_Val is non negative and the
-- smallest base type range is the symmetric range around zero
-- containing Hi_Val.
- elsif UI_Le (UI_Abs (Lo_Val), UI_Abs (Hi_Val)) then
- Sym_Hi_Val := Hi_Val;
- Sym_Lo_Val := UI_Negate (Hi_Val);
+ elsif UI_Le (UI_Abs (Lo_Val), UI_Abs (Hi_Val)) then
+ Sym_Hi_Val := Hi_Val;
+ Sym_Lo_Val := UI_Negate (Hi_Val);
-- Otherwise, the subtype range is not empty, Lo_Val has the
-- strictly largest absolute value, Lo_Val is negative and the
-- smallest base type range is the symmetric range around zero
-- with an extra negative value Lo_Val.
- else
- Sym_Lo_Val := Lo_Val;
- Sym_Hi_Val := UI_Sub (UI_Negate (Lo_Val), Uint_1);
- end if;
+ else
+ Sym_Lo_Val := Lo_Val;
+ Sym_Hi_Val := UI_Sub (UI_Negate (Lo_Val), Uint_1);
+ end if;
- Lbound := Make_Integer_Literal (Dloc, Sym_Lo_Val);
- Ubound := Make_Integer_Literal (Dloc, Sym_Hi_Val);
- Set_Is_Static_Expression (Lbound);
- Set_Is_Static_Expression (Ubound);
+ Lbound := Make_Integer_Literal (Dloc, Sym_Lo_Val);
+ Ubound := Make_Integer_Literal (Dloc, Sym_Hi_Val);
+ Set_Is_Static_Expression (Lbound);
+ Set_Is_Static_Expression (Ubound);
+ Analyze_And_Resolve (Lbound, Any_Integer);
+ Analyze_And_Resolve (Ubound, Any_Integer);
- Decl := Make_Full_Type_Declaration (Dloc,
- Defining_Identifier => Implicit_Base,
- Type_Definition =>
- Make_Signed_Integer_Type_Definition (Dloc,
- Low_Bound => Lbound,
- High_Bound => Ubound));
+ Bounds := Make_Range (Dloc, Lbound, Ubound);
+ Set_Etype (Bounds, Base_Typ);
- Analyze (Decl);
- Set_Etype (Implicit_Base, Base_Type (Implicit_Base));
- Set_Etype (T, Base_Type (Implicit_Base));
- Insert_Before (Parent (Def), Decl);
- end;
- end if;
+ Set_Scalar_Range (Implicit_Base, Bounds);
+ end;
+
+ else
+ Set_Scalar_Range (Implicit_Base, Scalar_Range (Base_Typ));
end if;
Set_Size_Info (T, (Implicit_Base));
OSDN Git Service
