2009-07-20 Robert Dewar <dewar@adacore.com>
+ * vms_data.ads: Minor reformatting
+
+ * einfo.ads, einfo.adb (Parent_Subtype): Now allowed on record subtype,
+ applies to base type.
+ (Parent_Subtype): Now allowed on record subtype, applies to base type
+ * exp_ch5.adb (Expand_Assign_Record): Handle Componentwise_Assignment
+ for case of fully repped tagged type.
+ (Make_Tag_Ctrl_Assignment): Set Componentwise_Assignment and avoid
+ tag save/restore for fully repped tagged type case.
+ * exp_util.ads, exp_util.adb (Is_Fully_Repped_Tagged_Type): New function
+ * fe.h (Is_Fully_Repped_Tagged_Type): New function
+ * sem_ch13.adb (Analyze_Recorrd_Representation_Clause): Check for
+ overlap of tagged type components with parent type if parent type is
+ fully repped.
+ * sinfo.ads, sinfo.adb (Componentwise_Assignment): New flag
+
+ * sem_res.adb (Check_No_Direct_Boolean_Operators): Remove handling of
+ comparisons.
+ (Resolve_Comparison_Operators): Remove No_Direct_Boolean_Operators check
+ (Resolve_Equality_Op): Remove No_Direct_Boolean_Operators check
+
+ * gnat_rm.texi: Restriction No_Direct_Boolean_Operators includes only
+ logical operators (AND/OR/XOR), not comparison operators.
+
+ * sprint.ads: Minor reformatting
+
+2009-07-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_intr.adb (Check_Intrinsic_Call): For Import_Value and related
+ intrinsics, check that argument is a string literal, rather than
+ checking for staticness.
+
+2009-07-20 Robert Dewar <dewar@adacore.com>
+
* sem_ch13.adb: Minor reformatting
* einfo.ads: Minor reformatting
function Parent_Subtype (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Record_Type);
- return Node19 (Id);
+ pragma Assert (Is_Record_Type (Id));
+ return Node19 (Base_Type (Id));
end Parent_Subtype;
function Postcondition_Proc (Id : E) return E is
-- used when obtaining the formal kind of a formal parameter (the result
-- is one of E_[In/Out/In_Out]_Parameter)
--- Parent_Subtype (Node19)
--- Present in E_Record_Type. Points to the subtype to use for a field
--- that references the parent record.
+-- Parent_Subtype (Node19) [base type only]
+-- Present in E_Record_Type. Set only for derived tagged types, in which
+-- case it points to the subtype of the parent type. This is the type
+-- that is used as the Etype of the _parent field.
-- Postcondition_Proc (Node8)
-- Present only in procedure entities, saves the entity of the generated
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Corresponding_Concurrent_Type (Node18)
- -- Parent_Subtype (Node19)
+ -- Parent_Subtype (Node19) (base type only)
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
-- N is an assignment of a non-tagged record value. This routine handles
-- the case where the assignment must be made component by component,
-- either because the target is not byte aligned, or there is a change
- -- of representation.
+ -- of representation, or when we have a tagged type with a representation
+ -- clause (this last case is required because holes in the tagged type
+ -- might be filled with components from child types).
procedure Expand_Non_Function_Return (N : Node_Id);
-- Called by Expand_N_Simple_Return_Statement in case we're returning from
-- from a function body this is called by Expand_N_Simple_Return_Statement.
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
- -- Generate the necessary code for controlled and tagged assignment,
- -- that is to say, finalization of the target before, adjustment of
- -- the target after and save and restore of the tag and finalization
- -- pointers which are not 'part of the value' and must not be changed
- -- upon assignment. N is the original Assignment node.
+ -- Generate the necessary code for controlled and tagged assignment, that
+ -- is to say, finalization of the target before, adjustment of the target
+ -- after and save and restore of the tag and finalization pointers which
+ -- are not 'part of the value' and must not be changed upon assignment. N
+ -- is the original Assignment node.
------------------------------
-- Change_Of_Representation --
-- Expand_Assign_Record --
--------------------------
- -- The only processing required is in the change of representation case,
- -- where we must expand the assignment to a series of field by field
- -- assignments.
-
procedure Expand_Assign_Record (N : Node_Id) is
- Lhs : constant Node_Id := Name (N);
- Rhs : Node_Id := Expression (N);
+ Lhs : constant Node_Id := Name (N);
+ Rhs : Node_Id := Expression (N);
+ L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
begin
-- If change of representation, then extract the real right hand side
then
null;
+ -- If we have a tagged type that has a complete record representation
+ -- clause, we must do we must do component-wise assignments, since child
+ -- types may have used gaps for their components, and we might be
+ -- dealing with a view conversion.
+
+ elsif Is_Fully_Repped_Tagged_Type (L_Typ) then
+ null;
+
-- If neither condition met, then nothing special to do, the back end
-- can handle assignment of the entire component as a single entity.
declare
Loc : constant Source_Ptr := Sloc (N);
R_Typ : constant Entity_Id := Base_Type (Etype (Rhs));
- L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
Decl : constant Node_Id := Declaration_Node (R_Typ);
RDef : Node_Id;
F : Entity_Id;
begin
C := First_Entity (Utyp);
-
while Present (C) loop
if Chars (C) = Chars (Comp) then
return C;
end if;
+
Next_Entity (C);
end loop;
Result := Make_Field_Assigns (CI);
if Present (VP) then
-
V := First_Non_Pragma (Variants (VP));
Alts := New_List;
while Present (V) loop
-
DCH := New_List;
DC := First (Discrete_Choices (V));
while Present (DC) loop
-- Set Assignment_OK, so discriminants can be assigned
Set_Assignment_OK (Name (A), True);
+
+ if Componentwise_Assignment (N)
+ and then Nkind (Name (A)) = N_Selected_Component
+ and then Chars (Selector_Name (Name (A))) = Name_uParent
+ then
+ Set_Componentwise_Assignment (A);
+ end if;
+
return A;
end Make_Field_Assign;
Item := First (CI);
Result := New_List;
while Present (Item) loop
- if Nkind (Item) = N_Component_Declaration then
+
+ -- Look for components, but exclude _tag field assignment if
+ -- the special Componentwise_Assignment flag is set.
+
+ if Nkind (Item) = N_Component_Declaration
+ and then not (Is_Tag (Defining_Identifier (Item))
+ and then Componentwise_Assignment (N))
+ then
Append_To
(Result, Make_Field_Assign (Defining_Identifier (Item)));
end if;
-- We know the underlying type is a record, but its current view
-- may be private. We must retrieve the usable record declaration.
- if Nkind (Decl) = N_Private_Type_Declaration
+ if Nkind_In (Decl, N_Private_Type_Declaration,
+ N_Private_Extension_Declaration)
and then Present (Full_View (R_Typ))
then
RDef := Type_Definition (Declaration_Node (Full_View (R_Typ)));
RDef := Type_Definition (Decl);
end if;
+ if Nkind (RDef) = N_Derived_Type_Definition then
+ RDef := Record_Extension_Part (RDef);
+ end if;
+
if Nkind (RDef) = N_Record_Definition
and then Present (Component_List (RDef))
then
-
if Is_Unchecked_Union (R_Typ) then
Insert_Actions (N,
Make_Component_List_Assign (Component_List (RDef), True));
Rewrite (N, Make_Null_Statement (Loc));
end if;
-
end;
end Expand_Assign_Record;
Exp : Node_Id;
begin
+ -- Special case to check right away, if the Componentwise_Assignment
+ -- flag is set, this is a reanalysis from the expansion of the primitive
+ -- assignment procedure for a tagged type, and all we need to do is to
+ -- expand to assignment of components, because otherwise, we would get
+ -- infinite recursion (since this looks like a tagged assignment which
+ -- would normally try to *call* the primitive assignment procedure).
+
+ if Componentwise_Assignment (N) then
+ Expand_Assign_Record (N);
+ return;
+ end if;
+
-- Ada 2005 (AI-327): Handle assignment to priority of protected object
-- Rewrite an assignment to X'Priority into a run-time call
Expand_Ctrl_Actions : constant Boolean := not No_Ctrl_Actions (N);
begin
- -- In the controlled case, we need to make sure that function
- -- calls are evaluated before finalizing the target. In all cases,
- -- it makes the expansion easier if the side-effects are removed
- -- first.
+ -- In the controlled case, we ensure that function calls are
+ -- evaluated before finalizing the target. In all cases, it makes
+ -- the expansion easier if the side-effects are removed first.
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
-- is set True in this case).
or else (Is_Tagged_Type (Typ)
- and then not Is_Value_Type (Etype (Lhs))
- and then Chars (Current_Scope) /= Name_uAssign
- and then Expand_Ctrl_Actions
- and then not Discriminant_Checks_Suppressed (Empty))
+ and then not Is_Value_Type (Etype (Lhs))
+ and then Chars (Current_Scope) /= Name_uAssign
+ and then Expand_Ctrl_Actions
+ and then not Discriminant_Checks_Suppressed (Empty))
then
-- Fetch the primitive op _assign and proper type to call it.
- -- Because of possible conflicts between private and full view
- -- the proper type is fetched directly from the operation
- -- profile.
+ -- Because of possible conflicts between private and full view,
+ -- fetch the proper type directly from the operation profile.
declare
Op : constant Entity_Id :=
Ctrl_Act : constant Boolean := Needs_Finalization (T)
and then not No_Ctrl_Actions (N);
+ Component_Assign : constant Boolean :=
+ Is_Fully_Repped_Tagged_Type (T);
+
Save_Tag : constant Boolean := Is_Tagged_Type (T)
+ and then not Component_Assign
and then not No_Ctrl_Actions (N)
and then Tagged_Type_Expansion;
-- Tags are not saved and restored when VM_Target because VM tags are
begin
Res := New_List;
- -- Finalize the target of the assignment when controlled.
+ -- Finalize the target of the assignment when controlled
+
-- We have two exceptions here:
- -- 1. If we are in an init proc since it is an initialization
- -- more than an assignment
+ -- 1. If we are in an init proc since it is an initialization more
+ -- than an assignment.
-- 2. If the left-hand side is a temporary that was not initialized
-- (or the parent part of a temporary since it is the case in
elsif Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L))
- and then Nkind (Parent (Entity (Expression (L))))
- = N_Object_Declaration
+ and then Nkind (Parent (Entity (Expression (L)))) =
+ N_Object_Declaration
and then No_Initialization (Parent (Entity (Expression (L))))
then
null;
else
Append_List_To (Res,
- Make_Final_Call (
- Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L),
- With_Detach => New_Reference_To (Standard_False, Loc)));
+ Make_Final_Call
+ (Ref => Duplicate_Subexpr_No_Checks (L),
+ Typ => Etype (L),
+ With_Detach => New_Reference_To (Standard_False, Loc)));
end if;
-- Save the Tag in a local variable Tag_Tmp
First_After_Root := Make_Integer_Literal (Loc, 1);
- -- For the case of a controlled object, skip the
- -- Root_Controlled part.
+ -- For controlled object, skip Root_Controlled part
if Is_Controlled (T) then
First_After_Root :=
end if;
-- For the case of a record with controlled components, skip
- -- the Prev and Next components of the record controller.
- -- These components constitute a 'hole' in the middle of the
- -- data to be copied.
+ -- record controller Prev/Next components. These components
+ -- constitute a 'hole' in the middle of the data to be copied.
if Has_Controlled_Component (T) then
Prev_Ref :=
New_Reference_To (Controller_Component (T), Loc)),
Selector_Name => Make_Identifier (Loc, Name_Prev));
- -- Last index before hole: determined by position of
- -- the _Controller.Prev component.
+ -- Last index before hole: determined by position of the
+ -- _Controller.Prev component.
Last_Before_Hole :=
Make_Defining_Identifier (Loc,
end Controlled_Actions;
end if;
+ -- Not controlled case
+
else
- Append_To (Res, Relocate_Node (N));
+ declare
+ Asn : constant Node_Id := Relocate_Node (N);
+
+ begin
+ -- If this is the case of a tagged type with a full rep clause,
+ -- we must expand it into component assignments, so we mark the
+ -- node as unanalyzed, to get it reanalyzed, but flag it has
+ -- requiring component-wise assignment so we don't get infinite
+ -- recursion.
+
+ if Component_Assign then
+ Set_Analyzed (Asn, False);
+ Set_Componentwise_Assignment (Asn, True);
+ end if;
+
+ Append_To (Res, Asn);
+ end;
end if;
-- Restore the tag
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
UT : constant Entity_Id := Underlying_Type (Etype (Comp));
+
begin
-- If no component clause, then everything is fine, since the back end
-- never bit-misaligns by default, even if there is a pragma Packed for
then
return False;
- -- If we know that we have a small (64 bits or less) record
- -- or bit-packed array, then everything is fine, since the
- -- back end can handle these cases correctly.
+ -- If we know that we have a small (64 bits or less) record or small
+ -- bit-packed array, then everything is fine, since the back end can
+ -- handle these cases correctly.
elsif Esize (Comp) <= 64
and then (Is_Record_Type (UT)
return True;
end Is_All_Null_Statements;
+ ---------------------------------
+ -- Is_Fully_Repped_Tagged_Type --
+ ---------------------------------
+
+ function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
+ U : constant Entity_Id := Underlying_Type (T);
+ Comp : Entity_Id;
+
+ begin
+ if No (U) or else not Is_Tagged_Type (U) then
+ return False;
+ elsif Has_Discriminants (U) then
+ return False;
+ elsif not Has_Specified_Layout (U) then
+ return False;
+ end if;
+
+ -- Here we have a tagged type, see if it has any unlayed out fields
+ -- other than a possible tag and parent fields. If so, we return False.
+
+ Comp := First_Component (U);
+ while Present (Comp) loop
+ if not Is_Tag (Comp)
+ and then Chars (Comp) /= Name_uParent
+ and then No (Component_Clause (Comp))
+ then
+ return False;
+ else
+ Next_Component (Comp);
+ end if;
+ end loop;
+
+ -- All components are layed out
+
+ return True;
+ end Is_Fully_Repped_Tagged_Type;
+
----------------------------------
-- Is_Library_Level_Tagged_Type --
----------------------------------
function Is_Renamed_Object (N : Node_Id) return Boolean is
Pnod : constant Node_Id := Parent (N);
Kind : constant Node_Kind := Nkind (Pnod);
-
begin
if Kind = N_Object_Renaming_Declaration then
return True;
-
- elsif Kind = N_Indexed_Component
- or else Kind = N_Selected_Component
- then
+ elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
return Is_Renamed_Object (Pnod);
-
else
return False;
end if;
-- Make_CW_Equivalent_Type --
-----------------------------
- -- Create a record type used as an equivalent of any member
- -- of the class which takes its size from exp.
+ -- Create a record type used as an equivalent of any member of the class
+ -- which takes its size from exp.
-- Generate the following code:
Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
if not Is_Interface (Root_Typ) then
+
-- subtype rg__xx is
-- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
-- False otherwise. True for an empty list. It is an error to call this
-- routine with No_List as the argument.
+ function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean;
+ -- Tests given type T, and returns True if T is a non-discriminated tagged
+ -- type which has a record representation clause that specifies the layout
+ -- of all the components, including recursively components in all parent
+ -- types. We exclude discriminated types for convenience, it is extremely
+ -- unlikely that the special processing associated with the use of this
+ -- routine is useful for the case of a discriminated type, and testing for
+ -- component overlap would be a pain.
+
function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean;
-- Return True if Typ is a library level tagged type. Currently we use
-- this information to build statically allocated dispatch tables.
extern void Get_External_Name (Entity_Id, Boolean);
extern void Get_External_Name_With_Suffix (Entity_Id, Fat_Pointer);
+/* exp_util: */
+
+#define Is_Fully_Repped_Tagged_Type exp_util__is_fully_repped_tagged_type
+
+extern Boolean Is_Fully_Repped_Tagged_Type (Entity_Id);
+
/* lib: */
#define Cunit lib__cunit
@item No_Direct_Boolean_Operators
@findex No_Direct_Boolean_Operators
-This restriction ensures that no logical (and/or/xor) or comparison
-operators are used on operands of type Boolean (or any type derived
+This restriction ensures that no logical (and/or/xor) are used on
+operands of type Boolean (or any type derived
from Boolean). This is intended for use in safety critical programs
where the certification protocol requires the use of short-circuit
-(and then, or else) forms for all composite boolean operations. An
-exception is that an explicit equality test with True or False as the
-right operand is not considered to violate this restriction.
+(and then, or else) forms for all composite boolean operations.
@item No_Dispatching_Calls
@findex No_Dispatching_Calls
Hbit : Uint := Uint_0;
Comp : Entity_Id;
Ocomp : Entity_Id;
+ Pcomp : Entity_Id;
Biased : Boolean;
Max_Bit_So_Far : Uint;
-- are monotonically increasing, then we can skip the circuit for
-- checking for overlap, since no overlap is possible.
+ Tagged_Parent : Entity_Id := Empty;
+ -- This is set in the case of a derived tagged type for which we have
+ -- Is_Fully_Repped_Tagged_Type True (indicating that all components are
+ -- positioned by record representation clauses). In this case we must
+ -- check for overlap between components of this tagged type, and the
+ -- components of its parent. Tagged_Parent will point to this parent
+ -- type. For all other cases Tagged_Parent is left set to Empty.
+
+ Parent_Last_Bit : Uint;
+ -- Relevant only if Tagged_Parent is set, Parent_Last_Bit indicates the
+ -- last bit position for any field in the parent type. We only need to
+ -- check overlap for fields starting below this point.
+
Overlap_Check_Required : Boolean;
-- Used to keep track of whether or not an overlap check is required
end loop;
end if;
+ -- See if we have a fully repped derived tagged type
+
+ declare
+ PS : constant Entity_Id := Parent_Subtype (Rectype);
+
+ begin
+ if Present (PS) and then Is_Fully_Repped_Tagged_Type (PS) then
+ Tagged_Parent := PS;
+
+ -- Find maximum bit of any component of the parent type
+
+ Parent_Last_Bit := UI_From_Int (System_Address_Size - 1);
+ Pcomp := First_Entity (Tagged_Parent);
+ while Present (Pcomp) loop
+ if Ekind (Pcomp) = E_Discriminant
+ or else
+ Ekind (Pcomp) = E_Component
+ then
+ if Component_Bit_Offset (Pcomp) /= No_Uint
+ and then Known_Static_Esize (Pcomp)
+ then
+ Parent_Last_Bit :=
+ UI_Max
+ (Parent_Last_Bit,
+ Component_Bit_Offset (Pcomp) + Esize (Pcomp) - 1);
+ end if;
+
+ Next_Entity (Pcomp);
+ end if;
+ end loop;
+ end if;
+ end;
+
-- All done if no component clauses
CC := First (Component_Clauses (N));
end;
end if;
+ -- Normal case where this is the first component clause we
+ -- have seen for this entity, so set it up properly.
+
else
-- Make reference for field in record rep clause and set
-- appropriate entity field in the field identifier.
then
Error_Msg_NE
("component overlaps tag field of&",
- CC, Rectype);
+ Component_Name (CC), Rectype);
end if;
-- This information is also set in the corresponding
Error_Msg_N ("component size is negative", CC);
end if;
end if;
+
+ -- If OK component size, check parent type overlap if
+ -- this component might overlap a parent field.
+
+ if Present (Tagged_Parent)
+ and Fbit <= Parent_Last_Bit
+ then
+ Pcomp := First_Entity (Tagged_Parent);
+ while Present (Pcomp) loop
+ if (Ekind (Pcomp) = E_Discriminant
+ or else
+ Ekind (Pcomp) = E_Component)
+ and then not Is_Tag (Pcomp)
+ and then Chars (Pcomp) /= Name_uParent
+ then
+ Check_Component_Overlap (Comp, Pcomp);
+ end if;
+
+ Next_Entity (Pcomp);
+ end loop;
+ end if;
end if;
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
Arg1 : constant Node_Id := First_Actual (N);
begin
- -- For Import_xxx calls, argument must be static string
+ -- For Import_xxx calls, argument must be static string. A string
+ -- literal is legal even in Ada83 mode, where such literals are
+ -- not static.
if Cnam = Name_Import_Address
or else
then
null;
- elsif not Is_Static_Expression (Arg1) then
+ elsif Nkind (Arg1) /= N_String_Literal
+ and then not Is_Static_Expression (Arg1)
+ then
Error_Msg_FE
("call to & requires static string argument!", N, Nam);
Why_Not_Static (Arg1);
-- Could be optimized away perhaps?
procedure Check_No_Direct_Boolean_Operators (N : Node_Id);
- -- N is the node for a comparison or logical operator. If the operator
- -- is predefined, and the root type of the operands is Standard.Boolean,
- -- then a check is made for restriction No_Direct_Boolean_Operators.
+ -- N is the node for a logical operator. If the operator is predefined, and
+ -- the root type of the operands is Standard.Boolean, then a check is made
+ -- for restriction No_Direct_Boolean_Operators.
function Is_Definite_Access_Type (E : Entity_Id) return Boolean;
-- Determine whether E is an access type declared by an access
if Scope (Entity (N)) = Standard_Standard
and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean
then
- -- Restriction does not apply to generated code
+ -- Restriction only applies to original source code
- if not Comes_From_Source (N) then
- null;
-
- -- Restriction does not apply for A=False, A=True
-
- elsif Nkind (N) = N_Op_Eq
- and then (Is_Entity_Name (Right_Opnd (N))
- and then (Entity (Right_Opnd (N)) = Standard_True
- or else
- Entity (Right_Opnd (N)) = Standard_False))
- then
- null;
-
- -- Otherwise restriction applies
-
- else
+ if Comes_From_Source (N) then
Check_Restriction (No_Direct_Boolean_Operators, N);
end if;
end if;
T : Entity_Id;
begin
- Check_No_Direct_Boolean_Operators (N);
-
-- If this is an intrinsic operation which is not predefined, use the
-- types of its declared arguments to resolve the possibly overloaded
-- operands. Otherwise the operands are unambiguous and specify the
-- Start of processing for Resolve_Equality_Op
begin
- Check_No_Direct_Boolean_Operators (N);
-
Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
return Node1 (N);
end Component_Name;
+ function Componentwise_Assignment
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ return Flag14 (N);
+ end Componentwise_Assignment;
+
function Condition
(N : Node_Id) return Node_Id is
begin
Set_Node1_With_Parent (N, Val);
end Set_Component_Name;
+ procedure Set_Componentwise_Assignment
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ Set_Flag14 (N, Val);
+ end Set_Componentwise_Assignment;
+
procedure Set_Condition
(N : Node_Id; Val : Node_Id) is
begin
-- Sem_Aggr for the specific conditions under which an aggregate has this
-- flag set. See also the flag Static_Processing_OK.
+ -- Componentwise_Assignment (Flag14-Sem)
+ -- Present in N_Assignment_Statement nodes. Set for a record assignment
+ -- where all that needs doing is to expand it into component-by-component
+ -- assignments. This is used internally for the case of tagged types with
+ -- rep clauses, where we need to avoid recursion (we don't want to try to
+ -- generate a call to the primitive operation, because this is the case
+ -- where we are compiling the primitive operation). Note that when we are
+ -- expanding component assignments in this case, we never assign the _tag
+ -- field, but we recursively assign components of the parent type.
+
-- Condition_Actions (List3-Sem)
-- This field appears in else-if nodes and in the iteration scheme node
-- for while loops. This field is only used during semantic processing to
-- Forwards_OK (Flag5-Sem)
-- Backwards_OK (Flag6-Sem)
-- No_Ctrl_Actions (Flag7-Sem)
+ -- Componentwise_Assignment (Flag14-Sem)
-- Note: if a range check is required, then the Do_Range_Check flag
-- is set in the Expression (right hand side), with the check being
function Component_Name
(N : Node_Id) return Node_Id; -- Node1
+ function Componentwise_Assignment
+ (N : Node_Id) return Boolean; -- Flag14
+
function Condition
(N : Node_Id) return Node_Id; -- Node1
procedure Set_Component_Name
(N : Node_Id; Val : Node_Id); -- Node1
+ procedure Set_Componentwise_Assignment
+ (N : Node_Id; Val : Boolean := True); -- Flag14
+
procedure Set_Condition
(N : Node_Id; Val : Node_Id); -- Node1
pragma Inline (Component_Items);
pragma Inline (Component_List);
pragma Inline (Component_Name);
+ pragma Inline (Componentwise_Assignment);
pragma Inline (Condition);
pragma Inline (Condition_Actions);
pragma Inline (Config_Pragmas);
pragma Inline (Set_Component_Items);
pragma Inline (Set_Component_List);
pragma Inline (Set_Component_Name);
+ pragma Inline (Set_Componentwise_Assignment);
pragma Inline (Set_Condition);
pragma Inline (Set_Condition_Actions);
pragma Inline (Set_Config_Pragmas);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
-- Validate_Unchecked_Conversion validate unchecked_conversion
-- (src-type, target-typ);
- -- Note: the storage_pool parameters for allocators and the free node
- -- are omitted if the Storage_Pool field is Empty, indicating use of
- -- the standard default pool.
+ -- Note: the storage_pool parameters for allocators and the free node are
+ -- omitted if the Storage_Pool field is Empty, indicating use of the
+ -- standard default pool.
-----------------
-- Subprograms --
-- -sz print source from tree for package Standard
procedure Sprint_Comma_List (List : List_Id);
- -- Prints the nodes in a list, with separating commas. If the list
- -- is empty then no output is generated.
+ -- Prints the nodes in a list, with separating commas. If the list is empty
+ -- then no output is generated.
procedure Sprint_Paren_Comma_List (List : List_Id);
- -- Prints the nodes in a list, surrounded by parentheses, and separated
- -- by comas. If the list is empty, then no output is generated. A blank
- -- is output before the initial left parenthesis.
+ -- Prints the nodes in a list, surrounded by parentheses, and separated by
+ -- commas. If the list is empty, then no output is generated. A blank is
+ -- output before the initial left parenthesis.
procedure Sprint_Opt_Paren_Comma_List (List : List_Id);
- -- Same as normal Sprint_Paren_Comma_List procedure, except that
- -- an extra blank is output if List is non-empty, and nothing at all is
- -- printed it the argument is No_List.
+ -- Same as normal Sprint_Paren_Comma_List procedure, except that an extra
+ -- blank is output if List is non-empty, and nothing at all is printed it
+ -- the argument is No_List.
procedure Sprint_Node_List (List : List_Id);
-- Prints the nodes in a list with no separating characters. This is used
-- Like Sprint_Node_List, but prints nothing if List = No_List
procedure Sprint_Indented_List (List : List_Id);
- -- Like Sprint_Line_List, except that the indentation level is
- -- increased before outputting the list of items, and then decremented
- -- (back to its original level) before returning to the caller.
+ -- Like Sprint_Line_List, except that the indentation level is increased
+ -- before outputting the list of items, and then decremented (back to its
+ -- original level) before returning to the caller.
procedure Sprint_Node (Node : Node_Id);
-- Prints a single node. No new lines are output, except as required for
-- blank characters are generated.
procedure Sprint_Opt_Node (Node : Node_Id);
- -- Same as normal Sprint_Node procedure, except that one leading
- -- blank is output before the node if it is non-empty.
+ -- Same as normal Sprint_Node procedure, except that one leading blank is
+ -- output before the node if it is non-empty.
procedure pg (Arg : Union_Id);
pragma Export (Ada, pg);
-- /NONO_LOCAL_HEADER (D)
-- /NO_LOCAL_HEADER
--
- -- Do not put local comment header before body stub for a local progran
- -- unit
+ -- Do not put local comment header before body stub for local program unit.
S_Stub_Output : aliased constant S := "/OUTPUT=@" &
"-o@";
-- OVERWRITE (D) Overwrite the existing tree file. If the current
-- directory already contains the file which, according
-- to the GNAT file naming rules should be considered
- -- as a tree file for the argument source file,
- -- gnatstub will refuse to create the tree file needed
- -- to create a sample body unless this option is chosen.
+ -- as a tree file for the argument source file, gnatstub
+ -- will refuse to create the tree file needed to create
+ -- a sample body unless this option is chosen.
--
-- SAVE Do not remove the tree file (i.e., the snapshot
-- of the compiler internal structures used by gnatstub)
OSDN Git Service
