+2014-01-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.adb (Build_Init_Procedure): For
+ derivations of interfaces, do not move the the initialization
+ of the _parent field since such assignment is not generated.
+
+2014-01-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Rewrite_Renamed_Operator): Do not replace entity
+ with the operator it renames if we are within an expression of
+ a pre/postcondition, because the expression will be reanalyzed
+ at a later point, and the analysis of the renaming may affect
+ the visibility of the operator when in an instance.
+
+2014-01-21 Robert Dewar <dewar@adacore.com>
+
+ * sinfo.ads, sinfo.adb: Change Do_Discriminant_Check to use new Flag1.
+ Add this flag to type conversion nodes and assignment nodes.
+ * treepr.adb: Deal properly with Flag 1,2,3.
+ * treeprs.adt: Minor comment update.
+
+2014-01-21 Robert Dewar <dewar@adacore.com>
+
+ * sem_eval.adb (Compile_Time_Known_Value): Add Ignore_CRT
+ parameter.
+ * sem_eval.ads (Compile_Time_Known_Value): Add Ignore_CRT
+ parameter, completely rewrite spec.
+
+2014-01-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch10.adb (Install_Withed_Unit): If the unit is a subprogram
+ instance that is inlined, it may have been rewritten as a wrapper
+ package. In that case the unit that must be made visible is the
+ related instance of the package.
+
+2014-01-21 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Selective_Accept.Add_Accept): Refine
+ previous change in codepeer mode.
+
2014-01-21 Arnaud Charlet <charlet@adacore.com>
* exp_ch9.adb (Expand_N_Selective_Accept.Add_Accept): Always add
Component_List (Record_Extension_Node));
begin
- -- The parent field must be initialized first because
- -- the offset of the new discriminants may depend on it
+ -- The parent field must be initialized first because the
+ -- offset of the new discriminants may depend on it. This is
+ -- not needed if the parent is an interface type because in
+ -- such case the initialization of the _parent field was not
+ -- generated.
+
+ if not Is_Interface (Etype (Rec_Ent)) then
+ Prepend_To (Body_Stmts, Remove_Head (Stmts));
+ end if;
- Prepend_To (Body_Stmts, Remove_Head (Stmts));
Append_List_To (Body_Stmts, Stmts);
end;
end if;
if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then
Null_Body := New_Reference_To (Standard_False, Eloc);
- -- Always add call to Abort_Undefer, since this is what the
- -- runtime expects (abort deferred in Selective_Wait).
-
- Call :=
- Make_Procedure_Call_Statement (Eloc,
- Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc));
- Insert_Before
- (First (Statements (Handled_Statement_Sequence
- (Accept_Statement (Alt)))),
- Call);
- Analyze (Call);
+ -- Always add call to Abort_Undefer when generating code, since
+ -- this is what the runtime expects (abort deferred in
+ -- Selective_Wait). In CodePeer mode this only confuses the
+ -- analysis with unknown calls, so don't do it.
+
+ if not CodePeer_Mode then
+ Call :=
+ Make_Procedure_Call_Statement (Eloc,
+ Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc));
+ Insert_Before
+ (First (Statements (Handled_Statement_Sequence
+ (Accept_Statement (Alt)))),
+ Call);
+ Analyze (Call);
+ end if;
PB_Ent :=
Make_Defining_Identifier (Eloc,
Set_Is_Visible_Lib_Unit (Uname);
+ -- If the unit is a wrapper package for a compilation unit that is
+ -- a subprogrm instance, indicate that the instance itself is a
+ -- visible unit. This is necessary if the instance is inlined.
+
+ if Is_Wrapper_Package (Uname) then
+ Set_Is_Visible_Lib_Unit (Related_Instance (Uname));
+ end if;
+
-- If the child unit appears in the context of its parent, it is
-- immediately visible.
-- If the unit is a wrapper package, the subprogram instance is
-- what must be removed from visibility.
+ -- Should we use Related_Instance instead???
if Is_Wrapper_Package (Unit_Name) then
Set_Is_Immediately_Visible (Current_Entity (Unit_Name), False);
-- Compile_Time_Known_Value --
------------------------------
- function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
+ function Compile_Time_Known_Value
+ (Op : Node_Id;
+ Ignore_CRT : Boolean := False) return Boolean
+ is
K : constant Node_Kind := Nkind (Op);
CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
-- time. This avoids anomalies where whether something is allowed with a
-- given configurable run-time library depends on how good the compiler
-- is at optimizing and knowing that things are constant when they are
- -- nonstatic.
+ -- nonstatic. This check is suppressed if Ignore_CRT is True
- if Configurable_Run_Time_Mode
+ if (Configurable_Run_Time_Mode and not Ignore_CRT)
and then K /= N_Null
and then not Is_Static_Expression (Op)
then
and then Etype (Entity (Op)) = Standard_Boolean
then
null;
-
else
return False;
end if;
-- does not raise constraint error. In fact for certain legality checks not
-- only do we need to ascertain that the expression is static, but we must
-- also ensure that it does not raise constraint error.
- --
+
-- Neither of Is_Static_Expression and Is_OK_Static_Expression should be
-- used for compile time evaluation purposes. In fact certain expression
- -- whose value is known at compile time are not static in the RM 4.9 sense.
- -- A typical example is:
- --
+ -- whose value may be known at compile time are not static in the RM 4.9
+ -- sense. A typical example is:
+
-- C : constant Integer := Record_Type'Size;
- --
+
-- The expression 'C' is not static in the technical RM sense, but for many
-- simple record types, the size is in fact known at compile time. When we
-- are trying to perform compile time constant folding (for instance for
-- are not the right functions to test if folding is possible. Instead, we
-- use Compile_Time_Known_Value. All static expressions that do not raise
-- constraint error (i.e. those for which Is_OK_Static_Expression is true)
- -- are known at compile time, but as shown by the above example, there are
- -- cases of non-static expressions which are known at compile time.
+ -- are known at compile time, but as shown by the above example, there may
+ -- be cases of non-static expressions which are known at compile time.
-----------------
-- Subprograms --
-- Determine whether two types T1, T2, which have the same base type,
-- are statically matching subtypes (RM 4.9.1(1-2)).
- function Compile_Time_Known_Value (Op : Node_Id) return Boolean;
+ function Compile_Time_Known_Value
+ (Op : Node_Id;
+ Ignore_CRT : Boolean := False) return Boolean;
-- Returns true if Op is an expression not raising Constraint_Error whose
- -- value is known at compile time. This is true if Op is a static
+ -- value is known at compile time and for which a call to Expr_Value can
+ -- be used to determine this value. This is always true if Op is a static
-- expression, but can also be true for expressions which are technically
- -- non-static but which are in fact known at compile time, such as the
- -- static lower bound of a non-static range or the value of a constant
- -- object whose initial value is static. Note that this routine is defended
- -- against unanalyzed expressions. Such expressions will not cause a
- -- blowup, they may cause pessimistic (i.e. False) results to be returned.
+ -- non-static but which are in fact known at compile time. Some possible
+ -- examples of such expressions might be the static lower bound of a
+ -- non-static range or the value of a constant object whose initial
+ -- value is itself compile time known in the sense of this routine. Note
+ -- that this routine is defended against unanalyzed expressions. Such
+ -- expressions will not cause a blowup, they may cause pessimistic (i.e.
+ -- False) results to be returned. In general we take a pessimistic view.
+ -- False does not mean the value could not be known at compile time, but
+ -- True means that absolutely definition it is known at compile time and
+ -- it is safe to call Expr_Value on the expression Op.
+ --
+ -- Note that we don't define precisely the set of expressions that return
+ -- True. Callers should not make any assumptions regarding the value that
+ -- is returned for non-static expressions. Functional behavior should never
+ -- be affected by whether a given non-static expression returns True or
+ -- False when this function is called. In other words this is purely for
+ -- efficiency optimization purposes. The code generated can often be more
+ -- efficient with compile time known values, e.g. range analysis for the
+ -- purpose of removing checks is more effective if we know precise bounds.
+ --
+ -- The Ignore_CRT parameter has to do with the special case of configurable
+ -- runtime mode. Consider the following example:
+ --
+ -- X := B ** C;
+ --
+ -- Now if C is compile time known, and has the value 4, then inline code
+ -- can be generated at compile time, instead of calling a run-time routine.
+ -- That's fine in the normal case, but when we have a configurable run-time
+ -- the run-time routine may not be available. This means that the program
+ -- will be rejected if C is not known at compile time. We don't want the
+ -- legality of a program to depend on how clever the implementation of this
+ -- function is. If the run-time in use lacks the exponentiation routine,
+ -- then what we say is that exponentiation is permitted if the exponent is
+ -- officially static and has a value in the range 0 .. 4.
+ --
+ -- However, in the normal case, we want efficient code in the case where
+ -- a non-static exponent is known at compile time. To take care of this,
+ -- the normal default behavior is that in configurable run-time mode most
+ -- expressions are considered known at compile time ONLY in the case where
+ -- they are officially static. An exception is boolean objects which may
+ -- be considered known at compile time even in configurable run-time mode.
+ --
+ -- That loses optimization opportunities, and it would be better to look
+ -- case by case at each use of Compile_Time_Known_Value to see if this
+ -- configurable run-time mode special processing is needed. The Ignore_CRT
+ -- parameter can be set to True to ignore this special handling in cases
+ -- where it is known to be safe to do so.
function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
-- Similar to Compile_Time_Known_Value, but also returns True if the value
Op_Node : Node_Id;
begin
+ -- Do not perform this transformation within a pre/postcondition,
+ -- because the expression will be re-analyzed, and the transformation
+ -- might affect the visibility of the operator, e.g. in an instance.
+
+ if In_Assertion_Expr > 0 then
+ return;
+ end if;
+
-- Rewrite the operator node using the real operator, not its renaming.
-- Exclude user-defined intrinsic operations of the same name, which are
-- treated separately and rewritten as calls.
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- return Flag13 (N);
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Type_Conversion);
+ return Flag1 (N);
end Do_Discriminant_Check;
function Do_Division_Check
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Selected_Component);
- Set_Flag13 (N, Val);
+ or else NT (N).Nkind = N_Assignment_Statement
+ or else NT (N).Nkind = N_Selected_Component
+ or else NT (N).Nkind = N_Type_Conversion);
+ Set_Flag1 (N, Val);
end Set_Do_Discriminant_Check;
procedure Set_Do_Division_Check
-- A flag set in the N_Subprogram_Body node for a subprogram body which
-- is acting as its own spec, except in the case of a library level
-- subprogram, in which case the flag is set on the parent compilation
- -- unit node instead (see further description in spec of Lib package).
- -- ??? Above note about Lib is dubious since lib.ads does not mention
- -- Acts_As_Spec at all.
+ -- unit node instead.
-- Actual_Designated_Subtype (Node4-Sem)
-- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi
-- that an accessibility check is required for the parameter. It is
-- not yet decided who takes care of this check (TBD ???).
- -- Do_Discriminant_Check (Flag13-Sem)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- This flag is set on N_Selected_Component nodes to indicate that a
-- discriminant check is required using the discriminant check routine
-- associated with the selector. The actual check is generated by the
-- expander when processing selected components. In the case of
-- Unchecked_Union, the flag is also set, but no discriminant check
-- routine is associated with the selector, and the expander does not
- -- generate a check.
+ -- generate a check. This flag is also present in assignment statements
+ -- (and set if the assignment requires a discriminant check), and in type
+ -- conversion nodes (and set if the conversion requires a check).
-- Do_Division_Check (Flag13-Sem)
-- This flag is set on a division operator (/ mod rem) to indicate
-- is undefined and should not be read).
-- No_Ctrl_Actions (Flag7-Sem)
- -- Present in N_Assignment_Statement to indicate that no finalize nor
- -- adjust should take place on this assignment even though the rhs is
+ -- Present in N_Assignment_Statement to indicate that no Finalize nor
+ -- Adjust should take place on this assignment even though the RHS is
-- controlled. This is used in init procs and aggregate expansions where
- -- the generated assignments are more initialisations than real
- -- assignments.
+ -- the generated assignments are initializations, not real assignments.
-- No_Elaboration_Check (Flag14-Sem)
-- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates
-- Prefix (Node3)
-- Selector_Name (Node2)
-- Associated_Node (Node4-Sem)
- -- Do_Discriminant_Check (Flag13-Sem)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- Is_In_Discriminant_Check (Flag11-Sem)
-- Is_Prefixed_Call (Flag17-Sem)
-- Atomic_Sync_Required (Flag14-Sem)
-- Sloc points to first token of subtype mark
-- Subtype_Mark (Node4)
-- Expression (Node3)
- -- Do_Tag_Check (Flag13-Sem)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- Do_Length_Check (Flag4-Sem)
- -- Do_Overflow_Check (Flag17-Sem)
-- Float_Truncate (Flag11-Sem)
- -- Rounded_Result (Flag18-Sem)
+ -- Do_Tag_Check (Flag13-Sem)
-- Conversion_OK (Flag14-Sem)
+ -- Do_Overflow_Check (Flag17-Sem)
+ -- Rounded_Result (Flag18-Sem)
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
-- Sloc points to :=
-- Name (Node2)
-- Expression (Node3)
+ -- Do_Discriminant_Check (Flag1-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- Do_Length_Check (Flag4-Sem)
-- Forwards_OK (Flag5-Sem)
(N : Node_Id) return Boolean; -- Flag13
function Do_Discriminant_Check
- (N : Node_Id) return Boolean; -- Flag13
+ (N : Node_Id) return Boolean; -- Flag1
function Do_Division_Check
(N : Node_Id) return Boolean; -- Flag13
(N : Node_Id; Val : Boolean := True); -- Flag13
procedure Set_Do_Discriminant_Check
- (N : Node_Id; Val : Boolean := True); -- Flag13
+ (N : Node_Id; Val : Boolean := True); -- Flag1
procedure Set_Do_Division_Check
(N : Node_Id; Val : Boolean := True); -- Flag13
when F_Field5 =>
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
- -- Flag3 is obsolete, so this probably gets removed ???
-
- when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N);
-
+ when F_Flag1 => Field_To_Be_Printed := Flag1 (N);
+ when F_Flag2 => Field_To_Be_Printed := Flag2 (N);
+ when F_Flag3 => Field_To_Be_Printed := Flag3 (N);
when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
-
- -- Flag1,2 are no longer used
-
- when F_Flag1 => raise Program_Error;
- when F_Flag2 => raise Program_Error;
end case;
-- Print field if it is to be printed
-- Special case End_Span = Uint5
when F_Field5 =>
- if Nkind (N) = N_Case_Statement
- or else Nkind (N) = N_If_Statement
- then
+ if Nkind_In (N, N_Case_Statement, N_If_Statement) then
Print_End_Span (N);
else
Print_Field (Field5 (N), Fmt);
end if;
+ when F_Flag1 => Print_Flag (Flag1 (N));
+ when F_Flag2 => Print_Flag (Flag2 (N));
+ when F_Flag3 => Print_Flag (Flag3 (N));
when F_Flag4 => Print_Flag (Flag4 (N));
when F_Flag5 => Print_Flag (Flag5 (N));
when F_Flag6 => Print_Flag (Flag6 (N));
when F_Flag16 => Print_Flag (Flag16 (N));
when F_Flag17 => Print_Flag (Flag17 (N));
when F_Flag18 => Print_Flag (Flag18 (N));
-
- -- Flag1,2 are no longer used
-
- when F_Flag1 => raise Program_Error;
- when F_Flag2 => raise Program_Error;
-
- -- Not clear why we need the following ???
-
- when F_Flag3 => Print_Flag (Has_Aspects (N));
end case;
Print_Eol;
-- --
-- T e m p l a t e --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
-- could never occur in a field name, so they also mark the end of the
-- previous name.
+ -- Note the following definitions do not include Flag0. This will have to
+ -- be addressed if we ever need to use Flag0 (it's not currently used).
+
subtype Fchar is Character range '#' .. '9';
F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#)
projects / platform / upstream / gcc.git / commitdiff