+2015-05-26 Doug Rupp <rupp@adacore.com>
+
+ * init.c [vxworks]: Refine previous checkin.
+
+2015-05-26 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch4.adb (Wrap_MA): New function.
+ (Expand_N_Op_Expon): Use Wrap_MA.
+
+2015-05-26 Bob Duff <duff@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration):
+ Do not use secondary stack to return limited records with
+ defaulted discriminants. This is an efficiency improvement.
+ * exp_ch6.adb, exp_dist.adb, sem_attr.adb, sem_aux.adb, sem_aux.ads,
+ sem_ch12.adb, sem_ch3.adb, sem_ch4.adb, sem_ch6.adb, sem_ch7.adb,
+ sem_util.adb: Change the sense of Is_Indefinite_Subtype to be
+ Is_Definite_Subtype. This is an improvement to readability (the double
+ negative in "not Is_Indefinite_Subtype" was slightly confusing). Also
+ disallow passing non-[sub]type entities, an unnecessary and slightly
+ bug-prone flexibility.
+
2015-05-26 Robert Dewar <dewar@adacore.com>
* sem_aggr.adb (Resolve_Array_Aggregate): Defend against
Etyp : Entity_Id;
Xnode : Node_Id;
+ function Wrap_MA (Exp : Node_Id) return Node_Id;
+ -- Given an expression Exp, if the root type is Float or Long_Float,
+ -- then wrap the expression in a call of Bastyp'Machine, to stop any
+ -- extra precision. This is done to ensure that X**A = X**B when A is
+ -- a static constant and B is a variable with the same value. For any
+ -- other type, the node Exp is returned unchanged.
+
+ -------------
+ -- Wrap_MA --
+ -------------
+
+ function Wrap_MA (Exp : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Exp);
+ begin
+ if Rtyp = Standard_Float or else Rtyp = Standard_Long_Float then
+ return
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Machine,
+ Prefix => New_Occurrence_Of (Bastyp, Loc),
+ Expressions => New_List (Relocate_Node (Exp)));
+ else
+ return Exp;
+ end if;
+ end Wrap_MA;
+
+ -- Start of processing for Expand_N_Op
+
begin
Binary_Op_Validity_Checks (N);
-- could fold small negative exponents for the real case, but we
-- can't because we are required to raise Constraint_Error for
-- the case of 0.0 ** (negative) even if Machine_Overflows = False.
- -- See ACVC test C4A012B.
+ -- See ACVC test C4A012B, and it is not worth generating the test.
if Expv >= 0 and then Expv <= 4 then
elsif Expv = 2 then
Xnode :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Duplicate_Subexpr (Base),
- Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
+ Wrap_MA (
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Duplicate_Subexpr (Base),
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
-- X ** 3 = X * X * X
elsif Expv = 3 then
Xnode :=
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_Op_Multiply (Loc,
- Left_Opnd => Duplicate_Subexpr (Base),
- Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
- Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
+ Wrap_MA (
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Duplicate_Subexpr (Base),
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base)));
-- X ** 4 ->
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression =>
- Make_Op_Multiply (Loc,
- Left_Opnd =>
- Duplicate_Subexpr (Base),
- Right_Opnd =>
- Duplicate_Subexpr_No_Checks (Base)))),
+ Wrap_MA (
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Duplicate_Subexpr (Base),
+ Right_Opnd =>
+ Duplicate_Subexpr_No_Checks (Base))))),
Expression =>
- Make_Op_Multiply (Loc,
- Left_Opnd => New_Occurrence_Of (Temp, Loc),
- Right_Opnd => New_Occurrence_Of (Temp, Loc)));
+ Wrap_MA (
+ Make_Op_Multiply (Loc,
+ Left_Opnd => New_Occurrence_Of (Temp, Loc),
+ Right_Opnd => New_Occurrence_Of (Temp, Loc))));
end if;
Rewrite (N, Xnode);
if Is_Modular_Integer_Type (Rtyp) then
- -- Nonbinary case, we call the special exponentiation routine for
- -- the nonbinary case, converting the argument to Long_Long_Integer
- -- and passing the modulus value. Then the result is converted back
- -- to the base type.
+ -- Nonbinary modular case, we call the special exponentiation
+ -- routine for the nonbinary case, converting the argument to
+ -- Long_Long_Integer and passing the modulus value. Then the
+ -- result is converted back to the base type.
if Non_Binary_Modulus (Rtyp) then
Rewrite (N,
Make_Integer_Literal (Loc, Modulus (Rtyp)),
Exp))));
- -- Binary case, in this case, we call one of two routines, either the
- -- unsigned integer case, or the unsigned long long integer case,
- -- with a final "and" operation to do the required mod.
+ -- Binary modular case, in this case, we call one of two routines,
+ -- either the unsigned integer case, or the unsigned long long
+ -- integer case, with a final "and" operation to do the required mod.
else
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
Rent := RE_Exn_Integer;
end if;
- -- Floating-point cases, always done using Long_Long_Float. We do not
- -- need separate routines for the overflow case here, since in the case
- -- of floating-point, we generate infinities anyway as a rule (either
- -- that or we automatically trap overflow), and if there is an infinity
- -- generated and a range check is required, the check will fail anyway.
+ -- Floating-point cases. We do not need separate routines for the
+ -- overflow case here, since in the case of floating-point, we generate
+ -- infinities anyway as a rule (either that or we automatically trap
+ -- overflow), and if there is an infinity generated and a range check
+ -- is required, the check will fail anyway.
+
+ -- Historical note: we used to convert everything to Long_Long_Float
+ -- and call a single common routine, but this had the undesirable effect
+ -- of giving different results for small static exponent values and the
+ -- same dynamic values.
else
pragma Assert (Is_Floating_Point_Type (Rtyp));
- Etyp := Standard_Long_Long_Float;
- Rent := RE_Exn_Long_Long_Float;
+
+ if Rtyp = Standard_Float then
+ Etyp := Standard_Float;
+ Rent := RE_Exn_Float;
+
+ elsif Rtyp = Standard_Long_Float then
+ Etyp := Standard_Long_Float;
+ Rent := RE_Exn_Long_Float;
+
+ else
+ Etyp := Standard_Long_Long_Float;
+ Rent := RE_Exn_Long_Long_Float;
+ end if;
end if;
-- Common processing for integer cases and floating-point cases.
and then Rtyp /= Universal_Real
then
Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (Rent), Loc),
- Parameter_Associations => New_List (Base, Exp)));
+ Wrap_MA (
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (Rent), Loc),
+ Parameter_Associations => New_List (Base, Exp))));
-- Otherwise we have to introduce conversions (conversions are also
-- required in the universal cases, since the runtime routine is
Pass_Caller_Acc : Boolean := False;
Res_Decl : Node_Id;
Result_Subt : Entity_Id;
+ Definite : Boolean; -- True for definite function result subtype
begin
-- Step past qualification or unchecked conversion (the latter can occur
end if;
Result_Subt := Etype (Function_Id);
+ Definite := Is_Definite_Subtype (Underlying_Type (Result_Subt));
-- Create an access type designating the function's result subtype. We
-- use the type of the original call because it may be a call to an
-- The access type and its accompanying object must be inserted after
-- the object declaration in the constrained case, so that the function
- -- call can be passed access to the object. In the unconstrained case,
+ -- call can be passed access to the object. In the indefinite case,
-- or if the object declaration is for a return object, the access type
-- and object must be inserted before the object, since the object
-- declaration is rewritten to be a renaming of a dereference of the
-- the result object is in a different (transient) scope, so won't
-- cause freezing.
- if Is_Constrained (Underlying_Type (Result_Subt))
+ if Definite
and then not Is_Return_Object (Defining_Identifier (Object_Decl))
then
Insert_After_And_Analyze (Object_Decl, Ptr_Typ_Decl);
-- function, then the implicit build-in-place parameters of the
-- enclosing function are simply passed along to the called function.
-- (Unfortunately, this won't cover the case of extension aggregates
- -- where the ancestor part is a build-in-place unconstrained function
+ -- where the ancestor part is a build-in-place indefinite function
-- call that should be passed along the caller's parameters. Currently
-- those get mishandled by reassigning the result of the call to the
-- aggregate return object, when the call result should really be
Loc),
Pool_Actual => Pool_Actual);
- -- Otherwise, if enclosing function has a constrained result subtype,
+ -- Otherwise, if enclosing function has a definite result subtype,
-- then caller allocation will be used.
else
(Build_In_Place_Formal (Enclosing_Func, BIP_Object_Access),
Loc));
- -- In the constrained case, add an implicit actual to the function call
+ -- In the definite case, add an implicit actual to the function call
-- that provides access to the declared object. An unchecked conversion
-- to the (specific) result type of the function is inserted to handle
-- the case where the object is declared with a class-wide type.
- elsif Is_Constrained (Underlying_Type (Result_Subt)) then
+ elsif Definite then
Caller_Object :=
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc),
-- parameter must be passed indicating that the caller is allocating
-- the result object. This is needed because such a function can be
-- called as a dispatching operation and must be treated similarly
- -- to functions with unconstrained result subtypes.
+ -- to functions with indefinite result subtypes.
Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Func_Call, Function_Id, Alloc_Form => Caller_Allocation);
- -- In other unconstrained cases, pass an indication to do the allocation
+ -- In other indefinite cases, pass an indication to do the allocation
-- on the secondary stack and set Caller_Object to Empty so that a null
-- value will be passed for the caller's object address. A transient
-- scope is established to ensure eventual cleanup of the result.
Insert_After_And_Analyze (Ptr_Typ_Decl, Res_Decl);
- -- If the result subtype of the called function is constrained and
- -- is not itself the return expression of an enclosing BIP function,
- -- then mark the object as having no initialization.
+ -- If the result subtype of the called function is definite and is not
+ -- itself the return expression of an enclosing BIP function, then mark
+ -- the object as having no initialization.
- if Is_Constrained (Underlying_Type (Result_Subt))
+ if Definite
and then not Is_Return_Object (Defining_Identifier (Object_Decl))
then
-- The related object declaration is encased in a transient block
Set_Expression (Object_Decl, Empty);
Set_No_Initialization (Object_Decl);
- -- In case of an unconstrained result subtype, or if the call is the
+ -- In case of an indefinite result subtype, or if the call is the
-- return expression of an enclosing BIP function, rewrite the object
-- declaration as an object renaming where the renamed object is a
-- dereference of <function_Call>'reference:
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
return Out_Present (Parameter)
and then Has_Discriminants (Etyp)
and then not Is_Constrained (Etyp)
- and then not Is_Indefinite_Subtype (Etyp);
+ and then Is_Definite_Subtype (Etyp);
end Need_Extra_Constrained;
------------------------------------
#include <signal.h>
#include <taskLib.h>
-#if defined (i386) || defined (__i386__)
+#if (defined (i386) || defined (__i386__)) && !defined (VTHREADS)
#include <sysLib.h>
#endif
Raise_From_Signal_Handler (exception, msg);
}
-#if defined (i386) || defined (__i386__)
+#if (defined (i386) || defined (__i386__)) && !defined (VTHREADS)
extern void
__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc);
necessary. This only incurs a few extra instructions and a tiny
amount of extra stack usage. */
-#if defined (i386) || defined (__i386__)
+#if (defined (i386) || defined (__i386__)) && !defined (VTHREADS)
/* On x86, the vxsim signal context is subtly different and is processeed
by a handler compiled especially for vxsim. */
trap_0_entry->inst_fourth = 0xa1480000;
#endif
-#if defined (i386) || defined (__i386__)
+#if (defined (i386) || defined (__i386__)) && !defined (VTHREADS)
/* By experiment, found that sysModel () returns the following string
prefix for vxsim when running on Linux and Windows. */
model = sysModel ();
null;
elsif Is_Generic_Type (Entity (P)) then
- if not Is_Indefinite_Subtype (Entity (P)) then
+ if Is_Definite_Subtype (Entity (P)) then
Error_Attr_P
("prefix of % attribute must be indefinite generic type");
end if;
when Attribute_Definite =>
Rewrite (N, New_Occurrence_Of (
- Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
+ Boolean_Literals (Is_Definite_Subtype (P_Entity)), Loc));
Analyze_And_Resolve (N, Standard_Boolean);
-----------
end if;
end Is_By_Reference_Type;
+ ---------------------------
+ -- Is_Definite_Subtype --
+ ---------------------------
+
+ function Is_Definite_Subtype (T : Entity_Id) return Boolean is
+ pragma Assert (Is_Type (T));
+ K : constant Entity_Kind := Ekind (T);
+
+ begin
+ if Is_Constrained (T) then
+ return True;
+
+ elsif K in Array_Kind
+ or else K in Class_Wide_Kind
+ or else Has_Unknown_Discriminants (T)
+ then
+ return False;
+
+ -- Known discriminants: definite if there are default values. Note that
+ -- if any discriminant has a default, they all do.
+
+ elsif Has_Discriminants (T) then
+ return Present
+ (Discriminant_Default_Value (First_Discriminant (T)));
+
+ else
+ return True;
+ end if;
+ end Is_Definite_Subtype;
+
---------------------
-- Is_Derived_Type --
---------------------
end if;
end Is_Immutably_Limited_Type;
- ---------------------------
- -- Is_Indefinite_Subtype --
- ---------------------------
-
- function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean is
- K : constant Entity_Kind := Ekind (Ent);
-
- begin
- if Is_Constrained (Ent) then
- return False;
-
- elsif K in Array_Kind
- or else K in Class_Wide_Kind
- or else Has_Unknown_Discriminants (Ent)
- then
- return True;
-
- -- Known discriminants: indefinite if there are no default values
-
- elsif K in Record_Kind
- or else Is_Incomplete_Or_Private_Type (Ent)
- or else Is_Concurrent_Type (Ent)
- then
- return (Has_Discriminants (Ent)
- and then
- No (Discriminant_Default_Value (First_Discriminant (Ent))));
-
- else
- return False;
- end if;
- end Is_Indefinite_Subtype;
-
---------------------
-- Is_Limited_Type --
---------------------
-- used to set the visibility of generic formals of a generic package
-- declared with a box or with partial parameterization.
- function Is_Indefinite_Subtype (Ent : Entity_Id) return Boolean;
- -- Ent is any entity. Determines if given entity is an unconstrained array
- -- type or subtype, a discriminated record type or subtype with no initial
- -- discriminant values or a class wide type or subtype and returns True if
- -- so. False for other type entities, or any entities that are not types.
+ function Is_Definite_Subtype (T : Entity_Id) return Boolean;
+ -- T is a type entity. Returns True if T is a definite subtype.
+ -- Indefinite subtypes are unconstrained arrays, unconstrained
+ -- discriminated types without defaulted discriminants, class-wide types,
+ -- and types with unknown discriminants. Definite subtypes are all others
+ -- (elementary, constrained composites (including the case of records
+ -- without discriminants), and types with defaulted discriminants).
function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
-- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the
-- It should not be necessary to check for unknown discriminants on
-- Formal, but for some reason Has_Unknown_Discriminants is false for
- -- A_Gen_T, so Is_Indefinite_Subtype incorrectly returns False. This
+ -- A_Gen_T, so Is_Definite_Subtype incorrectly returns True. This
-- needs fixing. ???
- if not Is_Indefinite_Subtype (A_Gen_T)
+ if Is_Definite_Subtype (A_Gen_T)
and then not Unknown_Discriminants_Present (Formal)
- and then Is_Indefinite_Subtype (Act_T)
+ and then not Is_Definite_Subtype (Act_T)
then
Error_Msg_N ("actual subtype must be constrained", Actual);
Abandon_Instantiation (Actual);
("actual for & must have preelaborable initialization", Actual,
Gen_T);
- elsif Is_Indefinite_Subtype (Act_T)
- and then not Is_Indefinite_Subtype (A_Gen_T)
+ elsif not Is_Definite_Subtype (Act_T)
+ and then Is_Definite_Subtype (A_Gen_T)
and then Ada_Version >= Ada_95
then
Error_Msg_NE
-- The parent type may be a private view with unknown discriminants,
-- and thus unconstrained. Regular components must be constrained.
- if Is_Indefinite_Subtype (T) and then Chars (Id) /= Name_uParent then
+ if not Is_Definite_Subtype (T) and then Chars (Id) /= Name_uParent then
if Is_Class_Wide_Type (T) then
Error_Msg_N
("class-wide subtype with unknown discriminants" &
-- Case of unconstrained type
- if Is_Indefinite_Subtype (T) then
+ if not Is_Definite_Subtype (T) then
-- In SPARK, a declaration of unconstrained type is allowed
-- only for constants of type string.
and then Is_Record_Type (T)
and then not Is_Constrained (T)
and then Has_Discriminants (T)
- and then (Ada_Version < Ada_2005 or else Is_Indefinite_Subtype (T))
+ and then (Ada_Version < Ada_2005
+ or else not Is_Definite_Subtype (T))
then
Set_Actual_Subtype (Id, Build_Default_Subtype (T, N));
end if;
-- that all the indexes are unconstrained but we still need to make sure
-- that the element type is constrained.
- if Is_Indefinite_Subtype (Element_Type) then
+ if not Is_Definite_Subtype (Element_Type) then
Error_Msg_N
("unconstrained element type in array declaration",
Subtype_Indication (Component_Def));
-- not completed with an unconstrained type. A separate error message
-- is produced if the full type has defaulted discriminants.
- if not Is_Indefinite_Subtype (Priv_T)
- and then Is_Indefinite_Subtype (Full_T)
+ if Is_Definite_Subtype (Priv_T)
+ and then not Is_Definite_Subtype (Full_T)
then
Error_Msg_Sloc := Sloc (Parent (Priv_T));
Error_Msg_NE
-- had errors on analyzing the allocator, since in that case these
-- are probably cascaded errors.
- if Is_Indefinite_Subtype (Type_Id)
+ if not Is_Definite_Subtype (Type_Id)
and then Serious_Errors_Detected = Sav_Errs
then
-- The build-in-place machinery may produce an allocator when
-- because the allocator is marked as coming from source.
if Present (Underlying_Type (Type_Id))
- and then not Is_Indefinite_Subtype (Underlying_Type (Type_Id))
+ and then Is_Definite_Subtype (Underlying_Type (Type_Id))
and then not Comes_From_Source (Parent (N))
then
null;
if Has_Discriminants (Formal_Type)
and then not Is_Constrained (Formal_Type)
- and then not Is_Indefinite_Subtype (Formal_Type)
+ and then Is_Definite_Subtype (Formal_Type)
and then (Ada_Version < Ada_2012
or else No (Underlying_Type (Formal_Type))
or else not
-- The following test may be redundant, as this is already
-- diagnosed in sem_ch3. ???
- if Is_Indefinite_Subtype (Full)
- and then not Is_Indefinite_Subtype (Id)
+ if not Is_Definite_Subtype (Full)
+ and then Is_Definite_Subtype (Id)
then
Error_Msg_Sloc := Sloc (Parent (Id));
Error_Msg_NE
-- Ada 2005 (AI-363): In Ada 2005 an aliased object can be mutable
if not Is_Constrained (Prefix_Type)
- and then (not Is_Indefinite_Subtype (Prefix_Type)
+ and then (Is_Definite_Subtype (Prefix_Type)
or else
(Is_Generic_Type (Prefix_Type)
and then Ekind (Current_Scope) = E_Generic_Package
-- for declaring an object. It might be possible to relax this in the
-- future, e.g. by declaring the maximum possible space for the type.
- elsif Is_Indefinite_Subtype (Typ) then
+ elsif not Is_Definite_Subtype (Typ) then
return True;
-- Functions returning tagged types may dispatch on result so their
projects / gcc.git / commitdiff