1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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
337 Loc : constant Source_Ptr := Sloc (N);
338 T : constant Entity_Id := Etype (N);
341 -- Defend against a call where the argument has no type, or has a
342 -- type that is not Boolean. This can occur because of prior errors.
344 if No (T) or else not Is_Boolean_Type (T) then
348 -- Apply validity checking if needed
350 if Validity_Checks_On and Validity_Check_Tests then
354 -- Immediate return if standard boolean, the most common case,
355 -- where nothing needs to be done.
357 if Base_Type (T) = Standard_Boolean then
361 -- Case of zero/nonzero semantics or nonstandard enumeration
362 -- representation. In each case, we rewrite the node as:
364 -- ityp!(N) /= False'Enum_Rep
366 -- where ityp is an integer type with large enough size to hold any
369 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
374 (Integer_Type_For (Esize (T), Uns => False), N),
376 Make_Attribute_Reference (Loc,
377 Attribute_Name => Name_Enum_Rep,
379 New_Occurrence_Of (First_Literal (T), Loc))));
380 Analyze_And_Resolve (N, Standard_Boolean);
383 Rewrite (N, Convert_To (Standard_Boolean, N));
384 Analyze_And_Resolve (N, Standard_Boolean);
387 end Adjust_Condition;
389 ------------------------
390 -- Adjust_Result_Type --
391 ------------------------
393 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
395 -- Ignore call if current type is not Standard.Boolean
397 if Etype (N) /= Standard_Boolean then
401 -- If result is already of correct type, nothing to do. Note that
402 -- this will get the most common case where everything has a type
403 -- of Standard.Boolean.
405 if Base_Type (T) = Standard_Boolean then
410 KP : constant Node_Kind := Nkind (Parent (N));
413 -- If result is to be used as a Condition in the syntax, no need
414 -- to convert it back, since if it was changed to Standard.Boolean
415 -- using Adjust_Condition, that is just fine for this usage.
417 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
420 -- If result is an operand of another logical operation, no need
421 -- to reset its type, since Standard.Boolean is just fine, and
422 -- such operations always do Adjust_Condition on their operands.
424 elsif KP in N_Op_Boolean
425 or else KP in N_Short_Circuit
426 or else KP = N_Op_Not
430 -- Otherwise we perform a conversion from the current type, which
431 -- must be Standard.Boolean, to the desired type. Use the base
432 -- type to prevent spurious constraint checks that are extraneous
433 -- to the transformation. The type and its base have the same
434 -- representation, standard or otherwise.
438 Rewrite (N, Convert_To (Base_Type (T), N));
439 Analyze_And_Resolve (N, Base_Type (T));
443 end Adjust_Result_Type;
445 --------------------------
446 -- Append_Freeze_Action --
447 --------------------------
449 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
453 Ensure_Freeze_Node (T);
454 Fnode := Freeze_Node (T);
456 if No (Actions (Fnode)) then
457 Set_Actions (Fnode, New_List (N));
459 Append (N, Actions (Fnode));
462 end Append_Freeze_Action;
464 ---------------------------
465 -- Append_Freeze_Actions --
466 ---------------------------
468 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
476 Ensure_Freeze_Node (T);
477 Fnode := Freeze_Node (T);
479 if No (Actions (Fnode)) then
480 Set_Actions (Fnode, L);
482 Append_List (L, Actions (Fnode));
484 end Append_Freeze_Actions;
486 ----------------------------------------
487 -- Attribute_Constrained_Static_Value --
488 ----------------------------------------
490 function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
492 Ptyp : constant Entity_Id := Etype (Pref);
493 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
495 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
496 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
497 -- view of an aliased object whose subtype is constrained.
499 ---------------------------------
500 -- Is_Constrained_Aliased_View --
501 ---------------------------------
503 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
507 if Is_Entity_Name (Obj) then
510 if Present (Renamed_Object (E)) then
511 return Is_Constrained_Aliased_View (Renamed_Object (E));
513 return Is_Aliased (E) and then Is_Constrained (Etype (E));
517 return Is_Aliased_View (Obj)
519 (Is_Constrained (Etype (Obj))
521 (Nkind (Obj) = N_Explicit_Dereference
523 not Object_Type_Has_Constrained_Partial_View
524 (Typ => Base_Type (Etype (Obj)),
525 Scop => Current_Scope)));
527 end Is_Constrained_Aliased_View;
529 -- Start of processing for Attribute_Constrained_Static_Value
532 -- We are in a case where the attribute is known statically, and
533 -- implicit dereferences have been rewritten.
536 (not (Present (Formal_Ent)
537 and then Ekind (Formal_Ent) /= E_Constant
538 and then Present (Extra_Constrained (Formal_Ent)))
540 not (Is_Access_Type (Etype (Pref))
541 and then (not Is_Entity_Name (Pref)
542 or else Is_Object (Entity (Pref))))
544 not (Nkind (Pref) = N_Identifier
545 and then Ekind (Entity (Pref)) = E_Variable
546 and then Present (Extra_Constrained (Entity (Pref)))));
548 if Is_Entity_Name (Pref) then
550 Ent : constant Entity_Id := Entity (Pref);
554 -- (RM J.4) obsolescent cases
556 if Is_Type (Ent) then
560 if Is_Private_Type (Ent) then
561 Res := not Has_Discriminants (Ent)
562 or else Is_Constrained (Ent);
564 -- It not a private type, must be a generic actual type
565 -- that corresponded to a private type. We know that this
566 -- correspondence holds, since otherwise the reference
567 -- within the generic template would have been illegal.
570 if Is_Composite_Type (Underlying_Type (Ent)) then
571 Res := Is_Constrained (Ent);
579 -- If the prefix is not a variable or is aliased, then
580 -- definitely true; if it's a formal parameter without an
581 -- associated extra formal, then treat it as constrained.
583 -- Ada 2005 (AI-363): An aliased prefix must be known to be
584 -- constrained in order to set the attribute to True.
586 if not Is_Variable (Pref)
587 or else Present (Formal_Ent)
588 or else (Ada_Version < Ada_2005
589 and then Is_Aliased_View (Pref))
590 or else (Ada_Version >= Ada_2005
591 and then Is_Constrained_Aliased_View (Pref))
595 -- Variable case, look at type to see if it is constrained.
596 -- Note that the one case where this is not accurate (the
597 -- procedure formal case), has been handled above.
599 -- We use the Underlying_Type here (and below) in case the
600 -- type is private without discriminants, but the full type
601 -- has discriminants. This case is illegal, but we generate
602 -- it internally for passing to the Extra_Constrained
606 -- In Ada 2012, test for case of a limited tagged type,
607 -- in which case the attribute is always required to
608 -- return True. The underlying type is tested, to make
609 -- sure we also return True for cases where there is an
610 -- unconstrained object with an untagged limited partial
611 -- view which has defaulted discriminants (such objects
612 -- always produce a False in earlier versions of
613 -- Ada). (Ada 2012: AI05-0214)
616 Is_Constrained (Underlying_Type (Etype (Ent)))
618 (Ada_Version >= Ada_2012
619 and then Is_Tagged_Type (Underlying_Type (Ptyp))
620 and then Is_Limited_Type (Ptyp));
627 -- Prefix is not an entity name. These are also cases where we can
628 -- always tell at compile time by looking at the form and type of the
629 -- prefix. If an explicit dereference of an object with constrained
630 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
631 -- underlying type is a limited tagged type, then Constrained is
632 -- required to always return True (Ada 2012: AI05-0214).
635 return not Is_Variable (Pref)
637 (Nkind (Pref) = N_Explicit_Dereference
639 not Object_Type_Has_Constrained_Partial_View
640 (Typ => Base_Type (Ptyp),
641 Scop => Current_Scope))
642 or else Is_Constrained (Underlying_Type (Ptyp))
643 or else (Ada_Version >= Ada_2012
644 and then Is_Tagged_Type (Underlying_Type (Ptyp))
645 and then Is_Limited_Type (Ptyp));
647 end Attribute_Constrained_Static_Value;
649 ------------------------------------
650 -- Build_Allocate_Deallocate_Proc --
651 ------------------------------------
653 procedure Build_Allocate_Deallocate_Proc
655 Is_Allocate : Boolean)
657 function Find_Object (E : Node_Id) return Node_Id;
658 -- Given an arbitrary expression of an allocator, try to find an object
659 -- reference in it, otherwise return the original expression.
661 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
662 -- Determine whether subprogram Subp denotes a custom allocate or
669 function Find_Object (E : Node_Id) return Node_Id is
673 pragma Assert (Is_Allocate);
677 if Nkind (Expr) = N_Explicit_Dereference then
678 Expr := Prefix (Expr);
680 elsif Nkind (Expr) = N_Qualified_Expression then
681 Expr := Expression (Expr);
683 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
685 -- When interface class-wide types are involved in allocation,
686 -- the expander introduces several levels of address arithmetic
687 -- to perform dispatch table displacement. In this scenario the
688 -- object appears as:
690 -- Tag_Ptr (Base_Address (<object>'Address))
692 -- Detect this case and utilize the whole expression as the
693 -- "object" since it now points to the proper dispatch table.
695 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
698 -- Continue to strip the object
701 Expr := Expression (Expr);
712 ---------------------------------
713 -- Is_Allocate_Deallocate_Proc --
714 ---------------------------------
716 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
718 -- Look for a subprogram body with only one statement which is a
719 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
721 if Ekind (Subp) = E_Procedure
722 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
725 HSS : constant Node_Id :=
726 Handled_Statement_Sequence (Parent (Parent (Subp)));
730 if Present (Statements (HSS))
731 and then Nkind (First (Statements (HSS))) =
732 N_Procedure_Call_Statement
734 Proc := Entity (Name (First (Statements (HSS))));
737 Is_RTE (Proc, RE_Allocate_Any_Controlled)
738 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
744 end Is_Allocate_Deallocate_Proc;
748 Desig_Typ : Entity_Id;
752 Proc_To_Call : Node_Id := Empty;
754 Use_Secondary_Stack_Pool : Boolean;
756 -- Start of processing for Build_Allocate_Deallocate_Proc
759 -- Obtain the attributes of the allocation / deallocation
761 if Nkind (N) = N_Free_Statement then
762 Expr := Expression (N);
763 Ptr_Typ := Base_Type (Etype (Expr));
764 Proc_To_Call := Procedure_To_Call (N);
767 if Nkind (N) = N_Object_Declaration then
768 Expr := Expression (N);
773 -- In certain cases an allocator with a qualified expression may
774 -- be relocated and used as the initialization expression of a
778 -- Obj : Ptr_Typ := new Desig_Typ'(...);
781 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
782 -- Obj : Ptr_Typ := Tmp;
784 -- Since the allocator is always marked as analyzed to avoid infinite
785 -- expansion, it will never be processed by this routine given that
786 -- the designated type needs finalization actions. Detect this case
787 -- and complete the expansion of the allocator.
789 if Nkind (Expr) = N_Identifier
790 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
791 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
793 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
797 -- The allocator may have been rewritten into something else in which
798 -- case the expansion performed by this routine does not apply.
800 if Nkind (Expr) /= N_Allocator then
804 Ptr_Typ := Base_Type (Etype (Expr));
805 Proc_To_Call := Procedure_To_Call (Expr);
808 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
809 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
811 -- Handle concurrent types
813 if Is_Concurrent_Type (Desig_Typ)
814 and then Present (Corresponding_Record_Type (Desig_Typ))
816 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
819 Use_Secondary_Stack_Pool :=
820 Is_RTE (Pool_Id, RE_SS_Pool)
821 or else (Nkind (Expr) = N_Allocator
822 and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool));
824 -- Do not process allocations / deallocations without a pool
829 -- Do not process allocations on / deallocations from the secondary
830 -- stack, except for access types used to implement indirect temps.
832 elsif Use_Secondary_Stack_Pool
833 and then not Old_Attr_Util.Indirect_Temps
834 .Is_Access_Type_For_Indirect_Temp (Ptr_Typ)
838 -- Optimize the case where we are using the default Global_Pool_Object,
839 -- and we don't need the heavy finalization machinery.
841 elsif Is_RTE (Pool_Id, RE_Global_Pool_Object)
842 and then not Needs_Finalization (Desig_Typ)
846 -- Do not replicate the machinery if the allocator / free has already
847 -- been expanded and has a custom Allocate / Deallocate.
849 elsif Present (Proc_To_Call)
850 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
855 -- Finalization actions are required when the object to be allocated or
856 -- deallocated needs these actions and the associated access type is not
857 -- subject to pragma No_Heap_Finalization.
860 Needs_Finalization (Desig_Typ)
861 and then not No_Heap_Finalization (Ptr_Typ);
865 -- Do nothing if the access type may never allocate / deallocate
868 if No_Pool_Assigned (Ptr_Typ) then
872 -- The allocation / deallocation of a controlled object must be
873 -- chained on / detached from a finalization master.
875 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
877 -- The only other kind of allocation / deallocation supported by this
878 -- routine is on / from a subpool.
880 elsif Nkind (Expr) = N_Allocator
881 and then No (Subpool_Handle_Name (Expr))
887 Loc : constant Source_Ptr := Sloc (N);
888 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
889 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
890 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
891 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
894 Fin_Addr_Id : Entity_Id;
895 Fin_Mas_Act : Node_Id;
896 Fin_Mas_Id : Entity_Id;
897 Proc_To_Call : Entity_Id;
898 Subpool : Node_Id := Empty;
901 -- Step 1: Construct all the actuals for the call to library routine
902 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
906 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
912 if Nkind (Expr) = N_Allocator then
913 Subpool := Subpool_Handle_Name (Expr);
916 -- If a subpool is present it can be an arbitrary name, so make
917 -- the actual by copying the tree.
919 if Present (Subpool) then
920 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
922 Append_To (Actuals, Make_Null (Loc));
925 -- c) Finalization master
928 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
929 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
931 -- Handle the case where the master is actually a pointer to a
932 -- master. This case arises in build-in-place functions.
934 if Is_Access_Type (Etype (Fin_Mas_Id)) then
935 Append_To (Actuals, Fin_Mas_Act);
938 Make_Attribute_Reference (Loc,
939 Prefix => Fin_Mas_Act,
940 Attribute_Name => Name_Unrestricted_Access));
943 Append_To (Actuals, Make_Null (Loc));
946 -- d) Finalize_Address
948 -- Primitive Finalize_Address is never generated in CodePeer mode
949 -- since it contains an Unchecked_Conversion.
951 if Needs_Fin and then not CodePeer_Mode then
952 Fin_Addr_Id := Finalize_Address (Desig_Typ);
953 pragma Assert (Present (Fin_Addr_Id));
956 Make_Attribute_Reference (Loc,
957 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
958 Attribute_Name => Name_Unrestricted_Access));
960 Append_To (Actuals, Make_Null (Loc));
968 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
969 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
971 if (Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ))
972 and then not Use_Secondary_Stack_Pool
974 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
976 -- For deallocation of class-wide types we obtain the value of
977 -- alignment from the Type Specific Record of the deallocated object.
978 -- This is needed because the frontend expansion of class-wide types
979 -- into equivalent types confuses the back end.
985 -- ... because 'Alignment applied to class-wide types is expanded
986 -- into the code that reads the value of alignment from the TSD
987 -- (see Expand_N_Attribute_Reference)
989 -- In the Use_Secondary_Stack_Pool case, Alig_Id is not
990 -- passed in and therefore must not be referenced.
993 Unchecked_Convert_To (RTE (RE_Storage_Offset),
994 Make_Attribute_Reference (Loc,
996 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
997 Attribute_Name => Name_Alignment)));
1003 Is_Controlled : declare
1004 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
1005 Flag_Expr : Node_Id;
1012 Temp := Find_Object (Expression (Expr));
1017 -- Processing for allocations where the expression is a subtype
1021 and then Is_Entity_Name (Temp)
1022 and then Is_Type (Entity (Temp))
1027 (Needs_Finalization (Entity (Temp))), Loc);
1029 -- The allocation / deallocation of a class-wide object relies
1030 -- on a runtime check to determine whether the object is truly
1031 -- controlled or not. Depending on this check, the finalization
1032 -- machinery will request or reclaim extra storage reserved for
1035 elsif Is_Class_Wide_Type (Desig_Typ) then
1037 -- Detect a special case where interface class-wide types
1038 -- are involved as the object appears as:
1040 -- Tag_Ptr (Base_Address (<object>'Address))
1042 -- The expression already yields the proper tag, generate:
1046 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
1048 Make_Explicit_Dereference (Loc,
1049 Prefix => Relocate_Node (Temp));
1051 -- In the default case, obtain the tag of the object about
1052 -- to be allocated / deallocated. Generate:
1056 -- If the object is an unchecked conversion (typically to
1057 -- an access to class-wide type), we must preserve the
1058 -- conversion to ensure that the object is seen as tagged
1059 -- in the code that follows.
1064 if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion
1066 Pref := Parent (Pref);
1070 Make_Attribute_Reference (Loc,
1071 Prefix => Relocate_Node (Pref),
1072 Attribute_Name => Name_Tag);
1076 -- Needs_Finalization (<Param>)
1079 Make_Function_Call (Loc,
1081 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
1082 Parameter_Associations => New_List (Param));
1084 -- Processing for generic actuals
1086 elsif Is_Generic_Actual_Type (Desig_Typ) then
1088 New_Occurrence_Of (Boolean_Literals
1089 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
1091 -- The object does not require any specialized checks, it is
1092 -- known to be controlled.
1095 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
1098 -- Create the temporary which represents the finalization state
1099 -- of the expression. Generate:
1101 -- F : constant Boolean := <Flag_Expr>;
1104 Make_Object_Declaration (Loc,
1105 Defining_Identifier => Flag_Id,
1106 Constant_Present => True,
1107 Object_Definition =>
1108 New_Occurrence_Of (Standard_Boolean, Loc),
1109 Expression => Flag_Expr));
1111 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
1114 -- The object is not controlled
1117 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
1124 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
1127 -- Step 2: Build a wrapper Allocate / Deallocate which internally
1128 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
1130 -- Select the proper routine to call
1133 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
1135 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
1138 -- Create a custom Allocate / Deallocate routine which has identical
1139 -- profile to that of System.Storage_Pools.
1142 -- P : Root_Storage_Pool
1143 function Pool_Param return Node_Id is (
1144 Make_Parameter_Specification (Loc,
1145 Defining_Identifier => Make_Temporary (Loc, 'P'),
1147 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)));
1149 -- A : [out] Address
1150 function Address_Param return Node_Id is (
1151 Make_Parameter_Specification (Loc,
1152 Defining_Identifier => Addr_Id,
1153 Out_Present => Is_Allocate,
1155 New_Occurrence_Of (RTE (RE_Address), Loc)));
1157 -- S : Storage_Count
1158 function Size_Param return Node_Id is (
1159 Make_Parameter_Specification (Loc,
1160 Defining_Identifier => Size_Id,
1162 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
1164 -- L : Storage_Count
1165 function Alignment_Param return Node_Id is (
1166 Make_Parameter_Specification (Loc,
1167 Defining_Identifier => Alig_Id,
1169 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
1171 Formal_Params : List_Id;
1173 if Use_Secondary_Stack_Pool then
1174 -- Gigi expects a different profile in the Secondary_Stack_Pool
1175 -- case. There must be no uses of the two missing formals
1176 -- (i.e., Pool_Param and Alignment_Param) in this case.
1177 Formal_Params := New_List (Address_Param, Size_Param);
1179 Formal_Params := New_List (
1180 Pool_Param, Address_Param, Size_Param, Alignment_Param);
1184 Make_Subprogram_Body (Loc,
1187 Make_Procedure_Specification (Loc,
1188 Defining_Unit_Name => Proc_Id,
1189 Parameter_Specifications => Formal_Params),
1191 Declarations => No_List,
1193 Handled_Statement_Sequence =>
1194 Make_Handled_Sequence_Of_Statements (Loc,
1195 Statements => New_List (
1196 Make_Procedure_Call_Statement (Loc,
1198 New_Occurrence_Of (Proc_To_Call, Loc),
1199 Parameter_Associations => Actuals)))),
1200 Suppress => All_Checks);
1203 -- The newly generated Allocate / Deallocate becomes the default
1204 -- procedure to call when the back end processes the allocation /
1208 Set_Procedure_To_Call (Expr, Proc_Id);
1210 Set_Procedure_To_Call (N, Proc_Id);
1213 end Build_Allocate_Deallocate_Proc;
1215 -------------------------------
1216 -- Build_Abort_Undefer_Block --
1217 -------------------------------
1219 function Build_Abort_Undefer_Block
1222 Context : Node_Id) return Node_Id
1224 Exceptions_OK : constant Boolean :=
1225 not Restriction_Active (No_Exception_Propagation);
1233 -- The block should be generated only when undeferring abort in the
1234 -- context of a potential exception.
1236 pragma Assert (Abort_Allowed and Exceptions_OK);
1242 -- Abort_Undefer_Direct;
1245 AUD := RTE (RE_Abort_Undefer_Direct);
1248 Make_Handled_Sequence_Of_Statements (Loc,
1249 Statements => Stmts,
1250 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1253 Make_Block_Statement (Loc,
1254 Handled_Statement_Sequence => HSS);
1255 Set_Is_Abort_Block (Blk);
1257 Add_Block_Identifier (Blk, Blk_Id);
1258 Expand_At_End_Handler (HSS, Blk_Id);
1260 -- Present the Abort_Undefer_Direct function to the back end to inline
1261 -- the call to the routine.
1263 Add_Inlined_Body (AUD, Context);
1266 end Build_Abort_Undefer_Block;
1268 ---------------------------------
1269 -- Build_Class_Wide_Expression --
1270 ---------------------------------
1272 procedure Build_Class_Wide_Expression
1275 Par_Subp : Entity_Id;
1276 Adjust_Sloc : Boolean;
1277 Needs_Wrapper : out Boolean)
1279 function Replace_Entity (N : Node_Id) return Traverse_Result;
1280 -- Replace reference to formal of inherited operation or to primitive
1281 -- operation of root type, with corresponding entity for derived type,
1282 -- when constructing the class-wide condition of an overriding
1285 --------------------
1286 -- Replace_Entity --
1287 --------------------
1289 function Replace_Entity (N : Node_Id) return Traverse_Result is
1294 Adjust_Inherited_Pragma_Sloc (N);
1297 if Nkind (N) = N_Identifier
1298 and then Present (Entity (N))
1300 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
1302 (Nkind (Parent (N)) /= N_Attribute_Reference
1303 or else Attribute_Name (Parent (N)) /= Name_Class)
1305 -- The replacement does not apply to dispatching calls within the
1306 -- condition, but only to calls whose static tag is that of the
1309 if Is_Subprogram (Entity (N))
1310 and then Nkind (Parent (N)) = N_Function_Call
1311 and then Present (Controlling_Argument (Parent (N)))
1316 -- Determine whether entity has a renaming
1318 New_E := Type_Map.Get (Entity (N));
1320 if Present (New_E) then
1321 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
1323 -- AI12-0166: a precondition for a protected operation
1324 -- cannot include an internal call to a protected function
1325 -- of the type. In the case of an inherited condition for an
1326 -- overriding operation, both the operation and the function
1327 -- are given by primitive wrappers.
1328 -- Move this check to sem???
1330 if Ekind (New_E) = E_Function
1331 and then Is_Primitive_Wrapper (New_E)
1332 and then Is_Primitive_Wrapper (Subp)
1333 and then Scope (Subp) = Scope (New_E)
1334 and then Chars (Pragma_Identifier (Prag)) = Name_Precondition
1336 Error_Msg_Node_2 := Wrapped_Entity (Subp);
1338 ("internal call to& cannot appear in inherited "
1339 & "precondition of protected operation&",
1340 N, Wrapped_Entity (New_E));
1343 -- If the entity is an overridden primitive and we are not
1344 -- in GNATprove mode, we must build a wrapper for the current
1345 -- inherited operation. If the reference is the prefix of an
1346 -- attribute such as 'Result (or others ???) there is no need
1347 -- for a wrapper: the condition is just rewritten in terms of
1348 -- the inherited subprogram.
1350 if Is_Subprogram (New_E)
1351 and then Nkind (Parent (N)) /= N_Attribute_Reference
1352 and then not GNATprove_Mode
1354 Needs_Wrapper := True;
1358 -- Check that there are no calls left to abstract operations if
1359 -- the current subprogram is not abstract.
1360 -- Move this check to sem???
1362 if Nkind (Parent (N)) = N_Function_Call
1363 and then N = Name (Parent (N))
1365 if not Is_Abstract_Subprogram (Subp)
1366 and then Is_Abstract_Subprogram (Entity (N))
1368 Error_Msg_Sloc := Sloc (Current_Scope);
1369 Error_Msg_Node_2 := Subp;
1370 if Comes_From_Source (Subp) then
1372 ("cannot call abstract subprogram & in inherited "
1373 & "condition for&#", Subp, Entity (N));
1376 ("cannot call abstract subprogram & in inherited "
1377 & "condition for inherited&#", Subp, Entity (N));
1380 -- In SPARK mode, reject an inherited condition for an
1381 -- inherited operation if it contains a call to an overriding
1382 -- operation, because this implies that the pre/postconditions
1383 -- of the inherited operation have changed silently.
1385 elsif SPARK_Mode = On
1386 and then Warn_On_Suspicious_Contract
1387 and then Present (Alias (Subp))
1388 and then Present (New_E)
1389 and then Comes_From_Source (New_E)
1392 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
1394 Error_Msg_Sloc := Sloc (New_E);
1395 Error_Msg_Node_2 := Subp;
1397 ("\overriding of&# forces overriding of&",
1398 Parent (Subp), New_E);
1402 -- Update type of function call node, which should be the same as
1403 -- the function's return type.
1405 if Is_Subprogram (Entity (N))
1406 and then Nkind (Parent (N)) = N_Function_Call
1408 Set_Etype (Parent (N), Etype (Entity (N)));
1411 -- The whole expression will be reanalyzed
1413 elsif Nkind (N) in N_Has_Etype then
1414 Set_Analyzed (N, False);
1420 procedure Replace_Condition_Entities is
1421 new Traverse_Proc (Replace_Entity);
1425 Par_Formal : Entity_Id;
1426 Subp_Formal : Entity_Id;
1428 -- Start of processing for Build_Class_Wide_Expression
1431 Needs_Wrapper := False;
1433 -- Add mapping from old formals to new formals
1435 Par_Formal := First_Formal (Par_Subp);
1436 Subp_Formal := First_Formal (Subp);
1438 while Present (Par_Formal) and then Present (Subp_Formal) loop
1439 Type_Map.Set (Par_Formal, Subp_Formal);
1440 Next_Formal (Par_Formal);
1441 Next_Formal (Subp_Formal);
1444 Replace_Condition_Entities (Prag);
1445 end Build_Class_Wide_Expression;
1447 --------------------
1448 -- Build_DIC_Call --
1449 --------------------
1451 function Build_DIC_Call
1454 Typ : Entity_Id) return Node_Id
1456 Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
1457 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1460 -- The DIC procedure has a null body if assertions are disabled or
1461 -- Assertion_Policy Ignore is in effect. In that case, it would be
1462 -- nice to generate a null statement instead of a call to the DIC
1463 -- procedure, but doing that seems to interfere with the determination
1464 -- of ECRs (early call regions) in SPARK. ???
1467 Make_Procedure_Call_Statement (Loc,
1468 Name => New_Occurrence_Of (Proc_Id, Loc),
1469 Parameter_Associations => New_List (
1470 Unchecked_Convert_To (Formal_Typ, Obj_Name)));
1473 ------------------------------
1474 -- Build_DIC_Procedure_Body --
1475 ------------------------------
1477 -- WARNING: This routine manages Ghost regions. Return statements must be
1478 -- replaced by gotos which jump to the end of the routine and restore the
1481 procedure Build_DIC_Procedure_Body
1483 Partial_DIC : Boolean := False)
1485 Pragmas_Seen : Elist_Id := No_Elist;
1486 -- This list contains all DIC pragmas processed so far. The list is used
1487 -- to avoid redundant Default_Initial_Condition checks.
1489 procedure Add_DIC_Check
1490 (DIC_Prag : Node_Id;
1492 Stmts : in out List_Id);
1493 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1494 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1495 -- is added to list Stmts.
1497 procedure Add_Inherited_DIC
1498 (DIC_Prag : Node_Id;
1499 Par_Typ : Entity_Id;
1500 Deriv_Typ : Entity_Id;
1501 Stmts : in out List_Id);
1502 -- Add a runtime check to verify the assertion expression of inherited
1503 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1504 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1505 -- pragma. All generated code is added to list Stmts.
1507 procedure Add_Inherited_Tagged_DIC
1508 (DIC_Prag : Node_Id;
1510 Stmts : in out List_Id);
1511 -- Add a runtime check to verify assertion expression DIC_Expr of
1512 -- inherited pragma DIC_Prag. This routine applies class-wide pre-
1513 -- and postcondition-like runtime semantics to the check. Expr is
1514 -- the assertion expression after substitition has been performed
1515 -- (via Replace_References). All generated code is added to list Stmts.
1517 procedure Add_Inherited_DICs
1519 Priv_Typ : Entity_Id;
1520 Full_Typ : Entity_Id;
1522 Checks : in out List_Id);
1523 -- Generate a DIC check for each inherited Default_Initial_Condition
1524 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
1525 -- the partial and full view of the parent type. Obj_Id denotes the
1526 -- entity of the _object formal parameter of the DIC procedure. All
1527 -- created checks are added to list Checks.
1529 procedure Add_Own_DIC
1530 (DIC_Prag : Node_Id;
1531 DIC_Typ : Entity_Id;
1533 Stmts : in out List_Id);
1534 -- Add a runtime check to verify the assertion expression of pragma
1535 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. Obj_Id is the
1536 -- object to substitute in the assertion expression for any references
1537 -- to the current instance of the type All generated code is added to
1540 procedure Add_Parent_DICs
1543 Checks : in out List_Id);
1544 -- Generate a Default_Initial_Condition check for each inherited DIC
1545 -- aspect coming from all parent types of type T. Obj_Id denotes the
1546 -- entity of the _object formal parameter of the DIC procedure. All
1547 -- created checks are added to list Checks.
1553 procedure Add_DIC_Check
1554 (DIC_Prag : Node_Id;
1556 Stmts : in out List_Id)
1558 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1559 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1562 -- The DIC pragma is ignored, nothing left to do
1564 if Is_Ignored (DIC_Prag) then
1567 -- Otherwise the DIC expression must be checked at run time.
1570 -- pragma Check (<Nam>, <DIC_Expr>);
1573 Append_New_To (Stmts,
1575 Pragma_Identifier =>
1576 Make_Identifier (Loc, Name_Check),
1578 Pragma_Argument_Associations => New_List (
1579 Make_Pragma_Argument_Association (Loc,
1580 Expression => Make_Identifier (Loc, Nam)),
1582 Make_Pragma_Argument_Association (Loc,
1583 Expression => DIC_Expr))));
1586 -- Add the pragma to the list of processed pragmas
1588 Append_New_Elmt (DIC_Prag, Pragmas_Seen);
1591 -----------------------
1592 -- Add_Inherited_DIC --
1593 -----------------------
1595 procedure Add_Inherited_DIC
1596 (DIC_Prag : Node_Id;
1597 Par_Typ : Entity_Id;
1598 Deriv_Typ : Entity_Id;
1599 Stmts : in out List_Id)
1601 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1602 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1603 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1604 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1605 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1608 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1610 -- Verify the inherited DIC assertion expression by calling the DIC
1611 -- procedure of the parent type.
1614 -- <Par_Typ>DIC (Par_Typ (_object));
1616 Append_New_To (Stmts,
1617 Make_Procedure_Call_Statement (Loc,
1618 Name => New_Occurrence_Of (Par_Proc, Loc),
1619 Parameter_Associations => New_List (
1621 (Typ => Etype (Par_Obj),
1622 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1623 end Add_Inherited_DIC;
1625 ------------------------------
1626 -- Add_Inherited_Tagged_DIC --
1627 ------------------------------
1629 procedure Add_Inherited_Tagged_DIC
1630 (DIC_Prag : Node_Id;
1632 Stmts : in out List_Id)
1635 -- Once the DIC assertion expression is fully processed, add a check
1636 -- to the statements of the DIC procedure.
1639 (DIC_Prag => DIC_Prag,
1642 end Add_Inherited_Tagged_DIC;
1644 ------------------------
1645 -- Add_Inherited_DICs --
1646 ------------------------
1648 procedure Add_Inherited_DICs
1650 Priv_Typ : Entity_Id;
1651 Full_Typ : Entity_Id;
1653 Checks : in out List_Id)
1655 Deriv_Typ : Entity_Id;
1658 Prag_Expr : Node_Id;
1659 Prag_Expr_Arg : Node_Id;
1661 Prag_Typ_Arg : Node_Id;
1663 Par_Proc : Entity_Id;
1664 -- The "partial" invariant procedure of Par_Typ
1666 Par_Typ : Entity_Id;
1667 -- The suitable view of the parent type used in the substitution of
1671 if not Present (Priv_Typ) and then not Present (Full_Typ) then
1675 -- When the type inheriting the class-wide invariant is a concurrent
1676 -- type, use the corresponding record type because it contains all
1677 -- primitive operations of the concurrent type and allows for proper
1680 if Is_Concurrent_Type (T) then
1681 Deriv_Typ := Corresponding_Record_Type (T);
1686 pragma Assert (Present (Deriv_Typ));
1688 -- Determine which rep item chain to use. Precedence is given to that
1689 -- of the parent type's partial view since it usually carries all the
1690 -- class-wide invariants.
1692 if Present (Priv_Typ) then
1693 Prag := First_Rep_Item (Priv_Typ);
1695 Prag := First_Rep_Item (Full_Typ);
1698 while Present (Prag) loop
1699 if Nkind (Prag) = N_Pragma
1700 and then Pragma_Name (Prag) = Name_Default_Initial_Condition
1702 -- Nothing to do if the pragma was already processed
1704 if Contains (Pragmas_Seen, Prag) then
1708 -- Extract arguments of the Default_Initial_Condition pragma
1710 Prag_Expr_Arg := First (Pragma_Argument_Associations (Prag));
1711 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
1713 -- Pick up the implicit second argument of the pragma, which
1714 -- indicates the type that the pragma applies to.
1716 Prag_Typ_Arg := Next (Prag_Expr_Arg);
1717 if Present (Prag_Typ_Arg) then
1718 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
1723 -- The pragma applies to the partial view of the parent type
1725 if Present (Priv_Typ)
1726 and then Present (Prag_Typ)
1727 and then Entity (Prag_Typ) = Priv_Typ
1729 Par_Typ := Priv_Typ;
1731 -- The pragma applies to the full view of the parent type
1733 elsif Present (Full_Typ)
1734 and then Present (Prag_Typ)
1735 and then Entity (Prag_Typ) = Full_Typ
1737 Par_Typ := Full_Typ;
1739 -- Otherwise the pragma does not belong to the parent type and
1740 -- should not be considered.
1746 -- Substitute references in the DIC expression that are related
1747 -- to the partial type with corresponding references related to
1748 -- the derived type (call to Replace_References below).
1750 Expr := New_Copy_Tree (Prag_Expr);
1752 Par_Proc := Partial_DIC_Procedure (Par_Typ);
1754 -- If there's not a partial DIC procedure (such as when a
1755 -- full type doesn't have its own DIC, but is inherited from
1756 -- a type with DIC), get the full DIC procedure.
1758 if not Present (Par_Proc) then
1759 Par_Proc := DIC_Procedure (Par_Typ);
1765 Deriv_Typ => Deriv_Typ,
1766 Par_Obj => First_Formal (Par_Proc),
1767 Deriv_Obj => Obj_Id);
1769 -- Why are there different actions depending on whether T is
1770 -- tagged? Can these be unified? ???
1772 if Is_Tagged_Type (T) then
1773 Add_Inherited_Tagged_DIC
1782 Deriv_Typ => Deriv_Typ,
1786 -- Leave as soon as we get a DIC pragma, since we'll visit
1787 -- the pragmas of the parents, so will get to any "inherited"
1788 -- pragmas that way.
1793 Next_Rep_Item (Prag);
1795 end Add_Inherited_DICs;
1801 procedure Add_Own_DIC
1802 (DIC_Prag : Node_Id;
1803 DIC_Typ : Entity_Id;
1805 Stmts : in out List_Id)
1807 DIC_Args : constant List_Id :=
1808 Pragma_Argument_Associations (DIC_Prag);
1809 DIC_Arg : constant Node_Id := First (DIC_Args);
1810 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1811 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1815 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1819 -- Start of processing for Add_Own_DIC
1822 pragma Assert (Present (DIC_Expr));
1823 Expr := New_Copy_Tree (DIC_Expr);
1825 -- Perform the following substitution:
1827 -- * Replace the current instance of DIC_Typ with a reference to
1828 -- the _object formal parameter of the DIC procedure.
1830 Replace_Type_References
1835 -- Preanalyze the DIC expression to detect errors and at the same
1836 -- time capture the visibility of the proper package part.
1838 Set_Parent (Expr, Typ_Decl);
1839 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1841 -- Save a copy of the expression with all replacements and analysis
1842 -- already taken place in case a derived type inherits the pragma.
1843 -- The copy will be used as the foundation of the derived type's own
1844 -- version of the DIC assertion expression.
1846 if Is_Tagged_Type (DIC_Typ) then
1847 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1850 -- If the pragma comes from an aspect specification, replace the
1851 -- saved expression because all type references must be substituted
1852 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1855 if Present (DIC_Asp) then
1856 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1859 -- Once the DIC assertion expression is fully processed, add a check
1860 -- to the statements of the DIC procedure (unless the type is an
1861 -- abstract type, in which case we don't want the possibility of
1862 -- generating a call to an abstract function of the type; such DIC
1863 -- procedures can never be called in any case, so not generating the
1864 -- check at all is OK).
1866 if not Is_Abstract_Type (DIC_Typ) or else GNATprove_Mode then
1868 (DIC_Prag => DIC_Prag,
1874 ---------------------
1875 -- Add_Parent_DICs --
1876 ---------------------
1878 procedure Add_Parent_DICs
1881 Checks : in out List_Id)
1883 Dummy_1 : Entity_Id;
1884 Dummy_2 : Entity_Id;
1886 Curr_Typ : Entity_Id;
1887 -- The entity of the current type being examined
1889 Full_Typ : Entity_Id;
1890 -- The full view of Par_Typ
1892 Par_Typ : Entity_Id;
1893 -- The entity of the parent type
1895 Priv_Typ : Entity_Id;
1896 -- The partial view of Par_Typ
1899 -- Climb the parent type chain
1903 -- Do not consider subtypes, as they inherit the DICs from their
1906 Par_Typ := Base_Type (Etype (Base_Type (Curr_Typ)));
1908 -- Stop the climb once the root of the parent chain is
1911 exit when Curr_Typ = Par_Typ;
1913 -- Process the DICs of the parent type
1915 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
1917 -- Only try to inherit a DIC pragma from the parent type Par_Typ
1918 -- if it Has_Own_DIC pragma. The loop will proceed up the parent
1919 -- chain to find all types that have their own DIC.
1921 if Has_Own_DIC (Par_Typ) then
1924 Priv_Typ => Priv_Typ,
1925 Full_Typ => Full_Typ,
1930 Curr_Typ := Par_Typ;
1932 end Add_Parent_DICs;
1936 Loc : constant Source_Ptr := Sloc (Typ);
1938 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1939 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1940 -- Save the Ghost-related attributes to restore on exit
1943 DIC_Typ : Entity_Id;
1944 Dummy_1 : Entity_Id;
1945 Dummy_2 : Entity_Id;
1946 Proc_Body : Node_Id;
1947 Proc_Body_Id : Entity_Id;
1948 Proc_Decl : Node_Id;
1949 Proc_Id : Entity_Id;
1950 Stmts : List_Id := No_List;
1952 CRec_Typ : Entity_Id := Empty;
1953 -- The corresponding record type of Full_Typ
1955 Full_Typ : Entity_Id := Empty;
1956 -- The full view of the working type
1958 Obj_Id : Entity_Id := Empty;
1959 -- The _object formal parameter of the invariant procedure
1961 Part_Proc : Entity_Id := Empty;
1962 -- The entity of the "partial" invariant procedure
1964 Priv_Typ : Entity_Id := Empty;
1965 -- The partial view of the working type
1967 Work_Typ : Entity_Id;
1970 -- Start of processing for Build_DIC_Procedure_Body
1973 Work_Typ := Base_Type (Typ);
1975 -- Do not process class-wide types as these are Itypes, but lack a first
1976 -- subtype (see below).
1978 if Is_Class_Wide_Type (Work_Typ) then
1981 -- Do not process the underlying full view of a private type. There is
1982 -- no way to get back to the partial view, plus the body will be built
1983 -- by the full view or the base type.
1985 elsif Is_Underlying_Full_View (Work_Typ) then
1988 -- Use the first subtype when dealing with various base types
1990 elsif Is_Itype (Work_Typ) then
1991 Work_Typ := First_Subtype (Work_Typ);
1993 -- The input denotes the corresponding record type of a protected or a
1994 -- task type. Work with the concurrent type because the corresponding
1995 -- record type may not be visible to clients of the type.
1997 elsif Ekind (Work_Typ) = E_Record_Type
1998 and then Is_Concurrent_Record_Type (Work_Typ)
2000 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2003 -- The working type may be subject to pragma Ghost. Set the mode now to
2004 -- ensure that the DIC procedure is properly marked as Ghost.
2006 Set_Ghost_Mode (Work_Typ);
2008 -- The working type must be either define a DIC pragma of its own or
2009 -- inherit one from a parent type.
2011 pragma Assert (Has_DIC (Work_Typ));
2013 -- Recover the type which defines the DIC pragma. This is either the
2014 -- working type itself or a parent type when the pragma is inherited.
2016 DIC_Typ := Find_DIC_Type (Work_Typ);
2017 pragma Assert (Present (DIC_Typ));
2019 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2020 pragma Assert (Present (DIC_Prag));
2022 -- Nothing to do if pragma DIC appears without an argument or its sole
2023 -- argument is "null".
2025 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2029 -- Obtain both views of the type
2031 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ);
2033 -- The caller requests a body for the partial DIC procedure
2036 Proc_Id := Partial_DIC_Procedure (Work_Typ);
2038 -- The "full" DIC procedure body was already created
2040 -- Create a declaration for the "partial" DIC procedure if it
2041 -- is not available.
2043 if No (Proc_Id) then
2044 Build_DIC_Procedure_Declaration
2046 Partial_DIC => True);
2048 Proc_Id := Partial_DIC_Procedure (Work_Typ);
2051 -- The caller requests a body for the "full" DIC procedure
2054 Proc_Id := DIC_Procedure (Work_Typ);
2055 Part_Proc := Partial_DIC_Procedure (Work_Typ);
2057 -- Create a declaration for the "full" DIC procedure if it is
2060 if No (Proc_Id) then
2061 Build_DIC_Procedure_Declaration (Work_Typ);
2062 Proc_Id := DIC_Procedure (Work_Typ);
2066 -- At this point there should be a DIC procedure declaration
2068 pragma Assert (Present (Proc_Id));
2069 Proc_Decl := Unit_Declaration_Node (Proc_Id);
2071 -- Nothing to do if the DIC procedure already has a body
2073 if Present (Corresponding_Body (Proc_Decl)) then
2077 -- Emulate the environment of the DIC procedure by installing its scope
2078 -- and formal parameters.
2080 Push_Scope (Proc_Id);
2081 Install_Formals (Proc_Id);
2083 Obj_Id := First_Formal (Proc_Id);
2084 pragma Assert (Present (Obj_Id));
2086 -- The "partial" DIC procedure verifies the DICs of the partial view
2090 pragma Assert (Present (Priv_Typ));
2092 if Has_Own_DIC (Work_Typ) then -- If we're testing this then maybe
2093 Add_Own_DIC -- we shouldn't be calling Find_DIC_Typ above???
2094 (DIC_Prag => DIC_Prag,
2095 DIC_Typ => DIC_Typ, -- Should this just be Work_Typ???
2100 -- Otherwise the "full" DIC procedure verifies the DICs of the full
2101 -- view, well as DICs inherited from parent types. In addition, it
2102 -- indirectly verifies the DICs of the partial view by calling the
2103 -- "partial" DIC procedure.
2106 pragma Assert (Present (Full_Typ));
2108 -- Check the DIC of the partial view by calling the "partial" DIC
2109 -- procedure, unless the partial DIC body is empty. Generate:
2111 -- <Work_Typ>Partial_DIC (_object);
2113 if Present (Part_Proc) and then not Has_Null_Body (Part_Proc) then
2114 Append_New_To (Stmts,
2115 Make_Procedure_Call_Statement (Loc,
2116 Name => New_Occurrence_Of (Part_Proc, Loc),
2117 Parameter_Associations => New_List (
2118 New_Occurrence_Of (Obj_Id, Loc))));
2121 -- Derived subtypes do not have a partial view
2123 if Present (Priv_Typ) then
2125 -- The processing of the "full" DIC procedure intentionally
2126 -- skips the partial view because a) this may result in changes of
2127 -- visibility and b) lead to duplicate checks. However, when the
2128 -- full view is the underlying full view of an untagged derived
2129 -- type whose parent type is private, partial DICs appear on
2130 -- the rep item chain of the partial view only.
2132 -- package Pack_1 is
2133 -- type Root ... is private;
2135 -- <full view of Root>
2139 -- package Pack_2 is
2140 -- type Child is new Pack_1.Root with Type_DIC => ...;
2141 -- <underlying full view of Child>
2144 -- As a result, the processing of the full view must also consider
2145 -- all DICs of the partial view.
2147 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
2150 -- Otherwise the DICs of the partial view are ignored
2153 -- Ignore the DICs of the partial view by eliminating the view
2159 -- Process inherited Default_Initial_Conditions for all parent types
2161 Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
2166 -- Produce an empty completing body in the following cases:
2167 -- * Assertions are disabled
2168 -- * The DIC Assertion_Policy is Ignore
2171 Stmts := New_List (Make_Null_Statement (Loc));
2175 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
2178 -- end <Work_Typ>DIC;
2181 Make_Subprogram_Body (Loc,
2183 Copy_Subprogram_Spec (Parent (Proc_Id)),
2184 Declarations => Empty_List,
2185 Handled_Statement_Sequence =>
2186 Make_Handled_Sequence_Of_Statements (Loc,
2187 Statements => Stmts));
2188 Proc_Body_Id := Defining_Entity (Proc_Body);
2190 -- Perform minor decoration in case the body is not analyzed
2192 Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
2193 Set_Etype (Proc_Body_Id, Standard_Void_Type);
2194 Set_Scope (Proc_Body_Id, Current_Scope);
2195 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
2196 Set_SPARK_Pragma_Inherited
2197 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
2199 -- Link both spec and body to avoid generating duplicates
2201 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
2202 Set_Corresponding_Spec (Proc_Body, Proc_Id);
2204 -- The body should not be inserted into the tree when the context
2205 -- is a generic unit because it is not part of the template.
2206 -- Note that the body must still be generated in order to resolve the
2207 -- DIC assertion expression.
2209 if Inside_A_Generic then
2212 -- Semi-insert the body into the tree for GNATprove by setting its
2213 -- Parent field. This allows for proper upstream tree traversals.
2215 elsif GNATprove_Mode then
2216 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
2218 -- Otherwise the body is part of the freezing actions of the working
2222 Append_Freeze_Action (Work_Typ, Proc_Body);
2226 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2227 end Build_DIC_Procedure_Body;
2229 -------------------------------------
2230 -- Build_DIC_Procedure_Declaration --
2231 -------------------------------------
2233 -- WARNING: This routine manages Ghost regions. Return statements must be
2234 -- replaced by gotos which jump to the end of the routine and restore the
2237 procedure Build_DIC_Procedure_Declaration
2239 Partial_DIC : Boolean := False)
2241 Loc : constant Source_Ptr := Sloc (Typ);
2243 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2244 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2245 -- Save the Ghost-related attributes to restore on exit
2248 DIC_Typ : Entity_Id;
2249 Proc_Decl : Node_Id;
2250 Proc_Id : Entity_Id;
2254 CRec_Typ : Entity_Id;
2255 -- The corresponding record type of Full_Typ
2257 Full_Typ : Entity_Id;
2258 -- The full view of working type
2261 -- The _object formal parameter of the DIC procedure
2263 Priv_Typ : Entity_Id;
2264 -- The partial view of working type
2266 UFull_Typ : Entity_Id;
2267 -- The underlying full view of Full_Typ
2269 Work_Typ : Entity_Id;
2273 Work_Typ := Base_Type (Typ);
2275 -- Do not process class-wide types as these are Itypes, but lack a first
2276 -- subtype (see below).
2278 if Is_Class_Wide_Type (Work_Typ) then
2281 -- Do not process the underlying full view of a private type. There is
2282 -- no way to get back to the partial view, plus the body will be built
2283 -- by the full view or the base type.
2285 elsif Is_Underlying_Full_View (Work_Typ) then
2288 -- Use the first subtype when dealing with various base types
2290 elsif Is_Itype (Work_Typ) then
2291 Work_Typ := First_Subtype (Work_Typ);
2293 -- The input denotes the corresponding record type of a protected or a
2294 -- task type. Work with the concurrent type because the corresponding
2295 -- record type may not be visible to clients of the type.
2297 elsif Ekind (Work_Typ) = E_Record_Type
2298 and then Is_Concurrent_Record_Type (Work_Typ)
2300 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2303 -- The working type may be subject to pragma Ghost. Set the mode now to
2304 -- ensure that the DIC procedure is properly marked as Ghost.
2306 Set_Ghost_Mode (Work_Typ);
2308 -- The type must be either subject to a DIC pragma or inherit one from a
2311 pragma Assert (Has_DIC (Work_Typ));
2313 -- Recover the type which defines the DIC pragma. This is either the
2314 -- working type itself or a parent type when the pragma is inherited.
2316 DIC_Typ := Find_DIC_Type (Work_Typ);
2317 pragma Assert (Present (DIC_Typ));
2319 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2320 pragma Assert (Present (DIC_Prag));
2322 -- Nothing to do if pragma DIC appears without an argument or its sole
2323 -- argument is "null".
2325 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2329 -- Nothing to do if the type already has a "partial" DIC procedure
2332 if Present (Partial_DIC_Procedure (Work_Typ)) then
2336 -- Nothing to do if the type already has a "full" DIC procedure
2338 elsif Present (DIC_Procedure (Work_Typ)) then
2342 -- The caller requests the declaration of the "partial" DIC procedure
2345 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_DIC");
2347 -- Otherwise the caller requests the declaration of the "full" DIC
2351 Proc_Nam := New_External_Name (Chars (Work_Typ), "DIC");
2355 Make_Defining_Identifier (Loc, Chars => Proc_Nam);
2357 -- Perform minor decoration in case the declaration is not analyzed
2359 Mutate_Ekind (Proc_Id, E_Procedure);
2360 Set_Etype (Proc_Id, Standard_Void_Type);
2361 Set_Is_DIC_Procedure (Proc_Id);
2362 Set_Scope (Proc_Id, Current_Scope);
2363 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
2364 Set_SPARK_Pragma_Inherited (Proc_Id);
2366 Set_DIC_Procedure (Work_Typ, Proc_Id);
2368 -- The DIC procedure requires debug info when the assertion expression
2369 -- is subject to Source Coverage Obligations.
2371 if Generate_SCO then
2372 Set_Debug_Info_Needed (Proc_Id);
2375 -- Obtain all views of the input type
2377 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
2379 -- Associate the DIC procedure and various flags with all views
2381 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
2382 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
2383 Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ);
2384 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
2386 -- The declaration of the DIC procedure must be inserted after the
2387 -- declaration of the partial view as this allows for proper external
2390 if Present (Priv_Typ) then
2391 Typ_Decl := Declaration_Node (Priv_Typ);
2393 -- Derived types with the full view as parent do not have a partial
2394 -- view. Insert the DIC procedure after the derived type.
2397 Typ_Decl := Declaration_Node (Full_Typ);
2400 -- The type should have a declarative node
2402 pragma Assert (Present (Typ_Decl));
2404 -- Create the formal parameter which emulates the variable-like behavior
2405 -- of the type's current instance.
2407 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
2409 -- Perform minor decoration in case the declaration is not analyzed
2411 Mutate_Ekind (Obj_Id, E_In_Parameter);
2412 Set_Etype (Obj_Id, Work_Typ);
2413 Set_Scope (Obj_Id, Proc_Id);
2415 Set_First_Entity (Proc_Id, Obj_Id);
2416 Set_Last_Entity (Proc_Id, Obj_Id);
2419 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2422 Make_Subprogram_Declaration (Loc,
2424 Make_Procedure_Specification (Loc,
2425 Defining_Unit_Name => Proc_Id,
2426 Parameter_Specifications => New_List (
2427 Make_Parameter_Specification (Loc,
2428 Defining_Identifier => Obj_Id,
2430 New_Occurrence_Of (Work_Typ, Loc)))));
2432 -- The declaration should not be inserted into the tree when the context
2433 -- is a generic unit because it is not part of the template.
2435 if Inside_A_Generic then
2438 -- Semi-insert the declaration into the tree for GNATprove by setting
2439 -- its Parent field. This allows for proper upstream tree traversals.
2441 elsif GNATprove_Mode then
2442 Set_Parent (Proc_Decl, Parent (Typ_Decl));
2444 -- Otherwise insert the declaration
2447 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
2451 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2452 end Build_DIC_Procedure_Declaration;
2454 ------------------------------------
2455 -- Build_Invariant_Procedure_Body --
2456 ------------------------------------
2458 -- WARNING: This routine manages Ghost regions. Return statements must be
2459 -- replaced by gotos which jump to the end of the routine and restore the
2462 procedure Build_Invariant_Procedure_Body
2464 Partial_Invariant : Boolean := False)
2466 Loc : constant Source_Ptr := Sloc (Typ);
2468 Pragmas_Seen : Elist_Id := No_Elist;
2469 -- This list contains all invariant pragmas processed so far. The list
2470 -- is used to avoid generating redundant invariant checks.
2472 Produced_Check : Boolean := False;
2473 -- This flag tracks whether the type has produced at least one invariant
2474 -- check. The flag is used as a sanity check at the end of the routine.
2476 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2477 -- intentionally unnested to avoid deep indentation of code.
2479 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2480 -- they emit checks, loops (for arrays) and case statements (for record
2481 -- variant parts) only when there are invariants to verify. This keeps
2482 -- the body of the invariant procedure free of useless code.
2484 procedure Add_Array_Component_Invariants
2487 Checks : in out List_Id);
2488 -- Generate an invariant check for each component of array type T.
2489 -- Obj_Id denotes the entity of the _object formal parameter of the
2490 -- invariant procedure. All created checks are added to list Checks.
2492 procedure Add_Inherited_Invariants
2494 Priv_Typ : Entity_Id;
2495 Full_Typ : Entity_Id;
2497 Checks : in out List_Id);
2498 -- Generate an invariant check for each inherited class-wide invariant
2499 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2500 -- the partial and full view of the parent type. Obj_Id denotes the
2501 -- entity of the _object formal parameter of the invariant procedure.
2502 -- All created checks are added to list Checks.
2504 procedure Add_Interface_Invariants
2507 Checks : in out List_Id);
2508 -- Generate an invariant check for each inherited class-wide invariant
2509 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2510 -- entity of the _object formal parameter of the invariant procedure.
2511 -- All created checks are added to list Checks.
2513 procedure Add_Invariant_Check
2516 Checks : in out List_Id;
2517 Inherited : Boolean := False);
2518 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2519 -- verify assertion expression Expr of pragma Prag. All generated code
2520 -- is added to list Checks. Flag Inherited should be set when the pragma
2521 -- is inherited from a parent or interface type.
2523 procedure Add_Own_Invariants
2526 Checks : in out List_Id;
2527 Priv_Item : Node_Id := Empty);
2528 -- Generate an invariant check for each invariant found for type T.
2529 -- Obj_Id denotes the entity of the _object formal parameter of the
2530 -- invariant procedure. All created checks are added to list Checks.
2531 -- Priv_Item denotes the first rep item of the private type.
2533 procedure Add_Parent_Invariants
2536 Checks : in out List_Id);
2537 -- Generate an invariant check for each inherited class-wide invariant
2538 -- coming from all parent types of type T. Obj_Id denotes the entity of
2539 -- the _object formal parameter of the invariant procedure. All created
2540 -- checks are added to list Checks.
2542 procedure Add_Record_Component_Invariants
2545 Checks : in out List_Id);
2546 -- Generate an invariant check for each component of record type T.
2547 -- Obj_Id denotes the entity of the _object formal parameter of the
2548 -- invariant procedure. All created checks are added to list Checks.
2550 ------------------------------------
2551 -- Add_Array_Component_Invariants --
2552 ------------------------------------
2554 procedure Add_Array_Component_Invariants
2557 Checks : in out List_Id)
2559 Comp_Typ : constant Entity_Id := Component_Type (T);
2560 Dims : constant Pos := Number_Dimensions (T);
2562 procedure Process_Array_Component
2564 Comp_Checks : in out List_Id);
2565 -- Generate an invariant check for an array component identified by
2566 -- the indices in list Indices. All created checks are added to list
2569 procedure Process_One_Dimension
2572 Dim_Checks : in out List_Id);
2573 -- Generate a loop over the Nth dimension Dim of an array type. List
2574 -- Indices contains all array indices for the dimension. All created
2575 -- checks are added to list Dim_Checks.
2577 -----------------------------
2578 -- Process_Array_Component --
2579 -----------------------------
2581 procedure Process_Array_Component
2583 Comp_Checks : in out List_Id)
2585 Proc_Id : Entity_Id;
2588 if Has_Invariants (Comp_Typ) then
2590 -- In GNATprove mode, the component invariants are checked by
2591 -- other means. They should not be added to the array type
2592 -- invariant procedure, so that the procedure can be used to
2593 -- check the array type invariants if any.
2595 if GNATprove_Mode then
2599 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2601 -- The component type should have an invariant procedure
2602 -- if it has invariants of its own or inherits class-wide
2603 -- invariants from parent or interface types.
2605 pragma Assert (Present (Proc_Id));
2608 -- <Comp_Typ>Invariant (_object (<Indices>));
2610 -- The invariant procedure has a null body if assertions are
2611 -- disabled or Assertion_Policy Ignore is in effect.
2613 if not Has_Null_Body (Proc_Id) then
2614 Append_New_To (Comp_Checks,
2615 Make_Procedure_Call_Statement (Loc,
2617 New_Occurrence_Of (Proc_Id, Loc),
2618 Parameter_Associations => New_List (
2619 Make_Indexed_Component (Loc,
2620 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2621 Expressions => New_Copy_List (Indices)))));
2625 Produced_Check := True;
2627 end Process_Array_Component;
2629 ---------------------------
2630 -- Process_One_Dimension --
2631 ---------------------------
2633 procedure Process_One_Dimension
2636 Dim_Checks : in out List_Id)
2638 Comp_Checks : List_Id := No_List;
2642 -- Generate the invariant checks for the array component after all
2643 -- dimensions have produced their respective loops.
2646 Process_Array_Component
2647 (Indices => Indices,
2648 Comp_Checks => Dim_Checks);
2650 -- Otherwise create a loop for the current dimension
2653 -- Create a new loop variable for each dimension
2656 Make_Defining_Identifier (Loc,
2657 Chars => New_External_Name ('I', Dim));
2658 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2660 Process_One_Dimension
2663 Dim_Checks => Comp_Checks);
2666 -- for I<Dim> in _object'Range (<Dim>) loop
2670 -- Note that the invariant procedure may have a null body if
2671 -- assertions are disabled or Assertion_Policy Ignore is in
2674 if Present (Comp_Checks) then
2675 Append_New_To (Dim_Checks,
2676 Make_Implicit_Loop_Statement (T,
2677 Identifier => Empty,
2679 Make_Iteration_Scheme (Loc,
2680 Loop_Parameter_Specification =>
2681 Make_Loop_Parameter_Specification (Loc,
2682 Defining_Identifier => Index,
2683 Discrete_Subtype_Definition =>
2684 Make_Attribute_Reference (Loc,
2686 New_Occurrence_Of (Obj_Id, Loc),
2687 Attribute_Name => Name_Range,
2688 Expressions => New_List (
2689 Make_Integer_Literal (Loc, Dim))))),
2690 Statements => Comp_Checks));
2693 end Process_One_Dimension;
2695 -- Start of processing for Add_Array_Component_Invariants
2698 Process_One_Dimension
2700 Indices => New_List,
2701 Dim_Checks => Checks);
2702 end Add_Array_Component_Invariants;
2704 ------------------------------
2705 -- Add_Inherited_Invariants --
2706 ------------------------------
2708 procedure Add_Inherited_Invariants
2710 Priv_Typ : Entity_Id;
2711 Full_Typ : Entity_Id;
2713 Checks : in out List_Id)
2715 Deriv_Typ : Entity_Id;
2718 Prag_Expr : Node_Id;
2719 Prag_Expr_Arg : Node_Id;
2721 Prag_Typ_Arg : Node_Id;
2723 Par_Proc : Entity_Id;
2724 -- The "partial" invariant procedure of Par_Typ
2726 Par_Typ : Entity_Id;
2727 -- The suitable view of the parent type used in the substitution of
2731 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2735 -- When the type inheriting the class-wide invariant is a concurrent
2736 -- type, use the corresponding record type because it contains all
2737 -- primitive operations of the concurrent type and allows for proper
2740 if Is_Concurrent_Type (T) then
2741 Deriv_Typ := Corresponding_Record_Type (T);
2746 pragma Assert (Present (Deriv_Typ));
2748 -- Determine which rep item chain to use. Precedence is given to that
2749 -- of the parent type's partial view since it usually carries all the
2750 -- class-wide invariants.
2752 if Present (Priv_Typ) then
2753 Prag := First_Rep_Item (Priv_Typ);
2755 Prag := First_Rep_Item (Full_Typ);
2758 while Present (Prag) loop
2759 if Nkind (Prag) = N_Pragma
2760 and then Pragma_Name (Prag) = Name_Invariant
2762 -- Nothing to do if the pragma was already processed
2764 if Contains (Pragmas_Seen, Prag) then
2767 -- Nothing to do when the caller requests the processing of all
2768 -- inherited class-wide invariants, but the pragma does not
2769 -- fall in this category.
2771 elsif not Class_Present (Prag) then
2775 -- Extract the arguments of the invariant pragma
2777 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2778 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2779 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2780 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2782 -- The pragma applies to the partial view of the parent type
2784 if Present (Priv_Typ)
2785 and then Entity (Prag_Typ) = Priv_Typ
2787 Par_Typ := Priv_Typ;
2789 -- The pragma applies to the full view of the parent type
2791 elsif Present (Full_Typ)
2792 and then Entity (Prag_Typ) = Full_Typ
2794 Par_Typ := Full_Typ;
2796 -- Otherwise the pragma does not belong to the parent type and
2797 -- should not be considered.
2803 -- Perform the following substitutions:
2805 -- * Replace a reference to the _object parameter of the
2806 -- parent type's partial invariant procedure with a
2807 -- reference to the _object parameter of the derived
2808 -- type's full invariant procedure.
2810 -- * Replace a reference to a discriminant of the parent type
2811 -- with a suitable value from the point of view of the
2814 -- * Replace a call to an overridden parent primitive with a
2815 -- call to the overriding derived type primitive.
2817 -- * Replace a call to an inherited parent primitive with a
2818 -- call to the internally-generated inherited derived type
2821 Expr := New_Copy_Tree (Prag_Expr);
2823 -- The parent type must have a "partial" invariant procedure
2824 -- because class-wide invariants are captured exclusively by
2827 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2828 pragma Assert (Present (Par_Proc));
2833 Deriv_Typ => Deriv_Typ,
2834 Par_Obj => First_Formal (Par_Proc),
2835 Deriv_Obj => Obj_Id);
2837 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2840 Next_Rep_Item (Prag);
2842 end Add_Inherited_Invariants;
2844 ------------------------------
2845 -- Add_Interface_Invariants --
2846 ------------------------------
2848 procedure Add_Interface_Invariants
2851 Checks : in out List_Id)
2853 Iface_Elmt : Elmt_Id;
2857 -- Generate an invariant check for each class-wide invariant coming
2858 -- from all interfaces implemented by type T.
2860 if Is_Tagged_Type (T) then
2861 Collect_Interfaces (T, Ifaces);
2863 -- Process the class-wide invariants of all implemented interfaces
2865 Iface_Elmt := First_Elmt (Ifaces);
2866 while Present (Iface_Elmt) loop
2868 -- The Full_Typ parameter is intentionally left Empty because
2869 -- interfaces are treated as the partial view of a private type
2870 -- in order to achieve uniformity with the general case.
2872 Add_Inherited_Invariants
2874 Priv_Typ => Node (Iface_Elmt),
2879 Next_Elmt (Iface_Elmt);
2882 end Add_Interface_Invariants;
2884 -------------------------
2885 -- Add_Invariant_Check --
2886 -------------------------
2888 procedure Add_Invariant_Check
2891 Checks : in out List_Id;
2892 Inherited : Boolean := False)
2894 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2895 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2896 Ploc : constant Source_Ptr := Sloc (Prag);
2897 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2903 -- The invariant is ignored, nothing left to do
2905 if Is_Ignored (Prag) then
2908 -- Otherwise the invariant is checked. Build a pragma Check to verify
2909 -- the expression at run time.
2913 Make_Pragma_Argument_Association (Ploc,
2914 Expression => Make_Identifier (Ploc, Nam)),
2915 Make_Pragma_Argument_Association (Ploc,
2916 Expression => Expr));
2918 -- Handle the String argument (if any)
2920 if Present (Str_Arg) then
2921 Str := Strval (Get_Pragma_Arg (Str_Arg));
2923 -- When inheriting an invariant, modify the message from
2924 -- "failed invariant" to "failed inherited invariant".
2927 String_To_Name_Buffer (Str);
2929 if Name_Buffer (1 .. 16) = "failed invariant" then
2930 Insert_Str_In_Name_Buffer ("inherited ", 8);
2931 Str := String_From_Name_Buffer;
2936 Make_Pragma_Argument_Association (Ploc,
2937 Expression => Make_String_Literal (Ploc, Str)));
2941 -- pragma Check (<Nam>, <Expr>, <Str>);
2943 Append_New_To (Checks,
2945 Chars => Name_Check,
2946 Pragma_Argument_Associations => Assoc));
2949 -- Output an info message when inheriting an invariant and the
2950 -- listing option is enabled.
2952 if Inherited and Opt.List_Inherited_Aspects then
2953 Error_Msg_Sloc := Sloc (Prag);
2955 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
2958 -- Add the pragma to the list of processed pragmas
2960 Append_New_Elmt (Prag, Pragmas_Seen);
2961 Produced_Check := True;
2962 end Add_Invariant_Check;
2964 ---------------------------
2965 -- Add_Parent_Invariants --
2966 ---------------------------
2968 procedure Add_Parent_Invariants
2971 Checks : in out List_Id)
2973 Dummy_1 : Entity_Id;
2974 Dummy_2 : Entity_Id;
2976 Curr_Typ : Entity_Id;
2977 -- The entity of the current type being examined
2979 Full_Typ : Entity_Id;
2980 -- The full view of Par_Typ
2982 Par_Typ : Entity_Id;
2983 -- The entity of the parent type
2985 Priv_Typ : Entity_Id;
2986 -- The partial view of Par_Typ
2989 -- Do not process array types because they cannot have true parent
2990 -- types. This also prevents the generation of a duplicate invariant
2991 -- check when the input type is an array base type because its Etype
2992 -- denotes the first subtype, both of which share the same component
2995 if Is_Array_Type (T) then
2999 -- Climb the parent type chain
3003 -- Do not consider subtypes as they inherit the invariants
3004 -- from their base types.
3006 Par_Typ := Base_Type (Etype (Curr_Typ));
3008 -- Stop the climb once the root of the parent chain is
3011 exit when Curr_Typ = Par_Typ;
3013 -- Process the class-wide invariants of the parent type
3015 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
3017 -- Process the elements of an array type
3019 if Is_Array_Type (Full_Typ) then
3020 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
3022 -- Process the components of a record type
3024 elsif Ekind (Full_Typ) = E_Record_Type then
3025 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
3028 Add_Inherited_Invariants
3030 Priv_Typ => Priv_Typ,
3031 Full_Typ => Full_Typ,
3035 Curr_Typ := Par_Typ;
3037 end Add_Parent_Invariants;
3039 ------------------------
3040 -- Add_Own_Invariants --
3041 ------------------------
3043 procedure Add_Own_Invariants
3046 Checks : in out List_Id;
3047 Priv_Item : Node_Id := Empty)
3052 Prag_Expr : Node_Id;
3053 Prag_Expr_Arg : Node_Id;
3055 Prag_Typ_Arg : Node_Id;
3058 if not Present (T) then
3062 Prag := First_Rep_Item (T);
3063 while Present (Prag) loop
3064 if Nkind (Prag) = N_Pragma
3065 and then Pragma_Name (Prag) = Name_Invariant
3067 -- Stop the traversal of the rep item chain once a specific
3068 -- item is encountered.
3070 if Present (Priv_Item) and then Prag = Priv_Item then
3074 -- Nothing to do if the pragma was already processed
3076 if Contains (Pragmas_Seen, Prag) then
3080 -- Extract the arguments of the invariant pragma
3082 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
3083 Prag_Expr_Arg := Next (Prag_Typ_Arg);
3084 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
3085 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
3086 Prag_Asp := Corresponding_Aspect (Prag);
3088 -- Verify the pragma belongs to T, otherwise the pragma applies
3089 -- to a parent type in which case it will be processed later by
3090 -- Add_Parent_Invariants or Add_Interface_Invariants.
3092 if Entity (Prag_Typ) /= T then
3096 Expr := New_Copy_Tree (Prag_Expr);
3098 -- Substitute all references to type T with references to the
3099 -- _object formal parameter.
3101 Replace_Type_References (Expr, T, Obj_Id);
3103 -- Preanalyze the invariant expression to detect errors and at
3104 -- the same time capture the visibility of the proper package
3107 Set_Parent (Expr, Parent (Prag_Expr));
3108 Preanalyze_Assert_Expression (Expr, Any_Boolean);
3110 -- Save a copy of the expression when T is tagged to detect
3111 -- errors and capture the visibility of the proper package part
3112 -- for the generation of inherited type invariants.
3114 if Is_Tagged_Type (T) then
3115 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
3118 -- If the pragma comes from an aspect specification, replace
3119 -- the saved expression because all type references must be
3120 -- substituted for the call to Preanalyze_Spec_Expression in
3121 -- Check_Aspect_At_xxx routines.
3123 if Present (Prag_Asp) then
3124 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
3127 Add_Invariant_Check (Prag, Expr, Checks);
3130 Next_Rep_Item (Prag);
3132 end Add_Own_Invariants;
3134 -------------------------------------
3135 -- Add_Record_Component_Invariants --
3136 -------------------------------------
3138 procedure Add_Record_Component_Invariants
3141 Checks : in out List_Id)
3143 procedure Process_Component_List
3144 (Comp_List : Node_Id;
3145 CL_Checks : in out List_Id);
3146 -- Generate invariant checks for all record components found in
3147 -- component list Comp_List, including variant parts. All created
3148 -- checks are added to list CL_Checks.
3150 procedure Process_Record_Component
3151 (Comp_Id : Entity_Id;
3152 Comp_Checks : in out List_Id);
3153 -- Generate an invariant check for a record component identified by
3154 -- Comp_Id. All created checks are added to list Comp_Checks.
3156 ----------------------------
3157 -- Process_Component_List --
3158 ----------------------------
3160 procedure Process_Component_List
3161 (Comp_List : Node_Id;
3162 CL_Checks : in out List_Id)
3166 Var_Alts : List_Id := No_List;
3167 Var_Checks : List_Id := No_List;
3168 Var_Stmts : List_Id;
3170 Produced_Variant_Check : Boolean := False;
3171 -- This flag tracks whether the component has produced at least
3172 -- one invariant check.
3175 -- Traverse the component items
3177 Comp := First (Component_Items (Comp_List));
3178 while Present (Comp) loop
3179 if Nkind (Comp) = N_Component_Declaration then
3181 -- Generate the component invariant check
3183 Process_Record_Component
3184 (Comp_Id => Defining_Entity (Comp),
3185 Comp_Checks => CL_Checks);
3191 -- Traverse the variant part
3193 if Present (Variant_Part (Comp_List)) then
3194 Var := First (Variants (Variant_Part (Comp_List)));
3195 while Present (Var) loop
3196 Var_Checks := No_List;
3198 -- Generate invariant checks for all components and variant
3199 -- parts that qualify.
3201 Process_Component_List
3202 (Comp_List => Component_List (Var),
3203 CL_Checks => Var_Checks);
3205 -- The components of the current variant produced at least
3206 -- one invariant check.
3208 if Present (Var_Checks) then
3209 Var_Stmts := Var_Checks;
3210 Produced_Variant_Check := True;
3212 -- Otherwise there are either no components with invariants,
3213 -- assertions are disabled, or Assertion_Policy Ignore is in
3217 Var_Stmts := New_List (Make_Null_Statement (Loc));
3220 Append_New_To (Var_Alts,
3221 Make_Case_Statement_Alternative (Loc,
3223 New_Copy_List (Discrete_Choices (Var)),
3224 Statements => Var_Stmts));
3229 -- Create a case statement which verifies the invariant checks
3230 -- of a particular component list depending on the discriminant
3231 -- values only when there is at least one real invariant check.
3233 if Produced_Variant_Check then
3234 Append_New_To (CL_Checks,
3235 Make_Case_Statement (Loc,
3237 Make_Selected_Component (Loc,
3238 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3241 (Entity (Name (Variant_Part (Comp_List))), Loc)),
3242 Alternatives => Var_Alts));
3245 end Process_Component_List;
3247 ------------------------------
3248 -- Process_Record_Component --
3249 ------------------------------
3251 procedure Process_Record_Component
3252 (Comp_Id : Entity_Id;
3253 Comp_Checks : in out List_Id)
3255 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
3256 Proc_Id : Entity_Id;
3258 Produced_Component_Check : Boolean := False;
3259 -- This flag tracks whether the component has produced at least
3260 -- one invariant check.
3263 -- Nothing to do for internal component _parent. Note that it is
3264 -- not desirable to check whether the component comes from source
3265 -- because protected type components are relocated to an internal
3266 -- corresponding record, but still need processing.
3268 if Chars (Comp_Id) = Name_uParent then
3272 -- Verify the invariant of the component. Note that an access
3273 -- type may have an invariant when it acts as the full view of a
3274 -- private type and the invariant appears on the partial view. In
3275 -- this case verify the access value itself.
3277 if Has_Invariants (Comp_Typ) then
3279 -- In GNATprove mode, the component invariants are checked by
3280 -- other means. They should not be added to the record type
3281 -- invariant procedure, so that the procedure can be used to
3282 -- check the record type invariants if any.
3284 if GNATprove_Mode then
3288 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3290 -- The component type should have an invariant procedure
3291 -- if it has invariants of its own or inherits class-wide
3292 -- invariants from parent or interface types.
3294 pragma Assert (Present (Proc_Id));
3297 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
3299 -- Note that the invariant procedure may have a null body if
3300 -- assertions are disabled or Assertion_Policy Ignore is in
3303 if not Has_Null_Body (Proc_Id) then
3304 Append_New_To (Comp_Checks,
3305 Make_Procedure_Call_Statement (Loc,
3307 New_Occurrence_Of (Proc_Id, Loc),
3308 Parameter_Associations => New_List (
3309 Make_Selected_Component (Loc,
3311 Unchecked_Convert_To
3312 (T, New_Occurrence_Of (Obj_Id, Loc)),
3314 New_Occurrence_Of (Comp_Id, Loc)))));
3318 Produced_Check := True;
3319 Produced_Component_Check := True;
3322 if Produced_Component_Check and then Has_Unchecked_Union (T) then
3324 ("invariants cannot be checked on components of "
3325 & "unchecked_union type &??", Comp_Id, T);
3327 end Process_Record_Component;
3334 -- Start of processing for Add_Record_Component_Invariants
3337 -- An untagged derived type inherits the components of its parent
3338 -- type. In order to avoid creating redundant invariant checks, do
3339 -- not process the components now. Instead wait until the ultimate
3340 -- parent of the untagged derivation chain is reached.
3342 if not Is_Untagged_Derivation (T) then
3343 Def := Type_Definition (Parent (T));
3345 if Nkind (Def) = N_Derived_Type_Definition then
3346 Def := Record_Extension_Part (Def);
3349 pragma Assert (Nkind (Def) = N_Record_Definition);
3350 Comps := Component_List (Def);
3352 if Present (Comps) then
3353 Process_Component_List
3354 (Comp_List => Comps,
3355 CL_Checks => Checks);
3358 end Add_Record_Component_Invariants;
3362 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3363 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3364 -- Save the Ghost-related attributes to restore on exit
3367 Priv_Item : Node_Id;
3368 Proc_Body : Node_Id;
3369 Proc_Body_Id : Entity_Id;
3370 Proc_Decl : Node_Id;
3371 Proc_Id : Entity_Id;
3372 Stmts : List_Id := No_List;
3374 CRec_Typ : Entity_Id := Empty;
3375 -- The corresponding record type of Full_Typ
3377 Full_Proc : Entity_Id := Empty;
3378 -- The entity of the "full" invariant procedure
3380 Full_Typ : Entity_Id := Empty;
3381 -- The full view of the working type
3383 Obj_Id : Entity_Id := Empty;
3384 -- The _object formal parameter of the invariant procedure
3386 Part_Proc : Entity_Id := Empty;
3387 -- The entity of the "partial" invariant procedure
3389 Priv_Typ : Entity_Id := Empty;
3390 -- The partial view of the working type
3392 Work_Typ : Entity_Id := Empty;
3395 -- Start of processing for Build_Invariant_Procedure_Body
3400 -- Do not process the underlying full view of a private type. There is
3401 -- no way to get back to the partial view, plus the body will be built
3402 -- by the full view or the base type.
3404 if Is_Underlying_Full_View (Work_Typ) then
3407 -- The input type denotes the implementation base type of a constrained
3408 -- array type. Work with the first subtype as all invariant pragmas are
3409 -- on its rep item chain.
3411 elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3412 Work_Typ := First_Subtype (Work_Typ);
3414 -- The input type denotes the corresponding record type of a protected
3415 -- or task type. Work with the concurrent type because the corresponding
3416 -- record type may not be visible to clients of the type.
3418 elsif Ekind (Work_Typ) = E_Record_Type
3419 and then Is_Concurrent_Record_Type (Work_Typ)
3421 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3424 -- The working type may be subject to pragma Ghost. Set the mode now to
3425 -- ensure that the invariant procedure is properly marked as Ghost.
3427 Set_Ghost_Mode (Work_Typ);
3429 -- The type must either have invariants of its own, inherit class-wide
3430 -- invariants from parent types or interfaces, or be an array or record
3431 -- type whose components have invariants.
3433 pragma Assert (Has_Invariants (Work_Typ));
3435 -- Interfaces are treated as the partial view of a private type in order
3436 -- to achieve uniformity with the general case.
3438 if Is_Interface (Work_Typ) then
3439 Priv_Typ := Work_Typ;
3441 -- Otherwise obtain both views of the type
3444 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
3447 -- The caller requests a body for the partial invariant procedure
3449 if Partial_Invariant then
3450 Full_Proc := Invariant_Procedure (Work_Typ);
3451 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3453 -- The "full" invariant procedure body was already created
3455 if Present (Full_Proc)
3457 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
3459 -- This scenario happens only when the type is an untagged
3460 -- derivation from a private parent and the underlying full
3461 -- view was processed before the partial view.
3464 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3466 -- Nothing to do because the processing of the underlying full
3467 -- view already checked the invariants of the partial view.
3472 -- Create a declaration for the "partial" invariant procedure if it
3473 -- is not available.
3475 if No (Proc_Id) then
3476 Build_Invariant_Procedure_Declaration
3478 Partial_Invariant => True);
3480 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3483 -- The caller requests a body for the "full" invariant procedure
3486 Proc_Id := Invariant_Procedure (Work_Typ);
3487 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3489 -- Create a declaration for the "full" invariant procedure if it is
3492 if No (Proc_Id) then
3493 Build_Invariant_Procedure_Declaration (Work_Typ);
3494 Proc_Id := Invariant_Procedure (Work_Typ);
3498 -- At this point there should be an invariant procedure declaration
3500 pragma Assert (Present (Proc_Id));
3501 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3503 -- Nothing to do if the invariant procedure already has a body
3505 if Present (Corresponding_Body (Proc_Decl)) then
3509 -- Emulate the environment of the invariant procedure by installing its
3510 -- scope and formal parameters. Note that this is not needed, but having
3511 -- the scope installed helps with the detection of invariant-related
3514 Push_Scope (Proc_Id);
3515 Install_Formals (Proc_Id);
3517 Obj_Id := First_Formal (Proc_Id);
3518 pragma Assert (Present (Obj_Id));
3520 -- The "partial" invariant procedure verifies the invariants of the
3521 -- partial view only.
3523 if Partial_Invariant then
3524 pragma Assert (Present (Priv_Typ));
3531 -- Otherwise the "full" invariant procedure verifies the invariants of
3532 -- the full view, all array or record components, as well as class-wide
3533 -- invariants inherited from parent types or interfaces. In addition, it
3534 -- indirectly verifies the invariants of the partial view by calling the
3535 -- "partial" invariant procedure.
3538 pragma Assert (Present (Full_Typ));
3540 -- Check the invariants of the partial view by calling the "partial"
3541 -- invariant procedure. Generate:
3543 -- <Work_Typ>Partial_Invariant (_object);
3545 if Present (Part_Proc) then
3546 Append_New_To (Stmts,
3547 Make_Procedure_Call_Statement (Loc,
3548 Name => New_Occurrence_Of (Part_Proc, Loc),
3549 Parameter_Associations => New_List (
3550 New_Occurrence_Of (Obj_Id, Loc))));
3552 Produced_Check := True;
3557 -- Derived subtypes do not have a partial view
3559 if Present (Priv_Typ) then
3561 -- The processing of the "full" invariant procedure intentionally
3562 -- skips the partial view because a) this may result in changes of
3563 -- visibility and b) lead to duplicate checks. However, when the
3564 -- full view is the underlying full view of an untagged derived
3565 -- type whose parent type is private, partial invariants appear on
3566 -- the rep item chain of the partial view only.
3568 -- package Pack_1 is
3569 -- type Root ... is private;
3571 -- <full view of Root>
3575 -- package Pack_2 is
3576 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3577 -- <underlying full view of Child>
3580 -- As a result, the processing of the full view must also consider
3581 -- all invariants of the partial view.
3583 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3586 -- Otherwise the invariants of the partial view are ignored
3589 -- Note that the rep item chain is shared between the partial
3590 -- and full views of a type. To avoid processing the invariants
3591 -- of the partial view, signal the logic to stop when the first
3592 -- rep item of the partial view has been reached.
3594 Priv_Item := First_Rep_Item (Priv_Typ);
3596 -- Ignore the invariants of the partial view by eliminating the
3603 -- Process the invariants of the full view and in certain cases those
3604 -- of the partial view. This also handles any invariants on array or
3605 -- record components.
3611 Priv_Item => Priv_Item);
3617 Priv_Item => Priv_Item);
3619 -- Process the elements of an array type
3621 if Is_Array_Type (Full_Typ) then
3622 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3624 -- Process the components of a record type
3626 elsif Ekind (Full_Typ) = E_Record_Type then
3627 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3629 -- Process the components of a corresponding record
3631 elsif Present (CRec_Typ) then
3632 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3635 -- Process the inherited class-wide invariants of all parent types.
3636 -- This also handles any invariants on record components.
3638 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3640 -- Process the inherited class-wide invariants of all implemented
3643 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3648 -- At this point there should be at least one invariant check. If this
3649 -- is not the case, then the invariant-related flags were not properly
3650 -- set, or there is a missing invariant procedure on one of the array
3651 -- or record components.
3653 pragma Assert (Produced_Check);
3655 -- Account for the case where assertions are disabled or all invariant
3656 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3660 Stmts := New_List (Make_Null_Statement (Loc));
3664 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3667 -- end <Work_Typ>[Partial_]Invariant;
3670 Make_Subprogram_Body (Loc,
3672 Copy_Subprogram_Spec (Parent (Proc_Id)),
3673 Declarations => Empty_List,
3674 Handled_Statement_Sequence =>
3675 Make_Handled_Sequence_Of_Statements (Loc,
3676 Statements => Stmts));
3677 Proc_Body_Id := Defining_Entity (Proc_Body);
3679 -- Perform minor decoration in case the body is not analyzed
3681 Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
3682 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3683 Set_Scope (Proc_Body_Id, Current_Scope);
3685 -- Link both spec and body to avoid generating duplicates
3687 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3688 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3690 -- The body should not be inserted into the tree when the context is
3691 -- a generic unit because it is not part of the template. Note
3692 -- that the body must still be generated in order to resolve the
3695 if Inside_A_Generic then
3698 -- Semi-insert the body into the tree for GNATprove by setting its
3699 -- Parent field. This allows for proper upstream tree traversals.
3701 elsif GNATprove_Mode then
3702 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3704 -- Otherwise the body is part of the freezing actions of the type
3707 Append_Freeze_Action (Work_Typ, Proc_Body);
3711 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3712 end Build_Invariant_Procedure_Body;
3714 -------------------------------------------
3715 -- Build_Invariant_Procedure_Declaration --
3716 -------------------------------------------
3718 -- WARNING: This routine manages Ghost regions. Return statements must be
3719 -- replaced by gotos which jump to the end of the routine and restore the
3722 procedure Build_Invariant_Procedure_Declaration
3724 Partial_Invariant : Boolean := False)
3726 Loc : constant Source_Ptr := Sloc (Typ);
3728 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3729 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3730 -- Save the Ghost-related attributes to restore on exit
3732 Proc_Decl : Node_Id;
3733 Proc_Id : Entity_Id;
3737 CRec_Typ : Entity_Id;
3738 -- The corresponding record type of Full_Typ
3740 Full_Typ : Entity_Id;
3741 -- The full view of working type
3744 -- The _object formal parameter of the invariant procedure
3746 Obj_Typ : Entity_Id;
3747 -- The type of the _object formal parameter
3749 Priv_Typ : Entity_Id;
3750 -- The partial view of working type
3752 UFull_Typ : Entity_Id;
3753 -- The underlying full view of Full_Typ
3755 Work_Typ : Entity_Id;
3761 -- The input type denotes the implementation base type of a constrained
3762 -- array type. Work with the first subtype as all invariant pragmas are
3763 -- on its rep item chain.
3765 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3766 Work_Typ := First_Subtype (Work_Typ);
3768 -- The input denotes the corresponding record type of a protected or a
3769 -- task type. Work with the concurrent type because the corresponding
3770 -- record type may not be visible to clients of the type.
3772 elsif Ekind (Work_Typ) = E_Record_Type
3773 and then Is_Concurrent_Record_Type (Work_Typ)
3775 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3778 -- The working type may be subject to pragma Ghost. Set the mode now to
3779 -- ensure that the invariant procedure is properly marked as Ghost.
3781 Set_Ghost_Mode (Work_Typ);
3783 -- The type must either have invariants of its own, inherit class-wide
3784 -- invariants from parent or interface types, or be an array or record
3785 -- type whose components have invariants.
3787 pragma Assert (Has_Invariants (Work_Typ));
3789 -- Nothing to do if the type already has a "partial" invariant procedure
3791 if Partial_Invariant then
3792 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3796 -- Nothing to do if the type already has a "full" invariant procedure
3798 elsif Present (Invariant_Procedure (Work_Typ)) then
3802 -- The caller requests the declaration of the "partial" invariant
3805 if Partial_Invariant then
3806 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3808 -- Otherwise the caller requests the declaration of the "full" invariant
3812 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3815 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3817 -- Perform minor decoration in case the declaration is not analyzed
3819 Mutate_Ekind (Proc_Id, E_Procedure);
3820 Set_Etype (Proc_Id, Standard_Void_Type);
3821 Set_Scope (Proc_Id, Current_Scope);
3823 if Partial_Invariant then
3824 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3825 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3827 Set_Is_Invariant_Procedure (Proc_Id);
3828 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3831 -- The invariant procedure requires debug info when the invariants are
3832 -- subject to Source Coverage Obligations.
3834 if Generate_SCO then
3835 Set_Debug_Info_Needed (Proc_Id);
3838 -- Obtain all views of the input type
3840 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
3842 -- Associate the invariant procedure and various flags with all views
3844 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3845 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3846 Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ);
3847 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3849 -- The declaration of the invariant procedure is inserted after the
3850 -- declaration of the partial view as this allows for proper external
3853 if Present (Priv_Typ) then
3854 Typ_Decl := Declaration_Node (Priv_Typ);
3856 -- Anonymous arrays in object declarations have no explicit declaration
3857 -- so use the related object declaration as the insertion point.
3859 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
3860 Typ_Decl := Associated_Node_For_Itype (Work_Typ);
3862 -- Derived types with the full view as parent do not have a partial
3863 -- view. Insert the invariant procedure after the derived type.
3866 Typ_Decl := Declaration_Node (Full_Typ);
3869 -- The type should have a declarative node
3871 pragma Assert (Present (Typ_Decl));
3873 -- Create the formal parameter which emulates the variable-like behavior
3874 -- of the current type instance.
3876 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3878 -- When generating an invariant procedure declaration for an abstract
3879 -- type (including interfaces), use the class-wide type as the _object
3880 -- type. This has several desirable effects:
3882 -- * The invariant procedure does not become a primitive of the type.
3883 -- This eliminates the need to either special case the treatment of
3884 -- invariant procedures, or to make it a predefined primitive and
3885 -- force every derived type to potentially provide an empty body.
3887 -- * The invariant procedure does not need to be declared as abstract.
3888 -- This allows for a proper body, which in turn avoids redundant
3889 -- processing of the same invariants for types with multiple views.
3891 -- * The class-wide type allows for calls to abstract primitives
3892 -- within a nonabstract subprogram. The calls are treated as
3893 -- dispatching and require additional processing when they are
3894 -- remapped to call primitives of derived types. See routine
3895 -- Replace_References for details.
3897 if Is_Abstract_Type (Work_Typ) then
3898 Obj_Typ := Class_Wide_Type (Work_Typ);
3900 Obj_Typ := Work_Typ;
3903 -- Perform minor decoration in case the declaration is not analyzed
3905 Mutate_Ekind (Obj_Id, E_In_Parameter);
3906 Set_Etype (Obj_Id, Obj_Typ);
3907 Set_Scope (Obj_Id, Proc_Id);
3909 Set_First_Entity (Proc_Id, Obj_Id);
3910 Set_Last_Entity (Proc_Id, Obj_Id);
3913 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3916 Make_Subprogram_Declaration (Loc,
3918 Make_Procedure_Specification (Loc,
3919 Defining_Unit_Name => Proc_Id,
3920 Parameter_Specifications => New_List (
3921 Make_Parameter_Specification (Loc,
3922 Defining_Identifier => Obj_Id,
3923 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3925 -- The declaration should not be inserted into the tree when the context
3926 -- is a generic unit because it is not part of the template.
3928 if Inside_A_Generic then
3931 -- Semi-insert the declaration into the tree for GNATprove by setting
3932 -- its Parent field. This allows for proper upstream tree traversals.
3934 elsif GNATprove_Mode then
3935 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3937 -- Otherwise insert the declaration
3940 pragma Assert (Present (Typ_Decl));
3941 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3945 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3946 end Build_Invariant_Procedure_Declaration;
3948 --------------------------
3949 -- Build_Procedure_Form --
3950 --------------------------
3952 procedure Build_Procedure_Form (N : Node_Id) is
3953 Loc : constant Source_Ptr := Sloc (N);
3954 Subp : constant Entity_Id := Defining_Entity (N);
3956 Func_Formal : Entity_Id;
3957 Proc_Formals : List_Id;
3958 Proc_Decl : Node_Id;
3961 -- No action needed if this transformation was already done, or in case
3962 -- of subprogram renaming declarations.
3964 if Nkind (Specification (N)) = N_Procedure_Specification
3965 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3970 -- Ditto when dealing with an expression function, where both the
3971 -- original expression and the generated declaration end up being
3974 if Rewritten_For_C (Subp) then
3978 Proc_Formals := New_List;
3980 -- Create a list of formal parameters with the same types as the
3983 Func_Formal := First_Formal (Subp);
3984 while Present (Func_Formal) loop
3985 Append_To (Proc_Formals,
3986 Make_Parameter_Specification (Loc,
3987 Defining_Identifier =>
3988 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
3990 New_Occurrence_Of (Etype (Func_Formal), Loc)));
3992 Next_Formal (Func_Formal);
3995 -- Add an extra out parameter to carry the function result
3997 Append_To (Proc_Formals,
3998 Make_Parameter_Specification (Loc,
3999 Defining_Identifier =>
4000 Make_Defining_Identifier (Loc, Name_UP_RESULT),
4001 Out_Present => True,
4002 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
4004 -- The new procedure declaration is inserted before the function
4005 -- declaration. The processing in Build_Procedure_Body_Form relies on
4006 -- this order. Note that we insert before because in the case of a
4007 -- function body with no separate spec, we do not want to insert the
4008 -- new spec after the body which will later get rewritten.
4011 Make_Subprogram_Declaration (Loc,
4013 Make_Procedure_Specification (Loc,
4014 Defining_Unit_Name =>
4015 Make_Defining_Identifier (Loc, Chars (Subp)),
4016 Parameter_Specifications => Proc_Formals));
4018 Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
4020 -- Entity of procedure must remain invisible so that it does not
4021 -- overload subsequent references to the original function.
4023 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
4025 -- Mark the function as having a procedure form and link the function
4026 -- and its internally built procedure.
4028 Set_Rewritten_For_C (Subp);
4029 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
4030 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
4031 end Build_Procedure_Form;
4033 ------------------------
4034 -- Build_Runtime_Call --
4035 ------------------------
4037 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
4039 -- If entity is not available, we can skip making the call (this avoids
4040 -- junk duplicated error messages in a number of cases).
4042 if not RTE_Available (RE) then
4043 return Make_Null_Statement (Loc);
4046 Make_Procedure_Call_Statement (Loc,
4047 Name => New_Occurrence_Of (RTE (RE), Loc));
4049 end Build_Runtime_Call;
4051 ------------------------
4052 -- Build_SS_Mark_Call --
4053 ------------------------
4055 function Build_SS_Mark_Call
4057 Mark : Entity_Id) return Node_Id
4061 -- Mark : constant Mark_Id := SS_Mark;
4064 Make_Object_Declaration (Loc,
4065 Defining_Identifier => Mark,
4066 Constant_Present => True,
4067 Object_Definition =>
4068 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
4070 Make_Function_Call (Loc,
4071 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
4072 end Build_SS_Mark_Call;
4074 ---------------------------
4075 -- Build_SS_Release_Call --
4076 ---------------------------
4078 function Build_SS_Release_Call
4080 Mark : Entity_Id) return Node_Id
4084 -- SS_Release (Mark);
4087 Make_Procedure_Call_Statement (Loc,
4089 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
4090 Parameter_Associations => New_List (
4091 New_Occurrence_Of (Mark, Loc)));
4092 end Build_SS_Release_Call;
4094 ----------------------------
4095 -- Build_Task_Array_Image --
4096 ----------------------------
4098 -- This function generates the body for a function that constructs the
4099 -- image string for a task that is an array component. The function is
4100 -- local to the init proc for the array type, and is called for each one
4101 -- of the components. The constructed image has the form of an indexed
4102 -- component, whose prefix is the outer variable of the array type.
4103 -- The n-dimensional array type has known indexes Index, Index2...
4105 -- Id_Ref is an indexed component form created by the enclosing init proc.
4106 -- Its successive indexes are Val1, Val2, ... which are the loop variables
4107 -- in the loops that call the individual task init proc on each component.
4109 -- The generated function has the following structure:
4111 -- function F return String is
4112 -- Pref : string renames Task_Name;
4113 -- T1 : String := Index1'Image (Val1);
4115 -- Tn : String := indexn'image (Valn);
4116 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
4117 -- -- Len includes commas and the end parentheses.
4118 -- Res : String (1..Len);
4119 -- Pos : Integer := Pref'Length;
4122 -- Res (1 .. Pos) := Pref;
4124 -- Res (Pos) := '(';
4126 -- Res (Pos .. Pos + T1'Length - 1) := T1;
4127 -- Pos := Pos + T1'Length;
4128 -- Res (Pos) := '.';
4131 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
4132 -- Res (Len) := ')';
4137 -- Needless to say, multidimensional arrays of tasks are rare enough that
4138 -- the bulkiness of this code is not really a concern.
4140 function Build_Task_Array_Image
4144 Dyn : Boolean := False) return Node_Id
4146 Dims : constant Nat := Number_Dimensions (A_Type);
4147 -- Number of dimensions for array of tasks
4149 Temps : array (1 .. Dims) of Entity_Id;
4150 -- Array of temporaries to hold string for each index
4156 -- Total length of generated name
4159 -- Running index for substring assignments
4161 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4162 -- Name of enclosing variable, prefix of resulting name
4165 -- String to hold result
4168 -- Value of successive indexes
4171 -- Expression to compute total size of string
4174 -- Entity for name at one index position
4176 Decls : constant List_Id := New_List;
4177 Stats : constant List_Id := New_List;
4180 -- For a dynamic task, the name comes from the target variable. For a
4181 -- static one it is a formal of the enclosing init proc.
4184 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4186 Make_Object_Declaration (Loc,
4187 Defining_Identifier => Pref,
4188 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4190 Make_String_Literal (Loc,
4191 Strval => String_From_Name_Buffer)));
4195 Make_Object_Renaming_Declaration (Loc,
4196 Defining_Identifier => Pref,
4197 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4198 Name => Make_Identifier (Loc, Name_uTask_Name)));
4201 Indx := First_Index (A_Type);
4202 Val := First (Expressions (Id_Ref));
4204 for J in 1 .. Dims loop
4205 T := Make_Temporary (Loc, 'T');
4209 Make_Object_Declaration (Loc,
4210 Defining_Identifier => T,
4211 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4213 Make_Attribute_Reference (Loc,
4214 Attribute_Name => Name_Image,
4215 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
4216 Expressions => New_List (New_Copy_Tree (Val)))));
4222 Sum := Make_Integer_Literal (Loc, Dims + 1);
4228 Make_Attribute_Reference (Loc,
4229 Attribute_Name => Name_Length,
4230 Prefix => New_Occurrence_Of (Pref, Loc),
4231 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4233 for J in 1 .. Dims loop
4238 Make_Attribute_Reference (Loc,
4239 Attribute_Name => Name_Length,
4241 New_Occurrence_Of (Temps (J), Loc),
4242 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4245 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4247 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
4250 Make_Assignment_Statement (Loc,
4252 Make_Indexed_Component (Loc,
4253 Prefix => New_Occurrence_Of (Res, Loc),
4254 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4256 Make_Character_Literal (Loc,
4258 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
4261 Make_Assignment_Statement (Loc,
4262 Name => New_Occurrence_Of (Pos, Loc),
4265 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4266 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4268 for J in 1 .. Dims loop
4271 Make_Assignment_Statement (Loc,
4274 Prefix => New_Occurrence_Of (Res, Loc),
4277 Low_Bound => New_Occurrence_Of (Pos, Loc),
4279 Make_Op_Subtract (Loc,
4282 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4284 Make_Attribute_Reference (Loc,
4285 Attribute_Name => Name_Length,
4287 New_Occurrence_Of (Temps (J), Loc),
4289 New_List (Make_Integer_Literal (Loc, 1)))),
4290 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
4292 Expression => New_Occurrence_Of (Temps (J), Loc)));
4296 Make_Assignment_Statement (Loc,
4297 Name => New_Occurrence_Of (Pos, Loc),
4300 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4302 Make_Attribute_Reference (Loc,
4303 Attribute_Name => Name_Length,
4304 Prefix => New_Occurrence_Of (Temps (J), Loc),
4306 New_List (Make_Integer_Literal (Loc, 1))))));
4308 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
4311 Make_Assignment_Statement (Loc,
4312 Name => Make_Indexed_Component (Loc,
4313 Prefix => New_Occurrence_Of (Res, Loc),
4314 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4316 Make_Character_Literal (Loc,
4318 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
4321 Make_Assignment_Statement (Loc,
4322 Name => New_Occurrence_Of (Pos, Loc),
4325 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4326 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4330 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
4333 Make_Assignment_Statement (Loc,
4335 Make_Indexed_Component (Loc,
4336 Prefix => New_Occurrence_Of (Res, Loc),
4337 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
4339 Make_Character_Literal (Loc,
4341 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
4342 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4343 end Build_Task_Array_Image;
4345 ----------------------------
4346 -- Build_Task_Image_Decls --
4347 ----------------------------
4349 function Build_Task_Image_Decls
4353 In_Init_Proc : Boolean := False) return List_Id
4355 Decls : constant List_Id := New_List;
4356 T_Id : Entity_Id := Empty;
4358 Expr : Node_Id := Empty;
4359 Fun : Node_Id := Empty;
4360 Is_Dyn : constant Boolean :=
4361 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
4363 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
4366 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
4367 -- generate a dummy declaration only.
4369 if Restriction_Active (No_Implicit_Heap_Allocations)
4370 or else Global_Discard_Names
4372 T_Id := Make_Temporary (Loc, 'J');
4377 Make_Object_Declaration (Loc,
4378 Defining_Identifier => T_Id,
4379 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4381 Make_String_Literal (Loc,
4382 Strval => String_From_Name_Buffer)));
4385 if Nkind (Id_Ref) = N_Identifier
4386 or else Nkind (Id_Ref) = N_Defining_Identifier
4388 -- For a simple variable, the image of the task is built from
4389 -- the name of the variable. To avoid possible conflict with the
4390 -- anonymous type created for a single protected object, add a
4394 Make_Defining_Identifier (Loc,
4395 New_External_Name (Chars (Id_Ref), 'T', 1));
4397 Get_Name_String (Chars (Id_Ref));
4400 Make_String_Literal (Loc,
4401 Strval => String_From_Name_Buffer);
4403 elsif Nkind (Id_Ref) = N_Selected_Component then
4405 Make_Defining_Identifier (Loc,
4406 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
4407 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
4409 elsif Nkind (Id_Ref) = N_Indexed_Component then
4411 Make_Defining_Identifier (Loc,
4412 New_External_Name (Chars (A_Type), 'N'));
4414 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
4418 if Present (Fun) then
4419 Append (Fun, Decls);
4420 Expr := Make_Function_Call (Loc,
4421 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
4423 if not In_Init_Proc then
4424 Set_Uses_Sec_Stack (Defining_Entity (Fun));
4428 Decl := Make_Object_Declaration (Loc,
4429 Defining_Identifier => T_Id,
4430 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4431 Constant_Present => True,
4432 Expression => Expr);
4434 Append (Decl, Decls);
4436 end Build_Task_Image_Decls;
4438 -------------------------------
4439 -- Build_Task_Image_Function --
4440 -------------------------------
4442 function Build_Task_Image_Function
4446 Res : Entity_Id) return Node_Id
4452 Make_Simple_Return_Statement (Loc,
4453 Expression => New_Occurrence_Of (Res, Loc)));
4455 Spec := Make_Function_Specification (Loc,
4456 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
4457 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
4459 -- Calls to 'Image use the secondary stack, which must be cleaned up
4460 -- after the task name is built.
4462 return Make_Subprogram_Body (Loc,
4463 Specification => Spec,
4464 Declarations => Decls,
4465 Handled_Statement_Sequence =>
4466 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
4467 end Build_Task_Image_Function;
4469 -----------------------------
4470 -- Build_Task_Image_Prefix --
4471 -----------------------------
4473 procedure Build_Task_Image_Prefix
4475 Len : out Entity_Id;
4476 Res : out Entity_Id;
4477 Pos : out Entity_Id;
4484 Len := Make_Temporary (Loc, 'L', Sum);
4487 Make_Object_Declaration (Loc,
4488 Defining_Identifier => Len,
4489 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4490 Expression => Sum));
4492 Res := Make_Temporary (Loc, 'R');
4495 Make_Object_Declaration (Loc,
4496 Defining_Identifier => Res,
4497 Object_Definition =>
4498 Make_Subtype_Indication (Loc,
4499 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4501 Make_Index_Or_Discriminant_Constraint (Loc,
4505 Low_Bound => Make_Integer_Literal (Loc, 1),
4506 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4508 -- Indicate that the result is an internal temporary, so it does not
4509 -- receive a bogus initialization when declaration is expanded. This
4510 -- is both efficient, and prevents anomalies in the handling of
4511 -- dynamic objects on the secondary stack.
4513 Set_Is_Internal (Res);
4514 Pos := Make_Temporary (Loc, 'P');
4517 Make_Object_Declaration (Loc,
4518 Defining_Identifier => Pos,
4519 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4521 -- Pos := Prefix'Length;
4524 Make_Assignment_Statement (Loc,
4525 Name => New_Occurrence_Of (Pos, Loc),
4527 Make_Attribute_Reference (Loc,
4528 Attribute_Name => Name_Length,
4529 Prefix => New_Occurrence_Of (Prefix, Loc),
4530 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4532 -- Res (1 .. Pos) := Prefix;
4535 Make_Assignment_Statement (Loc,
4538 Prefix => New_Occurrence_Of (Res, Loc),
4541 Low_Bound => Make_Integer_Literal (Loc, 1),
4542 High_Bound => New_Occurrence_Of (Pos, Loc))),
4544 Expression => New_Occurrence_Of (Prefix, Loc)));
4547 Make_Assignment_Statement (Loc,
4548 Name => New_Occurrence_Of (Pos, Loc),
4551 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4552 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4553 end Build_Task_Image_Prefix;
4555 -----------------------------
4556 -- Build_Task_Record_Image --
4557 -----------------------------
4559 function Build_Task_Record_Image
4562 Dyn : Boolean := False) return Node_Id
4565 -- Total length of generated name
4568 -- Index into result
4571 -- String to hold result
4573 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4574 -- Name of enclosing variable, prefix of resulting name
4577 -- Expression to compute total size of string
4580 -- Entity for selector name
4582 Decls : constant List_Id := New_List;
4583 Stats : constant List_Id := New_List;
4586 -- For a dynamic task, the name comes from the target variable. For a
4587 -- static one it is a formal of the enclosing init proc.
4590 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4592 Make_Object_Declaration (Loc,
4593 Defining_Identifier => Pref,
4594 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4596 Make_String_Literal (Loc,
4597 Strval => String_From_Name_Buffer)));
4601 Make_Object_Renaming_Declaration (Loc,
4602 Defining_Identifier => Pref,
4603 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4604 Name => Make_Identifier (Loc, Name_uTask_Name)));
4607 Sel := Make_Temporary (Loc, 'S');
4609 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4612 Make_Object_Declaration (Loc,
4613 Defining_Identifier => Sel,
4614 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4616 Make_String_Literal (Loc,
4617 Strval => String_From_Name_Buffer)));
4619 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4625 Make_Attribute_Reference (Loc,
4626 Attribute_Name => Name_Length,
4628 New_Occurrence_Of (Pref, Loc),
4629 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4631 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4633 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
4635 -- Res (Pos) := '.';
4638 Make_Assignment_Statement (Loc,
4639 Name => Make_Indexed_Component (Loc,
4640 Prefix => New_Occurrence_Of (Res, Loc),
4641 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4643 Make_Character_Literal (Loc,
4645 Char_Literal_Value =>
4646 UI_From_Int (Character'Pos ('.')))));
4649 Make_Assignment_Statement (Loc,
4650 Name => New_Occurrence_Of (Pos, Loc),
4653 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4654 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4656 -- Res (Pos .. Len) := Selector;
4659 Make_Assignment_Statement (Loc,
4660 Name => Make_Slice (Loc,
4661 Prefix => New_Occurrence_Of (Res, Loc),
4664 Low_Bound => New_Occurrence_Of (Pos, Loc),
4665 High_Bound => New_Occurrence_Of (Len, Loc))),
4666 Expression => New_Occurrence_Of (Sel, Loc)));
4668 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4669 end Build_Task_Record_Image;
4671 ---------------------------------------
4672 -- Build_Transient_Object_Statements --
4673 ---------------------------------------
4675 procedure Build_Transient_Object_Statements
4676 (Obj_Decl : Node_Id;
4677 Fin_Call : out Node_Id;
4678 Hook_Assign : out Node_Id;
4679 Hook_Clear : out Node_Id;
4680 Hook_Decl : out Node_Id;
4681 Ptr_Decl : out Node_Id;
4682 Finalize_Obj : Boolean := True)
4684 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4685 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4686 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4688 Desig_Typ : Entity_Id;
4689 Hook_Expr : Node_Id;
4690 Hook_Id : Entity_Id;
4692 Ptr_Typ : Entity_Id;
4695 -- Recover the type of the object
4697 Desig_Typ := Obj_Typ;
4699 if Is_Access_Type (Desig_Typ) then
4700 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4703 -- Create an access type which provides a reference to the transient
4704 -- object. Generate:
4706 -- type Ptr_Typ is access all Desig_Typ;
4708 Ptr_Typ := Make_Temporary (Loc, 'A');
4709 Mutate_Ekind (Ptr_Typ, E_General_Access_Type);
4710 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4713 Make_Full_Type_Declaration (Loc,
4714 Defining_Identifier => Ptr_Typ,
4716 Make_Access_To_Object_Definition (Loc,
4717 All_Present => True,
4718 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4720 -- Create a temporary check which acts as a hook to the transient
4721 -- object. Generate:
4723 -- Hook : Ptr_Typ := null;
4725 Hook_Id := Make_Temporary (Loc, 'T');
4726 Mutate_Ekind (Hook_Id, E_Variable);
4727 Set_Etype (Hook_Id, Ptr_Typ);
4730 Make_Object_Declaration (Loc,
4731 Defining_Identifier => Hook_Id,
4732 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4733 Expression => Make_Null (Loc));
4735 -- Mark the temporary as a hook. This signals the machinery in
4736 -- Build_Finalizer to recognize this special case.
4738 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4740 -- Hook the transient object to the temporary. Generate:
4742 -- Hook := Ptr_Typ (Obj_Id);
4744 -- Hool := Obj_Id'Unrestricted_Access;
4746 if Is_Access_Type (Obj_Typ) then
4748 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4751 Make_Attribute_Reference (Loc,
4752 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4753 Attribute_Name => Name_Unrestricted_Access);
4757 Make_Assignment_Statement (Loc,
4758 Name => New_Occurrence_Of (Hook_Id, Loc),
4759 Expression => Hook_Expr);
4761 -- Crear the hook prior to finalizing the object. Generate:
4766 Make_Assignment_Statement (Loc,
4767 Name => New_Occurrence_Of (Hook_Id, Loc),
4768 Expression => Make_Null (Loc));
4770 -- Finalize the object. Generate:
4772 -- [Deep_]Finalize (Obj_Ref[.all]);
4774 if Finalize_Obj then
4775 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4777 if Is_Access_Type (Obj_Typ) then
4778 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4779 Set_Etype (Obj_Ref, Desig_Typ);
4784 (Obj_Ref => Obj_Ref,
4787 -- Otherwise finalize the hook. Generate:
4789 -- [Deep_]Finalize (Hook.all);
4795 Make_Explicit_Dereference (Loc,
4796 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4799 end Build_Transient_Object_Statements;
4801 -----------------------------
4802 -- Check_Float_Op_Overflow --
4803 -----------------------------
4805 procedure Check_Float_Op_Overflow (N : Node_Id) is
4807 -- Return if no check needed
4809 if not Is_Floating_Point_Type (Etype (N))
4810 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4812 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4813 -- and do not expand the code for float overflow checking.
4815 or else CodePeer_Mode
4820 -- Otherwise we replace the expression by
4822 -- do Tnn : constant ftype := expression;
4823 -- constraint_error when not Tnn'Valid;
4827 Loc : constant Source_Ptr := Sloc (N);
4828 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4829 Typ : constant Entity_Id := Etype (N);
4832 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4833 -- right here. We also set the node as analyzed to prevent infinite
4834 -- recursion from repeating the operation in the expansion.
4836 Set_Do_Overflow_Check (N, False);
4837 Set_Analyzed (N, True);
4839 -- Do the rewrite to include the check
4842 Make_Expression_With_Actions (Loc,
4843 Actions => New_List (
4844 Make_Object_Declaration (Loc,
4845 Defining_Identifier => Tnn,
4846 Object_Definition => New_Occurrence_Of (Typ, Loc),
4847 Constant_Present => True,
4848 Expression => Relocate_Node (N)),
4849 Make_Raise_Constraint_Error (Loc,
4853 Make_Attribute_Reference (Loc,
4854 Prefix => New_Occurrence_Of (Tnn, Loc),
4855 Attribute_Name => Name_Valid)),
4856 Reason => CE_Overflow_Check_Failed)),
4857 Expression => New_Occurrence_Of (Tnn, Loc)));
4859 Analyze_And_Resolve (N, Typ);
4861 end Check_Float_Op_Overflow;
4863 ----------------------------------
4864 -- Component_May_Be_Bit_Aligned --
4865 ----------------------------------
4867 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4871 -- If no component clause, then everything is fine, since the back end
4872 -- never misaligns from byte boundaries by default, even if there is a
4873 -- pragma Pack for the record.
4875 if No (Comp) or else No (Component_Clause (Comp)) then
4879 UT := Underlying_Type (Etype (Comp));
4881 -- It is only array and record types that cause trouble
4883 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4886 -- If we know that we have a small (at most the maximum integer size)
4887 -- record or bit-packed array, then everything is fine, since the back
4888 -- end can handle these cases correctly.
4890 elsif Esize (Comp) <= System_Max_Integer_Size
4891 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4895 -- Otherwise if the component is not byte aligned, we know we have the
4896 -- nasty unaligned case.
4898 elsif Normalized_First_Bit (Comp) /= Uint_0
4899 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4903 -- If we are large and byte aligned, then OK at this level
4908 end Component_May_Be_Bit_Aligned;
4910 -------------------------------
4911 -- Convert_To_Actual_Subtype --
4912 -------------------------------
4914 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
4918 Act_ST := Get_Actual_Subtype (Exp);
4920 if Act_ST = Etype (Exp) then
4923 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4924 Analyze_And_Resolve (Exp, Act_ST);
4926 end Convert_To_Actual_Subtype;
4928 -----------------------------------
4929 -- Corresponding_Runtime_Package --
4930 -----------------------------------
4932 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4933 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4934 -- Return True if protected type T has one entry and the maximum queue
4937 --------------------------------
4938 -- Has_One_Entry_And_No_Queue --
4939 --------------------------------
4941 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4943 Is_First : Boolean := True;
4946 Item := First_Entity (T);
4947 while Present (Item) loop
4948 if Is_Entry (Item) then
4950 -- The protected type has more than one entry
4952 if not Is_First then
4956 -- The queue length is not one
4958 if not Restriction_Active (No_Entry_Queue)
4959 and then Get_Max_Queue_Length (Item) /= Uint_1
4971 end Has_One_Entry_And_No_Queue;
4975 Pkg_Id : RTU_Id := RTU_Null;
4977 -- Start of processing for Corresponding_Runtime_Package
4980 pragma Assert (Is_Concurrent_Type (Typ));
4982 if Is_Protected_Type (Typ) then
4983 if Has_Entries (Typ)
4985 -- A protected type without entries that covers an interface and
4986 -- overrides the abstract routines with protected procedures is
4987 -- considered equivalent to a protected type with entries in the
4988 -- context of dispatching select statements. It is sufficient to
4989 -- check for the presence of an interface list in the declaration
4990 -- node to recognize this case.
4992 or else Present (Interface_List (Parent (Typ)))
4994 -- Protected types with interrupt handlers (when not using a
4995 -- restricted profile) are also considered equivalent to
4996 -- protected types with entries. The types which are used
4997 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
4998 -- are derived from Protection_Entries.
5000 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
5001 or else Has_Interrupt_Handler (Typ)
5004 or else Restriction_Active (No_Select_Statements) = False
5005 or else not Has_One_Entry_And_No_Queue (Typ)
5006 or else (Has_Attach_Handler (Typ)
5007 and then not Restricted_Profile)
5009 Pkg_Id := System_Tasking_Protected_Objects_Entries;
5011 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
5015 Pkg_Id := System_Tasking_Protected_Objects;
5020 end Corresponding_Runtime_Package;
5022 -----------------------------------
5023 -- Current_Sem_Unit_Declarations --
5024 -----------------------------------
5026 function Current_Sem_Unit_Declarations return List_Id is
5027 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
5031 -- If the current unit is a package body, locate the visible
5032 -- declarations of the package spec.
5034 if Nkind (U) = N_Package_Body then
5035 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
5038 if Nkind (U) = N_Package_Declaration then
5039 U := Specification (U);
5040 Decls := Visible_Declarations (U);
5044 Set_Visible_Declarations (U, Decls);
5048 Decls := Declarations (U);
5052 Set_Declarations (U, Decls);
5057 end Current_Sem_Unit_Declarations;
5059 -----------------------
5060 -- Duplicate_Subexpr --
5061 -----------------------
5063 function Duplicate_Subexpr
5065 Name_Req : Boolean := False;
5066 Renaming_Req : Boolean := False) return Node_Id
5069 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
5070 return New_Copy_Tree (Exp);
5071 end Duplicate_Subexpr;
5073 ---------------------------------
5074 -- Duplicate_Subexpr_No_Checks --
5075 ---------------------------------
5077 function Duplicate_Subexpr_No_Checks
5079 Name_Req : Boolean := False;
5080 Renaming_Req : Boolean := False;
5081 Related_Id : Entity_Id := Empty;
5082 Is_Low_Bound : Boolean := False;
5083 Is_High_Bound : Boolean := False) return Node_Id
5090 Name_Req => Name_Req,
5091 Renaming_Req => Renaming_Req,
5092 Related_Id => Related_Id,
5093 Is_Low_Bound => Is_Low_Bound,
5094 Is_High_Bound => Is_High_Bound);
5096 New_Exp := New_Copy_Tree (Exp);
5097 Remove_Checks (New_Exp);
5099 end Duplicate_Subexpr_No_Checks;
5101 -----------------------------------
5102 -- Duplicate_Subexpr_Move_Checks --
5103 -----------------------------------
5105 function Duplicate_Subexpr_Move_Checks
5107 Name_Req : Boolean := False;
5108 Renaming_Req : Boolean := False) return Node_Id
5113 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
5114 New_Exp := New_Copy_Tree (Exp);
5115 Remove_Checks (Exp);
5117 end Duplicate_Subexpr_Move_Checks;
5119 -------------------------
5120 -- Enclosing_Init_Proc --
5121 -------------------------
5123 function Enclosing_Init_Proc return Entity_Id is
5128 while Present (S) and then S /= Standard_Standard loop
5129 if Is_Init_Proc (S) then
5137 end Enclosing_Init_Proc;
5139 --------------------
5140 -- Ensure_Defined --
5141 --------------------
5143 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
5147 -- An itype reference must only be created if this is a local itype, so
5148 -- that gigi can elaborate it on the proper objstack.
5150 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
5151 IR := Make_Itype_Reference (Sloc (N));
5152 Set_Itype (IR, Typ);
5153 Insert_Action (N, IR);
5157 --------------------
5158 -- Entry_Names_OK --
5159 --------------------
5161 function Entry_Names_OK return Boolean is
5164 not Restricted_Profile
5165 and then not Global_Discard_Names
5166 and then not Restriction_Active (No_Implicit_Heap_Allocations)
5167 and then not Restriction_Active (No_Local_Allocators);
5174 procedure Evaluate_Name (Nam : Node_Id) is
5177 -- For an aggregate, force its evaluation
5180 Force_Evaluation (Nam);
5182 -- For an attribute reference or an indexed component, evaluate the
5183 -- prefix, which is itself a name, recursively, and then force the
5184 -- evaluation of all the subscripts (or attribute expressions).
5186 when N_Attribute_Reference
5187 | N_Indexed_Component
5189 Evaluate_Name (Prefix (Nam));
5195 E := First (Expressions (Nam));
5196 while Present (E) loop
5197 Force_Evaluation (E);
5199 if Is_Rewrite_Substitution (E) then
5201 (E, Do_Range_Check (Original_Node (E)));
5208 -- For an explicit dereference, we simply force the evaluation of
5209 -- the name expression. The dereference provides a value that is the
5210 -- address for the renamed object, and it is precisely this value
5211 -- that we want to preserve.
5213 when N_Explicit_Dereference =>
5214 Force_Evaluation (Prefix (Nam));
5216 -- For a function call, we evaluate the call; same for an operator
5218 when N_Function_Call
5221 Force_Evaluation (Nam);
5223 -- For a qualified expression, we evaluate the expression
5225 when N_Qualified_Expression =>
5226 Evaluate_Name (Expression (Nam));
5228 -- For a selected component, we simply evaluate the prefix
5230 when N_Selected_Component =>
5231 Evaluate_Name (Prefix (Nam));
5233 -- For a slice, we evaluate the prefix, as for the indexed component
5234 -- case and then, if there is a range present, either directly or as
5235 -- the constraint of a discrete subtype indication, we evaluate the
5236 -- two bounds of this range.
5239 Evaluate_Name (Prefix (Nam));
5240 Evaluate_Slice_Bounds (Nam);
5242 -- For a type conversion, the expression of the conversion must be
5243 -- the name of an object, and we simply need to evaluate this name.
5245 when N_Type_Conversion =>
5246 Evaluate_Name (Expression (Nam));
5248 -- The remaining cases are direct name and character literal. In all
5249 -- these cases, we do nothing, since we want to reevaluate each time
5250 -- the renamed object is used. ??? There are more remaining cases, at
5251 -- least in the GNATprove_Mode, where this routine is called in more
5252 -- contexts than in GNAT.
5259 ---------------------------
5260 -- Evaluate_Slice_Bounds --
5261 ---------------------------
5263 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
5264 DR : constant Node_Id := Discrete_Range (Slice);
5269 if Nkind (DR) = N_Range then
5270 Force_Evaluation (Low_Bound (DR));
5271 Force_Evaluation (High_Bound (DR));
5273 elsif Nkind (DR) = N_Subtype_Indication then
5274 Constr := Constraint (DR);
5276 if Nkind (Constr) = N_Range_Constraint then
5277 Rexpr := Range_Expression (Constr);
5279 Force_Evaluation (Low_Bound (Rexpr));
5280 Force_Evaluation (High_Bound (Rexpr));
5283 end Evaluate_Slice_Bounds;
5285 ---------------------
5286 -- Evolve_And_Then --
5287 ---------------------
5289 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
5295 Make_And_Then (Sloc (Cond1),
5297 Right_Opnd => Cond1);
5299 end Evolve_And_Then;
5301 --------------------
5302 -- Evolve_Or_Else --
5303 --------------------
5305 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
5311 Make_Or_Else (Sloc (Cond1),
5313 Right_Opnd => Cond1);
5317 -------------------------------
5318 -- Expand_Sliding_Conversion --
5319 -------------------------------
5321 procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id) is
5323 pragma Assert (Is_Array_Type (Arr_Typ)
5324 and then not Is_Constrained (Arr_Typ)
5325 and then Is_Fixed_Lower_Bound_Array_Subtype (Arr_Typ));
5327 Constraints : List_Id;
5328 Index : Node_Id := First_Index (Arr_Typ);
5329 Loc : constant Source_Ptr := Sloc (N);
5330 Subt_Decl : Node_Id;
5333 Subt_High : Node_Id;
5335 Act_Subt : Entity_Id;
5336 Act_Index : Node_Id;
5339 Adjust_Incr : Node_Id;
5340 Dimension : Int := 0;
5341 All_FLBs_Match : Boolean := True;
5344 -- This procedure is called during semantic analysis, and we only expand
5345 -- a sliding conversion when Expander_Active, to avoid doing it during
5346 -- preanalysis (which can lead to problems with the target subtype not
5347 -- getting properly expanded during later full analysis). Also, sliding
5348 -- should never be needed for string literals, because their bounds are
5349 -- determined directly based on the fixed lower bound of Arr_Typ and
5352 if Expander_Active and then Nkind (N) /= N_String_Literal then
5353 Constraints := New_List;
5355 Act_Subt := Get_Actual_Subtype (N);
5356 Act_Index := First_Index (Act_Subt);
5358 -- Loop over the indexes of the fixed-lower-bound array type or
5359 -- subtype to build up an index constraint for constructing the
5360 -- subtype that will be the target of a conversion of the array
5361 -- object that may need a sliding conversion.
5363 while Present (Index) loop
5364 pragma Assert (Present (Act_Index));
5366 Dimension := Dimension + 1;
5368 Get_Index_Bounds (Act_Index, Act_Low, Act_High);
5370 -- If Index defines a normal unconstrained range (range <>),
5371 -- then we will simply use the bounds of the actual subtype's
5372 -- corresponding index range.
5374 if not Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) then
5375 Subt_Low := Act_Low;
5376 Subt_High := Act_High;
5378 -- Otherwise, a range will be created with a low bound given by
5379 -- the fixed lower bound of the array subtype's index, and with
5380 -- high bound given by (Actual'Length + fixed lower bound - 1).
5383 if Nkind (Index) = N_Subtype_Indication then
5386 (Low_Bound (Range_Expression (Constraint (Index))));
5388 pragma Assert (Nkind (Index) = N_Range);
5390 Subt_Low := New_Copy_Tree (Low_Bound (Index));
5393 -- If either we have a nonstatic lower bound, or the target and
5394 -- source subtypes are statically known to have unequal lower
5395 -- bounds, then we will need to make a subtype conversion to
5396 -- slide the bounds. However, if all of the indexes' lower
5397 -- bounds are static and known to be equal (the common case),
5398 -- then no conversion will be needed, and we'll end up not
5399 -- creating the subtype or the conversion (though we still
5400 -- build up the index constraint, which will simply be unused).
5402 if not (Compile_Time_Known_Value (Subt_Low)
5403 and then Compile_Time_Known_Value (Act_Low))
5404 or else Expr_Value (Subt_Low) /= Expr_Value (Act_Low)
5406 All_FLBs_Match := False;
5409 -- Apply 'Pos to lower bound, which may be of an enumeration
5410 -- type, before subtracting.
5413 Make_Op_Subtract (Loc,
5414 Make_Attribute_Reference (Loc,
5416 New_Occurrence_Of (Etype (Act_Index), Loc),
5420 New_List (New_Copy_Tree (Subt_Low))),
5421 Make_Integer_Literal (Loc, 1));
5423 -- Apply 'Val to the result of adding the increment to the
5424 -- length, to handle indexes of enumeration types.
5427 Make_Attribute_Reference (Loc,
5429 New_Occurrence_Of (Etype (Act_Index), Loc),
5433 New_List (Make_Op_Add (Loc,
5434 Make_Attribute_Reference (Loc,
5436 New_Occurrence_Of (Act_Subt, Loc),
5441 (Make_Integer_Literal
5446 Append (Make_Range (Loc, Subt_Low, Subt_High), Constraints);
5452 -- If for each index with a fixed lower bound (FLB), the lower bound
5453 -- of the corresponding index of the actual subtype is statically
5454 -- known be equal to the FLB, then a sliding conversion isn't needed
5455 -- at all, so just return without building a subtype or conversion.
5457 if All_FLBs_Match then
5461 -- A sliding conversion is needed, so create the target subtype using
5462 -- the index constraint created above, and rewrite the expression
5463 -- as a conversion to that subtype.
5465 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
5466 Set_Is_Internal (Subt);
5469 Make_Subtype_Declaration (Loc,
5470 Defining_Identifier => Subt,
5471 Subtype_Indication =>
5472 Make_Subtype_Indication (Loc,
5474 New_Occurrence_Of (Arr_Typ, Loc),
5476 Make_Index_Or_Discriminant_Constraint (Loc,
5477 Constraints => Constraints)));
5479 Mark_Rewrite_Insertion (Subt_Decl);
5481 -- The actual subtype is an Itype, so we analyze the declaration,
5482 -- but do not attach it to the tree.
5484 Set_Parent (Subt_Decl, N);
5485 Set_Is_Itype (Subt);
5486 Analyze (Subt_Decl, Suppress => All_Checks);
5487 Set_Associated_Node_For_Itype (Subt, N);
5488 Set_Has_Delayed_Freeze (Subt, False);
5490 -- We need to freeze the actual subtype immediately. This is needed
5491 -- because otherwise this Itype will not get frozen at all, and it is
5492 -- always safe to freeze on creation because any associated types
5493 -- must be frozen at this point.
5495 Freeze_Itype (Subt, N);
5498 Make_Type_Conversion (Loc,
5500 New_Occurrence_Of (Subt, Loc),
5501 Expression => Relocate_Node (N)));
5504 end Expand_Sliding_Conversion;
5506 -----------------------------------------
5507 -- Expand_Static_Predicates_In_Choices --
5508 -----------------------------------------
5510 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
5511 pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
5513 Choices : List_Id := Discrete_Choices (N);
5521 -- If this is an "others" alternative, we need to process any static
5522 -- predicates in its Others_Discrete_Choices.
5524 if Nkind (First (Choices)) = N_Others_Choice then
5525 Choices := Others_Discrete_Choices (First (Choices));
5528 Choice := First (Choices);
5529 while Present (Choice) loop
5530 Next_C := Next (Choice);
5532 -- Check for name of subtype with static predicate
5534 if Is_Entity_Name (Choice)
5535 and then Is_Type (Entity (Choice))
5536 and then Has_Predicates (Entity (Choice))
5538 -- Loop through entries in predicate list, converting to choices
5539 -- and inserting in the list before the current choice. Note that
5540 -- if the list is empty, corresponding to a False predicate, then
5541 -- no choices are inserted.
5543 P := First (Static_Discrete_Predicate (Entity (Choice)));
5544 while Present (P) loop
5546 -- If low bound and high bounds are equal, copy simple choice
5548 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
5549 C := New_Copy (Low_Bound (P));
5551 -- Otherwise copy a range
5557 -- Change Sloc to referencing choice (rather than the Sloc of
5558 -- the predicate declaration element itself).
5560 Set_Sloc (C, Sloc (Choice));
5561 Insert_Before (Choice, C);
5565 -- Delete the predicated entry
5570 -- Move to next choice to check
5575 Set_Has_SP_Choice (N, False);
5576 end Expand_Static_Predicates_In_Choices;
5578 ------------------------------
5579 -- Expand_Subtype_From_Expr --
5580 ------------------------------
5582 -- This function is applicable for both static and dynamic allocation of
5583 -- objects which are constrained by an initial expression. Basically it
5584 -- transforms an unconstrained subtype indication into a constrained one.
5586 -- The expression may also be transformed in certain cases in order to
5587 -- avoid multiple evaluation. In the static allocation case, the general
5592 -- is transformed into
5594 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
5596 -- Here are the main cases :
5598 -- <if Expr is a Slice>
5599 -- Val : T ([Index_Subtype (Expr)]) := Expr;
5601 -- <elsif Expr is a String Literal>
5602 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
5604 -- <elsif Expr is Constrained>
5605 -- subtype T is Type_Of_Expr
5608 -- <elsif Expr is an entity_name>
5609 -- Val : T (constraints taken from Expr) := Expr;
5612 -- type Axxx is access all T;
5613 -- Rval : Axxx := Expr'ref;
5614 -- Val : T (constraints taken from Rval) := Rval.all;
5616 -- ??? note: when the Expression is allocated in the secondary stack
5617 -- we could use it directly instead of copying it by declaring
5618 -- Val : T (...) renames Rval.all
5620 procedure Expand_Subtype_From_Expr
5622 Unc_Type : Entity_Id;
5623 Subtype_Indic : Node_Id;
5625 Related_Id : Entity_Id := Empty)
5627 Loc : constant Source_Ptr := Sloc (N);
5628 Exp_Typ : constant Entity_Id := Etype (Exp);
5632 -- In general we cannot build the subtype if expansion is disabled,
5633 -- because internal entities may not have been defined. However, to
5634 -- avoid some cascaded errors, we try to continue when the expression is
5635 -- an array (or string), because it is safe to compute the bounds. It is
5636 -- in fact required to do so even in a generic context, because there
5637 -- may be constants that depend on the bounds of a string literal, both
5638 -- standard string types and more generally arrays of characters.
5640 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is
5641 -- a static expression. In that case, the subtype will be constrained
5642 -- while the original type might be unconstrained, so expanding the type
5643 -- is necessary both for passing legality checks in GNAT and for precise
5644 -- analysis in GNATprove.
5646 if GNATprove_Mode and then not Is_Static_Expression (Exp) then
5650 if not Expander_Active
5651 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5656 if Nkind (Exp) = N_Slice then
5658 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5661 Rewrite (Subtype_Indic,
5662 Make_Subtype_Indication (Loc,
5663 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5665 Make_Index_Or_Discriminant_Constraint (Loc,
5666 Constraints => New_List
5667 (New_Occurrence_Of (Slice_Type, Loc)))));
5669 -- This subtype indication may be used later for constraint checks
5670 -- we better make sure that if a variable was used as a bound of
5671 -- the original slice, its value is frozen.
5673 Evaluate_Slice_Bounds (Exp);
5676 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5677 Rewrite (Subtype_Indic,
5678 Make_Subtype_Indication (Loc,
5679 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5681 Make_Index_Or_Discriminant_Constraint (Loc,
5682 Constraints => New_List (
5683 Make_Literal_Range (Loc,
5684 Literal_Typ => Exp_Typ)))));
5686 -- If the type of the expression is an internally generated type it
5687 -- may not be necessary to create a new subtype. However there are two
5688 -- exceptions: references to the current instances, and aliased array
5689 -- object declarations for which the back end has to create a template.
5691 elsif Is_Constrained (Exp_Typ)
5692 and then not Is_Class_Wide_Type (Unc_Type)
5694 (Nkind (N) /= N_Object_Declaration
5695 or else not Is_Entity_Name (Expression (N))
5696 or else not Comes_From_Source (Entity (Expression (N)))
5697 or else not Is_Array_Type (Exp_Typ)
5698 or else not Aliased_Present (N))
5700 if Is_Itype (Exp_Typ) then
5702 -- Within an initialization procedure, a selected component
5703 -- denotes a component of the enclosing record, and it appears as
5704 -- an actual in a call to its own initialization procedure. If
5705 -- this component depends on the outer discriminant, we must
5706 -- generate the proper actual subtype for it.
5708 if Nkind (Exp) = N_Selected_Component
5709 and then Within_Init_Proc
5712 Decl : constant Node_Id :=
5713 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5715 if Present (Decl) then
5716 Insert_Action (N, Decl);
5717 T := Defining_Identifier (Decl);
5723 -- No need to generate a new subtype
5730 T := Make_Temporary (Loc, 'T');
5733 Make_Subtype_Declaration (Loc,
5734 Defining_Identifier => T,
5735 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5737 -- This type is marked as an itype even though it has an explicit
5738 -- declaration since otherwise Is_Generic_Actual_Type can get
5739 -- set, resulting in the generation of spurious errors. (See
5740 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5743 Set_Associated_Node_For_Itype (T, Exp);
5746 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5748 -- Nothing needs to be done for private types with unknown discriminants
5749 -- if the underlying type is not an unconstrained composite type or it
5750 -- is an unchecked union.
5752 elsif Is_Private_Type (Unc_Type)
5753 and then Has_Unknown_Discriminants (Unc_Type)
5754 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5755 or else Is_Constrained (Underlying_Type (Unc_Type))
5756 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5760 -- Case of derived type with unknown discriminants where the parent type
5761 -- also has unknown discriminants.
5763 elsif Is_Record_Type (Unc_Type)
5764 and then not Is_Class_Wide_Type (Unc_Type)
5765 and then Has_Unknown_Discriminants (Unc_Type)
5766 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5768 -- Nothing to be done if no underlying record view available
5770 -- If this is a limited type derived from a type with unknown
5771 -- discriminants, do not expand either, so that subsequent expansion
5772 -- of the call can add build-in-place parameters to call.
5774 if No (Underlying_Record_View (Unc_Type))
5775 or else Is_Limited_Type (Unc_Type)
5779 -- Otherwise use the Underlying_Record_View to create the proper
5780 -- constrained subtype for an object of a derived type with unknown
5784 Remove_Side_Effects (Exp);
5785 Rewrite (Subtype_Indic,
5786 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5789 -- Renamings of class-wide interface types require no equivalent
5790 -- constrained type declarations because we only need to reference
5791 -- the tag component associated with the interface. The same is
5792 -- presumably true for class-wide types in general, so this test
5793 -- is broadened to include all class-wide renamings, which also
5794 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5795 -- (Is this really correct, or are there some cases of class-wide
5796 -- renamings that require action in this procedure???)
5799 and then Nkind (N) = N_Object_Renaming_Declaration
5800 and then Is_Class_Wide_Type (Unc_Type)
5804 -- In Ada 95 nothing to be done if the type of the expression is limited
5805 -- because in this case the expression cannot be copied, and its use can
5806 -- only be by reference.
5808 -- In Ada 2005 the context can be an object declaration whose expression
5809 -- is a function that returns in place. If the nominal subtype has
5810 -- unknown discriminants, the call still provides constraints on the
5811 -- object, and we have to create an actual subtype from it.
5813 -- If the type is class-wide, the expression is dynamically tagged and
5814 -- we do not create an actual subtype either. Ditto for an interface.
5815 -- For now this applies only if the type is immutably limited, and the
5816 -- function being called is build-in-place. This will have to be revised
5817 -- when build-in-place functions are generalized to other types.
5819 elsif Is_Limited_View (Exp_Typ)
5821 (Is_Class_Wide_Type (Exp_Typ)
5822 or else Is_Interface (Exp_Typ)
5823 or else not Has_Unknown_Discriminants (Exp_Typ)
5824 or else not Is_Composite_Type (Unc_Type))
5828 -- For limited objects initialized with build-in-place function calls,
5829 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5830 -- node in the expression initializing the object, which breaks the
5831 -- circuitry that detects and adds the additional arguments to the
5834 elsif Is_Build_In_Place_Function_Call (Exp) then
5837 -- If the expression is an uninitialized aggregate, no need to build
5838 -- a subtype from the expression, because this may require the use of
5839 -- dynamic memory to create the object.
5841 elsif Is_Uninitialized_Aggregate (Exp, Exp_Typ) then
5842 Rewrite (Subtype_Indic, New_Occurrence_Of (Etype (Exp), Sloc (N)));
5843 if Nkind (N) = N_Object_Declaration then
5844 Set_Expression (N, Empty);
5845 Set_No_Initialization (N);
5849 Remove_Side_Effects (Exp);
5850 Rewrite (Subtype_Indic,
5851 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5853 end Expand_Subtype_From_Expr;
5855 ---------------------------------------------
5856 -- Expression_Contains_Primitives_Calls_Of --
5857 ---------------------------------------------
5859 function Expression_Contains_Primitives_Calls_Of
5861 Typ : Entity_Id) return Boolean
5863 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5865 Calls_OK : Boolean := False;
5866 -- This flag is set to True when expression Expr contains at least one
5867 -- call to a nondispatching primitive function of Typ.
5869 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5870 -- Search for nondispatching calls to primitive functions of type Typ
5872 ----------------------------
5873 -- Search_Primitive_Calls --
5874 ----------------------------
5876 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5877 Disp_Typ : Entity_Id;
5881 -- Detect a function call that could denote a nondispatching
5882 -- primitive of the input type.
5884 if Nkind (N) = N_Function_Call
5885 and then Is_Entity_Name (Name (N))
5887 Subp := Entity (Name (N));
5889 -- Do not consider function calls with a controlling argument, as
5890 -- those are always dispatching calls.
5892 if Is_Dispatching_Operation (Subp)
5893 and then No (Controlling_Argument (N))
5895 Disp_Typ := Find_Dispatching_Type (Subp);
5897 -- To qualify as a suitable primitive, the dispatching type of
5898 -- the function must be the input type.
5900 if Present (Disp_Typ)
5901 and then Unique_Entity (Disp_Typ) = U_Typ
5905 -- There is no need to continue the traversal, as one such
5914 end Search_Primitive_Calls;
5916 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5918 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5921 Search_Calls (Expr);
5923 end Expression_Contains_Primitives_Calls_Of;
5925 ----------------------
5926 -- Finalize_Address --
5927 ----------------------
5929 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5930 Btyp : constant Entity_Id := Base_Type (Typ);
5931 Utyp : Entity_Id := Typ;
5934 -- Handle protected class-wide or task class-wide types
5936 if Is_Class_Wide_Type (Utyp) then
5937 if Is_Concurrent_Type (Root_Type (Utyp)) then
5938 Utyp := Root_Type (Utyp);
5940 elsif Is_Private_Type (Root_Type (Utyp))
5941 and then Present (Full_View (Root_Type (Utyp)))
5942 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5944 Utyp := Full_View (Root_Type (Utyp));
5948 -- Handle private types
5950 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5951 Utyp := Full_View (Utyp);
5954 -- Handle protected and task types
5956 if Is_Concurrent_Type (Utyp)
5957 and then Present (Corresponding_Record_Type (Utyp))
5959 Utyp := Corresponding_Record_Type (Utyp);
5962 Utyp := Underlying_Type (Base_Type (Utyp));
5964 -- Deal with untagged derivation of private views. If the parent is
5965 -- now known to be protected, the finalization routine is the one
5966 -- defined on the corresponding record of the ancestor (corresponding
5967 -- records do not automatically inherit operations, but maybe they
5970 if Is_Untagged_Derivation (Btyp) then
5971 if Is_Protected_Type (Btyp) then
5972 Utyp := Corresponding_Record_Type (Root_Type (Btyp));
5975 Utyp := Underlying_Type (Root_Type (Btyp));
5977 if Is_Protected_Type (Utyp) then
5978 Utyp := Corresponding_Record_Type (Utyp);
5983 -- If the underlying_type is a subtype, we are dealing with the
5984 -- completion of a private type. We need to access the base type and
5985 -- generate a conversion to it.
5987 if Utyp /= Base_Type (Utyp) then
5988 pragma Assert (Is_Private_Type (Typ));
5990 Utyp := Base_Type (Utyp);
5993 -- When dealing with an internally built full view for a type with
5994 -- unknown discriminants, use the original record type.
5996 if Is_Underlying_Record_View (Utyp) then
5997 Utyp := Etype (Utyp);
6000 return TSS (Utyp, TSS_Finalize_Address);
6001 end Finalize_Address;
6003 ------------------------
6004 -- Find_Interface_ADT --
6005 ------------------------
6007 function Find_Interface_ADT
6009 Iface : Entity_Id) return Elmt_Id
6012 Typ : Entity_Id := T;
6015 pragma Assert (Is_Interface (Iface));
6017 -- Handle private types
6019 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
6020 Typ := Full_View (Typ);
6023 -- Handle access types
6025 if Is_Access_Type (Typ) then
6026 Typ := Designated_Type (Typ);
6029 -- Handle task and protected types implementing interfaces
6031 if Is_Concurrent_Type (Typ) then
6032 Typ := Corresponding_Record_Type (Typ);
6036 (not Is_Class_Wide_Type (Typ)
6037 and then Ekind (Typ) /= E_Incomplete_Type);
6039 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
6040 return First_Elmt (Access_Disp_Table (Typ));
6043 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
6045 and then Present (Related_Type (Node (ADT)))
6046 and then Related_Type (Node (ADT)) /= Iface
6047 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
6048 Use_Full_View => True)
6053 pragma Assert (Present (Related_Type (Node (ADT))));
6056 end Find_Interface_ADT;
6058 ------------------------
6059 -- Find_Interface_Tag --
6060 ------------------------
6062 function Find_Interface_Tag
6064 Iface : Entity_Id) return Entity_Id
6066 AI_Tag : Entity_Id := Empty;
6067 Found : Boolean := False;
6068 Typ : Entity_Id := T;
6070 procedure Find_Tag (Typ : Entity_Id);
6071 -- Internal subprogram used to recursively climb to the ancestors
6077 procedure Find_Tag (Typ : Entity_Id) is
6082 -- This routine does not handle the case in which the interface is an
6083 -- ancestor of Typ. That case is handled by the enclosing subprogram.
6085 pragma Assert (Typ /= Iface);
6087 -- Climb to the root type handling private types
6089 if Present (Full_View (Etype (Typ))) then
6090 if Full_View (Etype (Typ)) /= Typ then
6091 Find_Tag (Full_View (Etype (Typ)));
6094 elsif Etype (Typ) /= Typ then
6095 Find_Tag (Etype (Typ));
6098 -- Traverse the list of interfaces implemented by the type
6101 and then Present (Interfaces (Typ))
6102 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
6104 -- Skip the tag associated with the primary table
6106 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
6107 pragma Assert (Present (AI_Tag));
6109 AI_Elmt := First_Elmt (Interfaces (Typ));
6110 while Present (AI_Elmt) loop
6111 AI := Node (AI_Elmt);
6114 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
6120 AI_Tag := Next_Tag_Component (AI_Tag);
6121 Next_Elmt (AI_Elmt);
6126 -- Start of processing for Find_Interface_Tag
6129 pragma Assert (Is_Interface (Iface));
6131 -- Handle access types
6133 if Is_Access_Type (Typ) then
6134 Typ := Designated_Type (Typ);
6137 -- Handle class-wide types
6139 if Is_Class_Wide_Type (Typ) then
6140 Typ := Root_Type (Typ);
6143 -- Handle private types
6145 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
6146 Typ := Full_View (Typ);
6149 -- Handle entities from the limited view
6151 if Ekind (Typ) = E_Incomplete_Type then
6152 pragma Assert (Present (Non_Limited_View (Typ)));
6153 Typ := Non_Limited_View (Typ);
6156 -- Handle task and protected types implementing interfaces
6158 if Is_Concurrent_Type (Typ) then
6159 Typ := Corresponding_Record_Type (Typ);
6162 -- If the interface is an ancestor of the type, then it shared the
6163 -- primary dispatch table.
6165 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
6166 return First_Tag_Component (Typ);
6168 -- Otherwise we need to search for its associated tag component
6174 end Find_Interface_Tag;
6176 ---------------------------
6177 -- Find_Optional_Prim_Op --
6178 ---------------------------
6180 function Find_Optional_Prim_Op
6181 (T : Entity_Id; Name : Name_Id) return Entity_Id
6184 Typ : Entity_Id := T;
6188 if Is_Class_Wide_Type (Typ) then
6189 Typ := Root_Type (Typ);
6192 Typ := Underlying_Type (Typ);
6194 -- Loop through primitive operations
6196 Prim := First_Elmt (Primitive_Operations (Typ));
6197 while Present (Prim) loop
6200 -- We can retrieve primitive operations by name if it is an internal
6201 -- name. For equality we must check that both of its operands have
6202 -- the same type, to avoid confusion with user-defined equalities
6203 -- than may have a asymmetric signature.
6205 exit when Chars (Op) = Name
6208 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
6213 return Node (Prim); -- Empty if not found
6214 end Find_Optional_Prim_Op;
6216 ---------------------------
6217 -- Find_Optional_Prim_Op --
6218 ---------------------------
6220 function Find_Optional_Prim_Op
6222 Name : TSS_Name_Type) return Entity_Id
6224 Inher_Op : Entity_Id := Empty;
6225 Own_Op : Entity_Id := Empty;
6226 Prim_Elmt : Elmt_Id;
6227 Prim_Id : Entity_Id;
6228 Typ : Entity_Id := T;
6231 if Is_Class_Wide_Type (Typ) then
6232 Typ := Root_Type (Typ);
6235 Typ := Underlying_Type (Typ);
6237 -- This search is based on the assertion that the dispatching version
6238 -- of the TSS routine always precedes the real primitive.
6240 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6241 while Present (Prim_Elmt) loop
6242 Prim_Id := Node (Prim_Elmt);
6244 if Is_TSS (Prim_Id, Name) then
6245 if Present (Alias (Prim_Id)) then
6246 Inher_Op := Prim_Id;
6252 Next_Elmt (Prim_Elmt);
6255 if Present (Own_Op) then
6257 elsif Present (Inher_Op) then
6262 end Find_Optional_Prim_Op;
6268 function Find_Prim_Op
6269 (T : Entity_Id; Name : Name_Id) return Entity_Id
6271 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
6274 raise Program_Error;
6284 function Find_Prim_Op
6286 Name : TSS_Name_Type) return Entity_Id
6288 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
6291 raise Program_Error;
6297 ----------------------------
6298 -- Find_Protection_Object --
6299 ----------------------------
6301 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
6306 while Present (S) loop
6307 if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure
6308 and then Present (Protection_Object (S))
6310 return Protection_Object (S);
6316 -- If we do not find a Protection object in the scope chain, then
6317 -- something has gone wrong, most likely the object was never created.
6319 raise Program_Error;
6320 end Find_Protection_Object;
6322 --------------------------
6323 -- Find_Protection_Type --
6324 --------------------------
6326 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
6328 Typ : Entity_Id := Conc_Typ;
6331 if Is_Concurrent_Type (Typ) then
6332 Typ := Corresponding_Record_Type (Typ);
6335 -- Since restriction violations are not considered serious errors, the
6336 -- expander remains active, but may leave the corresponding record type
6337 -- malformed. In such cases, component _object is not available so do
6340 if not Analyzed (Typ) then
6344 Comp := First_Component (Typ);
6345 while Present (Comp) loop
6346 if Chars (Comp) = Name_uObject then
6347 return Base_Type (Etype (Comp));
6350 Next_Component (Comp);
6353 -- The corresponding record of a protected type should always have an
6356 raise Program_Error;
6357 end Find_Protection_Type;
6359 -----------------------
6360 -- Find_Hook_Context --
6361 -----------------------
6363 function Find_Hook_Context (N : Node_Id) return Node_Id is
6367 Wrapped_Node : Node_Id;
6368 -- Note: if we are in a transient scope, we want to reuse it as
6369 -- the context for actions insertion, if possible. But if N is itself
6370 -- part of the stored actions for the current transient scope,
6371 -- then we need to insert at the appropriate (inner) location in
6372 -- the not as an action on Node_To_Be_Wrapped.
6374 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
6377 -- When the node is inside a case/if expression, the lifetime of any
6378 -- temporary controlled object is extended. Find a suitable insertion
6379 -- node by locating the topmost case or if expressions.
6381 if In_Cond_Expr then
6384 while Present (Par) loop
6385 if Nkind (Original_Node (Par)) in
6386 N_Case_Expression | N_If_Expression
6390 -- Prevent the search from going too far
6392 elsif Is_Body_Or_Package_Declaration (Par) then
6396 Par := Parent (Par);
6399 -- The topmost case or if expression is now recovered, but it may
6400 -- still not be the correct place to add generated code. Climb to
6401 -- find a parent that is part of a declarative or statement list,
6402 -- and is not a list of actuals in a call.
6405 while Present (Par) loop
6406 if Is_List_Member (Par)
6407 and then Nkind (Par) not in N_Component_Association
6408 | N_Discriminant_Association
6409 | N_Parameter_Association
6410 | N_Pragma_Argument_Association
6413 | N_Extension_Aggregate
6414 and then Nkind (Parent (Par)) not in N_Function_Call
6415 | N_Procedure_Call_Statement
6416 | N_Entry_Call_Statement
6421 -- Prevent the search from going too far
6423 elsif Is_Body_Or_Package_Declaration (Par) then
6427 Par := Parent (Par);
6434 while Present (Par) loop
6436 -- Keep climbing past various operators
6438 if Nkind (Parent (Par)) in N_Op
6439 or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else
6441 Par := Parent (Par);
6449 -- The node may be located in a pragma in which case return the
6452 -- pragma Precondition (... and then Ctrl_Func_Call ...);
6454 -- Similar case occurs when the node is related to an object
6455 -- declaration or assignment:
6457 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
6459 -- Another case to consider is when the node is part of a return
6462 -- return ... and then Ctrl_Func_Call ...;
6464 -- Another case is when the node acts as a formal in a procedure
6467 -- Proc (... and then Ctrl_Func_Call ...);
6469 if Scope_Is_Transient then
6470 Wrapped_Node := Node_To_Be_Wrapped;
6472 Wrapped_Node := Empty;
6475 while Present (Par) loop
6476 if Par = Wrapped_Node
6477 or else Nkind (Par) in N_Assignment_Statement
6478 | N_Object_Declaration
6480 | N_Procedure_Call_Statement
6481 | N_Simple_Return_Statement
6485 -- Prevent the search from going too far
6487 elsif Is_Body_Or_Package_Declaration (Par) then
6491 Par := Parent (Par);
6494 -- Return the topmost short circuit operator
6498 end Find_Hook_Context;
6500 ------------------------------
6501 -- Following_Address_Clause --
6502 ------------------------------
6504 function Following_Address_Clause (D : Node_Id) return Node_Id is
6505 Id : constant Entity_Id := Defining_Identifier (D);
6509 function Check_Decls (D : Node_Id) return Node_Id;
6510 -- This internal function differs from the main function in that it
6511 -- gets called to deal with a following package private part, and
6512 -- it checks declarations starting with D (the main function checks
6513 -- declarations following D). If D is Empty, then Empty is returned.
6519 function Check_Decls (D : Node_Id) return Node_Id is
6524 while Present (Decl) loop
6525 if Nkind (Decl) = N_At_Clause
6526 and then Chars (Identifier (Decl)) = Chars (Id)
6530 elsif Nkind (Decl) = N_Attribute_Definition_Clause
6531 and then Chars (Decl) = Name_Address
6532 and then Chars (Name (Decl)) = Chars (Id)
6540 -- Otherwise not found, return Empty
6545 -- Start of processing for Following_Address_Clause
6548 -- If parser detected no address clause for the identifier in question,
6549 -- then the answer is a quick NO, without the need for a search.
6551 if not Get_Name_Table_Boolean1 (Chars (Id)) then
6555 -- Otherwise search current declarative unit
6557 Result := Check_Decls (Next (D));
6559 if Present (Result) then
6563 -- Check for possible package private part following
6567 if Nkind (Par) = N_Package_Specification
6568 and then Visible_Declarations (Par) = List_Containing (D)
6569 and then Present (Private_Declarations (Par))
6571 -- Private part present, check declarations there
6573 return Check_Decls (First (Private_Declarations (Par)));
6576 -- No private part, clause not found, return Empty
6580 end Following_Address_Clause;
6582 ----------------------
6583 -- Force_Evaluation --
6584 ----------------------
6586 procedure Force_Evaluation
6588 Name_Req : Boolean := False;
6589 Related_Id : Entity_Id := Empty;
6590 Is_Low_Bound : Boolean := False;
6591 Is_High_Bound : Boolean := False;
6592 Mode : Force_Evaluation_Mode := Relaxed)
6597 Name_Req => Name_Req,
6598 Variable_Ref => True,
6599 Renaming_Req => False,
6600 Related_Id => Related_Id,
6601 Is_Low_Bound => Is_Low_Bound,
6602 Is_High_Bound => Is_High_Bound,
6603 Check_Side_Effects =>
6604 Is_Static_Expression (Exp)
6605 or else Mode = Relaxed);
6606 end Force_Evaluation;
6608 ---------------------------------
6609 -- Fully_Qualified_Name_String --
6610 ---------------------------------
6612 function Fully_Qualified_Name_String
6614 Append_NUL : Boolean := True) return String_Id
6616 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6617 -- Compute recursively the qualified name without NUL at the end, adding
6618 -- it to the currently started string being generated
6620 ----------------------------------
6621 -- Internal_Full_Qualified_Name --
6622 ----------------------------------
6624 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6628 -- Deal properly with child units
6630 if Nkind (E) = N_Defining_Program_Unit_Name then
6631 Ent := Defining_Identifier (E);
6636 -- Compute qualification recursively (only "Standard" has no scope)
6638 if Present (Scope (Scope (Ent))) then
6639 Internal_Full_Qualified_Name (Scope (Ent));
6640 Store_String_Char (Get_Char_Code ('.'));
6643 -- Every entity should have a name except some expanded blocks
6644 -- don't bother about those.
6646 if Chars (Ent) = No_Name then
6650 -- Generates the entity name in upper case
6652 Get_Decoded_Name_String (Chars (Ent));
6654 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6656 end Internal_Full_Qualified_Name;
6658 -- Start of processing for Full_Qualified_Name
6662 Internal_Full_Qualified_Name (E);
6665 Store_String_Char (Get_Char_Code (ASCII.NUL));
6669 end Fully_Qualified_Name_String;
6671 ---------------------------------
6672 -- Get_Current_Value_Condition --
6673 ---------------------------------
6675 -- Note: the implementation of this procedure is very closely tied to the
6676 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6677 -- interpret Current_Value fields set by the Set procedure, so the two
6678 -- procedures need to be closely coordinated.
6680 procedure Get_Current_Value_Condition
6685 Loc : constant Source_Ptr := Sloc (Var);
6686 Ent : constant Entity_Id := Entity (Var);
6688 procedure Process_Current_Value_Condition (N : Node_Id; S : Boolean);
6689 -- N is an expression which holds either True (S = True) or False (S =
6690 -- False) in the condition. This procedure digs out the expression and
6691 -- if it refers to Ent, sets Op and Val appropriately.
6693 -------------------------------------
6694 -- Process_Current_Value_Condition --
6695 -------------------------------------
6697 procedure Process_Current_Value_Condition
6702 Prev_Cond : Node_Id;
6712 -- Deal with NOT operators, inverting sense
6714 while Nkind (Cond) = N_Op_Not loop
6715 Cond := Right_Opnd (Cond);
6719 -- Deal with conversions, qualifications, and expressions with
6722 while Nkind (Cond) in N_Type_Conversion
6723 | N_Qualified_Expression
6724 | N_Expression_With_Actions
6726 Cond := Expression (Cond);
6729 exit when Cond = Prev_Cond;
6732 -- Deal with AND THEN and AND cases
6734 if Nkind (Cond) in N_And_Then | N_Op_And then
6736 -- Don't ever try to invert a condition that is of the form of an
6737 -- AND or AND THEN (since we are not doing sufficiently general
6738 -- processing to allow this).
6740 if Sens = False then
6746 -- Recursively process AND and AND THEN branches
6748 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6749 pragma Assert (Op'Valid);
6751 if Op /= N_Empty then
6755 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6758 -- Case of relational operator
6760 elsif Nkind (Cond) in N_Op_Compare then
6763 -- Invert sense of test if inverted test
6765 if Sens = False then
6767 when N_Op_Eq => Op := N_Op_Ne;
6768 when N_Op_Ne => Op := N_Op_Eq;
6769 when N_Op_Lt => Op := N_Op_Ge;
6770 when N_Op_Gt => Op := N_Op_Le;
6771 when N_Op_Le => Op := N_Op_Gt;
6772 when N_Op_Ge => Op := N_Op_Lt;
6773 when others => raise Program_Error;
6777 -- Case of entity op value
6779 if Is_Entity_Name (Left_Opnd (Cond))
6780 and then Ent = Entity (Left_Opnd (Cond))
6781 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6783 Val := Right_Opnd (Cond);
6785 -- Case of value op entity
6787 elsif Is_Entity_Name (Right_Opnd (Cond))
6788 and then Ent = Entity (Right_Opnd (Cond))
6789 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6791 Val := Left_Opnd (Cond);
6793 -- We are effectively swapping operands
6796 when N_Op_Eq => null;
6797 when N_Op_Ne => null;
6798 when N_Op_Lt => Op := N_Op_Gt;
6799 when N_Op_Gt => Op := N_Op_Lt;
6800 when N_Op_Le => Op := N_Op_Ge;
6801 when N_Op_Ge => Op := N_Op_Le;
6802 when others => raise Program_Error;
6811 elsif Nkind (Cond) in N_Type_Conversion
6812 | N_Qualified_Expression
6813 | N_Expression_With_Actions
6815 Cond := Expression (Cond);
6817 -- Case of Boolean variable reference, return as though the
6818 -- reference had said var = True.
6821 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6822 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6824 if Sens = False then
6831 end Process_Current_Value_Condition;
6833 -- Start of processing for Get_Current_Value_Condition
6839 -- Immediate return, nothing doing, if this is not an object
6841 if not Is_Object (Ent) then
6845 -- In GNATprove mode we don't want to use current value optimizer, in
6846 -- particular for loop invariant expressions and other assertions that
6847 -- act as cut points for proof. The optimizer often folds expressions
6848 -- into True/False where they trivially follow from the previous
6849 -- assignments, but this deprives proof from the information needed to
6850 -- discharge checks that are beyond the scope of the value optimizer.
6852 if GNATprove_Mode then
6856 -- Otherwise examine current value
6859 CV : constant Node_Id := Current_Value (Ent);
6864 -- If statement. Condition is known true in THEN section, known False
6865 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6867 if Nkind (CV) = N_If_Statement then
6869 -- Before start of IF statement
6871 if Loc < Sloc (CV) then
6874 -- After end of IF statement
6876 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6880 -- At this stage we know that we are within the IF statement, but
6881 -- unfortunately, the tree does not record the SLOC of the ELSE so
6882 -- we cannot use a simple SLOC comparison to distinguish between
6883 -- the then/else statements, so we have to climb the tree.
6890 while Parent (N) /= CV loop
6893 -- If we fall off the top of the tree, then that's odd, but
6894 -- perhaps it could occur in some error situation, and the
6895 -- safest response is simply to assume that the outcome of
6896 -- the condition is unknown. No point in bombing during an
6897 -- attempt to optimize things.
6904 -- Now we have N pointing to a node whose parent is the IF
6905 -- statement in question, so now we can tell if we are within
6906 -- the THEN statements.
6908 if Is_List_Member (N)
6909 and then List_Containing (N) = Then_Statements (CV)
6913 -- If the variable reference does not come from source, we
6914 -- cannot reliably tell whether it appears in the else part.
6915 -- In particular, if it appears in generated code for a node
6916 -- that requires finalization, it may be attached to a list
6917 -- that has not been yet inserted into the code. For now,
6918 -- treat it as unknown.
6920 elsif not Comes_From_Source (N) then
6923 -- Otherwise we must be in ELSIF or ELSE part
6930 -- ELSIF part. Condition is known true within the referenced
6931 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6932 -- and unknown before the ELSE part or after the IF statement.
6934 elsif Nkind (CV) = N_Elsif_Part then
6936 -- if the Elsif_Part had condition_actions, the elsif has been
6937 -- rewritten as a nested if, and the original elsif_part is
6938 -- detached from the tree, so there is no way to obtain useful
6939 -- information on the current value of the variable.
6940 -- Can this be improved ???
6942 if No (Parent (CV)) then
6948 -- If the tree has been otherwise rewritten there is nothing
6949 -- else to be done either.
6951 if Nkind (Stm) /= N_If_Statement then
6955 -- Before start of ELSIF part
6957 if Loc < Sloc (CV) then
6960 -- After end of IF statement
6962 elsif Loc >= Sloc (Stm) +
6963 Text_Ptr (UI_To_Int (End_Span (Stm)))
6968 -- Again we lack the SLOC of the ELSE, so we need to climb the
6969 -- tree to see if we are within the ELSIF part in question.
6976 while Parent (N) /= Stm loop
6979 -- If we fall off the top of the tree, then that's odd, but
6980 -- perhaps it could occur in some error situation, and the
6981 -- safest response is simply to assume that the outcome of
6982 -- the condition is unknown. No point in bombing during an
6983 -- attempt to optimize things.
6990 -- Now we have N pointing to a node whose parent is the IF
6991 -- statement in question, so see if is the ELSIF part we want.
6992 -- the THEN statements.
6997 -- Otherwise we must be in subsequent ELSIF or ELSE part
7004 -- Iteration scheme of while loop. The condition is known to be
7005 -- true within the body of the loop.
7007 elsif Nkind (CV) = N_Iteration_Scheme then
7009 Loop_Stmt : constant Node_Id := Parent (CV);
7012 -- Before start of body of loop
7014 if Loc < Sloc (Loop_Stmt) then
7017 -- After end of LOOP statement
7019 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
7022 -- We are within the body of the loop
7029 -- All other cases of Current_Value settings
7035 -- If we fall through here, then we have a reportable condition, Sens
7036 -- is True if the condition is true and False if it needs inverting.
7038 Process_Current_Value_Condition (Condition (CV), Sens);
7040 end Get_Current_Value_Condition;
7042 -----------------------
7043 -- Get_Index_Subtype --
7044 -----------------------
7046 function Get_Index_Subtype (N : Node_Id) return Node_Id is
7047 P_Type : Entity_Id := Etype (Prefix (N));
7052 if Is_Access_Type (P_Type) then
7053 P_Type := Designated_Type (P_Type);
7056 if No (Expressions (N)) then
7059 J := UI_To_Int (Expr_Value (First (Expressions (N))));
7062 Indx := First_Index (P_Type);
7068 return Etype (Indx);
7069 end Get_Index_Subtype;
7071 ---------------------
7072 -- Get_Stream_Size --
7073 ---------------------
7075 function Get_Stream_Size (E : Entity_Id) return Uint is
7077 -- If we have a Stream_Size clause for this type use it
7079 if Has_Stream_Size_Clause (E) then
7080 return Static_Integer (Expression (Stream_Size_Clause (E)));
7082 -- Otherwise the Stream_Size is the size of the type
7087 end Get_Stream_Size;
7089 ---------------------------
7090 -- Has_Access_Constraint --
7091 ---------------------------
7093 function Has_Access_Constraint (E : Entity_Id) return Boolean is
7095 T : constant Entity_Id := Etype (E);
7098 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
7099 Disc := First_Discriminant (T);
7100 while Present (Disc) loop
7101 if Is_Access_Type (Etype (Disc)) then
7105 Next_Discriminant (Disc);
7112 end Has_Access_Constraint;
7114 --------------------
7115 -- Homonym_Number --
7116 --------------------
7118 function Homonym_Number (Subp : Entity_Id) return Pos is
7119 Hom : Entity_Id := Homonym (Subp);
7123 while Present (Hom) loop
7124 if Scope (Hom) = Scope (Subp) then
7128 Hom := Homonym (Hom);
7134 -----------------------------------
7135 -- In_Library_Level_Package_Body --
7136 -----------------------------------
7138 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
7140 -- First determine whether the entity appears at the library level, then
7141 -- look at the containing unit.
7143 if Is_Library_Level_Entity (Id) then
7145 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
7148 return Nkind (Unit (Container)) = N_Package_Body;
7153 end In_Library_Level_Package_Body;
7155 ------------------------------
7156 -- In_Unconditional_Context --
7157 ------------------------------
7159 function In_Unconditional_Context (Node : Node_Id) return Boolean is
7164 while Present (P) loop
7166 when N_Subprogram_Body => return True;
7167 when N_If_Statement => return False;
7168 when N_Loop_Statement => return False;
7169 when N_Case_Statement => return False;
7170 when others => P := Parent (P);
7175 end In_Unconditional_Context;
7181 procedure Insert_Action
7182 (Assoc_Node : Node_Id;
7183 Ins_Action : Node_Id;
7184 Spec_Expr_OK : Boolean := False)
7187 if Present (Ins_Action) then
7189 (Assoc_Node => Assoc_Node,
7190 Ins_Actions => New_List (Ins_Action),
7191 Spec_Expr_OK => Spec_Expr_OK);
7195 -- Version with check(s) suppressed
7197 procedure Insert_Action
7198 (Assoc_Node : Node_Id;
7199 Ins_Action : Node_Id;
7200 Suppress : Check_Id;
7201 Spec_Expr_OK : Boolean := False)
7205 (Assoc_Node => Assoc_Node,
7206 Ins_Actions => New_List (Ins_Action),
7207 Suppress => Suppress,
7208 Spec_Expr_OK => Spec_Expr_OK);
7211 -------------------------
7212 -- Insert_Action_After --
7213 -------------------------
7215 procedure Insert_Action_After
7216 (Assoc_Node : Node_Id;
7217 Ins_Action : Node_Id)
7220 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
7221 end Insert_Action_After;
7223 --------------------
7224 -- Insert_Actions --
7225 --------------------
7227 procedure Insert_Actions
7228 (Assoc_Node : Node_Id;
7229 Ins_Actions : List_Id;
7230 Spec_Expr_OK : Boolean := False)
7235 Wrapped_Node : Node_Id := Empty;
7238 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
7242 -- Insert the action when the context is "Handling of Default and Per-
7243 -- Object Expressions" only when requested by the caller.
7245 if Spec_Expr_OK then
7248 -- Ignore insert of actions from inside default expression (or other
7249 -- similar "spec expression") in the special spec-expression analyze
7250 -- mode. Any insertions at this point have no relevance, since we are
7251 -- only doing the analyze to freeze the types of any static expressions.
7252 -- See section "Handling of Default and Per-Object Expressions" in the
7253 -- spec of package Sem for further details.
7255 elsif In_Spec_Expression then
7259 -- If the action derives from stuff inside a record, then the actions
7260 -- are attached to the current scope, to be inserted and analyzed on
7261 -- exit from the scope. The reason for this is that we may also be
7262 -- generating freeze actions at the same time, and they must eventually
7263 -- be elaborated in the correct order.
7265 if Is_Record_Type (Current_Scope)
7266 and then not Is_Frozen (Current_Scope)
7268 if No (Scope_Stack.Table
7269 (Scope_Stack.Last).Pending_Freeze_Actions)
7271 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
7276 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
7282 -- We now intend to climb up the tree to find the right point to
7283 -- insert the actions. We start at Assoc_Node, unless this node is a
7284 -- subexpression in which case we start with its parent. We do this for
7285 -- two reasons. First it speeds things up. Second, if Assoc_Node is
7286 -- itself one of the special nodes like N_And_Then, then we assume that
7287 -- an initial request to insert actions for such a node does not expect
7288 -- the actions to get deposited in the node for later handling when the
7289 -- node is expanded, since clearly the node is being dealt with by the
7290 -- caller. Note that in the subexpression case, N is always the child we
7293 -- N_Raise_xxx_Error is an annoying special case, it is a statement
7294 -- if it has type Standard_Void_Type, and a subexpression otherwise.
7295 -- Procedure calls, and similarly procedure attribute references, are
7298 if Nkind (Assoc_Node) in N_Subexpr
7299 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
7300 or else Etype (Assoc_Node) /= Standard_Void_Type)
7301 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
7302 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
7303 or else not Is_Procedure_Attribute_Name
7304 (Attribute_Name (Assoc_Node)))
7307 P := Parent (Assoc_Node);
7309 -- Nonsubexpression case. Note that N is initially Empty in this case
7310 -- (N is only guaranteed non-Empty in the subexpr case).
7317 -- Capture root of the transient scope
7319 if Scope_Is_Transient then
7320 Wrapped_Node := Node_To_Be_Wrapped;
7324 pragma Assert (Present (P));
7326 -- Make sure that inserted actions stay in the transient scope
7328 if Present (Wrapped_Node) and then N = Wrapped_Node then
7329 Store_Before_Actions_In_Scope (Ins_Actions);
7335 -- Case of right operand of AND THEN or OR ELSE. Put the actions
7336 -- in the Actions field of the right operand. They will be moved
7337 -- out further when the AND THEN or OR ELSE operator is expanded.
7338 -- Nothing special needs to be done for the left operand since
7339 -- in that case the actions are executed unconditionally.
7341 when N_Short_Circuit =>
7342 if N = Right_Opnd (P) then
7344 -- We are now going to either append the actions to the
7345 -- actions field of the short-circuit operation. We will
7346 -- also analyze the actions now.
7348 -- This analysis is really too early, the proper thing would
7349 -- be to just park them there now, and only analyze them if
7350 -- we find we really need them, and to it at the proper
7351 -- final insertion point. However attempting to this proved
7352 -- tricky, so for now we just kill current values before and
7353 -- after the analyze call to make sure we avoid peculiar
7354 -- optimizations from this out of order insertion.
7356 Kill_Current_Values;
7358 -- If P has already been expanded, we can't park new actions
7359 -- on it, so we need to expand them immediately, introducing
7360 -- an Expression_With_Actions. N can't be an expression
7361 -- with actions, or else then the actions would have been
7362 -- inserted at an inner level.
7364 if Analyzed (P) then
7365 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
7367 Make_Expression_With_Actions (Sloc (N),
7368 Actions => Ins_Actions,
7369 Expression => Relocate_Node (N)));
7370 Analyze_And_Resolve (N);
7372 elsif Present (Actions (P)) then
7373 Insert_List_After_And_Analyze
7374 (Last (Actions (P)), Ins_Actions);
7376 Set_Actions (P, Ins_Actions);
7377 Analyze_List (Actions (P));
7380 Kill_Current_Values;
7385 -- Then or Else dependent expression of an if expression. Add
7386 -- actions to Then_Actions or Else_Actions field as appropriate.
7387 -- The actions will be moved further out when the if is expanded.
7389 when N_If_Expression =>
7391 ThenX : constant Node_Id := Next (First (Expressions (P)));
7392 ElseX : constant Node_Id := Next (ThenX);
7395 -- If the enclosing expression is already analyzed, as
7396 -- is the case for nested elaboration checks, insert the
7397 -- conditional further out.
7399 if Analyzed (P) then
7402 -- Actions belong to the then expression, temporarily place
7403 -- them as Then_Actions of the if expression. They will be
7404 -- moved to the proper place later when the if expression is
7407 elsif N = ThenX then
7408 if Present (Then_Actions (P)) then
7409 Insert_List_After_And_Analyze
7410 (Last (Then_Actions (P)), Ins_Actions);
7412 Set_Then_Actions (P, Ins_Actions);
7413 Analyze_List (Then_Actions (P));
7418 -- Else_Actions is treated the same as Then_Actions above
7420 elsif N = ElseX then
7421 if Present (Else_Actions (P)) then
7422 Insert_List_After_And_Analyze
7423 (Last (Else_Actions (P)), Ins_Actions);
7425 Set_Else_Actions (P, Ins_Actions);
7426 Analyze_List (Else_Actions (P));
7431 -- Actions belong to the condition. In this case they are
7432 -- unconditionally executed, and so we can continue the
7433 -- search for the proper insert point.
7440 -- Alternative of case expression, we place the action in the
7441 -- Actions field of the case expression alternative, this will
7442 -- be handled when the case expression is expanded.
7444 when N_Case_Expression_Alternative =>
7445 if Present (Actions (P)) then
7446 Insert_List_After_And_Analyze
7447 (Last (Actions (P)), Ins_Actions);
7449 Set_Actions (P, Ins_Actions);
7450 Analyze_List (Actions (P));
7455 -- Case of appearing within an Expressions_With_Actions node. When
7456 -- the new actions come from the expression of the expression with
7457 -- actions, they must be added to the existing actions. The other
7458 -- alternative is when the new actions are related to one of the
7459 -- existing actions of the expression with actions, and should
7460 -- never reach here: if actions are inserted on a statement
7461 -- within the Actions of an expression with actions, or on some
7462 -- subexpression of such a statement, then the outermost proper
7463 -- insertion point is right before the statement, and we should
7464 -- never climb up as far as the N_Expression_With_Actions itself.
7466 when N_Expression_With_Actions =>
7467 if N = Expression (P) then
7468 if Is_Empty_List (Actions (P)) then
7469 Append_List_To (Actions (P), Ins_Actions);
7470 Analyze_List (Actions (P));
7472 Insert_List_After_And_Analyze
7473 (Last (Actions (P)), Ins_Actions);
7479 raise Program_Error;
7482 -- Case of appearing in the condition of a while expression or
7483 -- elsif. We insert the actions into the Condition_Actions field.
7484 -- They will be moved further out when the while loop or elsif
7488 | N_Iteration_Scheme
7490 if N = Condition (P) then
7491 if Present (Condition_Actions (P)) then
7492 Insert_List_After_And_Analyze
7493 (Last (Condition_Actions (P)), Ins_Actions);
7495 Set_Condition_Actions (P, Ins_Actions);
7497 -- Set the parent of the insert actions explicitly. This
7498 -- is not a syntactic field, but we need the parent field
7499 -- set, in particular so that freeze can understand that
7500 -- it is dealing with condition actions, and properly
7501 -- insert the freezing actions.
7503 Set_Parent (Ins_Actions, P);
7504 Analyze_List (Condition_Actions (P));
7510 -- Statements, declarations, pragmas, representation clauses
7515 N_Procedure_Call_Statement
7516 | N_Statement_Other_Than_Procedure_Call
7522 -- Representation_Clause
7525 | N_Attribute_Definition_Clause
7526 | N_Enumeration_Representation_Clause
7527 | N_Record_Representation_Clause
7531 | N_Abstract_Subprogram_Declaration
7533 | N_Exception_Declaration
7534 | N_Exception_Renaming_Declaration
7535 | N_Expression_Function
7536 | N_Formal_Abstract_Subprogram_Declaration
7537 | N_Formal_Concrete_Subprogram_Declaration
7538 | N_Formal_Object_Declaration
7539 | N_Formal_Type_Declaration
7540 | N_Full_Type_Declaration
7541 | N_Function_Instantiation
7542 | N_Generic_Function_Renaming_Declaration
7543 | N_Generic_Package_Declaration
7544 | N_Generic_Package_Renaming_Declaration
7545 | N_Generic_Procedure_Renaming_Declaration
7546 | N_Generic_Subprogram_Declaration
7547 | N_Implicit_Label_Declaration
7548 | N_Incomplete_Type_Declaration
7549 | N_Number_Declaration
7550 | N_Object_Declaration
7551 | N_Object_Renaming_Declaration
7553 | N_Package_Body_Stub
7554 | N_Package_Declaration
7555 | N_Package_Instantiation
7556 | N_Package_Renaming_Declaration
7557 | N_Private_Extension_Declaration
7558 | N_Private_Type_Declaration
7559 | N_Procedure_Instantiation
7561 | N_Protected_Body_Stub
7562 | N_Single_Task_Declaration
7564 | N_Subprogram_Body_Stub
7565 | N_Subprogram_Declaration
7566 | N_Subprogram_Renaming_Declaration
7567 | N_Subtype_Declaration
7571 -- Use clauses can appear in lists of declarations
7573 | N_Use_Package_Clause
7576 -- Freeze entity behaves like a declaration or statement
7579 | N_Freeze_Generic_Entity
7581 -- Do not insert here if the item is not a list member (this
7582 -- happens for example with a triggering statement, and the
7583 -- proper approach is to insert before the entire select).
7585 if not Is_List_Member (P) then
7588 -- Do not insert if parent of P is an N_Component_Association
7589 -- node (i.e. we are in the context of an N_Aggregate or
7590 -- N_Extension_Aggregate node. In this case we want to insert
7591 -- before the entire aggregate.
7593 elsif Nkind (Parent (P)) = N_Component_Association then
7596 -- Do not insert if the parent of P is either an N_Variant node
7597 -- or an N_Record_Definition node, meaning in either case that
7598 -- P is a member of a component list, and that therefore the
7599 -- actions should be inserted outside the complete record
7602 elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
7605 -- Do not insert freeze nodes within the loop generated for
7606 -- an aggregate, because they may be elaborated too late for
7607 -- subsequent use in the back end: within a package spec the
7608 -- loop is part of the elaboration procedure and is only
7609 -- elaborated during the second pass.
7611 -- If the loop comes from source, or the entity is local to the
7612 -- loop itself it must remain within.
7614 elsif Nkind (Parent (P)) = N_Loop_Statement
7615 and then not Comes_From_Source (Parent (P))
7616 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7618 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7622 -- Otherwise we can go ahead and do the insertion
7624 elsif P = Wrapped_Node then
7625 Store_Before_Actions_In_Scope (Ins_Actions);
7629 Insert_List_Before_And_Analyze (P, Ins_Actions);
7633 -- the expansion of Task and protected type declarations can
7634 -- create declarations for temporaries which, like other actions
7635 -- are inserted and analyzed before the current declaraation.
7636 -- However, the current scope is the synchronized type, and
7637 -- for unnesting it is critical that the proper scope for these
7638 -- generated entities be the enclosing one.
7640 when N_Task_Type_Declaration
7641 | N_Protected_Type_Declaration =>
7643 Push_Scope (Scope (Current_Scope));
7644 Insert_List_Before_And_Analyze (P, Ins_Actions);
7648 -- A special case, N_Raise_xxx_Error can act either as a statement
7649 -- or a subexpression. We tell the difference by looking at the
7650 -- Etype. It is set to Standard_Void_Type in the statement case.
7652 when N_Raise_xxx_Error =>
7653 if Etype (P) = Standard_Void_Type then
7654 if P = Wrapped_Node then
7655 Store_Before_Actions_In_Scope (Ins_Actions);
7657 Insert_List_Before_And_Analyze (P, Ins_Actions);
7662 -- In the subexpression case, keep climbing
7668 -- If a component association appears within a loop created for
7669 -- an array aggregate, attach the actions to the association so
7670 -- they can be subsequently inserted within the loop. For other
7671 -- component associations insert outside of the aggregate. For
7672 -- an association that will generate a loop, its Loop_Actions
7673 -- attribute is already initialized (see exp_aggr.adb).
7675 -- The list of Loop_Actions can in turn generate additional ones,
7676 -- that are inserted before the associated node. If the associated
7677 -- node is outside the aggregate, the new actions are collected
7678 -- at the end of the Loop_Actions, to respect the order in which
7679 -- they are to be elaborated.
7681 when N_Component_Association
7682 | N_Iterated_Component_Association
7683 | N_Iterated_Element_Association
7685 if Nkind (Parent (P)) = N_Aggregate
7686 and then Present (Loop_Actions (P))
7688 if Is_Empty_List (Loop_Actions (P)) then
7689 Set_Loop_Actions (P, Ins_Actions);
7690 Analyze_List (Ins_Actions);
7696 -- Check whether these actions were generated by a
7697 -- declaration that is part of the Loop_Actions for
7698 -- the component_association.
7701 while Present (Decl) loop
7702 exit when Parent (Decl) = P
7703 and then Is_List_Member (Decl)
7705 List_Containing (Decl) = Loop_Actions (P);
7706 Decl := Parent (Decl);
7709 if Present (Decl) then
7710 Insert_List_Before_And_Analyze
7711 (Decl, Ins_Actions);
7713 Insert_List_After_And_Analyze
7714 (Last (Loop_Actions (P)), Ins_Actions);
7725 -- Special case: an attribute denoting a procedure call
7727 when N_Attribute_Reference =>
7728 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7729 if P = Wrapped_Node then
7730 Store_Before_Actions_In_Scope (Ins_Actions);
7732 Insert_List_Before_And_Analyze (P, Ins_Actions);
7737 -- In the subexpression case, keep climbing
7743 -- Special case: a marker
7746 | N_Variable_Reference_Marker
7748 if Is_List_Member (P) then
7749 Insert_List_Before_And_Analyze (P, Ins_Actions);
7753 -- A contract node should not belong to the tree
7756 raise Program_Error;
7758 -- For all other node types, keep climbing tree
7760 when N_Abortable_Part
7761 | N_Accept_Alternative
7762 | N_Access_Definition
7763 | N_Access_Function_Definition
7764 | N_Access_Procedure_Definition
7765 | N_Access_To_Object_Definition
7768 | N_Aspect_Specification
7770 | N_Case_Statement_Alternative
7771 | N_Character_Literal
7772 | N_Compilation_Unit
7773 | N_Compilation_Unit_Aux
7774 | N_Component_Clause
7775 | N_Component_Declaration
7776 | N_Component_Definition
7778 | N_Constrained_Array_Definition
7779 | N_Decimal_Fixed_Point_Definition
7780 | N_Defining_Character_Literal
7781 | N_Defining_Identifier
7782 | N_Defining_Operator_Symbol
7783 | N_Defining_Program_Unit_Name
7784 | N_Delay_Alternative
7786 | N_Delta_Constraint
7787 | N_Derived_Type_Definition
7789 | N_Digits_Constraint
7790 | N_Discriminant_Association
7791 | N_Discriminant_Specification
7793 | N_Entry_Body_Formal_Part
7794 | N_Entry_Call_Alternative
7795 | N_Entry_Declaration
7796 | N_Entry_Index_Specification
7797 | N_Enumeration_Type_Definition
7799 | N_Exception_Handler
7801 | N_Explicit_Dereference
7802 | N_Extension_Aggregate
7803 | N_Floating_Point_Definition
7804 | N_Formal_Decimal_Fixed_Point_Definition
7805 | N_Formal_Derived_Type_Definition
7806 | N_Formal_Discrete_Type_Definition
7807 | N_Formal_Floating_Point_Definition
7808 | N_Formal_Modular_Type_Definition
7809 | N_Formal_Ordinary_Fixed_Point_Definition
7810 | N_Formal_Package_Declaration
7811 | N_Formal_Private_Type_Definition
7812 | N_Formal_Incomplete_Type_Definition
7813 | N_Formal_Signed_Integer_Type_Definition
7815 | N_Function_Specification
7816 | N_Generic_Association
7817 | N_Handled_Sequence_Of_Statements
7820 | N_Index_Or_Discriminant_Constraint
7821 | N_Indexed_Component
7823 | N_Iterator_Specification
7826 | N_Loop_Parameter_Specification
7828 | N_Modular_Type_Definition
7854 | N_Op_Shift_Right_Arithmetic
7858 | N_Ordinary_Fixed_Point_Definition
7860 | N_Package_Specification
7861 | N_Parameter_Association
7862 | N_Parameter_Specification
7863 | N_Pop_Constraint_Error_Label
7864 | N_Pop_Program_Error_Label
7865 | N_Pop_Storage_Error_Label
7866 | N_Pragma_Argument_Association
7867 | N_Procedure_Specification
7868 | N_Protected_Definition
7869 | N_Push_Constraint_Error_Label
7870 | N_Push_Program_Error_Label
7871 | N_Push_Storage_Error_Label
7872 | N_Qualified_Expression
7873 | N_Quantified_Expression
7874 | N_Raise_Expression
7876 | N_Range_Constraint
7878 | N_Real_Range_Specification
7879 | N_Record_Definition
7881 | N_SCIL_Dispatch_Table_Tag_Init
7882 | N_SCIL_Dispatching_Call
7883 | N_SCIL_Membership_Test
7884 | N_Selected_Component
7885 | N_Signed_Integer_Type_Definition
7886 | N_Single_Protected_Declaration
7889 | N_Subtype_Indication
7893 | N_Terminate_Alternative
7894 | N_Triggering_Alternative
7896 | N_Unchecked_Expression
7897 | N_Unchecked_Type_Conversion
7898 | N_Unconstrained_Array_Definition
7903 | N_Validate_Unchecked_Conversion
7909 -- If we fall through above tests, keep climbing tree
7913 if Nkind (Parent (N)) = N_Subunit then
7915 -- This is the proper body corresponding to a stub. Insertion must
7916 -- be done at the point of the stub, which is in the declarative
7917 -- part of the parent unit.
7919 P := Corresponding_Stub (Parent (N));
7927 -- Version with check(s) suppressed
7929 procedure Insert_Actions
7930 (Assoc_Node : Node_Id;
7931 Ins_Actions : List_Id;
7932 Suppress : Check_Id;
7933 Spec_Expr_OK : Boolean := False)
7936 if Suppress = All_Checks then
7938 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
7940 Scope_Suppress.Suppress := (others => True);
7941 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7942 Scope_Suppress.Suppress := Sva;
7947 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
7949 Scope_Suppress.Suppress (Suppress) := True;
7950 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7951 Scope_Suppress.Suppress (Suppress) := Svg;
7956 --------------------------
7957 -- Insert_Actions_After --
7958 --------------------------
7960 procedure Insert_Actions_After
7961 (Assoc_Node : Node_Id;
7962 Ins_Actions : List_Id)
7965 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
7966 Store_After_Actions_In_Scope (Ins_Actions);
7968 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
7970 end Insert_Actions_After;
7972 ------------------------
7973 -- Insert_Declaration --
7974 ------------------------
7976 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
7980 pragma Assert (Nkind (N) in N_Subexpr);
7982 -- Climb until we find a procedure or a package
7986 pragma Assert (Present (Parent (P)));
7989 if Is_List_Member (P) then
7990 exit when Nkind (Parent (P)) in
7991 N_Package_Specification | N_Subprogram_Body;
7993 -- Special handling for handled sequence of statements, we must
7994 -- insert in the statements not the exception handlers!
7996 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
7997 P := First (Statements (Parent (P)));
8003 -- Now do the insertion
8005 Insert_Before (P, Decl);
8007 end Insert_Declaration;
8009 ---------------------------------
8010 -- Insert_Library_Level_Action --
8011 ---------------------------------
8013 procedure Insert_Library_Level_Action (N : Node_Id) is
8014 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
8017 Push_Scope (Cunit_Entity (Current_Sem_Unit));
8018 -- And not Main_Unit as previously. If the main unit is a body,
8019 -- the scope needed to analyze the actions is the entity of the
8020 -- corresponding declaration.
8022 if No (Actions (Aux)) then
8023 Set_Actions (Aux, New_List (N));
8025 Append (N, Actions (Aux));
8030 end Insert_Library_Level_Action;
8032 ----------------------------------
8033 -- Insert_Library_Level_Actions --
8034 ----------------------------------
8036 procedure Insert_Library_Level_Actions (L : List_Id) is
8037 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
8040 if Is_Non_Empty_List (L) then
8041 Push_Scope (Cunit_Entity (Main_Unit));
8042 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
8044 if No (Actions (Aux)) then
8045 Set_Actions (Aux, L);
8048 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
8053 end Insert_Library_Level_Actions;
8055 ----------------------
8056 -- Inside_Init_Proc --
8057 ----------------------
8059 function Inside_Init_Proc return Boolean is
8060 Proc : constant Entity_Id := Enclosing_Init_Proc;
8063 return Proc /= Empty;
8064 end Inside_Init_Proc;
8066 ----------------------
8067 -- Integer_Type_For --
8068 ----------------------
8070 function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id is
8072 pragma Assert (S <= System_Max_Integer_Size);
8074 -- This is the canonical 32-bit type
8076 if S <= Standard_Integer_Size then
8078 return Standard_Unsigned;
8080 return Standard_Integer;
8083 -- This is the canonical 64-bit type
8085 elsif S <= Standard_Long_Long_Integer_Size then
8087 return Standard_Long_Long_Unsigned;
8089 return Standard_Long_Long_Integer;
8092 -- This is the canonical 128-bit type
8094 elsif S <= Standard_Long_Long_Long_Integer_Size then
8096 return Standard_Long_Long_Long_Unsigned;
8098 return Standard_Long_Long_Long_Integer;
8102 raise Program_Error;
8104 end Integer_Type_For;
8106 --------------------------------------------------
8107 -- Is_Displacement_Of_Object_Or_Function_Result --
8108 --------------------------------------------------
8110 function Is_Displacement_Of_Object_Or_Function_Result
8111 (Obj_Id : Entity_Id) return Boolean
8113 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
8114 -- Determine whether node N denotes a controlled function call
8116 function Is_Controlled_Indexing (N : Node_Id) return Boolean;
8117 -- Determine whether node N denotes a generalized indexing form which
8118 -- involves a controlled result.
8120 function Is_Displace_Call (N : Node_Id) return Boolean;
8121 -- Determine whether node N denotes a call to Ada.Tags.Displace
8123 function Is_Source_Object (N : Node_Id) return Boolean;
8124 -- Determine whether a particular node denotes a source object
8126 function Strip (N : Node_Id) return Node_Id;
8127 -- Examine arbitrary node N by stripping various indirections and return
8130 ---------------------------------
8131 -- Is_Controlled_Function_Call --
8132 ---------------------------------
8134 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
8138 -- When a function call appears in Object.Operation format, the
8139 -- original representation has several possible forms depending on
8140 -- the availability and form of actual parameters:
8142 -- Obj.Func N_Selected_Component
8143 -- Obj.Func (Actual) N_Indexed_Component
8144 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
8145 -- N_Selected_Component
8147 Expr := Original_Node (N);
8149 if Nkind (Expr) = N_Function_Call then
8150 Expr := Name (Expr);
8152 -- "Obj.Func (Actual)" case
8154 elsif Nkind (Expr) = N_Indexed_Component then
8155 Expr := Prefix (Expr);
8157 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
8159 elsif Nkind (Expr) = N_Selected_Component then
8160 Expr := Selector_Name (Expr);
8168 Nkind (Expr) in N_Has_Entity
8169 and then Present (Entity (Expr))
8170 and then Ekind (Entity (Expr)) = E_Function
8171 and then Needs_Finalization (Etype (Entity (Expr)));
8172 end Is_Controlled_Function_Call;
8174 ----------------------------
8175 -- Is_Controlled_Indexing --
8176 ----------------------------
8178 function Is_Controlled_Indexing (N : Node_Id) return Boolean is
8179 Expr : constant Node_Id := Original_Node (N);
8183 Nkind (Expr) = N_Indexed_Component
8184 and then Present (Generalized_Indexing (Expr))
8185 and then Needs_Finalization (Etype (Expr));
8186 end Is_Controlled_Indexing;
8188 ----------------------
8189 -- Is_Displace_Call --
8190 ----------------------
8192 function Is_Displace_Call (N : Node_Id) return Boolean is
8193 Call : constant Node_Id := Strip (N);
8198 and then Nkind (Call) = N_Function_Call
8199 and then Nkind (Name (Call)) in N_Has_Entity
8200 and then Is_RTE (Entity (Name (Call)), RE_Displace);
8201 end Is_Displace_Call;
8203 ----------------------
8204 -- Is_Source_Object --
8205 ----------------------
8207 function Is_Source_Object (N : Node_Id) return Boolean is
8208 Obj : constant Node_Id := Strip (N);
8213 and then Comes_From_Source (Obj)
8214 and then Nkind (Obj) in N_Has_Entity
8215 and then Is_Object (Entity (Obj));
8216 end Is_Source_Object;
8222 function Strip (N : Node_Id) return Node_Id is
8228 if Nkind (Result) = N_Explicit_Dereference then
8229 Result := Prefix (Result);
8231 elsif Nkind (Result) in
8232 N_Type_Conversion | N_Unchecked_Type_Conversion
8234 Result := Expression (Result);
8246 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
8247 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
8248 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
8249 Orig_Expr : Node_Id;
8251 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
8256 -- Obj : CW_Type := Function_Call (...);
8258 -- is rewritten into:
8260 -- Temp : ... := Function_Call (...)'reference;
8261 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
8263 -- where the return type of the function and the class-wide type require
8264 -- dispatch table pointer displacement.
8268 -- Obj : CW_Type := Container (...);
8270 -- is rewritten into:
8272 -- Temp : ... := Function_Call (Container, ...)'reference;
8273 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
8275 -- where the container element type and the class-wide type require
8276 -- dispatch table pointer dispacement.
8280 -- Obj : CW_Type := Src_Obj;
8282 -- is rewritten into:
8284 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
8286 -- where the type of the source object and the class-wide type require
8287 -- dispatch table pointer displacement.
8289 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
8290 and then Is_Class_Wide_Type (Obj_Typ)
8291 and then Is_Displace_Call (Renamed_Object (Obj_Id))
8292 and then Nkind (Orig_Decl) = N_Object_Declaration
8293 and then Comes_From_Source (Orig_Decl)
8295 Orig_Expr := Expression (Orig_Decl);
8298 Is_Controlled_Function_Call (Orig_Expr)
8299 or else Is_Controlled_Indexing (Orig_Expr)
8300 or else Is_Source_Object (Orig_Expr);
8304 end Is_Displacement_Of_Object_Or_Function_Result;
8306 ------------------------------
8307 -- Is_Finalizable_Transient --
8308 ------------------------------
8310 function Is_Finalizable_Transient
8312 Rel_Node : Node_Id) return Boolean
8314 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
8315 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
8317 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
8318 -- Determine whether transient object Trans_Id is initialized either
8319 -- by a function call which returns an access type or simply renames
8322 function Initialized_By_Aliased_BIP_Func_Call
8323 (Trans_Id : Entity_Id) return Boolean;
8324 -- Determine whether transient object Trans_Id is initialized by a
8325 -- build-in-place function call where the BIPalloc parameter is of
8326 -- value 1 and BIPaccess is not null. This case creates an aliasing
8327 -- between the returned value and the value denoted by BIPaccess.
8330 (Trans_Id : Entity_Id;
8331 First_Stmt : Node_Id) return Boolean;
8332 -- Determine whether transient object Trans_Id has been renamed or
8333 -- aliased through 'reference in the statement list starting from
8336 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
8337 -- Determine whether transient object Trans_Id is allocated on the heap
8339 function Is_Iterated_Container
8340 (Trans_Id : Entity_Id;
8341 First_Stmt : Node_Id) return Boolean;
8342 -- Determine whether transient object Trans_Id denotes a container which
8343 -- is in the process of being iterated in the statement list starting
8346 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean;
8347 -- Return True if N is directly part of a build-in-place return
8350 ---------------------------
8351 -- Initialized_By_Access --
8352 ---------------------------
8354 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
8355 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8360 and then Nkind (Expr) /= N_Reference
8361 and then Is_Access_Type (Etype (Expr));
8362 end Initialized_By_Access;
8364 ------------------------------------------
8365 -- Initialized_By_Aliased_BIP_Func_Call --
8366 ------------------------------------------
8368 function Initialized_By_Aliased_BIP_Func_Call
8369 (Trans_Id : Entity_Id) return Boolean
8371 Call : Node_Id := Expression (Parent (Trans_Id));
8374 -- Build-in-place calls usually appear in 'reference format
8376 if Nkind (Call) = N_Reference then
8377 Call := Prefix (Call);
8380 Call := Unqual_Conv (Call);
8382 if Is_Build_In_Place_Function_Call (Call) then
8384 Access_Nam : Name_Id := No_Name;
8385 Access_OK : Boolean := False;
8387 Alloc_Nam : Name_Id := No_Name;
8388 Alloc_OK : Boolean := False;
8390 Func_Id : Entity_Id;
8394 -- Examine all parameter associations of the function call
8396 Param := First (Parameter_Associations (Call));
8397 while Present (Param) loop
8398 if Nkind (Param) = N_Parameter_Association
8399 and then Nkind (Selector_Name (Param)) = N_Identifier
8401 Actual := Explicit_Actual_Parameter (Param);
8402 Formal := Selector_Name (Param);
8404 -- Construct the names of formals BIPaccess and BIPalloc
8405 -- using the function name retrieved from an arbitrary
8408 if Access_Nam = No_Name
8409 and then Alloc_Nam = No_Name
8410 and then Present (Entity (Formal))
8412 Func_Id := Scope (Entity (Formal));
8415 New_External_Name (Chars (Func_Id),
8416 BIP_Formal_Suffix (BIP_Object_Access));
8419 New_External_Name (Chars (Func_Id),
8420 BIP_Formal_Suffix (BIP_Alloc_Form));
8423 -- A match for BIPaccess => Temp has been found
8425 if Chars (Formal) = Access_Nam
8426 and then Nkind (Actual) /= N_Null
8431 -- A match for BIPalloc => 1 has been found
8433 if Chars (Formal) = Alloc_Nam
8434 and then Nkind (Actual) = N_Integer_Literal
8435 and then Intval (Actual) = Uint_1
8444 return Access_OK and Alloc_OK;
8449 end Initialized_By_Aliased_BIP_Func_Call;
8456 (Trans_Id : Entity_Id;
8457 First_Stmt : Node_Id) return Boolean
8459 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
8460 -- Given an object renaming declaration, retrieve the entity of the
8461 -- renamed name. Return Empty if the renamed name is anything other
8462 -- than a variable or a constant.
8464 -------------------------
8465 -- Find_Renamed_Object --
8466 -------------------------
8468 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
8469 Ren_Obj : Node_Id := Empty;
8471 function Find_Object (N : Node_Id) return Traverse_Result;
8472 -- Try to detect an object which is either a constant or a
8479 function Find_Object (N : Node_Id) return Traverse_Result is
8481 -- Stop the search once a constant or a variable has been
8484 if Nkind (N) = N_Identifier
8485 and then Present (Entity (N))
8486 and then Ekind (Entity (N)) in E_Constant | E_Variable
8488 Ren_Obj := Entity (N);
8495 procedure Search is new Traverse_Proc (Find_Object);
8499 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
8501 -- Start of processing for Find_Renamed_Object
8504 -- Actions related to dispatching calls may appear as renamings of
8505 -- tags. Do not process this type of renaming because it does not
8506 -- use the actual value of the object.
8508 if not Is_RTE (Typ, RE_Tag_Ptr) then
8509 Search (Name (Ren_Decl));
8513 end Find_Renamed_Object;
8518 Ren_Obj : Entity_Id;
8521 -- Start of processing for Is_Aliased
8524 -- A controlled transient object is not considered aliased when it
8525 -- appears inside an expression_with_actions node even when there are
8526 -- explicit aliases of it:
8529 -- Trans_Id : Ctrl_Typ ...; -- transient object
8530 -- Alias : ... := Trans_Id; -- object is aliased
8531 -- Val : constant Boolean :=
8532 -- ... Alias ...; -- aliasing ends
8533 -- <finalize Trans_Id> -- object safe to finalize
8536 -- Expansion ensures that all aliases are encapsulated in the actions
8537 -- list and do not leak to the expression by forcing the evaluation
8538 -- of the expression.
8540 if Nkind (Rel_Node) = N_Expression_With_Actions then
8543 -- Otherwise examine the statements after the controlled transient
8544 -- object and look for various forms of aliasing.
8548 while Present (Stmt) loop
8549 if Nkind (Stmt) = N_Object_Declaration then
8550 Expr := Expression (Stmt);
8552 -- Aliasing of the form:
8553 -- Obj : ... := Trans_Id'reference;
8556 and then Nkind (Expr) = N_Reference
8557 and then Nkind (Prefix (Expr)) = N_Identifier
8558 and then Entity (Prefix (Expr)) = Trans_Id
8563 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
8564 Ren_Obj := Find_Renamed_Object (Stmt);
8566 -- Aliasing of the form:
8567 -- Obj : ... renames ... Trans_Id ...;
8569 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
8585 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
8586 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8589 Is_Access_Type (Etype (Trans_Id))
8590 and then Present (Expr)
8591 and then Nkind (Expr) = N_Allocator;
8594 ---------------------------
8595 -- Is_Iterated_Container --
8596 ---------------------------
8598 function Is_Iterated_Container
8599 (Trans_Id : Entity_Id;
8600 First_Stmt : Node_Id) return Boolean
8610 -- It is not possible to iterate over containers in non-Ada 2012 code
8612 if Ada_Version < Ada_2012 then
8616 Typ := Etype (Trans_Id);
8618 -- Handle access type created for secondary stack use
8620 if Is_Access_Type (Typ) then
8621 Typ := Designated_Type (Typ);
8624 -- Look for aspect Default_Iterator. It may be part of a type
8625 -- declaration for a container, or inherited from a base type
8628 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8630 if Present (Aspect) then
8631 Iter := Entity (Aspect);
8633 -- Examine the statements following the container object and
8634 -- look for a call to the default iterate routine where the
8635 -- first parameter is the transient. Such a call appears as:
8637 -- It : Access_To_CW_Iterator :=
8638 -- Iterate (Tran_Id.all, ...)'reference;
8641 while Present (Stmt) loop
8643 -- Detect an object declaration which is initialized by a
8644 -- secondary stack function call.
8646 if Nkind (Stmt) = N_Object_Declaration
8647 and then Present (Expression (Stmt))
8648 and then Nkind (Expression (Stmt)) = N_Reference
8649 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8651 Call := Prefix (Expression (Stmt));
8653 -- The call must invoke the default iterate routine of
8654 -- the container and the transient object must appear as
8655 -- the first actual parameter. Skip any calls whose names
8656 -- are not entities.
8658 if Is_Entity_Name (Name (Call))
8659 and then Entity (Name (Call)) = Iter
8660 and then Present (Parameter_Associations (Call))
8662 Param := First (Parameter_Associations (Call));
8664 if Nkind (Param) = N_Explicit_Dereference
8665 and then Entity (Prefix (Param)) = Trans_Id
8677 end Is_Iterated_Container;
8679 -------------------------------------
8680 -- Is_Part_Of_BIP_Return_Statement --
8681 -------------------------------------
8683 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
8684 Subp : constant Entity_Id := Current_Subprogram;
8687 -- First check if N is part of a BIP function
8690 or else not Is_Build_In_Place_Function (Subp)
8695 -- Then check whether N is a complete part of a return statement
8696 -- Should we consider other node kinds to go up the tree???
8700 case Nkind (Context) is
8701 when N_Expression_With_Actions => Context := Parent (Context);
8702 when N_Simple_Return_Statement => return True;
8703 when others => return False;
8706 end Is_Part_Of_BIP_Return_Statement;
8710 Desig : Entity_Id := Obj_Typ;
8712 -- Start of processing for Is_Finalizable_Transient
8715 -- Handle access types
8717 if Is_Access_Type (Desig) then
8718 Desig := Available_View (Designated_Type (Desig));
8722 Ekind (Obj_Id) in E_Constant | E_Variable
8723 and then Needs_Finalization (Desig)
8724 and then Requires_Transient_Scope (Desig)
8725 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8726 and then not Is_Part_Of_BIP_Return_Statement (Rel_Node)
8728 -- Do not consider a transient object that was already processed
8730 and then not Is_Finalized_Transient (Obj_Id)
8732 -- Do not consider renamed or 'reference-d transient objects because
8733 -- the act of renaming extends the object's lifetime.
8735 and then not Is_Aliased (Obj_Id, Decl)
8737 -- Do not consider transient objects allocated on the heap since
8738 -- they are attached to a finalization master.
8740 and then not Is_Allocated (Obj_Id)
8742 -- If the transient object is a pointer, check that it is not
8743 -- initialized by a function that returns a pointer or acts as a
8744 -- renaming of another pointer.
8747 (Is_Access_Type (Obj_Typ) and then Initialized_By_Access (Obj_Id))
8749 -- Do not consider transient objects which act as indirect aliases
8750 -- of build-in-place function results.
8752 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8754 -- Do not consider conversions of tags to class-wide types
8756 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8758 -- Do not consider iterators because those are treated as normal
8759 -- controlled objects and are processed by the usual finalization
8760 -- machinery. This avoids the double finalization of an iterator.
8762 and then not Is_Iterator (Desig)
8764 -- Do not consider containers in the context of iterator loops. Such
8765 -- transient objects must exist for as long as the loop is around,
8766 -- otherwise any operation carried out by the iterator will fail.
8768 and then not Is_Iterated_Container (Obj_Id, Decl);
8769 end Is_Finalizable_Transient;
8771 ---------------------------------
8772 -- Is_Fully_Repped_Tagged_Type --
8773 ---------------------------------
8775 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8776 U : constant Entity_Id := Underlying_Type (T);
8780 if No (U) or else not Is_Tagged_Type (U) then
8782 elsif Has_Discriminants (U) then
8784 elsif not Has_Specified_Layout (U) then
8788 -- Here we have a tagged type, see if it has any component (other than
8789 -- tag and parent) with no component_clause. If so, we return False.
8791 Comp := First_Component (U);
8792 while Present (Comp) loop
8793 if not Is_Tag (Comp)
8794 and then Chars (Comp) /= Name_uParent
8795 and then No (Component_Clause (Comp))
8799 Next_Component (Comp);
8803 -- All components have clauses
8806 end Is_Fully_Repped_Tagged_Type;
8808 ----------------------------------
8809 -- Is_Library_Level_Tagged_Type --
8810 ----------------------------------
8812 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8814 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8815 end Is_Library_Level_Tagged_Type;
8817 --------------------------
8818 -- Is_Non_BIP_Func_Call --
8819 --------------------------
8821 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8823 -- The expected call is of the format
8825 -- Func_Call'reference
8828 Nkind (Expr) = N_Reference
8829 and then Nkind (Prefix (Expr)) = N_Function_Call
8830 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8831 end Is_Non_BIP_Func_Call;
8833 ----------------------------------
8834 -- Is_Possibly_Unaligned_Object --
8835 ----------------------------------
8837 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8838 T : constant Entity_Id := Etype (N);
8841 -- If renamed object, apply test to underlying object
8843 if Is_Entity_Name (N)
8844 and then Is_Object (Entity (N))
8845 and then Present (Renamed_Object (Entity (N)))
8847 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8850 -- Tagged and controlled types and aliased types are always aligned, as
8851 -- are concurrent types.
8854 or else Has_Controlled_Component (T)
8855 or else Is_Concurrent_Type (T)
8856 or else Is_Tagged_Type (T)
8857 or else Is_Controlled (T)
8862 -- If this is an element of a packed array, may be unaligned
8864 if Is_Ref_To_Bit_Packed_Array (N) then
8868 -- Case of indexed component reference: test whether prefix is unaligned
8870 if Nkind (N) = N_Indexed_Component then
8871 return Is_Possibly_Unaligned_Object (Prefix (N));
8873 -- Case of selected component reference
8875 elsif Nkind (N) = N_Selected_Component then
8877 P : constant Node_Id := Prefix (N);
8878 C : constant Entity_Id := Entity (Selector_Name (N));
8883 -- If component reference is for an array with nonstatic bounds,
8884 -- then it is always aligned: we can only process unaligned arrays
8885 -- with static bounds (more precisely compile time known bounds).
8887 if Is_Array_Type (T)
8888 and then not Compile_Time_Known_Bounds (T)
8893 -- If component is aliased, it is definitely properly aligned
8895 if Is_Aliased (C) then
8899 -- If component is for a type implemented as a scalar, and the
8900 -- record is packed, and the component is other than the first
8901 -- component of the record, then the component may be unaligned.
8903 if Is_Packed (Etype (P))
8904 and then Represented_As_Scalar (Etype (C))
8905 and then First_Entity (Scope (C)) /= C
8910 -- Compute maximum possible alignment for T
8912 -- If alignment is known, then that settles things
8914 if Known_Alignment (T) then
8915 M := UI_To_Int (Alignment (T));
8917 -- If alignment is not known, tentatively set max alignment
8920 M := Ttypes.Maximum_Alignment;
8922 -- We can reduce this if the Esize is known since the default
8923 -- alignment will never be more than the smallest power of 2
8924 -- that does not exceed this Esize value.
8926 if Known_Esize (T) then
8927 S := UI_To_Int (Esize (T));
8929 while (M / 2) >= S loop
8935 -- Case of component clause present which may specify an
8936 -- unaligned position.
8938 if Present (Component_Clause (C)) then
8940 -- Otherwise we can do a test to make sure that the actual
8941 -- start position in the record, and the length, are both
8942 -- consistent with the required alignment. If not, we know
8943 -- that we are unaligned.
8946 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8952 -- For a component inherited in a record extension, the
8953 -- clause is inherited but position and size are not set.
8955 if Is_Base_Type (Etype (P))
8956 and then Is_Tagged_Type (Etype (P))
8957 and then Present (Original_Record_Component (Comp))
8959 Comp := Original_Record_Component (Comp);
8962 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
8963 or else Esize (Comp) mod Align_In_Bits /= 0
8970 -- Otherwise, for a component reference, test prefix
8972 return Is_Possibly_Unaligned_Object (P);
8975 -- If not a component reference, must be aligned
8980 end Is_Possibly_Unaligned_Object;
8982 ---------------------------------
8983 -- Is_Possibly_Unaligned_Slice --
8984 ---------------------------------
8986 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
8988 -- Go to renamed object
8990 if Is_Entity_Name (N)
8991 and then Is_Object (Entity (N))
8992 and then Present (Renamed_Object (Entity (N)))
8994 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
8997 -- The reference must be a slice
8999 if Nkind (N) /= N_Slice then
9003 -- If it is a slice, then look at the array type being sliced
9006 Sarr : constant Node_Id := Prefix (N);
9007 -- Prefix of the slice, i.e. the array being sliced
9009 Styp : constant Entity_Id := Etype (Prefix (N));
9010 -- Type of the array being sliced
9016 -- The problems arise if the array object that is being sliced
9017 -- is a component of a record or array, and we cannot guarantee
9018 -- the alignment of the array within its containing object.
9020 -- To investigate this, we look at successive prefixes to see
9021 -- if we have a worrisome indexed or selected component.
9025 -- Case of array is part of an indexed component reference
9027 if Nkind (Pref) = N_Indexed_Component then
9028 Ptyp := Etype (Prefix (Pref));
9030 -- The only problematic case is when the array is packed, in
9031 -- which case we really know nothing about the alignment of
9032 -- individual components.
9034 if Is_Bit_Packed_Array (Ptyp) then
9038 -- Case of array is part of a selected component reference
9040 elsif Nkind (Pref) = N_Selected_Component then
9041 Ptyp := Etype (Prefix (Pref));
9043 -- We are definitely in trouble if the record in question
9044 -- has an alignment, and either we know this alignment is
9045 -- inconsistent with the alignment of the slice, or we don't
9046 -- know what the alignment of the slice should be. But this
9047 -- really matters only if the target has strict alignment.
9049 if Target_Strict_Alignment
9050 and then Known_Alignment (Ptyp)
9051 and then (not Known_Alignment (Styp)
9052 or else Alignment (Styp) > Alignment (Ptyp))
9057 -- We are in potential trouble if the record type is packed.
9058 -- We could special case when we know that the array is the
9059 -- first component, but that's not such a simple case ???
9061 if Is_Packed (Ptyp) then
9065 -- We are in trouble if there is a component clause, and
9066 -- either we do not know the alignment of the slice, or
9067 -- the alignment of the slice is inconsistent with the
9068 -- bit position specified by the component clause.
9071 Field : constant Entity_Id := Entity (Selector_Name (Pref));
9073 if Present (Component_Clause (Field))
9075 (not Known_Alignment (Styp)
9077 (Component_Bit_Offset (Field) mod
9078 (System_Storage_Unit * Alignment (Styp))) /= 0)
9084 -- For cases other than selected or indexed components we know we
9085 -- are OK, since no issues arise over alignment.
9091 -- We processed an indexed component or selected component
9092 -- reference that looked safe, so keep checking prefixes.
9094 Pref := Prefix (Pref);
9097 end Is_Possibly_Unaligned_Slice;
9099 -------------------------------
9100 -- Is_Related_To_Func_Return --
9101 -------------------------------
9103 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
9104 Expr : constant Node_Id := Related_Expression (Id);
9106 -- In the case of a function with a class-wide result that returns
9107 -- a call to a function with a specific result, we introduce a
9108 -- type conversion for the return expression. We do not want that
9109 -- type conversion to influence the result of this function.
9113 and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
9114 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
9115 end Is_Related_To_Func_Return;
9117 --------------------------------
9118 -- Is_Ref_To_Bit_Packed_Array --
9119 --------------------------------
9121 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
9126 if Is_Entity_Name (N)
9127 and then Is_Object (Entity (N))
9128 and then Present (Renamed_Object (Entity (N)))
9130 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
9133 if Nkind (N) in N_Indexed_Component | N_Selected_Component then
9134 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
9137 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
9140 if Result and then Nkind (N) = N_Indexed_Component then
9141 Expr := First (Expressions (N));
9142 while Present (Expr) loop
9143 Force_Evaluation (Expr);
9153 end Is_Ref_To_Bit_Packed_Array;
9155 --------------------------------
9156 -- Is_Ref_To_Bit_Packed_Slice --
9157 --------------------------------
9159 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
9161 if Nkind (N) = N_Type_Conversion then
9162 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
9164 elsif Is_Entity_Name (N)
9165 and then Is_Object (Entity (N))
9166 and then Present (Renamed_Object (Entity (N)))
9168 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
9170 elsif Nkind (N) = N_Slice
9171 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
9175 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
9176 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
9181 end Is_Ref_To_Bit_Packed_Slice;
9183 -----------------------
9184 -- Is_Renamed_Object --
9185 -----------------------
9187 function Is_Renamed_Object (N : Node_Id) return Boolean is
9188 Pnod : constant Node_Id := Parent (N);
9189 Kind : constant Node_Kind := Nkind (Pnod);
9191 if Kind = N_Object_Renaming_Declaration then
9193 elsif Kind in N_Indexed_Component | N_Selected_Component then
9194 return Is_Renamed_Object (Pnod);
9198 end Is_Renamed_Object;
9200 --------------------------------------
9201 -- Is_Secondary_Stack_BIP_Func_Call --
9202 --------------------------------------
9204 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
9206 Call : Node_Id := Expr;
9211 -- Build-in-place calls usually appear in 'reference format. Note that
9212 -- the accessibility check machinery may add an extra 'reference due to
9213 -- side effect removal.
9215 while Nkind (Call) = N_Reference loop
9216 Call := Prefix (Call);
9219 Call := Unqual_Conv (Call);
9221 if Is_Build_In_Place_Function_Call (Call) then
9223 -- Examine all parameter associations of the function call
9225 Param := First (Parameter_Associations (Call));
9226 while Present (Param) loop
9227 if Nkind (Param) = N_Parameter_Association then
9228 Formal := Selector_Name (Param);
9229 Actual := Explicit_Actual_Parameter (Param);
9231 -- A match for BIPalloc => 2 has been found
9233 if Is_Build_In_Place_Entity (Formal)
9234 and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
9235 and then Nkind (Actual) = N_Integer_Literal
9236 and then Intval (Actual) = Uint_2
9247 end Is_Secondary_Stack_BIP_Func_Call;
9249 -------------------------------------
9250 -- Is_Tag_To_Class_Wide_Conversion --
9251 -------------------------------------
9253 function Is_Tag_To_Class_Wide_Conversion
9254 (Obj_Id : Entity_Id) return Boolean
9256 Expr : constant Node_Id := Expression (Parent (Obj_Id));
9260 Is_Class_Wide_Type (Etype (Obj_Id))
9261 and then Present (Expr)
9262 and then Nkind (Expr) = N_Unchecked_Type_Conversion
9263 and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
9264 end Is_Tag_To_Class_Wide_Conversion;
9266 --------------------------------
9267 -- Is_Uninitialized_Aggregate --
9268 --------------------------------
9270 function Is_Uninitialized_Aggregate
9272 T : Entity_Id) return Boolean
9275 Comp_Type : Entity_Id;
9279 if Nkind (Exp) /= N_Aggregate then
9283 Preanalyze_And_Resolve (Exp, T);
9287 or else Ekind (Typ) /= E_Array_Subtype
9288 or else Present (Expressions (Exp))
9289 or else No (Component_Associations (Exp))
9293 Comp_Type := Component_Type (Typ);
9294 Comp := First (Component_Associations (Exp));
9296 if not Box_Present (Comp)
9297 or else Present (Next (Comp))
9302 return Is_Scalar_Type (Comp_Type)
9303 and then No (Default_Aspect_Component_Value (Typ));
9305 end Is_Uninitialized_Aggregate;
9307 ----------------------------
9308 -- Is_Untagged_Derivation --
9309 ----------------------------
9311 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
9313 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
9315 (Is_Private_Type (T) and then Present (Full_View (T))
9316 and then not Is_Tagged_Type (Full_View (T))
9317 and then Is_Derived_Type (Full_View (T))
9318 and then Etype (Full_View (T)) /= T);
9319 end Is_Untagged_Derivation;
9321 ------------------------------------
9322 -- Is_Untagged_Private_Derivation --
9323 ------------------------------------
9325 function Is_Untagged_Private_Derivation
9326 (Priv_Typ : Entity_Id;
9327 Full_Typ : Entity_Id) return Boolean
9332 and then Is_Untagged_Derivation (Priv_Typ)
9333 and then Is_Private_Type (Etype (Priv_Typ))
9334 and then Present (Full_Typ)
9335 and then Is_Itype (Full_Typ);
9336 end Is_Untagged_Private_Derivation;
9338 ------------------------------
9339 -- Is_Verifiable_DIC_Pragma --
9340 ------------------------------
9342 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
9343 Args : constant List_Id := Pragma_Argument_Associations (Prag);
9346 -- To qualify as verifiable, a DIC pragma must have a non-null argument
9351 -- If there are args, but the first arg is Empty, then treat the
9352 -- pragma the same as having no args (there may be a second arg that
9353 -- is an implicitly added type arg, and Empty is a placeholder).
9355 and then Present (Get_Pragma_Arg (First (Args)))
9357 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
9358 end Is_Verifiable_DIC_Pragma;
9360 ---------------------------
9361 -- Is_Volatile_Reference --
9362 ---------------------------
9364 function Is_Volatile_Reference (N : Node_Id) return Boolean is
9366 -- Only source references are to be treated as volatile, internally
9367 -- generated stuff cannot have volatile external effects.
9369 if not Comes_From_Source (N) then
9372 -- Never true for reference to a type
9374 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
9377 -- Never true for a compile time known constant
9379 elsif Compile_Time_Known_Value (N) then
9382 -- True if object reference with volatile type
9384 elsif Is_Volatile_Object_Ref (N) then
9387 -- True if reference to volatile entity
9389 elsif Is_Entity_Name (N) then
9390 return Treat_As_Volatile (Entity (N));
9392 -- True for slice of volatile array
9394 elsif Nkind (N) = N_Slice then
9395 return Is_Volatile_Reference (Prefix (N));
9397 -- True if volatile component
9399 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
9400 if (Is_Entity_Name (Prefix (N))
9401 and then Has_Volatile_Components (Entity (Prefix (N))))
9402 or else (Present (Etype (Prefix (N)))
9403 and then Has_Volatile_Components (Etype (Prefix (N))))
9407 return Is_Volatile_Reference (Prefix (N));
9415 end Is_Volatile_Reference;
9417 --------------------
9418 -- Kill_Dead_Code --
9419 --------------------
9421 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
9422 W : Boolean := Warn;
9423 -- Set False if warnings suppressed
9427 Remove_Warning_Messages (N);
9429 -- Update the internal structures of the ABE mechanism in case the
9430 -- dead node is an elaboration scenario.
9432 Kill_Elaboration_Scenario (N);
9434 -- Generate warning if appropriate
9438 -- We suppress the warning if this code is under control of an
9439 -- if/case statement and either
9440 -- a) we are in an instance and the condition/selector
9441 -- has a statically known value; or
9442 -- b) the condition/selector is a simple identifier and
9443 -- warnings off is set for this identifier.
9444 -- Dead code is common and reasonable in instances, so we don't
9445 -- want a warning in that case.
9448 C : Node_Id := Empty;
9450 if Nkind (Parent (N)) = N_If_Statement then
9451 C := Condition (Parent (N));
9452 elsif Nkind (Parent (N)) = N_Case_Statement_Alternative then
9453 C := Expression (Parent (Parent (N)));
9457 if (In_Instance and Compile_Time_Known_Value (C))
9458 or else (Nkind (C) = N_Identifier
9459 and then Present (Entity (C))
9460 and then Has_Warnings_Off (Entity (C)))
9467 -- Generate warning if not suppressed
9471 ("?t?this code can never be executed and has been deleted!",
9476 -- Recurse into block statements and bodies to process declarations
9479 if Nkind (N) = N_Block_Statement
9480 or else Nkind (N) = N_Subprogram_Body
9481 or else Nkind (N) = N_Package_Body
9483 Kill_Dead_Code (Declarations (N), False);
9484 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
9486 if Nkind (N) = N_Subprogram_Body then
9487 Set_Is_Eliminated (Defining_Entity (N));
9490 elsif Nkind (N) = N_Package_Declaration then
9491 Kill_Dead_Code (Visible_Declarations (Specification (N)));
9492 Kill_Dead_Code (Private_Declarations (Specification (N)));
9494 -- ??? After this point, Delete_Tree has been called on all
9495 -- declarations in Specification (N), so references to entities
9496 -- therein look suspicious.
9499 E : Entity_Id := First_Entity (Defining_Entity (N));
9502 while Present (E) loop
9503 if Ekind (E) = E_Operator then
9504 Set_Is_Eliminated (E);
9511 -- Recurse into composite statement to kill individual statements in
9512 -- particular instantiations.
9514 elsif Nkind (N) = N_If_Statement then
9515 Kill_Dead_Code (Then_Statements (N));
9516 Kill_Dead_Code (Elsif_Parts (N));
9517 Kill_Dead_Code (Else_Statements (N));
9519 elsif Nkind (N) = N_Loop_Statement then
9520 Kill_Dead_Code (Statements (N));
9522 elsif Nkind (N) = N_Case_Statement then
9526 Alt := First (Alternatives (N));
9527 while Present (Alt) loop
9528 Kill_Dead_Code (Statements (Alt));
9533 elsif Nkind (N) = N_Case_Statement_Alternative then
9534 Kill_Dead_Code (Statements (N));
9536 -- Deal with dead instances caused by deleting instantiations
9538 elsif Nkind (N) in N_Generic_Instantiation then
9539 Remove_Dead_Instance (N);
9544 -- Case where argument is a list of nodes to be killed
9546 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
9553 if Is_Non_Empty_List (L) then
9555 while Present (N) loop
9556 Kill_Dead_Code (N, W);
9563 -----------------------------
9564 -- Make_CW_Equivalent_Type --
9565 -----------------------------
9567 -- Create a record type used as an equivalent of any member of the class
9568 -- which takes its size from exp.
9570 -- Generate the following code:
9572 -- type Equiv_T is record
9573 -- _parent : T (List of discriminant constraints taken from Exp);
9574 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
9577 -- ??? Note that this type does not guarantee same alignment as all
9580 -- Note: for the freezing circuitry, this looks like a record extension,
9581 -- and so we need to make sure that the scalar storage order is the same
9582 -- as that of the parent type. (This does not change anything for the
9583 -- representation of the extension part.)
9585 function Make_CW_Equivalent_Type
9587 E : Node_Id) return Entity_Id
9589 Loc : constant Source_Ptr := Sloc (E);
9590 Root_Typ : constant Entity_Id := Root_Type (T);
9591 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
9592 List_Def : constant List_Id := Empty_List;
9593 Comp_List : constant List_Id := New_List;
9594 Equiv_Type : Entity_Id;
9595 Range_Type : Entity_Id;
9596 Str_Type : Entity_Id;
9597 Constr_Root : Entity_Id;
9601 -- If the root type is already constrained, there are no discriminants
9602 -- in the expression.
9604 if not Has_Discriminants (Root_Typ)
9605 or else Is_Constrained (Root_Typ)
9607 Constr_Root := Root_Typ;
9609 -- At this point in the expansion, nonlimited view of the type
9610 -- must be available, otherwise the error will be reported later.
9612 if From_Limited_With (Constr_Root)
9613 and then Present (Non_Limited_View (Constr_Root))
9615 Constr_Root := Non_Limited_View (Constr_Root);
9619 Constr_Root := Make_Temporary (Loc, 'R');
9621 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9623 Append_To (List_Def,
9624 Make_Subtype_Declaration (Loc,
9625 Defining_Identifier => Constr_Root,
9626 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9629 -- Generate the range subtype declaration
9631 Range_Type := Make_Temporary (Loc, 'G');
9633 if not Is_Interface (Root_Typ) then
9635 -- subtype rg__xx is
9636 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
9639 Make_Op_Subtract (Loc,
9641 Make_Attribute_Reference (Loc,
9643 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9644 Attribute_Name => Name_Size),
9646 Make_Attribute_Reference (Loc,
9647 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9648 Attribute_Name => Name_Object_Size));
9650 -- subtype rg__xx is
9651 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
9654 Make_Attribute_Reference (Loc,
9656 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9657 Attribute_Name => Name_Size);
9660 Set_Paren_Count (Sizexpr, 1);
9662 Append_To (List_Def,
9663 Make_Subtype_Declaration (Loc,
9664 Defining_Identifier => Range_Type,
9665 Subtype_Indication =>
9666 Make_Subtype_Indication (Loc,
9667 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9668 Constraint => Make_Range_Constraint (Loc,
9671 Low_Bound => Make_Integer_Literal (Loc, 1),
9673 Make_Op_Divide (Loc,
9674 Left_Opnd => Sizexpr,
9675 Right_Opnd => Make_Integer_Literal (Loc,
9676 Intval => System_Storage_Unit)))))));
9678 -- subtype str__nn is Storage_Array (rg__x);
9680 Str_Type := Make_Temporary (Loc, 'S');
9681 Append_To (List_Def,
9682 Make_Subtype_Declaration (Loc,
9683 Defining_Identifier => Str_Type,
9684 Subtype_Indication =>
9685 Make_Subtype_Indication (Loc,
9686 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9688 Make_Index_Or_Discriminant_Constraint (Loc,
9690 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9692 -- type Equiv_T is record
9693 -- [ _parent : Tnn; ]
9697 Equiv_Type := Make_Temporary (Loc, 'T');
9698 Mutate_Ekind (Equiv_Type, E_Record_Type);
9699 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9701 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9702 -- treatment for this type. In particular, even though _parent's type
9703 -- is a controlled type or contains controlled components, we do not
9704 -- want to set Has_Controlled_Component on it to avoid making it gain
9705 -- an unwanted _controller component.
9707 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9709 -- A class-wide equivalent type does not require initialization
9711 Set_Suppress_Initialization (Equiv_Type);
9713 if not Is_Interface (Root_Typ) then
9714 Append_To (Comp_List,
9715 Make_Component_Declaration (Loc,
9716 Defining_Identifier =>
9717 Make_Defining_Identifier (Loc, Name_uParent),
9718 Component_Definition =>
9719 Make_Component_Definition (Loc,
9720 Aliased_Present => False,
9721 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9723 Set_Reverse_Storage_Order
9724 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
9725 Set_Reverse_Bit_Order
9726 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
9729 Append_To (Comp_List,
9730 Make_Component_Declaration (Loc,
9731 Defining_Identifier => Make_Temporary (Loc, 'C'),
9732 Component_Definition =>
9733 Make_Component_Definition (Loc,
9734 Aliased_Present => False,
9735 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9737 Append_To (List_Def,
9738 Make_Full_Type_Declaration (Loc,
9739 Defining_Identifier => Equiv_Type,
9741 Make_Record_Definition (Loc,
9743 Make_Component_List (Loc,
9744 Component_Items => Comp_List,
9745 Variant_Part => Empty))));
9747 -- Suppress all checks during the analysis of the expanded code to avoid
9748 -- the generation of spurious warnings under ZFP run-time.
9750 Insert_Actions (E, List_Def, Suppress => All_Checks);
9752 end Make_CW_Equivalent_Type;
9754 -------------------------
9755 -- Make_Invariant_Call --
9756 -------------------------
9758 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9759 Loc : constant Source_Ptr := Sloc (Expr);
9760 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9761 pragma Assert (Has_Invariants (Typ));
9762 Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
9763 pragma Assert (Present (Proc_Id));
9765 -- The invariant procedure has a null body if assertions are disabled or
9766 -- Assertion_Policy Ignore is in effect. In that case, generate a null
9767 -- statement instead of a call to the invariant procedure.
9769 if Has_Null_Body (Proc_Id) then
9770 return Make_Null_Statement (Loc);
9773 Make_Procedure_Call_Statement (Loc,
9774 Name => New_Occurrence_Of (Proc_Id, Loc),
9775 Parameter_Associations => New_List (Relocate_Node (Expr)));
9777 end Make_Invariant_Call;
9779 ------------------------
9780 -- Make_Literal_Range --
9781 ------------------------
9783 function Make_Literal_Range
9785 Literal_Typ : Entity_Id) return Node_Id
9787 Lo : constant Node_Id :=
9788 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9789 Index : constant Entity_Id := Etype (Lo);
9790 Length_Expr : constant Node_Id :=
9791 Make_Op_Subtract (Loc,
9793 Make_Integer_Literal (Loc,
9794 Intval => String_Literal_Length (Literal_Typ)),
9795 Right_Opnd => Make_Integer_Literal (Loc, 1));
9800 Set_Analyzed (Lo, False);
9802 if Is_Integer_Type (Index) then
9805 Left_Opnd => New_Copy_Tree (Lo),
9806 Right_Opnd => Length_Expr);
9809 Make_Attribute_Reference (Loc,
9810 Attribute_Name => Name_Val,
9811 Prefix => New_Occurrence_Of (Index, Loc),
9812 Expressions => New_List (
9815 Make_Attribute_Reference (Loc,
9816 Attribute_Name => Name_Pos,
9817 Prefix => New_Occurrence_Of (Index, Loc),
9818 Expressions => New_List (New_Copy_Tree (Lo))),
9819 Right_Opnd => Length_Expr)));
9826 end Make_Literal_Range;
9828 --------------------------
9829 -- Make_Non_Empty_Check --
9830 --------------------------
9832 function Make_Non_Empty_Check
9834 N : Node_Id) return Node_Id
9840 Make_Attribute_Reference (Loc,
9841 Attribute_Name => Name_Length,
9842 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9844 Make_Integer_Literal (Loc, 0));
9845 end Make_Non_Empty_Check;
9847 -------------------------
9848 -- Make_Predicate_Call --
9849 -------------------------
9851 -- WARNING: This routine manages Ghost regions. Return statements must be
9852 -- replaced by gotos which jump to the end of the routine and restore the
9855 function Make_Predicate_Call
9858 Mem : Boolean := False) return Node_Id
9860 Loc : constant Source_Ptr := Sloc (Expr);
9862 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9863 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9864 -- Save the Ghost-related attributes to restore on exit
9867 Func_Id : Entity_Id;
9870 Func_Id := Predicate_Function (Typ);
9871 pragma Assert (Present (Func_Id));
9873 -- The related type may be subject to pragma Ghost. Set the mode now to
9874 -- ensure that the call is properly marked as Ghost.
9876 Set_Ghost_Mode (Typ);
9878 -- Call special membership version if requested and available
9880 if Mem and then Present (Predicate_Function_M (Typ)) then
9881 Func_Id := Predicate_Function_M (Typ);
9884 -- Case of calling normal predicate function
9886 -- If the type is tagged, the expression may be class-wide, in which
9887 -- case it has to be converted to its root type, given that the
9888 -- generated predicate function is not dispatching. The conversion is
9889 -- type-safe and does not need validation, which matters when private
9890 -- extensions are involved.
9892 if Is_Tagged_Type (Typ) then
9894 Make_Function_Call (Loc,
9895 Name => New_Occurrence_Of (Func_Id, Loc),
9896 Parameter_Associations =>
9897 New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
9900 Make_Function_Call (Loc,
9901 Name => New_Occurrence_Of (Func_Id, Loc),
9902 Parameter_Associations => New_List (Relocate_Node (Expr)));
9905 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9908 end Make_Predicate_Call;
9910 --------------------------
9911 -- Make_Predicate_Check --
9912 --------------------------
9914 function Make_Predicate_Check
9916 Expr : Node_Id) return Node_Id
9918 Loc : constant Source_Ptr := Sloc (Expr);
9920 procedure Add_Failure_Expression (Args : List_Id);
9921 -- Add the failure expression of pragma Predicate_Failure (if any) to
9924 ----------------------------
9925 -- Add_Failure_Expression --
9926 ----------------------------
9928 procedure Add_Failure_Expression (Args : List_Id) is
9929 function Failure_Expression return Node_Id;
9930 pragma Inline (Failure_Expression);
9931 -- Find aspect or pragma Predicate_Failure that applies to type Typ
9932 -- and return its expression. Return Empty if no such annotation is
9935 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
9936 pragma Inline (Is_OK_PF_Aspect);
9937 -- Determine whether aspect Asp is a suitable Predicate_Failure
9938 -- aspect that applies to type Typ.
9940 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
9941 pragma Inline (Is_OK_PF_Pragma);
9942 -- Determine whether pragma Prag is a suitable Predicate_Failure
9943 -- pragma that applies to type Typ.
9945 procedure Replace_Subtype_Reference (N : Node_Id);
9946 -- Replace the current instance of type Typ denoted by N with
9949 ------------------------
9950 -- Failure_Expression --
9951 ------------------------
9953 function Failure_Expression return Node_Id is
9957 -- The management of the rep item chain involves "inheritance" of
9958 -- parent type chains. If a parent [sub]type is already subject to
9959 -- pragma Predicate_Failure, then the pragma will also appear in
9960 -- the chain of the child [sub]type, which in turn may possess a
9961 -- pragma of its own. Avoid order-dependent issues by inspecting
9962 -- the rep item chain directly. Note that routine Get_Pragma may
9963 -- return a parent pragma.
9965 Item := First_Rep_Item (Typ);
9966 while Present (Item) loop
9968 -- Predicate_Failure appears as an aspect
9970 if Nkind (Item) = N_Aspect_Specification
9971 and then Is_OK_PF_Aspect (Item)
9973 return Expression (Item);
9975 -- Predicate_Failure appears as a pragma
9977 elsif Nkind (Item) = N_Pragma
9978 and then Is_OK_PF_Pragma (Item)
9982 (Next (First (Pragma_Argument_Associations (Item))));
9985 Next_Rep_Item (Item);
9989 end Failure_Expression;
9991 ---------------------
9992 -- Is_OK_PF_Aspect --
9993 ---------------------
9995 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
9997 -- To qualify, the aspect must apply to the type subjected to the
10001 Chars (Identifier (Asp)) = Name_Predicate_Failure
10002 and then Present (Entity (Asp))
10003 and then Entity (Asp) = Typ;
10004 end Is_OK_PF_Aspect;
10006 ---------------------
10007 -- Is_OK_PF_Pragma --
10008 ---------------------
10010 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
10011 Args : constant List_Id := Pragma_Argument_Associations (Prag);
10015 -- Nothing to do when the pragma does not denote Predicate_Failure
10017 if Pragma_Name (Prag) /= Name_Predicate_Failure then
10020 -- Nothing to do when the pragma lacks arguments, in which case it
10023 elsif No (Args) or else Is_Empty_List (Args) then
10027 Typ_Arg := Get_Pragma_Arg (First (Args));
10029 -- To qualify, the local name argument of the pragma must denote
10030 -- the type subjected to the predicate check.
10033 Is_Entity_Name (Typ_Arg)
10034 and then Present (Entity (Typ_Arg))
10035 and then Entity (Typ_Arg) = Typ;
10036 end Is_OK_PF_Pragma;
10038 --------------------------------
10039 -- Replace_Subtype_Reference --
10040 --------------------------------
10042 procedure Replace_Subtype_Reference (N : Node_Id) is
10044 Rewrite (N, New_Copy_Tree (Expr));
10045 end Replace_Subtype_Reference;
10047 procedure Replace_Subtype_References is
10048 new Replace_Type_References_Generic (Replace_Subtype_Reference);
10052 PF_Expr : constant Node_Id := Failure_Expression;
10055 -- Start of processing for Add_Failure_Expression
10058 if Present (PF_Expr) then
10060 -- Replace any occurrences of the current instance of the type
10061 -- with the object subjected to the predicate check.
10063 Expr := New_Copy_Tree (PF_Expr);
10064 Replace_Subtype_References (Expr, Typ);
10066 -- The failure expression appears as the third argument of the
10070 Make_Pragma_Argument_Association (Loc,
10071 Expression => Expr));
10073 end Add_Failure_Expression;
10080 -- Start of processing for Make_Predicate_Check
10083 -- If predicate checks are suppressed, then return a null statement. For
10084 -- this call, we check only the scope setting. If the caller wants to
10085 -- check a specific entity's setting, they must do it manually.
10087 if Predicate_Checks_Suppressed (Empty) then
10088 return Make_Null_Statement (Loc);
10091 -- Do not generate a check within stream functions and the like.
10093 if not Predicate_Check_In_Scope (Expr) then
10094 return Make_Null_Statement (Loc);
10097 -- Compute proper name to use, we need to get this right so that the
10098 -- right set of check policies apply to the Check pragma we are making.
10100 if Has_Dynamic_Predicate_Aspect (Typ) then
10101 Nam := Name_Dynamic_Predicate;
10102 elsif Has_Static_Predicate_Aspect (Typ) then
10103 Nam := Name_Static_Predicate;
10105 Nam := Name_Predicate;
10109 Make_Pragma_Argument_Association (Loc,
10110 Expression => Make_Identifier (Loc, Nam)),
10111 Make_Pragma_Argument_Association (Loc,
10112 Expression => Make_Predicate_Call (Typ, Expr)));
10114 -- If the subtype is subject to pragma Predicate_Failure, add the
10115 -- failure expression as an additional parameter.
10117 Add_Failure_Expression (Args);
10121 Chars => Name_Check,
10122 Pragma_Argument_Associations => Args);
10123 end Make_Predicate_Check;
10125 ----------------------------
10126 -- Make_Subtype_From_Expr --
10127 ----------------------------
10129 -- 1. If Expr is an unconstrained array expression, creates
10130 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
10132 -- 2. If Expr is a unconstrained discriminated type expression, creates
10133 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
10135 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
10137 function Make_Subtype_From_Expr
10139 Unc_Typ : Entity_Id;
10140 Related_Id : Entity_Id := Empty) return Node_Id
10142 List_Constr : constant List_Id := New_List;
10143 Loc : constant Source_Ptr := Sloc (E);
10145 Full_Exp : Node_Id;
10146 Full_Subtyp : Entity_Id;
10147 High_Bound : Entity_Id;
10148 Index_Typ : Entity_Id;
10149 Low_Bound : Entity_Id;
10150 Priv_Subtyp : Entity_Id;
10154 if Is_Private_Type (Unc_Typ)
10155 and then Has_Unknown_Discriminants (Unc_Typ)
10157 -- The caller requests a unique external name for both the private
10158 -- and the full subtype.
10160 if Present (Related_Id) then
10162 Make_Defining_Identifier (Loc,
10163 Chars => New_External_Name (Chars (Related_Id), 'C'));
10165 Make_Defining_Identifier (Loc,
10166 Chars => New_External_Name (Chars (Related_Id), 'P'));
10169 Full_Subtyp := Make_Temporary (Loc, 'C');
10170 Priv_Subtyp := Make_Temporary (Loc, 'P');
10173 -- Prepare the subtype completion. Use the base type to find the
10174 -- underlying type because the type may be a generic actual or an
10175 -- explicit subtype.
10177 Utyp := Underlying_Type (Base_Type (Unc_Typ));
10180 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
10181 Set_Parent (Full_Exp, Parent (E));
10184 Make_Subtype_Declaration (Loc,
10185 Defining_Identifier => Full_Subtyp,
10186 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
10188 -- Define the dummy private subtype
10190 Mutate_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
10191 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
10192 Set_Scope (Priv_Subtyp, Full_Subtyp);
10193 Set_Is_Constrained (Priv_Subtyp);
10194 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
10195 Set_Is_Itype (Priv_Subtyp);
10196 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
10198 if Is_Tagged_Type (Priv_Subtyp) then
10199 Set_Class_Wide_Type
10200 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
10201 Set_Direct_Primitive_Operations (Priv_Subtyp,
10202 Direct_Primitive_Operations (Unc_Typ));
10205 Set_Full_View (Priv_Subtyp, Full_Subtyp);
10207 return New_Occurrence_Of (Priv_Subtyp, Loc);
10209 elsif Is_Array_Type (Unc_Typ) then
10210 Index_Typ := First_Index (Unc_Typ);
10211 for J in 1 .. Number_Dimensions (Unc_Typ) loop
10213 -- Capture the bounds of each index constraint in case the context
10214 -- is an object declaration of an unconstrained type initialized
10215 -- by a function call:
10217 -- Obj : Unconstr_Typ := Func_Call;
10219 -- This scenario requires secondary scope management and the index
10220 -- constraint cannot depend on the temporary used to capture the
10221 -- result of the function call.
10224 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
10225 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
10226 -- Obj : S := Temp.all;
10227 -- SS_Release; -- Temp is gone at this point, bounds of S are
10228 -- -- non existent.
10231 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
10233 Low_Bound := Make_Temporary (Loc, 'B');
10235 Make_Object_Declaration (Loc,
10236 Defining_Identifier => Low_Bound,
10237 Object_Definition =>
10238 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
10239 Constant_Present => True,
10241 Make_Attribute_Reference (Loc,
10242 Prefix => Duplicate_Subexpr_No_Checks (E),
10243 Attribute_Name => Name_First,
10244 Expressions => New_List (
10245 Make_Integer_Literal (Loc, J)))));
10248 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
10250 High_Bound := Make_Temporary (Loc, 'B');
10252 Make_Object_Declaration (Loc,
10253 Defining_Identifier => High_Bound,
10254 Object_Definition =>
10255 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
10256 Constant_Present => True,
10258 Make_Attribute_Reference (Loc,
10259 Prefix => Duplicate_Subexpr_No_Checks (E),
10260 Attribute_Name => Name_Last,
10261 Expressions => New_List (
10262 Make_Integer_Literal (Loc, J)))));
10264 Append_To (List_Constr,
10266 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
10267 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
10269 Next_Index (Index_Typ);
10272 elsif Is_Class_Wide_Type (Unc_Typ) then
10274 CW_Subtype : Entity_Id;
10275 EQ_Typ : Entity_Id := Empty;
10278 -- A class-wide equivalent type is not needed on VM targets
10279 -- because the VM back-ends handle the class-wide object
10280 -- initialization itself (and doesn't need or want the
10281 -- additional intermediate type to handle the assignment).
10283 if Expander_Active and then Tagged_Type_Expansion then
10285 -- If this is the class-wide type of a completion that is a
10286 -- record subtype, set the type of the class-wide type to be
10287 -- the full base type, for use in the expanded code for the
10288 -- equivalent type. Should this be done earlier when the
10289 -- completion is analyzed ???
10291 if Is_Private_Type (Etype (Unc_Typ))
10293 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
10295 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
10298 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
10301 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
10302 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
10303 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
10305 return New_Occurrence_Of (CW_Subtype, Loc);
10308 -- Indefinite record type with discriminants
10311 D := First_Discriminant (Unc_Typ);
10312 while Present (D) loop
10313 Append_To (List_Constr,
10314 Make_Selected_Component (Loc,
10315 Prefix => Duplicate_Subexpr_No_Checks (E),
10316 Selector_Name => New_Occurrence_Of (D, Loc)));
10318 Next_Discriminant (D);
10323 Make_Subtype_Indication (Loc,
10324 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
10326 Make_Index_Or_Discriminant_Constraint (Loc,
10327 Constraints => List_Constr));
10328 end Make_Subtype_From_Expr;
10330 -----------------------------
10331 -- Make_Variant_Comparison --
10332 -----------------------------
10334 function Make_Variant_Comparison
10337 Curr_Val : Node_Id;
10338 Old_Val : Node_Id) return Node_Id
10341 if Mode = Name_Increases then
10342 return Make_Op_Gt (Loc, Curr_Val, Old_Val);
10343 else pragma Assert (Mode = Name_Decreases);
10344 return Make_Op_Lt (Loc, Curr_Val, Old_Val);
10346 end Make_Variant_Comparison;
10352 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
10354 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
10355 -- avoid deep indentation of code.
10357 -- NOTE: Routines which deal with discriminant mapping operate on the
10358 -- [underlying/record] full view of various types because those views
10359 -- contain all discriminants and stored constraints.
10361 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
10362 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
10363 -- overriding chain starting from Prim whose dispatching type is parent
10364 -- type Par_Typ and add a mapping between the result and primitive Prim.
10366 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
10367 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
10368 -- the inheritance or overriding chain of subprogram Subp. Return Empty
10369 -- if no such primitive is available.
10371 function Build_Chain
10372 (Par_Typ : Entity_Id;
10373 Deriv_Typ : Entity_Id) return Elist_Id;
10374 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
10375 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
10376 -- list has the form:
10380 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
10382 -- Note that Par_Typ is not part of the resulting derivation chain
10384 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
10385 -- Return the view of type Typ which could potentially contains either
10386 -- the discriminants or stored constraints of the type.
10388 function Find_Discriminant_Value
10389 (Discr : Entity_Id;
10390 Par_Typ : Entity_Id;
10391 Deriv_Typ : Entity_Id;
10392 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
10393 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
10394 -- in the derivation chain starting from parent type Par_Typ leading to
10395 -- derived type Deriv_Typ. The returned value is one of the following:
10397 -- * An entity which is either a discriminant or a nondiscriminant
10398 -- name, and renames/constraints Discr.
10400 -- * An expression which constraints Discr
10402 -- Typ_Elmt is an element of the derivation chain created by routine
10403 -- Build_Chain and denotes the current ancestor being examined.
10405 procedure Map_Discriminants
10406 (Par_Typ : Entity_Id;
10407 Deriv_Typ : Entity_Id);
10408 -- Map each discriminant of type Par_Typ to a meaningful constraint
10409 -- from the point of view of type Deriv_Typ.
10411 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
10412 -- Map each primitive of type Par_Typ to a corresponding primitive of
10415 -------------------
10416 -- Add_Primitive --
10417 -------------------
10419 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
10420 Par_Prim : Entity_Id;
10423 -- Inspect the inheritance chain through the Alias attribute and the
10424 -- overriding chain through the Overridden_Operation looking for an
10425 -- ancestor primitive with the appropriate dispatching type.
10428 while Present (Par_Prim) loop
10429 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
10430 Par_Prim := Ancestor_Primitive (Par_Prim);
10433 -- Create a mapping of the form:
10435 -- parent type primitive -> derived type primitive
10437 if Present (Par_Prim) then
10438 Type_Map.Set (Par_Prim, Prim);
10442 ------------------------
10443 -- Ancestor_Primitive --
10444 ------------------------
10446 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
10447 Inher_Prim : constant Entity_Id := Alias (Subp);
10448 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
10451 -- The current subprogram overrides an ancestor primitive
10453 if Present (Over_Prim) then
10456 -- The current subprogram is an internally generated alias of an
10457 -- inherited ancestor primitive.
10459 elsif Present (Inher_Prim) then
10462 -- Otherwise the current subprogram is the root of the inheritance or
10463 -- overriding chain.
10468 end Ancestor_Primitive;
10474 function Build_Chain
10475 (Par_Typ : Entity_Id;
10476 Deriv_Typ : Entity_Id) return Elist_Id
10478 Anc_Typ : Entity_Id;
10480 Curr_Typ : Entity_Id;
10483 Chain := New_Elmt_List;
10485 -- Add the derived type to the derivation chain
10487 Prepend_Elmt (Deriv_Typ, Chain);
10489 -- Examine all ancestors starting from the derived type climbing
10490 -- towards parent type Par_Typ.
10492 Curr_Typ := Deriv_Typ;
10494 -- Handle the case where the current type is a record which
10495 -- derives from a subtype.
10497 -- subtype Sub_Typ is Par_Typ ...
10498 -- type Deriv_Typ is Sub_Typ ...
10500 if Ekind (Curr_Typ) = E_Record_Type
10501 and then Present (Parent_Subtype (Curr_Typ))
10503 Anc_Typ := Parent_Subtype (Curr_Typ);
10505 -- Handle the case where the current type is a record subtype of
10506 -- another subtype.
10508 -- subtype Sub_Typ1 is Par_Typ ...
10509 -- subtype Sub_Typ2 is Sub_Typ1 ...
10511 elsif Ekind (Curr_Typ) = E_Record_Subtype
10512 and then Present (Cloned_Subtype (Curr_Typ))
10514 Anc_Typ := Cloned_Subtype (Curr_Typ);
10516 -- Otherwise use the direct parent type
10519 Anc_Typ := Etype (Curr_Typ);
10522 -- Use the first subtype when dealing with itypes
10524 if Is_Itype (Anc_Typ) then
10525 Anc_Typ := First_Subtype (Anc_Typ);
10528 -- Work with the view which contains the discriminants and stored
10531 Anc_Typ := Discriminated_View (Anc_Typ);
10533 -- Stop the climb when either the parent type has been reached or
10534 -- there are no more ancestors left to examine.
10536 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
10538 Prepend_Unique_Elmt (Anc_Typ, Chain);
10539 Curr_Typ := Anc_Typ;
10545 ------------------------
10546 -- Discriminated_View --
10547 ------------------------
10549 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
10555 -- Use the [underlying] full view when dealing with private types
10556 -- because the view contains all inherited discriminants or stored
10559 if Is_Private_Type (T) then
10560 if Present (Underlying_Full_View (T)) then
10561 T := Underlying_Full_View (T);
10563 elsif Present (Full_View (T)) then
10564 T := Full_View (T);
10568 -- Use the underlying record view when the type is an extenstion of
10569 -- a parent type with unknown discriminants because the view contains
10570 -- all inherited discriminants or stored constraints.
10572 if Ekind (T) = E_Record_Type
10573 and then Present (Underlying_Record_View (T))
10575 T := Underlying_Record_View (T);
10579 end Discriminated_View;
10581 -----------------------------
10582 -- Find_Discriminant_Value --
10583 -----------------------------
10585 function Find_Discriminant_Value
10586 (Discr : Entity_Id;
10587 Par_Typ : Entity_Id;
10588 Deriv_Typ : Entity_Id;
10589 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
10591 Discr_Pos : constant Uint := Discriminant_Number (Discr);
10592 Typ : constant Entity_Id := Node (Typ_Elmt);
10594 function Find_Constraint_Value
10595 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
10596 -- Given constraint Constr, find what it denotes. This is either:
10598 -- * An entity which is either a discriminant or a name
10602 ---------------------------
10603 -- Find_Constraint_Value --
10604 ---------------------------
10606 function Find_Constraint_Value
10607 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
10610 if Nkind (Constr) in N_Entity then
10612 -- The constraint denotes a discriminant of the curren type
10613 -- which renames the ancestor discriminant:
10616 -- type Typ (D1 : ...; DN : ...) is
10617 -- new Anc (Discr => D1) with ...
10620 if Ekind (Constr) = E_Discriminant then
10622 -- The discriminant belongs to derived type Deriv_Typ. This
10623 -- is the final value for the ancestor discriminant as the
10624 -- derivations chain has been fully exhausted.
10626 if Typ = Deriv_Typ then
10629 -- Otherwise the discriminant may be renamed or constrained
10630 -- at a lower level. Continue looking down the derivation
10635 Find_Discriminant_Value
10637 Par_Typ => Par_Typ,
10638 Deriv_Typ => Deriv_Typ,
10639 Typ_Elmt => Next_Elmt (Typ_Elmt));
10642 -- Otherwise the constraint denotes a reference to some name
10643 -- which results in a Girder discriminant:
10647 -- type Typ (D1 : ...; DN : ...) is
10648 -- new Anc (Discr => Name) with ...
10651 -- Return the name as this is the proper constraint of the
10658 -- The constraint denotes a reference to a name
10660 elsif Is_Entity_Name (Constr) then
10661 return Find_Constraint_Value (Entity (Constr));
10663 -- Otherwise the current constraint is an expression which yields
10664 -- a Girder discriminant:
10666 -- type Typ (D1 : ...; DN : ...) is
10667 -- new Anc (Discr => <expression>) with ...
10670 -- Return the expression as this is the proper constraint of the
10676 end Find_Constraint_Value;
10680 Constrs : constant Elist_Id := Stored_Constraint (Typ);
10682 Constr_Elmt : Elmt_Id;
10684 Typ_Discr : Entity_Id;
10686 -- Start of processing for Find_Discriminant_Value
10689 -- The algorithm for finding the value of a discriminant works as
10690 -- follows. First, it recreates the derivation chain from Par_Typ
10691 -- to Deriv_Typ as a list:
10693 -- Par_Typ (shown for completeness)
10695 -- Ancestor_N <-- head of chain
10699 -- Deriv_Typ <-- tail of chain
10701 -- The algorithm then traces the fate of a parent discriminant down
10702 -- the derivation chain. At each derivation level, the discriminant
10703 -- may be either inherited or constrained.
10705 -- 1) Discriminant is inherited: there are two cases, depending on
10706 -- which type is inheriting.
10708 -- 1.1) Deriv_Typ is inheriting:
10710 -- type Ancestor (D_1 : ...) is tagged ...
10711 -- type Deriv_Typ is new Ancestor ...
10713 -- In this case the inherited discriminant is the final value of
10714 -- the parent discriminant because the end of the derivation chain
10715 -- has been reached.
10717 -- 1.2) Some other type is inheriting:
10719 -- type Ancestor_1 (D_1 : ...) is tagged ...
10720 -- type Ancestor_2 is new Ancestor_1 ...
10722 -- In this case the algorithm continues to trace the fate of the
10723 -- inherited discriminant down the derivation chain because it may
10724 -- be further inherited or constrained.
10726 -- 2) Discriminant is constrained: there are three cases, depending
10727 -- on what the constraint is.
10729 -- 2.1) The constraint is another discriminant (aka renaming):
10731 -- type Ancestor_1 (D_1 : ...) is tagged ...
10732 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
10734 -- In this case the constraining discriminant becomes the one to
10735 -- track down the derivation chain. The algorithm already knows
10736 -- that D_2 constrains D_1, therefore if the algorithm finds the
10737 -- value of D_2, then this would also be the value for D_1.
10739 -- 2.2) The constraint is a name (aka Girder):
10742 -- type Ancestor_1 (D_1 : ...) is tagged ...
10743 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
10745 -- In this case the name is the final value of D_1 because the
10746 -- discriminant cannot be further constrained.
10748 -- 2.3) The constraint is an expression (aka Girder):
10750 -- type Ancestor_1 (D_1 : ...) is tagged ...
10751 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10753 -- Similar to 2.2, the expression is the final value of D_1
10757 -- When a derived type constrains its parent type, all constaints
10758 -- appear in the Stored_Constraint list. Examine the list looking
10759 -- for a positional match.
10761 if Present (Constrs) then
10762 Constr_Elmt := First_Elmt (Constrs);
10763 while Present (Constr_Elmt) loop
10765 -- The position of the current constraint matches that of the
10766 -- ancestor discriminant.
10768 if Pos = Discr_Pos then
10769 return Find_Constraint_Value (Node (Constr_Elmt));
10772 Next_Elmt (Constr_Elmt);
10776 -- Otherwise the derived type does not constraint its parent type in
10777 -- which case it inherits the parent discriminants.
10780 Typ_Discr := First_Discriminant (Typ);
10781 while Present (Typ_Discr) loop
10783 -- The position of the current discriminant matches that of the
10784 -- ancestor discriminant.
10786 if Pos = Discr_Pos then
10787 return Find_Constraint_Value (Typ_Discr);
10790 Next_Discriminant (Typ_Discr);
10795 -- A discriminant must always have a corresponding value. This is
10796 -- either another discriminant, a name, or an expression. If this
10797 -- point is reached, them most likely the derivation chain employs
10798 -- the wrong views of types.
10800 pragma Assert (False);
10803 end Find_Discriminant_Value;
10805 -----------------------
10806 -- Map_Discriminants --
10807 -----------------------
10809 procedure Map_Discriminants
10810 (Par_Typ : Entity_Id;
10811 Deriv_Typ : Entity_Id)
10813 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10816 Discr_Val : Node_Or_Entity_Id;
10819 -- Examine each discriminant of parent type Par_Typ and find a
10820 -- suitable value for it from the point of view of derived type
10823 if Has_Discriminants (Par_Typ) then
10824 Discr := First_Discriminant (Par_Typ);
10825 while Present (Discr) loop
10827 Find_Discriminant_Value
10829 Par_Typ => Par_Typ,
10830 Deriv_Typ => Deriv_Typ,
10831 Typ_Elmt => First_Elmt (Deriv_Chain));
10833 -- Create a mapping of the form:
10835 -- parent type discriminant -> value
10837 Type_Map.Set (Discr, Discr_Val);
10839 Next_Discriminant (Discr);
10842 end Map_Discriminants;
10844 --------------------
10845 -- Map_Primitives --
10846 --------------------
10848 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
10849 Deriv_Prim : Entity_Id;
10850 Par_Prim : Entity_Id;
10851 Par_Prims : Elist_Id;
10852 Prim_Elmt : Elmt_Id;
10855 -- Inspect the primitives of the derived type and determine whether
10856 -- they relate to the primitives of the parent type. If there is a
10857 -- meaningful relation, create a mapping of the form:
10859 -- parent type primitive -> perived type primitive
10861 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
10862 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
10863 while Present (Prim_Elmt) loop
10864 Deriv_Prim := Node (Prim_Elmt);
10866 if Is_Subprogram (Deriv_Prim)
10867 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
10869 Add_Primitive (Deriv_Prim, Par_Typ);
10872 Next_Elmt (Prim_Elmt);
10876 -- If the parent operation is an interface operation, the overriding
10877 -- indicator is not present. Instead, we get from the interface
10878 -- operation the primitive of the current type that implements it.
10880 if Is_Interface (Par_Typ) then
10881 Par_Prims := Collect_Primitive_Operations (Par_Typ);
10883 if Present (Par_Prims) then
10884 Prim_Elmt := First_Elmt (Par_Prims);
10886 while Present (Prim_Elmt) loop
10887 Par_Prim := Node (Prim_Elmt);
10889 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
10891 if Present (Deriv_Prim) then
10892 Type_Map.Set (Par_Prim, Deriv_Prim);
10895 Next_Elmt (Prim_Elmt);
10899 end Map_Primitives;
10901 -- Start of processing for Map_Types
10904 -- Nothing to do if there are no types to work with
10906 if No (Parent_Type) or else No (Derived_Type) then
10909 -- Nothing to do if the mapping already exists
10911 elsif Type_Map.Get (Parent_Type) = Derived_Type then
10914 -- Nothing to do if both types are not tagged. Note that untagged types
10915 -- do not have primitive operations and their discriminants are already
10916 -- handled by gigi.
10918 elsif not Is_Tagged_Type (Parent_Type)
10919 or else not Is_Tagged_Type (Derived_Type)
10924 -- Create a mapping of the form
10926 -- parent type -> derived type
10928 -- to prevent any subsequent attempts to produce the same relations
10930 Type_Map.Set (Parent_Type, Derived_Type);
10932 -- Create mappings of the form
10934 -- parent type discriminant -> derived type discriminant
10936 -- parent type discriminant -> constraint
10938 -- Note that mapping of discriminants breaks privacy because it needs to
10939 -- work with those views which contains the discriminants and any stored
10943 (Par_Typ => Discriminated_View (Parent_Type),
10944 Deriv_Typ => Discriminated_View (Derived_Type));
10946 -- Create mappings of the form
10948 -- parent type primitive -> derived type primitive
10951 (Par_Typ => Parent_Type,
10952 Deriv_Typ => Derived_Type);
10955 ----------------------------
10956 -- Matching_Standard_Type --
10957 ----------------------------
10959 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
10960 pragma Assert (Is_Scalar_Type (Typ));
10961 Siz : constant Uint := Esize (Typ);
10964 -- Floating-point cases
10966 if Is_Floating_Point_Type (Typ) then
10967 if Siz <= Esize (Standard_Short_Float) then
10968 return Standard_Short_Float;
10969 elsif Siz <= Esize (Standard_Float) then
10970 return Standard_Float;
10971 elsif Siz <= Esize (Standard_Long_Float) then
10972 return Standard_Long_Float;
10973 elsif Siz <= Esize (Standard_Long_Long_Float) then
10974 return Standard_Long_Long_Float;
10976 raise Program_Error;
10979 -- Integer cases (includes fixed-point types)
10981 -- Unsigned integer cases (includes normal enumeration types)
10984 return Small_Integer_Type_For (Siz, Is_Unsigned_Type (Typ));
10986 end Matching_Standard_Type;
10988 -----------------------------
10989 -- May_Generate_Large_Temp --
10990 -----------------------------
10992 -- At the current time, the only types that we return False for (i.e. where
10993 -- we decide we know they cannot generate large temps) are ones where we
10994 -- know the size is 256 bits or less at compile time, and we are still not
10995 -- doing a thorough job on arrays and records ???
10997 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
10999 if not Size_Known_At_Compile_Time (Typ) then
11002 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
11005 elsif Is_Array_Type (Typ)
11006 and then Present (Packed_Array_Impl_Type (Typ))
11008 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
11010 -- We could do more here to find other small types ???
11015 end May_Generate_Large_Temp;
11017 --------------------------------------------
11018 -- Needs_Conditional_Null_Excluding_Check --
11019 --------------------------------------------
11021 function Needs_Conditional_Null_Excluding_Check
11022 (Typ : Entity_Id) return Boolean
11026 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
11027 end Needs_Conditional_Null_Excluding_Check;
11029 ----------------------------
11030 -- Needs_Constant_Address --
11031 ----------------------------
11033 function Needs_Constant_Address
11035 Typ : Entity_Id) return Boolean
11038 -- If we have no initialization of any kind, then we don't need to place
11039 -- any restrictions on the address clause, because the object will be
11040 -- elaborated after the address clause is evaluated. This happens if the
11041 -- declaration has no initial expression, or the type has no implicit
11042 -- initialization, or the object is imported.
11044 -- The same holds for all initialized scalar types and all access types.
11045 -- Packed bit array types of size up to the maximum integer size are
11046 -- represented using a modular type with an initialization (to zero) and
11047 -- can be processed like other initialized scalar types.
11049 -- If the type is controlled, code to attach the object to a
11050 -- finalization chain is generated at the point of declaration, and
11051 -- therefore the elaboration of the object cannot be delayed: the
11052 -- address expression must be a constant.
11054 if No (Expression (Decl))
11055 and then not Needs_Finalization (Typ)
11057 (not Has_Non_Null_Base_Init_Proc (Typ)
11058 or else Is_Imported (Defining_Identifier (Decl)))
11062 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
11063 or else Is_Access_Type (Typ)
11065 (Is_Bit_Packed_Array (Typ)
11066 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
11071 -- Otherwise, we require the address clause to be constant because
11072 -- the call to the initialization procedure (or the attach code) has
11073 -- to happen at the point of the declaration.
11075 -- Actually the IP call has been moved to the freeze actions anyway,
11076 -- so maybe we can relax this restriction???
11080 end Needs_Constant_Address;
11082 ----------------------------
11083 -- New_Class_Wide_Subtype --
11084 ----------------------------
11086 function New_Class_Wide_Subtype
11087 (CW_Typ : Entity_Id;
11088 N : Node_Id) return Entity_Id
11090 Res : constant Entity_Id := Create_Itype (E_Void, N);
11092 -- Capture relevant attributes of the class-wide subtype which must be
11093 -- restored after the copy.
11095 Res_Chars : constant Name_Id := Chars (Res);
11096 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
11097 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
11098 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
11099 Res_Scope : constant Entity_Id := Scope (Res);
11102 Copy_Node (CW_Typ, Res);
11104 -- Restore the relevant attributes of the class-wide subtype
11106 Set_Chars (Res, Res_Chars);
11107 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
11108 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
11109 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
11110 Set_Scope (Res, Res_Scope);
11112 -- Decorate the class-wide subtype
11114 Set_Associated_Node_For_Itype (Res, N);
11115 Set_Comes_From_Source (Res, False);
11116 Mutate_Ekind (Res, E_Class_Wide_Subtype);
11117 Set_Etype (Res, Base_Type (CW_Typ));
11118 Set_Freeze_Node (Res, Empty);
11119 Set_Is_Frozen (Res, False);
11120 Set_Is_Itype (Res);
11121 Set_Is_Public (Res, False);
11122 Set_Next_Entity (Res, Empty);
11123 Set_Prev_Entity (Res, Empty);
11124 Set_Sloc (Res, Sloc (N));
11126 Set_Public_Status (Res);
11129 end New_Class_Wide_Subtype;
11131 -----------------------------------
11132 -- OK_To_Do_Constant_Replacement --
11133 -----------------------------------
11135 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
11136 ES : constant Entity_Id := Scope (E);
11140 -- Do not replace statically allocated objects, because they may be
11141 -- modified outside the current scope.
11143 if Is_Statically_Allocated (E) then
11146 -- Do not replace aliased or volatile objects, since we don't know what
11147 -- else might change the value.
11149 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
11152 -- Debug flag -gnatdM disconnects this optimization
11154 elsif Debug_Flag_MM then
11157 -- Otherwise check scopes
11160 CS := Current_Scope;
11163 -- If we are in right scope, replacement is safe
11168 -- Packages do not affect the determination of safety
11170 elsif Ekind (CS) = E_Package then
11171 exit when CS = Standard_Standard;
11174 -- Blocks do not affect the determination of safety
11176 elsif Ekind (CS) = E_Block then
11179 -- Loops do not affect the determination of safety. Note that we
11180 -- kill all current values on entry to a loop, so we are just
11181 -- talking about processing within a loop here.
11183 elsif Ekind (CS) = E_Loop then
11186 -- Otherwise, the reference is dubious, and we cannot be sure that
11187 -- it is safe to do the replacement.
11196 end OK_To_Do_Constant_Replacement;
11198 ------------------------------------
11199 -- Possible_Bit_Aligned_Component --
11200 ------------------------------------
11202 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
11204 -- Do not process an unanalyzed node because it is not yet decorated and
11205 -- most checks performed below will fail.
11207 if not Analyzed (N) then
11211 -- There are never alignment issues in CodePeer mode
11213 if CodePeer_Mode then
11219 -- Case of indexed component
11221 when N_Indexed_Component =>
11223 P : constant Node_Id := Prefix (N);
11224 Ptyp : constant Entity_Id := Etype (P);
11227 -- If we know the component size and it is not larger than the
11228 -- maximum integer size, then we are OK. The back end does the
11229 -- assignment of small misaligned objects correctly.
11231 if Known_Static_Component_Size (Ptyp)
11232 and then Component_Size (Ptyp) <= System_Max_Integer_Size
11236 -- Otherwise, we need to test the prefix, to see if we are
11237 -- indexing from a possibly unaligned component.
11240 return Possible_Bit_Aligned_Component (P);
11244 -- Case of selected component
11246 when N_Selected_Component =>
11248 P : constant Node_Id := Prefix (N);
11249 Comp : constant Entity_Id := Entity (Selector_Name (N));
11252 -- This is the crucial test: if the component itself causes
11253 -- trouble, then we can stop and return True.
11255 if Component_May_Be_Bit_Aligned (Comp) then
11258 -- Otherwise, we need to test the prefix, to see if we are
11259 -- selecting from a possibly unaligned component.
11262 return Possible_Bit_Aligned_Component (P);
11266 -- For a slice, test the prefix, if that is possibly misaligned,
11267 -- then for sure the slice is.
11270 return Possible_Bit_Aligned_Component (Prefix (N));
11272 -- For an unchecked conversion, check whether the expression may
11275 when N_Unchecked_Type_Conversion =>
11276 return Possible_Bit_Aligned_Component (Expression (N));
11278 -- If we have none of the above, it means that we have fallen off the
11279 -- top testing prefixes recursively, and we now have a stand alone
11280 -- object, where we don't have a problem, unless this is a renaming,
11281 -- in which case we need to look into the renamed object.
11284 if Is_Entity_Name (N)
11285 and then Present (Renamed_Object (Entity (N)))
11288 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
11293 end Possible_Bit_Aligned_Component;
11295 -----------------------------------------------
11296 -- Process_Statements_For_Controlled_Objects --
11297 -----------------------------------------------
11299 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
11300 Loc : constant Source_Ptr := Sloc (N);
11302 function Are_Wrapped (L : List_Id) return Boolean;
11303 -- Determine whether list L contains only one statement which is a block
11305 function Wrap_Statements_In_Block
11307 Scop : Entity_Id := Current_Scope) return Node_Id;
11308 -- Given a list of statements L, wrap it in a block statement and return
11309 -- the generated node. Scop is either the current scope or the scope of
11310 -- the context (if applicable).
11316 function Are_Wrapped (L : List_Id) return Boolean is
11317 Stmt : constant Node_Id := First (L);
11321 and then No (Next (Stmt))
11322 and then Nkind (Stmt) = N_Block_Statement;
11325 ------------------------------
11326 -- Wrap_Statements_In_Block --
11327 ------------------------------
11329 function Wrap_Statements_In_Block
11331 Scop : Entity_Id := Current_Scope) return Node_Id
11333 Block_Id : Entity_Id;
11334 Block_Nod : Node_Id;
11335 Iter_Loop : Entity_Id;
11339 Make_Block_Statement (Loc,
11340 Declarations => No_List,
11341 Handled_Statement_Sequence =>
11342 Make_Handled_Sequence_Of_Statements (Loc,
11345 -- Create a label for the block in case the block needs to manage the
11346 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
11348 Add_Block_Identifier (Block_Nod, Block_Id);
11350 -- When wrapping the statements of an iterator loop, check whether
11351 -- the loop requires secondary stack management and if so, propagate
11352 -- the appropriate flags to the block. This ensures that the cursor
11353 -- is properly cleaned up at each iteration of the loop.
11355 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
11357 if Present (Iter_Loop) then
11358 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
11360 -- Secondary stack reclamation is suppressed when the associated
11361 -- iterator loop contains a return statement which uses the stack.
11363 Set_Sec_Stack_Needed_For_Return
11364 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
11368 end Wrap_Statements_In_Block;
11374 -- Start of processing for Process_Statements_For_Controlled_Objects
11377 -- Whenever a non-handled statement list is wrapped in a block, the
11378 -- block must be explicitly analyzed to redecorate all entities in the
11379 -- list and ensure that a finalizer is properly built.
11382 when N_Conditional_Entry_Call
11385 | N_Selective_Accept
11387 -- Check the "then statements" for elsif parts and if statements
11389 if Nkind (N) in N_Elsif_Part | N_If_Statement
11390 and then not Is_Empty_List (Then_Statements (N))
11391 and then not Are_Wrapped (Then_Statements (N))
11392 and then Requires_Cleanup_Actions
11393 (L => Then_Statements (N),
11394 Lib_Level => False,
11395 Nested_Constructs => False)
11397 Block := Wrap_Statements_In_Block (Then_Statements (N));
11398 Set_Then_Statements (N, New_List (Block));
11403 -- Check the "else statements" for conditional entry calls, if
11404 -- statements and selective accepts.
11407 N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept
11408 and then not Is_Empty_List (Else_Statements (N))
11409 and then not Are_Wrapped (Else_Statements (N))
11410 and then Requires_Cleanup_Actions
11411 (L => Else_Statements (N),
11412 Lib_Level => False,
11413 Nested_Constructs => False)
11415 Block := Wrap_Statements_In_Block (Else_Statements (N));
11416 Set_Else_Statements (N, New_List (Block));
11421 when N_Abortable_Part
11422 | N_Accept_Alternative
11423 | N_Case_Statement_Alternative
11424 | N_Delay_Alternative
11425 | N_Entry_Call_Alternative
11426 | N_Exception_Handler
11428 | N_Triggering_Alternative
11430 if not Is_Empty_List (Statements (N))
11431 and then not Are_Wrapped (Statements (N))
11432 and then Requires_Cleanup_Actions
11433 (L => Statements (N),
11434 Lib_Level => False,
11435 Nested_Constructs => False)
11437 if Nkind (N) = N_Loop_Statement
11438 and then Present (Identifier (N))
11441 Wrap_Statements_In_Block
11442 (L => Statements (N),
11443 Scop => Entity (Identifier (N)));
11445 Block := Wrap_Statements_In_Block (Statements (N));
11448 Set_Statements (N, New_List (Block));
11452 -- Could be e.g. a loop that was transformed into a block or null
11453 -- statement. Do nothing for terminate alternatives.
11455 when N_Block_Statement
11457 | N_Terminate_Alternative
11462 raise Program_Error;
11464 end Process_Statements_For_Controlled_Objects;
11470 function Power_Of_Two (N : Node_Id) return Nat is
11471 Typ : constant Entity_Id := Etype (N);
11472 pragma Assert (Is_Integer_Type (Typ));
11474 Siz : constant Nat := UI_To_Int (Esize (Typ));
11478 if not Compile_Time_Known_Value (N) then
11482 Val := Expr_Value (N);
11483 for J in 1 .. Siz - 1 loop
11484 if Val = Uint_2 ** J then
11493 ----------------------
11494 -- Remove_Init_Call --
11495 ----------------------
11497 function Remove_Init_Call
11499 Rep_Clause : Node_Id) return Node_Id
11501 Par : constant Node_Id := Parent (Var);
11502 Typ : constant Entity_Id := Etype (Var);
11504 Init_Proc : Entity_Id;
11505 -- Initialization procedure for Typ
11507 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
11508 -- Look for init call for Var starting at From and scanning the
11509 -- enclosing list until Rep_Clause or the end of the list is reached.
11511 ----------------------------
11512 -- Find_Init_Call_In_List --
11513 ----------------------------
11515 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
11516 Init_Call : Node_Id;
11520 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
11521 if Nkind (Init_Call) = N_Procedure_Call_Statement
11522 and then Is_Entity_Name (Name (Init_Call))
11523 and then Entity (Name (Init_Call)) = Init_Proc
11532 end Find_Init_Call_In_List;
11534 Init_Call : Node_Id;
11536 -- Start of processing for Remove_Init_Call
11539 if Present (Initialization_Statements (Var)) then
11540 Init_Call := Initialization_Statements (Var);
11541 Set_Initialization_Statements (Var, Empty);
11543 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
11545 -- No init proc for the type, so obviously no call to be found
11550 -- We might be able to handle other cases below by just properly
11551 -- setting Initialization_Statements at the point where the init proc
11552 -- call is generated???
11554 Init_Proc := Base_Init_Proc (Typ);
11556 -- First scan the list containing the declaration of Var
11558 Init_Call := Find_Init_Call_In_List (From => Next (Par));
11560 -- If not found, also look on Var's freeze actions list, if any,
11561 -- since the init call may have been moved there (case of an address
11562 -- clause applying to Var).
11564 if No (Init_Call) and then Present (Freeze_Node (Var)) then
11566 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
11569 -- If the initialization call has actuals that use the secondary
11570 -- stack, the call may have been wrapped into a temporary block, in
11571 -- which case the block itself has to be removed.
11573 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
11575 Blk : constant Node_Id := Next (Par);
11578 (Find_Init_Call_In_List
11579 (First (Statements (Handled_Statement_Sequence (Blk)))))
11587 if Present (Init_Call) then
11588 -- If restrictions have forbidden Aborts, the initialization call
11589 -- for objects that require deep initialization has not been wrapped
11590 -- into the following block (see Exp_Ch3, Default_Initialize_Object)
11591 -- so if present remove it as well, and include the IP call in it,
11592 -- in the rare case the caller may need to simply displace the
11593 -- initialization, as is done for a later address specification.
11595 if Nkind (Next (Init_Call)) = N_Block_Statement
11596 and then Is_Initialization_Block (Next (Init_Call))
11599 IP_Call : constant Node_Id := Init_Call;
11601 Init_Call := Next (IP_Call);
11604 Statements (Handled_Statement_Sequence (Init_Call)));
11608 Remove (Init_Call);
11612 end Remove_Init_Call;
11614 -------------------------
11615 -- Remove_Side_Effects --
11616 -------------------------
11618 procedure Remove_Side_Effects
11620 Name_Req : Boolean := False;
11621 Renaming_Req : Boolean := False;
11622 Variable_Ref : Boolean := False;
11623 Related_Id : Entity_Id := Empty;
11624 Is_Low_Bound : Boolean := False;
11625 Is_High_Bound : Boolean := False;
11626 Check_Side_Effects : Boolean := True)
11628 function Build_Temporary
11631 Related_Nod : Node_Id := Empty) return Entity_Id;
11632 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
11633 -- is present (xxx is taken from the Chars field of Related_Nod),
11634 -- otherwise it generates an internal temporary. The created temporary
11635 -- entity is marked as internal.
11637 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean;
11638 -- Computes whether a side effect is possible in SPARK, which should
11639 -- be handled by removing it from the expression for GNATprove. Note
11640 -- that other side effects related to volatile variables are handled
11643 ---------------------
11644 -- Build_Temporary --
11645 ---------------------
11647 function Build_Temporary
11650 Related_Nod : Node_Id := Empty) return Entity_Id
11652 Temp_Id : Entity_Id;
11653 Temp_Nam : Name_Id;
11656 -- The context requires an external symbol
11658 if Present (Related_Id) then
11659 if Is_Low_Bound then
11660 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
11661 else pragma Assert (Is_High_Bound);
11662 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
11665 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
11667 -- Otherwise generate an internal temporary
11670 Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
11673 Set_Is_Internal (Temp_Id);
11676 end Build_Temporary;
11678 -----------------------------------
11679 -- Possible_Side_Effect_In_SPARK --
11680 -----------------------------------
11682 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean is
11684 -- Side-effect removal in SPARK should only occur when not inside a
11685 -- generic and not doing a preanalysis, inside an object renaming or
11686 -- a type declaration or a for-loop iteration scheme.
11688 return not Inside_A_Generic
11689 and then Full_Analysis
11690 and then Nkind (Enclosing_Declaration (Exp)) in
11691 N_Component_Declaration
11692 | N_Full_Type_Declaration
11693 | N_Iterator_Specification
11694 | N_Loop_Parameter_Specification
11695 | N_Object_Renaming_Declaration
11696 | N_Subtype_Declaration;
11697 end Possible_Side_Effect_In_SPARK;
11701 Loc : constant Source_Ptr := Sloc (Exp);
11702 Exp_Type : constant Entity_Id := Etype (Exp);
11703 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
11704 Def_Id : Entity_Id;
11707 Ptr_Typ_Decl : Node_Id;
11708 Ref_Type : Entity_Id;
11711 -- Start of processing for Remove_Side_Effects
11714 -- Handle cases in which there is nothing to do. In GNATprove mode,
11715 -- removal of side effects is useful for the light expansion of
11718 if not Expander_Active
11720 (GNATprove_Mode and then Possible_Side_Effect_In_SPARK (Exp))
11724 -- Cannot generate temporaries if the invocation to remove side effects
11725 -- was issued too early and the type of the expression is not resolved
11726 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
11727 -- Remove_Side_Effects).
11729 elsif No (Exp_Type)
11730 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11734 -- Nothing to do if prior expansion determined that a function call does
11735 -- not require side effect removal.
11737 elsif Nkind (Exp) = N_Function_Call
11738 and then No_Side_Effect_Removal (Exp)
11742 -- No action needed for side-effect free expressions
11744 elsif Check_Side_Effects
11745 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11749 -- Generating C code we cannot remove side effect of function returning
11750 -- class-wide types since there is no secondary stack (required to use
11753 elsif Modify_Tree_For_C
11754 and then Nkind (Exp) = N_Function_Call
11755 and then Is_Class_Wide_Type (Etype (Exp))
11760 -- The remaining processing is done with all checks suppressed
11762 -- Note: from now on, don't use return statements, instead do a goto
11763 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11765 Scope_Suppress.Suppress := (others => True);
11767 -- If this is a side-effect free attribute reference whose expressions
11768 -- are also side-effect free and whose prefix is not a name, remove the
11769 -- side effects of the prefix. A copy of the prefix is required in this
11770 -- case and it is better not to make an additional one for the attribute
11771 -- itself, because the return type of many of them is universal integer,
11772 -- which is a very large type for a temporary.
11774 if Nkind (Exp) = N_Attribute_Reference
11775 and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
11776 and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
11777 and then not Is_Name_Reference (Prefix (Exp))
11779 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11782 -- If this is an elementary or a small not-by-reference record type, and
11783 -- we need to capture the value, just make a constant; this is cheap and
11784 -- objects of both kinds of types can be bit aligned, so it might not be
11785 -- possible to generate a reference to them. Likewise if this is not a
11786 -- name reference, except for a type conversion, because we would enter
11787 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11788 -- type has predicates (and type conversions need a specific treatment
11789 -- anyway, see below). Also do it if we have a volatile reference and
11790 -- Name_Req is not set (see comments for Side_Effect_Free).
11792 elsif (Is_Elementary_Type (Exp_Type)
11793 or else (Is_Record_Type (Exp_Type)
11794 and then Known_Static_RM_Size (Exp_Type)
11795 and then RM_Size (Exp_Type) <= System_Max_Integer_Size
11796 and then not Has_Discriminants (Exp_Type)
11797 and then not Is_By_Reference_Type (Exp_Type)))
11798 and then (Variable_Ref
11799 or else (not Is_Name_Reference (Exp)
11800 and then Nkind (Exp) /= N_Type_Conversion)
11801 or else (not Name_Req
11802 and then Is_Volatile_Reference (Exp)))
11804 Def_Id := Build_Temporary (Loc, 'R', Exp);
11805 Set_Etype (Def_Id, Exp_Type);
11806 Res := New_Occurrence_Of (Def_Id, Loc);
11808 -- If the expression is a packed reference, it must be reanalyzed and
11809 -- expanded, depending on context. This is the case for actuals where
11810 -- a constraint check may capture the actual before expansion of the
11811 -- call is complete.
11813 if Nkind (Exp) = N_Indexed_Component
11814 and then Is_Packed (Etype (Prefix (Exp)))
11816 Set_Analyzed (Exp, False);
11817 Set_Analyzed (Prefix (Exp), False);
11821 -- Rnn : Exp_Type renames Expr;
11823 -- In GNATprove mode, we prefer to use renamings for intermediate
11824 -- variables to definition of constants, due to the implicit move
11825 -- operation that such a constant definition causes as part of the
11826 -- support in GNATprove for ownership pointers. Hence, we generate
11827 -- a renaming for a reference to an object of a nonscalar type.
11830 or else (GNATprove_Mode
11831 and then Is_Object_Reference (Exp)
11832 and then not Is_Scalar_Type (Exp_Type))
11835 Make_Object_Renaming_Declaration (Loc,
11836 Defining_Identifier => Def_Id,
11837 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11838 Name => Relocate_Node (Exp));
11841 -- Rnn : constant Exp_Type := Expr;
11845 Make_Object_Declaration (Loc,
11846 Defining_Identifier => Def_Id,
11847 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11848 Constant_Present => True,
11849 Expression => Relocate_Node (Exp));
11851 Set_Assignment_OK (E);
11854 Insert_Action (Exp, E);
11856 -- If the expression has the form v.all then we can just capture the
11857 -- pointer, and then do an explicit dereference on the result, but
11858 -- this is not right if this is a volatile reference.
11860 elsif Nkind (Exp) = N_Explicit_Dereference
11861 and then not Is_Volatile_Reference (Exp)
11863 Def_Id := Build_Temporary (Loc, 'R', Exp);
11865 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
11867 Insert_Action (Exp,
11868 Make_Object_Declaration (Loc,
11869 Defining_Identifier => Def_Id,
11870 Object_Definition =>
11871 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
11872 Constant_Present => True,
11873 Expression => Relocate_Node (Prefix (Exp))));
11875 -- Similar processing for an unchecked conversion of an expression of
11876 -- the form v.all, where we want the same kind of treatment.
11878 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11879 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
11881 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11884 -- If this is a type conversion, leave the type conversion and remove
11885 -- side effects in the expression, unless it is of universal integer,
11886 -- which is a very large type for a temporary. This is important in
11887 -- several circumstances: for change of representations and also when
11888 -- this is a view conversion to a smaller object, where gigi can end
11889 -- up creating its own temporary of the wrong size.
11891 elsif Nkind (Exp) = N_Type_Conversion
11892 and then Etype (Expression (Exp)) /= Universal_Integer
11894 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11896 -- Generating C code the type conversion of an access to constrained
11897 -- array type into an access to unconstrained array type involves
11898 -- initializing a fat pointer and the expression must be free of
11899 -- side effects to safely compute its bounds.
11901 if Modify_Tree_For_C
11902 and then Is_Access_Type (Etype (Exp))
11903 and then Is_Array_Type (Designated_Type (Etype (Exp)))
11904 and then not Is_Constrained (Designated_Type (Etype (Exp)))
11906 Def_Id := Build_Temporary (Loc, 'R', Exp);
11907 Set_Etype (Def_Id, Exp_Type);
11908 Res := New_Occurrence_Of (Def_Id, Loc);
11910 Insert_Action (Exp,
11911 Make_Object_Declaration (Loc,
11912 Defining_Identifier => Def_Id,
11913 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11914 Constant_Present => True,
11915 Expression => Relocate_Node (Exp)));
11920 -- If this is an unchecked conversion that Gigi can't handle, make
11921 -- a copy or a use a renaming to capture the value.
11923 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11924 and then not Safe_Unchecked_Type_Conversion (Exp)
11926 if CW_Or_Has_Controlled_Part (Exp_Type) then
11928 -- Use a renaming to capture the expression, rather than create
11929 -- a controlled temporary.
11931 Def_Id := Build_Temporary (Loc, 'R', Exp);
11932 Res := New_Occurrence_Of (Def_Id, Loc);
11934 Insert_Action (Exp,
11935 Make_Object_Renaming_Declaration (Loc,
11936 Defining_Identifier => Def_Id,
11937 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11938 Name => Relocate_Node (Exp)));
11941 Def_Id := Build_Temporary (Loc, 'R', Exp);
11942 Set_Etype (Def_Id, Exp_Type);
11943 Res := New_Occurrence_Of (Def_Id, Loc);
11946 Make_Object_Declaration (Loc,
11947 Defining_Identifier => Def_Id,
11948 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11949 Constant_Present => not Is_Variable (Exp),
11950 Expression => Relocate_Node (Exp));
11952 Set_Assignment_OK (E);
11953 Insert_Action (Exp, E);
11956 -- If this is a packed array component or a selected component with a
11957 -- nonstandard representation, we cannot generate a reference because
11958 -- the component may be unaligned, so we must use a renaming and this
11959 -- renaming is handled by the front end, as the back end may balk at
11960 -- the nonstandard representation (see Evaluation_Required in Exp_Ch8).
11962 elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
11963 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
11965 Def_Id := Build_Temporary (Loc, 'R', Exp);
11966 Res := New_Occurrence_Of (Def_Id, Loc);
11968 Insert_Action (Exp,
11969 Make_Object_Renaming_Declaration (Loc,
11970 Defining_Identifier => Def_Id,
11971 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11972 Name => Relocate_Node (Exp)));
11974 -- For an expression that denotes a name, we can use a renaming scheme.
11975 -- This is needed for correctness in the case of a volatile object of
11976 -- a nonvolatile type because the Make_Reference call of the "default"
11977 -- approach would generate an illegal access value (an access value
11978 -- cannot designate such an object - see Analyze_Reference).
11980 elsif Is_Name_Reference (Exp)
11982 -- We skip using this scheme if we have an object of a volatile
11983 -- type and we do not have Name_Req set true (see comments for
11984 -- Side_Effect_Free).
11986 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
11988 Def_Id := Build_Temporary (Loc, 'R', Exp);
11989 Res := New_Occurrence_Of (Def_Id, Loc);
11991 Insert_Action (Exp,
11992 Make_Object_Renaming_Declaration (Loc,
11993 Defining_Identifier => Def_Id,
11994 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11995 Name => Relocate_Node (Exp)));
11997 -- Avoid generating a variable-sized temporary, by generating the
11998 -- reference just for the function call. The transformation could be
11999 -- refined to apply only when the array component is constrained by a
12002 elsif Nkind (Exp) = N_Selected_Component
12003 and then Nkind (Prefix (Exp)) = N_Function_Call
12004 and then Is_Array_Type (Exp_Type)
12006 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
12009 -- Otherwise we generate a reference to the expression
12012 -- When generating C code we cannot consider side effect free object
12013 -- declarations that have discriminants and are initialized by means
12014 -- of a function call since on this target there is no secondary
12015 -- stack to store the return value and the expander may generate an
12016 -- extra call to the function to compute the discriminant value. In
12017 -- addition, for targets that have secondary stack, the expansion of
12018 -- functions with side effects involves the generation of an access
12019 -- type to capture the return value stored in the secondary stack;
12020 -- by contrast when generating C code such expansion generates an
12021 -- internal object declaration (no access type involved) which must
12022 -- be identified here to avoid entering into a never-ending loop
12023 -- generating internal object declarations.
12025 if Modify_Tree_For_C
12026 and then Nkind (Parent (Exp)) = N_Object_Declaration
12028 (Nkind (Exp) /= N_Function_Call
12029 or else not Has_Discriminants (Exp_Type)
12030 or else Is_Internal_Name
12031 (Chars (Defining_Identifier (Parent (Exp)))))
12036 -- Special processing for function calls that return a limited type.
12037 -- We need to build a declaration that will enable build-in-place
12038 -- expansion of the call. This is not done if the context is already
12039 -- an object declaration, to prevent infinite recursion.
12041 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
12042 -- to accommodate functions returning limited objects by reference.
12044 if Ada_Version >= Ada_2005
12045 and then Nkind (Exp) = N_Function_Call
12046 and then Is_Limited_View (Etype (Exp))
12047 and then Nkind (Parent (Exp)) /= N_Object_Declaration
12050 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
12055 Make_Object_Declaration (Loc,
12056 Defining_Identifier => Obj,
12057 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
12058 Expression => Relocate_Node (Exp));
12060 Insert_Action (Exp, Decl);
12061 Set_Etype (Obj, Exp_Type);
12062 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
12067 Def_Id := Build_Temporary (Loc, 'R', Exp);
12069 -- The regular expansion of functions with side effects involves the
12070 -- generation of an access type to capture the return value found on
12071 -- the secondary stack. Since SPARK (and why) cannot process access
12072 -- types, use a different approach which ignores the secondary stack
12073 -- and "copies" the returned object.
12074 -- When generating C code, no need for a 'reference since the
12075 -- secondary stack is not supported.
12077 if GNATprove_Mode or Modify_Tree_For_C then
12078 Res := New_Occurrence_Of (Def_Id, Loc);
12079 Ref_Type := Exp_Type;
12081 -- Regular expansion utilizing an access type and 'reference
12085 Make_Explicit_Dereference (Loc,
12086 Prefix => New_Occurrence_Of (Def_Id, Loc));
12089 -- type Ann is access all <Exp_Type>;
12091 Ref_Type := Make_Temporary (Loc, 'A');
12094 Make_Full_Type_Declaration (Loc,
12095 Defining_Identifier => Ref_Type,
12097 Make_Access_To_Object_Definition (Loc,
12098 All_Present => True,
12099 Subtype_Indication =>
12100 New_Occurrence_Of (Exp_Type, Loc)));
12102 Insert_Action (Exp, Ptr_Typ_Decl);
12106 if Nkind (E) = N_Explicit_Dereference then
12107 New_Exp := Relocate_Node (Prefix (E));
12110 E := Relocate_Node (E);
12112 -- Do not generate a 'reference in SPARK mode or C generation
12113 -- since the access type is not created in the first place.
12115 if GNATprove_Mode or Modify_Tree_For_C then
12118 -- Otherwise generate reference, marking the value as non-null
12119 -- since we know it cannot be null and we don't want a check.
12122 New_Exp := Make_Reference (Loc, E);
12123 Set_Is_Known_Non_Null (Def_Id);
12127 if Is_Delayed_Aggregate (E) then
12129 -- The expansion of nested aggregates is delayed until the
12130 -- enclosing aggregate is expanded. As aggregates are often
12131 -- qualified, the predicate applies to qualified expressions as
12132 -- well, indicating that the enclosing aggregate has not been
12133 -- expanded yet. At this point the aggregate is part of a
12134 -- stand-alone declaration, and must be fully expanded.
12136 if Nkind (E) = N_Qualified_Expression then
12137 Set_Expansion_Delayed (Expression (E), False);
12138 Set_Analyzed (Expression (E), False);
12140 Set_Expansion_Delayed (E, False);
12143 Set_Analyzed (E, False);
12146 -- Generating C code of object declarations that have discriminants
12147 -- and are initialized by means of a function call we propagate the
12148 -- discriminants of the parent type to the internally built object.
12149 -- This is needed to avoid generating an extra call to the called
12152 -- For example, if we generate here the following declaration, it
12153 -- will be expanded later adding an extra call to evaluate the value
12154 -- of the discriminant (needed to compute the size of the object).
12156 -- type Rec (D : Integer) is ...
12157 -- Obj : constant Rec := SomeFunc;
12159 if Modify_Tree_For_C
12160 and then Nkind (Parent (Exp)) = N_Object_Declaration
12161 and then Has_Discriminants (Exp_Type)
12162 and then Nkind (Exp) = N_Function_Call
12164 Insert_Action (Exp,
12165 Make_Object_Declaration (Loc,
12166 Defining_Identifier => Def_Id,
12167 Object_Definition => New_Copy_Tree
12168 (Object_Definition (Parent (Exp))),
12169 Constant_Present => True,
12170 Expression => New_Exp));
12172 Insert_Action (Exp,
12173 Make_Object_Declaration (Loc,
12174 Defining_Identifier => Def_Id,
12175 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
12176 Constant_Present => True,
12177 Expression => New_Exp));
12181 -- Preserve the Assignment_OK flag in all copies, since at least one
12182 -- copy may be used in a context where this flag must be set (otherwise
12183 -- why would the flag be set in the first place).
12185 Set_Assignment_OK (Res, Assignment_OK (Exp));
12187 -- Preserve the Do_Range_Check flag in all copies
12189 Set_Do_Range_Check (Res, Do_Range_Check (Exp));
12191 -- Finally rewrite the original expression and we are done
12193 Rewrite (Exp, Res);
12194 Analyze_And_Resolve (Exp, Exp_Type);
12197 Scope_Suppress := Svg_Suppress;
12198 end Remove_Side_Effects;
12200 ------------------------
12201 -- Replace_References --
12202 ------------------------
12204 procedure Replace_References
12206 Par_Typ : Entity_Id;
12207 Deriv_Typ : Entity_Id;
12208 Par_Obj : Entity_Id := Empty;
12209 Deriv_Obj : Entity_Id := Empty)
12211 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
12212 -- Determine whether node Ref denotes some component of Deriv_Obj
12214 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
12215 -- Substitute a reference to an entity with the corresponding value
12216 -- stored in table Type_Map.
12218 function Type_Of_Formal
12220 Actual : Node_Id) return Entity_Id;
12221 -- Find the type of the formal parameter which corresponds to actual
12222 -- parameter Actual in subprogram call Call.
12224 ----------------------
12225 -- Is_Deriv_Obj_Ref --
12226 ----------------------
12228 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
12229 Par : constant Node_Id := Parent (Ref);
12232 -- Detect the folowing selected component form:
12234 -- Deriv_Obj.(something)
12237 Nkind (Par) = N_Selected_Component
12238 and then Is_Entity_Name (Prefix (Par))
12239 and then Entity (Prefix (Par)) = Deriv_Obj;
12240 end Is_Deriv_Obj_Ref;
12246 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
12247 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
12248 -- Reset the Controlling_Argument of all function calls that
12249 -- encapsulate node From_Arg.
12251 ----------------------------------
12252 -- Remove_Controlling_Arguments --
12253 ----------------------------------
12255 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
12260 while Present (Par) loop
12261 if Nkind (Par) = N_Function_Call
12262 and then Present (Controlling_Argument (Par))
12264 Set_Controlling_Argument (Par, Empty);
12266 -- Prevent the search from going too far
12268 elsif Is_Body_Or_Package_Declaration (Par) then
12272 Par := Parent (Par);
12274 end Remove_Controlling_Arguments;
12278 Context : constant Node_Id :=
12279 (if No (Ref) then Empty else Parent (Ref));
12281 Loc : constant Source_Ptr := Sloc (Ref);
12282 Ref_Id : Entity_Id;
12283 Result : Traverse_Result;
12286 -- The new reference which is intended to substitute the old one
12289 -- The reference designated for replacement. In certain cases this
12290 -- may be a node other than Ref.
12292 Val : Node_Or_Entity_Id;
12293 -- The corresponding value of Ref from the type map
12295 -- Start of processing for Replace_Ref
12298 -- Assume that the input reference is to be replaced and that the
12299 -- traversal should examine the children of the reference.
12304 -- The input denotes a meaningful reference
12306 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
12307 Ref_Id := Entity (Ref);
12308 Val := Type_Map.Get (Ref_Id);
12310 -- The reference has a corresponding value in the type map, a
12311 -- substitution is possible.
12313 if Present (Val) then
12315 -- The reference denotes a discriminant
12317 if Ekind (Ref_Id) = E_Discriminant then
12318 if Nkind (Val) in N_Entity then
12320 -- The value denotes another discriminant. Replace as
12323 -- _object.Discr -> _object.Val
12325 if Ekind (Val) = E_Discriminant then
12326 New_Ref := New_Occurrence_Of (Val, Loc);
12328 -- Otherwise the value denotes the entity of a name which
12329 -- constraints the discriminant. Replace as follows:
12331 -- _object.Discr -> Val
12334 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
12336 New_Ref := New_Occurrence_Of (Val, Loc);
12337 Old_Ref := Parent (Old_Ref);
12340 -- Otherwise the value denotes an arbitrary expression which
12341 -- constraints the discriminant. Replace as follows:
12343 -- _object.Discr -> Val
12346 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
12348 New_Ref := New_Copy_Tree (Val);
12349 Old_Ref := Parent (Old_Ref);
12352 -- Otherwise the reference denotes a primitive. Replace as
12355 -- Primitive -> Val
12358 pragma Assert (Nkind (Val) in N_Entity);
12359 New_Ref := New_Occurrence_Of (Val, Loc);
12362 -- The reference mentions the _object parameter of the parent
12363 -- type's DIC or type invariant procedure. Replace as follows:
12365 -- _object -> _object
12367 elsif Present (Par_Obj)
12368 and then Present (Deriv_Obj)
12369 and then Ref_Id = Par_Obj
12371 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
12373 -- The type of the _object parameter is class-wide when the
12374 -- expression comes from an assertion pragma that applies to
12375 -- an abstract parent type or an interface. The class-wide type
12376 -- facilitates the preanalysis of the expression by treating
12377 -- calls to abstract primitives that mention the current
12378 -- instance of the type as dispatching. Once the calls are
12379 -- remapped to invoke overriding or inherited primitives, the
12380 -- calls no longer need to be dispatching. Examine all function
12381 -- calls that encapsulate the _object parameter and reset their
12382 -- Controlling_Argument attribute.
12384 if Is_Class_Wide_Type (Etype (Par_Obj))
12385 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
12387 Remove_Controlling_Arguments (Old_Ref);
12390 -- The reference to _object acts as an actual parameter in a
12391 -- subprogram call which may be invoking a primitive of the
12394 -- Primitive (... _object ...);
12396 -- The parent type primitive may not be overridden nor
12397 -- inherited when it is declared after the derived type
12400 -- type Parent is tagged private;
12401 -- type Child is new Parent with private;
12402 -- procedure Primitive (Obj : Parent);
12404 -- In this scenario the _object parameter is converted to the
12405 -- parent type. Due to complications with partial/full views
12406 -- and view swaps, the parent type is taken from the formal
12407 -- parameter of the subprogram being called.
12409 if Nkind (Context) in N_Subprogram_Call
12410 and then No (Type_Map.Get (Entity (Name (Context))))
12413 -- We need to use the Original_Node of the callee, in
12414 -- case it was already modified. Note that we are using
12415 -- Traverse_Proc to walk the tree, and it is defined to
12416 -- walk subtrees in an arbitrary order.
12418 Callee : constant Entity_Id :=
12419 Entity (Original_Node (Name (Context)));
12421 if No (Type_Map.Get (Callee)) then
12424 (Type_Of_Formal (Context, Old_Ref), New_Ref);
12426 -- Do not process the generated type conversion
12427 -- because both the parent type and the derived type
12428 -- are in the Type_Map table. This will clobber the
12429 -- type conversion by resetting its subtype mark.
12436 -- Otherwise there is nothing to replace
12442 if Present (New_Ref) then
12443 Rewrite (Old_Ref, New_Ref);
12445 -- Update the return type when the context of the reference
12446 -- acts as the name of a function call. Note that the update
12447 -- should not be performed when the reference appears as an
12448 -- actual in the call.
12450 if Nkind (Context) = N_Function_Call
12451 and then Name (Context) = Old_Ref
12453 Set_Etype (Context, Etype (Val));
12458 -- Reanalyze the reference due to potential replacements
12460 if Nkind (Old_Ref) in N_Has_Etype then
12461 Set_Analyzed (Old_Ref, False);
12467 procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
12469 --------------------
12470 -- Type_Of_Formal --
12471 --------------------
12473 function Type_Of_Formal
12475 Actual : Node_Id) return Entity_Id
12481 -- Examine the list of actual and formal parameters in parallel
12483 A := First (Parameter_Associations (Call));
12484 F := First_Formal (Entity (Name (Call)));
12485 while Present (A) and then Present (F) loop
12494 -- The actual parameter must always have a corresponding formal
12496 pragma Assert (False);
12499 end Type_Of_Formal;
12501 -- Start of processing for Replace_References
12504 -- Map the attributes of the parent type to the proper corresponding
12505 -- attributes of the derived type.
12508 (Parent_Type => Par_Typ,
12509 Derived_Type => Deriv_Typ);
12511 -- Inspect the input expression and perform substitutions where
12514 Replace_Refs (Expr);
12515 end Replace_References;
12517 -----------------------------
12518 -- Replace_Type_References --
12519 -----------------------------
12521 procedure Replace_Type_References
12524 Obj_Id : Entity_Id)
12526 procedure Replace_Type_Ref (N : Node_Id);
12527 -- Substitute a single reference of the current instance of type Typ
12528 -- with a reference to Obj_Id.
12530 ----------------------
12531 -- Replace_Type_Ref --
12532 ----------------------
12534 procedure Replace_Type_Ref (N : Node_Id) is
12536 -- Decorate the reference to Typ even though it may be rewritten
12537 -- further down. This is done so that routines which examine
12538 -- properties of the Original_Node have some semantic information.
12540 if Nkind (N) = N_Identifier then
12541 Set_Entity (N, Typ);
12542 Set_Etype (N, Typ);
12544 elsif Nkind (N) = N_Selected_Component then
12545 Analyze (Prefix (N));
12546 Set_Entity (Selector_Name (N), Typ);
12547 Set_Etype (Selector_Name (N), Typ);
12550 -- Perform the following substitution:
12554 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
12555 Set_Comes_From_Source (N, True);
12556 end Replace_Type_Ref;
12558 procedure Replace_Type_Refs is
12559 new Replace_Type_References_Generic (Replace_Type_Ref);
12561 -- Start of processing for Replace_Type_References
12564 Replace_Type_Refs (Expr, Typ);
12565 end Replace_Type_References;
12567 ---------------------------
12568 -- Represented_As_Scalar --
12569 ---------------------------
12571 function Represented_As_Scalar (T : Entity_Id) return Boolean is
12572 UT : constant Entity_Id := Underlying_Type (T);
12574 return Is_Scalar_Type (UT)
12575 or else (Is_Bit_Packed_Array (UT)
12576 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
12577 end Represented_As_Scalar;
12579 ------------------------------
12580 -- Requires_Cleanup_Actions --
12581 ------------------------------
12583 function Requires_Cleanup_Actions
12585 Lib_Level : Boolean) return Boolean
12587 At_Lib_Level : constant Boolean :=
12589 and then Nkind (N) in N_Package_Body | N_Package_Specification;
12590 -- N is at the library level if the top-most context is a package and
12591 -- the path taken to reach N does not include nonpackage constructs.
12595 when N_Accept_Statement
12596 | N_Block_Statement
12600 | N_Subprogram_Body
12604 Requires_Cleanup_Actions
12605 (L => Declarations (N),
12606 Lib_Level => At_Lib_Level,
12607 Nested_Constructs => True)
12609 (Present (Handled_Statement_Sequence (N))
12611 Requires_Cleanup_Actions
12613 Statements (Handled_Statement_Sequence (N)),
12614 Lib_Level => At_Lib_Level,
12615 Nested_Constructs => True));
12617 -- Extended return statements are the same as the above, except that
12618 -- there is no Declarations field. We do not want to clean up the
12619 -- Return_Object_Declarations.
12621 when N_Extended_Return_Statement =>
12623 Present (Handled_Statement_Sequence (N))
12624 and then Requires_Cleanup_Actions
12626 Statements (Handled_Statement_Sequence (N)),
12627 Lib_Level => At_Lib_Level,
12628 Nested_Constructs => True);
12630 when N_Package_Specification =>
12632 Requires_Cleanup_Actions
12633 (L => Visible_Declarations (N),
12634 Lib_Level => At_Lib_Level,
12635 Nested_Constructs => True)
12637 Requires_Cleanup_Actions
12638 (L => Private_Declarations (N),
12639 Lib_Level => At_Lib_Level,
12640 Nested_Constructs => True);
12643 raise Program_Error;
12645 end Requires_Cleanup_Actions;
12647 ------------------------------
12648 -- Requires_Cleanup_Actions --
12649 ------------------------------
12651 function Requires_Cleanup_Actions
12653 Lib_Level : Boolean;
12654 Nested_Constructs : Boolean) return Boolean
12658 Obj_Id : Entity_Id;
12659 Obj_Typ : Entity_Id;
12660 Pack_Id : Entity_Id;
12664 if No (L) or else Is_Empty_List (L) then
12669 while Present (Decl) loop
12671 -- Library-level tagged types
12673 if Nkind (Decl) = N_Full_Type_Declaration then
12674 Typ := Defining_Identifier (Decl);
12676 -- Ignored Ghost types do not need any cleanup actions because
12677 -- they will not appear in the final tree.
12679 if Is_Ignored_Ghost_Entity (Typ) then
12682 elsif Is_Tagged_Type (Typ)
12683 and then Is_Library_Level_Entity (Typ)
12684 and then Convention (Typ) = Convention_Ada
12685 and then Present (Access_Disp_Table (Typ))
12686 and then RTE_Available (RE_Unregister_Tag)
12687 and then not Is_Abstract_Type (Typ)
12688 and then not No_Run_Time_Mode
12693 -- Regular object declarations
12695 elsif Nkind (Decl) = N_Object_Declaration then
12696 Obj_Id := Defining_Identifier (Decl);
12697 Obj_Typ := Base_Type (Etype (Obj_Id));
12698 Expr := Expression (Decl);
12700 -- Bypass any form of processing for objects which have their
12701 -- finalization disabled. This applies only to objects at the
12704 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12707 -- Finalization of transient objects are treated separately in
12708 -- order to handle sensitive cases. These include:
12710 -- * Aggregate expansion
12711 -- * If, case, and expression with actions expansion
12712 -- * Transient scopes
12714 -- If one of those contexts has marked the transient object as
12715 -- ignored, do not generate finalization actions for it.
12717 elsif Is_Finalized_Transient (Obj_Id)
12718 or else Is_Ignored_Transient (Obj_Id)
12722 -- Ignored Ghost objects do not need any cleanup actions because
12723 -- they will not appear in the final tree.
12725 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12728 -- The object is of the form:
12729 -- Obj : [constant] Typ [:= Expr];
12731 -- Do not process tag-to-class-wide conversions because they do
12732 -- not yield an object. Do not process the incomplete view of a
12733 -- deferred constant. Note that an object initialized by means
12734 -- of a build-in-place function call may appear as a deferred
12735 -- constant after expansion activities. These kinds of objects
12736 -- must be finalized.
12738 elsif not Is_Imported (Obj_Id)
12739 and then Needs_Finalization (Obj_Typ)
12740 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
12741 and then not (Ekind (Obj_Id) = E_Constant
12742 and then not Has_Completion (Obj_Id)
12743 and then No (BIP_Initialization_Call (Obj_Id)))
12747 -- The object is of the form:
12748 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
12750 -- Obj : Access_Typ :=
12751 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
12753 elsif Is_Access_Type (Obj_Typ)
12754 and then Needs_Finalization
12755 (Available_View (Designated_Type (Obj_Typ)))
12756 and then Present (Expr)
12758 (Is_Secondary_Stack_BIP_Func_Call (Expr)
12760 (Is_Non_BIP_Func_Call (Expr)
12761 and then not Is_Related_To_Func_Return (Obj_Id)))
12765 -- Processing for "hook" objects generated for transient objects
12766 -- declared inside an Expression_With_Actions.
12768 elsif Is_Access_Type (Obj_Typ)
12769 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12770 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12771 N_Object_Declaration
12775 -- Processing for intermediate results of if expressions where
12776 -- one of the alternatives uses a controlled function call.
12778 elsif Is_Access_Type (Obj_Typ)
12779 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12780 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12781 N_Defining_Identifier
12782 and then Present (Expr)
12783 and then Nkind (Expr) = N_Null
12787 -- Simple protected objects which use type System.Tasking.
12788 -- Protected_Objects.Protection to manage their locks should be
12789 -- treated as controlled since they require manual cleanup.
12791 elsif Ekind (Obj_Id) = E_Variable
12792 and then (Is_Simple_Protected_Type (Obj_Typ)
12793 or else Has_Simple_Protected_Object (Obj_Typ))
12798 -- Specific cases of object renamings
12800 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
12801 Obj_Id := Defining_Identifier (Decl);
12802 Obj_Typ := Base_Type (Etype (Obj_Id));
12804 -- Bypass any form of processing for objects which have their
12805 -- finalization disabled. This applies only to objects at the
12808 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12811 -- Ignored Ghost object renamings do not need any cleanup actions
12812 -- because they will not appear in the final tree.
12814 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12817 -- Return object of a build-in-place function. This case is
12818 -- recognized and marked by the expansion of an extended return
12819 -- statement (see Expand_N_Extended_Return_Statement).
12821 elsif Needs_Finalization (Obj_Typ)
12822 and then Is_Return_Object (Obj_Id)
12823 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12827 -- Detect a case where a source object has been initialized by
12828 -- a controlled function call or another object which was later
12829 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
12831 -- Obj1 : CW_Type := Src_Obj;
12832 -- Obj2 : CW_Type := Function_Call (...);
12834 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
12835 -- Tmp : ... := Function_Call (...)'reference;
12836 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
12838 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
12842 -- Inspect the freeze node of an access-to-controlled type and look
12843 -- for a delayed finalization master. This case arises when the
12844 -- freeze actions are inserted at a later time than the expansion of
12845 -- the context. Since Build_Finalizer is never called on a single
12846 -- construct twice, the master will be ultimately left out and never
12847 -- finalized. This is also needed for freeze actions of designated
12848 -- types themselves, since in some cases the finalization master is
12849 -- associated with a designated type's freeze node rather than that
12850 -- of the access type (see handling for freeze actions in
12851 -- Build_Finalization_Master).
12853 elsif Nkind (Decl) = N_Freeze_Entity
12854 and then Present (Actions (Decl))
12856 Typ := Entity (Decl);
12858 -- Freeze nodes for ignored Ghost types do not need cleanup
12859 -- actions because they will never appear in the final tree.
12861 if Is_Ignored_Ghost_Entity (Typ) then
12864 elsif ((Is_Access_Object_Type (Typ)
12865 and then Needs_Finalization
12866 (Available_View (Designated_Type (Typ))))
12867 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
12868 and then Requires_Cleanup_Actions
12869 (Actions (Decl), Lib_Level, Nested_Constructs)
12874 -- Nested package declarations
12876 elsif Nested_Constructs
12877 and then Nkind (Decl) = N_Package_Declaration
12879 Pack_Id := Defining_Entity (Decl);
12881 -- Do not inspect an ignored Ghost package because all code found
12882 -- within will not appear in the final tree.
12884 if Is_Ignored_Ghost_Entity (Pack_Id) then
12887 elsif Ekind (Pack_Id) /= E_Generic_Package
12888 and then Requires_Cleanup_Actions
12889 (Specification (Decl), Lib_Level)
12894 -- Nested package bodies
12896 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
12898 -- Do not inspect an ignored Ghost package body because all code
12899 -- found within will not appear in the final tree.
12901 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
12904 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
12905 and then Requires_Cleanup_Actions (Decl, Lib_Level)
12910 elsif Nkind (Decl) = N_Block_Statement
12913 -- Handle a rare case caused by a controlled transient object
12914 -- created as part of a record init proc. The variable is wrapped
12915 -- in a block, but the block is not associated with a transient
12920 -- Handle the case where the original context has been wrapped in
12921 -- a block to avoid interference between exception handlers and
12922 -- At_End handlers. Treat the block as transparent and process its
12925 or else Is_Finalization_Wrapper (Decl))
12927 if Requires_Cleanup_Actions (Decl, Lib_Level) then
12936 end Requires_Cleanup_Actions;
12938 ------------------------------------
12939 -- Safe_Unchecked_Type_Conversion --
12940 ------------------------------------
12942 -- Note: this function knows quite a bit about the exact requirements of
12943 -- Gigi with respect to unchecked type conversions, and its code must be
12944 -- coordinated with any changes in Gigi in this area.
12946 -- The above requirements should be documented in Sinfo ???
12948 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
12953 Pexp : constant Node_Id := Parent (Exp);
12956 -- If the expression is the RHS of an assignment or object declaration
12957 -- we are always OK because there will always be a target.
12959 -- Object renaming declarations, (generated for view conversions of
12960 -- actuals in inlined calls), like object declarations, provide an
12961 -- explicit type, and are safe as well.
12963 if (Nkind (Pexp) = N_Assignment_Statement
12964 and then Expression (Pexp) = Exp)
12965 or else Nkind (Pexp)
12966 in N_Object_Declaration | N_Object_Renaming_Declaration
12970 -- If the expression is the prefix of an N_Selected_Component we should
12971 -- also be OK because GCC knows to look inside the conversion except if
12972 -- the type is discriminated. We assume that we are OK anyway if the
12973 -- type is not set yet or if it is controlled since we can't afford to
12974 -- introduce a temporary in this case.
12976 elsif Nkind (Pexp) = N_Selected_Component
12977 and then Prefix (Pexp) = Exp
12979 return No (Etype (Pexp))
12980 or else not Is_Type (Etype (Pexp))
12981 or else not Has_Discriminants (Etype (Pexp))
12982 or else Is_Constrained (Etype (Pexp));
12985 -- Set the output type, this comes from Etype if it is set, otherwise we
12986 -- take it from the subtype mark, which we assume was already fully
12989 if Present (Etype (Exp)) then
12990 Otyp := Etype (Exp);
12992 Otyp := Entity (Subtype_Mark (Exp));
12995 -- The input type always comes from the expression, and we assume this
12996 -- is indeed always analyzed, so we can simply get the Etype.
12998 Ityp := Etype (Expression (Exp));
13000 -- Initialize alignments to unknown so far
13005 -- Replace a concurrent type by its corresponding record type and each
13006 -- type by its underlying type and do the tests on those. The original
13007 -- type may be a private type whose completion is a concurrent type, so
13008 -- find the underlying type first.
13010 if Present (Underlying_Type (Otyp)) then
13011 Otyp := Underlying_Type (Otyp);
13014 if Present (Underlying_Type (Ityp)) then
13015 Ityp := Underlying_Type (Ityp);
13018 if Is_Concurrent_Type (Otyp) then
13019 Otyp := Corresponding_Record_Type (Otyp);
13022 if Is_Concurrent_Type (Ityp) then
13023 Ityp := Corresponding_Record_Type (Ityp);
13026 -- If the base types are the same, we know there is no problem since
13027 -- this conversion will be a noop.
13029 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
13032 -- Same if this is an upwards conversion of an untagged type, and there
13033 -- are no constraints involved (could be more general???)
13035 elsif Etype (Ityp) = Otyp
13036 and then not Is_Tagged_Type (Ityp)
13037 and then not Has_Discriminants (Ityp)
13038 and then No (First_Rep_Item (Base_Type (Ityp)))
13042 -- If the expression has an access type (object or subprogram) we assume
13043 -- that the conversion is safe, because the size of the target is safe,
13044 -- even if it is a record (which might be treated as having unknown size
13047 elsif Is_Access_Type (Ityp) then
13050 -- If the size of output type is known at compile time, there is never
13051 -- a problem. Note that unconstrained records are considered to be of
13052 -- known size, but we can't consider them that way here, because we are
13053 -- talking about the actual size of the object.
13055 -- We also make sure that in addition to the size being known, we do not
13056 -- have a case which might generate an embarrassingly large temp in
13057 -- stack checking mode.
13059 elsif Size_Known_At_Compile_Time (Otyp)
13061 (not Stack_Checking_Enabled
13062 or else not May_Generate_Large_Temp (Otyp))
13063 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
13067 -- If either type is tagged, then we know the alignment is OK so Gigi
13068 -- will be able to use pointer punning.
13070 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
13073 -- If either type is a limited record type, we cannot do a copy, so say
13074 -- safe since there's nothing else we can do.
13076 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
13079 -- Conversions to and from packed array types are always ignored and
13082 elsif Is_Packed_Array_Impl_Type (Otyp)
13083 or else Is_Packed_Array_Impl_Type (Ityp)
13088 -- The only other cases known to be safe is if the input type's
13089 -- alignment is known to be at least the maximum alignment for the
13090 -- target or if both alignments are known and the output type's
13091 -- alignment is no stricter than the input's. We can use the component
13092 -- type alignment for an array if a type is an unpacked array type.
13094 if Present (Alignment_Clause (Otyp)) then
13095 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
13097 elsif Is_Array_Type (Otyp)
13098 and then Present (Alignment_Clause (Component_Type (Otyp)))
13100 Oalign := Expr_Value (Expression (Alignment_Clause
13101 (Component_Type (Otyp))));
13104 if Present (Alignment_Clause (Ityp)) then
13105 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
13107 elsif Is_Array_Type (Ityp)
13108 and then Present (Alignment_Clause (Component_Type (Ityp)))
13110 Ialign := Expr_Value (Expression (Alignment_Clause
13111 (Component_Type (Ityp))));
13114 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
13117 elsif Ialign /= No_Uint
13118 and then Oalign /= No_Uint
13119 and then Ialign <= Oalign
13123 -- Otherwise, Gigi cannot handle this and we must make a temporary
13128 end Safe_Unchecked_Type_Conversion;
13130 ---------------------------------
13131 -- Set_Current_Value_Condition --
13132 ---------------------------------
13134 -- Note: the implementation of this procedure is very closely tied to the
13135 -- implementation of Get_Current_Value_Condition. Here we set required
13136 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
13137 -- them, so they must have a consistent view.
13139 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
13141 procedure Set_Entity_Current_Value (N : Node_Id);
13142 -- If N is an entity reference, where the entity is of an appropriate
13143 -- kind, then set the current value of this entity to Cnode, unless
13144 -- there is already a definite value set there.
13146 procedure Set_Expression_Current_Value (N : Node_Id);
13147 -- If N is of an appropriate form, sets an appropriate entry in current
13148 -- value fields of relevant entities. Multiple entities can be affected
13149 -- in the case of an AND or AND THEN.
13151 ------------------------------
13152 -- Set_Entity_Current_Value --
13153 ------------------------------
13155 procedure Set_Entity_Current_Value (N : Node_Id) is
13157 if Is_Entity_Name (N) then
13159 Ent : constant Entity_Id := Entity (N);
13162 -- Don't capture if not safe to do so
13164 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
13168 -- Here we have a case where the Current_Value field may need
13169 -- to be set. We set it if it is not already set to a compile
13170 -- time expression value.
13172 -- Note that this represents a decision that one condition
13173 -- blots out another previous one. That's certainly right if
13174 -- they occur at the same level. If the second one is nested,
13175 -- then the decision is neither right nor wrong (it would be
13176 -- equally OK to leave the outer one in place, or take the new
13177 -- inner one). Really we should record both, but our data
13178 -- structures are not that elaborate.
13180 if Nkind (Current_Value (Ent)) not in N_Subexpr then
13181 Set_Current_Value (Ent, Cnode);
13185 end Set_Entity_Current_Value;
13187 ----------------------------------
13188 -- Set_Expression_Current_Value --
13189 ----------------------------------
13191 procedure Set_Expression_Current_Value (N : Node_Id) is
13197 -- Loop to deal with (ignore for now) any NOT operators present. The
13198 -- presence of NOT operators will be handled properly when we call
13199 -- Get_Current_Value_Condition.
13201 while Nkind (Cond) = N_Op_Not loop
13202 Cond := Right_Opnd (Cond);
13205 -- For an AND or AND THEN, recursively process operands
13207 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
13208 Set_Expression_Current_Value (Left_Opnd (Cond));
13209 Set_Expression_Current_Value (Right_Opnd (Cond));
13213 -- Check possible relational operator
13215 if Nkind (Cond) in N_Op_Compare then
13216 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
13217 Set_Entity_Current_Value (Left_Opnd (Cond));
13218 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
13219 Set_Entity_Current_Value (Right_Opnd (Cond));
13222 elsif Nkind (Cond) in N_Type_Conversion
13223 | N_Qualified_Expression
13224 | N_Expression_With_Actions
13226 Set_Expression_Current_Value (Expression (Cond));
13228 -- Check possible boolean variable reference
13231 Set_Entity_Current_Value (Cond);
13233 end Set_Expression_Current_Value;
13235 -- Start of processing for Set_Current_Value_Condition
13238 Set_Expression_Current_Value (Condition (Cnode));
13239 end Set_Current_Value_Condition;
13241 --------------------------
13242 -- Set_Elaboration_Flag --
13243 --------------------------
13245 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
13246 Loc : constant Source_Ptr := Sloc (N);
13247 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
13251 if Present (Ent) then
13253 -- Nothing to do if at the compilation unit level, because in this
13254 -- case the flag is set by the binder generated elaboration routine.
13256 if Nkind (Parent (N)) = N_Compilation_Unit then
13259 -- Here we do need to generate an assignment statement
13262 Check_Restriction (No_Elaboration_Code, N);
13265 Make_Assignment_Statement (Loc,
13266 Name => New_Occurrence_Of (Ent, Loc),
13267 Expression => Make_Integer_Literal (Loc, Uint_1));
13269 -- Mark the assignment statement as elaboration code. This allows
13270 -- the early call region mechanism (see Sem_Elab) to properly
13271 -- ignore such assignments even though they are nonpreelaborable
13274 Set_Is_Elaboration_Code (Asn);
13276 if Nkind (Parent (N)) = N_Subunit then
13277 Insert_After (Corresponding_Stub (Parent (N)), Asn);
13279 Insert_After (N, Asn);
13284 -- Kill current value indication. This is necessary because the
13285 -- tests of this flag are inserted out of sequence and must not
13286 -- pick up bogus indications of the wrong constant value.
13288 Set_Current_Value (Ent, Empty);
13290 -- If the subprogram is in the current declarative part and
13291 -- 'access has been applied to it, generate an elaboration
13292 -- check at the beginning of the declarations of the body.
13294 if Nkind (N) = N_Subprogram_Body
13295 and then Address_Taken (Spec_Id)
13297 Ekind (Scope (Spec_Id)) in E_Block | E_Procedure | E_Function
13300 Loc : constant Source_Ptr := Sloc (N);
13301 Decls : constant List_Id := Declarations (N);
13305 -- No need to generate this check if first entry in the
13306 -- declaration list is a raise of Program_Error now.
13309 and then Nkind (First (Decls)) = N_Raise_Program_Error
13314 -- Otherwise generate the check
13317 Make_Raise_Program_Error (Loc,
13320 Left_Opnd => New_Occurrence_Of (Ent, Loc),
13321 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
13322 Reason => PE_Access_Before_Elaboration);
13325 Set_Declarations (N, New_List (Chk));
13327 Prepend (Chk, Decls);
13335 end Set_Elaboration_Flag;
13337 ----------------------------
13338 -- Set_Renamed_Subprogram --
13339 ----------------------------
13341 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
13343 -- If input node is an identifier, we can just reset it
13345 if Nkind (N) = N_Identifier then
13346 Set_Chars (N, Chars (E));
13349 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
13353 CS : constant Boolean := Comes_From_Source (N);
13355 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
13357 Set_Comes_From_Source (N, CS);
13358 Set_Analyzed (N, True);
13361 end Set_Renamed_Subprogram;
13363 ----------------------
13364 -- Side_Effect_Free --
13365 ----------------------
13367 function Side_Effect_Free
13369 Name_Req : Boolean := False;
13370 Variable_Ref : Boolean := False) return Boolean
13372 Typ : constant Entity_Id := Etype (N);
13373 -- Result type of the expression
13375 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
13376 -- The argument N is a construct where the Prefix is dereferenced if it
13377 -- is an access type and the result is a variable. The call returns True
13378 -- if the construct is side effect free (not considering side effects in
13379 -- other than the prefix which are to be tested by the caller).
13381 function Within_In_Parameter (N : Node_Id) return Boolean;
13382 -- Determines if N is a subcomponent of a composite in-parameter. If so,
13383 -- N is not side-effect free when the actual is global and modifiable
13384 -- indirectly from within a subprogram, because it may be passed by
13385 -- reference. The front-end must be conservative here and assume that
13386 -- this may happen with any array or record type. On the other hand, we
13387 -- cannot create temporaries for all expressions for which this
13388 -- condition is true, for various reasons that might require clearing up
13389 -- ??? For example, discriminant references that appear out of place, or
13390 -- spurious type errors with class-wide expressions. As a result, we
13391 -- limit the transformation to loop bounds, which is so far the only
13392 -- case that requires it.
13394 -----------------------------
13395 -- Safe_Prefixed_Reference --
13396 -----------------------------
13398 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
13400 -- If prefix is not side effect free, definitely not safe
13402 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
13405 -- If the prefix is of an access type that is not access-to-constant,
13406 -- then this construct is a variable reference, which means it is to
13407 -- be considered to have side effects if Variable_Ref is set True.
13409 elsif Is_Access_Type (Etype (Prefix (N)))
13410 and then not Is_Access_Constant (Etype (Prefix (N)))
13411 and then Variable_Ref
13413 -- Exception is a prefix that is the result of a previous removal
13414 -- of side effects.
13416 return Is_Entity_Name (Prefix (N))
13417 and then not Comes_From_Source (Prefix (N))
13418 and then Ekind (Entity (Prefix (N))) = E_Constant
13419 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
13421 -- If the prefix is an explicit dereference then this construct is a
13422 -- variable reference, which means it is to be considered to have
13423 -- side effects if Variable_Ref is True.
13425 -- We do NOT exclude dereferences of access-to-constant types because
13426 -- we handle them as constant view of variables.
13428 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
13429 and then Variable_Ref
13433 -- Note: The following test is the simplest way of solving a complex
13434 -- problem uncovered by the following test (Side effect on loop bound
13435 -- that is a subcomponent of a global variable:
13437 -- with Text_Io; use Text_Io;
13438 -- procedure Tloop is
13441 -- V : Natural := 4;
13442 -- S : String (1..5) := (others => 'a');
13449 -- with procedure Action;
13450 -- procedure Loop_G (Arg : X; Msg : String)
13452 -- procedure Loop_G (Arg : X; Msg : String) is
13454 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
13455 -- & Natural'Image (Arg.V));
13456 -- for Index in 1 .. Arg.V loop
13457 -- Text_Io.Put_Line
13458 -- (Natural'Image (Index) & " " & Arg.S (Index));
13459 -- if Index > 2 then
13463 -- Put_Line ("end loop_g " & Msg);
13466 -- procedure Loop1 is new Loop_G (Modi);
13467 -- procedure Modi is
13470 -- Loop1 (X1, "from modi");
13474 -- Loop1 (X1, "initial");
13477 -- The output of the above program should be:
13479 -- begin loop_g initial will loop till: 4
13483 -- begin loop_g from modi will loop till: 1
13485 -- end loop_g from modi
13487 -- begin loop_g from modi will loop till: 1
13489 -- end loop_g from modi
13490 -- end loop_g initial
13492 -- If a loop bound is a subcomponent of a global variable, a
13493 -- modification of that variable within the loop may incorrectly
13494 -- affect the execution of the loop.
13496 elsif Parent_Kind (Parent (N)) = N_Loop_Parameter_Specification
13497 and then Within_In_Parameter (Prefix (N))
13498 and then Variable_Ref
13502 -- All other cases are side effect free
13507 end Safe_Prefixed_Reference;
13509 -------------------------
13510 -- Within_In_Parameter --
13511 -------------------------
13513 function Within_In_Parameter (N : Node_Id) return Boolean is
13515 if not Comes_From_Source (N) then
13518 elsif Is_Entity_Name (N) then
13519 return Ekind (Entity (N)) = E_In_Parameter;
13521 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
13522 return Within_In_Parameter (Prefix (N));
13527 end Within_In_Parameter;
13529 -- Start of processing for Side_Effect_Free
13532 -- If volatile reference, always consider it to have side effects
13534 if Is_Volatile_Reference (N) then
13538 -- Note on checks that could raise Constraint_Error. Strictly, if we
13539 -- take advantage of 11.6, these checks do not count as side effects.
13540 -- However, we would prefer to consider that they are side effects,
13541 -- since the back end CSE does not work very well on expressions which
13542 -- can raise Constraint_Error. On the other hand if we don't consider
13543 -- them to be side effect free, then we get some awkward expansions
13544 -- in -gnato mode, resulting in code insertions at a point where we
13545 -- do not have a clear model for performing the insertions.
13547 -- Special handling for entity names
13549 if Is_Entity_Name (N) then
13551 -- A type reference is always side effect free
13553 if Is_Type (Entity (N)) then
13556 -- Variables are considered to be a side effect if Variable_Ref
13557 -- is set or if we have a volatile reference and Name_Req is off.
13558 -- If Name_Req is True then we can't help returning a name which
13559 -- effectively allows multiple references in any case.
13561 elsif Is_Variable (N, Use_Original_Node => False) then
13562 return not Variable_Ref
13563 and then (not Is_Volatile_Reference (N) or else Name_Req);
13565 -- Any other entity (e.g. a subtype name) is definitely side
13572 -- A value known at compile time is always side effect free
13574 elsif Compile_Time_Known_Value (N) then
13577 -- A variable renaming is not side-effect free, because the renaming
13578 -- will function like a macro in the front-end in some cases, and an
13579 -- assignment can modify the component designated by N, so we need to
13580 -- create a temporary for it.
13582 -- The guard testing for Entity being present is needed at least in
13583 -- the case of rewritten predicate expressions, and may well also be
13584 -- appropriate elsewhere. Obviously we can't go testing the entity
13585 -- field if it does not exist, so it's reasonable to say that this is
13586 -- not the renaming case if it does not exist.
13588 elsif Is_Entity_Name (Original_Node (N))
13589 and then Present (Entity (Original_Node (N)))
13590 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
13591 and then Ekind (Entity (Original_Node (N))) /= E_Constant
13594 RO : constant Node_Id :=
13595 Renamed_Object (Entity (Original_Node (N)));
13598 -- If the renamed object is an indexed component, or an
13599 -- explicit dereference, then the designated object could
13600 -- be modified by an assignment.
13602 if Nkind (RO) in N_Indexed_Component | N_Explicit_Dereference then
13605 -- A selected component must have a safe prefix
13607 elsif Nkind (RO) = N_Selected_Component then
13608 return Safe_Prefixed_Reference (RO);
13610 -- In all other cases, designated object cannot be changed so
13611 -- we are side effect free.
13618 -- Remove_Side_Effects generates an object renaming declaration to
13619 -- capture the expression of a class-wide expression. In VM targets
13620 -- the frontend performs no expansion for dispatching calls to
13621 -- class- wide types since they are handled by the VM. Hence, we must
13622 -- locate here if this node corresponds to a previous invocation of
13623 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
13625 elsif not Tagged_Type_Expansion
13626 and then not Comes_From_Source (N)
13627 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
13628 and then Is_Class_Wide_Type (Typ)
13632 -- Generating C the type conversion of an access to constrained array
13633 -- type into an access to unconstrained array type involves initializing
13634 -- a fat pointer and the expression cannot be assumed to be free of side
13635 -- effects since it must referenced several times to compute its bounds.
13637 elsif Modify_Tree_For_C
13638 and then Nkind (N) = N_Type_Conversion
13639 and then Is_Access_Type (Typ)
13640 and then Is_Array_Type (Designated_Type (Typ))
13641 and then not Is_Constrained (Designated_Type (Typ))
13646 -- For other than entity names and compile time known values,
13647 -- check the node kind for special processing.
13651 -- An attribute reference is side-effect free if its expressions
13652 -- are side-effect free and its prefix is side-effect free or is
13653 -- an entity reference.
13655 when N_Attribute_Reference =>
13656 return Side_Effect_Free_Attribute (Attribute_Name (N))
13658 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13660 (Is_Entity_Name (Prefix (N))
13662 Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
13664 -- A binary operator is side effect free if and both operands are
13665 -- side effect free. For this purpose binary operators include
13666 -- short circuit forms.
13671 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13673 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13675 -- Membership tests may have either Right_Opnd or Alternatives set
13677 when N_Membership_Test =>
13678 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13680 (if Present (Right_Opnd (N))
13681 then Side_Effect_Free
13682 (Right_Opnd (N), Name_Req, Variable_Ref)
13683 else Side_Effect_Free
13684 (Alternatives (N), Name_Req, Variable_Ref));
13686 -- An explicit dereference is side effect free only if it is
13687 -- a side effect free prefixed reference.
13689 when N_Explicit_Dereference =>
13690 return Safe_Prefixed_Reference (N);
13692 -- An expression with action is side effect free if its expression
13693 -- is side effect free and it has no actions.
13695 when N_Expression_With_Actions =>
13697 Is_Empty_List (Actions (N))
13698 and then Side_Effect_Free
13699 (Expression (N), Name_Req, Variable_Ref);
13701 -- A call to _rep_to_pos is side effect free, since we generate
13702 -- this pure function call ourselves. Moreover it is critically
13703 -- important to make this exception, since otherwise we can have
13704 -- discriminants in array components which don't look side effect
13705 -- free in the case of an array whose index type is an enumeration
13706 -- type with an enumeration rep clause.
13708 -- All other function calls are not side effect free
13710 when N_Function_Call =>
13712 Nkind (Name (N)) = N_Identifier
13713 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
13714 and then Side_Effect_Free
13715 (First (Parameter_Associations (N)),
13716 Name_Req, Variable_Ref);
13718 -- An IF expression is side effect free if it's of a scalar type, and
13719 -- all its components are all side effect free (conditions and then
13720 -- actions and else actions). We restrict to scalar types, since it
13721 -- is annoying to deal with things like (if A then B else C)'First
13722 -- where the type involved is a string type.
13724 when N_If_Expression =>
13726 Is_Scalar_Type (Typ)
13727 and then Side_Effect_Free
13728 (Expressions (N), Name_Req, Variable_Ref);
13730 -- An indexed component is side effect free if it is a side
13731 -- effect free prefixed reference and all the indexing
13732 -- expressions are side effect free.
13734 when N_Indexed_Component =>
13736 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13737 and then Safe_Prefixed_Reference (N);
13739 -- A type qualification, type conversion, or unchecked expression is
13740 -- side effect free if the expression is side effect free.
13742 when N_Qualified_Expression
13743 | N_Type_Conversion
13744 | N_Unchecked_Expression
13746 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
13748 -- A selected component is side effect free only if it is a side
13749 -- effect free prefixed reference.
13751 when N_Selected_Component =>
13752 return Safe_Prefixed_Reference (N);
13754 -- A range is side effect free if the bounds are side effect free
13757 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
13759 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
13761 -- A slice is side effect free if it is a side effect free
13762 -- prefixed reference and the bounds are side effect free.
13766 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
13767 and then Safe_Prefixed_Reference (N);
13769 -- A unary operator is side effect free if the operand
13770 -- is side effect free.
13773 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13775 -- An unchecked type conversion is side effect free only if it
13776 -- is safe and its argument is side effect free.
13778 when N_Unchecked_Type_Conversion =>
13780 Safe_Unchecked_Type_Conversion (N)
13781 and then Side_Effect_Free
13782 (Expression (N), Name_Req, Variable_Ref);
13784 -- A literal is side effect free
13786 when N_Character_Literal
13787 | N_Integer_Literal
13793 -- An aggregate is side effect free if all its values are compile
13796 when N_Aggregate =>
13797 return Compile_Time_Known_Aggregate (N);
13799 -- We consider that anything else has side effects. This is a bit
13800 -- crude, but we are pretty close for most common cases, and we
13801 -- are certainly correct (i.e. we never return True when the
13802 -- answer should be False).
13807 end Side_Effect_Free;
13809 -- A list is side effect free if all elements of the list are side
13812 function Side_Effect_Free
13814 Name_Req : Boolean := False;
13815 Variable_Ref : Boolean := False) return Boolean
13820 if L = No_List or else L = Error_List then
13825 while Present (N) loop
13826 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
13835 end Side_Effect_Free;
13837 --------------------------------
13838 -- Side_Effect_Free_Attribute --
13839 --------------------------------
13841 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
13850 | Name_Wide_Wide_Image
13852 -- CodePeer doesn't want to see replicated copies of 'Image calls
13854 return not CodePeer_Mode;
13859 end Side_Effect_Free_Attribute;
13861 ----------------------------------
13862 -- Silly_Boolean_Array_Not_Test --
13863 ----------------------------------
13865 -- This procedure implements an odd and silly test. We explicitly check
13866 -- for the case where the 'First of the component type is equal to the
13867 -- 'Last of this component type, and if this is the case, we make sure
13868 -- that constraint error is raised. The reason is that the NOT is bound
13869 -- to cause CE in this case, and we will not otherwise catch it.
13871 -- No such check is required for AND and OR, since for both these cases
13872 -- False op False = False, and True op True = True. For the XOR case,
13873 -- see Silly_Boolean_Array_Xor_Test.
13875 -- Believe it or not, this was reported as a bug. Note that nearly always,
13876 -- the test will evaluate statically to False, so the code will be
13877 -- statically removed, and no extra overhead caused.
13879 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
13880 Loc : constant Source_Ptr := Sloc (N);
13881 CT : constant Entity_Id := Component_Type (T);
13884 -- The check we install is
13886 -- constraint_error when
13887 -- component_type'first = component_type'last
13888 -- and then array_type'Length /= 0)
13890 -- We need the last guard because we don't want to raise CE for empty
13891 -- arrays since no out of range values result. (Empty arrays with a
13892 -- component type of True .. True -- very useful -- even the ACATS
13893 -- does not test that marginal case).
13896 Make_Raise_Constraint_Error (Loc,
13898 Make_And_Then (Loc,
13902 Make_Attribute_Reference (Loc,
13903 Prefix => New_Occurrence_Of (CT, Loc),
13904 Attribute_Name => Name_First),
13907 Make_Attribute_Reference (Loc,
13908 Prefix => New_Occurrence_Of (CT, Loc),
13909 Attribute_Name => Name_Last)),
13911 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
13912 Reason => CE_Range_Check_Failed));
13913 end Silly_Boolean_Array_Not_Test;
13915 ----------------------------------
13916 -- Silly_Boolean_Array_Xor_Test --
13917 ----------------------------------
13919 -- This procedure implements an odd and silly test. We explicitly check
13920 -- for the XOR case where the component type is True .. True, since this
13921 -- will raise constraint error. A special check is required since CE
13922 -- will not be generated otherwise (cf Expand_Packed_Not).
13924 -- No such check is required for AND and OR, since for both these cases
13925 -- False op False = False, and True op True = True, and no check is
13926 -- required for the case of False .. False, since False xor False = False.
13927 -- See also Silly_Boolean_Array_Not_Test
13929 procedure Silly_Boolean_Array_Xor_Test
13934 Loc : constant Source_Ptr := Sloc (N);
13935 CT : constant Entity_Id := Component_Type (T);
13938 -- The check we install is
13940 -- constraint_error when
13941 -- Boolean (component_type'First)
13942 -- and then Boolean (component_type'Last)
13943 -- and then array_type'Length /= 0)
13945 -- We need the last guard because we don't want to raise CE for empty
13946 -- arrays since no out of range values result (Empty arrays with a
13947 -- component type of True .. True -- very useful -- even the ACATS
13948 -- does not test that marginal case).
13951 Make_Raise_Constraint_Error (Loc,
13953 Make_And_Then (Loc,
13955 Make_And_Then (Loc,
13957 Convert_To (Standard_Boolean,
13958 Make_Attribute_Reference (Loc,
13959 Prefix => New_Occurrence_Of (CT, Loc),
13960 Attribute_Name => Name_First)),
13963 Convert_To (Standard_Boolean,
13964 Make_Attribute_Reference (Loc,
13965 Prefix => New_Occurrence_Of (CT, Loc),
13966 Attribute_Name => Name_Last))),
13968 Right_Opnd => Make_Non_Empty_Check (Loc, R)),
13969 Reason => CE_Range_Check_Failed));
13970 end Silly_Boolean_Array_Xor_Test;
13972 ----------------------------
13973 -- Small_Integer_Type_For --
13974 ----------------------------
13976 function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id
13979 pragma Assert (S <= System_Max_Integer_Size);
13981 if S <= Standard_Short_Short_Integer_Size then
13983 return Standard_Short_Short_Unsigned;
13985 return Standard_Short_Short_Integer;
13988 elsif S <= Standard_Short_Integer_Size then
13990 return Standard_Short_Unsigned;
13992 return Standard_Short_Integer;
13995 elsif S <= Standard_Integer_Size then
13997 return Standard_Unsigned;
13999 return Standard_Integer;
14002 elsif S <= Standard_Long_Integer_Size then
14004 return Standard_Long_Unsigned;
14006 return Standard_Long_Integer;
14009 elsif S <= Standard_Long_Long_Integer_Size then
14011 return Standard_Long_Long_Unsigned;
14013 return Standard_Long_Long_Integer;
14016 elsif S <= Standard_Long_Long_Long_Integer_Size then
14018 return Standard_Long_Long_Long_Unsigned;
14020 return Standard_Long_Long_Long_Integer;
14024 raise Program_Error;
14026 end Small_Integer_Type_For;
14028 -------------------
14029 -- Type_Map_Hash --
14030 -------------------
14032 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
14034 return Type_Map_Header (Id mod Type_Map_Size);
14037 ------------------------------------------
14038 -- Type_May_Have_Bit_Aligned_Components --
14039 ------------------------------------------
14041 function Type_May_Have_Bit_Aligned_Components
14042 (Typ : Entity_Id) return Boolean
14045 -- Array type, check component type
14047 if Is_Array_Type (Typ) then
14049 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
14051 -- Record type, check components
14053 elsif Is_Record_Type (Typ) then
14058 E := First_Component_Or_Discriminant (Typ);
14059 while Present (E) loop
14060 -- This is the crucial test: if the component itself causes
14061 -- trouble, then we can stop and return True.
14063 if Component_May_Be_Bit_Aligned (E) then
14067 -- Otherwise, we need to test its type, to see if it may
14068 -- itself contain a troublesome component.
14070 if Type_May_Have_Bit_Aligned_Components (Etype (E)) then
14074 Next_Component_Or_Discriminant (E);
14080 -- Type other than array or record is always OK
14085 end Type_May_Have_Bit_Aligned_Components;
14087 -------------------------------
14088 -- Update_Primitives_Mapping --
14089 -------------------------------
14091 procedure Update_Primitives_Mapping
14092 (Inher_Id : Entity_Id;
14093 Subp_Id : Entity_Id)
14097 (Parent_Type => Find_Dispatching_Type (Inher_Id),
14098 Derived_Type => Find_Dispatching_Type (Subp_Id));
14099 end Update_Primitives_Mapping;
14101 ----------------------------------
14102 -- Within_Case_Or_If_Expression --
14103 ----------------------------------
14105 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
14109 -- Locate an enclosing case or if expression. Note that these constructs
14110 -- can be expanded into Expression_With_Actions, hence the test of the
14114 while Present (Par) loop
14115 if Nkind (Original_Node (Par)) in N_Case_Expression | N_If_Expression
14119 -- Prevent the search from going too far
14121 elsif Is_Body_Or_Package_Declaration (Par) then
14125 Par := Parent (Par);
14129 end Within_Case_Or_If_Expression;
14131 ------------------------------
14132 -- Predicate_Check_In_Scope --
14133 ------------------------------
14135 function Predicate_Check_In_Scope (N : Node_Id) return Boolean is
14139 S := Current_Scope;
14140 while Present (S) and then not Is_Subprogram (S) loop
14144 if Present (S) then
14146 -- Predicate checks should only be enabled in init procs for
14147 -- expressions coming from source.
14149 if Is_Init_Proc (S) then
14150 return Comes_From_Source (N);
14152 elsif Get_TSS_Name (S) /= TSS_Null
14153 and then not Is_Predicate_Function (S)
14154 and then not Is_Predicate_Function_M (S)
14161 end Predicate_Check_In_Scope;