2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Process_Declarations): A loop
parameter does not require finalization actions.
2015-10-20 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch6.adb (Expand_Simple_Function_Return): Do not create an
actual subtype for a mutable record return type if the expression
is itself a function call.
2015-10-20 Dmitriy Anisimkov <anisimko@adacore.com>
* s-atocou.adb, s-atocou-builtin.adb: Fix implementation description
related to new type support.
2015-10-20 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension
to propagate dimension information from prefix.
* sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference.
* inline.ads: minor whitespace fix in comment
* sem_ch6.adb: minor gramar fix in comment
2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch3.adb (Analyze_Object_Contract):
A protected type or a protected object is allowed to have a
discriminated part.
2015-10-20 Bob Duff <duff@adacore.com>
* sem_util.adb (Requires_Transient_Scope):
Return true for mutable records if the maximum size is very large.
2015-10-20 Eric Botcazou <ebotcazou@adacore.com>
* a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with
the same signature as in System.IO.Put.
From-SVN: r229052
+2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Process_Declarations): A loop
+ parameter does not require finalization actions.
+
+2015-10-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Expand_Simple_Function_Return): Do not create an
+ actual subtype for a mutable record return type if the expression
+ is itself a function call.
+
+2015-10-20 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * s-atocou.adb, s-atocou-builtin.adb: Fix implementation description
+ related to new type support.
+
+2015-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Explicit_Dererence): Call Analyze_Dimension
+ to propagate dimension information from prefix.
+ * sem_dim.adb (Analyze_Dimension): Handle Explicit_Dereference.
+ * inline.ads: minor whitespace fix in comment
+ * sem_ch6.adb: minor gramar fix in comment
+
+2015-10-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Contract):
+ A protected type or a protected object is allowed to have a
+ discriminated part.
+
+2015-10-20 Bob Duff <duff@adacore.com>
+
+ * sem_util.adb (Requires_Transient_Scope):
+ Return true for mutable records if the maximum size is very large.
+
+2015-10-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * a-except-2005.adb (To_Stderr): Import Put_Char_Stderr with
+ the same signature as in System.IO.Put.
+
2015-10-20 Bob Duff <duff@adacore.com>
* a-cobove.adb (Set_Length): Restore previous logic, but with "Checks
---------------
procedure To_Stderr (C : Character) is
- type int is new Integer;
- procedure put_char_stderr (C : int);
- pragma Import (C, put_char_stderr, "put_char_stderr");
+ procedure Put_Char_Stderr (C : Character);
+ pragma Import (C, Put_Char_Stderr, "put_char_stderr");
begin
- put_char_stderr (Character'Pos (C));
+ Put_Char_Stderr (C);
end To_Stderr;
procedure To_Stderr (S : String) is
elsif not Requires_Transient_Scope (R_Type) then
- -- Mutable records with no variable length components are not
- -- returned on the sec-stack, so we need to make sure that the
- -- backend will only copy back the size of the actual value, and not
- -- the maximum size. We create an actual subtype for this purpose.
+ -- Mutable records with variable-length components are not returned
+ -- on the sec-stack, so we need to make sure that the back end will
+ -- only copy back the size of the actual value, and not the maximum
+ -- size. We create an actual subtype for this purpose. However we
+ -- need not do it if the expression is a function call since this
+ -- will be done in the called function and doing it here too would
+ -- cause a temporary with maximum size to be created.
declare
Ubt : constant Entity_Id := Underlying_Type (Base_Type (Exptyp));
Decl : Node_Id;
Ent : Entity_Id;
begin
- if Has_Discriminants (Ubt)
+ if Nkind (Exp) /= N_Function_Call
+ and then Has_Discriminants (Ubt)
and then not Is_Constrained (Ubt)
and then not Has_Unchecked_Union (Ubt)
then
elsif Is_Ignored_Ghost_Entity (Obj_Id) then
null;
+ -- The expansion of iterator loops generates an object
+ -- declaration where the Ekind is explicitly set to loop
+ -- parameter. This is to ensure that the loop parameter behaves
+ -- as a constant from user code point of view. Such object are
+ -- never controlled and do not require finalization.
+
+ elsif Ekind (Obj_Id) = E_Loop_Parameter then
+ null;
+
-- The object is of the form:
-- Obj : Typ [:= Expr];
-- subsequently used for inline expansions at call sites. If subprogram can
-- be inlined (depending on size and nature of local declarations) the
-- template body is created. Otherwise subprogram body is treated normally
- -- and calls are not inlined in the frontend. If proper warnings are
+ -- and calls are not inlined in the frontend. If proper warnings are
-- enabled and the subprogram contains a construct that cannot be inlined,
-- the problematic construct is flagged accordingly.
-- --
------------------------------------------------------------------------------
--- This package implements Atomic_Counter operatiobns for platforms where
--- GCC supports __sync_add_and_fetch_4 and __sync_sub_and_fetch_4 builtins.
+-- This package implements Atomic_Counter and Atomic_Unsigned operations
+-- for platforms where GCC supports __sync_add_and_fetch_4 and
+-- __sync_sub_and_fetch_4 builtins.
package body System.Atomic_Counters is
-- --
------------------------------------------------------------------------------
--- This is dummy version of the package, for use on platforms where this
--- capability is not supported. Any use of any of the routines in this
--- package will raise Program_Error.
-
--- Why don't we use pragma Unimplemented_Unit in a dummy spec, this would
--- seem much more useful than raising an exception at run time ???
+-- This is version of the package, for use on platforms where this capability
+-- is not supported. All Atomic_Counter operations raises Program_Error,
+-- Atomic_Unsigned operations processed in non-atomic manner.
package body System.Atomic_Counters is
Obj_Id);
-- An object of a discriminated type cannot be effectively
- -- volatile (SPARK RM C.6(4)).
+ -- volatile except for protected objects (SPARK RM 7.1.3(5)).
- elsif Has_Discriminants (Obj_Typ) then
+ elsif Has_Discriminants (Obj_Typ)
+ and then not Is_Protected_Type (Obj_Typ)
+ then
Error_Msg_N
("discriminated object & cannot be volatile", Obj_Id);
LocX : constant Source_Ptr := Sloc (Expr);
Spec : constant Node_Id := Specification (N);
- Def_Id : Entity_Id;
+ Def_Id : Entity_Id;
- Prev : Entity_Id;
+ Prev : Entity_Id;
-- If the expression is a completion, Prev is the entity whose
-- declaration is completed. Def_Id is needed to analyze the spec.
New_Body : Node_Id;
New_Spec : Node_Id;
Ret : Node_Id;
+ Asp : Node_Id;
begin
-- This is one of the occasions on which we transform the tree during
Analyze (N);
+ -- If aspect SPARK_Mode was specified on the body, it needs to be
+ -- repeated both on the generated spec and the body.
+
+ Asp := Find_Aspect (Defining_Unit_Name (Spec), Aspect_SPARK_Mode);
+
+ if Present (Asp) then
+ Asp := New_Copy_Tree (Asp);
+ Set_Analyzed (Asp, False);
+ Set_Aspect_Specifications (New_Body, New_List (Asp));
+ end if;
+
-- Within a generic pre-analyze the original expression for name
-- capture. The body is also generated but plays no role in
-- this because it is not part of the original source.
-- declaration for now, as inlining of subprogram bodies acting as
-- declarations, or subprogram stubs, are not supported by frontend
-- inlining. This inlining should occur after analysis of the body, so
- -- that it is known whether the value of SPARK_Mode applicable to the
- -- body, which can be defined by a pragma inside the body.
+ -- that it is known whether the value of SPARK_Mode, which can be
+ -- defined by a pragma inside the body, is applicable to the body.
elsif GNATprove_Mode
and then Full_Analysis
OK_For_Dimension : constant array (Node_Kind) of Boolean :=
(N_Attribute_Reference => True,
N_Expanded_Name => True,
+ N_Explicit_Dereference => True,
N_Defining_Identifier => True,
N_Function_Call => True,
N_Identifier => True,
when N_Attribute_Reference |
N_Expanded_Name |
+ N_Explicit_Dereference |
N_Function_Call |
N_Identifier |
N_Indexed_Component |
procedure Analyze_Dimension_Simple_Return_Statement (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
- Dims_Of_Expr : constant Dimension_Type := Dimensions_Of (Expr);
Return_Ent : constant Entity_Id := Return_Statement_Entity (N);
Return_Etyp : constant Entity_Id :=
Etype (Return_Applies_To (Return_Ent));
-- Start of processing for Analyze_Dimension_Simple_Return_Statement
begin
- if Dims_Of_Return_Etyp /= Dims_Of_Expr then
+ if Dims_Of_Return_Etyp /= Dimensions_Of (Expr) then
Error_Dim_Msg_For_Simple_Return_Statement (N, Return_Etyp, Expr);
Remove_Dimensions (Expr);
end if;
Set_Etype (N, Get_Actual_Subtype (N));
end if;
+ Analyze_Dimension (N);
-- Note: No Eval processing is required for an explicit dereference,
-- because such a name can never be static.
-- could be nested inside some other record that is constrained by
-- nondiscriminants). That is, the recursive calls are too conservative.
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ is a nonlimited record with defaulted
+ -- discriminants whose max size makes it unsuitable for allocating on
+ -- the primary stack.
+
------------------------------
-- Caller_Known_Size_Record --
------------------------------
return True;
end Caller_Known_Size_Record;
+ ------------------------------
+ -- Large_Max_Size_Mutable --
+ ------------------------------
+
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
+ -- Returns true if the discrete type T has a large range
+
+ ----------------------------
+ -- Is_Large_Discrete_Type --
+ ----------------------------
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
+ Threshold : constant Int := 16;
+ -- Arbitrary threshold above which we consider it "large". We want
+ -- a fairly large threshold, because these large types really
+ -- shouldn't have default discriminants in the first place, in
+ -- most cases.
+
+ begin
+ return UI_To_Int (RM_Size (T)) > Threshold;
+ end Is_Large_Discrete_Type;
+
+ begin
+ if Is_Record_Type (Typ)
+ and then not Is_Limited_View (Typ)
+ and then Has_Defaulted_Discriminants (Typ)
+ then
+ -- Loop through the components, looking for an array whose upper
+ -- bound(s) depends on discriminants, where both the subtype of
+ -- the discriminant and the index subtype are too large.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component then
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+ Indx : Node_Id;
+ Ityp : Entity_Id;
+ Hi : Node_Id;
+
+ begin
+ if Is_Array_Type (Comp_Type) then
+ Indx := First_Index (Comp_Type);
+
+ while Present (Indx) loop
+ Ityp := Etype (Indx);
+ Hi := Type_High_Bound (Ityp);
+
+ if Nkind (Hi) = N_Identifier
+ and then Ekind (Entity (Hi)) = E_Discriminant
+ and then Is_Large_Discrete_Type (Ityp)
+ and then Is_Large_Discrete_Type
+ (Etype (Entity (Hi)))
+ then
+ return True;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Large_Max_Size_Mutable;
+
-- Local declarations
Typ : constant Entity_Id := Underlying_Type (Id);
-- Untagged definite subtypes are known size. This includes all
-- elementary [sub]types. Tasks are known size even if they have
- -- discriminants.
+ -- discriminants. So we return False here, with one exception:
+ -- For a type like:
+ -- type T (Last : Natural := 0) is
+ -- X : String (1 .. Last);
+ -- end record;
+ -- we return True. That's because for "P(F(...));", where F returns T,
+ -- we don't know the size of the result at the call site, so if we
+ -- allocated it on the primary stack, we would have to allocate the
+ -- maximum size, which is way too big.
elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
- return False;
+ return Large_Max_Size_Mutable (Typ);
-- Indefinite (discriminated) untagged record or protected type
projects / gcc.git / commitdiff