1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Checks; use Checks;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Einfo.Entities; use Einfo.Entities;
33 with Einfo.Utils; use Einfo.Utils;
34 with Elists; use Elists;
35 with Errout; use Errout;
36 with Exp_Aggr; use Exp_Aggr;
37 with Exp_Ch6; use Exp_Ch6;
38 with Exp_Ch7; use Exp_Ch7;
39 with Exp_Ch11; use Exp_Ch11;
40 with Freeze; use Freeze;
41 with Ghost; use Ghost;
42 with Inline; use Inline;
43 with Itypes; use Itypes;
45 with Nlists; use Nlists;
46 with Nmake; use Nmake;
48 with Restrict; use Restrict;
49 with Rident; use Rident;
51 with Sem_Aux; use Sem_Aux;
52 with Sem_Ch3; use Sem_Ch3;
53 with Sem_Ch6; use Sem_Ch6;
54 with Sem_Ch8; use Sem_Ch8;
55 with Sem_Ch12; use Sem_Ch12;
56 with Sem_Ch13; use Sem_Ch13;
57 with Sem_Disp; use Sem_Disp;
58 with Sem_Elab; use Sem_Elab;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Type; use Sem_Type;
62 with Sem_Util; use Sem_Util;
63 with Sinfo.Utils; use Sinfo.Utils;
64 with Snames; use Snames;
65 with Stand; use Stand;
66 with Stringt; use Stringt;
67 with Tbuild; use Tbuild;
68 with Ttypes; use Ttypes;
69 with Validsw; use Validsw;
72 package body Exp_Util is
74 ---------------------------------------------------------
75 -- Handling of inherited class-wide pre/postconditions --
76 ---------------------------------------------------------
78 -- Following AI12-0113, the expression for a class-wide condition is
79 -- transformed for a subprogram that inherits it, by replacing calls
80 -- to primitive operations of the original controlling type into the
81 -- corresponding overriding operations of the derived type. The following
82 -- hash table manages this mapping, and is expanded on demand whenever
83 -- such inherited expression needs to be constructed.
85 -- The mapping is also used to check whether an inherited operation has
86 -- a condition that depends on overridden operations. For such an
87 -- operation we must create a wrapper that is then treated as a normal
88 -- overriding. In SPARK mode such operations are illegal.
90 -- For a given root type there may be several type extensions with their
91 -- own overriding operations, so at various times a given operation of
92 -- the root will be mapped into different overridings. The root type is
93 -- also mapped into the current type extension to indicate that its
94 -- operations are mapped into the overriding operations of that current
97 -- The contents of the map are as follows:
101 -- Discriminant (Entity_Id) Discriminant (Entity_Id)
102 -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
103 -- Discriminant (Entity_Id) Expression (Node_Id)
104 -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
105 -- Type (Entity_Id) Type (Entity_Id)
107 Type_Map_Size : constant := 511;
109 subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
110 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
112 package Type_Map is new GNAT.HTable.Simple_HTable
113 (Header_Num => Type_Map_Header,
115 Element => Node_Or_Entity_Id,
117 Hash => Type_Map_Hash,
120 -----------------------
121 -- Local Subprograms --
122 -----------------------
124 function Build_Task_Array_Image
128 Dyn : Boolean := False) return Node_Id;
129 -- Build function to generate the image string for a task that is an array
130 -- component, concatenating the images of each index. To avoid storage
131 -- leaks, the string is built with successive slice assignments. The flag
132 -- Dyn indicates whether this is called for the initialization procedure of
133 -- an array of tasks, or for the name of a dynamically created task that is
134 -- assigned to an indexed component.
136 function Build_Task_Image_Function
140 Res : Entity_Id) return Node_Id;
141 -- Common processing for Task_Array_Image and Task_Record_Image. Build
142 -- function body that computes image.
144 procedure Build_Task_Image_Prefix
153 -- Common processing for Task_Array_Image and Task_Record_Image. Create
154 -- local variables and assign prefix of name to result string.
156 function Build_Task_Record_Image
159 Dyn : Boolean := False) return Node_Id;
160 -- Build function to generate the image string for a task that is a record
161 -- component. Concatenate name of variable with that of selector. The flag
162 -- Dyn indicates whether this is called for the initialization procedure of
163 -- record with task components, or for a dynamically created task that is
164 -- assigned to a selected component.
166 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
167 -- Force evaluation of bounds of a slice, which may be given by a range
168 -- or by a subtype indication with or without a constraint.
170 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
171 -- Determine whether pragma Default_Initial_Condition denoted by Prag has
172 -- an assertion expression that should be verified at run time.
174 function Is_Uninitialized_Aggregate
176 T : Entity_Id) return Boolean;
177 -- Determine whether an array aggregate used in an object declaration
178 -- is uninitialized, when the aggregate is declared with a box and
179 -- the component type has no default value. Such an aggregate can be
180 -- optimized away to prevent the copying of uninitialized data, and
181 -- the bounds of the aggregate can be propagated directly to the
182 -- object declaration.
184 function Make_CW_Equivalent_Type
186 E : Node_Id) return Entity_Id;
187 -- T is a class-wide type entity, E is the initial expression node that
188 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
189 -- returns the entity of the Equivalent type and inserts on the fly the
190 -- necessary declaration such as:
192 -- type anon is record
193 -- _parent : Root_Type (T); constrained with E discriminants (if any)
194 -- Extension : String (1 .. expr to match size of E);
197 -- This record is compatible with any object of the class of T thanks to
198 -- the first field and has the same size as E thanks to the second.
200 function Make_Literal_Range
202 Literal_Typ : Entity_Id) return Node_Id;
203 -- Produce a Range node whose bounds are:
204 -- Low_Bound (Literal_Type) ..
205 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
206 -- this is used for expanding declarations like X : String := "sdfgdfg";
208 -- If the index type of the target array is not integer, we generate:
209 -- Low_Bound (Literal_Type) ..
211 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
212 -- + (Length (Literal_Typ) -1))
214 function Make_Non_Empty_Check
216 N : Node_Id) return Node_Id;
217 -- Produce a boolean expression checking that the unidimensional array
218 -- node N is not empty.
220 function New_Class_Wide_Subtype
222 N : Node_Id) return Entity_Id;
223 -- Create an implicit subtype of CW_Typ attached to node N
225 function Requires_Cleanup_Actions
228 Nested_Constructs : Boolean) return Boolean;
229 -- Given a list L, determine whether it contains one of the following:
231 -- 1) controlled objects
232 -- 2) library-level tagged types
234 -- Lib_Level is True when the list comes from a construct at the library
235 -- level, and False otherwise. Nested_Constructs is True when any nested
236 -- packages declared in L must be processed, and False otherwise.
238 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean;
239 -- Return True if the evaluation of the given attribute is considered
240 -- side-effect free, independently of its prefix and expressions.
242 -------------------------------------
243 -- Activate_Atomic_Synchronization --
244 -------------------------------------
246 procedure Activate_Atomic_Synchronization (N : Node_Id) is
250 case Nkind (Parent (N)) is
252 -- Check for cases of appearing in the prefix of a construct where we
253 -- don't need atomic synchronization for this kind of usage.
256 -- Nothing to do if we are the prefix of an attribute, since we
257 -- do not want an atomic sync operation for things like 'Size.
259 N_Attribute_Reference
261 -- The N_Reference node is like an attribute
265 -- Nothing to do for a reference to a component (or components)
266 -- of a composite object. Only reads and updates of the object
267 -- as a whole require atomic synchronization (RM C.6 (15)).
269 | N_Indexed_Component
270 | N_Selected_Component
273 -- For all the above cases, nothing to do if we are the prefix
275 if Prefix (Parent (N)) = N then
283 -- Nothing to do for the identifier in an object renaming declaration,
284 -- the renaming itself does not need atomic synchronization.
286 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
290 -- Go ahead and set the flag
292 Set_Atomic_Sync_Required (N);
294 -- Generate info message if requested
296 if Warn_On_Atomic_Synchronization then
302 | N_Selected_Component
304 Msg_Node := Selector_Name (N);
306 when N_Explicit_Dereference
307 | N_Indexed_Component
312 pragma Assert (False);
316 if Present (Msg_Node) then
318 ("info: atomic synchronization set for &?.n?", Msg_Node);
321 ("info: atomic synchronization set?.n?", N);
324 end Activate_Atomic_Synchronization;
326 ----------------------
327 -- Adjust_Condition --
328 ----------------------
330 procedure Adjust_Condition (N : Node_Id) is
332 function Is_Hardbool_Type (T : Entity_Id) return Boolean;
333 -- Return True iff T is a type annotated with the
334 -- Machine_Attribute pragma "hardbool".
336 ----------------------
337 -- Is_Hardbool_Type --
338 ----------------------
340 function Is_Hardbool_Type (T : Entity_Id) return Boolean is
342 function Find_Hardbool_Pragma
343 (Id : Entity_Id) return Node_Id;
344 -- Return a Rep_Item associated with entity Id that
345 -- corresponds to the Hardbool Machine_Attribute pragma, if
346 -- any, or Empty otherwise.
348 function Pragma_Arg_To_String (Item : Node_Id) return String is
349 (To_String (Strval (Expr_Value_S (Item))));
350 -- Return the pragma argument Item as a String
352 function Hardbool_Pragma_P (Item : Node_Id) return Boolean is
353 (Nkind (Item) = N_Pragma
355 Pragma_Name (Item) = Name_Machine_Attribute
359 (Next (First (Pragma_Argument_Associations (Item)))))
361 -- Return True iff representation Item is a "hardbool"
362 -- Machine_Attribute pragma.
364 --------------------------
365 -- Find_Hardbool_Pragma --
366 --------------------------
368 function Find_Hardbool_Pragma
369 (Id : Entity_Id) return Node_Id
374 if not Has_Gigi_Rep_Item (Id) then
378 Item := First_Rep_Item (Id);
379 while Present (Item) loop
380 if Hardbool_Pragma_P (Item) then
383 Item := Next_Rep_Item (Item);
387 end Find_Hardbool_Pragma;
389 -- Start of processing for Is_Hardbool_Type
392 return Present (Find_Hardbool_Pragma (T));
393 end Is_Hardbool_Type;
395 -- Start of processing for Adjust_Condition
403 Loc : constant Source_Ptr := Sloc (N);
404 T : constant Entity_Id := Etype (N);
407 -- Defend against a call where the argument has no type, or has a
408 -- type that is not Boolean. This can occur because of prior errors.
410 if No (T) or else not Is_Boolean_Type (T) then
414 -- Apply validity checking if needed
416 if Validity_Checks_On
418 (Validity_Check_Tests or else Is_Hardbool_Type (T))
423 -- Immediate return if standard boolean, the most common case,
424 -- where nothing needs to be done.
426 if Base_Type (T) = Standard_Boolean then
430 -- Case of zero/nonzero semantics or nonstandard enumeration
431 -- representation. In each case, we rewrite the node as:
433 -- ityp!(N) /= False'Enum_Rep
435 -- where ityp is an integer type with large enough size to hold any
438 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
443 (Integer_Type_For (Esize (T), Uns => False), N),
445 Make_Attribute_Reference (Loc,
446 Attribute_Name => Name_Enum_Rep,
448 New_Occurrence_Of (First_Literal (T), Loc))));
449 Analyze_And_Resolve (N, Standard_Boolean);
452 Rewrite (N, Convert_To (Standard_Boolean, N));
453 Analyze_And_Resolve (N, Standard_Boolean);
456 end Adjust_Condition;
458 ------------------------
459 -- Adjust_Result_Type --
460 ------------------------
462 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
464 -- Ignore call if current type is not Standard.Boolean
466 if Etype (N) /= Standard_Boolean then
470 -- If result is already of correct type, nothing to do. Note that
471 -- this will get the most common case where everything has a type
472 -- of Standard.Boolean.
474 if Base_Type (T) = Standard_Boolean then
479 KP : constant Node_Kind := Nkind (Parent (N));
482 -- If result is to be used as a Condition in the syntax, no need
483 -- to convert it back, since if it was changed to Standard.Boolean
484 -- using Adjust_Condition, that is just fine for this usage.
486 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
489 -- If result is an operand of another logical operation, no need
490 -- to reset its type, since Standard.Boolean is just fine, and
491 -- such operations always do Adjust_Condition on their operands.
493 elsif KP in N_Op_Boolean
494 or else KP in N_Short_Circuit
495 or else KP = N_Op_Not
496 or else (KP in N_Type_Conversion
497 | N_Unchecked_Type_Conversion
498 and then Is_Boolean_Type (Etype (Parent (N))))
502 -- Otherwise we perform a conversion from the current type, which
503 -- must be Standard.Boolean, to the desired type. Use the base
504 -- type to prevent spurious constraint checks that are extraneous
505 -- to the transformation. The type and its base have the same
506 -- representation, standard or otherwise.
510 Rewrite (N, Convert_To (Base_Type (T), N));
511 Analyze_And_Resolve (N, Base_Type (T));
515 end Adjust_Result_Type;
517 --------------------------
518 -- Append_Freeze_Action --
519 --------------------------
521 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
525 Ensure_Freeze_Node (T);
526 Fnode := Freeze_Node (T);
528 if No (Actions (Fnode)) then
529 Set_Actions (Fnode, New_List (N));
531 Append (N, Actions (Fnode));
533 end Append_Freeze_Action;
535 ---------------------------
536 -- Append_Freeze_Actions --
537 ---------------------------
539 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
547 Ensure_Freeze_Node (T);
548 Fnode := Freeze_Node (T);
550 if No (Actions (Fnode)) then
551 Set_Actions (Fnode, L);
553 Append_List (L, Actions (Fnode));
555 end Append_Freeze_Actions;
557 ----------------------------------------
558 -- Attribute_Constrained_Static_Value --
559 ----------------------------------------
561 function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
563 Ptyp : constant Entity_Id := Etype (Pref);
564 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
566 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
567 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
568 -- view of an aliased object whose subtype is constrained.
570 ---------------------------------
571 -- Is_Constrained_Aliased_View --
572 ---------------------------------
574 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
578 if Is_Entity_Name (Obj) then
581 if Present (Renamed_Object (E)) then
582 return Is_Constrained_Aliased_View (Renamed_Object (E));
584 return Is_Aliased (E) and then Is_Constrained (Etype (E));
588 return Is_Aliased_View (Obj)
590 (Is_Constrained (Etype (Obj))
592 (Nkind (Obj) = N_Explicit_Dereference
594 not Object_Type_Has_Constrained_Partial_View
595 (Typ => Base_Type (Etype (Obj)),
596 Scop => Current_Scope)));
598 end Is_Constrained_Aliased_View;
600 -- Start of processing for Attribute_Constrained_Static_Value
603 -- We are in a case where the attribute is known statically, and
604 -- implicit dereferences have been rewritten.
607 (not (Present (Formal_Ent)
608 and then Ekind (Formal_Ent) /= E_Constant
609 and then Present (Extra_Constrained (Formal_Ent)))
611 not (Is_Access_Type (Etype (Pref))
612 and then (not Is_Entity_Name (Pref)
613 or else Is_Object (Entity (Pref))))
615 not (Nkind (Pref) = N_Identifier
616 and then Ekind (Entity (Pref)) = E_Variable
617 and then Present (Extra_Constrained (Entity (Pref)))));
619 if Is_Entity_Name (Pref) then
621 Ent : constant Entity_Id := Entity (Pref);
625 -- (RM J.4) obsolescent cases
627 if Is_Type (Ent) then
631 if Is_Private_Type (Ent) then
632 Res := not Has_Discriminants (Ent)
633 or else Is_Constrained (Ent);
635 -- It not a private type, must be a generic actual type
636 -- that corresponded to a private type. We know that this
637 -- correspondence holds, since otherwise the reference
638 -- within the generic template would have been illegal.
641 if Is_Composite_Type (Underlying_Type (Ent)) then
642 Res := Is_Constrained (Ent);
650 -- If the prefix is not a variable or is aliased, then
651 -- definitely true; if it's a formal parameter without an
652 -- associated extra formal, then treat it as constrained.
654 -- Ada 2005 (AI-363): An aliased prefix must be known to be
655 -- constrained in order to set the attribute to True.
657 if not Is_Variable (Pref)
658 or else Present (Formal_Ent)
659 or else (Ada_Version < Ada_2005
660 and then Is_Aliased_View (Pref))
661 or else (Ada_Version >= Ada_2005
662 and then Is_Constrained_Aliased_View (Pref))
666 -- Variable case, look at type to see if it is constrained.
667 -- Note that the one case where this is not accurate (the
668 -- procedure formal case), has been handled above.
670 -- We use the Underlying_Type here (and below) in case the
671 -- type is private without discriminants, but the full type
672 -- has discriminants. This case is illegal, but we generate
673 -- it internally for passing to the Extra_Constrained
677 -- In Ada 2012, test for case of a limited tagged type,
678 -- in which case the attribute is always required to
679 -- return True. The underlying type is tested, to make
680 -- sure we also return True for cases where there is an
681 -- unconstrained object with an untagged limited partial
682 -- view which has defaulted discriminants (such objects
683 -- always produce a False in earlier versions of
684 -- Ada). (Ada 2012: AI05-0214)
687 Is_Constrained (Underlying_Type (Etype (Ent)))
689 (Ada_Version >= Ada_2012
690 and then Is_Tagged_Type (Underlying_Type (Ptyp))
691 and then Is_Limited_Type (Ptyp));
698 -- Prefix is not an entity name. These are also cases where we can
699 -- always tell at compile time by looking at the form and type of the
700 -- prefix. If an explicit dereference of an object with constrained
701 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
702 -- underlying type is a limited tagged type, then Constrained is
703 -- required to always return True (Ada 2012: AI05-0214).
706 return not Is_Variable (Pref)
708 (Nkind (Pref) = N_Explicit_Dereference
710 not Object_Type_Has_Constrained_Partial_View
711 (Typ => Base_Type (Ptyp),
712 Scop => Current_Scope))
713 or else Is_Constrained (Underlying_Type (Ptyp))
714 or else (Ada_Version >= Ada_2012
715 and then Is_Tagged_Type (Underlying_Type (Ptyp))
716 and then Is_Limited_Type (Ptyp));
718 end Attribute_Constrained_Static_Value;
720 ------------------------------------
721 -- Build_Allocate_Deallocate_Proc --
722 ------------------------------------
724 procedure Build_Allocate_Deallocate_Proc
726 Is_Allocate : Boolean)
728 function Find_Object (E : Node_Id) return Node_Id;
729 -- Given an arbitrary expression of an allocator, try to find an object
730 -- reference in it, otherwise return the original expression.
732 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
733 -- Determine whether subprogram Subp denotes a custom allocate or
740 function Find_Object (E : Node_Id) return Node_Id is
744 pragma Assert (Is_Allocate);
748 if Nkind (Expr) = N_Explicit_Dereference then
749 Expr := Prefix (Expr);
751 elsif Nkind (Expr) = N_Qualified_Expression then
752 Expr := Expression (Expr);
754 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
756 -- When interface class-wide types are involved in allocation,
757 -- the expander introduces several levels of address arithmetic
758 -- to perform dispatch table displacement. In this scenario the
759 -- object appears as:
761 -- Tag_Ptr (Base_Address (<object>'Address))
763 -- Detect this case and utilize the whole expression as the
764 -- "object" since it now points to the proper dispatch table.
766 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
769 -- Continue to strip the object
772 Expr := Expression (Expr);
783 ---------------------------------
784 -- Is_Allocate_Deallocate_Proc --
785 ---------------------------------
787 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
789 -- Look for a subprogram body with only one statement which is a
790 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
792 if Ekind (Subp) = E_Procedure
793 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
796 HSS : constant Node_Id :=
797 Handled_Statement_Sequence (Parent (Parent (Subp)));
801 if Present (Statements (HSS))
802 and then Nkind (First (Statements (HSS))) =
803 N_Procedure_Call_Statement
805 Proc := Entity (Name (First (Statements (HSS))));
808 Is_RTE (Proc, RE_Allocate_Any_Controlled)
809 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
815 end Is_Allocate_Deallocate_Proc;
819 Desig_Typ : Entity_Id;
823 Proc_To_Call : Node_Id := Empty;
825 Use_Secondary_Stack_Pool : Boolean;
827 -- Start of processing for Build_Allocate_Deallocate_Proc
830 -- Obtain the attributes of the allocation / deallocation
832 if Nkind (N) = N_Free_Statement then
833 Expr := Expression (N);
834 Ptr_Typ := Base_Type (Etype (Expr));
835 Proc_To_Call := Procedure_To_Call (N);
838 if Nkind (N) = N_Object_Declaration then
839 Expr := Expression (N);
844 -- In certain cases an allocator with a qualified expression may
845 -- be relocated and used as the initialization expression of a
849 -- Obj : Ptr_Typ := new Desig_Typ'(...);
852 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
853 -- Obj : Ptr_Typ := Tmp;
855 -- Since the allocator is always marked as analyzed to avoid infinite
856 -- expansion, it will never be processed by this routine given that
857 -- the designated type needs finalization actions. Detect this case
858 -- and complete the expansion of the allocator.
860 if Nkind (Expr) = N_Identifier
861 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
862 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
864 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
868 -- The allocator may have been rewritten into something else in which
869 -- case the expansion performed by this routine does not apply.
871 if Nkind (Expr) /= N_Allocator then
875 Ptr_Typ := Base_Type (Etype (Expr));
876 Proc_To_Call := Procedure_To_Call (Expr);
879 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
880 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
882 -- Handle concurrent types
884 if Is_Concurrent_Type (Desig_Typ)
885 and then Present (Corresponding_Record_Type (Desig_Typ))
887 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
890 Use_Secondary_Stack_Pool :=
891 Is_RTE (Pool_Id, RE_SS_Pool)
892 or else (Nkind (Expr) = N_Allocator
893 and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool));
895 -- Do not process allocations / deallocations without a pool
900 -- Do not process allocations from the return stack
902 elsif Is_RTE (Pool_Id, RE_RS_Pool) then
905 -- Do not process allocations on / deallocations from the secondary
906 -- stack, except for access types used to implement indirect temps.
908 elsif Use_Secondary_Stack_Pool
909 and then not Old_Attr_Util.Indirect_Temps
910 .Is_Access_Type_For_Indirect_Temp (Ptr_Typ)
914 -- Optimize the case where we are using the default Global_Pool_Object,
915 -- and we don't need the heavy finalization machinery.
917 elsif Is_RTE (Pool_Id, RE_Global_Pool_Object)
918 and then not Needs_Finalization (Desig_Typ)
922 -- Do not replicate the machinery if the allocator / free has already
923 -- been expanded and has a custom Allocate / Deallocate.
925 elsif Present (Proc_To_Call)
926 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
931 -- Finalization actions are required when the object to be allocated or
932 -- deallocated needs these actions and the associated access type is not
933 -- subject to pragma No_Heap_Finalization.
936 Needs_Finalization (Desig_Typ)
937 and then not No_Heap_Finalization (Ptr_Typ);
941 -- Do nothing if the access type may never allocate / deallocate
944 if No_Pool_Assigned (Ptr_Typ) then
948 -- The allocation / deallocation of a controlled object must be
949 -- chained on / detached from a finalization master.
951 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
953 -- The only other kind of allocation / deallocation supported by this
954 -- routine is on / from a subpool.
956 elsif Nkind (Expr) = N_Allocator
957 and then No (Subpool_Handle_Name (Expr))
963 Loc : constant Source_Ptr := Sloc (N);
964 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
965 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
966 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
967 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
970 Alloc_Nod : Node_Id := Empty;
971 Alloc_Expr : Node_Id := Empty;
972 Fin_Addr_Id : Entity_Id;
973 Fin_Mas_Act : Node_Id;
974 Fin_Mas_Id : Entity_Id;
975 Proc_To_Call : Entity_Id;
976 Subpool : Node_Id := Empty;
979 -- When we are building an allocator procedure, extract the allocator
980 -- node for later processing and calculation of alignment.
984 if Nkind (Expr) = N_Allocator then
987 -- When Expr is an object declaration we have to examine its
990 elsif Nkind (Expr) = N_Object_Declaration
991 and then Nkind (Expression (Expr)) = N_Allocator
993 Alloc_Nod := Expression (Expr);
995 -- Otherwise, we raise an error because we should have found one
1001 -- Extract the qualified expression if there is one from the
1004 if Nkind (Expression (Alloc_Nod)) = N_Qualified_Expression then
1005 Alloc_Expr := Expression (Alloc_Nod);
1009 -- Step 1: Construct all the actuals for the call to library routine
1010 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
1014 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
1020 if Nkind (Expr) = N_Allocator then
1021 Subpool := Subpool_Handle_Name (Expr);
1024 -- If a subpool is present it can be an arbitrary name, so make
1025 -- the actual by copying the tree.
1027 if Present (Subpool) then
1028 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
1030 Append_To (Actuals, Make_Null (Loc));
1033 -- c) Finalization master
1036 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
1037 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
1039 -- Handle the case where the master is actually a pointer to a
1040 -- master. This case arises in build-in-place functions.
1042 if Is_Access_Type (Etype (Fin_Mas_Id)) then
1043 Append_To (Actuals, Fin_Mas_Act);
1046 Make_Attribute_Reference (Loc,
1047 Prefix => Fin_Mas_Act,
1048 Attribute_Name => Name_Unrestricted_Access));
1051 Append_To (Actuals, Make_Null (Loc));
1054 -- d) Finalize_Address
1056 -- Primitive Finalize_Address is never generated in CodePeer mode
1057 -- since it contains an Unchecked_Conversion.
1059 if Needs_Fin and then not CodePeer_Mode then
1060 Fin_Addr_Id := Finalize_Address (Desig_Typ);
1061 pragma Assert (Present (Fin_Addr_Id));
1064 Make_Attribute_Reference (Loc,
1065 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
1066 Attribute_Name => Name_Unrestricted_Access));
1068 Append_To (Actuals, Make_Null (Loc));
1076 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
1077 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
1079 -- Class-wide allocations without expressions and non-class-wide
1080 -- allocations can be performed without getting the alignment from
1081 -- the type's Type Specific Record.
1083 if ((Is_Allocate and then No (Alloc_Expr))
1085 not Is_Class_Wide_Type (Desig_Typ))
1086 and then not Use_Secondary_Stack_Pool
1088 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
1090 -- For operations on class-wide types we obtain the value of
1091 -- alignment from the Type Specific Record of the relevant object.
1092 -- This is needed because the frontend expansion of class-wide types
1093 -- into equivalent types confuses the back end.
1097 -- Obj.all'Alignment
1099 -- Alloc_Expr'Alignment
1101 -- ... because 'Alignment applied to class-wide types is expanded
1102 -- into the code that reads the value of alignment from the TSD
1103 -- (see Expand_N_Attribute_Reference)
1105 -- In the Use_Secondary_Stack_Pool case, Alig_Id is not
1106 -- passed in and therefore must not be referenced.
1109 Unchecked_Convert_To (RTE (RE_Storage_Offset),
1110 Make_Attribute_Reference (Loc,
1112 (if No (Alloc_Expr) then
1113 Make_Explicit_Dereference (Loc, Relocate_Node (Expr))
1115 Relocate_Node (Expression (Alloc_Expr))),
1116 Attribute_Name => Name_Alignment)));
1122 Is_Controlled : declare
1123 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
1124 Flag_Expr : Node_Id;
1131 Temp := Find_Object (Expression (Expr));
1136 -- Processing for allocations where the expression is a subtype
1140 and then Is_Entity_Name (Temp)
1141 and then Is_Type (Entity (Temp))
1146 (Needs_Finalization (Entity (Temp))), Loc);
1148 -- The allocation / deallocation of a class-wide object relies
1149 -- on a runtime check to determine whether the object is truly
1150 -- controlled or not. Depending on this check, the finalization
1151 -- machinery will request or reclaim extra storage reserved for
1154 elsif Is_Class_Wide_Type (Desig_Typ) then
1156 -- Detect a special case where interface class-wide types
1157 -- are involved as the object appears as:
1159 -- Tag_Ptr (Base_Address (<object>'Address))
1161 -- The expression already yields the proper tag, generate:
1165 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
1167 Make_Explicit_Dereference (Loc,
1168 Prefix => Relocate_Node (Temp));
1170 -- In the default case, obtain the tag of the object about
1171 -- to be allocated / deallocated. Generate:
1175 -- If the object is an unchecked conversion (typically to
1176 -- an access to class-wide type), we must preserve the
1177 -- conversion to ensure that the object is seen as tagged
1178 -- in the code that follows.
1183 if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion
1185 Pref := Parent (Pref);
1189 Make_Attribute_Reference (Loc,
1190 Prefix => Relocate_Node (Pref),
1191 Attribute_Name => Name_Tag);
1195 -- Needs_Finalization (<Param>)
1198 Make_Function_Call (Loc,
1200 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
1201 Parameter_Associations => New_List (Param));
1203 -- Processing for generic actuals
1205 elsif Is_Generic_Actual_Type (Desig_Typ) then
1207 New_Occurrence_Of (Boolean_Literals
1208 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
1210 -- The object does not require any specialized checks, it is
1211 -- known to be controlled.
1214 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
1217 -- Create the temporary which represents the finalization state
1218 -- of the expression. Generate:
1220 -- F : constant Boolean := <Flag_Expr>;
1223 Make_Object_Declaration (Loc,
1224 Defining_Identifier => Flag_Id,
1225 Constant_Present => True,
1226 Object_Definition =>
1227 New_Occurrence_Of (Standard_Boolean, Loc),
1228 Expression => Flag_Expr));
1230 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
1233 -- The object is not controlled
1236 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
1243 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
1246 -- Step 2: Build a wrapper Allocate / Deallocate which internally
1247 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
1249 -- Select the proper routine to call
1252 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
1254 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
1257 -- Create a custom Allocate / Deallocate routine which has identical
1258 -- profile to that of System.Storage_Pools.
1261 -- P : Root_Storage_Pool
1262 function Pool_Param return Node_Id is (
1263 Make_Parameter_Specification (Loc,
1264 Defining_Identifier => Make_Temporary (Loc, 'P'),
1266 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)));
1268 -- A : [out] Address
1269 function Address_Param return Node_Id is (
1270 Make_Parameter_Specification (Loc,
1271 Defining_Identifier => Addr_Id,
1272 Out_Present => Is_Allocate,
1274 New_Occurrence_Of (RTE (RE_Address), Loc)));
1276 -- S : Storage_Count
1277 function Size_Param return Node_Id is (
1278 Make_Parameter_Specification (Loc,
1279 Defining_Identifier => Size_Id,
1281 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
1283 -- L : Storage_Count
1284 function Alignment_Param return Node_Id is (
1285 Make_Parameter_Specification (Loc,
1286 Defining_Identifier => Alig_Id,
1288 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
1290 Formal_Params : List_Id;
1292 if Use_Secondary_Stack_Pool then
1293 -- Gigi expects a different profile in the Secondary_Stack_Pool
1294 -- case. There must be no uses of the two missing formals
1295 -- (i.e., Pool_Param and Alignment_Param) in this case.
1296 Formal_Params := New_List (Address_Param, Size_Param);
1298 Formal_Params := New_List (
1299 Pool_Param, Address_Param, Size_Param, Alignment_Param);
1303 Make_Subprogram_Body (Loc,
1306 Make_Procedure_Specification (Loc,
1307 Defining_Unit_Name => Proc_Id,
1308 Parameter_Specifications => Formal_Params),
1310 Declarations => No_List,
1312 Handled_Statement_Sequence =>
1313 Make_Handled_Sequence_Of_Statements (Loc,
1314 Statements => New_List (
1315 Make_Procedure_Call_Statement (Loc,
1317 New_Occurrence_Of (Proc_To_Call, Loc),
1318 Parameter_Associations => Actuals)))),
1319 Suppress => All_Checks);
1322 -- The newly generated Allocate / Deallocate becomes the default
1323 -- procedure to call when the back end processes the allocation /
1327 Set_Procedure_To_Call (Expr, Proc_Id);
1329 Set_Procedure_To_Call (N, Proc_Id);
1332 end Build_Allocate_Deallocate_Proc;
1334 -------------------------------
1335 -- Build_Abort_Undefer_Block --
1336 -------------------------------
1338 function Build_Abort_Undefer_Block
1341 Context : Node_Id) return Node_Id
1343 Exceptions_OK : constant Boolean :=
1344 not Restriction_Active (No_Exception_Propagation);
1352 -- The block should be generated only when undeferring abort in the
1353 -- context of a potential exception.
1355 pragma Assert (Abort_Allowed and Exceptions_OK);
1361 -- Abort_Undefer_Direct;
1364 AUD := RTE (RE_Abort_Undefer_Direct);
1367 Make_Handled_Sequence_Of_Statements (Loc,
1368 Statements => Stmts,
1369 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1372 Make_Block_Statement (Loc,
1373 Handled_Statement_Sequence => HSS);
1374 Set_Is_Abort_Block (Blk);
1376 Add_Block_Identifier (Blk, Blk_Id);
1377 Expand_At_End_Handler (HSS, Blk_Id);
1379 -- Present the Abort_Undefer_Direct function to the back end to inline
1380 -- the call to the routine.
1382 Add_Inlined_Body (AUD, Context);
1385 end Build_Abort_Undefer_Block;
1387 ---------------------------------
1388 -- Build_Class_Wide_Expression --
1389 ---------------------------------
1391 procedure Build_Class_Wide_Expression
1392 (Pragma_Or_Expr : Node_Id;
1394 Par_Subp : Entity_Id;
1395 Adjust_Sloc : Boolean)
1397 function Replace_Entity (N : Node_Id) return Traverse_Result;
1398 -- Replace reference to formal of inherited operation or to primitive
1399 -- operation of root type, with corresponding entity for derived type,
1400 -- when constructing the class-wide condition of an overriding
1403 --------------------
1404 -- Replace_Entity --
1405 --------------------
1407 function Replace_Entity (N : Node_Id) return Traverse_Result is
1412 Adjust_Inherited_Pragma_Sloc (N);
1415 if Nkind (N) in N_Identifier | N_Expanded_Name | N_Operator_Symbol
1416 and then Present (Entity (N))
1418 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
1420 (Nkind (Parent (N)) /= N_Attribute_Reference
1421 or else Attribute_Name (Parent (N)) /= Name_Class)
1423 -- The replacement does not apply to dispatching calls within the
1424 -- condition, but only to calls whose static tag is that of the
1427 if Is_Subprogram (Entity (N))
1428 and then Nkind (Parent (N)) = N_Function_Call
1429 and then Present (Controlling_Argument (Parent (N)))
1434 -- Determine whether entity has a renaming
1436 New_E := Type_Map.Get (Entity (N));
1438 if Present (New_E) then
1439 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
1442 -- Update type of function call node, which should be the same as
1443 -- the function's return type.
1445 if Is_Subprogram (Entity (N))
1446 and then Nkind (Parent (N)) = N_Function_Call
1448 Set_Etype (Parent (N), Etype (Entity (N)));
1451 -- The whole expression will be reanalyzed
1453 elsif Nkind (N) in N_Has_Etype then
1454 Set_Analyzed (N, False);
1460 procedure Replace_Condition_Entities is
1461 new Traverse_Proc (Replace_Entity);
1465 Par_Typ : constant Entity_Id := Find_Dispatching_Type (Par_Subp);
1466 Subp_Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
1468 -- Start of processing for Build_Class_Wide_Expression
1471 pragma Assert (Par_Typ /= Subp_Typ);
1473 Update_Primitives_Mapping (Par_Subp, Subp);
1474 Map_Formals (Par_Subp, Subp);
1475 Replace_Condition_Entities (Pragma_Or_Expr);
1476 end Build_Class_Wide_Expression;
1478 --------------------
1479 -- Build_DIC_Call --
1480 --------------------
1482 function Build_DIC_Call
1485 Typ : Entity_Id) return Node_Id
1487 Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
1488 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1491 -- The DIC procedure has a null body if assertions are disabled or
1492 -- Assertion_Policy Ignore is in effect. In that case, it would be
1493 -- nice to generate a null statement instead of a call to the DIC
1494 -- procedure, but doing that seems to interfere with the determination
1495 -- of ECRs (early call regions) in SPARK. ???
1498 Make_Procedure_Call_Statement (Loc,
1499 Name => New_Occurrence_Of (Proc_Id, Loc),
1500 Parameter_Associations => New_List (
1501 Unchecked_Convert_To (Formal_Typ, Obj_Name)));
1504 ------------------------------
1505 -- Build_DIC_Procedure_Body --
1506 ------------------------------
1508 -- WARNING: This routine manages Ghost regions. Return statements must be
1509 -- replaced by gotos which jump to the end of the routine and restore the
1512 procedure Build_DIC_Procedure_Body
1514 Partial_DIC : Boolean := False)
1516 Pragmas_Seen : Elist_Id := No_Elist;
1517 -- This list contains all DIC pragmas processed so far. The list is used
1518 -- to avoid redundant Default_Initial_Condition checks.
1520 procedure Add_DIC_Check
1521 (DIC_Prag : Node_Id;
1523 Stmts : in out List_Id);
1524 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1525 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1526 -- is added to list Stmts.
1528 procedure Add_Inherited_DIC
1529 (DIC_Prag : Node_Id;
1530 Par_Typ : Entity_Id;
1531 Deriv_Typ : Entity_Id;
1532 Stmts : in out List_Id);
1533 -- Add a runtime check to verify the assertion expression of inherited
1534 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1535 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1536 -- pragma. All generated code is added to list Stmts.
1538 procedure Add_Inherited_Tagged_DIC
1539 (DIC_Prag : Node_Id;
1541 Stmts : in out List_Id);
1542 -- Add a runtime check to verify assertion expression DIC_Expr of
1543 -- inherited pragma DIC_Prag. This routine applies class-wide pre-
1544 -- and postcondition-like runtime semantics to the check. Expr is
1545 -- the assertion expression after substitution has been performed
1546 -- (via Replace_References). All generated code is added to list Stmts.
1548 procedure Add_Inherited_DICs
1550 Priv_Typ : Entity_Id;
1551 Full_Typ : Entity_Id;
1553 Checks : in out List_Id);
1554 -- Generate a DIC check for each inherited Default_Initial_Condition
1555 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
1556 -- the partial and full view of the parent type. Obj_Id denotes the
1557 -- entity of the _object formal parameter of the DIC procedure. All
1558 -- created checks are added to list Checks.
1560 procedure Add_Own_DIC
1561 (DIC_Prag : Node_Id;
1562 DIC_Typ : Entity_Id;
1564 Stmts : in out List_Id);
1565 -- Add a runtime check to verify the assertion expression of pragma
1566 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. Obj_Id is the
1567 -- object to substitute in the assertion expression for any references
1568 -- to the current instance of the type All generated code is added to
1571 procedure Add_Parent_DICs
1574 Checks : in out List_Id);
1575 -- Generate a Default_Initial_Condition check for each inherited DIC
1576 -- aspect coming from all parent types of type T. Obj_Id denotes the
1577 -- entity of the _object formal parameter of the DIC procedure. All
1578 -- created checks are added to list Checks.
1584 procedure Add_DIC_Check
1585 (DIC_Prag : Node_Id;
1587 Stmts : in out List_Id)
1589 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1590 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1593 -- The DIC pragma is ignored, nothing left to do
1595 if Is_Ignored (DIC_Prag) then
1598 -- Otherwise the DIC expression must be checked at run time.
1601 -- pragma Check (<Nam>, <DIC_Expr>);
1604 Append_New_To (Stmts,
1606 Pragma_Identifier =>
1607 Make_Identifier (Loc, Name_Check),
1609 Pragma_Argument_Associations => New_List (
1610 Make_Pragma_Argument_Association (Loc,
1611 Expression => Make_Identifier (Loc, Nam)),
1613 Make_Pragma_Argument_Association (Loc,
1614 Expression => DIC_Expr))));
1617 -- Add the pragma to the list of processed pragmas
1619 Append_New_Elmt (DIC_Prag, Pragmas_Seen);
1622 -----------------------
1623 -- Add_Inherited_DIC --
1624 -----------------------
1626 procedure Add_Inherited_DIC
1627 (DIC_Prag : Node_Id;
1628 Par_Typ : Entity_Id;
1629 Deriv_Typ : Entity_Id;
1630 Stmts : in out List_Id)
1632 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1633 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1634 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1635 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1636 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1639 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1641 -- Verify the inherited DIC assertion expression by calling the DIC
1642 -- procedure of the parent type.
1645 -- <Par_Typ>DIC (Par_Typ (_object));
1647 Append_New_To (Stmts,
1648 Make_Procedure_Call_Statement (Loc,
1649 Name => New_Occurrence_Of (Par_Proc, Loc),
1650 Parameter_Associations => New_List (
1652 (Typ => Etype (Par_Obj),
1653 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1654 end Add_Inherited_DIC;
1656 ------------------------------
1657 -- Add_Inherited_Tagged_DIC --
1658 ------------------------------
1660 procedure Add_Inherited_Tagged_DIC
1661 (DIC_Prag : Node_Id;
1663 Stmts : in out List_Id)
1666 -- Once the DIC assertion expression is fully processed, add a check
1667 -- to the statements of the DIC procedure.
1670 (DIC_Prag => DIC_Prag,
1673 end Add_Inherited_Tagged_DIC;
1675 ------------------------
1676 -- Add_Inherited_DICs --
1677 ------------------------
1679 procedure Add_Inherited_DICs
1681 Priv_Typ : Entity_Id;
1682 Full_Typ : Entity_Id;
1684 Checks : in out List_Id)
1686 Deriv_Typ : Entity_Id;
1689 Prag_Expr : Node_Id;
1690 Prag_Expr_Arg : Node_Id;
1692 Prag_Typ_Arg : Node_Id;
1694 Par_Proc : Entity_Id;
1695 -- The "partial" invariant procedure of Par_Typ
1697 Par_Typ : Entity_Id;
1698 -- The suitable view of the parent type used in the substitution of
1702 if not Present (Priv_Typ) and then not Present (Full_Typ) then
1706 -- When the type inheriting the class-wide invariant is a concurrent
1707 -- type, use the corresponding record type because it contains all
1708 -- primitive operations of the concurrent type and allows for proper
1711 if Is_Concurrent_Type (T) then
1712 Deriv_Typ := Corresponding_Record_Type (T);
1717 pragma Assert (Present (Deriv_Typ));
1719 -- Determine which rep item chain to use. Precedence is given to that
1720 -- of the parent type's partial view since it usually carries all the
1721 -- class-wide invariants.
1723 if Present (Priv_Typ) then
1724 Prag := First_Rep_Item (Priv_Typ);
1726 Prag := First_Rep_Item (Full_Typ);
1729 while Present (Prag) loop
1730 if Nkind (Prag) = N_Pragma
1731 and then Pragma_Name (Prag) = Name_Default_Initial_Condition
1733 -- Nothing to do if the pragma was already processed
1735 if Contains (Pragmas_Seen, Prag) then
1739 -- Extract arguments of the Default_Initial_Condition pragma
1741 Prag_Expr_Arg := First (Pragma_Argument_Associations (Prag));
1742 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
1744 -- Pick up the implicit second argument of the pragma, which
1745 -- indicates the type that the pragma applies to.
1747 Prag_Typ_Arg := Next (Prag_Expr_Arg);
1748 if Present (Prag_Typ_Arg) then
1749 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
1754 -- The pragma applies to the partial view of the parent type
1756 if Present (Priv_Typ)
1757 and then Present (Prag_Typ)
1758 and then Entity (Prag_Typ) = Priv_Typ
1760 Par_Typ := Priv_Typ;
1762 -- The pragma applies to the full view of the parent type
1764 elsif Present (Full_Typ)
1765 and then Present (Prag_Typ)
1766 and then Entity (Prag_Typ) = Full_Typ
1768 Par_Typ := Full_Typ;
1770 -- Otherwise the pragma does not belong to the parent type and
1771 -- should not be considered.
1777 -- Substitute references in the DIC expression that are related
1778 -- to the partial type with corresponding references related to
1779 -- the derived type (call to Replace_References below).
1781 Expr := New_Copy_Tree (Prag_Expr);
1783 Par_Proc := Partial_DIC_Procedure (Par_Typ);
1785 -- If there's not a partial DIC procedure (such as when a
1786 -- full type doesn't have its own DIC, but is inherited from
1787 -- a type with DIC), get the full DIC procedure.
1789 if not Present (Par_Proc) then
1790 Par_Proc := DIC_Procedure (Par_Typ);
1796 Deriv_Typ => Deriv_Typ,
1797 Par_Obj => First_Formal (Par_Proc),
1798 Deriv_Obj => Obj_Id);
1800 -- Why are there different actions depending on whether T is
1801 -- tagged? Can these be unified? ???
1803 if Is_Tagged_Type (T) then
1804 Add_Inherited_Tagged_DIC
1813 Deriv_Typ => Deriv_Typ,
1817 -- Leave as soon as we get a DIC pragma, since we'll visit
1818 -- the pragmas of the parents, so will get to any "inherited"
1819 -- pragmas that way.
1824 Next_Rep_Item (Prag);
1826 end Add_Inherited_DICs;
1832 procedure Add_Own_DIC
1833 (DIC_Prag : Node_Id;
1834 DIC_Typ : Entity_Id;
1836 Stmts : in out List_Id)
1838 DIC_Args : constant List_Id :=
1839 Pragma_Argument_Associations (DIC_Prag);
1840 DIC_Arg : constant Node_Id := First (DIC_Args);
1841 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1842 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1846 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1850 -- Start of processing for Add_Own_DIC
1853 pragma Assert (Present (DIC_Expr));
1854 Expr := New_Copy_Tree (DIC_Expr);
1856 -- Perform the following substitution:
1858 -- * Replace the current instance of DIC_Typ with a reference to
1859 -- the _object formal parameter of the DIC procedure.
1861 Replace_Type_References
1866 -- Preanalyze the DIC expression to detect errors and at the same
1867 -- time capture the visibility of the proper package part.
1869 Set_Parent (Expr, Typ_Decl);
1870 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1872 -- Save a copy of the expression with all replacements and analysis
1873 -- already taken place in case a derived type inherits the pragma.
1874 -- The copy will be used as the foundation of the derived type's own
1875 -- version of the DIC assertion expression.
1877 if Is_Tagged_Type (DIC_Typ) then
1878 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1881 -- If the pragma comes from an aspect specification, replace the
1882 -- saved expression because all type references must be substituted
1883 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1886 if Present (DIC_Asp) then
1887 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1890 -- Once the DIC assertion expression is fully processed, add a check
1891 -- to the statements of the DIC procedure (unless the type is an
1892 -- abstract type, in which case we don't want the possibility of
1893 -- generating a call to an abstract function of the type; such DIC
1894 -- procedures can never be called in any case, so not generating the
1895 -- check at all is OK).
1897 if not Is_Abstract_Type (DIC_Typ) or else GNATprove_Mode then
1899 (DIC_Prag => DIC_Prag,
1905 ---------------------
1906 -- Add_Parent_DICs --
1907 ---------------------
1909 procedure Add_Parent_DICs
1912 Checks : in out List_Id)
1914 Dummy_1 : Entity_Id;
1915 Dummy_2 : Entity_Id;
1917 Curr_Typ : Entity_Id;
1918 -- The entity of the current type being examined
1920 Full_Typ : Entity_Id;
1921 -- The full view of Par_Typ
1923 Par_Typ : Entity_Id;
1924 -- The entity of the parent type
1926 Priv_Typ : Entity_Id;
1927 -- The partial view of Par_Typ
1930 Par_Prim : Entity_Id;
1934 -- Map the overridden primitive to the overriding one; required by
1935 -- Replace_References (called by Add_Inherited_DICs) to handle calls
1936 -- to parent primitives.
1938 Op_Node := First_Elmt (Primitive_Operations (T));
1939 while Present (Op_Node) loop
1940 Prim := Node (Op_Node);
1942 if Present (Overridden_Operation (Prim))
1943 and then Comes_From_Source (Prim)
1945 Par_Prim := Overridden_Operation (Prim);
1947 -- Create a mapping of the form:
1948 -- parent type primitive -> derived type primitive
1950 Type_Map.Set (Par_Prim, Prim);
1953 Next_Elmt (Op_Node);
1956 -- Climb the parent type chain
1960 -- Do not consider subtypes, as they inherit the DICs from their
1963 Par_Typ := Base_Type (Etype (Base_Type (Curr_Typ)));
1965 -- Stop the climb once the root of the parent chain is
1968 exit when Curr_Typ = Par_Typ;
1970 -- Process the DICs of the parent type
1972 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
1974 -- Only try to inherit a DIC pragma from the parent type Par_Typ
1975 -- if it Has_Own_DIC pragma. The loop will proceed up the parent
1976 -- chain to find all types that have their own DIC.
1978 if Has_Own_DIC (Par_Typ) then
1981 Priv_Typ => Priv_Typ,
1982 Full_Typ => Full_Typ,
1987 Curr_Typ := Par_Typ;
1989 end Add_Parent_DICs;
1993 Loc : constant Source_Ptr := Sloc (Typ);
1995 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1996 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1997 -- Save the Ghost-related attributes to restore on exit
2000 DIC_Typ : Entity_Id;
2001 Dummy_1 : Entity_Id;
2002 Dummy_2 : Entity_Id;
2003 Proc_Body : Node_Id;
2004 Proc_Body_Id : Entity_Id;
2005 Proc_Decl : Node_Id;
2006 Proc_Id : Entity_Id;
2007 Stmts : List_Id := No_List;
2009 CRec_Typ : Entity_Id := Empty;
2010 -- The corresponding record type of Full_Typ
2012 Full_Typ : Entity_Id := Empty;
2013 -- The full view of the working type
2015 Obj_Id : Entity_Id := Empty;
2016 -- The _object formal parameter of the invariant procedure
2018 Part_Proc : Entity_Id := Empty;
2019 -- The entity of the "partial" invariant procedure
2021 Priv_Typ : Entity_Id := Empty;
2022 -- The partial view of the working type
2024 Work_Typ : Entity_Id;
2027 -- Start of processing for Build_DIC_Procedure_Body
2030 Work_Typ := Base_Type (Typ);
2032 -- Do not process class-wide types as these are Itypes, but lack a first
2033 -- subtype (see below).
2035 if Is_Class_Wide_Type (Work_Typ) then
2038 -- Do not process the underlying full view of a private type. There is
2039 -- no way to get back to the partial view, plus the body will be built
2040 -- by the full view or the base type.
2042 elsif Is_Underlying_Full_View (Work_Typ) then
2045 -- Use the first subtype when dealing with various base types
2047 elsif Is_Itype (Work_Typ) then
2048 Work_Typ := First_Subtype (Work_Typ);
2050 -- The input denotes the corresponding record type of a protected or a
2051 -- task type. Work with the concurrent type because the corresponding
2052 -- record type may not be visible to clients of the type.
2054 elsif Ekind (Work_Typ) = E_Record_Type
2055 and then Is_Concurrent_Record_Type (Work_Typ)
2057 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2060 -- The working type may be subject to pragma Ghost. Set the mode now to
2061 -- ensure that the DIC procedure is properly marked as Ghost.
2063 Set_Ghost_Mode (Work_Typ);
2065 -- The working type must be either define a DIC pragma of its own or
2066 -- inherit one from a parent type.
2068 pragma Assert (Has_DIC (Work_Typ));
2070 -- Recover the type which defines the DIC pragma. This is either the
2071 -- working type itself or a parent type when the pragma is inherited.
2073 DIC_Typ := Find_DIC_Type (Work_Typ);
2074 pragma Assert (Present (DIC_Typ));
2076 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2077 pragma Assert (Present (DIC_Prag));
2079 -- Nothing to do if pragma DIC appears without an argument or its sole
2080 -- argument is "null".
2082 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2086 -- Obtain both views of the type
2088 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ);
2090 -- The caller requests a body for the partial DIC procedure
2093 Proc_Id := Partial_DIC_Procedure (Work_Typ);
2095 -- The "full" DIC procedure body was already created
2097 -- Create a declaration for the "partial" DIC procedure if it
2098 -- is not available.
2100 if No (Proc_Id) then
2101 Build_DIC_Procedure_Declaration
2103 Partial_DIC => True);
2105 Proc_Id := Partial_DIC_Procedure (Work_Typ);
2108 -- The caller requests a body for the "full" DIC procedure
2111 Proc_Id := DIC_Procedure (Work_Typ);
2112 Part_Proc := Partial_DIC_Procedure (Work_Typ);
2114 -- Create a declaration for the "full" DIC procedure if it is
2117 if No (Proc_Id) then
2118 Build_DIC_Procedure_Declaration (Work_Typ);
2119 Proc_Id := DIC_Procedure (Work_Typ);
2123 -- At this point there should be a DIC procedure declaration
2125 pragma Assert (Present (Proc_Id));
2126 Proc_Decl := Unit_Declaration_Node (Proc_Id);
2128 -- Nothing to do if the DIC procedure already has a body
2130 if Present (Corresponding_Body (Proc_Decl)) then
2134 -- Emulate the environment of the DIC procedure by installing its scope
2135 -- and formal parameters.
2137 Push_Scope (Proc_Id);
2138 Install_Formals (Proc_Id);
2140 Obj_Id := First_Formal (Proc_Id);
2141 pragma Assert (Present (Obj_Id));
2143 -- The "partial" DIC procedure verifies the DICs of the partial view
2147 pragma Assert (Present (Priv_Typ));
2149 if Has_Own_DIC (Work_Typ) then -- If we're testing this then maybe
2150 Add_Own_DIC -- we shouldn't be calling Find_DIC_Typ above???
2151 (DIC_Prag => DIC_Prag,
2152 DIC_Typ => DIC_Typ, -- Should this just be Work_Typ???
2157 -- Otherwise, the "full" DIC procedure verifies the DICs inherited from
2158 -- parent types, as well as indirectly verifying the DICs of the partial
2159 -- view by calling the "partial" DIC procedure.
2162 -- Check the DIC of the partial view by calling the "partial" DIC
2163 -- procedure, unless the partial DIC body is empty. Generate:
2165 -- <Work_Typ>Partial_DIC (_object);
2167 if Present (Part_Proc) and then not Has_Null_Body (Part_Proc) then
2168 Append_New_To (Stmts,
2169 Make_Procedure_Call_Statement (Loc,
2170 Name => New_Occurrence_Of (Part_Proc, Loc),
2171 Parameter_Associations => New_List (
2172 New_Occurrence_Of (Obj_Id, Loc))));
2175 -- Process inherited Default_Initial_Conditions for all parent types
2177 Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
2182 -- Produce an empty completing body in the following cases:
2183 -- * Assertions are disabled
2184 -- * The DIC Assertion_Policy is Ignore
2187 Stmts := New_List (Make_Null_Statement (Loc));
2191 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
2194 -- end <Work_Typ>DIC;
2197 Make_Subprogram_Body (Loc,
2199 Copy_Subprogram_Spec (Parent (Proc_Id)),
2200 Declarations => Empty_List,
2201 Handled_Statement_Sequence =>
2202 Make_Handled_Sequence_Of_Statements (Loc,
2203 Statements => Stmts));
2204 Proc_Body_Id := Defining_Entity (Proc_Body);
2206 -- Perform minor decoration in case the body is not analyzed
2208 Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
2209 Set_Etype (Proc_Body_Id, Standard_Void_Type);
2210 Set_Scope (Proc_Body_Id, Current_Scope);
2211 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
2212 Set_SPARK_Pragma_Inherited
2213 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
2215 -- Link both spec and body to avoid generating duplicates
2217 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
2218 Set_Corresponding_Spec (Proc_Body, Proc_Id);
2220 -- The body should not be inserted into the tree when the context
2221 -- is a generic unit because it is not part of the template.
2222 -- Note that the body must still be generated in order to resolve the
2223 -- DIC assertion expression.
2225 if Inside_A_Generic then
2228 -- Semi-insert the body into the tree for GNATprove by setting its
2229 -- Parent field. This allows for proper upstream tree traversals.
2231 elsif GNATprove_Mode then
2232 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
2234 -- Otherwise the body is part of the freezing actions of the working
2238 Append_Freeze_Action (Work_Typ, Proc_Body);
2242 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2243 end Build_DIC_Procedure_Body;
2245 -------------------------------------
2246 -- Build_DIC_Procedure_Declaration --
2247 -------------------------------------
2249 -- WARNING: This routine manages Ghost regions. Return statements must be
2250 -- replaced by gotos which jump to the end of the routine and restore the
2253 procedure Build_DIC_Procedure_Declaration
2255 Partial_DIC : Boolean := False)
2257 Loc : constant Source_Ptr := Sloc (Typ);
2259 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2260 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2261 -- Save the Ghost-related attributes to restore on exit
2264 DIC_Typ : Entity_Id;
2265 Proc_Decl : Node_Id;
2266 Proc_Id : Entity_Id;
2270 CRec_Typ : Entity_Id;
2271 -- The corresponding record type of Full_Typ
2273 Full_Typ : Entity_Id;
2274 -- The full view of working type
2277 -- The _object formal parameter of the DIC procedure
2279 Priv_Typ : Entity_Id;
2280 -- The partial view of working type
2282 UFull_Typ : Entity_Id;
2283 -- The underlying full view of Full_Typ
2285 Work_Typ : Entity_Id;
2289 Work_Typ := Base_Type (Typ);
2291 -- Do not process class-wide types as these are Itypes, but lack a first
2292 -- subtype (see below).
2294 if Is_Class_Wide_Type (Work_Typ) then
2297 -- Do not process the underlying full view of a private type. There is
2298 -- no way to get back to the partial view, plus the body will be built
2299 -- by the full view or the base type.
2301 elsif Is_Underlying_Full_View (Work_Typ) then
2304 -- Use the first subtype when dealing with various base types
2306 elsif Is_Itype (Work_Typ) then
2307 Work_Typ := First_Subtype (Work_Typ);
2309 -- The input denotes the corresponding record type of a protected or a
2310 -- task type. Work with the concurrent type because the corresponding
2311 -- record type may not be visible to clients of the type.
2313 elsif Ekind (Work_Typ) = E_Record_Type
2314 and then Is_Concurrent_Record_Type (Work_Typ)
2316 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2319 -- The working type may be subject to pragma Ghost. Set the mode now to
2320 -- ensure that the DIC procedure is properly marked as Ghost.
2322 Set_Ghost_Mode (Work_Typ);
2324 -- The type must be either subject to a DIC pragma or inherit one from a
2327 pragma Assert (Has_DIC (Work_Typ));
2329 -- Recover the type which defines the DIC pragma. This is either the
2330 -- working type itself or a parent type when the pragma is inherited.
2332 DIC_Typ := Find_DIC_Type (Work_Typ);
2333 pragma Assert (Present (DIC_Typ));
2335 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2336 pragma Assert (Present (DIC_Prag));
2338 -- Nothing to do if pragma DIC appears without an argument or its sole
2339 -- argument is "null".
2341 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2345 -- Nothing to do if the type already has a "partial" DIC procedure
2348 if Present (Partial_DIC_Procedure (Work_Typ)) then
2352 -- Nothing to do if the type already has a "full" DIC procedure
2354 elsif Present (DIC_Procedure (Work_Typ)) then
2358 -- The caller requests the declaration of the "partial" DIC procedure
2361 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_DIC");
2363 -- Otherwise the caller requests the declaration of the "full" DIC
2367 Proc_Nam := New_External_Name (Chars (Work_Typ), "DIC");
2371 Make_Defining_Identifier (Loc, Chars => Proc_Nam);
2373 -- Perform minor decoration in case the declaration is not analyzed
2375 Mutate_Ekind (Proc_Id, E_Procedure);
2376 Set_Etype (Proc_Id, Standard_Void_Type);
2377 Set_Is_DIC_Procedure (Proc_Id);
2378 Set_Scope (Proc_Id, Current_Scope);
2379 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
2380 Set_SPARK_Pragma_Inherited (Proc_Id);
2382 Set_DIC_Procedure (Work_Typ, Proc_Id);
2384 -- The DIC procedure requires debug info when the assertion expression
2385 -- is subject to Source Coverage Obligations.
2387 if Generate_SCO then
2388 Set_Debug_Info_Needed (Proc_Id);
2391 -- Obtain all views of the input type
2393 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
2395 -- Associate the DIC procedure and various flags with all views
2397 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
2398 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
2399 Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ);
2400 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
2402 -- The declaration of the DIC procedure must be inserted after the
2403 -- declaration of the partial view as this allows for proper external
2406 if Present (Priv_Typ) then
2407 Typ_Decl := Declaration_Node (Priv_Typ);
2409 -- Derived types with the full view as parent do not have a partial
2410 -- view. Insert the DIC procedure after the derived type.
2413 Typ_Decl := Declaration_Node (Full_Typ);
2416 -- The type should have a declarative node
2418 pragma Assert (Present (Typ_Decl));
2420 -- Create the formal parameter which emulates the variable-like behavior
2421 -- of the type's current instance.
2423 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
2425 -- Perform minor decoration in case the declaration is not analyzed
2427 Mutate_Ekind (Obj_Id, E_In_Parameter);
2428 Set_Etype (Obj_Id, Work_Typ);
2429 Set_Scope (Obj_Id, Proc_Id);
2431 Set_First_Entity (Proc_Id, Obj_Id);
2432 Set_Last_Entity (Proc_Id, Obj_Id);
2435 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2438 Make_Subprogram_Declaration (Loc,
2440 Make_Procedure_Specification (Loc,
2441 Defining_Unit_Name => Proc_Id,
2442 Parameter_Specifications => New_List (
2443 Make_Parameter_Specification (Loc,
2444 Defining_Identifier => Obj_Id,
2446 New_Occurrence_Of (Work_Typ, Loc)))));
2448 -- The declaration should not be inserted into the tree when the context
2449 -- is a generic unit because it is not part of the template.
2451 if Inside_A_Generic then
2454 -- Semi-insert the declaration into the tree for GNATprove by setting
2455 -- its Parent field. This allows for proper upstream tree traversals.
2457 elsif GNATprove_Mode then
2458 Set_Parent (Proc_Decl, Parent (Typ_Decl));
2460 -- Otherwise insert the declaration
2463 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
2467 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2468 end Build_DIC_Procedure_Declaration;
2470 ------------------------------------
2471 -- Build_Invariant_Procedure_Body --
2472 ------------------------------------
2474 -- WARNING: This routine manages Ghost regions. Return statements must be
2475 -- replaced by gotos which jump to the end of the routine and restore the
2478 procedure Build_Invariant_Procedure_Body
2480 Partial_Invariant : Boolean := False)
2482 Loc : constant Source_Ptr := Sloc (Typ);
2484 Pragmas_Seen : Elist_Id := No_Elist;
2485 -- This list contains all invariant pragmas processed so far. The list
2486 -- is used to avoid generating redundant invariant checks.
2488 Produced_Check : Boolean := False;
2489 -- This flag tracks whether the type has produced at least one invariant
2490 -- check. The flag is used as a sanity check at the end of the routine.
2492 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2493 -- intentionally unnested to avoid deep indentation of code.
2495 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2496 -- they emit checks, loops (for arrays) and case statements (for record
2497 -- variant parts) only when there are invariants to verify. This keeps
2498 -- the body of the invariant procedure free of useless code.
2500 procedure Add_Array_Component_Invariants
2503 Checks : in out List_Id);
2504 -- Generate an invariant check for each component of array type T.
2505 -- Obj_Id denotes the entity of the _object formal parameter of the
2506 -- invariant procedure. All created checks are added to list Checks.
2508 procedure Add_Inherited_Invariants
2510 Priv_Typ : Entity_Id;
2511 Full_Typ : Entity_Id;
2513 Checks : in out List_Id);
2514 -- Generate an invariant check for each inherited class-wide invariant
2515 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2516 -- the partial and full view of the parent type. Obj_Id denotes the
2517 -- entity of the _object formal parameter of the invariant procedure.
2518 -- All created checks are added to list Checks.
2520 procedure Add_Interface_Invariants
2523 Checks : in out List_Id);
2524 -- Generate an invariant check for each inherited class-wide invariant
2525 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2526 -- entity of the _object formal parameter of the invariant procedure.
2527 -- All created checks are added to list Checks.
2529 procedure Add_Invariant_Check
2532 Checks : in out List_Id;
2533 Inherited : Boolean := False);
2534 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2535 -- verify assertion expression Expr of pragma Prag. All generated code
2536 -- is added to list Checks. Flag Inherited should be set when the pragma
2537 -- is inherited from a parent or interface type.
2539 procedure Add_Own_Invariants
2542 Checks : in out List_Id;
2543 Priv_Item : Node_Id := Empty);
2544 -- Generate an invariant check for each invariant found for type T.
2545 -- Obj_Id denotes the entity of the _object formal parameter of the
2546 -- invariant procedure. All created checks are added to list Checks.
2547 -- Priv_Item denotes the first rep item of the private type.
2549 procedure Add_Parent_Invariants
2552 Checks : in out List_Id);
2553 -- Generate an invariant check for each inherited class-wide invariant
2554 -- coming from all parent types of type T. Obj_Id denotes the entity of
2555 -- the _object formal parameter of the invariant procedure. All created
2556 -- checks are added to list Checks.
2558 procedure Add_Record_Component_Invariants
2561 Checks : in out List_Id);
2562 -- Generate an invariant check for each component of record type T.
2563 -- Obj_Id denotes the entity of the _object formal parameter of the
2564 -- invariant procedure. All created checks are added to list Checks.
2566 ------------------------------------
2567 -- Add_Array_Component_Invariants --
2568 ------------------------------------
2570 procedure Add_Array_Component_Invariants
2573 Checks : in out List_Id)
2575 Comp_Typ : constant Entity_Id := Component_Type (T);
2576 Dims : constant Pos := Number_Dimensions (T);
2578 procedure Process_Array_Component
2580 Comp_Checks : in out List_Id);
2581 -- Generate an invariant check for an array component identified by
2582 -- the indices in list Indices. All created checks are added to list
2585 procedure Process_One_Dimension
2588 Dim_Checks : in out List_Id);
2589 -- Generate a loop over the Nth dimension Dim of an array type. List
2590 -- Indices contains all array indices for the dimension. All created
2591 -- checks are added to list Dim_Checks.
2593 -----------------------------
2594 -- Process_Array_Component --
2595 -----------------------------
2597 procedure Process_Array_Component
2599 Comp_Checks : in out List_Id)
2601 Proc_Id : Entity_Id;
2604 if Has_Invariants (Comp_Typ) then
2606 -- In GNATprove mode, the component invariants are checked by
2607 -- other means. They should not be added to the array type
2608 -- invariant procedure, so that the procedure can be used to
2609 -- check the array type invariants if any.
2611 if GNATprove_Mode then
2615 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2617 -- The component type should have an invariant procedure
2618 -- if it has invariants of its own or inherits class-wide
2619 -- invariants from parent or interface types.
2621 pragma Assert (Present (Proc_Id));
2624 -- <Comp_Typ>Invariant (_object (<Indices>));
2626 -- The invariant procedure has a null body if assertions are
2627 -- disabled or Assertion_Policy Ignore is in effect.
2629 if not Has_Null_Body (Proc_Id) then
2630 Append_New_To (Comp_Checks,
2631 Make_Procedure_Call_Statement (Loc,
2633 New_Occurrence_Of (Proc_Id, Loc),
2634 Parameter_Associations => New_List (
2635 Make_Indexed_Component (Loc,
2636 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2637 Expressions => New_Copy_List (Indices)))));
2641 Produced_Check := True;
2643 end Process_Array_Component;
2645 ---------------------------
2646 -- Process_One_Dimension --
2647 ---------------------------
2649 procedure Process_One_Dimension
2652 Dim_Checks : in out List_Id)
2654 Comp_Checks : List_Id := No_List;
2658 -- Generate the invariant checks for the array component after all
2659 -- dimensions have produced their respective loops.
2662 Process_Array_Component
2663 (Indices => Indices,
2664 Comp_Checks => Dim_Checks);
2666 -- Otherwise create a loop for the current dimension
2669 -- Create a new loop variable for each dimension
2672 Make_Defining_Identifier (Loc,
2673 Chars => New_External_Name ('I', Dim));
2674 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2676 Process_One_Dimension
2679 Dim_Checks => Comp_Checks);
2682 -- for I<Dim> in _object'Range (<Dim>) loop
2686 -- Note that the invariant procedure may have a null body if
2687 -- assertions are disabled or Assertion_Policy Ignore is in
2690 if Present (Comp_Checks) then
2691 Append_New_To (Dim_Checks,
2692 Make_Implicit_Loop_Statement (T,
2693 Identifier => Empty,
2695 Make_Iteration_Scheme (Loc,
2696 Loop_Parameter_Specification =>
2697 Make_Loop_Parameter_Specification (Loc,
2698 Defining_Identifier => Index,
2699 Discrete_Subtype_Definition =>
2700 Make_Attribute_Reference (Loc,
2702 New_Occurrence_Of (Obj_Id, Loc),
2703 Attribute_Name => Name_Range,
2704 Expressions => New_List (
2705 Make_Integer_Literal (Loc, Dim))))),
2706 Statements => Comp_Checks));
2709 end Process_One_Dimension;
2711 -- Start of processing for Add_Array_Component_Invariants
2714 Process_One_Dimension
2716 Indices => New_List,
2717 Dim_Checks => Checks);
2718 end Add_Array_Component_Invariants;
2720 ------------------------------
2721 -- Add_Inherited_Invariants --
2722 ------------------------------
2724 procedure Add_Inherited_Invariants
2726 Priv_Typ : Entity_Id;
2727 Full_Typ : Entity_Id;
2729 Checks : in out List_Id)
2731 Deriv_Typ : Entity_Id;
2734 Prag_Expr : Node_Id;
2735 Prag_Expr_Arg : Node_Id;
2737 Prag_Typ_Arg : Node_Id;
2739 Par_Proc : Entity_Id;
2740 -- The "partial" invariant procedure of Par_Typ
2742 Par_Typ : Entity_Id;
2743 -- The suitable view of the parent type used in the substitution of
2747 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2751 -- When the type inheriting the class-wide invariant is a concurrent
2752 -- type, use the corresponding record type because it contains all
2753 -- primitive operations of the concurrent type and allows for proper
2756 if Is_Concurrent_Type (T) then
2757 Deriv_Typ := Corresponding_Record_Type (T);
2762 pragma Assert (Present (Deriv_Typ));
2764 -- Determine which rep item chain to use. Precedence is given to that
2765 -- of the parent type's partial view since it usually carries all the
2766 -- class-wide invariants.
2768 if Present (Priv_Typ) then
2769 Prag := First_Rep_Item (Priv_Typ);
2771 Prag := First_Rep_Item (Full_Typ);
2774 while Present (Prag) loop
2775 if Nkind (Prag) = N_Pragma
2776 and then Pragma_Name (Prag) = Name_Invariant
2778 -- Nothing to do if the pragma was already processed
2780 if Contains (Pragmas_Seen, Prag) then
2783 -- Nothing to do when the caller requests the processing of all
2784 -- inherited class-wide invariants, but the pragma does not
2785 -- fall in this category.
2787 elsif not Class_Present (Prag) then
2791 -- Extract the arguments of the invariant pragma
2793 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2794 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2795 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2796 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2798 -- The pragma applies to the partial view of the parent type
2800 if Present (Priv_Typ)
2801 and then Entity (Prag_Typ) = Priv_Typ
2803 Par_Typ := Priv_Typ;
2805 -- The pragma applies to the full view of the parent type
2807 elsif Present (Full_Typ)
2808 and then Entity (Prag_Typ) = Full_Typ
2810 Par_Typ := Full_Typ;
2812 -- Otherwise the pragma does not belong to the parent type and
2813 -- should not be considered.
2819 -- Perform the following substitutions:
2821 -- * Replace a reference to the _object parameter of the
2822 -- parent type's partial invariant procedure with a
2823 -- reference to the _object parameter of the derived
2824 -- type's full invariant procedure.
2826 -- * Replace a reference to a discriminant of the parent type
2827 -- with a suitable value from the point of view of the
2830 -- * Replace a call to an overridden parent primitive with a
2831 -- call to the overriding derived type primitive.
2833 -- * Replace a call to an inherited parent primitive with a
2834 -- call to the internally-generated inherited derived type
2837 Expr := New_Copy_Tree (Prag_Expr);
2839 -- The parent type must have a "partial" invariant procedure
2840 -- because class-wide invariants are captured exclusively by
2843 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2844 pragma Assert (Present (Par_Proc));
2849 Deriv_Typ => Deriv_Typ,
2850 Par_Obj => First_Formal (Par_Proc),
2851 Deriv_Obj => Obj_Id);
2853 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2856 Next_Rep_Item (Prag);
2858 end Add_Inherited_Invariants;
2860 ------------------------------
2861 -- Add_Interface_Invariants --
2862 ------------------------------
2864 procedure Add_Interface_Invariants
2867 Checks : in out List_Id)
2869 Iface_Elmt : Elmt_Id;
2873 -- Generate an invariant check for each class-wide invariant coming
2874 -- from all interfaces implemented by type T.
2876 if Is_Tagged_Type (T) then
2877 Collect_Interfaces (T, Ifaces);
2879 -- Process the class-wide invariants of all implemented interfaces
2881 Iface_Elmt := First_Elmt (Ifaces);
2882 while Present (Iface_Elmt) loop
2884 -- The Full_Typ parameter is intentionally left Empty because
2885 -- interfaces are treated as the partial view of a private type
2886 -- in order to achieve uniformity with the general case.
2888 Add_Inherited_Invariants
2890 Priv_Typ => Node (Iface_Elmt),
2895 Next_Elmt (Iface_Elmt);
2898 end Add_Interface_Invariants;
2900 -------------------------
2901 -- Add_Invariant_Check --
2902 -------------------------
2904 procedure Add_Invariant_Check
2907 Checks : in out List_Id;
2908 Inherited : Boolean := False)
2910 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2911 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2912 Ploc : constant Source_Ptr := Sloc (Prag);
2913 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2919 -- The invariant is ignored, nothing left to do
2921 if Is_Ignored (Prag) then
2924 -- Otherwise the invariant is checked. Build a pragma Check to verify
2925 -- the expression at run time.
2929 Make_Pragma_Argument_Association (Ploc,
2930 Expression => Make_Identifier (Ploc, Nam)),
2931 Make_Pragma_Argument_Association (Ploc,
2932 Expression => Expr));
2934 -- Handle the String argument (if any)
2936 if Present (Str_Arg) then
2937 Str := Strval (Get_Pragma_Arg (Str_Arg));
2939 -- When inheriting an invariant, modify the message from
2940 -- "failed invariant" to "failed inherited invariant".
2943 String_To_Name_Buffer (Str);
2945 if Name_Buffer (1 .. 16) = "failed invariant" then
2946 Insert_Str_In_Name_Buffer ("inherited ", 8);
2947 Str := String_From_Name_Buffer;
2952 Make_Pragma_Argument_Association (Ploc,
2953 Expression => Make_String_Literal (Ploc, Str)));
2957 -- pragma Check (<Nam>, <Expr>, <Str>);
2959 Append_New_To (Checks,
2961 Chars => Name_Check,
2962 Pragma_Argument_Associations => Assoc));
2965 -- Output an info message when inheriting an invariant and the
2966 -- listing option is enabled.
2968 if Inherited and Opt.List_Inherited_Aspects then
2969 Error_Msg_Sloc := Sloc (Prag);
2971 ("info: & inherits `Invariant''Class` aspect from #?.l?", Typ);
2974 -- Add the pragma to the list of processed pragmas
2976 Append_New_Elmt (Prag, Pragmas_Seen);
2977 Produced_Check := True;
2978 end Add_Invariant_Check;
2980 ---------------------------
2981 -- Add_Parent_Invariants --
2982 ---------------------------
2984 procedure Add_Parent_Invariants
2987 Checks : in out List_Id)
2989 Dummy_1 : Entity_Id;
2990 Dummy_2 : Entity_Id;
2992 Curr_Typ : Entity_Id;
2993 -- The entity of the current type being examined
2995 Full_Typ : Entity_Id;
2996 -- The full view of Par_Typ
2998 Par_Typ : Entity_Id;
2999 -- The entity of the parent type
3001 Priv_Typ : Entity_Id;
3002 -- The partial view of Par_Typ
3005 -- Do not process array types because they cannot have true parent
3006 -- types. This also prevents the generation of a duplicate invariant
3007 -- check when the input type is an array base type because its Etype
3008 -- denotes the first subtype, both of which share the same component
3011 if Is_Array_Type (T) then
3015 -- Climb the parent type chain
3019 -- Do not consider subtypes as they inherit the invariants
3020 -- from their base types.
3022 Par_Typ := Base_Type (Etype (Curr_Typ));
3024 -- Stop the climb once the root of the parent chain is
3027 exit when Curr_Typ = Par_Typ;
3029 -- Process the class-wide invariants of the parent type
3031 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
3033 -- Process the elements of an array type
3035 if Is_Array_Type (Full_Typ) then
3036 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
3038 -- Process the components of a record type
3040 elsif Ekind (Full_Typ) = E_Record_Type then
3041 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
3044 Add_Inherited_Invariants
3046 Priv_Typ => Priv_Typ,
3047 Full_Typ => Full_Typ,
3051 Curr_Typ := Par_Typ;
3053 end Add_Parent_Invariants;
3055 ------------------------
3056 -- Add_Own_Invariants --
3057 ------------------------
3059 procedure Add_Own_Invariants
3062 Checks : in out List_Id;
3063 Priv_Item : Node_Id := Empty)
3068 Prag_Expr : Node_Id;
3069 Prag_Expr_Arg : Node_Id;
3071 Prag_Typ_Arg : Node_Id;
3074 if not Present (T) then
3078 Prag := First_Rep_Item (T);
3079 while Present (Prag) loop
3080 if Nkind (Prag) = N_Pragma
3081 and then Pragma_Name (Prag) = Name_Invariant
3083 -- Stop the traversal of the rep item chain once a specific
3084 -- item is encountered.
3086 if Present (Priv_Item) and then Prag = Priv_Item then
3090 -- Nothing to do if the pragma was already processed
3092 if Contains (Pragmas_Seen, Prag) then
3096 -- Extract the arguments of the invariant pragma
3098 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
3099 Prag_Expr_Arg := Next (Prag_Typ_Arg);
3100 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
3101 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
3102 Prag_Asp := Corresponding_Aspect (Prag);
3104 -- Verify the pragma belongs to T, otherwise the pragma applies
3105 -- to a parent type in which case it will be processed later by
3106 -- Add_Parent_Invariants or Add_Interface_Invariants.
3108 if Entity (Prag_Typ) /= T then
3112 Expr := New_Copy_Tree (Prag_Expr);
3114 -- Substitute all references to type T with references to the
3115 -- _object formal parameter.
3117 Replace_Type_References (Expr, T, Obj_Id);
3119 -- Preanalyze the invariant expression to detect errors and at
3120 -- the same time capture the visibility of the proper package
3123 Set_Parent (Expr, Parent (Prag_Expr));
3124 Preanalyze_Assert_Expression (Expr, Any_Boolean);
3126 -- Save a copy of the expression when T is tagged to detect
3127 -- errors and capture the visibility of the proper package part
3128 -- for the generation of inherited type invariants.
3130 if Is_Tagged_Type (T) then
3131 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
3134 -- If the pragma comes from an aspect specification, replace
3135 -- the saved expression because all type references must be
3136 -- substituted for the call to Preanalyze_Spec_Expression in
3137 -- Check_Aspect_At_xxx routines.
3139 if Present (Prag_Asp) then
3140 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
3143 Add_Invariant_Check (Prag, Expr, Checks);
3146 Next_Rep_Item (Prag);
3148 end Add_Own_Invariants;
3150 -------------------------------------
3151 -- Add_Record_Component_Invariants --
3152 -------------------------------------
3154 procedure Add_Record_Component_Invariants
3157 Checks : in out List_Id)
3159 procedure Process_Component_List
3160 (Comp_List : Node_Id;
3161 CL_Checks : in out List_Id);
3162 -- Generate invariant checks for all record components found in
3163 -- component list Comp_List, including variant parts. All created
3164 -- checks are added to list CL_Checks.
3166 procedure Process_Record_Component
3167 (Comp_Id : Entity_Id;
3168 Comp_Checks : in out List_Id);
3169 -- Generate an invariant check for a record component identified by
3170 -- Comp_Id. All created checks are added to list Comp_Checks.
3172 ----------------------------
3173 -- Process_Component_List --
3174 ----------------------------
3176 procedure Process_Component_List
3177 (Comp_List : Node_Id;
3178 CL_Checks : in out List_Id)
3182 Var_Alts : List_Id := No_List;
3183 Var_Checks : List_Id := No_List;
3184 Var_Stmts : List_Id;
3186 Produced_Variant_Check : Boolean := False;
3187 -- This flag tracks whether the component has produced at least
3188 -- one invariant check.
3191 -- Traverse the component items
3193 Comp := First (Component_Items (Comp_List));
3194 while Present (Comp) loop
3195 if Nkind (Comp) = N_Component_Declaration then
3197 -- Generate the component invariant check
3199 Process_Record_Component
3200 (Comp_Id => Defining_Entity (Comp),
3201 Comp_Checks => CL_Checks);
3207 -- Traverse the variant part
3209 if Present (Variant_Part (Comp_List)) then
3210 Var := First (Variants (Variant_Part (Comp_List)));
3211 while Present (Var) loop
3212 Var_Checks := No_List;
3214 -- Generate invariant checks for all components and variant
3215 -- parts that qualify.
3217 Process_Component_List
3218 (Comp_List => Component_List (Var),
3219 CL_Checks => Var_Checks);
3221 -- The components of the current variant produced at least
3222 -- one invariant check.
3224 if Present (Var_Checks) then
3225 Var_Stmts := Var_Checks;
3226 Produced_Variant_Check := True;
3228 -- Otherwise there are either no components with invariants,
3229 -- assertions are disabled, or Assertion_Policy Ignore is in
3233 Var_Stmts := New_List (Make_Null_Statement (Loc));
3236 Append_New_To (Var_Alts,
3237 Make_Case_Statement_Alternative (Loc,
3239 New_Copy_List (Discrete_Choices (Var)),
3240 Statements => Var_Stmts));
3245 -- Create a case statement which verifies the invariant checks
3246 -- of a particular component list depending on the discriminant
3247 -- values only when there is at least one real invariant check.
3249 if Produced_Variant_Check then
3250 Append_New_To (CL_Checks,
3251 Make_Case_Statement (Loc,
3253 Make_Selected_Component (Loc,
3254 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3257 (Entity (Name (Variant_Part (Comp_List))), Loc)),
3258 Alternatives => Var_Alts));
3261 end Process_Component_List;
3263 ------------------------------
3264 -- Process_Record_Component --
3265 ------------------------------
3267 procedure Process_Record_Component
3268 (Comp_Id : Entity_Id;
3269 Comp_Checks : in out List_Id)
3271 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
3272 Proc_Id : Entity_Id;
3274 Produced_Component_Check : Boolean := False;
3275 -- This flag tracks whether the component has produced at least
3276 -- one invariant check.
3279 -- Nothing to do for internal component _parent. Note that it is
3280 -- not desirable to check whether the component comes from source
3281 -- because protected type components are relocated to an internal
3282 -- corresponding record, but still need processing.
3284 if Chars (Comp_Id) = Name_uParent then
3288 -- Verify the invariant of the component. Note that an access
3289 -- type may have an invariant when it acts as the full view of a
3290 -- private type and the invariant appears on the partial view. In
3291 -- this case verify the access value itself.
3293 if Has_Invariants (Comp_Typ) then
3295 -- In GNATprove mode, the component invariants are checked by
3296 -- other means. They should not be added to the record type
3297 -- invariant procedure, so that the procedure can be used to
3298 -- check the record type invariants if any.
3300 if GNATprove_Mode then
3304 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3306 -- The component type should have an invariant procedure
3307 -- if it has invariants of its own or inherits class-wide
3308 -- invariants from parent or interface types.
3310 pragma Assert (Present (Proc_Id));
3313 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
3315 -- Note that the invariant procedure may have a null body if
3316 -- assertions are disabled or Assertion_Policy Ignore is in
3319 if not Has_Null_Body (Proc_Id) then
3320 Append_New_To (Comp_Checks,
3321 Make_Procedure_Call_Statement (Loc,
3323 New_Occurrence_Of (Proc_Id, Loc),
3324 Parameter_Associations => New_List (
3325 Make_Selected_Component (Loc,
3327 Unchecked_Convert_To
3328 (T, New_Occurrence_Of (Obj_Id, Loc)),
3330 New_Occurrence_Of (Comp_Id, Loc)))));
3334 Produced_Check := True;
3335 Produced_Component_Check := True;
3338 if Produced_Component_Check and then Has_Unchecked_Union (T) then
3340 ("invariants cannot be checked on components of "
3341 & "unchecked_union type &??", Comp_Id, T);
3343 end Process_Record_Component;
3350 -- Start of processing for Add_Record_Component_Invariants
3353 -- An untagged derived type inherits the components of its parent
3354 -- type. In order to avoid creating redundant invariant checks, do
3355 -- not process the components now. Instead wait until the ultimate
3356 -- parent of the untagged derivation chain is reached.
3358 if not Is_Untagged_Derivation (T) then
3359 Def := Type_Definition (Parent (T));
3361 if Nkind (Def) = N_Derived_Type_Definition then
3362 Def := Record_Extension_Part (Def);
3365 pragma Assert (Nkind (Def) = N_Record_Definition);
3366 Comps := Component_List (Def);
3368 if Present (Comps) then
3369 Process_Component_List
3370 (Comp_List => Comps,
3371 CL_Checks => Checks);
3374 end Add_Record_Component_Invariants;
3378 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3379 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3380 -- Save the Ghost-related attributes to restore on exit
3383 Priv_Item : Node_Id;
3384 Proc_Body : Node_Id;
3385 Proc_Body_Id : Entity_Id;
3386 Proc_Decl : Node_Id;
3387 Proc_Id : Entity_Id;
3388 Stmts : List_Id := No_List;
3390 CRec_Typ : Entity_Id := Empty;
3391 -- The corresponding record type of Full_Typ
3393 Full_Proc : Entity_Id := Empty;
3394 -- The entity of the "full" invariant procedure
3396 Full_Typ : Entity_Id := Empty;
3397 -- The full view of the working type
3399 Obj_Id : Entity_Id := Empty;
3400 -- The _object formal parameter of the invariant procedure
3402 Part_Proc : Entity_Id := Empty;
3403 -- The entity of the "partial" invariant procedure
3405 Priv_Typ : Entity_Id := Empty;
3406 -- The partial view of the working type
3408 Work_Typ : Entity_Id := Empty;
3411 -- Start of processing for Build_Invariant_Procedure_Body
3416 -- Do not process the underlying full view of a private type. There is
3417 -- no way to get back to the partial view, plus the body will be built
3418 -- by the full view or the base type.
3420 if Is_Underlying_Full_View (Work_Typ) then
3423 -- The input type denotes the implementation base type of a constrained
3424 -- array type. Work with the first subtype as all invariant pragmas are
3425 -- on its rep item chain.
3427 elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3428 Work_Typ := First_Subtype (Work_Typ);
3430 -- The input type denotes the corresponding record type of a protected
3431 -- or task type. Work with the concurrent type because the corresponding
3432 -- record type may not be visible to clients of the type.
3434 elsif Ekind (Work_Typ) = E_Record_Type
3435 and then Is_Concurrent_Record_Type (Work_Typ)
3437 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3440 -- The working type may be subject to pragma Ghost. Set the mode now to
3441 -- ensure that the invariant procedure is properly marked as Ghost.
3443 Set_Ghost_Mode (Work_Typ);
3445 -- The type must either have invariants of its own, inherit class-wide
3446 -- invariants from parent types or interfaces, or be an array or record
3447 -- type whose components have invariants.
3449 pragma Assert (Has_Invariants (Work_Typ));
3451 -- Interfaces are treated as the partial view of a private type in order
3452 -- to achieve uniformity with the general case.
3454 if Is_Interface (Work_Typ) then
3455 Priv_Typ := Work_Typ;
3457 -- Otherwise obtain both views of the type
3460 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
3463 -- The caller requests a body for the partial invariant procedure
3465 if Partial_Invariant then
3466 Full_Proc := Invariant_Procedure (Work_Typ);
3467 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3469 -- The "full" invariant procedure body was already created
3471 if Present (Full_Proc)
3473 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
3475 -- This scenario happens only when the type is an untagged
3476 -- derivation from a private parent and the underlying full
3477 -- view was processed before the partial view.
3480 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3482 -- Nothing to do because the processing of the underlying full
3483 -- view already checked the invariants of the partial view.
3488 -- Create a declaration for the "partial" invariant procedure if it
3489 -- is not available.
3491 if No (Proc_Id) then
3492 Build_Invariant_Procedure_Declaration
3494 Partial_Invariant => True);
3496 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3499 -- The caller requests a body for the "full" invariant procedure
3502 Proc_Id := Invariant_Procedure (Work_Typ);
3503 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3505 -- Create a declaration for the "full" invariant procedure if it is
3508 if No (Proc_Id) then
3509 Build_Invariant_Procedure_Declaration (Work_Typ);
3510 Proc_Id := Invariant_Procedure (Work_Typ);
3514 -- At this point there should be an invariant procedure declaration
3516 pragma Assert (Present (Proc_Id));
3517 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3519 -- Nothing to do if the invariant procedure already has a body
3521 if Present (Corresponding_Body (Proc_Decl)) then
3525 -- Emulate the environment of the invariant procedure by installing its
3526 -- scope and formal parameters. Note that this is not needed, but having
3527 -- the scope installed helps with the detection of invariant-related
3530 Push_Scope (Proc_Id);
3531 Install_Formals (Proc_Id);
3533 Obj_Id := First_Formal (Proc_Id);
3534 pragma Assert (Present (Obj_Id));
3536 -- The "partial" invariant procedure verifies the invariants of the
3537 -- partial view only.
3539 if Partial_Invariant then
3540 pragma Assert (Present (Priv_Typ));
3547 -- Otherwise the "full" invariant procedure verifies the invariants of
3548 -- the full view, all array or record components, as well as class-wide
3549 -- invariants inherited from parent types or interfaces. In addition, it
3550 -- indirectly verifies the invariants of the partial view by calling the
3551 -- "partial" invariant procedure.
3554 pragma Assert (Present (Full_Typ));
3556 -- Check the invariants of the partial view by calling the "partial"
3557 -- invariant procedure. Generate:
3559 -- <Work_Typ>Partial_Invariant (_object);
3561 if Present (Part_Proc) then
3562 Append_New_To (Stmts,
3563 Make_Procedure_Call_Statement (Loc,
3564 Name => New_Occurrence_Of (Part_Proc, Loc),
3565 Parameter_Associations => New_List (
3566 New_Occurrence_Of (Obj_Id, Loc))));
3568 Produced_Check := True;
3573 -- Derived subtypes do not have a partial view
3575 if Present (Priv_Typ) then
3577 -- The processing of the "full" invariant procedure intentionally
3578 -- skips the partial view because a) this may result in changes of
3579 -- visibility and b) lead to duplicate checks. However, when the
3580 -- full view is the underlying full view of an untagged derived
3581 -- type whose parent type is private, partial invariants appear on
3582 -- the rep item chain of the partial view only.
3584 -- package Pack_1 is
3585 -- type Root ... is private;
3587 -- <full view of Root>
3591 -- package Pack_2 is
3592 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3593 -- <underlying full view of Child>
3596 -- As a result, the processing of the full view must also consider
3597 -- all invariants of the partial view.
3599 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3602 -- Otherwise the invariants of the partial view are ignored
3605 -- Note that the rep item chain is shared between the partial
3606 -- and full views of a type. To avoid processing the invariants
3607 -- of the partial view, signal the logic to stop when the first
3608 -- rep item of the partial view has been reached.
3610 Priv_Item := First_Rep_Item (Priv_Typ);
3612 -- Ignore the invariants of the partial view by eliminating the
3619 -- Process the invariants of the full view and in certain cases those
3620 -- of the partial view. This also handles any invariants on array or
3621 -- record components.
3627 Priv_Item => Priv_Item);
3633 Priv_Item => Priv_Item);
3635 -- Process the elements of an array type
3637 if Is_Array_Type (Full_Typ) then
3638 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3640 -- Process the components of a record type
3642 elsif Ekind (Full_Typ) = E_Record_Type then
3643 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3645 -- Process the components of a corresponding record
3647 elsif Present (CRec_Typ) then
3648 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3651 -- Process the inherited class-wide invariants of all parent types.
3652 -- This also handles any invariants on record components.
3654 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3656 -- Process the inherited class-wide invariants of all implemented
3659 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3664 -- At this point there should be at least one invariant check. If this
3665 -- is not the case, then the invariant-related flags were not properly
3666 -- set, or there is a missing invariant procedure on one of the array
3667 -- or record components.
3669 pragma Assert (Produced_Check);
3671 -- Account for the case where assertions are disabled or all invariant
3672 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3676 Stmts := New_List (Make_Null_Statement (Loc));
3680 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3683 -- end <Work_Typ>[Partial_]Invariant;
3686 Make_Subprogram_Body (Loc,
3688 Copy_Subprogram_Spec (Parent (Proc_Id)),
3689 Declarations => Empty_List,
3690 Handled_Statement_Sequence =>
3691 Make_Handled_Sequence_Of_Statements (Loc,
3692 Statements => Stmts));
3693 Proc_Body_Id := Defining_Entity (Proc_Body);
3695 -- Perform minor decoration in case the body is not analyzed
3697 Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
3698 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3699 Set_Scope (Proc_Body_Id, Current_Scope);
3701 -- Link both spec and body to avoid generating duplicates
3703 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3704 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3706 -- The body should not be inserted into the tree when the context is
3707 -- a generic unit because it is not part of the template. Note
3708 -- that the body must still be generated in order to resolve the
3711 if Inside_A_Generic then
3714 -- Semi-insert the body into the tree for GNATprove by setting its
3715 -- Parent field. This allows for proper upstream tree traversals.
3717 elsif GNATprove_Mode then
3718 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3720 -- Otherwise the body is part of the freezing actions of the type
3723 Append_Freeze_Action (Work_Typ, Proc_Body);
3727 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3728 end Build_Invariant_Procedure_Body;
3730 -------------------------------------------
3731 -- Build_Invariant_Procedure_Declaration --
3732 -------------------------------------------
3734 -- WARNING: This routine manages Ghost regions. Return statements must be
3735 -- replaced by gotos which jump to the end of the routine and restore the
3738 procedure Build_Invariant_Procedure_Declaration
3740 Partial_Invariant : Boolean := False)
3742 Loc : constant Source_Ptr := Sloc (Typ);
3744 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3745 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3746 -- Save the Ghost-related attributes to restore on exit
3748 Proc_Decl : Node_Id;
3749 Proc_Id : Entity_Id;
3753 CRec_Typ : Entity_Id;
3754 -- The corresponding record type of Full_Typ
3756 Full_Typ : Entity_Id;
3757 -- The full view of working type
3760 -- The _object formal parameter of the invariant procedure
3762 Obj_Typ : Entity_Id;
3763 -- The type of the _object formal parameter
3765 Priv_Typ : Entity_Id;
3766 -- The partial view of working type
3768 UFull_Typ : Entity_Id;
3769 -- The underlying full view of Full_Typ
3771 Work_Typ : Entity_Id;
3777 -- The input type denotes the implementation base type of a constrained
3778 -- array type. Work with the first subtype as all invariant pragmas are
3779 -- on its rep item chain.
3781 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3782 Work_Typ := First_Subtype (Work_Typ);
3784 -- The input denotes the corresponding record type of a protected or a
3785 -- task type. Work with the concurrent type because the corresponding
3786 -- record type may not be visible to clients of the type.
3788 elsif Ekind (Work_Typ) = E_Record_Type
3789 and then Is_Concurrent_Record_Type (Work_Typ)
3791 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3794 -- The working type may be subject to pragma Ghost. Set the mode now to
3795 -- ensure that the invariant procedure is properly marked as Ghost.
3797 Set_Ghost_Mode (Work_Typ);
3799 -- The type must either have invariants of its own, inherit class-wide
3800 -- invariants from parent or interface types, or be an array or record
3801 -- type whose components have invariants.
3803 pragma Assert (Has_Invariants (Work_Typ));
3805 -- Nothing to do if the type already has a "partial" invariant procedure
3807 if Partial_Invariant then
3808 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3812 -- Nothing to do if the type already has a "full" invariant procedure
3814 elsif Present (Invariant_Procedure (Work_Typ)) then
3818 -- The caller requests the declaration of the "partial" invariant
3821 if Partial_Invariant then
3822 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3824 -- Otherwise the caller requests the declaration of the "full" invariant
3828 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3831 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3833 -- Perform minor decoration in case the declaration is not analyzed
3835 Mutate_Ekind (Proc_Id, E_Procedure);
3836 Set_Etype (Proc_Id, Standard_Void_Type);
3837 Set_Scope (Proc_Id, Current_Scope);
3839 if Partial_Invariant then
3840 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3841 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3843 Set_Is_Invariant_Procedure (Proc_Id);
3844 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3847 -- The invariant procedure requires debug info when the invariants are
3848 -- subject to Source Coverage Obligations.
3850 if Generate_SCO then
3851 Set_Debug_Info_Needed (Proc_Id);
3854 -- Obtain all views of the input type
3856 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
3858 -- Associate the invariant procedure and various flags with all views
3860 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3861 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3862 Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ);
3863 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3865 -- The declaration of the invariant procedure is inserted after the
3866 -- declaration of the partial view as this allows for proper external
3869 if Present (Priv_Typ) then
3870 Typ_Decl := Declaration_Node (Priv_Typ);
3872 -- Anonymous arrays in object declarations have no explicit declaration
3873 -- so use the related object declaration as the insertion point.
3875 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
3876 Typ_Decl := Associated_Node_For_Itype (Work_Typ);
3878 -- Derived types with the full view as parent do not have a partial
3879 -- view. Insert the invariant procedure after the derived type.
3882 Typ_Decl := Declaration_Node (Full_Typ);
3885 -- The type should have a declarative node
3887 pragma Assert (Present (Typ_Decl));
3889 -- Create the formal parameter which emulates the variable-like behavior
3890 -- of the current type instance.
3892 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3894 -- When generating an invariant procedure declaration for an abstract
3895 -- type (including interfaces), use the class-wide type as the _object
3896 -- type. This has several desirable effects:
3898 -- * The invariant procedure does not become a primitive of the type.
3899 -- This eliminates the need to either special case the treatment of
3900 -- invariant procedures, or to make it a predefined primitive and
3901 -- force every derived type to potentially provide an empty body.
3903 -- * The invariant procedure does not need to be declared as abstract.
3904 -- This allows for a proper body, which in turn avoids redundant
3905 -- processing of the same invariants for types with multiple views.
3907 -- * The class-wide type allows for calls to abstract primitives
3908 -- within a nonabstract subprogram. The calls are treated as
3909 -- dispatching and require additional processing when they are
3910 -- remapped to call primitives of derived types. See routine
3911 -- Replace_References for details.
3913 if Is_Abstract_Type (Work_Typ) then
3914 Obj_Typ := Class_Wide_Type (Work_Typ);
3916 Obj_Typ := Work_Typ;
3919 -- Perform minor decoration in case the declaration is not analyzed
3921 Mutate_Ekind (Obj_Id, E_In_Parameter);
3922 Set_Etype (Obj_Id, Obj_Typ);
3923 Set_Scope (Obj_Id, Proc_Id);
3925 Set_First_Entity (Proc_Id, Obj_Id);
3926 Set_Last_Entity (Proc_Id, Obj_Id);
3929 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3932 Make_Subprogram_Declaration (Loc,
3934 Make_Procedure_Specification (Loc,
3935 Defining_Unit_Name => Proc_Id,
3936 Parameter_Specifications => New_List (
3937 Make_Parameter_Specification (Loc,
3938 Defining_Identifier => Obj_Id,
3939 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3941 -- The declaration should not be inserted into the tree when the context
3942 -- is a generic unit because it is not part of the template.
3944 if Inside_A_Generic then
3947 -- Semi-insert the declaration into the tree for GNATprove by setting
3948 -- its Parent field. This allows for proper upstream tree traversals.
3950 elsif GNATprove_Mode then
3951 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3953 -- Otherwise insert the declaration
3956 pragma Assert (Present (Typ_Decl));
3957 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3961 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3962 end Build_Invariant_Procedure_Declaration;
3964 --------------------------
3965 -- Build_Procedure_Form --
3966 --------------------------
3968 procedure Build_Procedure_Form (N : Node_Id) is
3969 Loc : constant Source_Ptr := Sloc (N);
3970 Subp : constant Entity_Id := Defining_Entity (N);
3972 Func_Formal : Entity_Id;
3973 Proc_Formals : List_Id;
3974 Proc_Decl : Node_Id;
3977 -- No action needed if this transformation was already done, or in case
3978 -- of subprogram renaming declarations.
3980 if Nkind (Specification (N)) = N_Procedure_Specification
3981 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3986 -- Ditto when dealing with an expression function, where both the
3987 -- original expression and the generated declaration end up being
3990 if Rewritten_For_C (Subp) then
3994 Proc_Formals := New_List;
3996 -- Create a list of formal parameters with the same types as the
3999 Func_Formal := First_Formal (Subp);
4000 while Present (Func_Formal) loop
4001 Append_To (Proc_Formals,
4002 Make_Parameter_Specification (Loc,
4003 Defining_Identifier =>
4004 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
4006 New_Occurrence_Of (Etype (Func_Formal), Loc)));
4008 Next_Formal (Func_Formal);
4011 -- Add an extra out parameter to carry the function result
4013 Append_To (Proc_Formals,
4014 Make_Parameter_Specification (Loc,
4015 Defining_Identifier =>
4016 Make_Defining_Identifier (Loc, Name_UP_RESULT),
4017 Out_Present => True,
4018 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
4020 -- The new procedure declaration is inserted before the function
4021 -- declaration. The processing in Build_Procedure_Body_Form relies on
4022 -- this order. Note that we insert before because in the case of a
4023 -- function body with no separate spec, we do not want to insert the
4024 -- new spec after the body which will later get rewritten.
4027 Make_Subprogram_Declaration (Loc,
4029 Make_Procedure_Specification (Loc,
4030 Defining_Unit_Name =>
4031 Make_Defining_Identifier (Loc, Chars (Subp)),
4032 Parameter_Specifications => Proc_Formals));
4034 Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
4036 -- Entity of procedure must remain invisible so that it does not
4037 -- overload subsequent references to the original function.
4039 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
4041 -- Mark the function as having a procedure form and link the function
4042 -- and its internally built procedure.
4044 Set_Rewritten_For_C (Subp);
4045 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
4046 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
4047 end Build_Procedure_Form;
4049 ------------------------
4050 -- Build_Runtime_Call --
4051 ------------------------
4053 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
4055 -- If entity is not available, we can skip making the call (this avoids
4056 -- junk duplicated error messages in a number of cases).
4058 if not RTE_Available (RE) then
4059 return Make_Null_Statement (Loc);
4062 Make_Procedure_Call_Statement (Loc,
4063 Name => New_Occurrence_Of (RTE (RE), Loc));
4065 end Build_Runtime_Call;
4067 ------------------------
4068 -- Build_SS_Mark_Call --
4069 ------------------------
4071 function Build_SS_Mark_Call
4073 Mark : Entity_Id) return Node_Id
4077 -- Mark : constant Mark_Id := SS_Mark;
4080 Make_Object_Declaration (Loc,
4081 Defining_Identifier => Mark,
4082 Constant_Present => True,
4083 Object_Definition =>
4084 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
4086 Make_Function_Call (Loc,
4087 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
4088 end Build_SS_Mark_Call;
4090 ---------------------------
4091 -- Build_SS_Release_Call --
4092 ---------------------------
4094 function Build_SS_Release_Call
4096 Mark : Entity_Id) return Node_Id
4100 -- SS_Release (Mark);
4103 Make_Procedure_Call_Statement (Loc,
4105 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
4106 Parameter_Associations => New_List (
4107 New_Occurrence_Of (Mark, Loc)));
4108 end Build_SS_Release_Call;
4110 ----------------------------
4111 -- Build_Task_Array_Image --
4112 ----------------------------
4114 -- This function generates the body for a function that constructs the
4115 -- image string for a task that is an array component. The function is
4116 -- local to the init proc for the array type, and is called for each one
4117 -- of the components. The constructed image has the form of an indexed
4118 -- component, whose prefix is the outer variable of the array type.
4119 -- The n-dimensional array type has known indexes Index, Index2...
4121 -- Id_Ref is an indexed component form created by the enclosing init proc.
4122 -- Its successive indexes are Val1, Val2, ... which are the loop variables
4123 -- in the loops that call the individual task init proc on each component.
4125 -- The generated function has the following structure:
4127 -- function F return String is
4128 -- Pref : String renames Task_Name;
4129 -- T1 : constant String := Index1'Image (Val1);
4131 -- Tn : constant String := Indexn'Image (Valn);
4132 -- Len : constant Integer :=
4133 -- Pref'Length + T1'Length + ... + Tn'Length + n + 1;
4134 -- -- Len includes commas and the end parentheses
4136 -- Res : String (1 .. Len);
4137 -- Pos : Integer := Pref'Length;
4140 -- Res (1 .. Pos) := Pref;
4142 -- Res (Pos) := '(';
4144 -- Res (Pos .. Pos + T1'Length - 1) := T1;
4145 -- Pos := Pos + T1'Length;
4146 -- Res (Pos) := '.';
4149 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
4150 -- Res (Len) := ')';
4155 -- Needless to say, multidimensional arrays of tasks are rare enough that
4156 -- the bulkiness of this code is not really a concern.
4158 function Build_Task_Array_Image
4162 Dyn : Boolean := False) return Node_Id
4164 Dims : constant Nat := Number_Dimensions (A_Type);
4165 -- Number of dimensions for array of tasks
4167 Temps : array (1 .. Dims) of Entity_Id;
4168 -- Array of temporaries to hold string for each index
4174 -- Total length of generated name
4177 -- Running index for substring assignments
4179 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4180 -- Name of enclosing variable, prefix of resulting name
4183 -- String to hold result
4186 -- Value of successive indexes
4189 -- Expression to compute total size of string
4192 -- Entity for name at one index position
4194 Decls : constant List_Id := New_List;
4195 Stats : constant List_Id := New_List;
4198 -- For a dynamic task, the name comes from the target variable. For a
4199 -- static one it is a formal of the enclosing init proc.
4202 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4204 Make_Object_Declaration (Loc,
4205 Defining_Identifier => Pref,
4206 Constant_Present => True,
4207 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4209 Make_String_Literal (Loc,
4210 Strval => String_From_Name_Buffer)));
4214 Make_Object_Renaming_Declaration (Loc,
4215 Defining_Identifier => Pref,
4216 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4217 Name => Make_Identifier (Loc, Name_uTask_Name)));
4220 Indx := First_Index (A_Type);
4221 Val := First (Expressions (Id_Ref));
4223 for J in 1 .. Dims loop
4224 T := Make_Temporary (Loc, 'T');
4228 Make_Object_Declaration (Loc,
4229 Defining_Identifier => T,
4230 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4231 Constant_Present => True,
4233 Make_Attribute_Reference (Loc,
4234 Attribute_Name => Name_Image,
4235 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
4236 Expressions => New_List (New_Copy_Tree (Val)))));
4242 Sum := Make_Integer_Literal (Loc, Dims + 1);
4248 Make_Attribute_Reference (Loc,
4249 Attribute_Name => Name_Length,
4250 Prefix => New_Occurrence_Of (Pref, Loc),
4251 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4253 for J in 1 .. Dims loop
4258 Make_Attribute_Reference (Loc,
4259 Attribute_Name => Name_Length,
4261 New_Occurrence_Of (Temps (J), Loc),
4262 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4265 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4267 Set_Character_Literal_Name (Get_Char_Code ('('));
4270 Make_Assignment_Statement (Loc,
4272 Make_Indexed_Component (Loc,
4273 Prefix => New_Occurrence_Of (Res, Loc),
4274 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4276 Make_Character_Literal (Loc,
4278 Char_Literal_Value => UI_From_CC (Get_Char_Code ('(')))));
4281 Make_Assignment_Statement (Loc,
4282 Name => New_Occurrence_Of (Pos, Loc),
4285 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4286 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4288 for J in 1 .. Dims loop
4291 Make_Assignment_Statement (Loc,
4294 Prefix => New_Occurrence_Of (Res, Loc),
4297 Low_Bound => New_Occurrence_Of (Pos, Loc),
4299 Make_Op_Subtract (Loc,
4302 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4304 Make_Attribute_Reference (Loc,
4305 Attribute_Name => Name_Length,
4307 New_Occurrence_Of (Temps (J), Loc),
4309 New_List (Make_Integer_Literal (Loc, 1)))),
4310 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
4312 Expression => New_Occurrence_Of (Temps (J), Loc)));
4316 Make_Assignment_Statement (Loc,
4317 Name => New_Occurrence_Of (Pos, Loc),
4320 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4322 Make_Attribute_Reference (Loc,
4323 Attribute_Name => Name_Length,
4324 Prefix => New_Occurrence_Of (Temps (J), Loc),
4326 New_List (Make_Integer_Literal (Loc, 1))))));
4328 Set_Character_Literal_Name (Get_Char_Code (','));
4331 Make_Assignment_Statement (Loc,
4332 Name => Make_Indexed_Component (Loc,
4333 Prefix => New_Occurrence_Of (Res, Loc),
4334 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4336 Make_Character_Literal (Loc,
4338 Char_Literal_Value => UI_From_CC (Get_Char_Code (',')))));
4341 Make_Assignment_Statement (Loc,
4342 Name => New_Occurrence_Of (Pos, Loc),
4345 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4346 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4350 Set_Character_Literal_Name (Get_Char_Code (')'));
4353 Make_Assignment_Statement (Loc,
4355 Make_Indexed_Component (Loc,
4356 Prefix => New_Occurrence_Of (Res, Loc),
4357 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
4359 Make_Character_Literal (Loc,
4361 Char_Literal_Value => UI_From_CC (Get_Char_Code (')')))));
4362 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4363 end Build_Task_Array_Image;
4365 ----------------------------
4366 -- Build_Task_Image_Decls --
4367 ----------------------------
4369 function Build_Task_Image_Decls
4373 In_Init_Proc : Boolean := False) return List_Id
4375 Decls : constant List_Id := New_List;
4376 T_Id : Entity_Id := Empty;
4378 Expr : Node_Id := Empty;
4379 Fun : Node_Id := Empty;
4380 Is_Dyn : constant Boolean :=
4381 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
4383 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
4385 Component_Suffix_Index : constant Int :=
4386 (if In_Init_Proc then -1 else 0);
4387 -- If an init proc calls Build_Task_Image_Decls twice for its
4388 -- _Parent component (to split early/late initialization), we don't
4389 -- want two decls with the same name. Hence, the -1 suffix.
4392 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
4393 -- generate a dummy declaration only.
4395 if Restriction_Active (No_Implicit_Heap_Allocations)
4396 or else Global_Discard_Names
4398 T_Id := Make_Temporary (Loc, 'J');
4403 Make_Object_Declaration (Loc,
4404 Defining_Identifier => T_Id,
4405 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4407 Make_String_Literal (Loc,
4408 Strval => String_From_Name_Buffer)));
4411 if Nkind (Id_Ref) = N_Identifier
4412 or else Nkind (Id_Ref) = N_Defining_Identifier
4414 -- For a simple variable, the image of the task is built from
4415 -- the name of the variable. To avoid possible conflict with the
4416 -- anonymous type created for a single protected object, add a
4420 Make_Defining_Identifier (Loc,
4421 New_External_Name (Chars (Id_Ref), 'T', 1));
4423 Get_Name_String (Chars (Id_Ref));
4426 Make_String_Literal (Loc,
4427 Strval => String_From_Name_Buffer);
4429 elsif Nkind (Id_Ref) = N_Selected_Component then
4431 Make_Defining_Identifier (Loc,
4432 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T',
4433 Suffix_Index => Component_Suffix_Index));
4434 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
4436 elsif Nkind (Id_Ref) = N_Indexed_Component then
4438 Make_Defining_Identifier (Loc,
4439 New_External_Name (Chars (A_Type), 'N'));
4441 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
4445 if Present (Fun) then
4446 Append (Fun, Decls);
4447 Expr := Make_Function_Call (Loc,
4448 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
4450 if not In_Init_Proc then
4451 Set_Uses_Sec_Stack (Defining_Entity (Fun));
4455 Decl := Make_Object_Declaration (Loc,
4456 Defining_Identifier => T_Id,
4457 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4458 Constant_Present => True,
4459 Expression => Expr);
4461 Append (Decl, Decls);
4463 end Build_Task_Image_Decls;
4465 -------------------------------
4466 -- Build_Task_Image_Function --
4467 -------------------------------
4469 function Build_Task_Image_Function
4473 Res : Entity_Id) return Node_Id
4479 Make_Simple_Return_Statement (Loc,
4480 Expression => New_Occurrence_Of (Res, Loc)));
4482 Spec := Make_Function_Specification (Loc,
4483 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
4484 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
4486 -- Calls to 'Image use the secondary stack, which must be cleaned up
4487 -- after the task name is built.
4489 return Make_Subprogram_Body (Loc,
4490 Specification => Spec,
4491 Declarations => Decls,
4492 Handled_Statement_Sequence =>
4493 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
4494 end Build_Task_Image_Function;
4496 -----------------------------
4497 -- Build_Task_Image_Prefix --
4498 -----------------------------
4500 procedure Build_Task_Image_Prefix
4502 Len : out Entity_Id;
4503 Res : out Entity_Id;
4504 Pos : out Entity_Id;
4511 Len := Make_Temporary (Loc, 'L', Sum);
4514 Make_Object_Declaration (Loc,
4515 Defining_Identifier => Len,
4516 Constant_Present => True,
4517 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4518 Expression => Sum));
4520 Res := Make_Temporary (Loc, 'R');
4523 Make_Object_Declaration (Loc,
4524 Defining_Identifier => Res,
4525 Object_Definition =>
4526 Make_Subtype_Indication (Loc,
4527 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4529 Make_Index_Or_Discriminant_Constraint (Loc,
4533 Low_Bound => Make_Integer_Literal (Loc, 1),
4534 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4536 -- Indicate that the result is an internal temporary, so it does not
4537 -- receive a bogus initialization when declaration is expanded. This
4538 -- is both efficient, and prevents anomalies in the handling of
4539 -- dynamic objects on the secondary stack.
4541 Set_Is_Internal (Res);
4542 Pos := Make_Temporary (Loc, 'P');
4545 Make_Object_Declaration (Loc,
4546 Defining_Identifier => Pos,
4547 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4549 -- Pos := Prefix'Length;
4552 Make_Assignment_Statement (Loc,
4553 Name => New_Occurrence_Of (Pos, Loc),
4555 Make_Attribute_Reference (Loc,
4556 Attribute_Name => Name_Length,
4557 Prefix => New_Occurrence_Of (Prefix, Loc),
4558 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4560 -- Res (1 .. Pos) := Prefix;
4563 Make_Assignment_Statement (Loc,
4566 Prefix => New_Occurrence_Of (Res, Loc),
4569 Low_Bound => Make_Integer_Literal (Loc, 1),
4570 High_Bound => New_Occurrence_Of (Pos, Loc))),
4572 Expression => New_Occurrence_Of (Prefix, Loc)));
4575 Make_Assignment_Statement (Loc,
4576 Name => New_Occurrence_Of (Pos, Loc),
4579 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4580 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4581 end Build_Task_Image_Prefix;
4583 -----------------------------
4584 -- Build_Task_Record_Image --
4585 -----------------------------
4587 function Build_Task_Record_Image
4590 Dyn : Boolean := False) return Node_Id
4593 -- Total length of generated name
4596 -- Index into result
4599 -- String to hold result
4601 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4602 -- Name of enclosing variable, prefix of resulting name
4605 -- Expression to compute total size of string
4608 -- Entity for selector name
4610 Decls : constant List_Id := New_List;
4611 Stats : constant List_Id := New_List;
4614 -- For a dynamic task, the name comes from the target variable. For a
4615 -- static one it is a formal of the enclosing init proc.
4618 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4620 Make_Object_Declaration (Loc,
4621 Defining_Identifier => Pref,
4622 Constant_Present => True,
4623 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4625 Make_String_Literal (Loc,
4626 Strval => String_From_Name_Buffer)));
4630 Make_Object_Renaming_Declaration (Loc,
4631 Defining_Identifier => Pref,
4632 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4633 Name => Make_Identifier (Loc, Name_uTask_Name)));
4636 Sel := Make_Temporary (Loc, 'S');
4638 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4641 Make_Object_Declaration (Loc,
4642 Defining_Identifier => Sel,
4643 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4645 Make_String_Literal (Loc,
4646 Strval => String_From_Name_Buffer)));
4648 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4654 Make_Attribute_Reference (Loc,
4655 Attribute_Name => Name_Length,
4657 New_Occurrence_Of (Pref, Loc),
4658 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4660 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4662 Set_Character_Literal_Name (Get_Char_Code ('.'));
4664 -- Res (Pos) := '.';
4667 Make_Assignment_Statement (Loc,
4668 Name => Make_Indexed_Component (Loc,
4669 Prefix => New_Occurrence_Of (Res, Loc),
4670 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4672 Make_Character_Literal (Loc,
4674 Char_Literal_Value =>
4675 UI_From_CC (Get_Char_Code ('.')))));
4678 Make_Assignment_Statement (Loc,
4679 Name => New_Occurrence_Of (Pos, Loc),
4682 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4683 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4685 -- Res (Pos .. Len) := Selector;
4688 Make_Assignment_Statement (Loc,
4689 Name => Make_Slice (Loc,
4690 Prefix => New_Occurrence_Of (Res, Loc),
4693 Low_Bound => New_Occurrence_Of (Pos, Loc),
4694 High_Bound => New_Occurrence_Of (Len, Loc))),
4695 Expression => New_Occurrence_Of (Sel, Loc)));
4697 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4698 end Build_Task_Record_Image;
4700 ---------------------------------------
4701 -- Build_Transient_Object_Statements --
4702 ---------------------------------------
4704 procedure Build_Transient_Object_Statements
4705 (Obj_Decl : Node_Id;
4706 Fin_Call : out Node_Id;
4707 Hook_Assign : out Node_Id;
4708 Hook_Clear : out Node_Id;
4709 Hook_Decl : out Node_Id;
4710 Ptr_Decl : out Node_Id;
4711 Finalize_Obj : Boolean := True)
4713 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4714 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4715 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4717 Desig_Typ : Entity_Id;
4718 Hook_Expr : Node_Id;
4719 Hook_Id : Entity_Id;
4721 Ptr_Typ : Entity_Id;
4724 -- Recover the type of the object
4726 Desig_Typ := Obj_Typ;
4728 if Is_Access_Type (Desig_Typ) then
4729 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4732 -- Create an access type which provides a reference to the transient
4733 -- object. Generate:
4735 -- type Ptr_Typ is access all Desig_Typ;
4737 Ptr_Typ := Make_Temporary (Loc, 'A');
4738 Mutate_Ekind (Ptr_Typ, E_General_Access_Type);
4739 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4742 Make_Full_Type_Declaration (Loc,
4743 Defining_Identifier => Ptr_Typ,
4745 Make_Access_To_Object_Definition (Loc,
4746 All_Present => True,
4747 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4749 -- Create a temporary check which acts as a hook to the transient
4750 -- object. Generate:
4752 -- Hook : Ptr_Typ := null;
4754 Hook_Id := Make_Temporary (Loc, 'T');
4755 Mutate_Ekind (Hook_Id, E_Variable);
4756 Set_Etype (Hook_Id, Ptr_Typ);
4759 Make_Object_Declaration (Loc,
4760 Defining_Identifier => Hook_Id,
4761 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4762 Expression => Make_Null (Loc));
4764 -- Mark the temporary as a hook. This signals the machinery in
4765 -- Build_Finalizer to recognize this special case.
4767 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4769 -- Hook the transient object to the temporary. Generate:
4771 -- Hook := Ptr_Typ (Obj_Id);
4773 -- Hool := Obj_Id'Unrestricted_Access;
4775 if Is_Access_Type (Obj_Typ) then
4777 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4780 Make_Attribute_Reference (Loc,
4781 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4782 Attribute_Name => Name_Unrestricted_Access);
4786 Make_Assignment_Statement (Loc,
4787 Name => New_Occurrence_Of (Hook_Id, Loc),
4788 Expression => Hook_Expr);
4790 -- Crear the hook prior to finalizing the object. Generate:
4795 Make_Assignment_Statement (Loc,
4796 Name => New_Occurrence_Of (Hook_Id, Loc),
4797 Expression => Make_Null (Loc));
4799 -- Finalize the object. Generate:
4801 -- [Deep_]Finalize (Obj_Ref[.all]);
4803 if Finalize_Obj then
4804 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4806 if Is_Access_Type (Obj_Typ) then
4807 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4808 Set_Etype (Obj_Ref, Desig_Typ);
4813 (Obj_Ref => Obj_Ref,
4816 -- Otherwise finalize the hook. Generate:
4818 -- [Deep_]Finalize (Hook.all);
4824 Make_Explicit_Dereference (Loc,
4825 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4828 end Build_Transient_Object_Statements;
4830 -----------------------------
4831 -- Check_Float_Op_Overflow --
4832 -----------------------------
4834 procedure Check_Float_Op_Overflow (N : Node_Id) is
4836 -- Return if no check needed
4838 if not Is_Floating_Point_Type (Etype (N))
4839 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4841 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4842 -- and do not expand the code for float overflow checking.
4844 or else CodePeer_Mode
4849 -- Otherwise we replace the expression by
4851 -- do Tnn : constant ftype := expression;
4852 -- constraint_error when not Tnn'Valid;
4856 Loc : constant Source_Ptr := Sloc (N);
4857 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4858 Typ : constant Entity_Id := Etype (N);
4861 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4862 -- right here. We also set the node as analyzed to prevent infinite
4863 -- recursion from repeating the operation in the expansion.
4865 Set_Do_Overflow_Check (N, False);
4866 Set_Analyzed (N, True);
4868 -- Do the rewrite to include the check
4871 Make_Expression_With_Actions (Loc,
4872 Actions => New_List (
4873 Make_Object_Declaration (Loc,
4874 Defining_Identifier => Tnn,
4875 Object_Definition => New_Occurrence_Of (Typ, Loc),
4876 Constant_Present => True,
4877 Expression => Relocate_Node (N)),
4878 Make_Raise_Constraint_Error (Loc,
4882 Make_Attribute_Reference (Loc,
4883 Prefix => New_Occurrence_Of (Tnn, Loc),
4884 Attribute_Name => Name_Valid)),
4885 Reason => CE_Overflow_Check_Failed)),
4886 Expression => New_Occurrence_Of (Tnn, Loc)));
4888 Analyze_And_Resolve (N, Typ);
4890 end Check_Float_Op_Overflow;
4892 ----------------------------------
4893 -- Component_May_Be_Bit_Aligned --
4894 ----------------------------------
4896 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4900 -- If no component clause, then everything is fine, since the back end
4901 -- never misaligns from byte boundaries by default, even if there is a
4902 -- pragma Pack for the record.
4904 if No (Comp) or else No (Component_Clause (Comp)) then
4908 UT := Underlying_Type (Etype (Comp));
4910 -- It is only array and record types that cause trouble
4912 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4915 -- If we know that we have a small (at most the maximum integer size)
4916 -- record or bit-packed array, then everything is fine, since the back
4917 -- end can handle these cases correctly.
4919 elsif Known_Esize (Comp)
4920 and then Esize (Comp) <= System_Max_Integer_Size
4921 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4925 elsif not Known_Normalized_First_Bit (Comp) then
4928 -- Otherwise if the component is not byte aligned, we know we have the
4929 -- nasty unaligned case.
4931 elsif Normalized_First_Bit (Comp) /= Uint_0
4932 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4936 -- If we are large and byte aligned, then OK at this level
4941 end Component_May_Be_Bit_Aligned;
4943 -------------------------------
4944 -- Convert_To_Actual_Subtype --
4945 -------------------------------
4947 procedure Convert_To_Actual_Subtype (Exp : Node_Id) is
4951 Act_ST := Get_Actual_Subtype (Exp);
4953 if Act_ST = Etype (Exp) then
4956 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4957 Analyze_And_Resolve (Exp, Act_ST);
4959 end Convert_To_Actual_Subtype;
4961 -----------------------------------
4962 -- Corresponding_Runtime_Package --
4963 -----------------------------------
4965 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4966 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4967 -- Return True if protected type T has one entry and the maximum queue
4970 --------------------------------
4971 -- Has_One_Entry_And_No_Queue --
4972 --------------------------------
4974 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4976 Is_First : Boolean := True;
4979 Item := First_Entity (T);
4980 while Present (Item) loop
4981 if Is_Entry (Item) then
4983 -- The protected type has more than one entry
4985 if not Is_First then
4989 -- The queue length is not one
4991 if not Restriction_Active (No_Entry_Queue)
4992 and then Get_Max_Queue_Length (Item) /= Uint_1
5004 end Has_One_Entry_And_No_Queue;
5008 Pkg_Id : RTU_Id := RTU_Null;
5010 -- Start of processing for Corresponding_Runtime_Package
5013 pragma Assert (Is_Concurrent_Type (Typ));
5015 if Is_Protected_Type (Typ) then
5016 if Has_Entries (Typ)
5018 -- A protected type without entries that covers an interface and
5019 -- overrides the abstract routines with protected procedures is
5020 -- considered equivalent to a protected type with entries in the
5021 -- context of dispatching select statements. It is sufficient to
5022 -- check for the presence of an interface list in the declaration
5023 -- node to recognize this case.
5025 or else Present (Interface_List (Parent (Typ)))
5027 -- Protected types with interrupt handlers (when not using a
5028 -- restricted profile) are also considered equivalent to
5029 -- protected types with entries. The types which are used
5030 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
5031 -- are derived from Protection_Entries.
5033 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
5034 or else Has_Interrupt_Handler (Typ)
5037 or else Restriction_Active (No_Select_Statements) = False
5038 or else not Has_One_Entry_And_No_Queue (Typ)
5039 or else (Has_Attach_Handler (Typ)
5040 and then not Restricted_Profile)
5042 Pkg_Id := System_Tasking_Protected_Objects_Entries;
5044 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
5048 Pkg_Id := System_Tasking_Protected_Objects;
5053 end Corresponding_Runtime_Package;
5055 -----------------------------------
5056 -- Current_Sem_Unit_Declarations --
5057 -----------------------------------
5059 function Current_Sem_Unit_Declarations return List_Id is
5060 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
5064 -- If the current unit is a package body, locate the visible
5065 -- declarations of the package spec.
5067 if Nkind (U) = N_Package_Body then
5068 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
5071 if Nkind (U) = N_Package_Declaration then
5072 U := Specification (U);
5073 Decls := Visible_Declarations (U);
5077 Set_Visible_Declarations (U, Decls);
5081 Decls := Declarations (U);
5085 Set_Declarations (U, Decls);
5090 end Current_Sem_Unit_Declarations;
5092 -----------------------
5093 -- Duplicate_Subexpr --
5094 -----------------------
5096 function Duplicate_Subexpr
5098 Name_Req : Boolean := False;
5099 Renaming_Req : Boolean := False) return Node_Id
5102 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
5103 return New_Copy_Tree (Exp);
5104 end Duplicate_Subexpr;
5106 ---------------------------------
5107 -- Duplicate_Subexpr_No_Checks --
5108 ---------------------------------
5110 function Duplicate_Subexpr_No_Checks
5112 Name_Req : Boolean := False;
5113 Renaming_Req : Boolean := False;
5114 Related_Id : Entity_Id := Empty;
5115 Is_Low_Bound : Boolean := False;
5116 Is_High_Bound : Boolean := False) return Node_Id
5123 Name_Req => Name_Req,
5124 Renaming_Req => Renaming_Req,
5125 Related_Id => Related_Id,
5126 Is_Low_Bound => Is_Low_Bound,
5127 Is_High_Bound => Is_High_Bound);
5129 New_Exp := New_Copy_Tree (Exp);
5130 Remove_Checks (New_Exp);
5132 end Duplicate_Subexpr_No_Checks;
5134 -----------------------------------
5135 -- Duplicate_Subexpr_Move_Checks --
5136 -----------------------------------
5138 function Duplicate_Subexpr_Move_Checks
5140 Name_Req : Boolean := False;
5141 Renaming_Req : Boolean := False) return Node_Id
5146 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
5147 New_Exp := New_Copy_Tree (Exp);
5148 Remove_Checks (Exp);
5150 end Duplicate_Subexpr_Move_Checks;
5152 -------------------------
5153 -- Enclosing_Init_Proc --
5154 -------------------------
5156 function Enclosing_Init_Proc return Entity_Id is
5161 while Present (S) and then S /= Standard_Standard loop
5162 if Is_Init_Proc (S) then
5170 end Enclosing_Init_Proc;
5172 --------------------
5173 -- Ensure_Defined --
5174 --------------------
5176 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
5180 -- An itype reference must only be created if this is a local itype, so
5181 -- that gigi can elaborate it on the proper objstack.
5183 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
5184 IR := Make_Itype_Reference (Sloc (N));
5185 Set_Itype (IR, Typ);
5186 Insert_Action (N, IR);
5190 --------------------
5191 -- Entry_Names_OK --
5192 --------------------
5194 function Entry_Names_OK return Boolean is
5197 not Restricted_Profile
5198 and then not Global_Discard_Names
5199 and then not Restriction_Active (No_Implicit_Heap_Allocations)
5200 and then not Restriction_Active (No_Local_Allocators);
5207 procedure Evaluate_Name (Nam : Node_Id) is
5210 -- For an aggregate, force its evaluation
5213 Force_Evaluation (Nam);
5215 -- For an attribute reference or an indexed component, evaluate the
5216 -- prefix, which is itself a name, recursively, and then force the
5217 -- evaluation of all the subscripts (or attribute expressions).
5219 when N_Attribute_Reference
5220 | N_Indexed_Component
5222 Evaluate_Name (Prefix (Nam));
5228 E := First (Expressions (Nam));
5229 while Present (E) loop
5230 Force_Evaluation (E);
5232 if Is_Rewrite_Substitution (E) then
5234 (E, Do_Range_Check (Original_Node (E)));
5241 -- For an explicit dereference, we simply force the evaluation of
5242 -- the name expression. The dereference provides a value that is the
5243 -- address for the renamed object, and it is precisely this value
5244 -- that we want to preserve.
5246 when N_Explicit_Dereference =>
5247 Force_Evaluation (Prefix (Nam));
5249 -- For a function call, we evaluate the call; same for an operator
5251 when N_Function_Call
5254 Force_Evaluation (Nam);
5256 -- For a qualified expression, we evaluate the expression
5258 when N_Qualified_Expression =>
5259 Evaluate_Name (Expression (Nam));
5261 -- For a selected component, we simply evaluate the prefix
5263 when N_Selected_Component =>
5264 Evaluate_Name (Prefix (Nam));
5266 -- For a slice, we evaluate the prefix, as for the indexed component
5267 -- case and then, if there is a range present, either directly or as
5268 -- the constraint of a discrete subtype indication, we evaluate the
5269 -- two bounds of this range.
5272 Evaluate_Name (Prefix (Nam));
5273 Evaluate_Slice_Bounds (Nam);
5275 -- For a type conversion, the expression of the conversion must be
5276 -- the name of an object, and we simply need to evaluate this name.
5278 when N_Type_Conversion =>
5279 Evaluate_Name (Expression (Nam));
5281 -- The remaining cases are direct name and character literal. In all
5282 -- these cases, we do nothing, since we want to reevaluate each time
5283 -- the renamed object is used. ??? There are more remaining cases, at
5284 -- least in the GNATprove_Mode, where this routine is called in more
5285 -- contexts than in GNAT.
5292 ---------------------------
5293 -- Evaluate_Slice_Bounds --
5294 ---------------------------
5296 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
5297 DR : constant Node_Id := Discrete_Range (Slice);
5302 if Nkind (DR) = N_Range then
5303 Force_Evaluation (Low_Bound (DR));
5304 Force_Evaluation (High_Bound (DR));
5306 elsif Nkind (DR) = N_Subtype_Indication then
5307 Constr := Constraint (DR);
5309 if Nkind (Constr) = N_Range_Constraint then
5310 Rexpr := Range_Expression (Constr);
5312 Force_Evaluation (Low_Bound (Rexpr));
5313 Force_Evaluation (High_Bound (Rexpr));
5316 end Evaluate_Slice_Bounds;
5318 ---------------------
5319 -- Evolve_And_Then --
5320 ---------------------
5322 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
5328 Make_And_Then (Sloc (Cond1),
5330 Right_Opnd => Cond1);
5332 end Evolve_And_Then;
5334 --------------------
5335 -- Evolve_Or_Else --
5336 --------------------
5338 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
5344 Make_Or_Else (Sloc (Cond1),
5346 Right_Opnd => Cond1);
5350 -------------------------------
5351 -- Expand_Sliding_Conversion --
5352 -------------------------------
5354 procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id) is
5356 pragma Assert (Is_Array_Type (Arr_Typ)
5357 and then not Is_Constrained (Arr_Typ)
5358 and then Is_Fixed_Lower_Bound_Array_Subtype (Arr_Typ));
5360 Constraints : List_Id;
5361 Index : Node_Id := First_Index (Arr_Typ);
5362 Loc : constant Source_Ptr := Sloc (N);
5363 Subt_Decl : Node_Id;
5366 Subt_High : Node_Id;
5368 Act_Subt : Entity_Id;
5369 Act_Index : Node_Id;
5372 Adjust_Incr : Node_Id;
5373 Dimension : Int := 0;
5374 All_FLBs_Match : Boolean := True;
5377 -- This procedure is called during semantic analysis, and we only expand
5378 -- a sliding conversion when Expander_Active, to avoid doing it during
5379 -- preanalysis (which can lead to problems with the target subtype not
5380 -- getting properly expanded during later full analysis). Also, sliding
5381 -- should never be needed for string literals, because their bounds are
5382 -- determined directly based on the fixed lower bound of Arr_Typ and
5385 if Expander_Active and then Nkind (N) /= N_String_Literal then
5386 Constraints := New_List;
5388 Act_Subt := Get_Actual_Subtype (N);
5389 Act_Index := First_Index (Act_Subt);
5391 -- Loop over the indexes of the fixed-lower-bound array type or
5392 -- subtype to build up an index constraint for constructing the
5393 -- subtype that will be the target of a conversion of the array
5394 -- object that may need a sliding conversion.
5396 while Present (Index) loop
5397 pragma Assert (Present (Act_Index));
5399 Dimension := Dimension + 1;
5401 Get_Index_Bounds (Act_Index, Act_Low, Act_High);
5403 -- If Index defines a normal unconstrained range (range <>),
5404 -- then we will simply use the bounds of the actual subtype's
5405 -- corresponding index range.
5407 if not Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) then
5408 Subt_Low := Act_Low;
5409 Subt_High := Act_High;
5411 -- Otherwise, a range will be created with a low bound given by
5412 -- the fixed lower bound of the array subtype's index, and with
5413 -- high bound given by (Actual'Length + fixed lower bound - 1).
5416 if Nkind (Index) = N_Subtype_Indication then
5419 (Low_Bound (Range_Expression (Constraint (Index))));
5421 pragma Assert (Nkind (Index) = N_Range);
5423 Subt_Low := New_Copy_Tree (Low_Bound (Index));
5426 -- If either we have a nonstatic lower bound, or the target and
5427 -- source subtypes are statically known to have unequal lower
5428 -- bounds, then we will need to make a subtype conversion to
5429 -- slide the bounds. However, if all of the indexes' lower
5430 -- bounds are static and known to be equal (the common case),
5431 -- then no conversion will be needed, and we'll end up not
5432 -- creating the subtype or the conversion (though we still
5433 -- build up the index constraint, which will simply be unused).
5435 if not (Compile_Time_Known_Value (Subt_Low)
5436 and then Compile_Time_Known_Value (Act_Low))
5437 or else Expr_Value (Subt_Low) /= Expr_Value (Act_Low)
5439 All_FLBs_Match := False;
5442 -- Apply 'Pos to lower bound, which may be of an enumeration
5443 -- type, before subtracting.
5446 Make_Op_Subtract (Loc,
5447 Make_Attribute_Reference (Loc,
5449 New_Occurrence_Of (Etype (Act_Index), Loc),
5453 New_List (New_Copy_Tree (Subt_Low))),
5454 Make_Integer_Literal (Loc, 1));
5456 -- Apply 'Val to the result of adding the increment to the
5457 -- length, to handle indexes of enumeration types.
5460 Make_Attribute_Reference (Loc,
5462 New_Occurrence_Of (Etype (Act_Index), Loc),
5466 New_List (Make_Op_Add (Loc,
5467 Make_Attribute_Reference (Loc,
5469 New_Occurrence_Of (Act_Subt, Loc),
5474 (Make_Integer_Literal
5479 Append (Make_Range (Loc, Subt_Low, Subt_High), Constraints);
5485 -- If for each index with a fixed lower bound (FLB), the lower bound
5486 -- of the corresponding index of the actual subtype is statically
5487 -- known be equal to the FLB, then a sliding conversion isn't needed
5488 -- at all, so just return without building a subtype or conversion.
5490 if All_FLBs_Match then
5494 -- A sliding conversion is needed, so create the target subtype using
5495 -- the index constraint created above, and rewrite the expression
5496 -- as a conversion to that subtype.
5498 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
5499 Set_Is_Internal (Subt);
5502 Make_Subtype_Declaration (Loc,
5503 Defining_Identifier => Subt,
5504 Subtype_Indication =>
5505 Make_Subtype_Indication (Loc,
5507 New_Occurrence_Of (Arr_Typ, Loc),
5509 Make_Index_Or_Discriminant_Constraint (Loc,
5510 Constraints => Constraints)));
5512 Mark_Rewrite_Insertion (Subt_Decl);
5514 -- The actual subtype is an Itype, so we analyze the declaration,
5515 -- but do not attach it to the tree.
5517 Set_Parent (Subt_Decl, N);
5518 Set_Is_Itype (Subt);
5519 Analyze (Subt_Decl, Suppress => All_Checks);
5520 Set_Associated_Node_For_Itype (Subt, N);
5521 Set_Has_Delayed_Freeze (Subt, False);
5523 -- We need to freeze the actual subtype immediately. This is needed
5524 -- because otherwise this Itype will not get frozen at all, and it is
5525 -- always safe to freeze on creation because any associated types
5526 -- must be frozen at this point.
5528 Freeze_Itype (Subt, N);
5531 Make_Type_Conversion (Loc,
5533 New_Occurrence_Of (Subt, Loc),
5534 Expression => Relocate_Node (N)));
5537 end Expand_Sliding_Conversion;
5539 -----------------------------------------
5540 -- Expand_Static_Predicates_In_Choices --
5541 -----------------------------------------
5543 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
5544 pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
5546 Choices : List_Id := Discrete_Choices (N);
5554 -- If this is an "others" alternative, we need to process any static
5555 -- predicates in its Others_Discrete_Choices.
5557 if Nkind (First (Choices)) = N_Others_Choice then
5558 Choices := Others_Discrete_Choices (First (Choices));
5561 Choice := First (Choices);
5562 while Present (Choice) loop
5563 Next_C := Next (Choice);
5565 -- Check for name of subtype with static predicate
5567 if Is_Entity_Name (Choice)
5568 and then Is_Type (Entity (Choice))
5569 and then Has_Predicates (Entity (Choice))
5571 -- Loop through entries in predicate list, converting to choices
5572 -- and inserting in the list before the current choice. Note that
5573 -- if the list is empty, corresponding to a False predicate, then
5574 -- no choices are inserted.
5576 P := First (Static_Discrete_Predicate (Entity (Choice)));
5577 while Present (P) loop
5579 -- If low bound and high bounds are equal, copy simple choice
5581 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
5582 C := New_Copy (Low_Bound (P));
5584 -- Otherwise copy a range
5590 -- Change Sloc to referencing choice (rather than the Sloc of
5591 -- the predicate declaration element itself).
5593 Set_Sloc (C, Sloc (Choice));
5594 Insert_Before (Choice, C);
5598 -- Delete the predicated entry
5603 -- Move to next choice to check
5608 Set_Has_SP_Choice (N, False);
5609 end Expand_Static_Predicates_In_Choices;
5611 ------------------------------
5612 -- Expand_Subtype_From_Expr --
5613 ------------------------------
5615 -- This function is applicable for both static and dynamic allocation of
5616 -- objects which are constrained by an initial expression. Basically it
5617 -- transforms an unconstrained subtype indication into a constrained one.
5619 -- The expression may also be transformed in certain cases in order to
5620 -- avoid multiple evaluation. In the static allocation case, the general
5625 -- is transformed into
5627 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
5629 -- Here are the main cases :
5631 -- <if Expr is a Slice>
5632 -- Val : T ([Index_Subtype (Expr)]) := Expr;
5634 -- <elsif Expr is a String Literal>
5635 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
5637 -- <elsif Expr is Constrained>
5638 -- subtype T is Type_Of_Expr
5641 -- <elsif Expr is an entity_name>
5642 -- Val : T (constraints taken from Expr) := Expr;
5645 -- type Axxx is access all T;
5646 -- Rval : Axxx := Expr'ref;
5647 -- Val : T (constraints taken from Rval) := Rval.all;
5649 -- ??? note: when the Expression is allocated in the secondary stack
5650 -- we could use it directly instead of copying it by declaring
5651 -- Val : T (...) renames Rval.all
5653 procedure Expand_Subtype_From_Expr
5655 Unc_Type : Entity_Id;
5656 Subtype_Indic : Node_Id;
5658 Related_Id : Entity_Id := Empty)
5660 Loc : constant Source_Ptr := Sloc (N);
5661 Exp_Typ : constant Entity_Id := Etype (Exp);
5665 -- In general we cannot build the subtype if expansion is disabled,
5666 -- because internal entities may not have been defined. However, to
5667 -- avoid some cascaded errors, we try to continue when the expression is
5668 -- an array (or string), because it is safe to compute the bounds. It is
5669 -- in fact required to do so even in a generic context, because there
5670 -- may be constants that depend on the bounds of a string literal, both
5671 -- standard string types and more generally arrays of characters.
5673 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is
5674 -- a static expression. In that case, the subtype will be constrained
5675 -- while the original type might be unconstrained, so expanding the type
5676 -- is necessary both for passing legality checks in GNAT and for precise
5677 -- analysis in GNATprove.
5679 if GNATprove_Mode and then not Is_Static_Expression (Exp) then
5683 if not Expander_Active
5684 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5689 if Nkind (Exp) = N_Slice then
5691 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5694 Rewrite (Subtype_Indic,
5695 Make_Subtype_Indication (Loc,
5696 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5698 Make_Index_Or_Discriminant_Constraint (Loc,
5699 Constraints => New_List
5700 (New_Occurrence_Of (Slice_Type, Loc)))));
5702 -- This subtype indication may be used later for constraint checks
5703 -- we better make sure that if a variable was used as a bound of
5704 -- the original slice, its value is frozen.
5706 Evaluate_Slice_Bounds (Exp);
5709 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5710 Rewrite (Subtype_Indic,
5711 Make_Subtype_Indication (Loc,
5712 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5714 Make_Index_Or_Discriminant_Constraint (Loc,
5715 Constraints => New_List (
5716 Make_Literal_Range (Loc,
5717 Literal_Typ => Exp_Typ)))));
5719 -- If the type of the expression is an internally generated type it
5720 -- may not be necessary to create a new subtype. However there are two
5721 -- exceptions: references to the current instances, and aliased array
5722 -- object declarations for which the back end has to create a template.
5724 elsif Is_Constrained (Exp_Typ)
5725 and then not Is_Class_Wide_Type (Unc_Type)
5727 (Nkind (N) /= N_Object_Declaration
5728 or else not Is_Entity_Name (Expression (N))
5729 or else not Comes_From_Source (Entity (Expression (N)))
5730 or else not Is_Array_Type (Exp_Typ)
5731 or else not Aliased_Present (N))
5733 if Is_Itype (Exp_Typ) then
5735 -- Within an initialization procedure, a selected component
5736 -- denotes a component of the enclosing record, and it appears as
5737 -- an actual in a call to its own initialization procedure. If
5738 -- this component depends on the outer discriminant, we must
5739 -- generate the proper actual subtype for it.
5741 if Nkind (Exp) = N_Selected_Component
5742 and then Within_Init_Proc
5745 Decl : constant Node_Id :=
5746 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5748 if Present (Decl) then
5749 Insert_Action (N, Decl);
5750 T := Defining_Identifier (Decl);
5756 -- No need to generate a new subtype
5763 T := Make_Temporary (Loc, 'T');
5766 Make_Subtype_Declaration (Loc,
5767 Defining_Identifier => T,
5768 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5770 -- This type is marked as an itype even though it has an explicit
5771 -- declaration since otherwise Is_Generic_Actual_Type can get
5772 -- set, resulting in the generation of spurious errors. (See
5773 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5776 Set_Associated_Node_For_Itype (T, Exp);
5779 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5781 -- Nothing needs to be done for private types with unknown discriminants
5782 -- if the underlying type is not an unconstrained composite type or it
5783 -- is an unchecked union.
5785 elsif Is_Private_Type (Unc_Type)
5786 and then Has_Unknown_Discriminants (Unc_Type)
5787 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5788 or else Is_Constrained (Underlying_Type (Unc_Type))
5789 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5793 -- Case of derived type with unknown discriminants where the parent type
5794 -- also has unknown discriminants.
5796 elsif Is_Record_Type (Unc_Type)
5797 and then not Is_Class_Wide_Type (Unc_Type)
5798 and then Has_Unknown_Discriminants (Unc_Type)
5799 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5801 -- Nothing to be done if no underlying record view available
5803 -- If this is a limited type derived from a type with unknown
5804 -- discriminants, do not expand either, so that subsequent expansion
5805 -- of the call can add build-in-place parameters to call.
5807 if No (Underlying_Record_View (Unc_Type))
5808 or else Is_Limited_Type (Unc_Type)
5812 -- Otherwise use the Underlying_Record_View to create the proper
5813 -- constrained subtype for an object of a derived type with unknown
5817 Remove_Side_Effects (Exp);
5818 Rewrite (Subtype_Indic,
5819 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5822 -- Renamings of class-wide interface types require no equivalent
5823 -- constrained type declarations because we only need to reference
5824 -- the tag component associated with the interface. The same is
5825 -- presumably true for class-wide types in general, so this test
5826 -- is broadened to include all class-wide renamings, which also
5827 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5828 -- (Is this really correct, or are there some cases of class-wide
5829 -- renamings that require action in this procedure???)
5832 and then Nkind (N) = N_Object_Renaming_Declaration
5833 and then Is_Class_Wide_Type (Unc_Type)
5837 -- In Ada 95 nothing to be done if the type of the expression is limited
5838 -- because in this case the expression cannot be copied, and its use can
5839 -- only be by reference.
5841 -- In Ada 2005 the context can be an object declaration whose expression
5842 -- is a function that returns in place. If the nominal subtype has
5843 -- unknown discriminants, the call still provides constraints on the
5844 -- object, and we have to create an actual subtype from it.
5846 -- If the type is class-wide, the expression is dynamically tagged and
5847 -- we do not create an actual subtype either. Ditto for an interface.
5848 -- For now this applies only if the type is immutably limited, and the
5849 -- function being called is build-in-place. This will have to be revised
5850 -- when build-in-place functions are generalized to other types.
5852 elsif Is_Limited_View (Exp_Typ)
5854 (Is_Class_Wide_Type (Exp_Typ)
5855 or else Is_Interface (Exp_Typ)
5856 or else not Has_Unknown_Discriminants (Exp_Typ)
5857 or else not Is_Composite_Type (Unc_Type))
5861 -- For limited objects initialized with build-in-place function calls,
5862 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5863 -- node in the expression initializing the object, which breaks the
5864 -- circuitry that detects and adds the additional arguments to the
5867 elsif Is_Build_In_Place_Function_Call (Exp) then
5870 -- If the expression is an uninitialized aggregate, no need to build
5871 -- a subtype from the expression, because this may require the use of
5872 -- dynamic memory to create the object.
5874 elsif Is_Uninitialized_Aggregate (Exp, Exp_Typ) then
5875 Rewrite (Subtype_Indic, New_Occurrence_Of (Etype (Exp), Sloc (N)));
5876 if Nkind (N) = N_Object_Declaration then
5877 Set_Expression (N, Empty);
5878 Set_No_Initialization (N);
5882 Remove_Side_Effects (Exp);
5883 Rewrite (Subtype_Indic,
5884 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5886 end Expand_Subtype_From_Expr;
5888 ---------------------------------------------
5889 -- Expression_Contains_Primitives_Calls_Of --
5890 ---------------------------------------------
5892 function Expression_Contains_Primitives_Calls_Of
5894 Typ : Entity_Id) return Boolean
5896 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5898 Calls_OK : Boolean := False;
5899 -- This flag is set to True when expression Expr contains at least one
5900 -- call to a nondispatching primitive function of Typ.
5902 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5903 -- Search for nondispatching calls to primitive functions of type Typ
5905 ----------------------------
5906 -- Search_Primitive_Calls --
5907 ----------------------------
5909 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5910 Disp_Typ : Entity_Id;
5914 -- Detect a function call that could denote a nondispatching
5915 -- primitive of the input type.
5917 if Nkind (N) = N_Function_Call
5918 and then Is_Entity_Name (Name (N))
5920 Subp := Entity (Name (N));
5922 -- Do not consider function calls with a controlling argument, as
5923 -- those are always dispatching calls.
5925 if Is_Dispatching_Operation (Subp)
5926 and then No (Controlling_Argument (N))
5928 Disp_Typ := Find_Dispatching_Type (Subp);
5930 -- To qualify as a suitable primitive, the dispatching type of
5931 -- the function must be the input type.
5933 if Present (Disp_Typ)
5934 and then Unique_Entity (Disp_Typ) = U_Typ
5938 -- There is no need to continue the traversal, as one such
5947 end Search_Primitive_Calls;
5949 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5951 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5954 Search_Calls (Expr);
5956 end Expression_Contains_Primitives_Calls_Of;
5958 ----------------------
5959 -- Finalize_Address --
5960 ----------------------
5962 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5963 Btyp : constant Entity_Id := Base_Type (Typ);
5964 Utyp : Entity_Id := Typ;
5967 -- Handle protected class-wide or task class-wide types
5969 if Is_Class_Wide_Type (Utyp) then
5970 if Is_Concurrent_Type (Root_Type (Utyp)) then
5971 Utyp := Root_Type (Utyp);
5973 elsif Is_Private_Type (Root_Type (Utyp))
5974 and then Present (Full_View (Root_Type (Utyp)))
5975 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5977 Utyp := Full_View (Root_Type (Utyp));
5981 -- Handle private types
5983 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5984 Utyp := Full_View (Utyp);
5987 -- Handle protected and task types
5989 if Is_Concurrent_Type (Utyp)
5990 and then Present (Corresponding_Record_Type (Utyp))
5992 Utyp := Corresponding_Record_Type (Utyp);
5995 Utyp := Underlying_Type (Base_Type (Utyp));
5997 -- Deal with untagged derivation of private views. If the parent is
5998 -- now known to be protected, the finalization routine is the one
5999 -- defined on the corresponding record of the ancestor (corresponding
6000 -- records do not automatically inherit operations, but maybe they
6003 if Is_Untagged_Derivation (Btyp) then
6004 if Is_Protected_Type (Btyp) then
6005 Utyp := Corresponding_Record_Type (Root_Type (Btyp));
6008 Utyp := Underlying_Type (Root_Type (Btyp));
6010 if Is_Protected_Type (Utyp) then
6011 Utyp := Corresponding_Record_Type (Utyp);
6016 -- If the underlying_type is a subtype, we are dealing with the
6017 -- completion of a private type. We need to access the base type and
6018 -- generate a conversion to it.
6020 if Utyp /= Base_Type (Utyp) then
6021 pragma Assert (Is_Private_Type (Typ));
6023 Utyp := Base_Type (Utyp);
6026 -- When dealing with an internally built full view for a type with
6027 -- unknown discriminants, use the original record type.
6029 if Is_Underlying_Record_View (Utyp) then
6030 Utyp := Etype (Utyp);
6033 return TSS (Utyp, TSS_Finalize_Address);
6034 end Finalize_Address;
6036 ------------------------
6037 -- Find_Interface_ADT --
6038 ------------------------
6040 function Find_Interface_ADT
6042 Iface : Entity_Id) return Elmt_Id
6045 Typ : Entity_Id := T;
6048 pragma Assert (Is_Interface (Iface));
6050 -- Handle private types
6052 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
6053 Typ := Full_View (Typ);
6056 -- Handle access types
6058 if Is_Access_Type (Typ) then
6059 Typ := Designated_Type (Typ);
6062 -- Handle task and protected types implementing interfaces
6064 if Is_Concurrent_Type (Typ) then
6065 Typ := Corresponding_Record_Type (Typ);
6069 (not Is_Class_Wide_Type (Typ)
6070 and then Ekind (Typ) /= E_Incomplete_Type);
6072 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
6073 return First_Elmt (Access_Disp_Table (Typ));
6076 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
6078 and then Present (Related_Type (Node (ADT)))
6079 and then Related_Type (Node (ADT)) /= Iface
6080 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
6081 Use_Full_View => True)
6086 pragma Assert (Present (Related_Type (Node (ADT))));
6089 end Find_Interface_ADT;
6091 ------------------------
6092 -- Find_Interface_Tag --
6093 ------------------------
6095 function Find_Interface_Tag
6097 Iface : Entity_Id) return Entity_Id
6099 AI_Tag : Entity_Id := Empty;
6100 Found : Boolean := False;
6101 Typ : Entity_Id := T;
6103 procedure Find_Tag (Typ : Entity_Id);
6104 -- Internal subprogram used to recursively climb to the ancestors
6110 procedure Find_Tag (Typ : Entity_Id) is
6115 -- This routine does not handle the case in which the interface is an
6116 -- ancestor of Typ. That case is handled by the enclosing subprogram.
6118 pragma Assert (Typ /= Iface);
6120 -- Climb to the root type handling private types
6122 if Present (Full_View (Etype (Typ))) then
6123 if Full_View (Etype (Typ)) /= Typ then
6124 Find_Tag (Full_View (Etype (Typ)));
6127 elsif Etype (Typ) /= Typ then
6128 Find_Tag (Etype (Typ));
6131 -- Traverse the list of interfaces implemented by the type
6134 and then Present (Interfaces (Typ))
6135 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
6137 -- Skip the tag associated with the primary table
6139 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
6140 pragma Assert (Present (AI_Tag));
6142 AI_Elmt := First_Elmt (Interfaces (Typ));
6143 while Present (AI_Elmt) loop
6144 AI := Node (AI_Elmt);
6147 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
6153 AI_Tag := Next_Tag_Component (AI_Tag);
6154 Next_Elmt (AI_Elmt);
6159 -- Start of processing for Find_Interface_Tag
6162 pragma Assert (Is_Interface (Iface));
6164 -- Handle access types
6166 if Is_Access_Type (Typ) then
6167 Typ := Designated_Type (Typ);
6170 -- Handle class-wide types
6172 if Is_Class_Wide_Type (Typ) then
6173 Typ := Root_Type (Typ);
6176 -- Handle private types
6178 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
6179 Typ := Full_View (Typ);
6182 -- Handle entities from the limited view
6184 if Ekind (Typ) = E_Incomplete_Type then
6185 pragma Assert (Present (Non_Limited_View (Typ)));
6186 Typ := Non_Limited_View (Typ);
6189 -- Handle task and protected types implementing interfaces
6191 if Is_Concurrent_Type (Typ) then
6192 Typ := Corresponding_Record_Type (Typ);
6195 -- If the interface is an ancestor of the type, then it shared the
6196 -- primary dispatch table.
6198 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
6199 return First_Tag_Component (Typ);
6201 -- Otherwise we need to search for its associated tag component
6207 end Find_Interface_Tag;
6209 ---------------------------
6210 -- Find_Optional_Prim_Op --
6211 ---------------------------
6213 function Find_Optional_Prim_Op
6214 (T : Entity_Id; Name : Name_Id) return Entity_Id
6217 Typ : Entity_Id := T;
6221 if Is_Class_Wide_Type (Typ) then
6222 Typ := Root_Type (Typ);
6225 Typ := Underlying_Type (Typ);
6227 -- Loop through primitive operations
6229 Prim := First_Elmt (Primitive_Operations (Typ));
6230 while Present (Prim) loop
6233 -- We can retrieve primitive operations by name if it is an internal
6234 -- name. For equality we must check that both of its operands have
6235 -- the same type, to avoid confusion with user-defined equalities
6236 -- than may have a asymmetric signature.
6238 exit when Chars (Op) = Name
6241 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
6246 return Node (Prim); -- Empty if not found
6247 end Find_Optional_Prim_Op;
6249 ---------------------------
6250 -- Find_Optional_Prim_Op --
6251 ---------------------------
6253 function Find_Optional_Prim_Op
6255 Name : TSS_Name_Type) return Entity_Id
6257 Inher_Op : Entity_Id := Empty;
6258 Own_Op : Entity_Id := Empty;
6259 Prim_Elmt : Elmt_Id;
6260 Prim_Id : Entity_Id;
6261 Typ : Entity_Id := T;
6264 if Is_Class_Wide_Type (Typ) then
6265 Typ := Root_Type (Typ);
6268 Typ := Underlying_Type (Typ);
6270 -- This search is based on the assertion that the dispatching version
6271 -- of the TSS routine always precedes the real primitive.
6273 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6274 while Present (Prim_Elmt) loop
6275 Prim_Id := Node (Prim_Elmt);
6277 if Is_TSS (Prim_Id, Name) then
6278 if Present (Alias (Prim_Id)) then
6279 Inher_Op := Prim_Id;
6285 Next_Elmt (Prim_Elmt);
6288 if Present (Own_Op) then
6290 elsif Present (Inher_Op) then
6295 end Find_Optional_Prim_Op;
6301 function Find_Prim_Op
6302 (T : Entity_Id; Name : Name_Id) return Entity_Id
6304 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
6307 raise Program_Error;
6317 function Find_Prim_Op
6319 Name : TSS_Name_Type) return Entity_Id
6321 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
6324 raise Program_Error;
6330 ----------------------------
6331 -- Find_Protection_Object --
6332 ----------------------------
6334 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
6339 while Present (S) loop
6340 if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure
6341 and then Present (Protection_Object (S))
6343 return Protection_Object (S);
6349 -- If we do not find a Protection object in the scope chain, then
6350 -- something has gone wrong, most likely the object was never created.
6352 raise Program_Error;
6353 end Find_Protection_Object;
6355 --------------------------
6356 -- Find_Protection_Type --
6357 --------------------------
6359 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
6361 Typ : Entity_Id := Conc_Typ;
6364 if Is_Concurrent_Type (Typ) then
6365 Typ := Corresponding_Record_Type (Typ);
6368 -- Since restriction violations are not considered serious errors, the
6369 -- expander remains active, but may leave the corresponding record type
6370 -- malformed. In such cases, component _object is not available so do
6373 if not Analyzed (Typ) then
6377 Comp := First_Component (Typ);
6378 while Present (Comp) loop
6379 if Chars (Comp) = Name_uObject then
6380 return Base_Type (Etype (Comp));
6383 Next_Component (Comp);
6386 -- The corresponding record of a protected type should always have an
6389 raise Program_Error;
6390 end Find_Protection_Type;
6392 function Find_Storage_Op
6394 Nam : Name_Id) return Entity_Id
6396 use Sem_Util.Storage_Model_Support;
6399 if Has_Storage_Model_Type_Aspect (Typ) then
6401 SMT_Op : constant Entity_Id :=
6402 Get_Storage_Model_Type_Entity (Typ, Nam);
6404 if not Present (SMT_Op) then
6405 raise Program_Error;
6411 -- Otherwise we assume that Typ is a descendant of Root_Storage_Pool
6414 return Find_Prim_Op (Typ, Nam);
6416 end Find_Storage_Op;
6418 -----------------------
6419 -- Find_Hook_Context --
6420 -----------------------
6422 function Find_Hook_Context (N : Node_Id) return Node_Id is
6426 Wrapped_Node : Node_Id;
6427 -- Note: if we are in a transient scope, we want to reuse it as
6428 -- the context for actions insertion, if possible. But if N is itself
6429 -- part of the stored actions for the current transient scope,
6430 -- then we need to insert at the appropriate (inner) location in
6431 -- the not as an action on Node_To_Be_Wrapped.
6433 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
6436 -- When the node is inside a case/if expression, the lifetime of any
6437 -- temporary controlled object is extended. Find a suitable insertion
6438 -- node by locating the topmost case or if expressions.
6440 if In_Cond_Expr then
6443 while Present (Par) loop
6444 if Nkind (Original_Node (Par)) in
6445 N_Case_Expression | N_If_Expression
6449 -- Prevent the search from going too far
6451 elsif Is_Body_Or_Package_Declaration (Par) then
6455 Par := Parent (Par);
6458 -- The topmost case or if expression is now recovered, but it may
6459 -- still not be the correct place to add generated code. Climb to
6460 -- find a parent that is part of a declarative or statement list,
6461 -- and is not a list of actuals in a call.
6464 while Present (Par) loop
6465 if Is_List_Member (Par)
6466 and then Nkind (Par) not in N_Component_Association
6467 | N_Discriminant_Association
6468 | N_Parameter_Association
6469 | N_Pragma_Argument_Association
6472 | N_Extension_Aggregate
6473 and then Nkind (Parent (Par)) not in N_Function_Call
6474 | N_Procedure_Call_Statement
6475 | N_Entry_Call_Statement
6480 -- Prevent the search from going too far
6482 elsif Is_Body_Or_Package_Declaration (Par) then
6486 Par := Parent (Par);
6493 while Present (Par) loop
6495 -- Keep climbing past various operators
6497 if Nkind (Parent (Par)) in N_Op
6498 or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else
6500 Par := Parent (Par);
6508 -- The node may be located in a pragma in which case return the
6511 -- pragma Precondition (... and then Ctrl_Func_Call ...);
6513 -- Similar case occurs when the node is related to an object
6514 -- declaration or assignment:
6516 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
6518 -- Another case to consider is when the node is part of a return
6521 -- return ... and then Ctrl_Func_Call ...;
6523 -- Another case is when the node acts as a formal in a procedure
6526 -- Proc (... and then Ctrl_Func_Call ...);
6528 if Scope_Is_Transient then
6529 Wrapped_Node := Node_To_Be_Wrapped;
6531 Wrapped_Node := Empty;
6534 while Present (Par) loop
6535 if Par = Wrapped_Node
6536 or else Nkind (Par) in N_Assignment_Statement
6537 | N_Object_Declaration
6539 | N_Procedure_Call_Statement
6540 | N_Simple_Return_Statement
6544 -- Prevent the search from going too far
6546 elsif Is_Body_Or_Package_Declaration (Par) then
6550 Par := Parent (Par);
6553 -- Return the topmost short circuit operator
6557 end Find_Hook_Context;
6559 ------------------------------
6560 -- Following_Address_Clause --
6561 ------------------------------
6563 function Following_Address_Clause (D : Node_Id) return Node_Id is
6564 Id : constant Entity_Id := Defining_Identifier (D);
6568 function Check_Decls (D : Node_Id) return Node_Id;
6569 -- This internal function differs from the main function in that it
6570 -- gets called to deal with a following package private part, and
6571 -- it checks declarations starting with D (the main function checks
6572 -- declarations following D). If D is Empty, then Empty is returned.
6578 function Check_Decls (D : Node_Id) return Node_Id is
6583 while Present (Decl) loop
6584 if Nkind (Decl) = N_At_Clause
6585 and then Chars (Identifier (Decl)) = Chars (Id)
6589 elsif Nkind (Decl) = N_Attribute_Definition_Clause
6590 and then Chars (Decl) = Name_Address
6591 and then Chars (Name (Decl)) = Chars (Id)
6599 -- Otherwise not found, return Empty
6604 -- Start of processing for Following_Address_Clause
6607 -- If parser detected no address clause for the identifier in question,
6608 -- then the answer is a quick NO, without the need for a search.
6610 if not Get_Name_Table_Boolean1 (Chars (Id)) then
6614 -- Otherwise search current declarative unit
6616 Result := Check_Decls (Next (D));
6618 if Present (Result) then
6622 -- Check for possible package private part following
6626 if Nkind (Par) = N_Package_Specification
6627 and then Visible_Declarations (Par) = List_Containing (D)
6628 and then Present (Private_Declarations (Par))
6630 -- Private part present, check declarations there
6632 return Check_Decls (First (Private_Declarations (Par)));
6635 -- No private part, clause not found, return Empty
6639 end Following_Address_Clause;
6641 ----------------------
6642 -- Force_Evaluation --
6643 ----------------------
6645 procedure Force_Evaluation
6647 Name_Req : Boolean := False;
6648 Related_Id : Entity_Id := Empty;
6649 Is_Low_Bound : Boolean := False;
6650 Is_High_Bound : Boolean := False;
6651 Discr_Number : Int := 0;
6652 Mode : Force_Evaluation_Mode := Relaxed)
6657 Name_Req => Name_Req,
6658 Variable_Ref => True,
6659 Renaming_Req => False,
6660 Related_Id => Related_Id,
6661 Is_Low_Bound => Is_Low_Bound,
6662 Is_High_Bound => Is_High_Bound,
6663 Discr_Number => Discr_Number,
6664 Check_Side_Effects =>
6665 Is_Static_Expression (Exp)
6666 or else Mode = Relaxed);
6667 end Force_Evaluation;
6669 ---------------------------------
6670 -- Fully_Qualified_Name_String --
6671 ---------------------------------
6673 function Fully_Qualified_Name_String
6675 Append_NUL : Boolean := True) return String_Id
6677 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6678 -- Compute recursively the qualified name without NUL at the end, adding
6679 -- it to the currently started string being generated
6681 ----------------------------------
6682 -- Internal_Full_Qualified_Name --
6683 ----------------------------------
6685 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6689 -- Deal properly with child units
6691 if Nkind (E) = N_Defining_Program_Unit_Name then
6692 Ent := Defining_Identifier (E);
6697 -- Compute qualification recursively (only "Standard" has no scope)
6699 if Present (Scope (Scope (Ent))) then
6700 Internal_Full_Qualified_Name (Scope (Ent));
6701 Store_String_Char (Get_Char_Code ('.'));
6704 -- Every entity should have a name except some expanded blocks
6705 -- don't bother about those.
6707 if Chars (Ent) = No_Name then
6711 -- Generates the entity name in upper case
6713 Get_Decoded_Name_String (Chars (Ent));
6714 Set_Casing (All_Upper_Case);
6715 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6717 end Internal_Full_Qualified_Name;
6719 -- Start of processing for Full_Qualified_Name
6723 Internal_Full_Qualified_Name (E);
6726 Store_String_Char (Get_Char_Code (ASCII.NUL));
6730 end Fully_Qualified_Name_String;
6732 ---------------------------------
6733 -- Get_Current_Value_Condition --
6734 ---------------------------------
6736 -- Note: the implementation of this procedure is very closely tied to the
6737 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6738 -- interpret Current_Value fields set by the Set procedure, so the two
6739 -- procedures need to be closely coordinated.
6741 procedure Get_Current_Value_Condition
6746 Loc : constant Source_Ptr := Sloc (Var);
6747 Ent : constant Entity_Id := Entity (Var);
6749 procedure Process_Current_Value_Condition (N : Node_Id; S : Boolean);
6750 -- N is an expression which holds either True (S = True) or False (S =
6751 -- False) in the condition. This procedure digs out the expression and
6752 -- if it refers to Ent, sets Op and Val appropriately.
6754 -------------------------------------
6755 -- Process_Current_Value_Condition --
6756 -------------------------------------
6758 procedure Process_Current_Value_Condition
6763 Prev_Cond : Node_Id;
6773 -- Deal with NOT operators, inverting sense
6775 while Nkind (Cond) = N_Op_Not loop
6776 Cond := Right_Opnd (Cond);
6780 -- Deal with conversions, qualifications, and expressions with
6783 while Nkind (Cond) in N_Type_Conversion
6784 | N_Qualified_Expression
6785 | N_Expression_With_Actions
6787 Cond := Expression (Cond);
6790 exit when Cond = Prev_Cond;
6793 -- Deal with AND THEN and AND cases
6795 if Nkind (Cond) in N_And_Then | N_Op_And then
6797 -- Don't ever try to invert a condition that is of the form of an
6798 -- AND or AND THEN (since we are not doing sufficiently general
6799 -- processing to allow this).
6801 if Sens = False then
6807 -- Recursively process AND and AND THEN branches
6809 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6810 pragma Assert (Op'Valid);
6812 if Op /= N_Empty then
6816 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6819 -- Case of relational operator
6821 elsif Nkind (Cond) in N_Op_Compare then
6824 -- Invert sense of test if inverted test
6826 if Sens = False then
6828 when N_Op_Eq => Op := N_Op_Ne;
6829 when N_Op_Ne => Op := N_Op_Eq;
6830 when N_Op_Lt => Op := N_Op_Ge;
6831 when N_Op_Gt => Op := N_Op_Le;
6832 when N_Op_Le => Op := N_Op_Gt;
6833 when N_Op_Ge => Op := N_Op_Lt;
6834 when others => raise Program_Error;
6838 -- Case of entity op value
6840 if Is_Entity_Name (Left_Opnd (Cond))
6841 and then Ent = Entity (Left_Opnd (Cond))
6842 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6844 Val := Right_Opnd (Cond);
6846 -- Case of value op entity
6848 elsif Is_Entity_Name (Right_Opnd (Cond))
6849 and then Ent = Entity (Right_Opnd (Cond))
6850 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6852 Val := Left_Opnd (Cond);
6854 -- We are effectively swapping operands
6857 when N_Op_Eq => null;
6858 when N_Op_Ne => null;
6859 when N_Op_Lt => Op := N_Op_Gt;
6860 when N_Op_Gt => Op := N_Op_Lt;
6861 when N_Op_Le => Op := N_Op_Ge;
6862 when N_Op_Ge => Op := N_Op_Le;
6863 when others => raise Program_Error;
6872 elsif Nkind (Cond) in N_Type_Conversion
6873 | N_Qualified_Expression
6874 | N_Expression_With_Actions
6876 Cond := Expression (Cond);
6878 -- Case of Boolean variable reference, return as though the
6879 -- reference had said var = True.
6882 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6883 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6885 if Sens = False then
6892 end Process_Current_Value_Condition;
6894 -- Start of processing for Get_Current_Value_Condition
6900 -- Immediate return, nothing doing, if this is not an object
6902 if not Is_Object (Ent) then
6906 -- In GNATprove mode we don't want to use current value optimizer, in
6907 -- particular for loop invariant expressions and other assertions that
6908 -- act as cut points for proof. The optimizer often folds expressions
6909 -- into True/False where they trivially follow from the previous
6910 -- assignments, but this deprives proof from the information needed to
6911 -- discharge checks that are beyond the scope of the value optimizer.
6913 if GNATprove_Mode then
6917 -- Otherwise examine current value
6920 CV : constant Node_Id := Current_Value (Ent);
6925 -- If statement. Condition is known true in THEN section, known False
6926 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6928 if Nkind (CV) = N_If_Statement then
6930 -- Before start of IF statement
6932 if Loc < Sloc (CV) then
6935 -- After end of IF statement
6937 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6941 -- At this stage we know that we are within the IF statement, but
6942 -- unfortunately, the tree does not record the SLOC of the ELSE so
6943 -- we cannot use a simple SLOC comparison to distinguish between
6944 -- the then/else statements, so we have to climb the tree.
6951 while Parent (N) /= CV loop
6954 -- If we fall off the top of the tree, then that's odd, but
6955 -- perhaps it could occur in some error situation, and the
6956 -- safest response is simply to assume that the outcome of
6957 -- the condition is unknown. No point in bombing during an
6958 -- attempt to optimize things.
6965 -- Now we have N pointing to a node whose parent is the IF
6966 -- statement in question, so now we can tell if we are within
6967 -- the THEN statements.
6969 if Is_List_Member (N)
6970 and then List_Containing (N) = Then_Statements (CV)
6974 -- If the variable reference does not come from source, we
6975 -- cannot reliably tell whether it appears in the else part.
6976 -- In particular, if it appears in generated code for a node
6977 -- that requires finalization, it may be attached to a list
6978 -- that has not been yet inserted into the code. For now,
6979 -- treat it as unknown.
6981 elsif not Comes_From_Source (N) then
6984 -- Otherwise we must be in ELSIF or ELSE part
6991 -- ELSIF part. Condition is known true within the referenced
6992 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6993 -- and unknown before the ELSE part or after the IF statement.
6995 elsif Nkind (CV) = N_Elsif_Part then
6997 -- if the Elsif_Part had condition_actions, the elsif has been
6998 -- rewritten as a nested if, and the original elsif_part is
6999 -- detached from the tree, so there is no way to obtain useful
7000 -- information on the current value of the variable.
7001 -- Can this be improved ???
7003 if No (Parent (CV)) then
7009 -- If the tree has been otherwise rewritten there is nothing
7010 -- else to be done either.
7012 if Nkind (Stm) /= N_If_Statement then
7016 -- Before start of ELSIF part
7018 if Loc < Sloc (CV) then
7021 -- After end of IF statement
7023 elsif Loc >= Sloc (Stm) +
7024 Text_Ptr (UI_To_Int (End_Span (Stm)))
7029 -- Again we lack the SLOC of the ELSE, so we need to climb the
7030 -- tree to see if we are within the ELSIF part in question.
7037 while Parent (N) /= Stm loop
7040 -- If we fall off the top of the tree, then that's odd, but
7041 -- perhaps it could occur in some error situation, and the
7042 -- safest response is simply to assume that the outcome of
7043 -- the condition is unknown. No point in bombing during an
7044 -- attempt to optimize things.
7051 -- Now we have N pointing to a node whose parent is the IF
7052 -- statement in question, so see if is the ELSIF part we want.
7053 -- the THEN statements.
7058 -- Otherwise we must be in subsequent ELSIF or ELSE part
7065 -- Iteration scheme of while loop. The condition is known to be
7066 -- true within the body of the loop.
7068 elsif Nkind (CV) = N_Iteration_Scheme then
7070 Loop_Stmt : constant Node_Id := Parent (CV);
7073 -- Before start of body of loop
7075 if Loc < Sloc (Loop_Stmt) then
7078 -- After end of LOOP statement
7080 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
7083 -- We are within the body of the loop
7090 -- All other cases of Current_Value settings
7096 -- If we fall through here, then we have a reportable condition, Sens
7097 -- is True if the condition is true and False if it needs inverting.
7099 Process_Current_Value_Condition (Condition (CV), Sens);
7101 end Get_Current_Value_Condition;
7103 -----------------------
7104 -- Get_Index_Subtype --
7105 -----------------------
7107 function Get_Index_Subtype (N : Node_Id) return Entity_Id is
7108 P_Type : Entity_Id := Etype (Prefix (N));
7113 if Is_Access_Type (P_Type) then
7114 P_Type := Designated_Type (P_Type);
7117 if No (Expressions (N)) then
7120 J := UI_To_Int (Expr_Value (First (Expressions (N))));
7123 Indx := First_Index (P_Type);
7129 return Etype (Indx);
7130 end Get_Index_Subtype;
7132 -----------------------
7133 -- Get_Mapped_Entity --
7134 -----------------------
7136 function Get_Mapped_Entity (E : Entity_Id) return Entity_Id is
7138 return Type_Map.Get (E);
7139 end Get_Mapped_Entity;
7141 ---------------------
7142 -- Get_Stream_Size --
7143 ---------------------
7145 function Get_Stream_Size (E : Entity_Id) return Uint is
7147 -- If we have a Stream_Size clause for this type use it
7149 if Has_Stream_Size_Clause (E) then
7150 return Static_Integer (Expression (Stream_Size_Clause (E)));
7152 -- Otherwise the Stream_Size is the size of the type
7157 end Get_Stream_Size;
7159 ---------------------------
7160 -- Has_Access_Constraint --
7161 ---------------------------
7163 function Has_Access_Constraint (E : Entity_Id) return Boolean is
7165 T : constant Entity_Id := Etype (E);
7168 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
7169 Disc := First_Discriminant (T);
7170 while Present (Disc) loop
7171 if Is_Access_Type (Etype (Disc)) then
7175 Next_Discriminant (Disc);
7182 end Has_Access_Constraint;
7184 --------------------
7185 -- Homonym_Number --
7186 --------------------
7188 function Homonym_Number (Subp : Entity_Id) return Pos is
7189 Hom : Entity_Id := Homonym (Subp);
7193 while Present (Hom) loop
7194 if Scope (Hom) = Scope (Subp) then
7198 Hom := Homonym (Hom);
7204 -----------------------------------
7205 -- In_Library_Level_Package_Body --
7206 -----------------------------------
7208 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
7210 -- First determine whether the entity appears at the library level, then
7211 -- look at the containing unit.
7213 if Is_Library_Level_Entity (Id) then
7215 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
7218 return Nkind (Unit (Container)) = N_Package_Body;
7223 end In_Library_Level_Package_Body;
7225 ------------------------------
7226 -- In_Unconditional_Context --
7227 ------------------------------
7229 function In_Unconditional_Context (Node : Node_Id) return Boolean is
7234 while Present (P) loop
7236 when N_Subprogram_Body => return True;
7237 when N_If_Statement => return False;
7238 when N_Loop_Statement => return False;
7239 when N_Case_Statement => return False;
7240 when others => P := Parent (P);
7245 end In_Unconditional_Context;
7251 procedure Insert_Action
7252 (Assoc_Node : Node_Id;
7253 Ins_Action : Node_Id;
7254 Spec_Expr_OK : Boolean := False)
7257 if Present (Ins_Action) then
7259 (Assoc_Node => Assoc_Node,
7260 Ins_Actions => New_List (Ins_Action),
7261 Spec_Expr_OK => Spec_Expr_OK);
7265 -- Version with check(s) suppressed
7267 procedure Insert_Action
7268 (Assoc_Node : Node_Id;
7269 Ins_Action : Node_Id;
7270 Suppress : Check_Id;
7271 Spec_Expr_OK : Boolean := False)
7275 (Assoc_Node => Assoc_Node,
7276 Ins_Actions => New_List (Ins_Action),
7277 Suppress => Suppress,
7278 Spec_Expr_OK => Spec_Expr_OK);
7281 -------------------------
7282 -- Insert_Action_After --
7283 -------------------------
7285 procedure Insert_Action_After
7286 (Assoc_Node : Node_Id;
7287 Ins_Action : Node_Id)
7290 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
7291 end Insert_Action_After;
7293 --------------------
7294 -- Insert_Actions --
7295 --------------------
7297 procedure Insert_Actions
7298 (Assoc_Node : Node_Id;
7299 Ins_Actions : List_Id;
7300 Spec_Expr_OK : Boolean := False)
7305 Wrapped_Node : Node_Id := Empty;
7308 if Is_Empty_List (Ins_Actions) then
7312 -- Insert the action when the context is "Handling of Default and Per-
7313 -- Object Expressions" only when requested by the caller.
7315 if Spec_Expr_OK then
7318 -- Ignore insert of actions from inside default expression (or other
7319 -- similar "spec expression") in the special spec-expression analyze
7320 -- mode. Any insertions at this point have no relevance, since we are
7321 -- only doing the analyze to freeze the types of any static expressions.
7322 -- See section "Handling of Default and Per-Object Expressions" in the
7323 -- spec of package Sem for further details.
7325 elsif In_Spec_Expression then
7329 -- If the action derives from stuff inside a record, then the actions
7330 -- are attached to the current scope, to be inserted and analyzed on
7331 -- exit from the scope. The reason for this is that we may also be
7332 -- generating freeze actions at the same time, and they must eventually
7333 -- be elaborated in the correct order.
7335 if Is_Record_Type (Current_Scope)
7336 and then not Is_Frozen (Current_Scope)
7338 if No (Scope_Stack.Table
7339 (Scope_Stack.Last).Pending_Freeze_Actions)
7341 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
7346 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
7352 -- We now intend to climb up the tree to find the right point to
7353 -- insert the actions. We start at Assoc_Node, unless this node is a
7354 -- subexpression in which case we start with its parent. We do this for
7355 -- two reasons. First it speeds things up. Second, if Assoc_Node is
7356 -- itself one of the special nodes like N_And_Then, then we assume that
7357 -- an initial request to insert actions for such a node does not expect
7358 -- the actions to get deposited in the node for later handling when the
7359 -- node is expanded, since clearly the node is being dealt with by the
7360 -- caller. Note that in the subexpression case, N is always the child we
7363 -- N_Raise_xxx_Error is an annoying special case, it is a statement
7364 -- if it has type Standard_Void_Type, and a subexpression otherwise.
7365 -- Procedure calls, and similarly procedure attribute references, are
7368 if Nkind (Assoc_Node) in N_Subexpr
7369 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
7370 or else Etype (Assoc_Node) /= Standard_Void_Type)
7371 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
7372 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
7373 or else not Is_Procedure_Attribute_Name
7374 (Attribute_Name (Assoc_Node)))
7377 P := Parent (Assoc_Node);
7379 -- Nonsubexpression case. Note that N is initially Empty in this case
7380 -- (N is only guaranteed non-Empty in the subexpr case).
7387 -- Capture root of the transient scope
7389 if Scope_Is_Transient then
7390 Wrapped_Node := Node_To_Be_Wrapped;
7394 pragma Assert (Present (P));
7396 -- Make sure that inserted actions stay in the transient scope
7398 if Present (Wrapped_Node) and then N = Wrapped_Node then
7399 Store_Before_Actions_In_Scope (Ins_Actions);
7405 -- Case of right operand of AND THEN or OR ELSE. Put the actions
7406 -- in the Actions field of the right operand. They will be moved
7407 -- out further when the AND THEN or OR ELSE operator is expanded.
7408 -- Nothing special needs to be done for the left operand since
7409 -- in that case the actions are executed unconditionally.
7411 when N_Short_Circuit =>
7412 if N = Right_Opnd (P) then
7414 -- We are now going to either append the actions to the
7415 -- actions field of the short-circuit operation. We will
7416 -- also analyze the actions now.
7418 -- This analysis is really too early, the proper thing would
7419 -- be to just park them there now, and only analyze them if
7420 -- we find we really need them, and to it at the proper
7421 -- final insertion point. However attempting to this proved
7422 -- tricky, so for now we just kill current values before and
7423 -- after the analyze call to make sure we avoid peculiar
7424 -- optimizations from this out of order insertion.
7426 Kill_Current_Values;
7428 -- If P has already been expanded, we can't park new actions
7429 -- on it, so we need to expand them immediately, introducing
7430 -- an Expression_With_Actions. N can't be an expression
7431 -- with actions, or else then the actions would have been
7432 -- inserted at an inner level.
7434 if Analyzed (P) then
7435 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
7437 Make_Expression_With_Actions (Sloc (N),
7438 Actions => Ins_Actions,
7439 Expression => Relocate_Node (N)));
7440 Analyze_And_Resolve (N);
7442 elsif Present (Actions (P)) then
7443 Insert_List_After_And_Analyze
7444 (Last (Actions (P)), Ins_Actions);
7446 Set_Actions (P, Ins_Actions);
7447 Analyze_List (Actions (P));
7450 Kill_Current_Values;
7455 -- Then or Else dependent expression of an if expression. Add
7456 -- actions to Then_Actions or Else_Actions field as appropriate.
7457 -- The actions will be moved further out when the if is expanded.
7459 when N_If_Expression =>
7461 ThenX : constant Node_Id := Next (First (Expressions (P)));
7462 ElseX : constant Node_Id := Next (ThenX);
7465 -- If the enclosing expression is already analyzed, as
7466 -- is the case for nested elaboration checks, insert the
7467 -- conditional further out.
7469 if Analyzed (P) then
7472 -- Actions belong to the then expression, temporarily place
7473 -- them as Then_Actions of the if expression. They will be
7474 -- moved to the proper place later when the if expression is
7477 elsif N = ThenX then
7478 if Present (Then_Actions (P)) then
7479 Insert_List_After_And_Analyze
7480 (Last (Then_Actions (P)), Ins_Actions);
7482 Set_Then_Actions (P, Ins_Actions);
7483 Analyze_List (Then_Actions (P));
7488 -- Else_Actions is treated the same as Then_Actions above
7490 elsif N = ElseX then
7491 if Present (Else_Actions (P)) then
7492 Insert_List_After_And_Analyze
7493 (Last (Else_Actions (P)), Ins_Actions);
7495 Set_Else_Actions (P, Ins_Actions);
7496 Analyze_List (Else_Actions (P));
7501 -- Actions belong to the condition. In this case they are
7502 -- unconditionally executed, and so we can continue the
7503 -- search for the proper insert point.
7510 -- Alternative of case expression, we place the action in the
7511 -- Actions field of the case expression alternative, this will
7512 -- be handled when the case expression is expanded.
7514 when N_Case_Expression_Alternative =>
7515 if Present (Actions (P)) then
7516 Insert_List_After_And_Analyze
7517 (Last (Actions (P)), Ins_Actions);
7519 Set_Actions (P, Ins_Actions);
7520 Analyze_List (Actions (P));
7525 -- Case of appearing within an Expressions_With_Actions node. When
7526 -- the new actions come from the expression of the expression with
7527 -- actions, they must be added to the existing actions. The other
7528 -- alternative is when the new actions are related to one of the
7529 -- existing actions of the expression with actions, and should
7530 -- never reach here: if actions are inserted on a statement
7531 -- within the Actions of an expression with actions, or on some
7532 -- subexpression of such a statement, then the outermost proper
7533 -- insertion point is right before the statement, and we should
7534 -- never climb up as far as the N_Expression_With_Actions itself.
7536 when N_Expression_With_Actions =>
7537 if N = Expression (P) then
7538 if Is_Empty_List (Actions (P)) then
7539 Append_List_To (Actions (P), Ins_Actions);
7540 Analyze_List (Actions (P));
7542 Insert_List_After_And_Analyze
7543 (Last (Actions (P)), Ins_Actions);
7549 raise Program_Error;
7552 -- Case of appearing in the condition of a while expression or
7553 -- elsif. We insert the actions into the Condition_Actions field.
7554 -- They will be moved further out when the while loop or elsif
7558 | N_Iteration_Scheme
7560 if Present (Condition (P)) and then N = Condition (P) then
7561 if Present (Condition_Actions (P)) then
7562 Insert_List_After_And_Analyze
7563 (Last (Condition_Actions (P)), Ins_Actions);
7565 Set_Condition_Actions (P, Ins_Actions);
7567 -- Set the parent of the insert actions explicitly. This
7568 -- is not a syntactic field, but we need the parent field
7569 -- set, in particular so that freeze can understand that
7570 -- it is dealing with condition actions, and properly
7571 -- insert the freezing actions.
7573 Set_Parent (Ins_Actions, P);
7574 Analyze_List (Condition_Actions (P));
7580 -- Statements, declarations, pragmas, representation clauses
7585 N_Procedure_Call_Statement
7586 | N_Statement_Other_Than_Procedure_Call
7592 -- Representation_Clause
7595 | N_Attribute_Definition_Clause
7596 | N_Enumeration_Representation_Clause
7597 | N_Record_Representation_Clause
7601 | N_Abstract_Subprogram_Declaration
7603 | N_Exception_Declaration
7604 | N_Exception_Renaming_Declaration
7605 | N_Expression_Function
7606 | N_Formal_Abstract_Subprogram_Declaration
7607 | N_Formal_Concrete_Subprogram_Declaration
7608 | N_Formal_Object_Declaration
7609 | N_Formal_Type_Declaration
7610 | N_Full_Type_Declaration
7611 | N_Function_Instantiation
7612 | N_Generic_Function_Renaming_Declaration
7613 | N_Generic_Package_Declaration
7614 | N_Generic_Package_Renaming_Declaration
7615 | N_Generic_Procedure_Renaming_Declaration
7616 | N_Generic_Subprogram_Declaration
7617 | N_Implicit_Label_Declaration
7618 | N_Incomplete_Type_Declaration
7619 | N_Number_Declaration
7620 | N_Object_Declaration
7621 | N_Object_Renaming_Declaration
7623 | N_Package_Body_Stub
7624 | N_Package_Declaration
7625 | N_Package_Instantiation
7626 | N_Package_Renaming_Declaration
7627 | N_Private_Extension_Declaration
7628 | N_Private_Type_Declaration
7629 | N_Procedure_Instantiation
7631 | N_Protected_Body_Stub
7632 | N_Single_Task_Declaration
7634 | N_Subprogram_Body_Stub
7635 | N_Subprogram_Declaration
7636 | N_Subprogram_Renaming_Declaration
7637 | N_Subtype_Declaration
7641 -- Use clauses can appear in lists of declarations
7643 | N_Use_Package_Clause
7646 -- Freeze entity behaves like a declaration or statement
7649 | N_Freeze_Generic_Entity
7651 -- Do not insert here if the item is not a list member (this
7652 -- happens for example with a triggering statement, and the
7653 -- proper approach is to insert before the entire select).
7655 if not Is_List_Member (P) then
7658 -- Do not insert if parent of P is an N_Component_Association
7659 -- node (i.e. we are in the context of an N_Aggregate or
7660 -- N_Extension_Aggregate node. In this case we want to insert
7661 -- before the entire aggregate.
7663 elsif Nkind (Parent (P)) = N_Component_Association then
7666 -- Do not insert if the parent of P is either an N_Variant node
7667 -- or an N_Record_Definition node, meaning in either case that
7668 -- P is a member of a component list, and that therefore the
7669 -- actions should be inserted outside the complete record
7672 elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
7675 -- Do not insert freeze nodes within the loop generated for
7676 -- an aggregate, because they may be elaborated too late for
7677 -- subsequent use in the back end: within a package spec the
7678 -- loop is part of the elaboration procedure and is only
7679 -- elaborated during the second pass.
7681 -- If the loop comes from source, or the entity is local to the
7682 -- loop itself it must remain within.
7684 elsif Nkind (Parent (P)) = N_Loop_Statement
7685 and then not Comes_From_Source (Parent (P))
7686 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7688 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7692 -- Otherwise we can go ahead and do the insertion
7694 elsif P = Wrapped_Node then
7695 Store_Before_Actions_In_Scope (Ins_Actions);
7699 Insert_List_Before_And_Analyze (P, Ins_Actions);
7703 -- the expansion of Task and protected type declarations can
7704 -- create declarations for temporaries which, like other actions
7705 -- are inserted and analyzed before the current declaraation.
7706 -- However, the current scope is the synchronized type, and
7707 -- for unnesting it is critical that the proper scope for these
7708 -- generated entities be the enclosing one.
7710 when N_Task_Type_Declaration
7711 | N_Protected_Type_Declaration =>
7713 Push_Scope (Scope (Current_Scope));
7714 Insert_List_Before_And_Analyze (P, Ins_Actions);
7718 -- A special case, N_Raise_xxx_Error can act either as a statement
7719 -- or a subexpression. We tell the difference by looking at the
7720 -- Etype. It is set to Standard_Void_Type in the statement case.
7722 when N_Raise_xxx_Error =>
7723 if Etype (P) = Standard_Void_Type then
7724 if P = Wrapped_Node then
7725 Store_Before_Actions_In_Scope (Ins_Actions);
7727 Insert_List_Before_And_Analyze (P, Ins_Actions);
7732 -- In the subexpression case, keep climbing
7738 -- If a component association appears within a loop created for
7739 -- an array aggregate, attach the actions to the association so
7740 -- they can be subsequently inserted within the loop. For other
7741 -- component associations insert outside of the aggregate. For
7742 -- an association that will generate a loop, its Loop_Actions
7743 -- attribute is already initialized (see exp_aggr.adb).
7745 -- The list of Loop_Actions can in turn generate additional ones,
7746 -- that are inserted before the associated node. If the associated
7747 -- node is outside the aggregate, the new actions are collected
7748 -- at the end of the Loop_Actions, to respect the order in which
7749 -- they are to be elaborated.
7751 when N_Component_Association
7752 | N_Iterated_Component_Association
7753 | N_Iterated_Element_Association
7755 if Nkind (Parent (P)) in N_Aggregate | N_Delta_Aggregate
7757 -- We must not climb up out of an N_Iterated_xxx_Association
7758 -- because the actions might contain references to the loop
7759 -- parameter, except if we come from the Discrete_Choices of
7760 -- N_Iterated_Component_Association which cannot contain any.
7761 -- But it turns out that setting the Loop_Actions field in
7762 -- the case of an N_Component_Association when the field was
7763 -- not already set can lead to gigi assertion failures that
7764 -- are presumably due to malformed trees, so don't do that.
7766 and then (Nkind (P) /= N_Iterated_Component_Association
7767 or else not Is_List_Member (N)
7769 List_Containing (N) /= Discrete_Choices (P))
7770 and then (Nkind (P) /= N_Component_Association
7771 or else Present (Loop_Actions (P)))
7773 if Is_Empty_List (Loop_Actions (P)) then
7774 Set_Loop_Actions (P, Ins_Actions);
7775 Analyze_List (Ins_Actions);
7781 -- Check whether these actions were generated by a
7782 -- declaration that is part of the Loop_Actions for
7783 -- the component_association.
7786 while Present (Decl) loop
7787 exit when Parent (Decl) = P
7788 and then Is_List_Member (Decl)
7790 List_Containing (Decl) = Loop_Actions (P);
7791 Decl := Parent (Decl);
7794 if Present (Decl) then
7795 Insert_List_Before_And_Analyze
7796 (Decl, Ins_Actions);
7798 Insert_List_After_And_Analyze
7799 (Last (Loop_Actions (P)), Ins_Actions);
7810 -- Special case: an attribute denoting a procedure call
7812 when N_Attribute_Reference =>
7813 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7814 if P = Wrapped_Node then
7815 Store_Before_Actions_In_Scope (Ins_Actions);
7817 Insert_List_Before_And_Analyze (P, Ins_Actions);
7822 -- In the subexpression case, keep climbing
7828 -- Special case: a marker
7831 | N_Variable_Reference_Marker
7833 if Is_List_Member (P) then
7834 Insert_List_Before_And_Analyze (P, Ins_Actions);
7838 -- A contract node should not belong to the tree
7841 raise Program_Error;
7843 -- For all other node types, keep climbing tree
7845 when N_Abortable_Part
7846 | N_Accept_Alternative
7847 | N_Access_Definition
7848 | N_Access_Function_Definition
7849 | N_Access_Procedure_Definition
7850 | N_Access_To_Object_Definition
7853 | N_Aspect_Specification
7855 | N_Case_Statement_Alternative
7856 | N_Character_Literal
7857 | N_Compilation_Unit
7858 | N_Compilation_Unit_Aux
7859 | N_Component_Clause
7860 | N_Component_Declaration
7861 | N_Component_Definition
7863 | N_Constrained_Array_Definition
7864 | N_Decimal_Fixed_Point_Definition
7865 | N_Defining_Character_Literal
7866 | N_Defining_Identifier
7867 | N_Defining_Operator_Symbol
7868 | N_Defining_Program_Unit_Name
7869 | N_Delay_Alternative
7871 | N_Delta_Constraint
7872 | N_Derived_Type_Definition
7874 | N_Digits_Constraint
7875 | N_Discriminant_Association
7876 | N_Discriminant_Specification
7878 | N_Entry_Body_Formal_Part
7879 | N_Entry_Call_Alternative
7880 | N_Entry_Declaration
7881 | N_Entry_Index_Specification
7882 | N_Enumeration_Type_Definition
7884 | N_Exception_Handler
7886 | N_Explicit_Dereference
7887 | N_Extension_Aggregate
7888 | N_Floating_Point_Definition
7889 | N_Formal_Decimal_Fixed_Point_Definition
7890 | N_Formal_Derived_Type_Definition
7891 | N_Formal_Discrete_Type_Definition
7892 | N_Formal_Floating_Point_Definition
7893 | N_Formal_Modular_Type_Definition
7894 | N_Formal_Ordinary_Fixed_Point_Definition
7895 | N_Formal_Package_Declaration
7896 | N_Formal_Private_Type_Definition
7897 | N_Formal_Incomplete_Type_Definition
7898 | N_Formal_Signed_Integer_Type_Definition
7900 | N_Function_Specification
7901 | N_Generic_Association
7902 | N_Handled_Sequence_Of_Statements
7905 | N_Index_Or_Discriminant_Constraint
7906 | N_Indexed_Component
7908 | N_Iterator_Specification
7911 | N_Loop_Parameter_Specification
7913 | N_Modular_Type_Definition
7939 | N_Op_Shift_Right_Arithmetic
7943 | N_Ordinary_Fixed_Point_Definition
7945 | N_Package_Specification
7946 | N_Parameter_Association
7947 | N_Parameter_Specification
7948 | N_Pop_Constraint_Error_Label
7949 | N_Pop_Program_Error_Label
7950 | N_Pop_Storage_Error_Label
7951 | N_Pragma_Argument_Association
7952 | N_Procedure_Specification
7953 | N_Protected_Definition
7954 | N_Push_Constraint_Error_Label
7955 | N_Push_Program_Error_Label
7956 | N_Push_Storage_Error_Label
7957 | N_Qualified_Expression
7958 | N_Quantified_Expression
7959 | N_Raise_Expression
7961 | N_Range_Constraint
7963 | N_Real_Range_Specification
7964 | N_Record_Definition
7966 | N_SCIL_Dispatch_Table_Tag_Init
7967 | N_SCIL_Dispatching_Call
7968 | N_SCIL_Membership_Test
7969 | N_Selected_Component
7970 | N_Signed_Integer_Type_Definition
7971 | N_Single_Protected_Declaration
7974 | N_Subtype_Indication
7978 | N_Terminate_Alternative
7979 | N_Triggering_Alternative
7981 | N_Unchecked_Expression
7982 | N_Unchecked_Type_Conversion
7983 | N_Unconstrained_Array_Definition
7988 | N_Validate_Unchecked_Conversion
7994 -- If we fall through above tests, keep climbing tree
7998 if Nkind (Parent (N)) = N_Subunit then
8000 -- This is the proper body corresponding to a stub. Insertion must
8001 -- be done at the point of the stub, which is in the declarative
8002 -- part of the parent unit.
8004 P := Corresponding_Stub (Parent (N));
8012 -- Version with check(s) suppressed
8014 procedure Insert_Actions
8015 (Assoc_Node : Node_Id;
8016 Ins_Actions : List_Id;
8017 Suppress : Check_Id;
8018 Spec_Expr_OK : Boolean := False)
8021 if Suppress = All_Checks then
8023 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
8025 Scope_Suppress.Suppress := (others => True);
8026 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
8027 Scope_Suppress.Suppress := Sva;
8032 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
8034 Scope_Suppress.Suppress (Suppress) := True;
8035 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
8036 Scope_Suppress.Suppress (Suppress) := Svg;
8041 --------------------------
8042 -- Insert_Actions_After --
8043 --------------------------
8045 procedure Insert_Actions_After
8046 (Assoc_Node : Node_Id;
8047 Ins_Actions : List_Id)
8050 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
8051 Store_After_Actions_In_Scope (Ins_Actions);
8053 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
8055 end Insert_Actions_After;
8057 ---------------------------------
8058 -- Insert_Library_Level_Action --
8059 ---------------------------------
8061 procedure Insert_Library_Level_Action (N : Node_Id) is
8062 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
8065 Push_Scope (Cunit_Entity (Current_Sem_Unit));
8066 -- And not Main_Unit as previously. If the main unit is a body,
8067 -- the scope needed to analyze the actions is the entity of the
8068 -- corresponding declaration.
8070 if No (Actions (Aux)) then
8071 Set_Actions (Aux, New_List (N));
8073 Append (N, Actions (Aux));
8078 end Insert_Library_Level_Action;
8080 ----------------------------------
8081 -- Insert_Library_Level_Actions --
8082 ----------------------------------
8084 procedure Insert_Library_Level_Actions (L : List_Id) is
8085 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
8088 if Is_Non_Empty_List (L) then
8089 Push_Scope (Cunit_Entity (Main_Unit));
8090 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
8092 if No (Actions (Aux)) then
8093 Set_Actions (Aux, L);
8096 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
8101 end Insert_Library_Level_Actions;
8103 ----------------------
8104 -- Inside_Init_Proc --
8105 ----------------------
8107 function Inside_Init_Proc return Boolean is
8109 return Present (Enclosing_Init_Proc);
8110 end Inside_Init_Proc;
8112 ----------------------
8113 -- Integer_Type_For --
8114 ----------------------
8116 function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id is
8118 pragma Assert (S <= System_Max_Integer_Size);
8120 -- This is the canonical 32-bit type
8122 if S <= Standard_Integer_Size then
8124 return Standard_Unsigned;
8126 return Standard_Integer;
8129 -- This is the canonical 64-bit type
8131 elsif S <= Standard_Long_Long_Integer_Size then
8133 return Standard_Long_Long_Unsigned;
8135 return Standard_Long_Long_Integer;
8138 -- This is the canonical 128-bit type
8140 elsif S <= Standard_Long_Long_Long_Integer_Size then
8142 return Standard_Long_Long_Long_Unsigned;
8144 return Standard_Long_Long_Long_Integer;
8148 raise Program_Error;
8150 end Integer_Type_For;
8152 --------------------------------------------------
8153 -- Is_Displacement_Of_Object_Or_Function_Result --
8154 --------------------------------------------------
8156 function Is_Displacement_Of_Object_Or_Function_Result
8157 (Obj_Id : Entity_Id) return Boolean
8159 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
8160 -- Determine whether node N denotes a controlled function call
8162 function Is_Controlled_Indexing (N : Node_Id) return Boolean;
8163 -- Determine whether node N denotes a generalized indexing form which
8164 -- involves a controlled result.
8166 function Is_Displace_Call (N : Node_Id) return Boolean;
8167 -- Determine whether node N denotes a call to Ada.Tags.Displace
8169 function Is_Source_Object (N : Node_Id) return Boolean;
8170 -- Determine whether a particular node denotes a source object
8172 function Strip (N : Node_Id) return Node_Id;
8173 -- Examine arbitrary node N by stripping various indirections and return
8176 ---------------------------------
8177 -- Is_Controlled_Function_Call --
8178 ---------------------------------
8180 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
8184 -- When a function call appears in Object.Operation format, the
8185 -- original representation has several possible forms depending on
8186 -- the availability and form of actual parameters:
8188 -- Obj.Func N_Selected_Component
8189 -- Obj.Func (Actual) N_Indexed_Component
8190 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
8191 -- N_Selected_Component
8193 Expr := Original_Node (N);
8195 if Nkind (Expr) = N_Function_Call then
8196 Expr := Name (Expr);
8198 -- "Obj.Func (Actual)" case
8200 elsif Nkind (Expr) = N_Indexed_Component then
8201 Expr := Prefix (Expr);
8203 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
8205 elsif Nkind (Expr) = N_Selected_Component then
8206 Expr := Selector_Name (Expr);
8214 Nkind (Expr) in N_Has_Entity
8215 and then Present (Entity (Expr))
8216 and then Ekind (Entity (Expr)) = E_Function
8217 and then Needs_Finalization (Etype (Entity (Expr)));
8218 end Is_Controlled_Function_Call;
8220 ----------------------------
8221 -- Is_Controlled_Indexing --
8222 ----------------------------
8224 function Is_Controlled_Indexing (N : Node_Id) return Boolean is
8225 Expr : constant Node_Id := Original_Node (N);
8229 Nkind (Expr) = N_Indexed_Component
8230 and then Present (Generalized_Indexing (Expr))
8231 and then Needs_Finalization (Etype (Expr));
8232 end Is_Controlled_Indexing;
8234 ----------------------
8235 -- Is_Displace_Call --
8236 ----------------------
8238 function Is_Displace_Call (N : Node_Id) return Boolean is
8239 Call : constant Node_Id := Strip (N);
8244 and then Nkind (Call) = N_Function_Call
8245 and then Nkind (Name (Call)) in N_Has_Entity
8246 and then Is_RTE (Entity (Name (Call)), RE_Displace);
8247 end Is_Displace_Call;
8249 ----------------------
8250 -- Is_Source_Object --
8251 ----------------------
8253 function Is_Source_Object (N : Node_Id) return Boolean is
8254 Obj : constant Node_Id := Strip (N);
8259 and then Comes_From_Source (Obj)
8260 and then Nkind (Obj) in N_Has_Entity
8261 and then Is_Object (Entity (Obj));
8262 end Is_Source_Object;
8268 function Strip (N : Node_Id) return Node_Id is
8274 if Nkind (Result) = N_Explicit_Dereference then
8275 Result := Prefix (Result);
8277 elsif Nkind (Result) in
8278 N_Type_Conversion | N_Unchecked_Type_Conversion
8280 Result := Expression (Result);
8292 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
8293 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
8294 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
8295 Orig_Expr : Node_Id;
8297 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
8302 -- Obj : CW_Type := Function_Call (...);
8304 -- is rewritten into:
8306 -- Temp : ... := Function_Call (...)'reference;
8307 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
8309 -- where the return type of the function and the class-wide type require
8310 -- dispatch table pointer displacement.
8314 -- Obj : CW_Type := Container (...);
8316 -- is rewritten into:
8318 -- Temp : ... := Function_Call (Container, ...)'reference;
8319 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
8321 -- where the container element type and the class-wide type require
8322 -- dispatch table pointer dispacement.
8326 -- Obj : CW_Type := Src_Obj;
8328 -- is rewritten into:
8330 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
8332 -- where the type of the source object and the class-wide type require
8333 -- dispatch table pointer displacement.
8335 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
8336 and then Is_Class_Wide_Type (Obj_Typ)
8337 and then Is_Displace_Call (Renamed_Object (Obj_Id))
8338 and then Nkind (Orig_Decl) = N_Object_Declaration
8339 and then Comes_From_Source (Orig_Decl)
8341 Orig_Expr := Expression (Orig_Decl);
8344 Is_Controlled_Function_Call (Orig_Expr)
8345 or else Is_Controlled_Indexing (Orig_Expr)
8346 or else Is_Source_Object (Orig_Expr);
8350 end Is_Displacement_Of_Object_Or_Function_Result;
8352 ------------------------------
8353 -- Is_Finalizable_Transient --
8354 ------------------------------
8356 function Is_Finalizable_Transient
8358 Rel_Node : Node_Id) return Boolean
8360 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
8361 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
8363 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
8364 -- Determine whether transient object Trans_Id is initialized either
8365 -- by a function call which returns an access type or simply renames
8368 function Initialized_By_Aliased_BIP_Func_Call
8369 (Trans_Id : Entity_Id) return Boolean;
8370 -- Determine whether transient object Trans_Id is initialized by a
8371 -- build-in-place function call where the BIPalloc parameter is of
8372 -- value 1 and BIPaccess is not null. This case creates an aliasing
8373 -- between the returned value and the value denoted by BIPaccess.
8376 (Trans_Id : Entity_Id;
8377 First_Stmt : Node_Id) return Boolean;
8378 -- Determine whether transient object Trans_Id has been renamed or
8379 -- aliased through 'reference in the statement list starting from
8382 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
8383 -- Determine whether transient object Trans_Id is allocated on the heap
8385 function Is_Iterated_Container
8386 (Trans_Id : Entity_Id;
8387 First_Stmt : Node_Id) return Boolean;
8388 -- Determine whether transient object Trans_Id denotes a container which
8389 -- is in the process of being iterated in the statement list starting
8392 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean;
8393 -- Return True if N is directly part of a build-in-place return
8396 ---------------------------
8397 -- Initialized_By_Access --
8398 ---------------------------
8400 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
8401 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8406 and then Nkind (Expr) /= N_Reference
8407 and then Is_Access_Type (Etype (Expr));
8408 end Initialized_By_Access;
8410 ------------------------------------------
8411 -- Initialized_By_Aliased_BIP_Func_Call --
8412 ------------------------------------------
8414 function Initialized_By_Aliased_BIP_Func_Call
8415 (Trans_Id : Entity_Id) return Boolean
8417 Call : Node_Id := Expression (Parent (Trans_Id));
8420 -- Build-in-place calls usually appear in 'reference format
8422 if Nkind (Call) = N_Reference then
8423 Call := Prefix (Call);
8426 Call := Unqual_Conv (Call);
8428 if Is_Build_In_Place_Function_Call (Call) then
8430 Access_Nam : Name_Id := No_Name;
8431 Access_OK : Boolean := False;
8433 Alloc_Nam : Name_Id := No_Name;
8434 Alloc_OK : Boolean := False;
8436 Func_Id : Entity_Id;
8440 -- Examine all parameter associations of the function call
8442 Param := First (Parameter_Associations (Call));
8443 while Present (Param) loop
8444 if Nkind (Param) = N_Parameter_Association
8445 and then Nkind (Selector_Name (Param)) = N_Identifier
8447 Actual := Explicit_Actual_Parameter (Param);
8448 Formal := Selector_Name (Param);
8450 -- Construct the names of formals BIPaccess and BIPalloc
8451 -- using the function name retrieved from an arbitrary
8454 if Access_Nam = No_Name
8455 and then Alloc_Nam = No_Name
8456 and then Present (Entity (Formal))
8458 Func_Id := Scope (Entity (Formal));
8461 New_External_Name (Chars (Func_Id),
8462 BIP_Formal_Suffix (BIP_Object_Access));
8465 New_External_Name (Chars (Func_Id),
8466 BIP_Formal_Suffix (BIP_Alloc_Form));
8469 -- A match for BIPaccess => Temp has been found
8471 if Chars (Formal) = Access_Nam
8472 and then Nkind (Actual) /= N_Null
8477 -- A match for BIPalloc => 1 has been found
8479 if Chars (Formal) = Alloc_Nam
8480 and then Nkind (Actual) = N_Integer_Literal
8481 and then Intval (Actual) = Uint_1
8490 return Access_OK and Alloc_OK;
8495 end Initialized_By_Aliased_BIP_Func_Call;
8502 (Trans_Id : Entity_Id;
8503 First_Stmt : Node_Id) return Boolean
8505 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
8506 -- Given an object renaming declaration, retrieve the entity of the
8507 -- renamed name. Return Empty if the renamed name is anything other
8508 -- than a variable or a constant.
8510 -------------------------
8511 -- Find_Renamed_Object --
8512 -------------------------
8514 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
8515 Ren_Obj : Node_Id := Empty;
8517 function Find_Object (N : Node_Id) return Traverse_Result;
8518 -- Try to detect an object which is either a constant or a
8525 function Find_Object (N : Node_Id) return Traverse_Result is
8527 -- Stop the search once a constant or a variable has been
8530 if Nkind (N) = N_Identifier
8531 and then Present (Entity (N))
8532 and then Ekind (Entity (N)) in E_Constant | E_Variable
8534 Ren_Obj := Entity (N);
8541 procedure Search is new Traverse_Proc (Find_Object);
8545 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
8547 -- Start of processing for Find_Renamed_Object
8550 -- Actions related to dispatching calls may appear as renamings of
8551 -- tags. Do not process this type of renaming because it does not
8552 -- use the actual value of the object.
8554 if not Is_RTE (Typ, RE_Tag_Ptr) then
8555 Search (Name (Ren_Decl));
8559 end Find_Renamed_Object;
8564 Ren_Obj : Entity_Id;
8567 -- Start of processing for Is_Aliased
8570 -- A controlled transient object is not considered aliased when it
8571 -- appears inside an expression_with_actions node even when there are
8572 -- explicit aliases of it:
8575 -- Trans_Id : Ctrl_Typ ...; -- transient object
8576 -- Alias : ... := Trans_Id; -- object is aliased
8577 -- Val : constant Boolean :=
8578 -- ... Alias ...; -- aliasing ends
8579 -- <finalize Trans_Id> -- object safe to finalize
8582 -- Expansion ensures that all aliases are encapsulated in the actions
8583 -- list and do not leak to the expression by forcing the evaluation
8584 -- of the expression.
8586 if Nkind (Rel_Node) = N_Expression_With_Actions then
8589 -- Otherwise examine the statements after the controlled transient
8590 -- object and look for various forms of aliasing.
8594 while Present (Stmt) loop
8595 if Nkind (Stmt) = N_Object_Declaration then
8596 Expr := Expression (Stmt);
8598 -- Aliasing of the form:
8599 -- Obj : ... := Trans_Id'reference;
8602 and then Nkind (Expr) = N_Reference
8603 and then Nkind (Prefix (Expr)) = N_Identifier
8604 and then Entity (Prefix (Expr)) = Trans_Id
8609 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
8610 Ren_Obj := Find_Renamed_Object (Stmt);
8612 -- Aliasing of the form:
8613 -- Obj : ... renames ... Trans_Id ...;
8615 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
8631 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
8632 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8635 Is_Access_Type (Etype (Trans_Id))
8636 and then Present (Expr)
8637 and then Nkind (Expr) = N_Allocator;
8640 ---------------------------
8641 -- Is_Iterated_Container --
8642 ---------------------------
8644 function Is_Iterated_Container
8645 (Trans_Id : Entity_Id;
8646 First_Stmt : Node_Id) return Boolean
8656 -- It is not possible to iterate over containers in non-Ada 2012 code
8658 if Ada_Version < Ada_2012 then
8662 Typ := Etype (Trans_Id);
8664 -- Handle access type created for secondary stack use
8666 if Is_Access_Type (Typ) then
8667 Typ := Designated_Type (Typ);
8670 -- Look for aspect Default_Iterator. It may be part of a type
8671 -- declaration for a container, or inherited from a base type
8674 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8676 if Present (Aspect) then
8677 Iter := Entity (Aspect);
8679 -- Examine the statements following the container object and
8680 -- look for a call to the default iterate routine where the
8681 -- first parameter is the transient. Such a call appears as:
8683 -- It : Access_To_CW_Iterator :=
8684 -- Iterate (Tran_Id.all, ...)'reference;
8687 while Present (Stmt) loop
8689 -- Detect an object declaration which is initialized by a
8690 -- secondary stack function call.
8692 if Nkind (Stmt) = N_Object_Declaration
8693 and then Present (Expression (Stmt))
8694 and then Nkind (Expression (Stmt)) = N_Reference
8695 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8697 Call := Prefix (Expression (Stmt));
8699 -- The call must invoke the default iterate routine of
8700 -- the container and the transient object must appear as
8701 -- the first actual parameter. Skip any calls whose names
8702 -- are not entities.
8704 if Is_Entity_Name (Name (Call))
8705 and then Entity (Name (Call)) = Iter
8706 and then Present (Parameter_Associations (Call))
8708 Param := First (Parameter_Associations (Call));
8710 if Nkind (Param) = N_Explicit_Dereference
8711 and then Entity (Prefix (Param)) = Trans_Id
8723 end Is_Iterated_Container;
8725 -------------------------------------
8726 -- Is_Part_Of_BIP_Return_Statement --
8727 -------------------------------------
8729 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
8730 Subp : constant Entity_Id := Current_Subprogram;
8733 -- First check if N is part of a BIP function
8736 or else not Is_Build_In_Place_Function (Subp)
8741 -- Then check whether N is a complete part of a return statement
8742 -- Should we consider other node kinds to go up the tree???
8746 case Nkind (Context) is
8747 when N_Expression_With_Actions => Context := Parent (Context);
8748 when N_Simple_Return_Statement => return True;
8749 when others => return False;
8752 end Is_Part_Of_BIP_Return_Statement;
8756 Desig : Entity_Id := Obj_Typ;
8758 -- Start of processing for Is_Finalizable_Transient
8761 -- Handle access types
8763 if Is_Access_Type (Desig) then
8764 Desig := Available_View (Designated_Type (Desig));
8768 Ekind (Obj_Id) in E_Constant | E_Variable
8769 and then Needs_Finalization (Desig)
8770 and then Requires_Transient_Scope (Desig)
8771 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8772 and then not Is_Part_Of_BIP_Return_Statement (Rel_Node)
8774 -- Do not consider a transient object that was already processed
8776 and then not Is_Finalized_Transient (Obj_Id)
8778 -- Do not consider renamed or 'reference-d transient objects because
8779 -- the act of renaming extends the object's lifetime.
8781 and then not Is_Aliased (Obj_Id, Decl)
8783 -- Do not consider transient objects allocated on the heap since
8784 -- they are attached to a finalization master.
8786 and then not Is_Allocated (Obj_Id)
8788 -- If the transient object is a pointer, check that it is not
8789 -- initialized by a function that returns a pointer or acts as a
8790 -- renaming of another pointer.
8793 (Is_Access_Type (Obj_Typ) and then Initialized_By_Access (Obj_Id))
8795 -- Do not consider transient objects which act as indirect aliases
8796 -- of build-in-place function results.
8798 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8800 -- Do not consider conversions of tags to class-wide types
8802 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8804 -- Do not consider iterators because those are treated as normal
8805 -- controlled objects and are processed by the usual finalization
8806 -- machinery. This avoids the double finalization of an iterator.
8808 and then not Is_Iterator (Desig)
8810 -- Do not consider containers in the context of iterator loops. Such
8811 -- transient objects must exist for as long as the loop is around,
8812 -- otherwise any operation carried out by the iterator will fail.
8814 and then not Is_Iterated_Container (Obj_Id, Decl);
8815 end Is_Finalizable_Transient;
8817 ---------------------------------
8818 -- Is_Fully_Repped_Tagged_Type --
8819 ---------------------------------
8821 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8822 U : constant Entity_Id := Underlying_Type (T);
8826 if No (U) or else not Is_Tagged_Type (U) then
8828 elsif Has_Discriminants (U) then
8830 elsif not Has_Specified_Layout (U) then
8834 -- Here we have a tagged type, see if it has any component (other than
8835 -- tag and parent) with no component_clause. If so, we return False.
8837 Comp := First_Component (U);
8838 while Present (Comp) loop
8839 if not Is_Tag (Comp)
8840 and then Chars (Comp) /= Name_uParent
8841 and then No (Component_Clause (Comp))
8845 Next_Component (Comp);
8849 -- All components have clauses
8852 end Is_Fully_Repped_Tagged_Type;
8854 ----------------------------------
8855 -- Is_Library_Level_Tagged_Type --
8856 ----------------------------------
8858 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8860 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8861 end Is_Library_Level_Tagged_Type;
8863 --------------------------
8864 -- Is_Non_BIP_Func_Call --
8865 --------------------------
8867 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8869 -- The expected call is of the format
8871 -- Func_Call'reference
8874 Nkind (Expr) = N_Reference
8875 and then Nkind (Prefix (Expr)) = N_Function_Call
8876 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8877 end Is_Non_BIP_Func_Call;
8879 ----------------------------------
8880 -- Is_Possibly_Unaligned_Object --
8881 ----------------------------------
8883 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8884 T : constant Entity_Id := Etype (N);
8887 -- If renamed object, apply test to underlying object
8889 if Is_Entity_Name (N)
8890 and then Is_Object (Entity (N))
8891 and then Present (Renamed_Object (Entity (N)))
8893 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8896 -- Tagged and controlled types and aliased types are always aligned, as
8897 -- are concurrent types.
8900 or else Has_Controlled_Component (T)
8901 or else Is_Concurrent_Type (T)
8902 or else Is_Tagged_Type (T)
8903 or else Is_Controlled (T)
8908 -- If this is an element of a packed array, may be unaligned
8910 if Is_Ref_To_Bit_Packed_Array (N) then
8914 -- Case of indexed component reference: test whether prefix is unaligned
8916 if Nkind (N) = N_Indexed_Component then
8917 return Is_Possibly_Unaligned_Object (Prefix (N));
8919 -- Case of selected component reference
8921 elsif Nkind (N) = N_Selected_Component then
8923 P : constant Node_Id := Prefix (N);
8924 C : constant Entity_Id := Entity (Selector_Name (N));
8929 -- If component reference is for an array with nonstatic bounds,
8930 -- then it is always aligned: we can only process unaligned arrays
8931 -- with static bounds (more precisely compile time known bounds).
8933 if Is_Array_Type (T)
8934 and then not Compile_Time_Known_Bounds (T)
8939 -- If component is aliased, it is definitely properly aligned
8941 if Is_Aliased (C) then
8945 -- If component is for a type implemented as a scalar, and the
8946 -- record is packed, and the component is other than the first
8947 -- component of the record, then the component may be unaligned.
8949 if Is_Packed (Etype (P))
8950 and then Represented_As_Scalar (Etype (C))
8951 and then First_Entity (Scope (C)) /= C
8956 -- Compute maximum possible alignment for T
8958 -- If alignment is known, then that settles things
8960 if Known_Alignment (T) then
8961 M := UI_To_Int (Alignment (T));
8963 -- If alignment is not known, tentatively set max alignment
8966 M := Ttypes.Maximum_Alignment;
8968 -- We can reduce this if the Esize is known since the default
8969 -- alignment will never be more than the smallest power of 2
8970 -- that does not exceed this Esize value.
8972 if Known_Esize (T) then
8973 S := UI_To_Int (Esize (T));
8975 while (M / 2) >= S loop
8981 -- Case of component clause present which may specify an
8982 -- unaligned position.
8984 if Present (Component_Clause (C)) then
8986 -- Otherwise we can do a test to make sure that the actual
8987 -- start position in the record, and the length, are both
8988 -- consistent with the required alignment. If not, we know
8989 -- that we are unaligned.
8992 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8998 -- For a component inherited in a record extension, the
8999 -- clause is inherited but position and size are not set.
9001 if Is_Base_Type (Etype (P))
9002 and then Is_Tagged_Type (Etype (P))
9003 and then Present (Original_Record_Component (Comp))
9005 Comp := Original_Record_Component (Comp);
9008 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
9009 or else Esize (Comp) mod Align_In_Bits /= 0
9016 -- Otherwise, for a component reference, test prefix
9018 return Is_Possibly_Unaligned_Object (P);
9021 -- If not a component reference, must be aligned
9026 end Is_Possibly_Unaligned_Object;
9028 ---------------------------------
9029 -- Is_Possibly_Unaligned_Slice --
9030 ---------------------------------
9032 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
9034 -- Go to renamed object
9036 if Is_Entity_Name (N)
9037 and then Is_Object (Entity (N))
9038 and then Present (Renamed_Object (Entity (N)))
9040 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
9043 -- The reference must be a slice
9045 if Nkind (N) /= N_Slice then
9049 -- If it is a slice, then look at the array type being sliced
9052 Sarr : constant Node_Id := Prefix (N);
9053 -- Prefix of the slice, i.e. the array being sliced
9055 Styp : constant Entity_Id := Etype (Prefix (N));
9056 -- Type of the array being sliced
9062 -- The problems arise if the array object that is being sliced
9063 -- is a component of a record or array, and we cannot guarantee
9064 -- the alignment of the array within its containing object.
9066 -- To investigate this, we look at successive prefixes to see
9067 -- if we have a worrisome indexed or selected component.
9071 -- Case of array is part of an indexed component reference
9073 if Nkind (Pref) = N_Indexed_Component then
9074 Ptyp := Etype (Prefix (Pref));
9076 -- The only problematic case is when the array is packed, in
9077 -- which case we really know nothing about the alignment of
9078 -- individual components.
9080 if Is_Bit_Packed_Array (Ptyp) then
9084 -- Case of array is part of a selected component reference
9086 elsif Nkind (Pref) = N_Selected_Component then
9087 Ptyp := Etype (Prefix (Pref));
9089 -- We are definitely in trouble if the record in question
9090 -- has an alignment, and either we know this alignment is
9091 -- inconsistent with the alignment of the slice, or we don't
9092 -- know what the alignment of the slice should be. But this
9093 -- really matters only if the target has strict alignment.
9095 if Target_Strict_Alignment
9096 and then Known_Alignment (Ptyp)
9097 and then (not Known_Alignment (Styp)
9098 or else Alignment (Styp) > Alignment (Ptyp))
9103 -- We are in potential trouble if the record type is packed.
9104 -- We could special case when we know that the array is the
9105 -- first component, but that's not such a simple case ???
9107 if Is_Packed (Ptyp) then
9111 -- We are in trouble if there is a component clause, and
9112 -- either we do not know the alignment of the slice, or
9113 -- the alignment of the slice is inconsistent with the
9114 -- bit position specified by the component clause.
9117 Field : constant Entity_Id := Entity (Selector_Name (Pref));
9119 if Present (Component_Clause (Field))
9121 (not Known_Alignment (Styp)
9123 (Component_Bit_Offset (Field) mod
9124 (System_Storage_Unit * Alignment (Styp))) /= 0)
9130 -- For cases other than selected or indexed components we know we
9131 -- are OK, since no issues arise over alignment.
9137 -- We processed an indexed component or selected component
9138 -- reference that looked safe, so keep checking prefixes.
9140 Pref := Prefix (Pref);
9143 end Is_Possibly_Unaligned_Slice;
9145 -------------------------------
9146 -- Is_Related_To_Func_Return --
9147 -------------------------------
9149 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
9150 Expr : constant Node_Id := Related_Expression (Id);
9152 -- In the case of a function with a class-wide result that returns
9153 -- a call to a function with a specific result, we introduce a
9154 -- type conversion for the return expression. We do not want that
9155 -- type conversion to influence the result of this function.
9159 and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
9160 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
9161 end Is_Related_To_Func_Return;
9163 --------------------------------
9164 -- Is_Ref_To_Bit_Packed_Array --
9165 --------------------------------
9167 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
9172 if Is_Entity_Name (N)
9173 and then Is_Object (Entity (N))
9174 and then Present (Renamed_Object (Entity (N)))
9176 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
9179 if Nkind (N) in N_Indexed_Component | N_Selected_Component then
9180 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
9183 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
9186 if Result and then Nkind (N) = N_Indexed_Component then
9187 Expr := First (Expressions (N));
9188 while Present (Expr) loop
9189 Force_Evaluation (Expr);
9199 end Is_Ref_To_Bit_Packed_Array;
9201 --------------------------------
9202 -- Is_Ref_To_Bit_Packed_Slice --
9203 --------------------------------
9205 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
9207 if Nkind (N) = N_Type_Conversion then
9208 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
9210 elsif Is_Entity_Name (N)
9211 and then Is_Object (Entity (N))
9212 and then Present (Renamed_Object (Entity (N)))
9214 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
9216 elsif Nkind (N) = N_Slice
9217 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
9221 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
9222 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
9227 end Is_Ref_To_Bit_Packed_Slice;
9229 -----------------------
9230 -- Is_Renamed_Object --
9231 -----------------------
9233 function Is_Renamed_Object (N : Node_Id) return Boolean is
9234 Pnod : constant Node_Id := Parent (N);
9235 Kind : constant Node_Kind := Nkind (Pnod);
9237 if Kind = N_Object_Renaming_Declaration then
9239 elsif Kind in N_Indexed_Component | N_Selected_Component then
9240 return Is_Renamed_Object (Pnod);
9244 end Is_Renamed_Object;
9246 --------------------------------------
9247 -- Is_Secondary_Stack_BIP_Func_Call --
9248 --------------------------------------
9250 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
9252 Call : Node_Id := Expr;
9257 -- Build-in-place calls usually appear in 'reference format. Note that
9258 -- the accessibility check machinery may add an extra 'reference due to
9259 -- side effect removal.
9261 while Nkind (Call) = N_Reference loop
9262 Call := Prefix (Call);
9265 Call := Unqual_Conv (Call);
9267 if Is_Build_In_Place_Function_Call (Call) then
9269 -- Examine all parameter associations of the function call
9271 Param := First (Parameter_Associations (Call));
9272 while Present (Param) loop
9273 if Nkind (Param) = N_Parameter_Association then
9274 Formal := Selector_Name (Param);
9275 Actual := Explicit_Actual_Parameter (Param);
9277 -- A match for BIPalloc => 2 has been found
9279 if Is_Build_In_Place_Entity (Formal)
9280 and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
9281 and then Nkind (Actual) = N_Integer_Literal
9282 and then Intval (Actual) = Uint_2
9293 end Is_Secondary_Stack_BIP_Func_Call;
9295 -------------------------------------
9296 -- Is_Tag_To_Class_Wide_Conversion --
9297 -------------------------------------
9299 function Is_Tag_To_Class_Wide_Conversion
9300 (Obj_Id : Entity_Id) return Boolean
9302 Expr : constant Node_Id := Expression (Parent (Obj_Id));
9306 Is_Class_Wide_Type (Etype (Obj_Id))
9307 and then Present (Expr)
9308 and then Nkind (Expr) = N_Unchecked_Type_Conversion
9309 and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
9310 end Is_Tag_To_Class_Wide_Conversion;
9312 --------------------------------
9313 -- Is_Uninitialized_Aggregate --
9314 --------------------------------
9316 function Is_Uninitialized_Aggregate
9318 T : Entity_Id) return Boolean
9321 Comp_Type : Entity_Id;
9325 if Nkind (Exp) /= N_Aggregate then
9329 Preanalyze_And_Resolve (Exp, T);
9333 or else Ekind (Typ) /= E_Array_Subtype
9334 or else Present (Expressions (Exp))
9335 or else No (Component_Associations (Exp))
9339 Comp_Type := Component_Type (Typ);
9340 Comp := First (Component_Associations (Exp));
9342 if not Box_Present (Comp)
9343 or else Present (Next (Comp))
9348 return Is_Scalar_Type (Comp_Type)
9349 and then No (Default_Aspect_Component_Value (Typ));
9351 end Is_Uninitialized_Aggregate;
9353 ----------------------------
9354 -- Is_Untagged_Derivation --
9355 ----------------------------
9357 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
9359 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
9361 (Is_Private_Type (T) and then Present (Full_View (T))
9362 and then not Is_Tagged_Type (Full_View (T))
9363 and then Is_Derived_Type (Full_View (T))
9364 and then Etype (Full_View (T)) /= T);
9365 end Is_Untagged_Derivation;
9367 ------------------------------------
9368 -- Is_Untagged_Private_Derivation --
9369 ------------------------------------
9371 function Is_Untagged_Private_Derivation
9372 (Priv_Typ : Entity_Id;
9373 Full_Typ : Entity_Id) return Boolean
9378 and then Is_Untagged_Derivation (Priv_Typ)
9379 and then Is_Private_Type (Etype (Priv_Typ))
9380 and then Present (Full_Typ)
9381 and then Is_Itype (Full_Typ);
9382 end Is_Untagged_Private_Derivation;
9384 ------------------------------
9385 -- Is_Verifiable_DIC_Pragma --
9386 ------------------------------
9388 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
9389 Args : constant List_Id := Pragma_Argument_Associations (Prag);
9392 -- To qualify as verifiable, a DIC pragma must have a non-null argument
9397 -- If there are args, but the first arg is Empty, then treat the
9398 -- pragma the same as having no args (there may be a second arg that
9399 -- is an implicitly added type arg, and Empty is a placeholder).
9401 and then Present (Get_Pragma_Arg (First (Args)))
9403 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
9404 end Is_Verifiable_DIC_Pragma;
9406 ---------------------------
9407 -- Is_Volatile_Reference --
9408 ---------------------------
9410 function Is_Volatile_Reference (N : Node_Id) return Boolean is
9412 -- Only source references are to be treated as volatile, internally
9413 -- generated stuff cannot have volatile external effects.
9415 if not Comes_From_Source (N) then
9418 -- Never true for reference to a type
9420 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
9423 -- Never true for a compile time known constant
9425 elsif Compile_Time_Known_Value (N) then
9428 -- True if object reference with volatile type
9430 elsif Is_Volatile_Object_Ref (N) then
9433 -- True if reference to volatile entity
9435 elsif Is_Entity_Name (N) then
9436 return Treat_As_Volatile (Entity (N));
9438 -- True for slice of volatile array
9440 elsif Nkind (N) = N_Slice then
9441 return Is_Volatile_Reference (Prefix (N));
9443 -- True if volatile component
9445 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
9446 if (Is_Entity_Name (Prefix (N))
9447 and then Has_Volatile_Components (Entity (Prefix (N))))
9448 or else (Present (Etype (Prefix (N)))
9449 and then Has_Volatile_Components (Etype (Prefix (N))))
9453 return Is_Volatile_Reference (Prefix (N));
9461 end Is_Volatile_Reference;
9463 --------------------
9464 -- Kill_Dead_Code --
9465 --------------------
9467 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
9468 W : Boolean := Warn;
9469 -- Set False if warnings suppressed
9473 Remove_Warning_Messages (N);
9475 -- Update the internal structures of the ABE mechanism in case the
9476 -- dead node is an elaboration scenario.
9478 Kill_Elaboration_Scenario (N);
9480 -- Generate warning if appropriate
9484 -- We suppress the warning if this code is under control of an
9485 -- if/case statement and either
9486 -- a) we are in an instance and the condition/selector
9487 -- has a statically known value; or
9488 -- b) the condition/selector is a simple identifier and
9489 -- warnings off is set for this identifier.
9490 -- Dead code is common and reasonable in instances, so we don't
9491 -- want a warning in that case.
9494 C : Node_Id := Empty;
9496 if Nkind (Parent (N)) = N_If_Statement then
9497 C := Condition (Parent (N));
9498 elsif Nkind (Parent (N)) = N_Case_Statement_Alternative then
9499 C := Expression (Parent (Parent (N)));
9503 if (In_Instance and Compile_Time_Known_Value (C))
9504 or else (Nkind (C) = N_Identifier
9505 and then Present (Entity (C))
9506 and then Has_Warnings_Off (Entity (C)))
9513 -- Generate warning if not suppressed
9517 ("?t?this code can never be executed and has been deleted!",
9522 -- Recurse into block statements and bodies to process declarations
9525 if Nkind (N) = N_Block_Statement
9526 or else Nkind (N) = N_Subprogram_Body
9527 or else Nkind (N) = N_Package_Body
9529 Kill_Dead_Code (Declarations (N), False);
9530 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
9532 if Nkind (N) = N_Subprogram_Body then
9533 Set_Is_Eliminated (Defining_Entity (N));
9536 elsif Nkind (N) = N_Package_Declaration then
9537 Kill_Dead_Code (Visible_Declarations (Specification (N)));
9538 Kill_Dead_Code (Private_Declarations (Specification (N)));
9540 -- ??? After this point, Delete_Tree has been called on all
9541 -- declarations in Specification (N), so references to entities
9542 -- therein look suspicious.
9545 E : Entity_Id := First_Entity (Defining_Entity (N));
9548 while Present (E) loop
9549 if Ekind (E) = E_Operator then
9550 Set_Is_Eliminated (E);
9557 -- Recurse into composite statement to kill individual statements in
9558 -- particular instantiations.
9560 elsif Nkind (N) = N_If_Statement then
9561 Kill_Dead_Code (Then_Statements (N));
9562 Kill_Dead_Code (Elsif_Parts (N));
9563 Kill_Dead_Code (Else_Statements (N));
9565 elsif Nkind (N) = N_Loop_Statement then
9566 Kill_Dead_Code (Statements (N));
9568 elsif Nkind (N) = N_Case_Statement then
9572 Alt := First (Alternatives (N));
9573 while Present (Alt) loop
9574 Kill_Dead_Code (Statements (Alt));
9579 elsif Nkind (N) = N_Case_Statement_Alternative then
9580 Kill_Dead_Code (Statements (N));
9582 -- Deal with dead instances caused by deleting instantiations
9584 elsif Nkind (N) in N_Generic_Instantiation then
9585 Remove_Dead_Instance (N);
9590 -- Case where argument is a list of nodes to be killed
9592 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
9600 while Present (N) loop
9601 Kill_Dead_Code (N, W);
9607 -----------------------------
9608 -- Make_CW_Equivalent_Type --
9609 -----------------------------
9611 -- Create a record type used as an equivalent of any member of the class
9612 -- which takes its size from exp.
9614 -- Generate the following code:
9616 -- type Equiv_T is record
9617 -- _parent : T (List of discriminant constraints taken from Exp);
9618 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
9621 -- Note that this type does not guarantee same alignment as all derived
9624 -- Note: for the freezing circuitry, this looks like a record extension,
9625 -- and so we need to make sure that the scalar storage order is the same
9626 -- as that of the parent type. (This does not change anything for the
9627 -- representation of the extension part.)
9629 function Make_CW_Equivalent_Type
9631 E : Node_Id) return Entity_Id
9633 Loc : constant Source_Ptr := Sloc (E);
9634 Root_Typ : constant Entity_Id := Root_Type (T);
9635 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
9636 List_Def : constant List_Id := Empty_List;
9637 Comp_List : constant List_Id := New_List;
9638 Equiv_Type : Entity_Id;
9639 Range_Type : Entity_Id;
9640 Str_Type : Entity_Id;
9641 Constr_Root : Entity_Id;
9645 -- If the root type is already constrained, there are no discriminants
9646 -- in the expression.
9648 if not Has_Discriminants (Root_Typ)
9649 or else Is_Constrained (Root_Typ)
9651 Constr_Root := Root_Typ;
9653 -- At this point in the expansion, nonlimited view of the type
9654 -- must be available, otherwise the error will be reported later.
9656 if From_Limited_With (Constr_Root)
9657 and then Present (Non_Limited_View (Constr_Root))
9659 Constr_Root := Non_Limited_View (Constr_Root);
9663 Constr_Root := Make_Temporary (Loc, 'R');
9665 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9667 Append_To (List_Def,
9668 Make_Subtype_Declaration (Loc,
9669 Defining_Identifier => Constr_Root,
9670 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9673 -- Generate the range subtype declaration
9675 Range_Type := Make_Temporary (Loc, 'G');
9677 if not Is_Interface (Root_Typ) then
9679 -- subtype rg__xx is
9680 -- Storage_Offset range 1 .. (Expr'size - typ'object_size)
9684 Make_Op_Subtract (Loc,
9686 Make_Attribute_Reference (Loc,
9688 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9689 Attribute_Name => Name_Size),
9691 Make_Attribute_Reference (Loc,
9692 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9693 Attribute_Name => Name_Object_Size));
9695 -- subtype rg__xx is
9696 -- Storage_Offset range 1 .. (Expr'size - Ada.Tags.Tag'object_size)
9700 Make_Op_Subtract (Loc,
9702 Make_Attribute_Reference (Loc,
9704 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9705 Attribute_Name => Name_Size),
9707 Make_Attribute_Reference (Loc,
9708 Prefix => New_Occurrence_Of (RTE (RE_Tag), Loc),
9709 Attribute_Name => Name_Object_Size));
9712 Set_Paren_Count (Sizexpr, 1);
9714 Append_To (List_Def,
9715 Make_Subtype_Declaration (Loc,
9716 Defining_Identifier => Range_Type,
9717 Subtype_Indication =>
9718 Make_Subtype_Indication (Loc,
9719 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9720 Constraint => Make_Range_Constraint (Loc,
9723 Low_Bound => Make_Integer_Literal (Loc, 1),
9725 Make_Op_Divide (Loc,
9726 Left_Opnd => Sizexpr,
9727 Right_Opnd => Make_Integer_Literal (Loc,
9728 Intval => System_Storage_Unit)))))));
9730 -- subtype str__nn is Storage_Array (rg__x);
9732 Str_Type := Make_Temporary (Loc, 'S');
9733 Append_To (List_Def,
9734 Make_Subtype_Declaration (Loc,
9735 Defining_Identifier => Str_Type,
9736 Subtype_Indication =>
9737 Make_Subtype_Indication (Loc,
9738 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9740 Make_Index_Or_Discriminant_Constraint (Loc,
9742 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9744 -- type Equiv_T is record
9745 -- _Parent : Snn; -- not interface
9746 -- _Tag : Ada.Tags.Tag -- interface
9750 Equiv_Type := Make_Temporary (Loc, 'T');
9751 Mutate_Ekind (Equiv_Type, E_Record_Type);
9753 if not Is_Interface (Root_Typ) then
9754 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9757 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9758 -- treatment for this type. In particular, even though _parent's type
9759 -- is a controlled type or contains controlled components, we do not
9760 -- want to set Has_Controlled_Component on it to avoid making it gain
9761 -- an unwanted _controller component.
9763 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9765 -- A class-wide equivalent type does not require initialization
9767 Set_Suppress_Initialization (Equiv_Type);
9769 if not Is_Interface (Root_Typ) then
9770 Append_To (Comp_List,
9771 Make_Component_Declaration (Loc,
9772 Defining_Identifier =>
9773 Make_Defining_Identifier (Loc, Name_uParent),
9774 Component_Definition =>
9775 Make_Component_Definition (Loc,
9776 Aliased_Present => False,
9777 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9779 Set_Reverse_Storage_Order
9780 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
9781 Set_Reverse_Bit_Order
9782 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
9785 Append_To (Comp_List,
9786 Make_Component_Declaration (Loc,
9787 Defining_Identifier =>
9788 Make_Defining_Identifier (Loc, Name_uTag),
9789 Component_Definition =>
9790 Make_Component_Definition (Loc,
9791 Aliased_Present => False,
9792 Subtype_Indication =>
9793 New_Occurrence_Of (RTE (RE_Tag), Loc))));
9796 Append_To (Comp_List,
9797 Make_Component_Declaration (Loc,
9798 Defining_Identifier => Make_Temporary (Loc, 'C'),
9799 Component_Definition =>
9800 Make_Component_Definition (Loc,
9801 Aliased_Present => False,
9802 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9804 Append_To (List_Def,
9805 Make_Full_Type_Declaration (Loc,
9806 Defining_Identifier => Equiv_Type,
9808 Make_Record_Definition (Loc,
9810 Make_Component_List (Loc,
9811 Component_Items => Comp_List,
9812 Variant_Part => Empty))));
9814 -- Suppress all checks during the analysis of the expanded code to avoid
9815 -- the generation of spurious warnings under ZFP run-time.
9817 Insert_Actions (E, List_Def, Suppress => All_Checks);
9819 -- In the case of an interface type mark the tag for First_Tag_Component
9821 if Is_Interface (Root_Typ) then
9822 Set_Is_Tag (First_Entity (Equiv_Type));
9826 end Make_CW_Equivalent_Type;
9828 -------------------------
9829 -- Make_Invariant_Call --
9830 -------------------------
9832 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9833 Loc : constant Source_Ptr := Sloc (Expr);
9834 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9835 pragma Assert (Has_Invariants (Typ));
9836 Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
9837 pragma Assert (Present (Proc_Id));
9839 -- The invariant procedure has a null body if assertions are disabled or
9840 -- Assertion_Policy Ignore is in effect. In that case, generate a null
9841 -- statement instead of a call to the invariant procedure.
9843 if Has_Null_Body (Proc_Id) then
9844 return Make_Null_Statement (Loc);
9847 Make_Procedure_Call_Statement (Loc,
9848 Name => New_Occurrence_Of (Proc_Id, Loc),
9849 Parameter_Associations => New_List (Relocate_Node (Expr)));
9851 end Make_Invariant_Call;
9853 ------------------------
9854 -- Make_Literal_Range --
9855 ------------------------
9857 function Make_Literal_Range
9859 Literal_Typ : Entity_Id) return Node_Id
9861 Lo : constant Node_Id :=
9862 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9863 Index : constant Entity_Id := Etype (Lo);
9864 Length_Expr : constant Node_Id :=
9865 Make_Op_Subtract (Loc,
9867 Make_Integer_Literal (Loc,
9868 Intval => String_Literal_Length (Literal_Typ)),
9869 Right_Opnd => Make_Integer_Literal (Loc, 1));
9874 Set_Analyzed (Lo, False);
9876 if Is_Integer_Type (Index) then
9879 Left_Opnd => New_Copy_Tree (Lo),
9880 Right_Opnd => Length_Expr);
9883 Make_Attribute_Reference (Loc,
9884 Attribute_Name => Name_Val,
9885 Prefix => New_Occurrence_Of (Index, Loc),
9886 Expressions => New_List (
9889 Make_Attribute_Reference (Loc,
9890 Attribute_Name => Name_Pos,
9891 Prefix => New_Occurrence_Of (Index, Loc),
9892 Expressions => New_List (New_Copy_Tree (Lo))),
9893 Right_Opnd => Length_Expr)));
9900 end Make_Literal_Range;
9902 --------------------------
9903 -- Make_Non_Empty_Check --
9904 --------------------------
9906 function Make_Non_Empty_Check
9908 N : Node_Id) return Node_Id
9914 Make_Attribute_Reference (Loc,
9915 Attribute_Name => Name_Length,
9916 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9918 Make_Integer_Literal (Loc, 0));
9919 end Make_Non_Empty_Check;
9921 -------------------------
9922 -- Make_Predicate_Call --
9923 -------------------------
9925 -- WARNING: This routine manages Ghost regions. Return statements must be
9926 -- replaced by gotos which jump to the end of the routine and restore the
9929 function Make_Predicate_Call
9932 Mem : Boolean := False) return Node_Id
9934 Loc : constant Source_Ptr := Sloc (Expr);
9936 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9937 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9938 -- Save the Ghost-related attributes to restore on exit
9941 Func_Id : Entity_Id;
9944 Func_Id := Predicate_Function (Typ);
9945 pragma Assert (Present (Func_Id));
9947 -- The related type may be subject to pragma Ghost. Set the mode now to
9948 -- ensure that the call is properly marked as Ghost.
9950 Set_Ghost_Mode (Typ);
9952 -- Call special membership version if requested and available
9954 if Mem and then Present (Predicate_Function_M (Typ)) then
9955 Func_Id := Predicate_Function_M (Typ);
9958 -- Case of calling normal predicate function
9960 -- If the type is tagged, the expression may be class-wide, in which
9961 -- case it has to be converted to its root type, given that the
9962 -- generated predicate function is not dispatching. The conversion is
9963 -- type-safe and does not need validation, which matters when private
9964 -- extensions are involved.
9966 if Is_Tagged_Type (Typ) then
9968 Make_Function_Call (Loc,
9969 Name => New_Occurrence_Of (Func_Id, Loc),
9970 Parameter_Associations =>
9971 New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
9974 Make_Function_Call (Loc,
9975 Name => New_Occurrence_Of (Func_Id, Loc),
9976 Parameter_Associations => New_List (Relocate_Node (Expr)));
9979 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9982 end Make_Predicate_Call;
9984 --------------------------
9985 -- Make_Predicate_Check --
9986 --------------------------
9988 function Make_Predicate_Check
9990 Expr : Node_Id) return Node_Id
9992 Loc : constant Source_Ptr := Sloc (Expr);
9994 procedure Add_Failure_Expression (Args : List_Id);
9995 -- Add the failure expression of pragma Predicate_Failure (if any) to
9998 ----------------------------
9999 -- Add_Failure_Expression --
10000 ----------------------------
10002 procedure Add_Failure_Expression (Args : List_Id) is
10003 function Failure_Expression return Node_Id;
10004 pragma Inline (Failure_Expression);
10005 -- Find aspect or pragma Predicate_Failure that applies to type Typ
10006 -- and return its expression. Return Empty if no such annotation is
10009 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
10010 pragma Inline (Is_OK_PF_Aspect);
10011 -- Determine whether aspect Asp is a suitable Predicate_Failure
10012 -- aspect that applies to type Typ.
10014 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
10015 pragma Inline (Is_OK_PF_Pragma);
10016 -- Determine whether pragma Prag is a suitable Predicate_Failure
10017 -- pragma that applies to type Typ.
10019 procedure Replace_Subtype_Reference (N : Node_Id);
10020 -- Replace the current instance of type Typ denoted by N with
10021 -- expression Expr.
10023 ------------------------
10024 -- Failure_Expression --
10025 ------------------------
10027 function Failure_Expression return Node_Id is
10031 -- The management of the rep item chain involves "inheritance" of
10032 -- parent type chains. If a parent [sub]type is already subject to
10033 -- pragma Predicate_Failure, then the pragma will also appear in
10034 -- the chain of the child [sub]type, which in turn may possess a
10035 -- pragma of its own. Avoid order-dependent issues by inspecting
10036 -- the rep item chain directly. Note that routine Get_Pragma may
10037 -- return a parent pragma.
10039 Item := First_Rep_Item (Typ);
10040 while Present (Item) loop
10042 -- Predicate_Failure appears as an aspect
10044 if Nkind (Item) = N_Aspect_Specification
10045 and then Is_OK_PF_Aspect (Item)
10047 return Expression (Item);
10049 -- Predicate_Failure appears as a pragma
10051 elsif Nkind (Item) = N_Pragma
10052 and then Is_OK_PF_Pragma (Item)
10056 (Next (First (Pragma_Argument_Associations (Item))));
10059 Next_Rep_Item (Item);
10063 end Failure_Expression;
10065 ---------------------
10066 -- Is_OK_PF_Aspect --
10067 ---------------------
10069 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
10071 -- To qualify, the aspect must apply to the type subjected to the
10072 -- predicate check.
10075 Chars (Identifier (Asp)) = Name_Predicate_Failure
10076 and then Present (Entity (Asp))
10077 and then Entity (Asp) = Typ;
10078 end Is_OK_PF_Aspect;
10080 ---------------------
10081 -- Is_OK_PF_Pragma --
10082 ---------------------
10084 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
10085 Args : constant List_Id := Pragma_Argument_Associations (Prag);
10089 -- Nothing to do when the pragma does not denote Predicate_Failure
10091 if Pragma_Name (Prag) /= Name_Predicate_Failure then
10094 -- Nothing to do when the pragma lacks arguments, in which case it
10097 elsif Is_Empty_List (Args) then
10101 Typ_Arg := Get_Pragma_Arg (First (Args));
10103 -- To qualify, the local name argument of the pragma must denote
10104 -- the type subjected to the predicate check.
10107 Is_Entity_Name (Typ_Arg)
10108 and then Present (Entity (Typ_Arg))
10109 and then Entity (Typ_Arg) = Typ;
10110 end Is_OK_PF_Pragma;
10112 --------------------------------
10113 -- Replace_Subtype_Reference --
10114 --------------------------------
10116 procedure Replace_Subtype_Reference (N : Node_Id) is
10118 Rewrite (N, New_Copy_Tree (Expr));
10119 end Replace_Subtype_Reference;
10121 procedure Replace_Subtype_References is
10122 new Replace_Type_References_Generic (Replace_Subtype_Reference);
10126 PF_Expr : constant Node_Id := Failure_Expression;
10129 -- Start of processing for Add_Failure_Expression
10132 if Present (PF_Expr) then
10134 -- Replace any occurrences of the current instance of the type
10135 -- with the object subjected to the predicate check.
10137 Expr := New_Copy_Tree (PF_Expr);
10138 Replace_Subtype_References (Expr, Typ);
10140 -- The failure expression appears as the third argument of the
10144 Make_Pragma_Argument_Association (Loc,
10145 Expression => Expr));
10147 end Add_Failure_Expression;
10154 -- Start of processing for Make_Predicate_Check
10157 -- If predicate checks are suppressed, then return a null statement. For
10158 -- this call, we check only the scope setting. If the caller wants to
10159 -- check a specific entity's setting, they must do it manually.
10161 if Predicate_Checks_Suppressed (Empty) then
10162 return Make_Null_Statement (Loc);
10165 -- Do not generate a check within stream functions and the like.
10167 if not Predicate_Check_In_Scope (Expr) then
10168 return Make_Null_Statement (Loc);
10171 -- Compute proper name to use, we need to get this right so that the
10172 -- right set of check policies apply to the Check pragma we are making.
10174 if Has_Dynamic_Predicate_Aspect (Typ) then
10175 Nam := Name_Dynamic_Predicate;
10176 elsif Has_Static_Predicate_Aspect (Typ) then
10177 Nam := Name_Static_Predicate;
10179 Nam := Name_Predicate;
10183 Make_Pragma_Argument_Association (Loc,
10184 Expression => Make_Identifier (Loc, Nam)),
10185 Make_Pragma_Argument_Association (Loc,
10186 Expression => Make_Predicate_Call (Typ, Expr)));
10188 -- If the subtype is subject to pragma Predicate_Failure, add the
10189 -- failure expression as an additional parameter.
10191 Add_Failure_Expression (Args);
10195 Chars => Name_Check,
10196 Pragma_Argument_Associations => Args);
10197 end Make_Predicate_Check;
10199 ----------------------------
10200 -- Make_Subtype_From_Expr --
10201 ----------------------------
10203 -- 1. If Expr is an unconstrained array expression, creates
10204 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
10206 -- 2. If Expr is a unconstrained discriminated type expression, creates
10207 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
10209 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
10211 function Make_Subtype_From_Expr
10213 Unc_Typ : Entity_Id;
10214 Related_Id : Entity_Id := Empty) return Node_Id
10216 List_Constr : constant List_Id := New_List;
10217 Loc : constant Source_Ptr := Sloc (E);
10219 Full_Exp : Node_Id;
10220 Full_Subtyp : Entity_Id;
10221 High_Bound : Entity_Id;
10222 Index_Typ : Entity_Id;
10223 Low_Bound : Entity_Id;
10224 Priv_Subtyp : Entity_Id;
10228 if Is_Private_Type (Unc_Typ)
10229 and then Has_Unknown_Discriminants (Unc_Typ)
10231 -- The caller requests a unique external name for both the private
10232 -- and the full subtype.
10234 if Present (Related_Id) then
10236 Make_Defining_Identifier (Loc,
10237 Chars => New_External_Name (Chars (Related_Id), 'C'));
10239 Make_Defining_Identifier (Loc,
10240 Chars => New_External_Name (Chars (Related_Id), 'P'));
10243 Full_Subtyp := Make_Temporary (Loc, 'C');
10244 Priv_Subtyp := Make_Temporary (Loc, 'P');
10247 -- Prepare the subtype completion. Use the base type to find the
10248 -- underlying type because the type may be a generic actual or an
10249 -- explicit subtype.
10251 Utyp := Underlying_Type (Base_Type (Unc_Typ));
10254 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
10255 Set_Parent (Full_Exp, Parent (E));
10258 Make_Subtype_Declaration (Loc,
10259 Defining_Identifier => Full_Subtyp,
10260 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
10262 -- Define the dummy private subtype
10264 Mutate_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
10265 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
10266 Set_Scope (Priv_Subtyp, Full_Subtyp);
10267 Set_Is_Constrained (Priv_Subtyp);
10268 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
10269 Set_Is_Itype (Priv_Subtyp);
10270 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
10272 if Is_Tagged_Type (Priv_Subtyp) then
10273 Set_Class_Wide_Type
10274 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
10275 Set_Direct_Primitive_Operations (Priv_Subtyp,
10276 Direct_Primitive_Operations (Unc_Typ));
10279 Set_Full_View (Priv_Subtyp, Full_Subtyp);
10281 return New_Occurrence_Of (Priv_Subtyp, Loc);
10283 elsif Is_Array_Type (Unc_Typ) then
10284 Index_Typ := First_Index (Unc_Typ);
10285 for J in 1 .. Number_Dimensions (Unc_Typ) loop
10287 -- Capture the bounds of each index constraint in case the context
10288 -- is an object declaration of an unconstrained type initialized
10289 -- by a function call:
10291 -- Obj : Unconstr_Typ := Func_Call;
10293 -- This scenario requires secondary scope management and the index
10294 -- constraint cannot depend on the temporary used to capture the
10295 -- result of the function call.
10298 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
10299 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
10300 -- Obj : S := Temp.all;
10301 -- SS_Release; -- Temp is gone at this point, bounds of S are
10302 -- -- non existent.
10305 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
10307 Low_Bound := Make_Temporary (Loc, 'B');
10309 Make_Object_Declaration (Loc,
10310 Defining_Identifier => Low_Bound,
10311 Object_Definition =>
10312 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
10313 Constant_Present => True,
10315 Make_Attribute_Reference (Loc,
10316 Prefix => Duplicate_Subexpr_No_Checks (E),
10317 Attribute_Name => Name_First,
10318 Expressions => New_List (
10319 Make_Integer_Literal (Loc, J)))));
10322 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
10324 High_Bound := Make_Temporary (Loc, 'B');
10326 Make_Object_Declaration (Loc,
10327 Defining_Identifier => High_Bound,
10328 Object_Definition =>
10329 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
10330 Constant_Present => True,
10332 Make_Attribute_Reference (Loc,
10333 Prefix => Duplicate_Subexpr_No_Checks (E),
10334 Attribute_Name => Name_Last,
10335 Expressions => New_List (
10336 Make_Integer_Literal (Loc, J)))));
10338 Append_To (List_Constr,
10340 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
10341 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
10343 Next_Index (Index_Typ);
10346 elsif Is_Class_Wide_Type (Unc_Typ) then
10348 CW_Subtype : Entity_Id;
10349 EQ_Typ : Entity_Id := Empty;
10352 -- A class-wide equivalent type is not needed on VM targets
10353 -- because the VM back-ends handle the class-wide object
10354 -- initialization itself (and doesn't need or want the
10355 -- additional intermediate type to handle the assignment).
10357 if Expander_Active and then Tagged_Type_Expansion then
10359 -- If this is the class-wide type of a completion that is a
10360 -- record subtype, set the type of the class-wide type to be
10361 -- the full base type, for use in the expanded code for the
10362 -- equivalent type. Should this be done earlier when the
10363 -- completion is analyzed ???
10365 if Is_Private_Type (Etype (Unc_Typ))
10367 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
10369 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
10372 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
10375 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
10376 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
10377 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
10379 return New_Occurrence_Of (CW_Subtype, Loc);
10382 -- Indefinite record type with discriminants
10385 D := First_Discriminant (Unc_Typ);
10386 while Present (D) loop
10387 Append_To (List_Constr,
10388 Make_Selected_Component (Loc,
10389 Prefix => Duplicate_Subexpr_No_Checks (E),
10390 Selector_Name => New_Occurrence_Of (D, Loc)));
10392 Next_Discriminant (D);
10397 Make_Subtype_Indication (Loc,
10398 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
10400 Make_Index_Or_Discriminant_Constraint (Loc,
10401 Constraints => List_Constr));
10402 end Make_Subtype_From_Expr;
10404 -----------------------------
10405 -- Make_Variant_Comparison --
10406 -----------------------------
10408 function Make_Variant_Comparison
10412 Curr_Val : Node_Id;
10413 Old_Val : Node_Id) return Node_Id
10415 function Big_Integer_Lt return Entity_Id;
10416 -- Returns the entity of the predefined "<" function from
10417 -- Ada.Numerics.Big_Numbers.Big_Integers.
10419 --------------------
10420 -- Big_Integer_Lt --
10421 --------------------
10423 function Big_Integer_Lt return Entity_Id is
10424 Big_Integers : constant Entity_Id :=
10425 RTU_Entity (Ada_Numerics_Big_Numbers_Big_Integers);
10427 E : Entity_Id := First_Entity (Big_Integers);
10430 while Present (E) loop
10431 if Chars (E) = Name_Op_Lt then
10437 raise Program_Error;
10438 end Big_Integer_Lt;
10440 -- Start of processing for Make_Variant_Comparison
10443 if Mode = Name_Increases then
10444 return Make_Op_Gt (Loc, Curr_Val, Old_Val);
10446 else pragma Assert (Mode = Name_Decreases);
10448 -- For discrete expressions use the "<" operator
10450 if Is_Discrete_Type (Typ) then
10451 return Make_Op_Lt (Loc, Curr_Val, Old_Val);
10453 -- For Big_Integer expressions use the "<" function, because the
10454 -- operator on private type might not be visible and won't be
10457 else pragma Assert (Is_RTE (Base_Type (Typ), RE_Big_Integer));
10459 Make_Function_Call (Loc,
10461 New_Occurrence_Of (Big_Integer_Lt, Loc),
10462 Parameter_Associations =>
10463 New_List (Curr_Val, Old_Val));
10466 end Make_Variant_Comparison;
10472 procedure Map_Formals
10473 (Parent_Subp : Entity_Id;
10474 Derived_Subp : Entity_Id;
10475 Force_Update : Boolean := False)
10477 Par_Formal : Entity_Id := First_Formal (Parent_Subp);
10478 Subp_Formal : Entity_Id := First_Formal (Derived_Subp);
10481 if Force_Update then
10482 Type_Map.Set (Parent_Subp, Derived_Subp);
10485 -- At this stage either we are under regular processing and the caller
10486 -- has previously ensured that these primitives are already mapped (by
10487 -- means of calling previously to Update_Primitives_Mapping), or we are
10488 -- processing a late-overriding primitive and Force_Update updated above
10489 -- the mapping of these primitives.
10491 while Present (Par_Formal) and then Present (Subp_Formal) loop
10492 Type_Map.Set (Par_Formal, Subp_Formal);
10493 Next_Formal (Par_Formal);
10494 Next_Formal (Subp_Formal);
10502 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
10504 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
10505 -- avoid deep indentation of code.
10507 -- NOTE: Routines which deal with discriminant mapping operate on the
10508 -- [underlying/record] full view of various types because those views
10509 -- contain all discriminants and stored constraints.
10511 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
10512 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
10513 -- overriding chain starting from Prim whose dispatching type is parent
10514 -- type Par_Typ and add a mapping between the result and primitive Prim.
10516 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
10517 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
10518 -- the inheritance or overriding chain of subprogram Subp. Return Empty
10519 -- if no such primitive is available.
10521 function Build_Chain
10522 (Par_Typ : Entity_Id;
10523 Deriv_Typ : Entity_Id) return Elist_Id;
10524 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
10525 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
10526 -- list has the form:
10530 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
10532 -- Note that Par_Typ is not part of the resulting derivation chain
10534 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
10535 -- Return the view of type Typ which could potentially contains either
10536 -- the discriminants or stored constraints of the type.
10538 function Find_Discriminant_Value
10539 (Discr : Entity_Id;
10540 Par_Typ : Entity_Id;
10541 Deriv_Typ : Entity_Id;
10542 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
10543 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
10544 -- in the derivation chain starting from parent type Par_Typ leading to
10545 -- derived type Deriv_Typ. The returned value is one of the following:
10547 -- * An entity which is either a discriminant or a nondiscriminant
10548 -- name, and renames/constraints Discr.
10550 -- * An expression which constraints Discr
10552 -- Typ_Elmt is an element of the derivation chain created by routine
10553 -- Build_Chain and denotes the current ancestor being examined.
10555 procedure Map_Discriminants
10556 (Par_Typ : Entity_Id;
10557 Deriv_Typ : Entity_Id);
10558 -- Map each discriminant of type Par_Typ to a meaningful constraint
10559 -- from the point of view of type Deriv_Typ.
10561 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
10562 -- Map each primitive of type Par_Typ to a corresponding primitive of
10565 -------------------
10566 -- Add_Primitive --
10567 -------------------
10569 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
10570 Par_Prim : Entity_Id;
10573 -- Inspect the inheritance chain through the Alias attribute and the
10574 -- overriding chain through the Overridden_Operation looking for an
10575 -- ancestor primitive with the appropriate dispatching type.
10578 while Present (Par_Prim) loop
10579 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
10580 Par_Prim := Ancestor_Primitive (Par_Prim);
10583 -- Create a mapping of the form:
10585 -- parent type primitive -> derived type primitive
10587 if Present (Par_Prim) then
10588 Type_Map.Set (Par_Prim, Prim);
10592 ------------------------
10593 -- Ancestor_Primitive --
10594 ------------------------
10596 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
10597 Inher_Prim : constant Entity_Id := Alias (Subp);
10598 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
10601 -- The current subprogram overrides an ancestor primitive
10603 if Present (Over_Prim) then
10606 -- The current subprogram is an internally generated alias of an
10607 -- inherited ancestor primitive.
10609 elsif Present (Inher_Prim) then
10610 -- It is possible that an internally generated alias could be
10611 -- set to a subprogram which overrides the same aliased primitive,
10612 -- so return Empty in this case.
10614 if Ancestor_Primitive (Inher_Prim) = Subp then
10620 -- Otherwise the current subprogram is the root of the inheritance or
10621 -- overriding chain.
10626 end Ancestor_Primitive;
10632 function Build_Chain
10633 (Par_Typ : Entity_Id;
10634 Deriv_Typ : Entity_Id) return Elist_Id
10636 Anc_Typ : Entity_Id;
10638 Curr_Typ : Entity_Id;
10641 Chain := New_Elmt_List;
10643 -- Add the derived type to the derivation chain
10645 Prepend_Elmt (Deriv_Typ, Chain);
10647 -- Examine all ancestors starting from the derived type climbing
10648 -- towards parent type Par_Typ.
10650 Curr_Typ := Deriv_Typ;
10652 -- Handle the case where the current type is a record which
10653 -- derives from a subtype.
10655 -- subtype Sub_Typ is Par_Typ ...
10656 -- type Deriv_Typ is Sub_Typ ...
10658 if Ekind (Curr_Typ) = E_Record_Type
10659 and then Present (Parent_Subtype (Curr_Typ))
10661 Anc_Typ := Parent_Subtype (Curr_Typ);
10663 -- Handle the case where the current type is a record subtype of
10664 -- another subtype.
10666 -- subtype Sub_Typ1 is Par_Typ ...
10667 -- subtype Sub_Typ2 is Sub_Typ1 ...
10669 elsif Ekind (Curr_Typ) = E_Record_Subtype
10670 and then Present (Cloned_Subtype (Curr_Typ))
10672 Anc_Typ := Cloned_Subtype (Curr_Typ);
10674 -- Otherwise use the direct parent type
10677 Anc_Typ := Etype (Curr_Typ);
10680 -- Use the first subtype when dealing with itypes
10682 if Is_Itype (Anc_Typ) then
10683 Anc_Typ := First_Subtype (Anc_Typ);
10686 -- Work with the view which contains the discriminants and stored
10689 Anc_Typ := Discriminated_View (Anc_Typ);
10691 -- Stop the climb when either the parent type has been reached or
10692 -- there are no more ancestors left to examine.
10694 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
10696 Prepend_Unique_Elmt (Anc_Typ, Chain);
10697 Curr_Typ := Anc_Typ;
10703 ------------------------
10704 -- Discriminated_View --
10705 ------------------------
10707 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
10713 -- Use the [underlying] full view when dealing with private types
10714 -- because the view contains all inherited discriminants or stored
10717 if Is_Private_Type (T) then
10718 if Present (Underlying_Full_View (T)) then
10719 T := Underlying_Full_View (T);
10721 elsif Present (Full_View (T)) then
10722 T := Full_View (T);
10726 -- Use the underlying record view when the type is an extenstion of
10727 -- a parent type with unknown discriminants because the view contains
10728 -- all inherited discriminants or stored constraints.
10730 if Ekind (T) = E_Record_Type
10731 and then Present (Underlying_Record_View (T))
10733 T := Underlying_Record_View (T);
10737 end Discriminated_View;
10739 -----------------------------
10740 -- Find_Discriminant_Value --
10741 -----------------------------
10743 function Find_Discriminant_Value
10744 (Discr : Entity_Id;
10745 Par_Typ : Entity_Id;
10746 Deriv_Typ : Entity_Id;
10747 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
10749 Discr_Pos : constant Uint := Discriminant_Number (Discr);
10750 Typ : constant Entity_Id := Node (Typ_Elmt);
10752 function Find_Constraint_Value
10753 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
10754 -- Given constraint Constr, find what it denotes. This is either:
10756 -- * An entity which is either a discriminant or a name
10760 ---------------------------
10761 -- Find_Constraint_Value --
10762 ---------------------------
10764 function Find_Constraint_Value
10765 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
10768 if Nkind (Constr) in N_Entity then
10770 -- The constraint denotes a discriminant of the curren type
10771 -- which renames the ancestor discriminant:
10774 -- type Typ (D1 : ...; DN : ...) is
10775 -- new Anc (Discr => D1) with ...
10778 if Ekind (Constr) = E_Discriminant then
10780 -- The discriminant belongs to derived type Deriv_Typ. This
10781 -- is the final value for the ancestor discriminant as the
10782 -- derivations chain has been fully exhausted.
10784 if Typ = Deriv_Typ then
10787 -- Otherwise the discriminant may be renamed or constrained
10788 -- at a lower level. Continue looking down the derivation
10793 Find_Discriminant_Value
10795 Par_Typ => Par_Typ,
10796 Deriv_Typ => Deriv_Typ,
10797 Typ_Elmt => Next_Elmt (Typ_Elmt));
10800 -- Otherwise the constraint denotes a reference to some name
10801 -- which results in a Stored discriminant:
10805 -- type Typ (D1 : ...; DN : ...) is
10806 -- new Anc (Discr => Name) with ...
10809 -- Return the name as this is the proper constraint of the
10816 -- The constraint denotes a reference to a name
10818 elsif Is_Entity_Name (Constr) then
10819 return Find_Constraint_Value (Entity (Constr));
10821 -- Otherwise the current constraint is an expression which yields
10822 -- a Stored discriminant:
10824 -- type Typ (D1 : ...; DN : ...) is
10825 -- new Anc (Discr => <expression>) with ...
10828 -- Return the expression as this is the proper constraint of the
10834 end Find_Constraint_Value;
10838 Constrs : constant Elist_Id := Stored_Constraint (Typ);
10840 Constr_Elmt : Elmt_Id;
10842 Typ_Discr : Entity_Id;
10844 -- Start of processing for Find_Discriminant_Value
10847 -- The algorithm for finding the value of a discriminant works as
10848 -- follows. First, it recreates the derivation chain from Par_Typ
10849 -- to Deriv_Typ as a list:
10851 -- Par_Typ (shown for completeness)
10853 -- Ancestor_N <-- head of chain
10857 -- Deriv_Typ <-- tail of chain
10859 -- The algorithm then traces the fate of a parent discriminant down
10860 -- the derivation chain. At each derivation level, the discriminant
10861 -- may be either inherited or constrained.
10863 -- 1) Discriminant is inherited: there are two cases, depending on
10864 -- which type is inheriting.
10866 -- 1.1) Deriv_Typ is inheriting:
10868 -- type Ancestor (D_1 : ...) is tagged ...
10869 -- type Deriv_Typ is new Ancestor ...
10871 -- In this case the inherited discriminant is the final value of
10872 -- the parent discriminant because the end of the derivation chain
10873 -- has been reached.
10875 -- 1.2) Some other type is inheriting:
10877 -- type Ancestor_1 (D_1 : ...) is tagged ...
10878 -- type Ancestor_2 is new Ancestor_1 ...
10880 -- In this case the algorithm continues to trace the fate of the
10881 -- inherited discriminant down the derivation chain because it may
10882 -- be further inherited or constrained.
10884 -- 2) Discriminant is constrained: there are three cases, depending
10885 -- on what the constraint is.
10887 -- 2.1) The constraint is another discriminant (aka renaming):
10889 -- type Ancestor_1 (D_1 : ...) is tagged ...
10890 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
10892 -- In this case the constraining discriminant becomes the one to
10893 -- track down the derivation chain. The algorithm already knows
10894 -- that D_2 constrains D_1, therefore if the algorithm finds the
10895 -- value of D_2, then this would also be the value for D_1.
10897 -- 2.2) The constraint is a name (aka Stored):
10900 -- type Ancestor_1 (D_1 : ...) is tagged ...
10901 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
10903 -- In this case the name is the final value of D_1 because the
10904 -- discriminant cannot be further constrained.
10906 -- 2.3) The constraint is an expression (aka Stored):
10908 -- type Ancestor_1 (D_1 : ...) is tagged ...
10909 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10911 -- Similar to 2.2, the expression is the final value of D_1
10915 -- When a derived type constrains its parent type, all constaints
10916 -- appear in the Stored_Constraint list. Examine the list looking
10917 -- for a positional match.
10919 if Present (Constrs) then
10920 Constr_Elmt := First_Elmt (Constrs);
10921 while Present (Constr_Elmt) loop
10923 -- The position of the current constraint matches that of the
10924 -- ancestor discriminant.
10926 if Pos = Discr_Pos then
10927 return Find_Constraint_Value (Node (Constr_Elmt));
10930 Next_Elmt (Constr_Elmt);
10934 -- Otherwise the derived type does not constraint its parent type in
10935 -- which case it inherits the parent discriminants.
10938 Typ_Discr := First_Discriminant (Typ);
10939 while Present (Typ_Discr) loop
10941 -- The position of the current discriminant matches that of the
10942 -- ancestor discriminant.
10944 if Pos = Discr_Pos then
10945 return Find_Constraint_Value (Typ_Discr);
10948 Next_Discriminant (Typ_Discr);
10953 -- A discriminant must always have a corresponding value. This is
10954 -- either another discriminant, a name, or an expression. If this
10955 -- point is reached, them most likely the derivation chain employs
10956 -- the wrong views of types.
10958 pragma Assert (False);
10961 end Find_Discriminant_Value;
10963 -----------------------
10964 -- Map_Discriminants --
10965 -----------------------
10967 procedure Map_Discriminants
10968 (Par_Typ : Entity_Id;
10969 Deriv_Typ : Entity_Id)
10971 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10974 Discr_Val : Node_Or_Entity_Id;
10977 -- Examine each discriminant of parent type Par_Typ and find a
10978 -- suitable value for it from the point of view of derived type
10981 if Has_Discriminants (Par_Typ) then
10982 Discr := First_Discriminant (Par_Typ);
10983 while Present (Discr) loop
10985 Find_Discriminant_Value
10987 Par_Typ => Par_Typ,
10988 Deriv_Typ => Deriv_Typ,
10989 Typ_Elmt => First_Elmt (Deriv_Chain));
10991 -- Create a mapping of the form:
10993 -- parent type discriminant -> value
10995 Type_Map.Set (Discr, Discr_Val);
10997 Next_Discriminant (Discr);
11000 end Map_Discriminants;
11002 --------------------
11003 -- Map_Primitives --
11004 --------------------
11006 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
11007 Deriv_Prim : Entity_Id;
11008 Par_Prim : Entity_Id;
11009 Par_Prims : Elist_Id;
11010 Prim_Elmt : Elmt_Id;
11013 -- Inspect the primitives of the derived type and determine whether
11014 -- they relate to the primitives of the parent type. If there is a
11015 -- meaningful relation, create a mapping of the form:
11017 -- parent type primitive -> derived type primitive
11019 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
11020 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
11021 while Present (Prim_Elmt) loop
11022 Deriv_Prim := Node (Prim_Elmt);
11024 if Is_Subprogram (Deriv_Prim)
11025 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
11027 Add_Primitive (Deriv_Prim, Par_Typ);
11030 Next_Elmt (Prim_Elmt);
11034 -- If the parent operation is an interface operation, the overriding
11035 -- indicator is not present. Instead, we get from the interface
11036 -- operation the primitive of the current type that implements it.
11038 if Is_Interface (Par_Typ) then
11039 Par_Prims := Collect_Primitive_Operations (Par_Typ);
11041 if Present (Par_Prims) then
11042 Prim_Elmt := First_Elmt (Par_Prims);
11044 while Present (Prim_Elmt) loop
11045 Par_Prim := Node (Prim_Elmt);
11047 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
11049 if Present (Deriv_Prim) then
11050 Type_Map.Set (Par_Prim, Deriv_Prim);
11053 Next_Elmt (Prim_Elmt);
11057 end Map_Primitives;
11059 -- Start of processing for Map_Types
11062 -- Nothing to do if there are no types to work with
11064 if No (Parent_Type) or else No (Derived_Type) then
11067 -- Nothing to do if the mapping already exists
11069 elsif Type_Map.Get (Parent_Type) = Derived_Type then
11072 -- Nothing to do if both types are not tagged. Note that untagged types
11073 -- do not have primitive operations and their discriminants are already
11074 -- handled by gigi.
11076 elsif not Is_Tagged_Type (Parent_Type)
11077 or else not Is_Tagged_Type (Derived_Type)
11082 -- Create a mapping of the form
11084 -- parent type -> derived type
11086 -- to prevent any subsequent attempts to produce the same relations
11088 Type_Map.Set (Parent_Type, Derived_Type);
11090 -- Create mappings of the form
11092 -- parent type discriminant -> derived type discriminant
11094 -- parent type discriminant -> constraint
11096 -- Note that mapping of discriminants breaks privacy because it needs to
11097 -- work with those views which contains the discriminants and any stored
11101 (Par_Typ => Discriminated_View (Parent_Type),
11102 Deriv_Typ => Discriminated_View (Derived_Type));
11104 -- Create mappings of the form
11106 -- parent type primitive -> derived type primitive
11109 (Par_Typ => Parent_Type,
11110 Deriv_Typ => Derived_Type);
11113 ----------------------------
11114 -- Matching_Standard_Type --
11115 ----------------------------
11117 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
11118 pragma Assert (Is_Scalar_Type (Typ));
11119 Siz : constant Uint := Esize (Typ);
11122 -- Floating-point cases
11124 if Is_Floating_Point_Type (Typ) then
11125 if Siz <= Esize (Standard_Short_Float) then
11126 return Standard_Short_Float;
11127 elsif Siz <= Esize (Standard_Float) then
11128 return Standard_Float;
11129 elsif Siz <= Esize (Standard_Long_Float) then
11130 return Standard_Long_Float;
11131 elsif Siz <= Esize (Standard_Long_Long_Float) then
11132 return Standard_Long_Long_Float;
11134 raise Program_Error;
11137 -- Integer cases (includes fixed-point types)
11139 -- Unsigned integer cases (includes normal enumeration types)
11142 return Small_Integer_Type_For (Siz, Is_Unsigned_Type (Typ));
11144 end Matching_Standard_Type;
11146 -----------------------------
11147 -- May_Generate_Large_Temp --
11148 -----------------------------
11150 -- At the current time, the only types that we return False for (i.e. where
11151 -- we decide we know they cannot generate large temps) are ones where we
11152 -- know the size is 256 bits or less at compile time, and we are still not
11153 -- doing a thorough job on arrays and records.
11155 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
11157 if not Size_Known_At_Compile_Time (Typ) then
11161 if Known_Esize (Typ) and then Esize (Typ) <= 256 then
11165 if Is_Array_Type (Typ)
11166 and then Present (Packed_Array_Impl_Type (Typ))
11168 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
11172 end May_Generate_Large_Temp;
11174 --------------------------------------------
11175 -- Needs_Conditional_Null_Excluding_Check --
11176 --------------------------------------------
11178 function Needs_Conditional_Null_Excluding_Check
11179 (Typ : Entity_Id) return Boolean
11183 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
11184 end Needs_Conditional_Null_Excluding_Check;
11186 ----------------------------
11187 -- Needs_Constant_Address --
11188 ----------------------------
11190 function Needs_Constant_Address
11192 Typ : Entity_Id) return Boolean
11195 -- If we have no initialization of any kind, then we don't need to place
11196 -- any restrictions on the address clause, because the object will be
11197 -- elaborated after the address clause is evaluated. This happens if the
11198 -- declaration has no initial expression, or the type has no implicit
11199 -- initialization, or the object is imported.
11201 -- The same holds for all initialized scalar types and all access types.
11202 -- Packed bit array types of size up to the maximum integer size are
11203 -- represented using a modular type with an initialization (to zero) and
11204 -- can be processed like other initialized scalar types.
11206 -- If the type is controlled, code to attach the object to a
11207 -- finalization chain is generated at the point of declaration, and
11208 -- therefore the elaboration of the object cannot be delayed: the
11209 -- address expression must be a constant.
11211 if No (Expression (Decl))
11212 and then not Needs_Finalization (Typ)
11214 (not Has_Non_Null_Base_Init_Proc (Typ)
11215 or else Is_Imported (Defining_Identifier (Decl)))
11219 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
11220 or else Is_Access_Type (Typ)
11222 (Is_Bit_Packed_Array (Typ)
11223 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
11228 -- Otherwise, we require the address clause to be constant because
11229 -- the call to the initialization procedure (or the attach code) has
11230 -- to happen at the point of the declaration.
11232 -- Actually the IP call has been moved to the freeze actions anyway,
11233 -- so maybe we can relax this restriction???
11237 end Needs_Constant_Address;
11239 ----------------------------
11240 -- New_Class_Wide_Subtype --
11241 ----------------------------
11243 function New_Class_Wide_Subtype
11244 (CW_Typ : Entity_Id;
11245 N : Node_Id) return Entity_Id
11247 Res : constant Entity_Id := Create_Itype (E_Void, N);
11249 -- Capture relevant attributes of the class-wide subtype which must be
11250 -- restored after the copy.
11252 Res_Chars : constant Name_Id := Chars (Res);
11253 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
11254 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
11255 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
11256 Res_Scope : constant Entity_Id := Scope (Res);
11259 Copy_Node (CW_Typ, Res);
11261 -- Restore the relevant attributes of the class-wide subtype
11263 Set_Chars (Res, Res_Chars);
11264 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
11265 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
11266 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
11267 Set_Scope (Res, Res_Scope);
11269 -- Decorate the class-wide subtype
11271 Set_Associated_Node_For_Itype (Res, N);
11272 Set_Comes_From_Source (Res, False);
11273 Mutate_Ekind (Res, E_Class_Wide_Subtype);
11274 Set_Etype (Res, Base_Type (CW_Typ));
11275 Set_Freeze_Node (Res, Empty);
11276 Set_Is_Frozen (Res, False);
11277 Set_Is_Itype (Res);
11278 Set_Is_Public (Res, False);
11279 Set_Next_Entity (Res, Empty);
11280 Set_Prev_Entity (Res, Empty);
11281 Set_Sloc (Res, Sloc (N));
11283 Set_Public_Status (Res);
11286 end New_Class_Wide_Subtype;
11288 -----------------------------------
11289 -- OK_To_Do_Constant_Replacement --
11290 -----------------------------------
11292 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
11293 ES : constant Entity_Id := Scope (E);
11297 -- Do not replace statically allocated objects, because they may be
11298 -- modified outside the current scope.
11300 if Is_Statically_Allocated (E) then
11303 -- Do not replace aliased or volatile objects, since we don't know what
11304 -- else might change the value.
11306 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
11309 -- Debug flag -gnatdM disconnects this optimization
11311 elsif Debug_Flag_MM then
11314 -- Otherwise check scopes
11317 CS := Current_Scope;
11320 -- If we are in right scope, replacement is safe
11325 -- Packages do not affect the determination of safety
11327 elsif Ekind (CS) = E_Package then
11328 exit when CS = Standard_Standard;
11331 -- Blocks do not affect the determination of safety
11333 elsif Ekind (CS) = E_Block then
11336 -- Loops do not affect the determination of safety. Note that we
11337 -- kill all current values on entry to a loop, so we are just
11338 -- talking about processing within a loop here.
11340 elsif Ekind (CS) = E_Loop then
11343 -- Otherwise, the reference is dubious, and we cannot be sure that
11344 -- it is safe to do the replacement.
11353 end OK_To_Do_Constant_Replacement;
11355 ------------------------------------
11356 -- Possible_Bit_Aligned_Component --
11357 ------------------------------------
11359 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
11361 -- Do not process an unanalyzed node because it is not yet decorated and
11362 -- most checks performed below will fail.
11364 if not Analyzed (N) then
11368 -- There are never alignment issues in CodePeer mode
11370 if CodePeer_Mode then
11376 -- Case of indexed component
11378 when N_Indexed_Component =>
11380 P : constant Node_Id := Prefix (N);
11381 Ptyp : constant Entity_Id := Etype (P);
11384 -- If we know the component size and it is not larger than the
11385 -- maximum integer size, then we are OK. The back end does the
11386 -- assignment of small misaligned objects correctly.
11388 if Known_Static_Component_Size (Ptyp)
11389 and then Component_Size (Ptyp) <= System_Max_Integer_Size
11393 -- Otherwise, we need to test the prefix, to see if we are
11394 -- indexing from a possibly unaligned component.
11397 return Possible_Bit_Aligned_Component (P);
11401 -- Case of selected component
11403 when N_Selected_Component =>
11405 P : constant Node_Id := Prefix (N);
11406 Comp : constant Entity_Id := Entity (Selector_Name (N));
11409 -- This is the crucial test: if the component itself causes
11410 -- trouble, then we can stop and return True.
11412 if Component_May_Be_Bit_Aligned (Comp) then
11415 -- Otherwise, we need to test the prefix, to see if we are
11416 -- selecting from a possibly unaligned component.
11419 return Possible_Bit_Aligned_Component (P);
11423 -- For a slice, test the prefix, if that is possibly misaligned,
11424 -- then for sure the slice is.
11427 return Possible_Bit_Aligned_Component (Prefix (N));
11429 -- For an unchecked conversion, check whether the expression may
11432 when N_Unchecked_Type_Conversion =>
11433 return Possible_Bit_Aligned_Component (Expression (N));
11435 -- If we have none of the above, it means that we have fallen off the
11436 -- top testing prefixes recursively, and we now have a stand alone
11437 -- object, where we don't have a problem, unless this is a renaming,
11438 -- in which case we need to look into the renamed object.
11441 if Is_Entity_Name (N)
11442 and then Is_Object (Entity (N))
11443 and then Present (Renamed_Object (Entity (N)))
11446 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
11451 end Possible_Bit_Aligned_Component;
11453 -----------------------------------------------
11454 -- Process_Statements_For_Controlled_Objects --
11455 -----------------------------------------------
11457 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
11458 Loc : constant Source_Ptr := Sloc (N);
11460 function Are_Wrapped (L : List_Id) return Boolean;
11461 -- Determine whether list L contains only one statement which is a block
11463 function Wrap_Statements_In_Block
11465 Scop : Entity_Id := Current_Scope) return Node_Id;
11466 -- Given a list of statements L, wrap it in a block statement and return
11467 -- the generated node. Scop is either the current scope or the scope of
11468 -- the context (if applicable).
11474 function Are_Wrapped (L : List_Id) return Boolean is
11475 Stmt : constant Node_Id := First (L);
11479 and then No (Next (Stmt))
11480 and then Nkind (Stmt) = N_Block_Statement;
11483 ------------------------------
11484 -- Wrap_Statements_In_Block --
11485 ------------------------------
11487 function Wrap_Statements_In_Block
11489 Scop : Entity_Id := Current_Scope) return Node_Id
11491 Block_Id : Entity_Id;
11492 Block_Nod : Node_Id;
11493 Iter_Loop : Entity_Id;
11497 Make_Block_Statement (Loc,
11498 Declarations => No_List,
11499 Handled_Statement_Sequence =>
11500 Make_Handled_Sequence_Of_Statements (Loc,
11503 -- Create a label for the block in case the block needs to manage the
11504 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
11506 Add_Block_Identifier (Block_Nod, Block_Id);
11508 -- When wrapping the statements of an iterator loop, check whether
11509 -- the loop requires secondary stack management and if so, propagate
11510 -- the appropriate flags to the block. This ensures that the cursor
11511 -- is properly cleaned up at each iteration of the loop.
11513 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
11515 if Present (Iter_Loop) then
11516 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
11518 -- Secondary stack reclamation is suppressed when the associated
11519 -- iterator loop contains a return statement which uses the stack.
11521 Set_Sec_Stack_Needed_For_Return
11522 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
11526 end Wrap_Statements_In_Block;
11532 -- Start of processing for Process_Statements_For_Controlled_Objects
11535 -- Whenever a non-handled statement list is wrapped in a block, the
11536 -- block must be explicitly analyzed to redecorate all entities in the
11537 -- list and ensure that a finalizer is properly built.
11540 when N_Conditional_Entry_Call
11543 | N_Selective_Accept
11545 -- Check the "then statements" for elsif parts and if statements
11547 if Nkind (N) in N_Elsif_Part | N_If_Statement
11548 and then not Is_Empty_List (Then_Statements (N))
11549 and then not Are_Wrapped (Then_Statements (N))
11550 and then Requires_Cleanup_Actions
11551 (L => Then_Statements (N),
11552 Lib_Level => False,
11553 Nested_Constructs => False)
11555 Block := Wrap_Statements_In_Block (Then_Statements (N));
11556 Set_Then_Statements (N, New_List (Block));
11561 -- Check the "else statements" for conditional entry calls, if
11562 -- statements and selective accepts.
11565 N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept
11566 and then not Is_Empty_List (Else_Statements (N))
11567 and then not Are_Wrapped (Else_Statements (N))
11568 and then Requires_Cleanup_Actions
11569 (L => Else_Statements (N),
11570 Lib_Level => False,
11571 Nested_Constructs => False)
11573 Block := Wrap_Statements_In_Block (Else_Statements (N));
11574 Set_Else_Statements (N, New_List (Block));
11579 when N_Abortable_Part
11580 | N_Accept_Alternative
11581 | N_Case_Statement_Alternative
11582 | N_Delay_Alternative
11583 | N_Entry_Call_Alternative
11584 | N_Exception_Handler
11586 | N_Triggering_Alternative
11588 if not Is_Empty_List (Statements (N))
11589 and then not Are_Wrapped (Statements (N))
11590 and then Requires_Cleanup_Actions
11591 (L => Statements (N),
11592 Lib_Level => False,
11593 Nested_Constructs => False)
11595 if Nkind (N) = N_Loop_Statement
11596 and then Present (Identifier (N))
11599 Wrap_Statements_In_Block
11600 (L => Statements (N),
11601 Scop => Entity (Identifier (N)));
11603 Block := Wrap_Statements_In_Block (Statements (N));
11606 Set_Statements (N, New_List (Block));
11610 -- Could be e.g. a loop that was transformed into a block or null
11611 -- statement. Do nothing for terminate alternatives.
11613 when N_Block_Statement
11615 | N_Terminate_Alternative
11620 raise Program_Error;
11622 end Process_Statements_For_Controlled_Objects;
11628 function Power_Of_Two (N : Node_Id) return Nat is
11629 Typ : constant Entity_Id := Etype (N);
11630 pragma Assert (Is_Integer_Type (Typ));
11632 Siz : constant Nat := UI_To_Int (Esize (Typ));
11636 if not Compile_Time_Known_Value (N) then
11640 Val := Expr_Value (N);
11641 for J in 1 .. Siz - 1 loop
11642 if Val = Uint_2 ** J then
11651 ----------------------
11652 -- Remove_Init_Call --
11653 ----------------------
11655 function Remove_Init_Call
11657 Rep_Clause : Node_Id) return Node_Id
11659 Par : constant Node_Id := Parent (Var);
11660 Typ : constant Entity_Id := Etype (Var);
11662 Init_Proc : Entity_Id;
11663 -- Initialization procedure for Typ
11665 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
11666 -- Look for init call for Var starting at From and scanning the
11667 -- enclosing list until Rep_Clause or the end of the list is reached.
11669 ----------------------------
11670 -- Find_Init_Call_In_List --
11671 ----------------------------
11673 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
11674 Init_Call : Node_Id;
11678 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
11679 if Nkind (Init_Call) = N_Procedure_Call_Statement
11680 and then Is_Entity_Name (Name (Init_Call))
11681 and then Entity (Name (Init_Call)) = Init_Proc
11690 end Find_Init_Call_In_List;
11692 Init_Call : Node_Id;
11694 -- Start of processing for Remove_Init_Call
11697 if Present (Initialization_Statements (Var)) then
11698 Init_Call := Initialization_Statements (Var);
11699 Set_Initialization_Statements (Var, Empty);
11701 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
11703 -- No init proc for the type, so obviously no call to be found
11708 -- We might be able to handle other cases below by just properly
11709 -- setting Initialization_Statements at the point where the init proc
11710 -- call is generated???
11712 Init_Proc := Base_Init_Proc (Typ);
11714 -- First scan the list containing the declaration of Var
11716 Init_Call := Find_Init_Call_In_List (From => Next (Par));
11718 -- If not found, also look on Var's freeze actions list, if any,
11719 -- since the init call may have been moved there (case of an address
11720 -- clause applying to Var).
11722 if No (Init_Call) and then Present (Freeze_Node (Var)) then
11724 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
11727 -- If the initialization call has actuals that use the secondary
11728 -- stack, the call may have been wrapped into a temporary block, in
11729 -- which case the block itself has to be removed.
11731 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
11733 Blk : constant Node_Id := Next (Par);
11736 (Find_Init_Call_In_List
11737 (First (Statements (Handled_Statement_Sequence (Blk)))))
11745 if Present (Init_Call) then
11746 -- If restrictions have forbidden Aborts, the initialization call
11747 -- for objects that require deep initialization has not been wrapped
11748 -- into the following block (see Exp_Ch3, Default_Initialize_Object)
11749 -- so if present remove it as well, and include the IP call in it,
11750 -- in the rare case the caller may need to simply displace the
11751 -- initialization, as is done for a later address specification.
11753 if Nkind (Next (Init_Call)) = N_Block_Statement
11754 and then Is_Initialization_Block (Next (Init_Call))
11757 IP_Call : constant Node_Id := Init_Call;
11759 Init_Call := Next (IP_Call);
11762 Statements (Handled_Statement_Sequence (Init_Call)));
11766 Remove (Init_Call);
11770 end Remove_Init_Call;
11772 -------------------------
11773 -- Remove_Side_Effects --
11774 -------------------------
11776 procedure Remove_Side_Effects
11778 Name_Req : Boolean := False;
11779 Renaming_Req : Boolean := False;
11780 Variable_Ref : Boolean := False;
11781 Related_Id : Entity_Id := Empty;
11782 Is_Low_Bound : Boolean := False;
11783 Is_High_Bound : Boolean := False;
11784 Discr_Number : Int := 0;
11785 Check_Side_Effects : Boolean := True)
11787 function Build_Temporary
11790 Related_Nod : Node_Id := Empty) return Entity_Id;
11791 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
11792 -- is present (xxx is taken from the Chars field of Related_Nod),
11793 -- otherwise it generates an internal temporary. The created temporary
11794 -- entity is marked as internal.
11796 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean;
11797 -- Computes whether a side effect is possible in SPARK, which should
11798 -- be handled by removing it from the expression for GNATprove. Note
11799 -- that other side effects related to volatile variables are handled
11802 ---------------------
11803 -- Build_Temporary --
11804 ---------------------
11806 function Build_Temporary
11809 Related_Nod : Node_Id := Empty) return Entity_Id
11811 Temp_Id : Entity_Id;
11812 Temp_Nam : Name_Id;
11813 Should_Set_Related_Expression : Boolean := False;
11816 -- The context requires an external symbol : expression is
11817 -- the bound of an array, or a discriminant value. We create
11818 -- a unique string using the related entity and an appropriate
11819 -- suffix, rather than a numeric serial number (used for internal
11820 -- entities) that may vary depending on compilation options, in
11821 -- particular on the Assertions_Enabled mode. This avoids spurious
11824 if Present (Related_Id) then
11825 if Is_Low_Bound then
11826 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
11828 elsif Is_High_Bound then
11829 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
11832 pragma Assert (Discr_Number > 0);
11834 -- We don't have any intelligible way of printing T_DISCR in
11835 -- CodePeer. Thus, set a related expression in this case.
11837 Should_Set_Related_Expression := True;
11839 -- Use fully qualified name to avoid ambiguities.
11843 (Get_Qualified_Name (Related_Id), "_DISCR", Discr_Number);
11846 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
11848 if Should_Set_Related_Expression then
11849 Set_Related_Expression (Temp_Id, Related_Nod);
11852 -- Otherwise generate an internal temporary
11855 Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
11858 Set_Is_Internal (Temp_Id);
11861 end Build_Temporary;
11863 -----------------------------------
11864 -- Possible_Side_Effect_In_SPARK --
11865 -----------------------------------
11867 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean is
11869 -- Side-effect removal in SPARK should only occur when not inside a
11870 -- generic and not doing a preanalysis, inside an object renaming or
11871 -- a type declaration or a for-loop iteration scheme.
11873 return not Inside_A_Generic
11874 and then Full_Analysis
11875 and then Nkind (Enclosing_Declaration (Exp)) in
11876 N_Component_Declaration
11877 | N_Full_Type_Declaration
11878 | N_Iterator_Specification
11879 | N_Loop_Parameter_Specification
11880 | N_Object_Renaming_Declaration
11881 | N_Subtype_Declaration;
11882 end Possible_Side_Effect_In_SPARK;
11886 Loc : constant Source_Ptr := Sloc (Exp);
11887 Exp_Type : constant Entity_Id := Etype (Exp);
11888 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
11889 Def_Id : Entity_Id;
11892 Ptr_Typ_Decl : Node_Id;
11893 Ref_Type : Entity_Id;
11896 -- Start of processing for Remove_Side_Effects
11899 -- Handle cases in which there is nothing to do. In GNATprove mode,
11900 -- removal of side effects is useful for the light expansion of
11903 if not Expander_Active
11905 (GNATprove_Mode and then Possible_Side_Effect_In_SPARK (Exp))
11909 -- Cannot generate temporaries if the invocation to remove side effects
11910 -- was issued too early and the type of the expression is not resolved
11911 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
11912 -- Remove_Side_Effects).
11914 elsif No (Exp_Type)
11915 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11919 -- Nothing to do if prior expansion determined that a function call does
11920 -- not require side effect removal.
11922 elsif Nkind (Exp) = N_Function_Call
11923 and then No_Side_Effect_Removal (Exp)
11927 -- No action needed for side-effect free expressions
11929 elsif Check_Side_Effects
11930 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11934 -- Generating C code we cannot remove side effect of function returning
11935 -- class-wide types since there is no secondary stack (required to use
11938 elsif Modify_Tree_For_C
11939 and then Nkind (Exp) = N_Function_Call
11940 and then Is_Class_Wide_Type (Etype (Exp))
11945 -- The remaining processing is done with all checks suppressed
11947 -- Note: from now on, don't use return statements, instead do a goto
11948 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11950 Scope_Suppress.Suppress := (others => True);
11952 -- If this is a side-effect free attribute reference whose expressions
11953 -- are also side-effect free and whose prefix is not a name, remove the
11954 -- side effects of the prefix. A copy of the prefix is required in this
11955 -- case and it is better not to make an additional one for the attribute
11956 -- itself, because the return type of many of them is universal integer,
11957 -- which is a very large type for a temporary.
11958 -- The prefix of an attribute reference Reduce may be syntactically an
11959 -- aggregate, but will be expanded into a loop, so no need to remove
11962 if Nkind (Exp) = N_Attribute_Reference
11963 and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
11964 and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
11965 and then (Attribute_Name (Exp) /= Name_Reduce
11966 or else Nkind (Prefix (Exp)) /= N_Aggregate)
11967 and then not Is_Name_Reference (Prefix (Exp))
11969 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11972 -- If this is an elementary or a small not-by-reference record type, and
11973 -- we need to capture the value, just make a constant; this is cheap and
11974 -- objects of both kinds of types can be bit aligned, so it might not be
11975 -- possible to generate a reference to them. Likewise if this is not a
11976 -- name reference, except for a type conversion, because we would enter
11977 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11978 -- type has predicates (and type conversions need a specific treatment
11979 -- anyway, see below). Also do it if we have a volatile reference and
11980 -- Name_Req is not set (see comments for Side_Effect_Free).
11982 elsif (Is_Elementary_Type (Exp_Type)
11983 or else (Is_Record_Type (Exp_Type)
11984 and then Known_Static_RM_Size (Exp_Type)
11985 and then RM_Size (Exp_Type) <= System_Max_Integer_Size
11986 and then not Has_Discriminants (Exp_Type)
11987 and then not Is_By_Reference_Type (Exp_Type)))
11988 and then (Variable_Ref
11989 or else (not Is_Name_Reference (Exp)
11990 and then Nkind (Exp) /= N_Type_Conversion)
11991 or else (not Name_Req
11992 and then Is_Volatile_Reference (Exp)))
11994 Def_Id := Build_Temporary (Loc, 'R', Exp);
11995 Set_Etype (Def_Id, Exp_Type);
11996 Res := New_Occurrence_Of (Def_Id, Loc);
11998 -- If the expression is a packed reference, it must be reanalyzed and
11999 -- expanded, depending on context. This is the case for actuals where
12000 -- a constraint check may capture the actual before expansion of the
12001 -- call is complete.
12003 if Nkind (Exp) = N_Indexed_Component
12004 and then Is_Packed (Etype (Prefix (Exp)))
12006 Set_Analyzed (Exp, False);
12007 Set_Analyzed (Prefix (Exp), False);
12011 -- Rnn : Exp_Type renames Expr;
12013 -- In GNATprove mode, we prefer to use renamings for intermediate
12014 -- variables to definition of constants, due to the implicit move
12015 -- operation that such a constant definition causes as part of the
12016 -- support in GNATprove for ownership pointers. Hence, we generate
12017 -- a renaming for a reference to an object of a nonscalar type.
12020 or else (GNATprove_Mode
12021 and then Is_Object_Reference (Exp)
12022 and then not Is_Scalar_Type (Exp_Type))
12025 Make_Object_Renaming_Declaration (Loc,
12026 Defining_Identifier => Def_Id,
12027 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
12028 Name => Relocate_Node (Exp));
12031 -- Rnn : constant Exp_Type := Expr;
12035 Make_Object_Declaration (Loc,
12036 Defining_Identifier => Def_Id,
12037 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
12038 Constant_Present => True,
12039 Expression => Relocate_Node (Exp));
12041 Set_Assignment_OK (E);
12044 Insert_Action (Exp, E);
12046 -- If the expression has the form v.all then we can just capture the
12047 -- pointer, and then do an explicit dereference on the result, but
12048 -- this is not right if this is a volatile reference.
12050 elsif Nkind (Exp) = N_Explicit_Dereference
12051 and then not Is_Volatile_Reference (Exp)
12053 Def_Id := Build_Temporary (Loc, 'R', Exp);
12055 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
12057 Insert_Action (Exp,
12058 Make_Object_Declaration (Loc,
12059 Defining_Identifier => Def_Id,
12060 Object_Definition =>
12061 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
12062 Constant_Present => True,
12063 Expression => Relocate_Node (Prefix (Exp))));
12065 -- Similar processing for an unchecked conversion of an expression of
12066 -- the form v.all, where we want the same kind of treatment.
12068 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
12069 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
12071 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
12074 -- If this is a type conversion, leave the type conversion and remove
12075 -- side effects in the expression, unless it is of universal integer,
12076 -- which is a very large type for a temporary. This is important in
12077 -- several circumstances: for change of representations and also when
12078 -- this is a view conversion to a smaller object, where gigi can end
12079 -- up creating its own temporary of the wrong size.
12081 elsif Nkind (Exp) = N_Type_Conversion
12082 and then Etype (Expression (Exp)) /= Universal_Integer
12084 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
12086 -- Generating C code the type conversion of an access to constrained
12087 -- array type into an access to unconstrained array type involves
12088 -- initializing a fat pointer and the expression must be free of
12089 -- side effects to safely compute its bounds.
12091 if Modify_Tree_For_C
12092 and then Is_Access_Type (Etype (Exp))
12093 and then Is_Array_Type (Designated_Type (Etype (Exp)))
12094 and then not Is_Constrained (Designated_Type (Etype (Exp)))
12096 Def_Id := Build_Temporary (Loc, 'R', Exp);
12097 Set_Etype (Def_Id, Exp_Type);
12098 Res := New_Occurrence_Of (Def_Id, Loc);
12100 Insert_Action (Exp,
12101 Make_Object_Declaration (Loc,
12102 Defining_Identifier => Def_Id,
12103 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
12104 Constant_Present => True,
12105 Expression => Relocate_Node (Exp)));
12110 -- If this is an unchecked conversion that Gigi can't handle, make
12111 -- a copy or a use a renaming to capture the value.
12113 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
12114 and then not Safe_Unchecked_Type_Conversion (Exp)
12116 if CW_Or_Needs_Finalization (Exp_Type) then
12118 -- Use a renaming to capture the expression, rather than create
12119 -- a controlled temporary.
12121 Def_Id := Build_Temporary (Loc, 'R', Exp);
12122 Res := New_Occurrence_Of (Def_Id, Loc);
12124 Insert_Action (Exp,
12125 Make_Object_Renaming_Declaration (Loc,
12126 Defining_Identifier => Def_Id,
12127 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
12128 Name => Relocate_Node (Exp)));
12131 Def_Id := Build_Temporary (Loc, 'R', Exp);
12132 Set_Etype (Def_Id, Exp_Type);
12133 Res := New_Occurrence_Of (Def_Id, Loc);
12136 Make_Object_Declaration (Loc,
12137 Defining_Identifier => Def_Id,
12138 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
12139 Constant_Present => not Is_Variable (Exp),
12140 Expression => Relocate_Node (Exp));
12142 Set_Assignment_OK (E);
12143 Insert_Action (Exp, E);
12146 -- If this is a packed array component or a selected component with a
12147 -- nonstandard representation, we cannot generate a reference because
12148 -- the component may be unaligned, so we must use a renaming and this
12149 -- renaming is handled by the front end, as the back end may balk at
12150 -- the nonstandard representation (see Evaluation_Required in Exp_Ch8).
12152 elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
12153 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
12155 Def_Id := Build_Temporary (Loc, 'R', Exp);
12156 Res := New_Occurrence_Of (Def_Id, Loc);
12158 Insert_Action (Exp,
12159 Make_Object_Renaming_Declaration (Loc,
12160 Defining_Identifier => Def_Id,
12161 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
12162 Name => Relocate_Node (Exp)));
12164 -- For an expression that denotes a name, we can use a renaming scheme.
12165 -- This is needed for correctness in the case of a volatile object of
12166 -- a nonvolatile type because the Make_Reference call of the "default"
12167 -- approach would generate an illegal access value (an access value
12168 -- cannot designate such an object - see Analyze_Reference).
12170 elsif Is_Name_Reference (Exp)
12172 -- We skip using this scheme if we have an object of a volatile
12173 -- type and we do not have Name_Req set true (see comments for
12174 -- Side_Effect_Free).
12176 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
12178 Def_Id := Build_Temporary (Loc, 'R', Exp);
12179 Res := New_Occurrence_Of (Def_Id, Loc);
12181 Insert_Action (Exp,
12182 Make_Object_Renaming_Declaration (Loc,
12183 Defining_Identifier => Def_Id,
12184 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
12185 Name => Relocate_Node (Exp)));
12187 -- Avoid generating a variable-sized temporary, by generating the
12188 -- reference just for the function call. The transformation could be
12189 -- refined to apply only when the array component is constrained by a
12192 elsif Nkind (Exp) = N_Selected_Component
12193 and then Nkind (Prefix (Exp)) = N_Function_Call
12194 and then Is_Array_Type (Exp_Type)
12196 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
12199 -- Otherwise we generate a reference to the expression
12202 -- When generating C code we cannot consider side effect free object
12203 -- declarations that have discriminants and are initialized by means
12204 -- of a function call since on this target there is no secondary
12205 -- stack to store the return value and the expander may generate an
12206 -- extra call to the function to compute the discriminant value. In
12207 -- addition, for targets that have secondary stack, the expansion of
12208 -- functions with side effects involves the generation of an access
12209 -- type to capture the return value stored in the secondary stack;
12210 -- by contrast when generating C code such expansion generates an
12211 -- internal object declaration (no access type involved) which must
12212 -- be identified here to avoid entering into a never-ending loop
12213 -- generating internal object declarations.
12215 if Modify_Tree_For_C
12216 and then Nkind (Parent (Exp)) = N_Object_Declaration
12218 (Nkind (Exp) /= N_Function_Call
12219 or else not Has_Discriminants (Exp_Type)
12220 or else Is_Internal_Name
12221 (Chars (Defining_Identifier (Parent (Exp)))))
12226 -- Special processing for function calls that return a limited type.
12227 -- We need to build a declaration that will enable build-in-place
12228 -- expansion of the call. This is not done if the context is already
12229 -- an object declaration, to prevent infinite recursion.
12231 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
12232 -- to accommodate functions returning limited objects by reference.
12234 if Ada_Version >= Ada_2005
12235 and then Nkind (Exp) = N_Function_Call
12236 and then Is_Limited_View (Etype (Exp))
12237 and then Nkind (Parent (Exp)) /= N_Object_Declaration
12240 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
12245 Make_Object_Declaration (Loc,
12246 Defining_Identifier => Obj,
12247 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
12248 Expression => Relocate_Node (Exp));
12250 Insert_Action (Exp, Decl);
12251 Set_Etype (Obj, Exp_Type);
12252 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
12257 Def_Id := Build_Temporary (Loc, 'R', Exp);
12259 -- The regular expansion of functions with side effects involves the
12260 -- generation of an access type to capture the return value found on
12261 -- the secondary stack. Since SPARK (and why) cannot process access
12262 -- types, use a different approach which ignores the secondary stack
12263 -- and "copies" the returned object.
12264 -- When generating C code, no need for a 'reference since the
12265 -- secondary stack is not supported.
12267 if GNATprove_Mode or Modify_Tree_For_C then
12268 Res := New_Occurrence_Of (Def_Id, Loc);
12269 Ref_Type := Exp_Type;
12271 -- Regular expansion utilizing an access type and 'reference
12275 Make_Explicit_Dereference (Loc,
12276 Prefix => New_Occurrence_Of (Def_Id, Loc));
12279 -- type Ann is access all <Exp_Type>;
12281 Ref_Type := Make_Temporary (Loc, 'A');
12284 Make_Full_Type_Declaration (Loc,
12285 Defining_Identifier => Ref_Type,
12287 Make_Access_To_Object_Definition (Loc,
12288 All_Present => True,
12289 Subtype_Indication =>
12290 New_Occurrence_Of (Exp_Type, Loc)));
12292 Insert_Action (Exp, Ptr_Typ_Decl);
12296 if Nkind (E) = N_Explicit_Dereference then
12297 New_Exp := Relocate_Node (Prefix (E));
12300 E := Relocate_Node (E);
12302 -- Do not generate a 'reference in SPARK mode or C generation
12303 -- since the access type is not created in the first place.
12305 if GNATprove_Mode or Modify_Tree_For_C then
12308 -- Otherwise generate reference, marking the value as non-null
12309 -- since we know it cannot be null and we don't want a check.
12312 New_Exp := Make_Reference (Loc, E);
12313 Set_Is_Known_Non_Null (Def_Id);
12317 if Is_Delayed_Aggregate (E) then
12319 -- The expansion of nested aggregates is delayed until the
12320 -- enclosing aggregate is expanded. As aggregates are often
12321 -- qualified, the predicate applies to qualified expressions as
12322 -- well, indicating that the enclosing aggregate has not been
12323 -- expanded yet. At this point the aggregate is part of a
12324 -- stand-alone declaration, and must be fully expanded.
12326 if Nkind (E) = N_Qualified_Expression then
12327 Set_Expansion_Delayed (Expression (E), False);
12328 Set_Analyzed (Expression (E), False);
12330 Set_Expansion_Delayed (E, False);
12333 Set_Analyzed (E, False);
12336 -- Generating C code of object declarations that have discriminants
12337 -- and are initialized by means of a function call we propagate the
12338 -- discriminants of the parent type to the internally built object.
12339 -- This is needed to avoid generating an extra call to the called
12342 -- For example, if we generate here the following declaration, it
12343 -- will be expanded later adding an extra call to evaluate the value
12344 -- of the discriminant (needed to compute the size of the object).
12346 -- type Rec (D : Integer) is ...
12347 -- Obj : constant Rec := SomeFunc;
12349 if Modify_Tree_For_C
12350 and then Nkind (Parent (Exp)) = N_Object_Declaration
12351 and then Has_Discriminants (Exp_Type)
12352 and then Nkind (Exp) = N_Function_Call
12354 Insert_Action (Exp,
12355 Make_Object_Declaration (Loc,
12356 Defining_Identifier => Def_Id,
12357 Object_Definition => New_Copy_Tree
12358 (Object_Definition (Parent (Exp))),
12359 Constant_Present => True,
12360 Expression => New_Exp));
12362 Insert_Action (Exp,
12363 Make_Object_Declaration (Loc,
12364 Defining_Identifier => Def_Id,
12365 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
12366 Constant_Present => True,
12367 Expression => New_Exp));
12371 -- Preserve the Assignment_OK flag in all copies, since at least one
12372 -- copy may be used in a context where this flag must be set (otherwise
12373 -- why would the flag be set in the first place).
12375 Set_Assignment_OK (Res, Assignment_OK (Exp));
12377 -- Preserve the Do_Range_Check flag in all copies
12379 Set_Do_Range_Check (Res, Do_Range_Check (Exp));
12381 -- Finally rewrite the original expression and we are done
12383 Rewrite (Exp, Res);
12384 Analyze_And_Resolve (Exp, Exp_Type);
12387 Scope_Suppress := Svg_Suppress;
12388 end Remove_Side_Effects;
12390 ------------------------
12391 -- Replace_References --
12392 ------------------------
12394 procedure Replace_References
12396 Par_Typ : Entity_Id;
12397 Deriv_Typ : Entity_Id;
12398 Par_Obj : Entity_Id := Empty;
12399 Deriv_Obj : Entity_Id := Empty)
12401 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
12402 -- Determine whether node Ref denotes some component of Deriv_Obj
12404 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
12405 -- Substitute a reference to an entity with the corresponding value
12406 -- stored in table Type_Map.
12408 function Type_Of_Formal
12410 Actual : Node_Id) return Entity_Id;
12411 -- Find the type of the formal parameter which corresponds to actual
12412 -- parameter Actual in subprogram call Call.
12414 ----------------------
12415 -- Is_Deriv_Obj_Ref --
12416 ----------------------
12418 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
12419 Par : constant Node_Id := Parent (Ref);
12422 -- Detect the folowing selected component form:
12424 -- Deriv_Obj.(something)
12427 Nkind (Par) = N_Selected_Component
12428 and then Is_Entity_Name (Prefix (Par))
12429 and then Entity (Prefix (Par)) = Deriv_Obj;
12430 end Is_Deriv_Obj_Ref;
12436 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
12437 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
12438 -- Reset the Controlling_Argument of all function calls that
12439 -- encapsulate node From_Arg.
12441 ----------------------------------
12442 -- Remove_Controlling_Arguments --
12443 ----------------------------------
12445 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
12450 while Present (Par) loop
12451 if Nkind (Par) = N_Function_Call
12452 and then Present (Controlling_Argument (Par))
12454 Set_Controlling_Argument (Par, Empty);
12456 -- Prevent the search from going too far
12458 elsif Is_Body_Or_Package_Declaration (Par) then
12462 Par := Parent (Par);
12464 end Remove_Controlling_Arguments;
12468 Context : constant Node_Id :=
12469 (if No (Ref) then Empty else Parent (Ref));
12471 Loc : constant Source_Ptr := Sloc (Ref);
12472 Ref_Id : Entity_Id;
12473 Result : Traverse_Result;
12476 -- The new reference which is intended to substitute the old one
12479 -- The reference designated for replacement. In certain cases this
12480 -- may be a node other than Ref.
12482 Val : Node_Or_Entity_Id;
12483 -- The corresponding value of Ref from the type map
12485 -- Start of processing for Replace_Ref
12488 -- Assume that the input reference is to be replaced and that the
12489 -- traversal should examine the children of the reference.
12494 -- The input denotes a meaningful reference
12496 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
12497 Ref_Id := Entity (Ref);
12498 Val := Type_Map.Get (Ref_Id);
12500 -- The reference has a corresponding value in the type map, a
12501 -- substitution is possible.
12503 if Present (Val) then
12505 -- The reference denotes a discriminant
12507 if Ekind (Ref_Id) = E_Discriminant then
12508 if Nkind (Val) in N_Entity then
12510 -- The value denotes another discriminant. Replace as
12513 -- _object.Discr -> _object.Val
12515 if Ekind (Val) = E_Discriminant then
12516 New_Ref := New_Occurrence_Of (Val, Loc);
12518 -- Otherwise the value denotes the entity of a name which
12519 -- constraints the discriminant. Replace as follows:
12521 -- _object.Discr -> Val
12524 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
12526 New_Ref := New_Occurrence_Of (Val, Loc);
12527 Old_Ref := Parent (Old_Ref);
12530 -- Otherwise the value denotes an arbitrary expression which
12531 -- constraints the discriminant. Replace as follows:
12533 -- _object.Discr -> Val
12536 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
12538 New_Ref := New_Copy_Tree (Val);
12539 Old_Ref := Parent (Old_Ref);
12542 -- Otherwise the reference denotes a primitive. Replace as
12545 -- Primitive -> Val
12548 pragma Assert (Nkind (Val) in N_Entity);
12549 New_Ref := New_Occurrence_Of (Val, Loc);
12552 -- The reference mentions the _object parameter of the parent
12553 -- type's DIC or type invariant procedure. Replace as follows:
12555 -- _object -> _object
12557 elsif Present (Par_Obj)
12558 and then Present (Deriv_Obj)
12559 and then Ref_Id = Par_Obj
12561 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
12563 -- The type of the _object parameter is class-wide when the
12564 -- expression comes from an assertion pragma that applies to
12565 -- an abstract parent type or an interface. The class-wide type
12566 -- facilitates the preanalysis of the expression by treating
12567 -- calls to abstract primitives that mention the current
12568 -- instance of the type as dispatching. Once the calls are
12569 -- remapped to invoke overriding or inherited primitives, the
12570 -- calls no longer need to be dispatching. Examine all function
12571 -- calls that encapsulate the _object parameter and reset their
12572 -- Controlling_Argument attribute.
12574 if Is_Class_Wide_Type (Etype (Par_Obj))
12575 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
12577 Remove_Controlling_Arguments (Old_Ref);
12580 -- The reference to _object acts as an actual parameter in a
12581 -- subprogram call which may be invoking a primitive of the
12584 -- Primitive (... _object ...);
12586 -- The parent type primitive may not be overridden nor
12587 -- inherited when it is declared after the derived type
12590 -- type Parent is tagged private;
12591 -- type Child is new Parent with private;
12592 -- procedure Primitive (Obj : Parent);
12594 -- In this scenario the _object parameter is converted to the
12595 -- parent type. Due to complications with partial/full views
12596 -- and view swaps, the parent type is taken from the formal
12597 -- parameter of the subprogram being called.
12599 if Nkind (Context) in N_Subprogram_Call
12600 and then No (Type_Map.Get (Entity (Name (Context))))
12603 -- We need to use the Original_Node of the callee, in
12604 -- case it was already modified. Note that we are using
12605 -- Traverse_Proc to walk the tree, and it is defined to
12606 -- walk subtrees in an arbitrary order.
12608 Callee : constant Entity_Id :=
12609 Entity (Original_Node (Name (Context)));
12611 if No (Type_Map.Get (Callee)) then
12614 (Type_Of_Formal (Context, Old_Ref), New_Ref);
12616 -- Do not process the generated type conversion
12617 -- because both the parent type and the derived type
12618 -- are in the Type_Map table. This will clobber the
12619 -- type conversion by resetting its subtype mark.
12626 -- Otherwise there is nothing to replace
12632 if Present (New_Ref) then
12633 Rewrite (Old_Ref, New_Ref);
12635 -- Update the return type when the context of the reference
12636 -- acts as the name of a function call. Note that the update
12637 -- should not be performed when the reference appears as an
12638 -- actual in the call.
12640 if Nkind (Context) = N_Function_Call
12641 and then Name (Context) = Old_Ref
12643 Set_Etype (Context, Etype (Val));
12648 -- Reanalyze the reference due to potential replacements
12650 if Nkind (Old_Ref) in N_Has_Etype then
12651 Set_Analyzed (Old_Ref, False);
12657 procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
12659 --------------------
12660 -- Type_Of_Formal --
12661 --------------------
12663 function Type_Of_Formal
12665 Actual : Node_Id) return Entity_Id
12671 -- Examine the list of actual and formal parameters in parallel
12673 A := First (Parameter_Associations (Call));
12674 F := First_Formal (Entity (Name (Call)));
12675 while Present (A) and then Present (F) loop
12684 -- The actual parameter must always have a corresponding formal
12686 pragma Assert (False);
12689 end Type_Of_Formal;
12691 -- Start of processing for Replace_References
12694 -- Map the attributes of the parent type to the proper corresponding
12695 -- attributes of the derived type.
12698 (Parent_Type => Par_Typ,
12699 Derived_Type => Deriv_Typ);
12701 -- Inspect the input expression and perform substitutions where
12704 Replace_Refs (Expr);
12705 end Replace_References;
12707 -----------------------------
12708 -- Replace_Type_References --
12709 -----------------------------
12711 procedure Replace_Type_References
12714 Obj_Id : Entity_Id)
12716 procedure Replace_Type_Ref (N : Node_Id);
12717 -- Substitute a single reference of the current instance of type Typ
12718 -- with a reference to Obj_Id.
12720 ----------------------
12721 -- Replace_Type_Ref --
12722 ----------------------
12724 procedure Replace_Type_Ref (N : Node_Id) is
12726 -- Decorate the reference to Typ even though it may be rewritten
12727 -- further down. This is done so that routines which examine
12728 -- properties of the Original_Node have some semantic information.
12730 if Nkind (N) = N_Identifier then
12731 Set_Entity (N, Typ);
12732 Set_Etype (N, Typ);
12734 elsif Nkind (N) = N_Selected_Component then
12735 Analyze (Prefix (N));
12736 Set_Entity (Selector_Name (N), Typ);
12737 Set_Etype (Selector_Name (N), Typ);
12740 -- Perform the following substitution:
12744 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
12745 Set_Comes_From_Source (N, True);
12746 end Replace_Type_Ref;
12748 procedure Replace_Type_Refs is
12749 new Replace_Type_References_Generic (Replace_Type_Ref);
12751 -- Start of processing for Replace_Type_References
12754 Replace_Type_Refs (Expr, Typ);
12755 end Replace_Type_References;
12757 ---------------------------
12758 -- Represented_As_Scalar --
12759 ---------------------------
12761 function Represented_As_Scalar (T : Entity_Id) return Boolean is
12762 UT : constant Entity_Id := Underlying_Type (T);
12764 return Is_Scalar_Type (UT)
12765 or else (Is_Bit_Packed_Array (UT)
12766 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
12767 end Represented_As_Scalar;
12769 ------------------------------
12770 -- Requires_Cleanup_Actions --
12771 ------------------------------
12773 function Requires_Cleanup_Actions
12775 Lib_Level : Boolean) return Boolean
12777 At_Lib_Level : constant Boolean :=
12779 and then Nkind (N) in N_Package_Body | N_Package_Specification;
12780 -- N is at the library level if the top-most context is a package and
12781 -- the path taken to reach N does not include nonpackage constructs.
12785 when N_Accept_Statement
12786 | N_Block_Statement
12789 | N_Subprogram_Body
12793 Requires_Cleanup_Actions
12794 (L => Declarations (N),
12795 Lib_Level => At_Lib_Level,
12796 Nested_Constructs => True)
12798 (Present (Handled_Statement_Sequence (N))
12800 Requires_Cleanup_Actions
12802 Statements (Handled_Statement_Sequence (N)),
12803 Lib_Level => At_Lib_Level,
12804 Nested_Constructs => True));
12806 -- Extended return statements are the same as the above, except that
12807 -- there is no Declarations field. We do not want to clean up the
12808 -- Return_Object_Declarations.
12810 when N_Extended_Return_Statement =>
12812 Present (Handled_Statement_Sequence (N))
12813 and then Requires_Cleanup_Actions
12815 Statements (Handled_Statement_Sequence (N)),
12816 Lib_Level => At_Lib_Level,
12817 Nested_Constructs => True);
12819 when N_Package_Specification =>
12821 Requires_Cleanup_Actions
12822 (L => Visible_Declarations (N),
12823 Lib_Level => At_Lib_Level,
12824 Nested_Constructs => True)
12826 Requires_Cleanup_Actions
12827 (L => Private_Declarations (N),
12828 Lib_Level => At_Lib_Level,
12829 Nested_Constructs => True);
12832 raise Program_Error;
12834 end Requires_Cleanup_Actions;
12836 ------------------------------
12837 -- Requires_Cleanup_Actions --
12838 ------------------------------
12840 function Requires_Cleanup_Actions
12842 Lib_Level : Boolean;
12843 Nested_Constructs : Boolean) return Boolean
12847 Obj_Id : Entity_Id;
12848 Obj_Typ : Entity_Id;
12849 Pack_Id : Entity_Id;
12854 while Present (Decl) loop
12856 -- Library-level tagged types
12858 if Nkind (Decl) = N_Full_Type_Declaration then
12859 Typ := Defining_Identifier (Decl);
12861 -- Ignored Ghost types do not need any cleanup actions because
12862 -- they will not appear in the final tree.
12864 if Is_Ignored_Ghost_Entity (Typ) then
12867 elsif Is_Tagged_Type (Typ)
12868 and then Is_Library_Level_Entity (Typ)
12869 and then Convention (Typ) = Convention_Ada
12870 and then Present (Access_Disp_Table (Typ))
12871 and then not Is_Abstract_Type (Typ)
12872 and then not No_Run_Time_Mode
12873 and then not Restriction_Active (No_Tagged_Type_Registration)
12874 and then RTE_Available (RE_Unregister_Tag)
12879 -- Regular object declarations
12881 elsif Nkind (Decl) = N_Object_Declaration then
12882 Obj_Id := Defining_Identifier (Decl);
12883 Obj_Typ := Base_Type (Etype (Obj_Id));
12884 Expr := Expression (Decl);
12886 -- Bypass any form of processing for objects which have their
12887 -- finalization disabled. This applies only to objects at the
12890 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12893 -- Finalization of transient objects are treated separately in
12894 -- order to handle sensitive cases. These include:
12896 -- * Aggregate expansion
12897 -- * If, case, and expression with actions expansion
12898 -- * Transient scopes
12900 -- If one of those contexts has marked the transient object as
12901 -- ignored, do not generate finalization actions for it.
12903 elsif Is_Finalized_Transient (Obj_Id)
12904 or else Is_Ignored_Transient (Obj_Id)
12908 -- Ignored Ghost objects do not need any cleanup actions because
12909 -- they will not appear in the final tree.
12911 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12914 -- The object is of the form:
12915 -- Obj : [constant] Typ [:= Expr];
12917 -- Do not process tag-to-class-wide conversions because they do
12918 -- not yield an object. Do not process the incomplete view of a
12919 -- deferred constant. Note that an object initialized by means
12920 -- of a build-in-place function call may appear as a deferred
12921 -- constant after expansion activities. These kinds of objects
12922 -- must be finalized.
12924 elsif not Is_Imported (Obj_Id)
12925 and then Needs_Finalization (Obj_Typ)
12926 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
12927 and then not (Ekind (Obj_Id) = E_Constant
12928 and then not Has_Completion (Obj_Id)
12929 and then No (BIP_Initialization_Call (Obj_Id)))
12933 -- The object is of the form:
12934 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
12936 -- Obj : Access_Typ :=
12937 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
12939 elsif Is_Access_Type (Obj_Typ)
12940 and then Needs_Finalization
12941 (Available_View (Designated_Type (Obj_Typ)))
12942 and then Present (Expr)
12944 (Is_Secondary_Stack_BIP_Func_Call (Expr)
12946 (Is_Non_BIP_Func_Call (Expr)
12947 and then not Is_Related_To_Func_Return (Obj_Id)))
12951 -- Processing for "hook" objects generated for transient objects
12952 -- declared inside an Expression_With_Actions.
12954 elsif Is_Access_Type (Obj_Typ)
12955 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12956 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12957 N_Object_Declaration
12961 -- Processing for intermediate results of if expressions where
12962 -- one of the alternatives uses a controlled function call.
12964 elsif Is_Access_Type (Obj_Typ)
12965 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12966 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12967 N_Defining_Identifier
12968 and then Present (Expr)
12969 and then Nkind (Expr) = N_Null
12973 -- Simple protected objects which use type System.Tasking.
12974 -- Protected_Objects.Protection to manage their locks should be
12975 -- treated as controlled since they require manual cleanup.
12977 elsif Ekind (Obj_Id) = E_Variable
12978 and then (Is_Simple_Protected_Type (Obj_Typ)
12979 or else Has_Simple_Protected_Object (Obj_Typ))
12984 -- Specific cases of object renamings
12986 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
12987 Obj_Id := Defining_Identifier (Decl);
12988 Obj_Typ := Base_Type (Etype (Obj_Id));
12990 -- Bypass any form of processing for objects which have their
12991 -- finalization disabled. This applies only to objects at the
12994 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12997 -- Ignored Ghost object renamings do not need any cleanup actions
12998 -- because they will not appear in the final tree.
13000 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
13003 -- Return object of a build-in-place function. This case is
13004 -- recognized and marked by the expansion of an extended return
13005 -- statement (see Expand_N_Extended_Return_Statement).
13007 elsif Needs_Finalization (Obj_Typ)
13008 and then Is_Return_Object (Obj_Id)
13009 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
13013 -- Detect a case where a source object has been initialized by
13014 -- a controlled function call or another object which was later
13015 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
13017 -- Obj1 : CW_Type := Src_Obj;
13018 -- Obj2 : CW_Type := Function_Call (...);
13020 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
13021 -- Tmp : ... := Function_Call (...)'reference;
13022 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
13024 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
13028 -- Inspect the freeze node of an access-to-controlled type and look
13029 -- for a delayed finalization master. This case arises when the
13030 -- freeze actions are inserted at a later time than the expansion of
13031 -- the context. Since Build_Finalizer is never called on a single
13032 -- construct twice, the master will be ultimately left out and never
13033 -- finalized. This is also needed for freeze actions of designated
13034 -- types themselves, since in some cases the finalization master is
13035 -- associated with a designated type's freeze node rather than that
13036 -- of the access type (see handling for freeze actions in
13037 -- Build_Finalization_Master).
13039 elsif Nkind (Decl) = N_Freeze_Entity
13040 and then Present (Actions (Decl))
13042 Typ := Entity (Decl);
13044 -- Freeze nodes for ignored Ghost types do not need cleanup
13045 -- actions because they will never appear in the final tree.
13047 if Is_Ignored_Ghost_Entity (Typ) then
13050 elsif ((Is_Access_Object_Type (Typ)
13051 and then Needs_Finalization
13052 (Available_View (Designated_Type (Typ))))
13053 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
13054 and then Requires_Cleanup_Actions
13055 (Actions (Decl), Lib_Level, Nested_Constructs)
13060 -- Nested package declarations
13062 elsif Nested_Constructs
13063 and then Nkind (Decl) = N_Package_Declaration
13065 Pack_Id := Defining_Entity (Decl);
13067 -- Do not inspect an ignored Ghost package because all code found
13068 -- within will not appear in the final tree.
13070 if Is_Ignored_Ghost_Entity (Pack_Id) then
13073 elsif Ekind (Pack_Id) /= E_Generic_Package
13074 and then Requires_Cleanup_Actions
13075 (Specification (Decl), Lib_Level)
13080 -- Nested package bodies
13082 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
13084 -- Do not inspect an ignored Ghost package body because all code
13085 -- found within will not appear in the final tree.
13087 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
13090 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
13091 and then Requires_Cleanup_Actions (Decl, Lib_Level)
13096 elsif Nkind (Decl) = N_Block_Statement
13099 -- Handle a rare case caused by a controlled transient object
13100 -- created as part of a record init proc. The variable is wrapped
13101 -- in a block, but the block is not associated with a transient
13106 -- Handle the case where the original context has been wrapped in
13107 -- a block to avoid interference between exception handlers and
13108 -- At_End handlers. Treat the block as transparent and process its
13111 or else Is_Finalization_Wrapper (Decl))
13113 if Requires_Cleanup_Actions (Decl, Lib_Level) then
13122 end Requires_Cleanup_Actions;
13124 ------------------------------------
13125 -- Safe_Unchecked_Type_Conversion --
13126 ------------------------------------
13128 -- Note: this function knows quite a bit about the exact requirements of
13129 -- Gigi with respect to unchecked type conversions, and its code must be
13130 -- coordinated with any changes in Gigi in this area.
13132 -- The above requirements should be documented in Sinfo ???
13134 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
13139 Pexp : constant Node_Id := Parent (Exp);
13142 -- If the expression is the RHS of an assignment or object declaration
13143 -- we are always OK because there will always be a target.
13145 -- Object renaming declarations, (generated for view conversions of
13146 -- actuals in inlined calls), like object declarations, provide an
13147 -- explicit type, and are safe as well.
13149 if (Nkind (Pexp) = N_Assignment_Statement
13150 and then Expression (Pexp) = Exp)
13151 or else Nkind (Pexp)
13152 in N_Object_Declaration | N_Object_Renaming_Declaration
13156 -- If the expression is the prefix of an N_Selected_Component we should
13157 -- also be OK because GCC knows to look inside the conversion except if
13158 -- the type is discriminated. We assume that we are OK anyway if the
13159 -- type is not set yet or if it is controlled since we can't afford to
13160 -- introduce a temporary in this case.
13162 elsif Nkind (Pexp) = N_Selected_Component
13163 and then Prefix (Pexp) = Exp
13165 return No (Etype (Pexp))
13166 or else not Is_Type (Etype (Pexp))
13167 or else not Has_Discriminants (Etype (Pexp))
13168 or else Is_Constrained (Etype (Pexp));
13171 -- Set the output type, this comes from Etype if it is set, otherwise we
13172 -- take it from the subtype mark, which we assume was already fully
13175 if Present (Etype (Exp)) then
13176 Otyp := Etype (Exp);
13178 Otyp := Entity (Subtype_Mark (Exp));
13181 -- The input type always comes from the expression, and we assume this
13182 -- is indeed always analyzed, so we can simply get the Etype.
13184 Ityp := Etype (Expression (Exp));
13186 -- Initialize alignments to unknown so far
13191 -- Replace a concurrent type by its corresponding record type and each
13192 -- type by its underlying type and do the tests on those. The original
13193 -- type may be a private type whose completion is a concurrent type, so
13194 -- find the underlying type first.
13196 if Present (Underlying_Type (Otyp)) then
13197 Otyp := Underlying_Type (Otyp);
13200 if Present (Underlying_Type (Ityp)) then
13201 Ityp := Underlying_Type (Ityp);
13204 if Is_Concurrent_Type (Otyp) then
13205 Otyp := Corresponding_Record_Type (Otyp);
13208 if Is_Concurrent_Type (Ityp) then
13209 Ityp := Corresponding_Record_Type (Ityp);
13212 -- If the base types are the same, we know there is no problem since
13213 -- this conversion will be a noop.
13215 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
13218 -- Same if this is an upwards conversion of an untagged type, and there
13219 -- are no constraints involved (could be more general???)
13221 elsif Etype (Ityp) = Otyp
13222 and then not Is_Tagged_Type (Ityp)
13223 and then not Has_Discriminants (Ityp)
13224 and then No (First_Rep_Item (Base_Type (Ityp)))
13228 -- If the expression has an access type (object or subprogram) we assume
13229 -- that the conversion is safe, because the size of the target is safe,
13230 -- even if it is a record (which might be treated as having unknown size
13233 elsif Is_Access_Type (Ityp) then
13236 -- If the size of output type is known at compile time, there is never
13237 -- a problem. Note that unconstrained records are considered to be of
13238 -- known size, but we can't consider them that way here, because we are
13239 -- talking about the actual size of the object.
13241 -- We also make sure that in addition to the size being known, we do not
13242 -- have a case which might generate an embarrassingly large temp in
13243 -- stack checking mode.
13245 elsif Size_Known_At_Compile_Time (Otyp)
13247 (not Stack_Checking_Enabled
13248 or else not May_Generate_Large_Temp (Otyp))
13249 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
13253 -- If either type is tagged, then we know the alignment is OK so Gigi
13254 -- will be able to use pointer punning.
13256 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
13259 -- If either type is a limited record type, we cannot do a copy, so say
13260 -- safe since there's nothing else we can do.
13262 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
13265 -- Conversions to and from packed array types are always ignored and
13268 elsif Is_Packed_Array_Impl_Type (Otyp)
13269 or else Is_Packed_Array_Impl_Type (Ityp)
13274 -- The only other cases known to be safe is if the input type's
13275 -- alignment is known to be at least the maximum alignment for the
13276 -- target or if both alignments are known and the output type's
13277 -- alignment is no stricter than the input's. We can use the component
13278 -- type alignment for an array if a type is an unpacked array type.
13280 if Present (Alignment_Clause (Otyp)) then
13281 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
13283 elsif Is_Array_Type (Otyp)
13284 and then Present (Alignment_Clause (Component_Type (Otyp)))
13286 Oalign := Expr_Value (Expression (Alignment_Clause
13287 (Component_Type (Otyp))));
13290 if Present (Alignment_Clause (Ityp)) then
13291 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
13293 elsif Is_Array_Type (Ityp)
13294 and then Present (Alignment_Clause (Component_Type (Ityp)))
13296 Ialign := Expr_Value (Expression (Alignment_Clause
13297 (Component_Type (Ityp))));
13300 if Present (Ialign) and then Ialign > Maximum_Alignment then
13303 elsif Present (Ialign)
13304 and then Present (Oalign)
13305 and then Ialign <= Oalign
13309 -- Otherwise, Gigi cannot handle this and we must make a temporary
13314 end Safe_Unchecked_Type_Conversion;
13316 ---------------------------------
13317 -- Set_Current_Value_Condition --
13318 ---------------------------------
13320 -- Note: the implementation of this procedure is very closely tied to the
13321 -- implementation of Get_Current_Value_Condition. Here we set required
13322 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
13323 -- them, so they must have a consistent view.
13325 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
13327 procedure Set_Entity_Current_Value (N : Node_Id);
13328 -- If N is an entity reference, where the entity is of an appropriate
13329 -- kind, then set the current value of this entity to Cnode, unless
13330 -- there is already a definite value set there.
13332 procedure Set_Expression_Current_Value (N : Node_Id);
13333 -- If N is of an appropriate form, sets an appropriate entry in current
13334 -- value fields of relevant entities. Multiple entities can be affected
13335 -- in the case of an AND or AND THEN.
13337 ------------------------------
13338 -- Set_Entity_Current_Value --
13339 ------------------------------
13341 procedure Set_Entity_Current_Value (N : Node_Id) is
13343 if Is_Entity_Name (N) then
13345 Ent : constant Entity_Id := Entity (N);
13348 -- Don't capture if not safe to do so
13350 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
13354 -- Here we have a case where the Current_Value field may need
13355 -- to be set. We set it if it is not already set to a compile
13356 -- time expression value.
13358 -- Note that this represents a decision that one condition
13359 -- blots out another previous one. That's certainly right if
13360 -- they occur at the same level. If the second one is nested,
13361 -- then the decision is neither right nor wrong (it would be
13362 -- equally OK to leave the outer one in place, or take the new
13363 -- inner one). Really we should record both, but our data
13364 -- structures are not that elaborate.
13366 if Nkind (Current_Value (Ent)) not in N_Subexpr then
13367 Set_Current_Value (Ent, Cnode);
13371 end Set_Entity_Current_Value;
13373 ----------------------------------
13374 -- Set_Expression_Current_Value --
13375 ----------------------------------
13377 procedure Set_Expression_Current_Value (N : Node_Id) is
13383 -- Loop to deal with (ignore for now) any NOT operators present. The
13384 -- presence of NOT operators will be handled properly when we call
13385 -- Get_Current_Value_Condition.
13387 while Nkind (Cond) = N_Op_Not loop
13388 Cond := Right_Opnd (Cond);
13391 -- For an AND or AND THEN, recursively process operands
13393 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
13394 Set_Expression_Current_Value (Left_Opnd (Cond));
13395 Set_Expression_Current_Value (Right_Opnd (Cond));
13399 -- Check possible relational operator
13401 if Nkind (Cond) in N_Op_Compare then
13402 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
13403 Set_Entity_Current_Value (Left_Opnd (Cond));
13404 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
13405 Set_Entity_Current_Value (Right_Opnd (Cond));
13408 elsif Nkind (Cond) in N_Type_Conversion
13409 | N_Qualified_Expression
13410 | N_Expression_With_Actions
13412 Set_Expression_Current_Value (Expression (Cond));
13414 -- Check possible boolean variable reference
13417 Set_Entity_Current_Value (Cond);
13419 end Set_Expression_Current_Value;
13421 -- Start of processing for Set_Current_Value_Condition
13424 Set_Expression_Current_Value (Condition (Cnode));
13425 end Set_Current_Value_Condition;
13427 --------------------------
13428 -- Set_Elaboration_Flag --
13429 --------------------------
13431 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
13432 Loc : constant Source_Ptr := Sloc (N);
13433 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
13437 if Present (Ent) then
13439 -- Nothing to do if at the compilation unit level, because in this
13440 -- case the flag is set by the binder generated elaboration routine.
13442 if Nkind (Parent (N)) = N_Compilation_Unit then
13445 -- Here we do need to generate an assignment statement
13448 Check_Restriction (No_Elaboration_Code, N);
13451 Make_Assignment_Statement (Loc,
13452 Name => New_Occurrence_Of (Ent, Loc),
13453 Expression => Make_Integer_Literal (Loc, Uint_1));
13455 -- Mark the assignment statement as elaboration code. This allows
13456 -- the early call region mechanism (see Sem_Elab) to properly
13457 -- ignore such assignments even though they are nonpreelaborable
13460 Set_Is_Elaboration_Code (Asn);
13462 if Nkind (Parent (N)) = N_Subunit then
13463 Insert_After (Corresponding_Stub (Parent (N)), Asn);
13465 Insert_After (N, Asn);
13470 -- Kill current value indication. This is necessary because the
13471 -- tests of this flag are inserted out of sequence and must not
13472 -- pick up bogus indications of the wrong constant value.
13474 Set_Current_Value (Ent, Empty);
13476 -- If the subprogram is in the current declarative part and
13477 -- 'access has been applied to it, generate an elaboration
13478 -- check at the beginning of the declarations of the body.
13480 if Nkind (N) = N_Subprogram_Body
13481 and then Address_Taken (Spec_Id)
13483 Ekind (Scope (Spec_Id)) in E_Block | E_Procedure | E_Function
13486 Loc : constant Source_Ptr := Sloc (N);
13487 Decls : constant List_Id := Declarations (N);
13491 -- No need to generate this check if first entry in the
13492 -- declaration list is a raise of Program_Error now.
13495 and then Nkind (First (Decls)) = N_Raise_Program_Error
13500 -- Otherwise generate the check
13503 Make_Raise_Program_Error (Loc,
13506 Left_Opnd => New_Occurrence_Of (Ent, Loc),
13507 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
13508 Reason => PE_Access_Before_Elaboration);
13511 Set_Declarations (N, New_List (Chk));
13513 Prepend (Chk, Decls);
13521 end Set_Elaboration_Flag;
13523 ----------------------------
13524 -- Set_Renamed_Subprogram --
13525 ----------------------------
13527 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
13529 -- If input node is an identifier, we can just reset it
13531 if Nkind (N) = N_Identifier then
13532 Set_Chars (N, Chars (E));
13535 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
13539 CS : constant Boolean := Comes_From_Source (N);
13541 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
13543 Set_Comes_From_Source (N, CS);
13544 Set_Analyzed (N, True);
13547 end Set_Renamed_Subprogram;
13549 ----------------------
13550 -- Side_Effect_Free --
13551 ----------------------
13553 function Side_Effect_Free
13555 Name_Req : Boolean := False;
13556 Variable_Ref : Boolean := False) return Boolean
13558 Typ : constant Entity_Id := Etype (N);
13559 -- Result type of the expression
13561 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
13562 -- The argument N is a construct where the Prefix is dereferenced if it
13563 -- is an access type and the result is a variable. The call returns True
13564 -- if the construct is side effect free (not considering side effects in
13565 -- other than the prefix which are to be tested by the caller).
13567 function Within_In_Parameter (N : Node_Id) return Boolean;
13568 -- Determines if N is a subcomponent of a composite in-parameter. If so,
13569 -- N is not side-effect free when the actual is global and modifiable
13570 -- indirectly from within a subprogram, because it may be passed by
13571 -- reference. The front-end must be conservative here and assume that
13572 -- this may happen with any array or record type. On the other hand, we
13573 -- cannot create temporaries for all expressions for which this
13574 -- condition is true, for various reasons that might require clearing up
13575 -- ??? For example, discriminant references that appear out of place, or
13576 -- spurious type errors with class-wide expressions. As a result, we
13577 -- limit the transformation to loop bounds, which is so far the only
13578 -- case that requires it.
13580 -----------------------------
13581 -- Safe_Prefixed_Reference --
13582 -----------------------------
13584 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
13586 -- If prefix is not side effect free, definitely not safe
13588 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
13591 -- If the prefix is of an access type that is not access-to-constant,
13592 -- then this construct is a variable reference, which means it is to
13593 -- be considered to have side effects if Variable_Ref is set True.
13595 elsif Is_Access_Type (Etype (Prefix (N)))
13596 and then not Is_Access_Constant (Etype (Prefix (N)))
13597 and then Variable_Ref
13599 -- Exception is a prefix that is the result of a previous removal
13600 -- of side effects.
13602 return Is_Entity_Name (Prefix (N))
13603 and then not Comes_From_Source (Prefix (N))
13604 and then Ekind (Entity (Prefix (N))) = E_Constant
13605 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
13607 -- If the prefix is an explicit dereference then this construct is a
13608 -- variable reference, which means it is to be considered to have
13609 -- side effects if Variable_Ref is True.
13611 -- We do NOT exclude dereferences of access-to-constant types because
13612 -- we handle them as constant view of variables.
13614 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
13615 and then Variable_Ref
13619 -- Note: The following test is the simplest way of solving a complex
13620 -- problem uncovered by the following test (Side effect on loop bound
13621 -- that is a subcomponent of a global variable:
13623 -- with Text_Io; use Text_Io;
13624 -- procedure Tloop is
13627 -- V : Natural := 4;
13628 -- S : String (1..5) := (others => 'a');
13635 -- with procedure Action;
13636 -- procedure Loop_G (Arg : X; Msg : String)
13638 -- procedure Loop_G (Arg : X; Msg : String) is
13640 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
13641 -- & Natural'Image (Arg.V));
13642 -- for Index in 1 .. Arg.V loop
13643 -- Text_Io.Put_Line
13644 -- (Natural'Image (Index) & " " & Arg.S (Index));
13645 -- if Index > 2 then
13649 -- Put_Line ("end loop_g " & Msg);
13652 -- procedure Loop1 is new Loop_G (Modi);
13653 -- procedure Modi is
13656 -- Loop1 (X1, "from modi");
13660 -- Loop1 (X1, "initial");
13663 -- The output of the above program should be:
13665 -- begin loop_g initial will loop till: 4
13669 -- begin loop_g from modi will loop till: 1
13671 -- end loop_g from modi
13673 -- begin loop_g from modi will loop till: 1
13675 -- end loop_g from modi
13676 -- end loop_g initial
13678 -- If a loop bound is a subcomponent of a global variable, a
13679 -- modification of that variable within the loop may incorrectly
13680 -- affect the execution of the loop.
13682 elsif Parent_Kind (Parent (N)) = N_Loop_Parameter_Specification
13683 and then Within_In_Parameter (Prefix (N))
13684 and then Variable_Ref
13688 -- All other cases are side effect free
13693 end Safe_Prefixed_Reference;
13695 -------------------------
13696 -- Within_In_Parameter --
13697 -------------------------
13699 function Within_In_Parameter (N : Node_Id) return Boolean is
13701 if not Comes_From_Source (N) then
13704 elsif Is_Entity_Name (N) then
13705 return Ekind (Entity (N)) = E_In_Parameter;
13707 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
13708 return Within_In_Parameter (Prefix (N));
13713 end Within_In_Parameter;
13715 -- Start of processing for Side_Effect_Free
13718 -- If volatile reference, always consider it to have side effects
13720 if Is_Volatile_Reference (N) then
13724 -- Note on checks that could raise Constraint_Error. Strictly, if we
13725 -- take advantage of 11.6, these checks do not count as side effects.
13726 -- However, we would prefer to consider that they are side effects,
13727 -- since the back end CSE does not work very well on expressions which
13728 -- can raise Constraint_Error. On the other hand if we don't consider
13729 -- them to be side effect free, then we get some awkward expansions
13730 -- in -gnato mode, resulting in code insertions at a point where we
13731 -- do not have a clear model for performing the insertions.
13733 -- Special handling for entity names
13735 if Is_Entity_Name (N) then
13737 -- A type reference is always side effect free
13739 if Is_Type (Entity (N)) then
13742 -- Variables are considered to be a side effect if Variable_Ref
13743 -- is set or if we have a volatile reference and Name_Req is off.
13744 -- If Name_Req is True then we can't help returning a name which
13745 -- effectively allows multiple references in any case.
13747 elsif Is_Variable (N, Use_Original_Node => False) then
13748 return not Variable_Ref
13749 and then (not Is_Volatile_Reference (N) or else Name_Req);
13751 -- Any other entity (e.g. a subtype name) is definitely side
13758 -- A value known at compile time is always side effect free
13760 elsif Compile_Time_Known_Value (N) then
13763 -- A variable renaming is not side-effect free, because the renaming
13764 -- will function like a macro in the front-end in some cases, and an
13765 -- assignment can modify the component designated by N, so we need to
13766 -- create a temporary for it.
13768 -- The guard testing for Entity being present is needed at least in
13769 -- the case of rewritten predicate expressions, and may well also be
13770 -- appropriate elsewhere. Obviously we can't go testing the entity
13771 -- field if it does not exist, so it's reasonable to say that this is
13772 -- not the renaming case if it does not exist.
13774 elsif Is_Entity_Name (Original_Node (N))
13775 and then Present (Entity (Original_Node (N)))
13776 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
13777 and then Ekind (Entity (Original_Node (N))) /= E_Constant
13780 RO : constant Node_Id :=
13781 Renamed_Object (Entity (Original_Node (N)));
13784 -- If the renamed object is an indexed component, or an
13785 -- explicit dereference, then the designated object could
13786 -- be modified by an assignment.
13788 if Nkind (RO) in N_Indexed_Component | N_Explicit_Dereference then
13791 -- A selected component must have a safe prefix
13793 elsif Nkind (RO) = N_Selected_Component then
13794 return Safe_Prefixed_Reference (RO);
13796 -- In all other cases, designated object cannot be changed so
13797 -- we are side effect free.
13804 -- Remove_Side_Effects generates an object renaming declaration to
13805 -- capture the expression of a class-wide expression. In VM targets
13806 -- the frontend performs no expansion for dispatching calls to
13807 -- class- wide types since they are handled by the VM. Hence, we must
13808 -- locate here if this node corresponds to a previous invocation of
13809 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
13811 elsif not Tagged_Type_Expansion
13812 and then not Comes_From_Source (N)
13813 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
13814 and then Is_Class_Wide_Type (Typ)
13818 -- Generating C the type conversion of an access to constrained array
13819 -- type into an access to unconstrained array type involves initializing
13820 -- a fat pointer and the expression cannot be assumed to be free of side
13821 -- effects since it must referenced several times to compute its bounds.
13823 elsif Modify_Tree_For_C
13824 and then Nkind (N) = N_Type_Conversion
13825 and then Is_Access_Type (Typ)
13826 and then Is_Array_Type (Designated_Type (Typ))
13827 and then not Is_Constrained (Designated_Type (Typ))
13832 -- For other than entity names and compile time known values,
13833 -- check the node kind for special processing.
13837 -- An attribute reference is side-effect free if its expressions
13838 -- are side-effect free and its prefix is side-effect free or is
13839 -- an entity reference.
13841 when N_Attribute_Reference =>
13842 return Side_Effect_Free_Attribute (Attribute_Name (N))
13844 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13846 (Is_Entity_Name (Prefix (N))
13848 Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
13850 -- A binary operator is side effect free if and both operands are
13851 -- side effect free. For this purpose binary operators include
13852 -- short circuit forms.
13857 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13859 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13861 -- Membership tests may have either Right_Opnd or Alternatives set
13863 when N_Membership_Test =>
13864 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13866 (if Present (Right_Opnd (N))
13867 then Side_Effect_Free
13868 (Right_Opnd (N), Name_Req, Variable_Ref)
13869 else Side_Effect_Free
13870 (Alternatives (N), Name_Req, Variable_Ref));
13872 -- An explicit dereference is side effect free only if it is
13873 -- a side effect free prefixed reference.
13875 when N_Explicit_Dereference =>
13876 return Safe_Prefixed_Reference (N);
13878 -- An expression with action is side effect free if its expression
13879 -- is side effect free and it has no actions.
13881 when N_Expression_With_Actions =>
13883 Is_Empty_List (Actions (N))
13884 and then Side_Effect_Free
13885 (Expression (N), Name_Req, Variable_Ref);
13887 -- A call to _rep_to_pos is side effect free, since we generate
13888 -- this pure function call ourselves. Moreover it is critically
13889 -- important to make this exception, since otherwise we can have
13890 -- discriminants in array components which don't look side effect
13891 -- free in the case of an array whose index type is an enumeration
13892 -- type with an enumeration rep clause.
13894 -- All other function calls are not side effect free
13896 when N_Function_Call =>
13898 Nkind (Name (N)) = N_Identifier
13899 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
13900 and then Side_Effect_Free
13901 (First (Parameter_Associations (N)),
13902 Name_Req, Variable_Ref);
13904 -- An IF expression is side effect free if it's of a scalar type, and
13905 -- all its components are all side effect free (conditions and then
13906 -- actions and else actions). We restrict to scalar types, since it
13907 -- is annoying to deal with things like (if A then B else C)'First
13908 -- where the type involved is a string type.
13910 when N_If_Expression =>
13912 Is_Scalar_Type (Typ)
13913 and then Side_Effect_Free
13914 (Expressions (N), Name_Req, Variable_Ref);
13916 -- An indexed component is side effect free if it is a side
13917 -- effect free prefixed reference and all the indexing
13918 -- expressions are side effect free.
13920 when N_Indexed_Component =>
13922 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13923 and then Safe_Prefixed_Reference (N);
13925 -- A type qualification, type conversion, or unchecked expression is
13926 -- side effect free if the expression is side effect free.
13928 when N_Qualified_Expression
13929 | N_Type_Conversion
13930 | N_Unchecked_Expression
13932 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
13934 -- A selected component is side effect free only if it is a side
13935 -- effect free prefixed reference.
13937 when N_Selected_Component =>
13938 return Safe_Prefixed_Reference (N);
13940 -- A range is side effect free if the bounds are side effect free
13943 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
13945 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
13947 -- A slice is side effect free if it is a side effect free
13948 -- prefixed reference and the bounds are side effect free.
13952 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
13953 and then Safe_Prefixed_Reference (N);
13955 -- A unary operator is side effect free if the operand
13956 -- is side effect free.
13959 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13961 -- An unchecked type conversion is side effect free only if it
13962 -- is safe and its argument is side effect free.
13964 when N_Unchecked_Type_Conversion =>
13966 Safe_Unchecked_Type_Conversion (N)
13967 and then Side_Effect_Free
13968 (Expression (N), Name_Req, Variable_Ref);
13970 -- A literal is side effect free
13972 when N_Character_Literal
13973 | N_Integer_Literal
13979 -- An aggregate is side effect free if all its values are compile
13982 when N_Aggregate =>
13983 return Compile_Time_Known_Aggregate (N);
13985 -- We consider that anything else has side effects. This is a bit
13986 -- crude, but we are pretty close for most common cases, and we
13987 -- are certainly correct (i.e. we never return True when the
13988 -- answer should be False).
13993 end Side_Effect_Free;
13995 -- A list is side effect free if all elements of the list are side
13998 function Side_Effect_Free
14000 Name_Req : Boolean := False;
14001 Variable_Ref : Boolean := False) return Boolean
14006 if L = No_List or else L = Error_List then
14011 while Present (N) loop
14012 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
14021 end Side_Effect_Free;
14023 --------------------------------
14024 -- Side_Effect_Free_Attribute --
14025 --------------------------------
14027 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
14036 | Name_Wide_Wide_Image
14038 -- CodePeer doesn't want to see replicated copies of 'Image calls
14040 return not CodePeer_Mode;
14045 end Side_Effect_Free_Attribute;
14047 ----------------------------------
14048 -- Silly_Boolean_Array_Not_Test --
14049 ----------------------------------
14051 -- This procedure implements an odd and silly test. We explicitly check
14052 -- for the case where the 'First of the component type is equal to the
14053 -- 'Last of this component type, and if this is the case, we make sure
14054 -- that constraint error is raised. The reason is that the NOT is bound
14055 -- to cause CE in this case, and we will not otherwise catch it.
14057 -- No such check is required for AND and OR, since for both these cases
14058 -- False op False = False, and True op True = True. For the XOR case,
14059 -- see Silly_Boolean_Array_Xor_Test.
14061 -- Believe it or not, this was reported as a bug. Note that nearly always,
14062 -- the test will evaluate statically to False, so the code will be
14063 -- statically removed, and no extra overhead caused.
14065 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
14066 Loc : constant Source_Ptr := Sloc (N);
14067 CT : constant Entity_Id := Component_Type (T);
14070 -- The check we install is
14072 -- constraint_error when
14073 -- component_type'first = component_type'last
14074 -- and then array_type'Length /= 0)
14076 -- We need the last guard because we don't want to raise CE for empty
14077 -- arrays since no out of range values result. (Empty arrays with a
14078 -- component type of True .. True -- very useful -- even the ACATS
14079 -- does not test that marginal case).
14082 Make_Raise_Constraint_Error (Loc,
14084 Make_And_Then (Loc,
14088 Make_Attribute_Reference (Loc,
14089 Prefix => New_Occurrence_Of (CT, Loc),
14090 Attribute_Name => Name_First),
14093 Make_Attribute_Reference (Loc,
14094 Prefix => New_Occurrence_Of (CT, Loc),
14095 Attribute_Name => Name_Last)),
14097 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
14098 Reason => CE_Range_Check_Failed));
14099 end Silly_Boolean_Array_Not_Test;
14101 ----------------------------------
14102 -- Silly_Boolean_Array_Xor_Test --
14103 ----------------------------------
14105 -- This procedure implements an odd and silly test. We explicitly check
14106 -- for the XOR case where the component type is True .. True, since this
14107 -- will raise constraint error. A special check is required since CE
14108 -- will not be generated otherwise (cf Expand_Packed_Not).
14110 -- No such check is required for AND and OR, since for both these cases
14111 -- False op False = False, and True op True = True, and no check is
14112 -- required for the case of False .. False, since False xor False = False.
14113 -- See also Silly_Boolean_Array_Not_Test
14115 procedure Silly_Boolean_Array_Xor_Test
14120 Loc : constant Source_Ptr := Sloc (N);
14121 CT : constant Entity_Id := Component_Type (T);
14124 -- The check we install is
14126 -- constraint_error when
14127 -- Boolean (component_type'First)
14128 -- and then Boolean (component_type'Last)
14129 -- and then array_type'Length /= 0)
14131 -- We need the last guard because we don't want to raise CE for empty
14132 -- arrays since no out of range values result (Empty arrays with a
14133 -- component type of True .. True -- very useful -- even the ACATS
14134 -- does not test that marginal case).
14137 Make_Raise_Constraint_Error (Loc,
14139 Make_And_Then (Loc,
14141 Make_And_Then (Loc,
14143 Convert_To (Standard_Boolean,
14144 Make_Attribute_Reference (Loc,
14145 Prefix => New_Occurrence_Of (CT, Loc),
14146 Attribute_Name => Name_First)),
14149 Convert_To (Standard_Boolean,
14150 Make_Attribute_Reference (Loc,
14151 Prefix => New_Occurrence_Of (CT, Loc),
14152 Attribute_Name => Name_Last))),
14154 Right_Opnd => Make_Non_Empty_Check (Loc, R)),
14155 Reason => CE_Range_Check_Failed));
14156 end Silly_Boolean_Array_Xor_Test;
14158 ----------------------------
14159 -- Small_Integer_Type_For --
14160 ----------------------------
14162 function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id
14165 pragma Assert (S <= System_Max_Integer_Size);
14167 if S <= Standard_Short_Short_Integer_Size then
14169 return Standard_Short_Short_Unsigned;
14171 return Standard_Short_Short_Integer;
14174 elsif S <= Standard_Short_Integer_Size then
14176 return Standard_Short_Unsigned;
14178 return Standard_Short_Integer;
14181 elsif S <= Standard_Integer_Size then
14183 return Standard_Unsigned;
14185 return Standard_Integer;
14188 elsif S <= Standard_Long_Integer_Size then
14190 return Standard_Long_Unsigned;
14192 return Standard_Long_Integer;
14195 elsif S <= Standard_Long_Long_Integer_Size then
14197 return Standard_Long_Long_Unsigned;
14199 return Standard_Long_Long_Integer;
14202 elsif S <= Standard_Long_Long_Long_Integer_Size then
14204 return Standard_Long_Long_Long_Unsigned;
14206 return Standard_Long_Long_Long_Integer;
14210 raise Program_Error;
14212 end Small_Integer_Type_For;
14214 -------------------
14215 -- Type_Map_Hash --
14216 -------------------
14218 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
14220 return Type_Map_Header (Id mod Type_Map_Size);
14223 ------------------------------------------
14224 -- Type_May_Have_Bit_Aligned_Components --
14225 ------------------------------------------
14227 function Type_May_Have_Bit_Aligned_Components
14228 (Typ : Entity_Id) return Boolean
14231 -- Array type, check component type
14233 if Is_Array_Type (Typ) then
14235 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
14237 -- Record type, check components
14239 elsif Is_Record_Type (Typ) then
14244 E := First_Component_Or_Discriminant (Typ);
14245 while Present (E) loop
14246 -- This is the crucial test: if the component itself causes
14247 -- trouble, then we can stop and return True.
14249 if Component_May_Be_Bit_Aligned (E) then
14253 -- Otherwise, we need to test its type, to see if it may
14254 -- itself contain a troublesome component.
14256 if Type_May_Have_Bit_Aligned_Components (Etype (E)) then
14260 Next_Component_Or_Discriminant (E);
14266 -- Type other than array or record is always OK
14271 end Type_May_Have_Bit_Aligned_Components;
14273 -------------------------------
14274 -- Update_Primitives_Mapping --
14275 -------------------------------
14277 procedure Update_Primitives_Mapping
14278 (Inher_Id : Entity_Id;
14279 Subp_Id : Entity_Id)
14281 Parent_Type : constant Entity_Id := Find_Dispatching_Type (Inher_Id);
14282 Derived_Type : constant Entity_Id := Find_Dispatching_Type (Subp_Id);
14285 pragma Assert (Parent_Type /= Derived_Type);
14286 Map_Types (Parent_Type, Derived_Type);
14287 end Update_Primitives_Mapping;
14289 ----------------------------------
14290 -- Within_Case_Or_If_Expression --
14291 ----------------------------------
14293 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
14297 -- Locate an enclosing case or if expression. Note that these constructs
14298 -- can be expanded into Expression_With_Actions, hence the test of the
14302 while Present (Par) loop
14303 if Nkind (Original_Node (Par)) in N_Case_Expression | N_If_Expression
14307 -- Prevent the search from going too far
14309 elsif Is_Body_Or_Package_Declaration (Par) then
14313 Par := Parent (Par);
14317 end Within_Case_Or_If_Expression;
14319 ------------------------------
14320 -- Predicate_Check_In_Scope --
14321 ------------------------------
14323 function Predicate_Check_In_Scope (N : Node_Id) return Boolean is
14327 S := Current_Scope;
14328 while Present (S) and then not Is_Subprogram (S) loop
14332 if Present (S) then
14334 -- Predicate checks should only be enabled in init procs for
14335 -- expressions coming from source.
14337 if Is_Init_Proc (S) then
14338 return Comes_From_Source (N);
14340 elsif Get_TSS_Name (S) /= TSS_Null
14341 and then not Is_Predicate_Function (S)
14342 and then not Is_Predicate_Function_M (S)
14349 end Predicate_Check_In_Scope;