2017-10-20 Bob Duff <duff@adacore.com>
+ * exp_aggr.adb (Initialize_Array_Component): Avoid adjusting a
+ component of an array aggregate if it is initialized by a
+ build-in-place function call.
+ * exp_ch6.adb (Is_Build_In_Place_Result_Type): Use -gnatd.9 to disable
+ bip for nonlimited types.
+ * debug.adb: Document -gnatd.9.
+
+2017-10-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch12.adb: Remove redundant setting of Parent.
+
+2017-10-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch4.adb (Find_Concatenation_Types): Filter out operators if one
+ of the operands is a string literal.
+
+2017-10-20 Bob Duff <duff@adacore.com>
+
+ * einfo.ads: Comment fix.
+
+2017-10-20 Clement Fumex <fumex@adacore.com>
+
+ * switch-c.adb: Remove -gnatwm from the switches triggered by -gnateC.
+
+2017-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Extract_Power): Accept dimension values that are not
+ non-negative integers when the dimensioned base type is an Integer
+ type.
+
+2017-10-20 Bob Duff <duff@adacore.com>
+
* sinfo.ads, sinfo.adb (Alloc_For_BIP_Return): New flag to indicate
that an allocator came from a b-i-p return statement.
* exp_ch4.adb (Expand_Allocator_Expression): Avoid adjusting the return
-- stack globals.
if Sec_Stack_Used then
- -- Elaborate the body of the binder to initialize the
- -- default-sized secondary stack pool.
+
+ -- Elaborate the body of the binder to initialize the default-
+ -- sized secondary stack pool.
WBI ("");
WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
-- related secondary stack globals.
Set_String (" Default_Secondary_Stack_Size := ");
+
if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
Set_Int (Opt.Default_Sec_Stack_Size);
else
- Set_String
- ("System.Parameters.Runtime_Default_Sec_Stack_Size");
+ Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
end if;
+
Set_Char (';');
Write_Statement_Buffer;
-- stack globals.
if Sec_Stack_Used then
- -- Elaborate the body of the binder to initialize the
- -- default-sized secondary stack pool.
+
+ -- Elaborate the body of the binder to initialize the default-
+ -- sized secondary stack pool.
WBI (" " & Get_Ada_Main_Name & "'Elab_Body;");
-- related secondary stack globals.
Set_String (" Default_Secondary_Stack_Size := ");
+
if Opt.Default_Sec_Stack_Size /= Opt.No_Stack_Size then
Set_Int (Opt.Default_Sec_Stack_Size);
else
Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
end if;
+
Set_Char (';');
Write_Statement_Buffer;
Write_Statement_Buffer;
Set_String (" Default_Sized_SS_Pool := ");
+
if Num_Sec_Stacks > 0 then
Set_String ("Sec_Default_Sized_Stacks'Address;");
else
Set_String ("System.Null_Address;");
end if;
- Write_Statement_Buffer;
+ Write_Statement_Buffer;
WBI ("");
end if;
-- Generate call to Runtime_Initialize
+
WBI (" Runtime_Initialize (1);");
end if;
end if;
for J in Units.First .. Units.Last loop
- Num_Primary_Stacks := Num_Primary_Stacks +
- Units.Table (J).Primary_Stack_Count;
- Num_Sec_Stacks := Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count;
+ Num_Primary_Stacks :=
+ Num_Primary_Stacks + Units.Table (J).Primary_Stack_Count;
+
+ Num_Sec_Stacks :=
+ Num_Sec_Stacks + Units.Table (J).Sec_Stack_Count;
end loop;
-- Generate output file in appropriate language
Set_String (" : array (1 .. ");
Set_Int (Num_Sec_Stacks);
Set_String (") of aliased System.Secondary_Stack.SS_Stack (");
+
if Opt.Default_Sec_Stack_Size /= No_Stack_Size then
Set_Int (Opt.Default_Sec_Stack_Size);
else
Set_String ("System.Parameters.Runtime_Default_Sec_Stack_Size");
end if;
+
Set_String (");");
Write_Statement_Buffer;
WBI ("");
if not Suppress_Standard_Library_On_Target then
- -- The B.1(39) implementation advice says that the adainit
- -- and adafinal routines should be idempotent. Generate a flag to
+ -- The B.1(39) implementation advice says that the adainit and
+ -- adafinal routines should be idempotent. Generate a flag to
-- ensure that. This is not needed if we are suppressing the
-- standard library since it would never be referenced.
-- d.6 Do not avoid declaring unreferenced types in C code
-- d.7
-- d.8
- -- d.9 Enable build-in-place for nonlimited types
+ -- d.9 Disable build-in-place for nonlimited types
-- Debug flags for binder (GNATBIND)
-- that represents an activation record pointer is an extra formal.
-- Extra_Formals (Node28)
--- Applies to subprograms and subprogram types, and also to entries
--- and entry families. Returns first extra formal of the subprogram
--- or entry. Returns Empty if there are no extra formals.
+-- Applies to subprograms, subprogram types, entries, and entry
+-- families. Returns first extra formal of the subprogram or entry.
+-- Returns Empty if there are no extra formals.
-- Finalization_Master (Node23) [root type only]
-- Defined in access-to-controlled or access-to-class-wide types. The
if Finalization_OK
and then not Is_Limited_Type (Comp_Typ)
+ and then not Is_Build_In_Place_Function_Call (Init_Expr)
and then not
(Is_Array_Type (Comp_Typ)
and then Is_Controlled (Component_Type (Comp_Typ))
if Attribute_Name (Parent (Pref)) = Name_Old then
null;
-
else
Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
end if;
Sec_Stacks : out Int)
is
Component : Entity_Id;
+
begin
-- To calculate the number of default-sized task stacks required for
-- an object of Typ, a depth-first recursive traversal of the AST
end if;
case Ekind (Typ) is
- when E_Task_Type
- | E_Task_Subtype
+ when E_Task_Subtype
+ | E_Task_Type
=>
-- A task type is found marking the bottom of the descent. If
-- the type has no representation aspect for the corresponding
Sec_Stacks := 1;
end if;
- when E_Array_Type
- | E_Array_Subtype
+ when E_Array_Subtype
+ | E_Array_Type
=>
-- First find the number of default stacks contained within an
-- array component.
Sec_Stacks := Sec_Stacks * Quantity;
end;
- when E_Record_Type
- | E_Record_Subtype
+ when E_Protected_Subtype
| E_Protected_Type
- | E_Protected_Subtype
+ | E_Record_Subtype
+ | E_Record_Type
=>
Component := First_Component_Or_Discriminant (Typ);
while Present (Component) loop
if Has_Task (Etype (Component)) then
declare
- P, S : Int;
+ P : Int;
+ S : Int;
+
begin
Count_Default_Sized_Task_Stacks
(Etype (Component), P, S);
Next_Component_Or_Discriminant (Component);
end loop;
- when E_Limited_Private_Type
- | E_Limited_Private_Subtype
- | E_Record_Type_With_Private
+ when E_Limited_Private_Subtype
+ | E_Limited_Private_Type
| E_Record_Subtype_With_Private
+ | E_Record_Type_With_Private
=>
-- Switch to the full view of the private type to continue
-- search.
declare
Cnn : constant Entity_Id := Make_Temporary (Loc, 'C', N);
Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'A');
+
begin
-- Generate:
-- type Ann is access all Typ;
then
declare
Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
+
begin
Insert_Action (N,
Make_Object_Declaration (Loc,
declare
Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N);
+
begin
Decl :=
Make_Object_Declaration (Loc,
if Is_Limited_View (Typ) then
return Ada_Version >= Ada_2005 and then not Debug_Flag_Dot_L;
+
else
+ if Debug_Flag_Dot_9 then
+ return False;
+ end if;
+
if Has_Interfaces (Typ) then
return False;
end if;
declare
Result : Boolean;
+ -- So we can stop here in the debugger
begin
-- ???For now, enable build-in-place for a very narrow set of
-- controlled types. Change "if True" to "if False" to
-- experiment more controlled types. Eventually, we would
-- like to enable build-in-place for all tagged types, all
-- types that need finalization, and all caller-unknown-size
- -- types. We will eventually use Debug_Flag_Dot_9 to disable
- -- build-in-place for nonlimited types.
+ -- types.
--- if Debug_Flag_Dot_9 then
if True then
Result := Is_Controlled (T)
and then Present (Enclosing_Subprogram (T))
(Restriction_Active (No_Implicit_Heap_Allocations)
or else Restriction_Active (No_Implicit_Task_Allocations))
and then not Restriction_Active (No_Secondary_Stack)
- and then Has_Rep_Item (T, Name_Secondary_Stack_Size,
- Check_Parents => False);
+ and then Has_Rep_Item
+ (T, Name_Secondary_Stack_Size, Check_Parents => False);
end Create_Secondary_Stack_For_Task;
-------------------------------------
Get_Rep_Item
(TaskId, Name_Secondary_Stack_Size, Check_Parents => False);
- -- Get Secondary_Stack_Size expression. Can be a pragma or
- -- aspect.
+ -- Get Secondary_Stack_Size expression. Can be a pragma or aspect.
if Nkind (Ritem) = N_Pragma then
Size_Expr :=
-- Create the secondary stack for the task
- Decl_SS := Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
-
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => True,
- Subtype_Indication => Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Integer_Literal (Loc,
- Expr_Value (Size_Expr)))))));
+ Decl_SS :=
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uSecondary_Stack),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => True,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_SS_Stack), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Integer_Literal (Loc,
+ Expr_Value (Size_Expr)))))));
Append_To (Cdecls, Decl_SS);
end;
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name =>
- Make_Identifier (Loc, Name_uSecondary_Stack)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uSecondary_Stack)),
Attribute_Name => Name_Unrestricted_Access));
else
-- Could be e.g. a loop that was transformed into a block or null
-- statement. Do nothing for terminate alternatives.
- when N_Block_Statement | N_Null_Statement | N_Terminate_Alternative =>
+ when N_Block_Statement
+ | N_Null_Statement
+ | N_Terminate_Alternative
+ =>
null;
when others =>
function Generate_Code (U : Unit_Number_Type) return Boolean;
function Ident_String (U : Unit_Number_Type) return Node_Id;
function Has_RACW (U : Unit_Number_Type) return Boolean;
- function Is_Predefined_Renaming (U : Unit_Number_Type) return Boolean;
- function Is_Internal_Unit (U : Unit_Number_Type) return Boolean;
- function Is_Predefined_Unit (U : Unit_Number_Type) return Boolean;
+ function Is_Predefined_Renaming
+ (U : Unit_Number_Type) return Boolean;
+ function Is_Internal_Unit (U : Unit_Number_Type) return Boolean;
+ function Is_Predefined_Unit
+ (U : Unit_Number_Type) return Boolean;
function Loading (U : Unit_Number_Type) return Boolean;
function Main_CPU (U : Unit_Number_Type) return Int;
function Main_Priority (U : Unit_Number_Type) return Int;
function Munit_Index (U : Unit_Number_Type) return Nat;
function No_Elab_Code_All (U : Unit_Number_Type) return Boolean;
function OA_Setting (U : Unit_Number_Type) return Character;
- function Primary_Stack_Count (U : Unit_Number_Type) return Int;
+ function Primary_Stack_Count
+ (U : Unit_Number_Type) return Int;
function Sec_Stack_Count (U : Unit_Number_Type) return Int;
function Source_Index (U : Unit_Number_Type) return Source_File_Index;
function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type;
begin
-- There are two situations where the default secondary stack size is
-- set to zero:
+ --
-- * The user sets it to zero erroneously thinking it will disable
-- the secondary stack.
+ --
-- * Or more likely, we are building with an old compiler and
-- Default_SS_Size is never set.
--
Valid_Operator_Definition (Act_Decl_Id);
end if;
- Set_Alias (Act_Decl_Id, Anon_Id);
- Set_Parent (Act_Decl_Id, Parent (Anon_Id));
+ Set_Alias (Act_Decl_Id, Anon_Id);
Set_Has_Completion (Act_Decl_Id);
Set_Related_Instance (Pack_Id, Act_Decl_Id);
Op_Id : Entity_Id;
N : Node_Id)
is
- Op_Type : constant Entity_Id := Etype (Op_Id);
+ Is_String : constant Boolean := Nkind (L) = N_String_Literal
+ or else
+ Nkind (R) = N_String_Literal;
+ Op_Type : constant Entity_Id := Etype (Op_Id);
begin
if Is_Array_Type (Op_Type)
+
+ -- Small but very effective optimization: if at least one operand is a
+ -- string literal, then the type of the operator must be either array
+ -- of characters or array of strings.
+
+ and then (not Is_String
+ or else
+ Is_Character_Type (Component_Type (Op_Type))
+ or else
+ Is_String_Type (Component_Type (Op_Type)))
+
and then not Is_Limited_Type (Op_Type)
and then (Has_Compatible_Type (L, Op_Type)
Position : Dimension_Position)
is
begin
- -- Integer case
-
- if Is_Integer_Type (Def_Id) then
-
- -- Dimension value must be an integer literal
-
- if Nkind (Expr) = N_Integer_Literal then
- Dimensions (Position) := +Whole (UI_To_Int (Intval (Expr)));
- else
- Error_Msg_N ("integer literal expected", Expr);
- end if;
+ Dimensions (Position) := Create_Rational_From (Expr, True);
+ Processed (Position) := True;
- -- Float case
+ -- If the dimensioned root type is an integer type, it is not
+ -- particularly useful, and fractional dimensions do not make
+ -- much sense for such types, so previously we used to reject
+ -- dimensions of integer types that were not integer literals.
+ -- However, the manipulation of dimensions does not depend on
+ -- the kind of root type, so we can accept this usage for rare
+ -- cases where dimensions are specified for integer values.
- else
- Dimensions (Position) := Create_Rational_From (Expr, True);
- end if;
-
- Processed (Position) := True;
end Extract_Power;
------------------------
Set_SCO_Pragma_Enabled (Loc);
end if;
- -- Deal with analyzing the string argument
+ -- Deal with analyzing the string argument. If checks are not
+ -- on we don't want any expansion (since such expansion would
+ -- not get properly deleted) but we do want to analyze (to get
+ -- proper references). The Preanalyze_And_Resolve routine does
+ -- just what we want. Ditto if pragma is active, because it will
+ -- be rewritten as an if-statement whose analysis will complete
+ -- analysis and expansion of the string message. This makes a
+ -- difference in the unusual case where the expression for the
+ -- string may have a side effect, such as raising an exception.
+ -- This is mandated by RM 11.4.2, which specifies that the string
+ -- expression is only evaluated if the check fails and
+ -- Assertion_Error is to be raised.
if Arg_Count = 3 then
-
- -- If checks are not on we don't want any expansion (since
- -- such expansion would not get properly deleted) but
- -- we do want to analyze (to get proper references).
- -- The Preanalyze_And_Resolve routine does just what we want.
- -- Ditto if pragma is active, because it will be rewritten
- -- as an if-statement whose analysis will complete analysis
- -- and expansion of the string message. This makes a
- -- difference in the unusual case where the expression for
- -- the string may have a side effect, such as raising an
- -- exception. This is mandated by RM 11.4.2, which specifies
- -- that the string expression is only evaluated if the
- -- check fails and Assertion_Error is to be raised.
-
Preanalyze_And_Resolve (Str, Standard_String);
-
end if;
-- Now you might think we could just do the same with the Boolean
(Comes_From_Source (Parent (N))
or else
(Ekind (Current_Scope) = E_Function
- and then Nkind
- (Original_Node (Unit_Declaration_Node (Current_Scope)))
- = N_Expression_Function))
+ and then Nkind (Original_Node (Unit_Declaration_Node
+ (Current_Scope))) = N_Expression_Function))
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Etype (E), Expression (E)) then
Warn_On_Bad_Fixed_Value := True; -- -gnatwb
Warn_On_Biased_Representation := True; -- -gnatw.b
Warn_On_Export_Import := True; -- -gnatwx
- Warn_On_Modified_Unread := True; -- -gnatwm
Warn_On_No_Value_Assigned := True; -- -gnatwv
Warn_On_Object_Renames_Function := True; -- -gnatw.r
Warn_On_Overlap := True; -- -gnatw.i
+2017-10-20 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat.dg/dimensions.adb, gnat.dg/dimensions.ads: New testcase.
+
2017-10-20 Richard Biener <rguenther@suse.de>
PR tree-optimization/82473
--- /dev/null
+-- { dg-do compile }
+
+package body Dimensions is
+ procedure Dummy is null;
+end Dimensions;
--- /dev/null
+package Dimensions is
+
+ type Mks_Int_Type is new Integer
+ with
+ Dimension_System => (
+ (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'),
+ (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'),
+ (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'),
+ (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'),
+ (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'),
+ (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'),
+ (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J'));
+
+ subtype Int_Length is Mks_Int_Type
+ with
+ Dimension => (Symbol => 'm',
+ Meter => 1,
+ others => 0);
+
+ subtype Int_Speed is Mks_Int_Type
+ with
+ Dimension => (
+ Meter => 1,
+ Second => -1,
+ others => 0);
+
+ procedure Dummy;
+
+end Dimensions;
projects / platform / upstream / gcc.git / commitdiff