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 Make_Unchecked_Type_Conversion (Loc,
1471 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1472 Expression => Obj_Name)));
1475 ------------------------------
1476 -- Build_DIC_Procedure_Body --
1477 ------------------------------
1479 -- WARNING: This routine manages Ghost regions. Return statements must be
1480 -- replaced by gotos which jump to the end of the routine and restore the
1483 procedure Build_DIC_Procedure_Body
1485 Partial_DIC : Boolean := False)
1487 Pragmas_Seen : Elist_Id := No_Elist;
1488 -- This list contains all DIC pragmas processed so far. The list is used
1489 -- to avoid redundant Default_Initial_Condition checks.
1491 procedure Add_DIC_Check
1492 (DIC_Prag : Node_Id;
1494 Stmts : in out List_Id);
1495 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1496 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1497 -- is added to list Stmts.
1499 procedure Add_Inherited_DIC
1500 (DIC_Prag : Node_Id;
1501 Par_Typ : Entity_Id;
1502 Deriv_Typ : Entity_Id;
1503 Stmts : in out List_Id);
1504 -- Add a runtime check to verify the assertion expression of inherited
1505 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1506 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1507 -- pragma. All generated code is added to list Stmts.
1509 procedure Add_Inherited_Tagged_DIC
1510 (DIC_Prag : Node_Id;
1512 Stmts : in out List_Id);
1513 -- Add a runtime check to verify assertion expression DIC_Expr of
1514 -- inherited pragma DIC_Prag. This routine applies class-wide pre-
1515 -- and postcondition-like runtime semantics to the check. Expr is
1516 -- the assertion expression after substitition has been performed
1517 -- (via Replace_References). All generated code is added to list Stmts.
1519 procedure Add_Inherited_DICs
1521 Priv_Typ : Entity_Id;
1522 Full_Typ : Entity_Id;
1524 Checks : in out List_Id);
1525 -- Generate a DIC check for each inherited Default_Initial_Condition
1526 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
1527 -- the partial and full view of the parent type. Obj_Id denotes the
1528 -- entity of the _object formal parameter of the DIC procedure. All
1529 -- created checks are added to list Checks.
1531 procedure Add_Own_DIC
1532 (DIC_Prag : Node_Id;
1533 DIC_Typ : Entity_Id;
1535 Stmts : in out List_Id);
1536 -- Add a runtime check to verify the assertion expression of pragma
1537 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. Obj_Id is the
1538 -- object to substitute in the assertion expression for any references
1539 -- to the current instance of the type All generated code is added to
1542 procedure Add_Parent_DICs
1545 Checks : in out List_Id);
1546 -- Generate a Default_Initial_Condition check for each inherited DIC
1547 -- aspect coming from all parent types of type T. Obj_Id denotes the
1548 -- entity of the _object formal parameter of the DIC procedure. All
1549 -- created checks are added to list Checks.
1555 procedure Add_DIC_Check
1556 (DIC_Prag : Node_Id;
1558 Stmts : in out List_Id)
1560 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1561 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1564 -- The DIC pragma is ignored, nothing left to do
1566 if Is_Ignored (DIC_Prag) then
1569 -- Otherwise the DIC expression must be checked at run time.
1572 -- pragma Check (<Nam>, <DIC_Expr>);
1575 Append_New_To (Stmts,
1577 Pragma_Identifier =>
1578 Make_Identifier (Loc, Name_Check),
1580 Pragma_Argument_Associations => New_List (
1581 Make_Pragma_Argument_Association (Loc,
1582 Expression => Make_Identifier (Loc, Nam)),
1584 Make_Pragma_Argument_Association (Loc,
1585 Expression => DIC_Expr))));
1588 -- Add the pragma to the list of processed pragmas
1590 Append_New_Elmt (DIC_Prag, Pragmas_Seen);
1593 -----------------------
1594 -- Add_Inherited_DIC --
1595 -----------------------
1597 procedure Add_Inherited_DIC
1598 (DIC_Prag : Node_Id;
1599 Par_Typ : Entity_Id;
1600 Deriv_Typ : Entity_Id;
1601 Stmts : in out List_Id)
1603 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1604 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1605 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1606 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1607 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1610 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1612 -- Verify the inherited DIC assertion expression by calling the DIC
1613 -- procedure of the parent type.
1616 -- <Par_Typ>DIC (Par_Typ (_object));
1618 Append_New_To (Stmts,
1619 Make_Procedure_Call_Statement (Loc,
1620 Name => New_Occurrence_Of (Par_Proc, Loc),
1621 Parameter_Associations => New_List (
1623 (Typ => Etype (Par_Obj),
1624 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1625 end Add_Inherited_DIC;
1627 ------------------------------
1628 -- Add_Inherited_Tagged_DIC --
1629 ------------------------------
1631 procedure Add_Inherited_Tagged_DIC
1632 (DIC_Prag : Node_Id;
1634 Stmts : in out List_Id)
1637 -- Once the DIC assertion expression is fully processed, add a check
1638 -- to the statements of the DIC procedure.
1641 (DIC_Prag => DIC_Prag,
1644 end Add_Inherited_Tagged_DIC;
1646 ------------------------
1647 -- Add_Inherited_DICs --
1648 ------------------------
1650 procedure Add_Inherited_DICs
1652 Priv_Typ : Entity_Id;
1653 Full_Typ : Entity_Id;
1655 Checks : in out List_Id)
1657 Deriv_Typ : Entity_Id;
1660 Prag_Expr : Node_Id;
1661 Prag_Expr_Arg : Node_Id;
1663 Prag_Typ_Arg : Node_Id;
1665 Par_Proc : Entity_Id;
1666 -- The "partial" invariant procedure of Par_Typ
1668 Par_Typ : Entity_Id;
1669 -- The suitable view of the parent type used in the substitution of
1673 if not Present (Priv_Typ) and then not Present (Full_Typ) then
1677 -- When the type inheriting the class-wide invariant is a concurrent
1678 -- type, use the corresponding record type because it contains all
1679 -- primitive operations of the concurrent type and allows for proper
1682 if Is_Concurrent_Type (T) then
1683 Deriv_Typ := Corresponding_Record_Type (T);
1688 pragma Assert (Present (Deriv_Typ));
1690 -- Determine which rep item chain to use. Precedence is given to that
1691 -- of the parent type's partial view since it usually carries all the
1692 -- class-wide invariants.
1694 if Present (Priv_Typ) then
1695 Prag := First_Rep_Item (Priv_Typ);
1697 Prag := First_Rep_Item (Full_Typ);
1700 while Present (Prag) loop
1701 if Nkind (Prag) = N_Pragma
1702 and then Pragma_Name (Prag) = Name_Default_Initial_Condition
1704 -- Nothing to do if the pragma was already processed
1706 if Contains (Pragmas_Seen, Prag) then
1710 -- Extract arguments of the Default_Initial_Condition pragma
1712 Prag_Expr_Arg := First (Pragma_Argument_Associations (Prag));
1713 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
1715 -- Pick up the implicit second argument of the pragma, which
1716 -- indicates the type that the pragma applies to.
1718 Prag_Typ_Arg := Next (Prag_Expr_Arg);
1719 if Present (Prag_Typ_Arg) then
1720 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
1725 -- The pragma applies to the partial view of the parent type
1727 if Present (Priv_Typ)
1728 and then Present (Prag_Typ)
1729 and then Entity (Prag_Typ) = Priv_Typ
1731 Par_Typ := Priv_Typ;
1733 -- The pragma applies to the full view of the parent type
1735 elsif Present (Full_Typ)
1736 and then Present (Prag_Typ)
1737 and then Entity (Prag_Typ) = Full_Typ
1739 Par_Typ := Full_Typ;
1741 -- Otherwise the pragma does not belong to the parent type and
1742 -- should not be considered.
1748 -- Substitute references in the DIC expression that are related
1749 -- to the partial type with corresponding references related to
1750 -- the derived type (call to Replace_References below).
1752 Expr := New_Copy_Tree (Prag_Expr);
1754 Par_Proc := Partial_DIC_Procedure (Par_Typ);
1756 -- If there's not a partial DIC procedure (such as when a
1757 -- full type doesn't have its own DIC, but is inherited from
1758 -- a type with DIC), get the full DIC procedure.
1760 if not Present (Par_Proc) then
1761 Par_Proc := DIC_Procedure (Par_Typ);
1767 Deriv_Typ => Deriv_Typ,
1768 Par_Obj => First_Formal (Par_Proc),
1769 Deriv_Obj => Obj_Id);
1771 -- Why are there different actions depending on whether T is
1772 -- tagged? Can these be unified? ???
1774 if Is_Tagged_Type (T) then
1775 Add_Inherited_Tagged_DIC
1784 Deriv_Typ => Deriv_Typ,
1788 -- Leave as soon as we get a DIC pragma, since we'll visit
1789 -- the pragmas of the parents, so will get to any "inherited"
1790 -- pragmas that way.
1795 Next_Rep_Item (Prag);
1797 end Add_Inherited_DICs;
1803 procedure Add_Own_DIC
1804 (DIC_Prag : Node_Id;
1805 DIC_Typ : Entity_Id;
1807 Stmts : in out List_Id)
1809 DIC_Args : constant List_Id :=
1810 Pragma_Argument_Associations (DIC_Prag);
1811 DIC_Arg : constant Node_Id := First (DIC_Args);
1812 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1813 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1817 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1821 -- Start of processing for Add_Own_DIC
1824 pragma Assert (Present (DIC_Expr));
1825 Expr := New_Copy_Tree (DIC_Expr);
1827 -- Perform the following substitution:
1829 -- * Replace the current instance of DIC_Typ with a reference to
1830 -- the _object formal parameter of the DIC procedure.
1832 Replace_Type_References
1837 -- Preanalyze the DIC expression to detect errors and at the same
1838 -- time capture the visibility of the proper package part.
1840 Set_Parent (Expr, Typ_Decl);
1841 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1843 -- Save a copy of the expression with all replacements and analysis
1844 -- already taken place in case a derived type inherits the pragma.
1845 -- The copy will be used as the foundation of the derived type's own
1846 -- version of the DIC assertion expression.
1848 if Is_Tagged_Type (DIC_Typ) then
1849 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1852 -- If the pragma comes from an aspect specification, replace the
1853 -- saved expression because all type references must be substituted
1854 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1857 if Present (DIC_Asp) then
1858 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1861 -- Once the DIC assertion expression is fully processed, add a check
1862 -- to the statements of the DIC procedure (unless the type is an
1863 -- abstract type, in which case we don't want the possibility of
1864 -- generating a call to an abstract function of the type; such DIC
1865 -- procedures can never be called in any case, so not generating the
1866 -- check at all is OK).
1868 if not Is_Abstract_Type (DIC_Typ) or else GNATprove_Mode then
1870 (DIC_Prag => DIC_Prag,
1876 ---------------------
1877 -- Add_Parent_DICs --
1878 ---------------------
1880 procedure Add_Parent_DICs
1883 Checks : in out List_Id)
1885 Dummy_1 : Entity_Id;
1886 Dummy_2 : Entity_Id;
1888 Curr_Typ : Entity_Id;
1889 -- The entity of the current type being examined
1891 Full_Typ : Entity_Id;
1892 -- The full view of Par_Typ
1894 Par_Typ : Entity_Id;
1895 -- The entity of the parent type
1897 Priv_Typ : Entity_Id;
1898 -- The partial view of Par_Typ
1901 -- Climb the parent type chain
1905 -- Do not consider subtypes, as they inherit the DICs from their
1908 Par_Typ := Base_Type (Etype (Base_Type (Curr_Typ)));
1910 -- Stop the climb once the root of the parent chain is
1913 exit when Curr_Typ = Par_Typ;
1915 -- Process the DICs of the parent type
1917 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
1919 -- Only try to inherit a DIC pragma from the parent type Par_Typ
1920 -- if it Has_Own_DIC pragma. The loop will proceed up the parent
1921 -- chain to find all types that have their own DIC.
1923 if Has_Own_DIC (Par_Typ) then
1926 Priv_Typ => Priv_Typ,
1927 Full_Typ => Full_Typ,
1932 Curr_Typ := Par_Typ;
1934 end Add_Parent_DICs;
1938 Loc : constant Source_Ptr := Sloc (Typ);
1940 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1941 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1942 -- Save the Ghost-related attributes to restore on exit
1945 DIC_Typ : Entity_Id;
1946 Dummy_1 : Entity_Id;
1947 Dummy_2 : Entity_Id;
1948 Proc_Body : Node_Id;
1949 Proc_Body_Id : Entity_Id;
1950 Proc_Decl : Node_Id;
1951 Proc_Id : Entity_Id;
1952 Stmts : List_Id := No_List;
1954 CRec_Typ : Entity_Id := Empty;
1955 -- The corresponding record type of Full_Typ
1957 Full_Typ : Entity_Id := Empty;
1958 -- The full view of the working type
1960 Obj_Id : Entity_Id := Empty;
1961 -- The _object formal parameter of the invariant procedure
1963 Part_Proc : Entity_Id := Empty;
1964 -- The entity of the "partial" invariant procedure
1966 Priv_Typ : Entity_Id := Empty;
1967 -- The partial view of the working type
1969 Work_Typ : Entity_Id;
1972 -- Start of processing for Build_DIC_Procedure_Body
1975 Work_Typ := Base_Type (Typ);
1977 -- Do not process class-wide types as these are Itypes, but lack a first
1978 -- subtype (see below).
1980 if Is_Class_Wide_Type (Work_Typ) then
1983 -- Do not process the underlying full view of a private type. There is
1984 -- no way to get back to the partial view, plus the body will be built
1985 -- by the full view or the base type.
1987 elsif Is_Underlying_Full_View (Work_Typ) then
1990 -- Use the first subtype when dealing with various base types
1992 elsif Is_Itype (Work_Typ) then
1993 Work_Typ := First_Subtype (Work_Typ);
1995 -- The input denotes the corresponding record type of a protected or a
1996 -- task type. Work with the concurrent type because the corresponding
1997 -- record type may not be visible to clients of the type.
1999 elsif Ekind (Work_Typ) = E_Record_Type
2000 and then Is_Concurrent_Record_Type (Work_Typ)
2002 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2005 -- The working type may be subject to pragma Ghost. Set the mode now to
2006 -- ensure that the DIC procedure is properly marked as Ghost.
2008 Set_Ghost_Mode (Work_Typ);
2010 -- The working type must be either define a DIC pragma of its own or
2011 -- inherit one from a parent type.
2013 pragma Assert (Has_DIC (Work_Typ));
2015 -- Recover the type which defines the DIC pragma. This is either the
2016 -- working type itself or a parent type when the pragma is inherited.
2018 DIC_Typ := Find_DIC_Type (Work_Typ);
2019 pragma Assert (Present (DIC_Typ));
2021 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2022 pragma Assert (Present (DIC_Prag));
2024 -- Nothing to do if pragma DIC appears without an argument or its sole
2025 -- argument is "null".
2027 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2031 -- Obtain both views of the type
2033 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ);
2035 -- The caller requests a body for the partial DIC procedure
2038 Proc_Id := Partial_DIC_Procedure (Work_Typ);
2040 -- The "full" DIC procedure body was already created
2042 -- Create a declaration for the "partial" DIC procedure if it
2043 -- is not available.
2045 if No (Proc_Id) then
2046 Build_DIC_Procedure_Declaration
2048 Partial_DIC => True);
2050 Proc_Id := Partial_DIC_Procedure (Work_Typ);
2053 -- The caller requests a body for the "full" DIC procedure
2056 Proc_Id := DIC_Procedure (Work_Typ);
2057 Part_Proc := Partial_DIC_Procedure (Work_Typ);
2059 -- Create a declaration for the "full" DIC procedure if it is
2062 if No (Proc_Id) then
2063 Build_DIC_Procedure_Declaration (Work_Typ);
2064 Proc_Id := DIC_Procedure (Work_Typ);
2068 -- At this point there should be a DIC procedure declaration
2070 pragma Assert (Present (Proc_Id));
2071 Proc_Decl := Unit_Declaration_Node (Proc_Id);
2073 -- Nothing to do if the DIC procedure already has a body
2075 if Present (Corresponding_Body (Proc_Decl)) then
2079 -- Emulate the environment of the DIC procedure by installing its scope
2080 -- and formal parameters.
2082 Push_Scope (Proc_Id);
2083 Install_Formals (Proc_Id);
2085 Obj_Id := First_Formal (Proc_Id);
2086 pragma Assert (Present (Obj_Id));
2088 -- The "partial" DIC procedure verifies the DICs of the partial view
2092 pragma Assert (Present (Priv_Typ));
2094 if Has_Own_DIC (Work_Typ) then -- If we're testing this then maybe
2095 Add_Own_DIC -- we shouldn't be calling Find_DIC_Typ above???
2096 (DIC_Prag => DIC_Prag,
2097 DIC_Typ => DIC_Typ, -- Should this just be Work_Typ???
2102 -- Otherwise the "full" DIC procedure verifies the DICs of the full
2103 -- view, well as DICs inherited from parent types. In addition, it
2104 -- indirectly verifies the DICs of the partial view by calling the
2105 -- "partial" DIC procedure.
2108 pragma Assert (Present (Full_Typ));
2110 -- Check the DIC of the partial view by calling the "partial" DIC
2111 -- procedure, unless the partial DIC body is empty. Generate:
2113 -- <Work_Typ>Partial_DIC (_object);
2115 if Present (Part_Proc) and then not Has_Null_Body (Part_Proc) then
2116 Append_New_To (Stmts,
2117 Make_Procedure_Call_Statement (Loc,
2118 Name => New_Occurrence_Of (Part_Proc, Loc),
2119 Parameter_Associations => New_List (
2120 New_Occurrence_Of (Obj_Id, Loc))));
2123 -- Derived subtypes do not have a partial view
2125 if Present (Priv_Typ) then
2127 -- The processing of the "full" DIC procedure intentionally
2128 -- skips the partial view because a) this may result in changes of
2129 -- visibility and b) lead to duplicate checks. However, when the
2130 -- full view is the underlying full view of an untagged derived
2131 -- type whose parent type is private, partial DICs appear on
2132 -- the rep item chain of the partial view only.
2134 -- package Pack_1 is
2135 -- type Root ... is private;
2137 -- <full view of Root>
2141 -- package Pack_2 is
2142 -- type Child is new Pack_1.Root with Type_DIC => ...;
2143 -- <underlying full view of Child>
2146 -- As a result, the processing of the full view must also consider
2147 -- all DICs of the partial view.
2149 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
2152 -- Otherwise the DICs of the partial view are ignored
2155 -- Ignore the DICs of the partial view by eliminating the view
2161 -- Process inherited Default_Initial_Conditions for all parent types
2163 Add_Parent_DICs (Work_Typ, Obj_Id, Stmts);
2168 -- Produce an empty completing body in the following cases:
2169 -- * Assertions are disabled
2170 -- * The DIC Assertion_Policy is Ignore
2173 Stmts := New_List (Make_Null_Statement (Loc));
2177 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
2180 -- end <Work_Typ>DIC;
2183 Make_Subprogram_Body (Loc,
2185 Copy_Subprogram_Spec (Parent (Proc_Id)),
2186 Declarations => Empty_List,
2187 Handled_Statement_Sequence =>
2188 Make_Handled_Sequence_Of_Statements (Loc,
2189 Statements => Stmts));
2190 Proc_Body_Id := Defining_Entity (Proc_Body);
2192 -- Perform minor decoration in case the body is not analyzed
2194 Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
2195 Set_Etype (Proc_Body_Id, Standard_Void_Type);
2196 Set_Scope (Proc_Body_Id, Current_Scope);
2197 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
2198 Set_SPARK_Pragma_Inherited
2199 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
2201 -- Link both spec and body to avoid generating duplicates
2203 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
2204 Set_Corresponding_Spec (Proc_Body, Proc_Id);
2206 -- The body should not be inserted into the tree when the context
2207 -- is a generic unit because it is not part of the template.
2208 -- Note that the body must still be generated in order to resolve the
2209 -- DIC assertion expression.
2211 if Inside_A_Generic then
2214 -- Semi-insert the body into the tree for GNATprove by setting its
2215 -- Parent field. This allows for proper upstream tree traversals.
2217 elsif GNATprove_Mode then
2218 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
2220 -- Otherwise the body is part of the freezing actions of the working
2224 Append_Freeze_Action (Work_Typ, Proc_Body);
2228 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2229 end Build_DIC_Procedure_Body;
2231 -------------------------------------
2232 -- Build_DIC_Procedure_Declaration --
2233 -------------------------------------
2235 -- WARNING: This routine manages Ghost regions. Return statements must be
2236 -- replaced by gotos which jump to the end of the routine and restore the
2239 procedure Build_DIC_Procedure_Declaration
2241 Partial_DIC : Boolean := False)
2243 Loc : constant Source_Ptr := Sloc (Typ);
2245 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2246 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
2247 -- Save the Ghost-related attributes to restore on exit
2250 DIC_Typ : Entity_Id;
2251 Proc_Decl : Node_Id;
2252 Proc_Id : Entity_Id;
2256 CRec_Typ : Entity_Id;
2257 -- The corresponding record type of Full_Typ
2259 Full_Typ : Entity_Id;
2260 -- The full view of working type
2263 -- The _object formal parameter of the DIC procedure
2265 Priv_Typ : Entity_Id;
2266 -- The partial view of working type
2268 UFull_Typ : Entity_Id;
2269 -- The underlying full view of Full_Typ
2271 Work_Typ : Entity_Id;
2275 Work_Typ := Base_Type (Typ);
2277 -- Do not process class-wide types as these are Itypes, but lack a first
2278 -- subtype (see below).
2280 if Is_Class_Wide_Type (Work_Typ) then
2283 -- Do not process the underlying full view of a private type. There is
2284 -- no way to get back to the partial view, plus the body will be built
2285 -- by the full view or the base type.
2287 elsif Is_Underlying_Full_View (Work_Typ) then
2290 -- Use the first subtype when dealing with various base types
2292 elsif Is_Itype (Work_Typ) then
2293 Work_Typ := First_Subtype (Work_Typ);
2295 -- The input denotes the corresponding record type of a protected or a
2296 -- task type. Work with the concurrent type because the corresponding
2297 -- record type may not be visible to clients of the type.
2299 elsif Ekind (Work_Typ) = E_Record_Type
2300 and then Is_Concurrent_Record_Type (Work_Typ)
2302 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2305 -- The working type may be subject to pragma Ghost. Set the mode now to
2306 -- ensure that the DIC procedure is properly marked as Ghost.
2308 Set_Ghost_Mode (Work_Typ);
2310 -- The type must be either subject to a DIC pragma or inherit one from a
2313 pragma Assert (Has_DIC (Work_Typ));
2315 -- Recover the type which defines the DIC pragma. This is either the
2316 -- working type itself or a parent type when the pragma is inherited.
2318 DIC_Typ := Find_DIC_Type (Work_Typ);
2319 pragma Assert (Present (DIC_Typ));
2321 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2322 pragma Assert (Present (DIC_Prag));
2324 -- Nothing to do if pragma DIC appears without an argument or its sole
2325 -- argument is "null".
2327 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2331 -- Nothing to do if the type already has a "partial" DIC procedure
2334 if Present (Partial_DIC_Procedure (Work_Typ)) then
2338 -- Nothing to do if the type already has a "full" DIC procedure
2340 elsif Present (DIC_Procedure (Work_Typ)) then
2344 -- The caller requests the declaration of the "partial" DIC procedure
2347 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_DIC");
2349 -- Otherwise the caller requests the declaration of the "full" DIC
2353 Proc_Nam := New_External_Name (Chars (Work_Typ), "DIC");
2357 Make_Defining_Identifier (Loc, Chars => Proc_Nam);
2359 -- Perform minor decoration in case the declaration is not analyzed
2361 Mutate_Ekind (Proc_Id, E_Procedure);
2362 Set_Etype (Proc_Id, Standard_Void_Type);
2363 Set_Is_DIC_Procedure (Proc_Id);
2364 Set_Scope (Proc_Id, Current_Scope);
2365 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
2366 Set_SPARK_Pragma_Inherited (Proc_Id);
2368 Set_DIC_Procedure (Work_Typ, Proc_Id);
2370 -- The DIC procedure requires debug info when the assertion expression
2371 -- is subject to Source Coverage Obligations.
2373 if Generate_SCO then
2374 Set_Debug_Info_Needed (Proc_Id);
2377 -- Obtain all views of the input type
2379 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
2381 -- Associate the DIC procedure and various flags with all views
2383 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
2384 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
2385 Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ);
2386 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
2388 -- The declaration of the DIC procedure must be inserted after the
2389 -- declaration of the partial view as this allows for proper external
2392 if Present (Priv_Typ) then
2393 Typ_Decl := Declaration_Node (Priv_Typ);
2395 -- Derived types with the full view as parent do not have a partial
2396 -- view. Insert the DIC procedure after the derived type.
2399 Typ_Decl := Declaration_Node (Full_Typ);
2402 -- The type should have a declarative node
2404 pragma Assert (Present (Typ_Decl));
2406 -- Create the formal parameter which emulates the variable-like behavior
2407 -- of the type's current instance.
2409 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
2411 -- Perform minor decoration in case the declaration is not analyzed
2413 Mutate_Ekind (Obj_Id, E_In_Parameter);
2414 Set_Etype (Obj_Id, Work_Typ);
2415 Set_Scope (Obj_Id, Proc_Id);
2417 Set_First_Entity (Proc_Id, Obj_Id);
2418 Set_Last_Entity (Proc_Id, Obj_Id);
2421 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2424 Make_Subprogram_Declaration (Loc,
2426 Make_Procedure_Specification (Loc,
2427 Defining_Unit_Name => Proc_Id,
2428 Parameter_Specifications => New_List (
2429 Make_Parameter_Specification (Loc,
2430 Defining_Identifier => Obj_Id,
2432 New_Occurrence_Of (Work_Typ, Loc)))));
2434 -- The declaration should not be inserted into the tree when the context
2435 -- is a generic unit because it is not part of the template.
2437 if Inside_A_Generic then
2440 -- Semi-insert the declaration into the tree for GNATprove by setting
2441 -- its Parent field. This allows for proper upstream tree traversals.
2443 elsif GNATprove_Mode then
2444 Set_Parent (Proc_Decl, Parent (Typ_Decl));
2446 -- Otherwise insert the declaration
2449 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
2453 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2454 end Build_DIC_Procedure_Declaration;
2456 ------------------------------------
2457 -- Build_Invariant_Procedure_Body --
2458 ------------------------------------
2460 -- WARNING: This routine manages Ghost regions. Return statements must be
2461 -- replaced by gotos which jump to the end of the routine and restore the
2464 procedure Build_Invariant_Procedure_Body
2466 Partial_Invariant : Boolean := False)
2468 Loc : constant Source_Ptr := Sloc (Typ);
2470 Pragmas_Seen : Elist_Id := No_Elist;
2471 -- This list contains all invariant pragmas processed so far. The list
2472 -- is used to avoid generating redundant invariant checks.
2474 Produced_Check : Boolean := False;
2475 -- This flag tracks whether the type has produced at least one invariant
2476 -- check. The flag is used as a sanity check at the end of the routine.
2478 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2479 -- intentionally unnested to avoid deep indentation of code.
2481 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2482 -- they emit checks, loops (for arrays) and case statements (for record
2483 -- variant parts) only when there are invariants to verify. This keeps
2484 -- the body of the invariant procedure free of useless code.
2486 procedure Add_Array_Component_Invariants
2489 Checks : in out List_Id);
2490 -- Generate an invariant check for each component of array type T.
2491 -- Obj_Id denotes the entity of the _object formal parameter of the
2492 -- invariant procedure. All created checks are added to list Checks.
2494 procedure Add_Inherited_Invariants
2496 Priv_Typ : Entity_Id;
2497 Full_Typ : Entity_Id;
2499 Checks : in out List_Id);
2500 -- Generate an invariant check for each inherited class-wide invariant
2501 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2502 -- the partial and full view of the parent type. Obj_Id denotes the
2503 -- entity of the _object formal parameter of the invariant procedure.
2504 -- All created checks are added to list Checks.
2506 procedure Add_Interface_Invariants
2509 Checks : in out List_Id);
2510 -- Generate an invariant check for each inherited class-wide invariant
2511 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2512 -- entity of the _object formal parameter of the invariant procedure.
2513 -- All created checks are added to list Checks.
2515 procedure Add_Invariant_Check
2518 Checks : in out List_Id;
2519 Inherited : Boolean := False);
2520 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2521 -- verify assertion expression Expr of pragma Prag. All generated code
2522 -- is added to list Checks. Flag Inherited should be set when the pragma
2523 -- is inherited from a parent or interface type.
2525 procedure Add_Own_Invariants
2528 Checks : in out List_Id;
2529 Priv_Item : Node_Id := Empty);
2530 -- Generate an invariant check for each invariant found for type T.
2531 -- Obj_Id denotes the entity of the _object formal parameter of the
2532 -- invariant procedure. All created checks are added to list Checks.
2533 -- Priv_Item denotes the first rep item of the private type.
2535 procedure Add_Parent_Invariants
2538 Checks : in out List_Id);
2539 -- Generate an invariant check for each inherited class-wide invariant
2540 -- coming from all parent types of type T. Obj_Id denotes the entity of
2541 -- the _object formal parameter of the invariant procedure. All created
2542 -- checks are added to list Checks.
2544 procedure Add_Record_Component_Invariants
2547 Checks : in out List_Id);
2548 -- Generate an invariant check for each component of record type T.
2549 -- Obj_Id denotes the entity of the _object formal parameter of the
2550 -- invariant procedure. All created checks are added to list Checks.
2552 ------------------------------------
2553 -- Add_Array_Component_Invariants --
2554 ------------------------------------
2556 procedure Add_Array_Component_Invariants
2559 Checks : in out List_Id)
2561 Comp_Typ : constant Entity_Id := Component_Type (T);
2562 Dims : constant Pos := Number_Dimensions (T);
2564 procedure Process_Array_Component
2566 Comp_Checks : in out List_Id);
2567 -- Generate an invariant check for an array component identified by
2568 -- the indices in list Indices. All created checks are added to list
2571 procedure Process_One_Dimension
2574 Dim_Checks : in out List_Id);
2575 -- Generate a loop over the Nth dimension Dim of an array type. List
2576 -- Indices contains all array indices for the dimension. All created
2577 -- checks are added to list Dim_Checks.
2579 -----------------------------
2580 -- Process_Array_Component --
2581 -----------------------------
2583 procedure Process_Array_Component
2585 Comp_Checks : in out List_Id)
2587 Proc_Id : Entity_Id;
2590 if Has_Invariants (Comp_Typ) then
2592 -- In GNATprove mode, the component invariants are checked by
2593 -- other means. They should not be added to the array type
2594 -- invariant procedure, so that the procedure can be used to
2595 -- check the array type invariants if any.
2597 if GNATprove_Mode then
2601 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2603 -- The component type should have an invariant procedure
2604 -- if it has invariants of its own or inherits class-wide
2605 -- invariants from parent or interface types.
2607 pragma Assert (Present (Proc_Id));
2610 -- <Comp_Typ>Invariant (_object (<Indices>));
2612 -- The invariant procedure has a null body if assertions are
2613 -- disabled or Assertion_Policy Ignore is in effect.
2615 if not Has_Null_Body (Proc_Id) then
2616 Append_New_To (Comp_Checks,
2617 Make_Procedure_Call_Statement (Loc,
2619 New_Occurrence_Of (Proc_Id, Loc),
2620 Parameter_Associations => New_List (
2621 Make_Indexed_Component (Loc,
2622 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2623 Expressions => New_Copy_List (Indices)))));
2627 Produced_Check := True;
2629 end Process_Array_Component;
2631 ---------------------------
2632 -- Process_One_Dimension --
2633 ---------------------------
2635 procedure Process_One_Dimension
2638 Dim_Checks : in out List_Id)
2640 Comp_Checks : List_Id := No_List;
2644 -- Generate the invariant checks for the array component after all
2645 -- dimensions have produced their respective loops.
2648 Process_Array_Component
2649 (Indices => Indices,
2650 Comp_Checks => Dim_Checks);
2652 -- Otherwise create a loop for the current dimension
2655 -- Create a new loop variable for each dimension
2658 Make_Defining_Identifier (Loc,
2659 Chars => New_External_Name ('I', Dim));
2660 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2662 Process_One_Dimension
2665 Dim_Checks => Comp_Checks);
2668 -- for I<Dim> in _object'Range (<Dim>) loop
2672 -- Note that the invariant procedure may have a null body if
2673 -- assertions are disabled or Assertion_Policy Ignore is in
2676 if Present (Comp_Checks) then
2677 Append_New_To (Dim_Checks,
2678 Make_Implicit_Loop_Statement (T,
2679 Identifier => Empty,
2681 Make_Iteration_Scheme (Loc,
2682 Loop_Parameter_Specification =>
2683 Make_Loop_Parameter_Specification (Loc,
2684 Defining_Identifier => Index,
2685 Discrete_Subtype_Definition =>
2686 Make_Attribute_Reference (Loc,
2688 New_Occurrence_Of (Obj_Id, Loc),
2689 Attribute_Name => Name_Range,
2690 Expressions => New_List (
2691 Make_Integer_Literal (Loc, Dim))))),
2692 Statements => Comp_Checks));
2695 end Process_One_Dimension;
2697 -- Start of processing for Add_Array_Component_Invariants
2700 Process_One_Dimension
2702 Indices => New_List,
2703 Dim_Checks => Checks);
2704 end Add_Array_Component_Invariants;
2706 ------------------------------
2707 -- Add_Inherited_Invariants --
2708 ------------------------------
2710 procedure Add_Inherited_Invariants
2712 Priv_Typ : Entity_Id;
2713 Full_Typ : Entity_Id;
2715 Checks : in out List_Id)
2717 Deriv_Typ : Entity_Id;
2720 Prag_Expr : Node_Id;
2721 Prag_Expr_Arg : Node_Id;
2723 Prag_Typ_Arg : Node_Id;
2725 Par_Proc : Entity_Id;
2726 -- The "partial" invariant procedure of Par_Typ
2728 Par_Typ : Entity_Id;
2729 -- The suitable view of the parent type used in the substitution of
2733 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2737 -- When the type inheriting the class-wide invariant is a concurrent
2738 -- type, use the corresponding record type because it contains all
2739 -- primitive operations of the concurrent type and allows for proper
2742 if Is_Concurrent_Type (T) then
2743 Deriv_Typ := Corresponding_Record_Type (T);
2748 pragma Assert (Present (Deriv_Typ));
2750 -- Determine which rep item chain to use. Precedence is given to that
2751 -- of the parent type's partial view since it usually carries all the
2752 -- class-wide invariants.
2754 if Present (Priv_Typ) then
2755 Prag := First_Rep_Item (Priv_Typ);
2757 Prag := First_Rep_Item (Full_Typ);
2760 while Present (Prag) loop
2761 if Nkind (Prag) = N_Pragma
2762 and then Pragma_Name (Prag) = Name_Invariant
2764 -- Nothing to do if the pragma was already processed
2766 if Contains (Pragmas_Seen, Prag) then
2769 -- Nothing to do when the caller requests the processing of all
2770 -- inherited class-wide invariants, but the pragma does not
2771 -- fall in this category.
2773 elsif not Class_Present (Prag) then
2777 -- Extract the arguments of the invariant pragma
2779 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2780 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2781 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2782 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2784 -- The pragma applies to the partial view of the parent type
2786 if Present (Priv_Typ)
2787 and then Entity (Prag_Typ) = Priv_Typ
2789 Par_Typ := Priv_Typ;
2791 -- The pragma applies to the full view of the parent type
2793 elsif Present (Full_Typ)
2794 and then Entity (Prag_Typ) = Full_Typ
2796 Par_Typ := Full_Typ;
2798 -- Otherwise the pragma does not belong to the parent type and
2799 -- should not be considered.
2805 -- Perform the following substitutions:
2807 -- * Replace a reference to the _object parameter of the
2808 -- parent type's partial invariant procedure with a
2809 -- reference to the _object parameter of the derived
2810 -- type's full invariant procedure.
2812 -- * Replace a reference to a discriminant of the parent type
2813 -- with a suitable value from the point of view of the
2816 -- * Replace a call to an overridden parent primitive with a
2817 -- call to the overriding derived type primitive.
2819 -- * Replace a call to an inherited parent primitive with a
2820 -- call to the internally-generated inherited derived type
2823 Expr := New_Copy_Tree (Prag_Expr);
2825 -- The parent type must have a "partial" invariant procedure
2826 -- because class-wide invariants are captured exclusively by
2829 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2830 pragma Assert (Present (Par_Proc));
2835 Deriv_Typ => Deriv_Typ,
2836 Par_Obj => First_Formal (Par_Proc),
2837 Deriv_Obj => Obj_Id);
2839 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2842 Next_Rep_Item (Prag);
2844 end Add_Inherited_Invariants;
2846 ------------------------------
2847 -- Add_Interface_Invariants --
2848 ------------------------------
2850 procedure Add_Interface_Invariants
2853 Checks : in out List_Id)
2855 Iface_Elmt : Elmt_Id;
2859 -- Generate an invariant check for each class-wide invariant coming
2860 -- from all interfaces implemented by type T.
2862 if Is_Tagged_Type (T) then
2863 Collect_Interfaces (T, Ifaces);
2865 -- Process the class-wide invariants of all implemented interfaces
2867 Iface_Elmt := First_Elmt (Ifaces);
2868 while Present (Iface_Elmt) loop
2870 -- The Full_Typ parameter is intentionally left Empty because
2871 -- interfaces are treated as the partial view of a private type
2872 -- in order to achieve uniformity with the general case.
2874 Add_Inherited_Invariants
2876 Priv_Typ => Node (Iface_Elmt),
2881 Next_Elmt (Iface_Elmt);
2884 end Add_Interface_Invariants;
2886 -------------------------
2887 -- Add_Invariant_Check --
2888 -------------------------
2890 procedure Add_Invariant_Check
2893 Checks : in out List_Id;
2894 Inherited : Boolean := False)
2896 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2897 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2898 Ploc : constant Source_Ptr := Sloc (Prag);
2899 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2905 -- The invariant is ignored, nothing left to do
2907 if Is_Ignored (Prag) then
2910 -- Otherwise the invariant is checked. Build a pragma Check to verify
2911 -- the expression at run time.
2915 Make_Pragma_Argument_Association (Ploc,
2916 Expression => Make_Identifier (Ploc, Nam)),
2917 Make_Pragma_Argument_Association (Ploc,
2918 Expression => Expr));
2920 -- Handle the String argument (if any)
2922 if Present (Str_Arg) then
2923 Str := Strval (Get_Pragma_Arg (Str_Arg));
2925 -- When inheriting an invariant, modify the message from
2926 -- "failed invariant" to "failed inherited invariant".
2929 String_To_Name_Buffer (Str);
2931 if Name_Buffer (1 .. 16) = "failed invariant" then
2932 Insert_Str_In_Name_Buffer ("inherited ", 8);
2933 Str := String_From_Name_Buffer;
2938 Make_Pragma_Argument_Association (Ploc,
2939 Expression => Make_String_Literal (Ploc, Str)));
2943 -- pragma Check (<Nam>, <Expr>, <Str>);
2945 Append_New_To (Checks,
2947 Chars => Name_Check,
2948 Pragma_Argument_Associations => Assoc));
2951 -- Output an info message when inheriting an invariant and the
2952 -- listing option is enabled.
2954 if Inherited and Opt.List_Inherited_Aspects then
2955 Error_Msg_Sloc := Sloc (Prag);
2957 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
2960 -- Add the pragma to the list of processed pragmas
2962 Append_New_Elmt (Prag, Pragmas_Seen);
2963 Produced_Check := True;
2964 end Add_Invariant_Check;
2966 ---------------------------
2967 -- Add_Parent_Invariants --
2968 ---------------------------
2970 procedure Add_Parent_Invariants
2973 Checks : in out List_Id)
2975 Dummy_1 : Entity_Id;
2976 Dummy_2 : Entity_Id;
2978 Curr_Typ : Entity_Id;
2979 -- The entity of the current type being examined
2981 Full_Typ : Entity_Id;
2982 -- The full view of Par_Typ
2984 Par_Typ : Entity_Id;
2985 -- The entity of the parent type
2987 Priv_Typ : Entity_Id;
2988 -- The partial view of Par_Typ
2991 -- Do not process array types because they cannot have true parent
2992 -- types. This also prevents the generation of a duplicate invariant
2993 -- check when the input type is an array base type because its Etype
2994 -- denotes the first subtype, both of which share the same component
2997 if Is_Array_Type (T) then
3001 -- Climb the parent type chain
3005 -- Do not consider subtypes as they inherit the invariants
3006 -- from their base types.
3008 Par_Typ := Base_Type (Etype (Curr_Typ));
3010 -- Stop the climb once the root of the parent chain is
3013 exit when Curr_Typ = Par_Typ;
3015 -- Process the class-wide invariants of the parent type
3017 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
3019 -- Process the elements of an array type
3021 if Is_Array_Type (Full_Typ) then
3022 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
3024 -- Process the components of a record type
3026 elsif Ekind (Full_Typ) = E_Record_Type then
3027 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
3030 Add_Inherited_Invariants
3032 Priv_Typ => Priv_Typ,
3033 Full_Typ => Full_Typ,
3037 Curr_Typ := Par_Typ;
3039 end Add_Parent_Invariants;
3041 ------------------------
3042 -- Add_Own_Invariants --
3043 ------------------------
3045 procedure Add_Own_Invariants
3048 Checks : in out List_Id;
3049 Priv_Item : Node_Id := Empty)
3054 Prag_Expr : Node_Id;
3055 Prag_Expr_Arg : Node_Id;
3057 Prag_Typ_Arg : Node_Id;
3060 if not Present (T) then
3064 Prag := First_Rep_Item (T);
3065 while Present (Prag) loop
3066 if Nkind (Prag) = N_Pragma
3067 and then Pragma_Name (Prag) = Name_Invariant
3069 -- Stop the traversal of the rep item chain once a specific
3070 -- item is encountered.
3072 if Present (Priv_Item) and then Prag = Priv_Item then
3076 -- Nothing to do if the pragma was already processed
3078 if Contains (Pragmas_Seen, Prag) then
3082 -- Extract the arguments of the invariant pragma
3084 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
3085 Prag_Expr_Arg := Next (Prag_Typ_Arg);
3086 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
3087 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
3088 Prag_Asp := Corresponding_Aspect (Prag);
3090 -- Verify the pragma belongs to T, otherwise the pragma applies
3091 -- to a parent type in which case it will be processed later by
3092 -- Add_Parent_Invariants or Add_Interface_Invariants.
3094 if Entity (Prag_Typ) /= T then
3098 Expr := New_Copy_Tree (Prag_Expr);
3100 -- Substitute all references to type T with references to the
3101 -- _object formal parameter.
3103 Replace_Type_References (Expr, T, Obj_Id);
3105 -- Preanalyze the invariant expression to detect errors and at
3106 -- the same time capture the visibility of the proper package
3109 Set_Parent (Expr, Parent (Prag_Expr));
3110 Preanalyze_Assert_Expression (Expr, Any_Boolean);
3112 -- Save a copy of the expression when T is tagged to detect
3113 -- errors and capture the visibility of the proper package part
3114 -- for the generation of inherited type invariants.
3116 if Is_Tagged_Type (T) then
3117 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
3120 -- If the pragma comes from an aspect specification, replace
3121 -- the saved expression because all type references must be
3122 -- substituted for the call to Preanalyze_Spec_Expression in
3123 -- Check_Aspect_At_xxx routines.
3125 if Present (Prag_Asp) then
3126 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
3129 Add_Invariant_Check (Prag, Expr, Checks);
3132 Next_Rep_Item (Prag);
3134 end Add_Own_Invariants;
3136 -------------------------------------
3137 -- Add_Record_Component_Invariants --
3138 -------------------------------------
3140 procedure Add_Record_Component_Invariants
3143 Checks : in out List_Id)
3145 procedure Process_Component_List
3146 (Comp_List : Node_Id;
3147 CL_Checks : in out List_Id);
3148 -- Generate invariant checks for all record components found in
3149 -- component list Comp_List, including variant parts. All created
3150 -- checks are added to list CL_Checks.
3152 procedure Process_Record_Component
3153 (Comp_Id : Entity_Id;
3154 Comp_Checks : in out List_Id);
3155 -- Generate an invariant check for a record component identified by
3156 -- Comp_Id. All created checks are added to list Comp_Checks.
3158 ----------------------------
3159 -- Process_Component_List --
3160 ----------------------------
3162 procedure Process_Component_List
3163 (Comp_List : Node_Id;
3164 CL_Checks : in out List_Id)
3168 Var_Alts : List_Id := No_List;
3169 Var_Checks : List_Id := No_List;
3170 Var_Stmts : List_Id;
3172 Produced_Variant_Check : Boolean := False;
3173 -- This flag tracks whether the component has produced at least
3174 -- one invariant check.
3177 -- Traverse the component items
3179 Comp := First (Component_Items (Comp_List));
3180 while Present (Comp) loop
3181 if Nkind (Comp) = N_Component_Declaration then
3183 -- Generate the component invariant check
3185 Process_Record_Component
3186 (Comp_Id => Defining_Entity (Comp),
3187 Comp_Checks => CL_Checks);
3193 -- Traverse the variant part
3195 if Present (Variant_Part (Comp_List)) then
3196 Var := First (Variants (Variant_Part (Comp_List)));
3197 while Present (Var) loop
3198 Var_Checks := No_List;
3200 -- Generate invariant checks for all components and variant
3201 -- parts that qualify.
3203 Process_Component_List
3204 (Comp_List => Component_List (Var),
3205 CL_Checks => Var_Checks);
3207 -- The components of the current variant produced at least
3208 -- one invariant check.
3210 if Present (Var_Checks) then
3211 Var_Stmts := Var_Checks;
3212 Produced_Variant_Check := True;
3214 -- Otherwise there are either no components with invariants,
3215 -- assertions are disabled, or Assertion_Policy Ignore is in
3219 Var_Stmts := New_List (Make_Null_Statement (Loc));
3222 Append_New_To (Var_Alts,
3223 Make_Case_Statement_Alternative (Loc,
3225 New_Copy_List (Discrete_Choices (Var)),
3226 Statements => Var_Stmts));
3231 -- Create a case statement which verifies the invariant checks
3232 -- of a particular component list depending on the discriminant
3233 -- values only when there is at least one real invariant check.
3235 if Produced_Variant_Check then
3236 Append_New_To (CL_Checks,
3237 Make_Case_Statement (Loc,
3239 Make_Selected_Component (Loc,
3240 Prefix => New_Occurrence_Of (Obj_Id, Loc),
3243 (Entity (Name (Variant_Part (Comp_List))), Loc)),
3244 Alternatives => Var_Alts));
3247 end Process_Component_List;
3249 ------------------------------
3250 -- Process_Record_Component --
3251 ------------------------------
3253 procedure Process_Record_Component
3254 (Comp_Id : Entity_Id;
3255 Comp_Checks : in out List_Id)
3257 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
3258 Proc_Id : Entity_Id;
3260 Produced_Component_Check : Boolean := False;
3261 -- This flag tracks whether the component has produced at least
3262 -- one invariant check.
3265 -- Nothing to do for internal component _parent. Note that it is
3266 -- not desirable to check whether the component comes from source
3267 -- because protected type components are relocated to an internal
3268 -- corresponding record, but still need processing.
3270 if Chars (Comp_Id) = Name_uParent then
3274 -- Verify the invariant of the component. Note that an access
3275 -- type may have an invariant when it acts as the full view of a
3276 -- private type and the invariant appears on the partial view. In
3277 -- this case verify the access value itself.
3279 if Has_Invariants (Comp_Typ) then
3281 -- In GNATprove mode, the component invariants are checked by
3282 -- other means. They should not be added to the record type
3283 -- invariant procedure, so that the procedure can be used to
3284 -- check the record type invariants if any.
3286 if GNATprove_Mode then
3290 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3292 -- The component type should have an invariant procedure
3293 -- if it has invariants of its own or inherits class-wide
3294 -- invariants from parent or interface types.
3296 pragma Assert (Present (Proc_Id));
3299 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
3301 -- Note that the invariant procedure may have a null body if
3302 -- assertions are disabled or Assertion_Policy Ignore is in
3305 if not Has_Null_Body (Proc_Id) then
3306 Append_New_To (Comp_Checks,
3307 Make_Procedure_Call_Statement (Loc,
3309 New_Occurrence_Of (Proc_Id, Loc),
3310 Parameter_Associations => New_List (
3311 Make_Selected_Component (Loc,
3313 Unchecked_Convert_To
3314 (T, New_Occurrence_Of (Obj_Id, Loc)),
3316 New_Occurrence_Of (Comp_Id, Loc)))));
3320 Produced_Check := True;
3321 Produced_Component_Check := True;
3324 if Produced_Component_Check and then Has_Unchecked_Union (T) then
3326 ("invariants cannot be checked on components of "
3327 & "unchecked_union type &??", Comp_Id, T);
3329 end Process_Record_Component;
3336 -- Start of processing for Add_Record_Component_Invariants
3339 -- An untagged derived type inherits the components of its parent
3340 -- type. In order to avoid creating redundant invariant checks, do
3341 -- not process the components now. Instead wait until the ultimate
3342 -- parent of the untagged derivation chain is reached.
3344 if not Is_Untagged_Derivation (T) then
3345 Def := Type_Definition (Parent (T));
3347 if Nkind (Def) = N_Derived_Type_Definition then
3348 Def := Record_Extension_Part (Def);
3351 pragma Assert (Nkind (Def) = N_Record_Definition);
3352 Comps := Component_List (Def);
3354 if Present (Comps) then
3355 Process_Component_List
3356 (Comp_List => Comps,
3357 CL_Checks => Checks);
3360 end Add_Record_Component_Invariants;
3364 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3365 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3366 -- Save the Ghost-related attributes to restore on exit
3369 Priv_Item : Node_Id;
3370 Proc_Body : Node_Id;
3371 Proc_Body_Id : Entity_Id;
3372 Proc_Decl : Node_Id;
3373 Proc_Id : Entity_Id;
3374 Stmts : List_Id := No_List;
3376 CRec_Typ : Entity_Id := Empty;
3377 -- The corresponding record type of Full_Typ
3379 Full_Proc : Entity_Id := Empty;
3380 -- The entity of the "full" invariant procedure
3382 Full_Typ : Entity_Id := Empty;
3383 -- The full view of the working type
3385 Obj_Id : Entity_Id := Empty;
3386 -- The _object formal parameter of the invariant procedure
3388 Part_Proc : Entity_Id := Empty;
3389 -- The entity of the "partial" invariant procedure
3391 Priv_Typ : Entity_Id := Empty;
3392 -- The partial view of the working type
3394 Work_Typ : Entity_Id := Empty;
3397 -- Start of processing for Build_Invariant_Procedure_Body
3402 -- Do not process the underlying full view of a private type. There is
3403 -- no way to get back to the partial view, plus the body will be built
3404 -- by the full view or the base type.
3406 if Is_Underlying_Full_View (Work_Typ) then
3409 -- The input type denotes the implementation base type of a constrained
3410 -- array type. Work with the first subtype as all invariant pragmas are
3411 -- on its rep item chain.
3413 elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3414 Work_Typ := First_Subtype (Work_Typ);
3416 -- The input type denotes the corresponding record type of a protected
3417 -- or task type. Work with the concurrent type because the corresponding
3418 -- record type may not be visible to clients of the type.
3420 elsif Ekind (Work_Typ) = E_Record_Type
3421 and then Is_Concurrent_Record_Type (Work_Typ)
3423 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3426 -- The working type may be subject to pragma Ghost. Set the mode now to
3427 -- ensure that the invariant procedure is properly marked as Ghost.
3429 Set_Ghost_Mode (Work_Typ);
3431 -- The type must either have invariants of its own, inherit class-wide
3432 -- invariants from parent types or interfaces, or be an array or record
3433 -- type whose components have invariants.
3435 pragma Assert (Has_Invariants (Work_Typ));
3437 -- Interfaces are treated as the partial view of a private type in order
3438 -- to achieve uniformity with the general case.
3440 if Is_Interface (Work_Typ) then
3441 Priv_Typ := Work_Typ;
3443 -- Otherwise obtain both views of the type
3446 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
3449 -- The caller requests a body for the partial invariant procedure
3451 if Partial_Invariant then
3452 Full_Proc := Invariant_Procedure (Work_Typ);
3453 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3455 -- The "full" invariant procedure body was already created
3457 if Present (Full_Proc)
3459 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
3461 -- This scenario happens only when the type is an untagged
3462 -- derivation from a private parent and the underlying full
3463 -- view was processed before the partial view.
3466 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3468 -- Nothing to do because the processing of the underlying full
3469 -- view already checked the invariants of the partial view.
3474 -- Create a declaration for the "partial" invariant procedure if it
3475 -- is not available.
3477 if No (Proc_Id) then
3478 Build_Invariant_Procedure_Declaration
3480 Partial_Invariant => True);
3482 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3485 -- The caller requests a body for the "full" invariant procedure
3488 Proc_Id := Invariant_Procedure (Work_Typ);
3489 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3491 -- Create a declaration for the "full" invariant procedure if it is
3494 if No (Proc_Id) then
3495 Build_Invariant_Procedure_Declaration (Work_Typ);
3496 Proc_Id := Invariant_Procedure (Work_Typ);
3500 -- At this point there should be an invariant procedure declaration
3502 pragma Assert (Present (Proc_Id));
3503 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3505 -- Nothing to do if the invariant procedure already has a body
3507 if Present (Corresponding_Body (Proc_Decl)) then
3511 -- Emulate the environment of the invariant procedure by installing its
3512 -- scope and formal parameters. Note that this is not needed, but having
3513 -- the scope installed helps with the detection of invariant-related
3516 Push_Scope (Proc_Id);
3517 Install_Formals (Proc_Id);
3519 Obj_Id := First_Formal (Proc_Id);
3520 pragma Assert (Present (Obj_Id));
3522 -- The "partial" invariant procedure verifies the invariants of the
3523 -- partial view only.
3525 if Partial_Invariant then
3526 pragma Assert (Present (Priv_Typ));
3533 -- Otherwise the "full" invariant procedure verifies the invariants of
3534 -- the full view, all array or record components, as well as class-wide
3535 -- invariants inherited from parent types or interfaces. In addition, it
3536 -- indirectly verifies the invariants of the partial view by calling the
3537 -- "partial" invariant procedure.
3540 pragma Assert (Present (Full_Typ));
3542 -- Check the invariants of the partial view by calling the "partial"
3543 -- invariant procedure. Generate:
3545 -- <Work_Typ>Partial_Invariant (_object);
3547 if Present (Part_Proc) then
3548 Append_New_To (Stmts,
3549 Make_Procedure_Call_Statement (Loc,
3550 Name => New_Occurrence_Of (Part_Proc, Loc),
3551 Parameter_Associations => New_List (
3552 New_Occurrence_Of (Obj_Id, Loc))));
3554 Produced_Check := True;
3559 -- Derived subtypes do not have a partial view
3561 if Present (Priv_Typ) then
3563 -- The processing of the "full" invariant procedure intentionally
3564 -- skips the partial view because a) this may result in changes of
3565 -- visibility and b) lead to duplicate checks. However, when the
3566 -- full view is the underlying full view of an untagged derived
3567 -- type whose parent type is private, partial invariants appear on
3568 -- the rep item chain of the partial view only.
3570 -- package Pack_1 is
3571 -- type Root ... is private;
3573 -- <full view of Root>
3577 -- package Pack_2 is
3578 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3579 -- <underlying full view of Child>
3582 -- As a result, the processing of the full view must also consider
3583 -- all invariants of the partial view.
3585 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3588 -- Otherwise the invariants of the partial view are ignored
3591 -- Note that the rep item chain is shared between the partial
3592 -- and full views of a type. To avoid processing the invariants
3593 -- of the partial view, signal the logic to stop when the first
3594 -- rep item of the partial view has been reached.
3596 Priv_Item := First_Rep_Item (Priv_Typ);
3598 -- Ignore the invariants of the partial view by eliminating the
3605 -- Process the invariants of the full view and in certain cases those
3606 -- of the partial view. This also handles any invariants on array or
3607 -- record components.
3613 Priv_Item => Priv_Item);
3619 Priv_Item => Priv_Item);
3621 -- Process the elements of an array type
3623 if Is_Array_Type (Full_Typ) then
3624 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3626 -- Process the components of a record type
3628 elsif Ekind (Full_Typ) = E_Record_Type then
3629 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3631 -- Process the components of a corresponding record
3633 elsif Present (CRec_Typ) then
3634 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3637 -- Process the inherited class-wide invariants of all parent types.
3638 -- This also handles any invariants on record components.
3640 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3642 -- Process the inherited class-wide invariants of all implemented
3645 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3650 -- At this point there should be at least one invariant check. If this
3651 -- is not the case, then the invariant-related flags were not properly
3652 -- set, or there is a missing invariant procedure on one of the array
3653 -- or record components.
3655 pragma Assert (Produced_Check);
3657 -- Account for the case where assertions are disabled or all invariant
3658 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3662 Stmts := New_List (Make_Null_Statement (Loc));
3666 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3669 -- end <Work_Typ>[Partial_]Invariant;
3672 Make_Subprogram_Body (Loc,
3674 Copy_Subprogram_Spec (Parent (Proc_Id)),
3675 Declarations => Empty_List,
3676 Handled_Statement_Sequence =>
3677 Make_Handled_Sequence_Of_Statements (Loc,
3678 Statements => Stmts));
3679 Proc_Body_Id := Defining_Entity (Proc_Body);
3681 -- Perform minor decoration in case the body is not analyzed
3683 Mutate_Ekind (Proc_Body_Id, E_Subprogram_Body);
3684 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3685 Set_Scope (Proc_Body_Id, Current_Scope);
3687 -- Link both spec and body to avoid generating duplicates
3689 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3690 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3692 -- The body should not be inserted into the tree when the context is
3693 -- a generic unit because it is not part of the template. Note
3694 -- that the body must still be generated in order to resolve the
3697 if Inside_A_Generic then
3700 -- Semi-insert the body into the tree for GNATprove by setting its
3701 -- Parent field. This allows for proper upstream tree traversals.
3703 elsif GNATprove_Mode then
3704 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3706 -- Otherwise the body is part of the freezing actions of the type
3709 Append_Freeze_Action (Work_Typ, Proc_Body);
3713 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3714 end Build_Invariant_Procedure_Body;
3716 -------------------------------------------
3717 -- Build_Invariant_Procedure_Declaration --
3718 -------------------------------------------
3720 -- WARNING: This routine manages Ghost regions. Return statements must be
3721 -- replaced by gotos which jump to the end of the routine and restore the
3724 procedure Build_Invariant_Procedure_Declaration
3726 Partial_Invariant : Boolean := False)
3728 Loc : constant Source_Ptr := Sloc (Typ);
3730 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3731 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3732 -- Save the Ghost-related attributes to restore on exit
3734 Proc_Decl : Node_Id;
3735 Proc_Id : Entity_Id;
3739 CRec_Typ : Entity_Id;
3740 -- The corresponding record type of Full_Typ
3742 Full_Typ : Entity_Id;
3743 -- The full view of working type
3746 -- The _object formal parameter of the invariant procedure
3748 Obj_Typ : Entity_Id;
3749 -- The type of the _object formal parameter
3751 Priv_Typ : Entity_Id;
3752 -- The partial view of working type
3754 UFull_Typ : Entity_Id;
3755 -- The underlying full view of Full_Typ
3757 Work_Typ : Entity_Id;
3763 -- The input type denotes the implementation base type of a constrained
3764 -- array type. Work with the first subtype as all invariant pragmas are
3765 -- on its rep item chain.
3767 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3768 Work_Typ := First_Subtype (Work_Typ);
3770 -- The input denotes the corresponding record type of a protected or a
3771 -- task type. Work with the concurrent type because the corresponding
3772 -- record type may not be visible to clients of the type.
3774 elsif Ekind (Work_Typ) = E_Record_Type
3775 and then Is_Concurrent_Record_Type (Work_Typ)
3777 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3780 -- The working type may be subject to pragma Ghost. Set the mode now to
3781 -- ensure that the invariant procedure is properly marked as Ghost.
3783 Set_Ghost_Mode (Work_Typ);
3785 -- The type must either have invariants of its own, inherit class-wide
3786 -- invariants from parent or interface types, or be an array or record
3787 -- type whose components have invariants.
3789 pragma Assert (Has_Invariants (Work_Typ));
3791 -- Nothing to do if the type already has a "partial" invariant procedure
3793 if Partial_Invariant then
3794 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3798 -- Nothing to do if the type already has a "full" invariant procedure
3800 elsif Present (Invariant_Procedure (Work_Typ)) then
3804 -- The caller requests the declaration of the "partial" invariant
3807 if Partial_Invariant then
3808 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3810 -- Otherwise the caller requests the declaration of the "full" invariant
3814 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3817 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3819 -- Perform minor decoration in case the declaration is not analyzed
3821 Mutate_Ekind (Proc_Id, E_Procedure);
3822 Set_Etype (Proc_Id, Standard_Void_Type);
3823 Set_Scope (Proc_Id, Current_Scope);
3825 if Partial_Invariant then
3826 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3827 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3829 Set_Is_Invariant_Procedure (Proc_Id);
3830 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3833 -- The invariant procedure requires debug info when the invariants are
3834 -- subject to Source Coverage Obligations.
3836 if Generate_SCO then
3837 Set_Debug_Info_Needed (Proc_Id);
3840 -- Obtain all views of the input type
3842 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
3844 -- Associate the invariant procedure and various flags with all views
3846 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3847 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3848 Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ);
3849 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3851 -- The declaration of the invariant procedure is inserted after the
3852 -- declaration of the partial view as this allows for proper external
3855 if Present (Priv_Typ) then
3856 Typ_Decl := Declaration_Node (Priv_Typ);
3858 -- Anonymous arrays in object declarations have no explicit declaration
3859 -- so use the related object declaration as the insertion point.
3861 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
3862 Typ_Decl := Associated_Node_For_Itype (Work_Typ);
3864 -- Derived types with the full view as parent do not have a partial
3865 -- view. Insert the invariant procedure after the derived type.
3868 Typ_Decl := Declaration_Node (Full_Typ);
3871 -- The type should have a declarative node
3873 pragma Assert (Present (Typ_Decl));
3875 -- Create the formal parameter which emulates the variable-like behavior
3876 -- of the current type instance.
3878 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3880 -- When generating an invariant procedure declaration for an abstract
3881 -- type (including interfaces), use the class-wide type as the _object
3882 -- type. This has several desirable effects:
3884 -- * The invariant procedure does not become a primitive of the type.
3885 -- This eliminates the need to either special case the treatment of
3886 -- invariant procedures, or to make it a predefined primitive and
3887 -- force every derived type to potentially provide an empty body.
3889 -- * The invariant procedure does not need to be declared as abstract.
3890 -- This allows for a proper body, which in turn avoids redundant
3891 -- processing of the same invariants for types with multiple views.
3893 -- * The class-wide type allows for calls to abstract primitives
3894 -- within a nonabstract subprogram. The calls are treated as
3895 -- dispatching and require additional processing when they are
3896 -- remapped to call primitives of derived types. See routine
3897 -- Replace_References for details.
3899 if Is_Abstract_Type (Work_Typ) then
3900 Obj_Typ := Class_Wide_Type (Work_Typ);
3902 Obj_Typ := Work_Typ;
3905 -- Perform minor decoration in case the declaration is not analyzed
3907 Mutate_Ekind (Obj_Id, E_In_Parameter);
3908 Set_Etype (Obj_Id, Obj_Typ);
3909 Set_Scope (Obj_Id, Proc_Id);
3911 Set_First_Entity (Proc_Id, Obj_Id);
3912 Set_Last_Entity (Proc_Id, Obj_Id);
3915 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3918 Make_Subprogram_Declaration (Loc,
3920 Make_Procedure_Specification (Loc,
3921 Defining_Unit_Name => Proc_Id,
3922 Parameter_Specifications => New_List (
3923 Make_Parameter_Specification (Loc,
3924 Defining_Identifier => Obj_Id,
3925 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3927 -- The declaration should not be inserted into the tree when the context
3928 -- is a generic unit because it is not part of the template.
3930 if Inside_A_Generic then
3933 -- Semi-insert the declaration into the tree for GNATprove by setting
3934 -- its Parent field. This allows for proper upstream tree traversals.
3936 elsif GNATprove_Mode then
3937 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3939 -- Otherwise insert the declaration
3942 pragma Assert (Present (Typ_Decl));
3943 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3947 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3948 end Build_Invariant_Procedure_Declaration;
3950 --------------------------
3951 -- Build_Procedure_Form --
3952 --------------------------
3954 procedure Build_Procedure_Form (N : Node_Id) is
3955 Loc : constant Source_Ptr := Sloc (N);
3956 Subp : constant Entity_Id := Defining_Entity (N);
3958 Func_Formal : Entity_Id;
3959 Proc_Formals : List_Id;
3960 Proc_Decl : Node_Id;
3963 -- No action needed if this transformation was already done, or in case
3964 -- of subprogram renaming declarations.
3966 if Nkind (Specification (N)) = N_Procedure_Specification
3967 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3972 -- Ditto when dealing with an expression function, where both the
3973 -- original expression and the generated declaration end up being
3976 if Rewritten_For_C (Subp) then
3980 Proc_Formals := New_List;
3982 -- Create a list of formal parameters with the same types as the
3985 Func_Formal := First_Formal (Subp);
3986 while Present (Func_Formal) loop
3987 Append_To (Proc_Formals,
3988 Make_Parameter_Specification (Loc,
3989 Defining_Identifier =>
3990 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
3992 New_Occurrence_Of (Etype (Func_Formal), Loc)));
3994 Next_Formal (Func_Formal);
3997 -- Add an extra out parameter to carry the function result
3999 Append_To (Proc_Formals,
4000 Make_Parameter_Specification (Loc,
4001 Defining_Identifier =>
4002 Make_Defining_Identifier (Loc, Name_UP_RESULT),
4003 Out_Present => True,
4004 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
4006 -- The new procedure declaration is inserted before the function
4007 -- declaration. The processing in Build_Procedure_Body_Form relies on
4008 -- this order. Note that we insert before because in the case of a
4009 -- function body with no separate spec, we do not want to insert the
4010 -- new spec after the body which will later get rewritten.
4013 Make_Subprogram_Declaration (Loc,
4015 Make_Procedure_Specification (Loc,
4016 Defining_Unit_Name =>
4017 Make_Defining_Identifier (Loc, Chars (Subp)),
4018 Parameter_Specifications => Proc_Formals));
4020 Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
4022 -- Entity of procedure must remain invisible so that it does not
4023 -- overload subsequent references to the original function.
4025 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
4027 -- Mark the function as having a procedure form and link the function
4028 -- and its internally built procedure.
4030 Set_Rewritten_For_C (Subp);
4031 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
4032 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
4033 end Build_Procedure_Form;
4035 ------------------------
4036 -- Build_Runtime_Call --
4037 ------------------------
4039 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
4041 -- If entity is not available, we can skip making the call (this avoids
4042 -- junk duplicated error messages in a number of cases).
4044 if not RTE_Available (RE) then
4045 return Make_Null_Statement (Loc);
4048 Make_Procedure_Call_Statement (Loc,
4049 Name => New_Occurrence_Of (RTE (RE), Loc));
4051 end Build_Runtime_Call;
4053 ------------------------
4054 -- Build_SS_Mark_Call --
4055 ------------------------
4057 function Build_SS_Mark_Call
4059 Mark : Entity_Id) return Node_Id
4063 -- Mark : constant Mark_Id := SS_Mark;
4066 Make_Object_Declaration (Loc,
4067 Defining_Identifier => Mark,
4068 Constant_Present => True,
4069 Object_Definition =>
4070 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
4072 Make_Function_Call (Loc,
4073 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
4074 end Build_SS_Mark_Call;
4076 ---------------------------
4077 -- Build_SS_Release_Call --
4078 ---------------------------
4080 function Build_SS_Release_Call
4082 Mark : Entity_Id) return Node_Id
4086 -- SS_Release (Mark);
4089 Make_Procedure_Call_Statement (Loc,
4091 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
4092 Parameter_Associations => New_List (
4093 New_Occurrence_Of (Mark, Loc)));
4094 end Build_SS_Release_Call;
4096 ----------------------------
4097 -- Build_Task_Array_Image --
4098 ----------------------------
4100 -- This function generates the body for a function that constructs the
4101 -- image string for a task that is an array component. The function is
4102 -- local to the init proc for the array type, and is called for each one
4103 -- of the components. The constructed image has the form of an indexed
4104 -- component, whose prefix is the outer variable of the array type.
4105 -- The n-dimensional array type has known indexes Index, Index2...
4107 -- Id_Ref is an indexed component form created by the enclosing init proc.
4108 -- Its successive indexes are Val1, Val2, ... which are the loop variables
4109 -- in the loops that call the individual task init proc on each component.
4111 -- The generated function has the following structure:
4113 -- function F return String is
4114 -- Pref : string renames Task_Name;
4115 -- T1 : String := Index1'Image (Val1);
4117 -- Tn : String := indexn'image (Valn);
4118 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
4119 -- -- Len includes commas and the end parentheses.
4120 -- Res : String (1..Len);
4121 -- Pos : Integer := Pref'Length;
4124 -- Res (1 .. Pos) := Pref;
4126 -- Res (Pos) := '(';
4128 -- Res (Pos .. Pos + T1'Length - 1) := T1;
4129 -- Pos := Pos + T1'Length;
4130 -- Res (Pos) := '.';
4133 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
4134 -- Res (Len) := ')';
4139 -- Needless to say, multidimensional arrays of tasks are rare enough that
4140 -- the bulkiness of this code is not really a concern.
4142 function Build_Task_Array_Image
4146 Dyn : Boolean := False) return Node_Id
4148 Dims : constant Nat := Number_Dimensions (A_Type);
4149 -- Number of dimensions for array of tasks
4151 Temps : array (1 .. Dims) of Entity_Id;
4152 -- Array of temporaries to hold string for each index
4158 -- Total length of generated name
4161 -- Running index for substring assignments
4163 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4164 -- Name of enclosing variable, prefix of resulting name
4167 -- String to hold result
4170 -- Value of successive indexes
4173 -- Expression to compute total size of string
4176 -- Entity for name at one index position
4178 Decls : constant List_Id := New_List;
4179 Stats : constant List_Id := New_List;
4182 -- For a dynamic task, the name comes from the target variable. For a
4183 -- static one it is a formal of the enclosing init proc.
4186 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4188 Make_Object_Declaration (Loc,
4189 Defining_Identifier => Pref,
4190 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4192 Make_String_Literal (Loc,
4193 Strval => String_From_Name_Buffer)));
4197 Make_Object_Renaming_Declaration (Loc,
4198 Defining_Identifier => Pref,
4199 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4200 Name => Make_Identifier (Loc, Name_uTask_Name)));
4203 Indx := First_Index (A_Type);
4204 Val := First (Expressions (Id_Ref));
4206 for J in 1 .. Dims loop
4207 T := Make_Temporary (Loc, 'T');
4211 Make_Object_Declaration (Loc,
4212 Defining_Identifier => T,
4213 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4215 Make_Attribute_Reference (Loc,
4216 Attribute_Name => Name_Image,
4217 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
4218 Expressions => New_List (New_Copy_Tree (Val)))));
4224 Sum := Make_Integer_Literal (Loc, Dims + 1);
4230 Make_Attribute_Reference (Loc,
4231 Attribute_Name => Name_Length,
4232 Prefix => New_Occurrence_Of (Pref, Loc),
4233 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4235 for J in 1 .. Dims loop
4240 Make_Attribute_Reference (Loc,
4241 Attribute_Name => Name_Length,
4243 New_Occurrence_Of (Temps (J), Loc),
4244 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4247 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4249 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
4252 Make_Assignment_Statement (Loc,
4254 Make_Indexed_Component (Loc,
4255 Prefix => New_Occurrence_Of (Res, Loc),
4256 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4258 Make_Character_Literal (Loc,
4260 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
4263 Make_Assignment_Statement (Loc,
4264 Name => New_Occurrence_Of (Pos, Loc),
4267 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4268 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4270 for J in 1 .. Dims loop
4273 Make_Assignment_Statement (Loc,
4276 Prefix => New_Occurrence_Of (Res, Loc),
4279 Low_Bound => New_Occurrence_Of (Pos, Loc),
4281 Make_Op_Subtract (Loc,
4284 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4286 Make_Attribute_Reference (Loc,
4287 Attribute_Name => Name_Length,
4289 New_Occurrence_Of (Temps (J), Loc),
4291 New_List (Make_Integer_Literal (Loc, 1)))),
4292 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
4294 Expression => New_Occurrence_Of (Temps (J), Loc)));
4298 Make_Assignment_Statement (Loc,
4299 Name => New_Occurrence_Of (Pos, Loc),
4302 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4304 Make_Attribute_Reference (Loc,
4305 Attribute_Name => Name_Length,
4306 Prefix => New_Occurrence_Of (Temps (J), Loc),
4308 New_List (Make_Integer_Literal (Loc, 1))))));
4310 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
4313 Make_Assignment_Statement (Loc,
4314 Name => Make_Indexed_Component (Loc,
4315 Prefix => New_Occurrence_Of (Res, Loc),
4316 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4318 Make_Character_Literal (Loc,
4320 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
4323 Make_Assignment_Statement (Loc,
4324 Name => New_Occurrence_Of (Pos, Loc),
4327 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4328 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4332 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
4335 Make_Assignment_Statement (Loc,
4337 Make_Indexed_Component (Loc,
4338 Prefix => New_Occurrence_Of (Res, Loc),
4339 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
4341 Make_Character_Literal (Loc,
4343 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
4344 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4345 end Build_Task_Array_Image;
4347 ----------------------------
4348 -- Build_Task_Image_Decls --
4349 ----------------------------
4351 function Build_Task_Image_Decls
4355 In_Init_Proc : Boolean := False) return List_Id
4357 Decls : constant List_Id := New_List;
4358 T_Id : Entity_Id := Empty;
4360 Expr : Node_Id := Empty;
4361 Fun : Node_Id := Empty;
4362 Is_Dyn : constant Boolean :=
4363 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
4365 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
4368 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
4369 -- generate a dummy declaration only.
4371 if Restriction_Active (No_Implicit_Heap_Allocations)
4372 or else Global_Discard_Names
4374 T_Id := Make_Temporary (Loc, 'J');
4379 Make_Object_Declaration (Loc,
4380 Defining_Identifier => T_Id,
4381 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4383 Make_String_Literal (Loc,
4384 Strval => String_From_Name_Buffer)));
4387 if Nkind (Id_Ref) = N_Identifier
4388 or else Nkind (Id_Ref) = N_Defining_Identifier
4390 -- For a simple variable, the image of the task is built from
4391 -- the name of the variable. To avoid possible conflict with the
4392 -- anonymous type created for a single protected object, add a
4396 Make_Defining_Identifier (Loc,
4397 New_External_Name (Chars (Id_Ref), 'T', 1));
4399 Get_Name_String (Chars (Id_Ref));
4402 Make_String_Literal (Loc,
4403 Strval => String_From_Name_Buffer);
4405 elsif Nkind (Id_Ref) = N_Selected_Component then
4407 Make_Defining_Identifier (Loc,
4408 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
4409 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
4411 elsif Nkind (Id_Ref) = N_Indexed_Component then
4413 Make_Defining_Identifier (Loc,
4414 New_External_Name (Chars (A_Type), 'N'));
4416 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
4420 if Present (Fun) then
4421 Append (Fun, Decls);
4422 Expr := Make_Function_Call (Loc,
4423 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
4425 if not In_Init_Proc then
4426 Set_Uses_Sec_Stack (Defining_Entity (Fun));
4430 Decl := Make_Object_Declaration (Loc,
4431 Defining_Identifier => T_Id,
4432 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4433 Constant_Present => True,
4434 Expression => Expr);
4436 Append (Decl, Decls);
4438 end Build_Task_Image_Decls;
4440 -------------------------------
4441 -- Build_Task_Image_Function --
4442 -------------------------------
4444 function Build_Task_Image_Function
4448 Res : Entity_Id) return Node_Id
4454 Make_Simple_Return_Statement (Loc,
4455 Expression => New_Occurrence_Of (Res, Loc)));
4457 Spec := Make_Function_Specification (Loc,
4458 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
4459 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
4461 -- Calls to 'Image use the secondary stack, which must be cleaned up
4462 -- after the task name is built.
4464 return Make_Subprogram_Body (Loc,
4465 Specification => Spec,
4466 Declarations => Decls,
4467 Handled_Statement_Sequence =>
4468 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
4469 end Build_Task_Image_Function;
4471 -----------------------------
4472 -- Build_Task_Image_Prefix --
4473 -----------------------------
4475 procedure Build_Task_Image_Prefix
4477 Len : out Entity_Id;
4478 Res : out Entity_Id;
4479 Pos : out Entity_Id;
4486 Len := Make_Temporary (Loc, 'L', Sum);
4489 Make_Object_Declaration (Loc,
4490 Defining_Identifier => Len,
4491 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4492 Expression => Sum));
4494 Res := Make_Temporary (Loc, 'R');
4497 Make_Object_Declaration (Loc,
4498 Defining_Identifier => Res,
4499 Object_Definition =>
4500 Make_Subtype_Indication (Loc,
4501 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4503 Make_Index_Or_Discriminant_Constraint (Loc,
4507 Low_Bound => Make_Integer_Literal (Loc, 1),
4508 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4510 -- Indicate that the result is an internal temporary, so it does not
4511 -- receive a bogus initialization when declaration is expanded. This
4512 -- is both efficient, and prevents anomalies in the handling of
4513 -- dynamic objects on the secondary stack.
4515 Set_Is_Internal (Res);
4516 Pos := Make_Temporary (Loc, 'P');
4519 Make_Object_Declaration (Loc,
4520 Defining_Identifier => Pos,
4521 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4523 -- Pos := Prefix'Length;
4526 Make_Assignment_Statement (Loc,
4527 Name => New_Occurrence_Of (Pos, Loc),
4529 Make_Attribute_Reference (Loc,
4530 Attribute_Name => Name_Length,
4531 Prefix => New_Occurrence_Of (Prefix, Loc),
4532 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4534 -- Res (1 .. Pos) := Prefix;
4537 Make_Assignment_Statement (Loc,
4540 Prefix => New_Occurrence_Of (Res, Loc),
4543 Low_Bound => Make_Integer_Literal (Loc, 1),
4544 High_Bound => New_Occurrence_Of (Pos, Loc))),
4546 Expression => New_Occurrence_Of (Prefix, Loc)));
4549 Make_Assignment_Statement (Loc,
4550 Name => New_Occurrence_Of (Pos, Loc),
4553 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4554 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4555 end Build_Task_Image_Prefix;
4557 -----------------------------
4558 -- Build_Task_Record_Image --
4559 -----------------------------
4561 function Build_Task_Record_Image
4564 Dyn : Boolean := False) return Node_Id
4567 -- Total length of generated name
4570 -- Index into result
4573 -- String to hold result
4575 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4576 -- Name of enclosing variable, prefix of resulting name
4579 -- Expression to compute total size of string
4582 -- Entity for selector name
4584 Decls : constant List_Id := New_List;
4585 Stats : constant List_Id := New_List;
4588 -- For a dynamic task, the name comes from the target variable. For a
4589 -- static one it is a formal of the enclosing init proc.
4592 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4594 Make_Object_Declaration (Loc,
4595 Defining_Identifier => Pref,
4596 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4598 Make_String_Literal (Loc,
4599 Strval => String_From_Name_Buffer)));
4603 Make_Object_Renaming_Declaration (Loc,
4604 Defining_Identifier => Pref,
4605 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4606 Name => Make_Identifier (Loc, Name_uTask_Name)));
4609 Sel := Make_Temporary (Loc, 'S');
4611 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4614 Make_Object_Declaration (Loc,
4615 Defining_Identifier => Sel,
4616 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4618 Make_String_Literal (Loc,
4619 Strval => String_From_Name_Buffer)));
4621 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4627 Make_Attribute_Reference (Loc,
4628 Attribute_Name => Name_Length,
4630 New_Occurrence_Of (Pref, Loc),
4631 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4633 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4635 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
4637 -- Res (Pos) := '.';
4640 Make_Assignment_Statement (Loc,
4641 Name => Make_Indexed_Component (Loc,
4642 Prefix => New_Occurrence_Of (Res, Loc),
4643 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4645 Make_Character_Literal (Loc,
4647 Char_Literal_Value =>
4648 UI_From_Int (Character'Pos ('.')))));
4651 Make_Assignment_Statement (Loc,
4652 Name => New_Occurrence_Of (Pos, Loc),
4655 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4656 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4658 -- Res (Pos .. Len) := Selector;
4661 Make_Assignment_Statement (Loc,
4662 Name => Make_Slice (Loc,
4663 Prefix => New_Occurrence_Of (Res, Loc),
4666 Low_Bound => New_Occurrence_Of (Pos, Loc),
4667 High_Bound => New_Occurrence_Of (Len, Loc))),
4668 Expression => New_Occurrence_Of (Sel, Loc)));
4670 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4671 end Build_Task_Record_Image;
4673 ---------------------------------------
4674 -- Build_Transient_Object_Statements --
4675 ---------------------------------------
4677 procedure Build_Transient_Object_Statements
4678 (Obj_Decl : Node_Id;
4679 Fin_Call : out Node_Id;
4680 Hook_Assign : out Node_Id;
4681 Hook_Clear : out Node_Id;
4682 Hook_Decl : out Node_Id;
4683 Ptr_Decl : out Node_Id;
4684 Finalize_Obj : Boolean := True)
4686 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4687 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4688 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4690 Desig_Typ : Entity_Id;
4691 Hook_Expr : Node_Id;
4692 Hook_Id : Entity_Id;
4694 Ptr_Typ : Entity_Id;
4697 -- Recover the type of the object
4699 Desig_Typ := Obj_Typ;
4701 if Is_Access_Type (Desig_Typ) then
4702 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4705 -- Create an access type which provides a reference to the transient
4706 -- object. Generate:
4708 -- type Ptr_Typ is access all Desig_Typ;
4710 Ptr_Typ := Make_Temporary (Loc, 'A');
4711 Mutate_Ekind (Ptr_Typ, E_General_Access_Type);
4712 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4715 Make_Full_Type_Declaration (Loc,
4716 Defining_Identifier => Ptr_Typ,
4718 Make_Access_To_Object_Definition (Loc,
4719 All_Present => True,
4720 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4722 -- Create a temporary check which acts as a hook to the transient
4723 -- object. Generate:
4725 -- Hook : Ptr_Typ := null;
4727 Hook_Id := Make_Temporary (Loc, 'T');
4728 Mutate_Ekind (Hook_Id, E_Variable);
4729 Set_Etype (Hook_Id, Ptr_Typ);
4732 Make_Object_Declaration (Loc,
4733 Defining_Identifier => Hook_Id,
4734 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4735 Expression => Make_Null (Loc));
4737 -- Mark the temporary as a hook. This signals the machinery in
4738 -- Build_Finalizer to recognize this special case.
4740 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4742 -- Hook the transient object to the temporary. Generate:
4744 -- Hook := Ptr_Typ (Obj_Id);
4746 -- Hool := Obj_Id'Unrestricted_Access;
4748 if Is_Access_Type (Obj_Typ) then
4750 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4753 Make_Attribute_Reference (Loc,
4754 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4755 Attribute_Name => Name_Unrestricted_Access);
4759 Make_Assignment_Statement (Loc,
4760 Name => New_Occurrence_Of (Hook_Id, Loc),
4761 Expression => Hook_Expr);
4763 -- Crear the hook prior to finalizing the object. Generate:
4768 Make_Assignment_Statement (Loc,
4769 Name => New_Occurrence_Of (Hook_Id, Loc),
4770 Expression => Make_Null (Loc));
4772 -- Finalize the object. Generate:
4774 -- [Deep_]Finalize (Obj_Ref[.all]);
4776 if Finalize_Obj then
4777 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4779 if Is_Access_Type (Obj_Typ) then
4780 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4781 Set_Etype (Obj_Ref, Desig_Typ);
4786 (Obj_Ref => Obj_Ref,
4789 -- Otherwise finalize the hook. Generate:
4791 -- [Deep_]Finalize (Hook.all);
4797 Make_Explicit_Dereference (Loc,
4798 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4801 end Build_Transient_Object_Statements;
4803 -----------------------------
4804 -- Check_Float_Op_Overflow --
4805 -----------------------------
4807 procedure Check_Float_Op_Overflow (N : Node_Id) is
4809 -- Return if no check needed
4811 if not Is_Floating_Point_Type (Etype (N))
4812 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4814 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4815 -- and do not expand the code for float overflow checking.
4817 or else CodePeer_Mode
4822 -- Otherwise we replace the expression by
4824 -- do Tnn : constant ftype := expression;
4825 -- constraint_error when not Tnn'Valid;
4829 Loc : constant Source_Ptr := Sloc (N);
4830 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4831 Typ : constant Entity_Id := Etype (N);
4834 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4835 -- right here. We also set the node as analyzed to prevent infinite
4836 -- recursion from repeating the operation in the expansion.
4838 Set_Do_Overflow_Check (N, False);
4839 Set_Analyzed (N, True);
4841 -- Do the rewrite to include the check
4844 Make_Expression_With_Actions (Loc,
4845 Actions => New_List (
4846 Make_Object_Declaration (Loc,
4847 Defining_Identifier => Tnn,
4848 Object_Definition => New_Occurrence_Of (Typ, Loc),
4849 Constant_Present => True,
4850 Expression => Relocate_Node (N)),
4851 Make_Raise_Constraint_Error (Loc,
4855 Make_Attribute_Reference (Loc,
4856 Prefix => New_Occurrence_Of (Tnn, Loc),
4857 Attribute_Name => Name_Valid)),
4858 Reason => CE_Overflow_Check_Failed)),
4859 Expression => New_Occurrence_Of (Tnn, Loc)));
4861 Analyze_And_Resolve (N, Typ);
4863 end Check_Float_Op_Overflow;
4865 ----------------------------------
4866 -- Component_May_Be_Bit_Aligned --
4867 ----------------------------------
4869 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4873 -- If no component clause, then everything is fine, since the back end
4874 -- never misaligns from byte boundaries by default, even if there is a
4875 -- pragma Pack for the record.
4877 if No (Comp) or else No (Component_Clause (Comp)) then
4881 UT := Underlying_Type (Etype (Comp));
4883 -- It is only array and record types that cause trouble
4885 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4888 -- If we know that we have a small (at most the maximum integer size)
4889 -- record or bit-packed array, then everything is fine, since the back
4890 -- end can handle these cases correctly.
4892 elsif Esize (Comp) <= System_Max_Integer_Size
4893 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4897 -- Otherwise if the component is not byte aligned, we know we have the
4898 -- nasty unaligned case.
4900 elsif Normalized_First_Bit (Comp) /= Uint_0
4901 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4905 -- If we are large and byte aligned, then OK at this level
4910 end Component_May_Be_Bit_Aligned;
4912 -------------------------------
4913 -- Convert_To_Actual_Subtype --
4914 -------------------------------
4916 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
4920 Act_ST := Get_Actual_Subtype (Exp);
4922 if Act_ST = Etype (Exp) then
4925 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4926 Analyze_And_Resolve (Exp, Act_ST);
4928 end Convert_To_Actual_Subtype;
4930 -----------------------------------
4931 -- Corresponding_Runtime_Package --
4932 -----------------------------------
4934 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4935 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4936 -- Return True if protected type T has one entry and the maximum queue
4939 --------------------------------
4940 -- Has_One_Entry_And_No_Queue --
4941 --------------------------------
4943 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4945 Is_First : Boolean := True;
4948 Item := First_Entity (T);
4949 while Present (Item) loop
4950 if Is_Entry (Item) then
4952 -- The protected type has more than one entry
4954 if not Is_First then
4958 -- The queue length is not one
4960 if not Restriction_Active (No_Entry_Queue)
4961 and then Get_Max_Queue_Length (Item) /= Uint_1
4973 end Has_One_Entry_And_No_Queue;
4977 Pkg_Id : RTU_Id := RTU_Null;
4979 -- Start of processing for Corresponding_Runtime_Package
4982 pragma Assert (Is_Concurrent_Type (Typ));
4984 if Is_Protected_Type (Typ) then
4985 if Has_Entries (Typ)
4987 -- A protected type without entries that covers an interface and
4988 -- overrides the abstract routines with protected procedures is
4989 -- considered equivalent to a protected type with entries in the
4990 -- context of dispatching select statements. It is sufficient to
4991 -- check for the presence of an interface list in the declaration
4992 -- node to recognize this case.
4994 or else Present (Interface_List (Parent (Typ)))
4996 -- Protected types with interrupt handlers (when not using a
4997 -- restricted profile) are also considered equivalent to
4998 -- protected types with entries. The types which are used
4999 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
5000 -- are derived from Protection_Entries.
5002 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
5003 or else Has_Interrupt_Handler (Typ)
5006 or else Restriction_Active (No_Select_Statements) = False
5007 or else not Has_One_Entry_And_No_Queue (Typ)
5008 or else (Has_Attach_Handler (Typ)
5009 and then not Restricted_Profile)
5011 Pkg_Id := System_Tasking_Protected_Objects_Entries;
5013 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
5017 Pkg_Id := System_Tasking_Protected_Objects;
5022 end Corresponding_Runtime_Package;
5024 -----------------------------------
5025 -- Current_Sem_Unit_Declarations --
5026 -----------------------------------
5028 function Current_Sem_Unit_Declarations return List_Id is
5029 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
5033 -- If the current unit is a package body, locate the visible
5034 -- declarations of the package spec.
5036 if Nkind (U) = N_Package_Body then
5037 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
5040 if Nkind (U) = N_Package_Declaration then
5041 U := Specification (U);
5042 Decls := Visible_Declarations (U);
5046 Set_Visible_Declarations (U, Decls);
5050 Decls := Declarations (U);
5054 Set_Declarations (U, Decls);
5059 end Current_Sem_Unit_Declarations;
5061 -----------------------
5062 -- Duplicate_Subexpr --
5063 -----------------------
5065 function Duplicate_Subexpr
5067 Name_Req : Boolean := False;
5068 Renaming_Req : Boolean := False) return Node_Id
5071 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
5072 return New_Copy_Tree (Exp);
5073 end Duplicate_Subexpr;
5075 ---------------------------------
5076 -- Duplicate_Subexpr_No_Checks --
5077 ---------------------------------
5079 function Duplicate_Subexpr_No_Checks
5081 Name_Req : Boolean := False;
5082 Renaming_Req : Boolean := False;
5083 Related_Id : Entity_Id := Empty;
5084 Is_Low_Bound : Boolean := False;
5085 Is_High_Bound : Boolean := False) return Node_Id
5092 Name_Req => Name_Req,
5093 Renaming_Req => Renaming_Req,
5094 Related_Id => Related_Id,
5095 Is_Low_Bound => Is_Low_Bound,
5096 Is_High_Bound => Is_High_Bound);
5098 New_Exp := New_Copy_Tree (Exp);
5099 Remove_Checks (New_Exp);
5101 end Duplicate_Subexpr_No_Checks;
5103 -----------------------------------
5104 -- Duplicate_Subexpr_Move_Checks --
5105 -----------------------------------
5107 function Duplicate_Subexpr_Move_Checks
5109 Name_Req : Boolean := False;
5110 Renaming_Req : Boolean := False) return Node_Id
5115 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
5116 New_Exp := New_Copy_Tree (Exp);
5117 Remove_Checks (Exp);
5119 end Duplicate_Subexpr_Move_Checks;
5121 -------------------------
5122 -- Enclosing_Init_Proc --
5123 -------------------------
5125 function Enclosing_Init_Proc return Entity_Id is
5130 while Present (S) and then S /= Standard_Standard loop
5131 if Is_Init_Proc (S) then
5139 end Enclosing_Init_Proc;
5141 --------------------
5142 -- Ensure_Defined --
5143 --------------------
5145 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
5149 -- An itype reference must only be created if this is a local itype, so
5150 -- that gigi can elaborate it on the proper objstack.
5152 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
5153 IR := Make_Itype_Reference (Sloc (N));
5154 Set_Itype (IR, Typ);
5155 Insert_Action (N, IR);
5159 --------------------
5160 -- Entry_Names_OK --
5161 --------------------
5163 function Entry_Names_OK return Boolean is
5166 not Restricted_Profile
5167 and then not Global_Discard_Names
5168 and then not Restriction_Active (No_Implicit_Heap_Allocations)
5169 and then not Restriction_Active (No_Local_Allocators);
5176 procedure Evaluate_Name (Nam : Node_Id) is
5179 -- For an aggregate, force its evaluation
5182 Force_Evaluation (Nam);
5184 -- For an attribute reference or an indexed component, evaluate the
5185 -- prefix, which is itself a name, recursively, and then force the
5186 -- evaluation of all the subscripts (or attribute expressions).
5188 when N_Attribute_Reference
5189 | N_Indexed_Component
5191 Evaluate_Name (Prefix (Nam));
5197 E := First (Expressions (Nam));
5198 while Present (E) loop
5199 Force_Evaluation (E);
5201 if Is_Rewrite_Substitution (E) then
5203 (E, Do_Range_Check (Original_Node (E)));
5210 -- For an explicit dereference, we simply force the evaluation of
5211 -- the name expression. The dereference provides a value that is the
5212 -- address for the renamed object, and it is precisely this value
5213 -- that we want to preserve.
5215 when N_Explicit_Dereference =>
5216 Force_Evaluation (Prefix (Nam));
5218 -- For a function call, we evaluate the call; same for an operator
5220 when N_Function_Call
5223 Force_Evaluation (Nam);
5225 -- For a qualified expression, we evaluate the expression
5227 when N_Qualified_Expression =>
5228 Evaluate_Name (Expression (Nam));
5230 -- For a selected component, we simply evaluate the prefix
5232 when N_Selected_Component =>
5233 Evaluate_Name (Prefix (Nam));
5235 -- For a slice, we evaluate the prefix, as for the indexed component
5236 -- case and then, if there is a range present, either directly or as
5237 -- the constraint of a discrete subtype indication, we evaluate the
5238 -- two bounds of this range.
5241 Evaluate_Name (Prefix (Nam));
5242 Evaluate_Slice_Bounds (Nam);
5244 -- For a type conversion, the expression of the conversion must be
5245 -- the name of an object, and we simply need to evaluate this name.
5247 when N_Type_Conversion =>
5248 Evaluate_Name (Expression (Nam));
5250 -- The remaining cases are direct name and character literal. In all
5251 -- these cases, we do nothing, since we want to reevaluate each time
5252 -- the renamed object is used. ??? There are more remaining cases, at
5253 -- least in the GNATprove_Mode, where this routine is called in more
5254 -- contexts than in GNAT.
5261 ---------------------------
5262 -- Evaluate_Slice_Bounds --
5263 ---------------------------
5265 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
5266 DR : constant Node_Id := Discrete_Range (Slice);
5271 if Nkind (DR) = N_Range then
5272 Force_Evaluation (Low_Bound (DR));
5273 Force_Evaluation (High_Bound (DR));
5275 elsif Nkind (DR) = N_Subtype_Indication then
5276 Constr := Constraint (DR);
5278 if Nkind (Constr) = N_Range_Constraint then
5279 Rexpr := Range_Expression (Constr);
5281 Force_Evaluation (Low_Bound (Rexpr));
5282 Force_Evaluation (High_Bound (Rexpr));
5285 end Evaluate_Slice_Bounds;
5287 ---------------------
5288 -- Evolve_And_Then --
5289 ---------------------
5291 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
5297 Make_And_Then (Sloc (Cond1),
5299 Right_Opnd => Cond1);
5301 end Evolve_And_Then;
5303 --------------------
5304 -- Evolve_Or_Else --
5305 --------------------
5307 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
5313 Make_Or_Else (Sloc (Cond1),
5315 Right_Opnd => Cond1);
5319 -------------------------------
5320 -- Expand_Sliding_Conversion --
5321 -------------------------------
5323 procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id) is
5325 pragma Assert (Is_Array_Type (Arr_Typ)
5326 and then not Is_Constrained (Arr_Typ)
5327 and then Is_Fixed_Lower_Bound_Array_Subtype (Arr_Typ));
5329 Constraints : List_Id;
5330 Index : Node_Id := First_Index (Arr_Typ);
5331 Loc : constant Source_Ptr := Sloc (N);
5332 Subt_Decl : Node_Id;
5335 Subt_High : Node_Id;
5337 Act_Subt : Entity_Id;
5338 Act_Index : Node_Id;
5341 Adjust_Incr : Node_Id;
5342 Dimension : Int := 0;
5343 All_FLBs_Match : Boolean := True;
5346 -- This procedure is called during semantic analysis, and we only expand
5347 -- a sliding conversion when Expander_Active, to avoid doing it during
5348 -- preanalysis (which can lead to problems with the target subtype not
5349 -- getting properly expanded during later full analysis). Also, sliding
5350 -- should never be needed for string literals, because their bounds are
5351 -- determined directly based on the fixed lower bound of Arr_Typ and
5354 if Expander_Active and then Nkind (N) /= N_String_Literal then
5355 Constraints := New_List;
5357 Act_Subt := Get_Actual_Subtype (N);
5358 Act_Index := First_Index (Act_Subt);
5360 -- Loop over the indexes of the fixed-lower-bound array type or
5361 -- subtype to build up an index constraint for constructing the
5362 -- subtype that will be the target of a conversion of the array
5363 -- object that may need a sliding conversion.
5365 while Present (Index) loop
5366 pragma Assert (Present (Act_Index));
5368 Dimension := Dimension + 1;
5370 Get_Index_Bounds (Act_Index, Act_Low, Act_High);
5372 -- If Index defines a normal unconstrained range (range <>),
5373 -- then we will simply use the bounds of the actual subtype's
5374 -- corresponding index range.
5376 if not Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) then
5377 Subt_Low := Act_Low;
5378 Subt_High := Act_High;
5380 -- Otherwise, a range will be created with a low bound given by
5381 -- the fixed lower bound of the array subtype's index, and with
5382 -- high bound given by (Actual'Length + fixed lower bound - 1).
5385 if Nkind (Index) = N_Subtype_Indication then
5388 (Low_Bound (Range_Expression (Constraint (Index))));
5390 pragma Assert (Nkind (Index) = N_Range);
5392 Subt_Low := New_Copy_Tree (Low_Bound (Index));
5395 -- If either we have a nonstatic lower bound, or the target and
5396 -- source subtypes are statically known to have unequal lower
5397 -- bounds, then we will need to make a subtype conversion to
5398 -- slide the bounds. However, if all of the indexes' lower
5399 -- bounds are static and known to be equal (the common case),
5400 -- then no conversion will be needed, and we'll end up not
5401 -- creating the subtype or the conversion (though we still
5402 -- build up the index constraint, which will simply be unused).
5404 if not (Compile_Time_Known_Value (Subt_Low)
5405 and then Compile_Time_Known_Value (Act_Low))
5406 or else Expr_Value (Subt_Low) /= Expr_Value (Act_Low)
5408 All_FLBs_Match := False;
5411 -- Apply 'Pos to lower bound, which may be of an enumeration
5412 -- type, before subtracting.
5415 Make_Op_Subtract (Loc,
5416 Make_Attribute_Reference (Loc,
5418 New_Occurrence_Of (Etype (Act_Index), Loc),
5422 New_List (New_Copy_Tree (Subt_Low))),
5423 Make_Integer_Literal (Loc, 1));
5425 -- Apply 'Val to the result of adding the increment to the
5426 -- length, to handle indexes of enumeration types.
5429 Make_Attribute_Reference (Loc,
5431 New_Occurrence_Of (Etype (Act_Index), Loc),
5435 New_List (Make_Op_Add (Loc,
5436 Make_Attribute_Reference (Loc,
5438 New_Occurrence_Of (Act_Subt, Loc),
5443 (Make_Integer_Literal
5448 Append (Make_Range (Loc, Subt_Low, Subt_High), Constraints);
5454 -- If for each index with a fixed lower bound (FLB), the lower bound
5455 -- of the corresponding index of the actual subtype is statically
5456 -- known be equal to the FLB, then a sliding conversion isn't needed
5457 -- at all, so just return without building a subtype or conversion.
5459 if All_FLBs_Match then
5463 -- A sliding conversion is needed, so create the target subtype using
5464 -- the index constraint created above, and rewrite the expression
5465 -- as a conversion to that subtype.
5467 Subt := Make_Temporary (Loc, 'S', Related_Node => N);
5468 Set_Is_Internal (Subt);
5471 Make_Subtype_Declaration (Loc,
5472 Defining_Identifier => Subt,
5473 Subtype_Indication =>
5474 Make_Subtype_Indication (Loc,
5476 New_Occurrence_Of (Arr_Typ, Loc),
5478 Make_Index_Or_Discriminant_Constraint (Loc,
5479 Constraints => Constraints)));
5481 Mark_Rewrite_Insertion (Subt_Decl);
5483 -- The actual subtype is an Itype, so we analyze the declaration,
5484 -- but do not attach it to the tree.
5486 Set_Parent (Subt_Decl, N);
5487 Set_Is_Itype (Subt);
5488 Analyze (Subt_Decl, Suppress => All_Checks);
5489 Set_Associated_Node_For_Itype (Subt, N);
5490 Set_Has_Delayed_Freeze (Subt, False);
5492 -- We need to freeze the actual subtype immediately. This is needed
5493 -- because otherwise this Itype will not get frozen at all, and it is
5494 -- always safe to freeze on creation because any associated types
5495 -- must be frozen at this point.
5497 Freeze_Itype (Subt, N);
5500 Make_Type_Conversion (Loc,
5502 New_Occurrence_Of (Subt, Loc),
5503 Expression => Relocate_Node (N)));
5506 end Expand_Sliding_Conversion;
5508 -----------------------------------------
5509 -- Expand_Static_Predicates_In_Choices --
5510 -----------------------------------------
5512 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
5513 pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
5515 Choices : List_Id := Discrete_Choices (N);
5523 -- If this is an "others" alternative, we need to process any static
5524 -- predicates in its Others_Discrete_Choices.
5526 if Nkind (First (Choices)) = N_Others_Choice then
5527 Choices := Others_Discrete_Choices (First (Choices));
5530 Choice := First (Choices);
5531 while Present (Choice) loop
5532 Next_C := Next (Choice);
5534 -- Check for name of subtype with static predicate
5536 if Is_Entity_Name (Choice)
5537 and then Is_Type (Entity (Choice))
5538 and then Has_Predicates (Entity (Choice))
5540 -- Loop through entries in predicate list, converting to choices
5541 -- and inserting in the list before the current choice. Note that
5542 -- if the list is empty, corresponding to a False predicate, then
5543 -- no choices are inserted.
5545 P := First (Static_Discrete_Predicate (Entity (Choice)));
5546 while Present (P) loop
5548 -- If low bound and high bounds are equal, copy simple choice
5550 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
5551 C := New_Copy (Low_Bound (P));
5553 -- Otherwise copy a range
5559 -- Change Sloc to referencing choice (rather than the Sloc of
5560 -- the predicate declaration element itself).
5562 Set_Sloc (C, Sloc (Choice));
5563 Insert_Before (Choice, C);
5567 -- Delete the predicated entry
5572 -- Move to next choice to check
5577 Set_Has_SP_Choice (N, False);
5578 end Expand_Static_Predicates_In_Choices;
5580 ------------------------------
5581 -- Expand_Subtype_From_Expr --
5582 ------------------------------
5584 -- This function is applicable for both static and dynamic allocation of
5585 -- objects which are constrained by an initial expression. Basically it
5586 -- transforms an unconstrained subtype indication into a constrained one.
5588 -- The expression may also be transformed in certain cases in order to
5589 -- avoid multiple evaluation. In the static allocation case, the general
5594 -- is transformed into
5596 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
5598 -- Here are the main cases :
5600 -- <if Expr is a Slice>
5601 -- Val : T ([Index_Subtype (Expr)]) := Expr;
5603 -- <elsif Expr is a String Literal>
5604 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
5606 -- <elsif Expr is Constrained>
5607 -- subtype T is Type_Of_Expr
5610 -- <elsif Expr is an entity_name>
5611 -- Val : T (constraints taken from Expr) := Expr;
5614 -- type Axxx is access all T;
5615 -- Rval : Axxx := Expr'ref;
5616 -- Val : T (constraints taken from Rval) := Rval.all;
5618 -- ??? note: when the Expression is allocated in the secondary stack
5619 -- we could use it directly instead of copying it by declaring
5620 -- Val : T (...) renames Rval.all
5622 procedure Expand_Subtype_From_Expr
5624 Unc_Type : Entity_Id;
5625 Subtype_Indic : Node_Id;
5627 Related_Id : Entity_Id := Empty)
5629 Loc : constant Source_Ptr := Sloc (N);
5630 Exp_Typ : constant Entity_Id := Etype (Exp);
5634 -- In general we cannot build the subtype if expansion is disabled,
5635 -- because internal entities may not have been defined. However, to
5636 -- avoid some cascaded errors, we try to continue when the expression is
5637 -- an array (or string), because it is safe to compute the bounds. It is
5638 -- in fact required to do so even in a generic context, because there
5639 -- may be constants that depend on the bounds of a string literal, both
5640 -- standard string types and more generally arrays of characters.
5642 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is
5643 -- a static expression. In that case, the subtype will be constrained
5644 -- while the original type might be unconstrained, so expanding the type
5645 -- is necessary both for passing legality checks in GNAT and for precise
5646 -- analysis in GNATprove.
5648 if GNATprove_Mode and then not Is_Static_Expression (Exp) then
5652 if not Expander_Active
5653 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5658 if Nkind (Exp) = N_Slice then
5660 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5663 Rewrite (Subtype_Indic,
5664 Make_Subtype_Indication (Loc,
5665 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5667 Make_Index_Or_Discriminant_Constraint (Loc,
5668 Constraints => New_List
5669 (New_Occurrence_Of (Slice_Type, Loc)))));
5671 -- This subtype indication may be used later for constraint checks
5672 -- we better make sure that if a variable was used as a bound of
5673 -- the original slice, its value is frozen.
5675 Evaluate_Slice_Bounds (Exp);
5678 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5679 Rewrite (Subtype_Indic,
5680 Make_Subtype_Indication (Loc,
5681 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5683 Make_Index_Or_Discriminant_Constraint (Loc,
5684 Constraints => New_List (
5685 Make_Literal_Range (Loc,
5686 Literal_Typ => Exp_Typ)))));
5688 -- If the type of the expression is an internally generated type it
5689 -- may not be necessary to create a new subtype. However there are two
5690 -- exceptions: references to the current instances, and aliased array
5691 -- object declarations for which the back end has to create a template.
5693 elsif Is_Constrained (Exp_Typ)
5694 and then not Is_Class_Wide_Type (Unc_Type)
5696 (Nkind (N) /= N_Object_Declaration
5697 or else not Is_Entity_Name (Expression (N))
5698 or else not Comes_From_Source (Entity (Expression (N)))
5699 or else not Is_Array_Type (Exp_Typ)
5700 or else not Aliased_Present (N))
5702 if Is_Itype (Exp_Typ) then
5704 -- Within an initialization procedure, a selected component
5705 -- denotes a component of the enclosing record, and it appears as
5706 -- an actual in a call to its own initialization procedure. If
5707 -- this component depends on the outer discriminant, we must
5708 -- generate the proper actual subtype for it.
5710 if Nkind (Exp) = N_Selected_Component
5711 and then Within_Init_Proc
5714 Decl : constant Node_Id :=
5715 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5717 if Present (Decl) then
5718 Insert_Action (N, Decl);
5719 T := Defining_Identifier (Decl);
5725 -- No need to generate a new subtype
5732 T := Make_Temporary (Loc, 'T');
5735 Make_Subtype_Declaration (Loc,
5736 Defining_Identifier => T,
5737 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5739 -- This type is marked as an itype even though it has an explicit
5740 -- declaration since otherwise Is_Generic_Actual_Type can get
5741 -- set, resulting in the generation of spurious errors. (See
5742 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5745 Set_Associated_Node_For_Itype (T, Exp);
5748 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5750 -- Nothing needs to be done for private types with unknown discriminants
5751 -- if the underlying type is not an unconstrained composite type or it
5752 -- is an unchecked union.
5754 elsif Is_Private_Type (Unc_Type)
5755 and then Has_Unknown_Discriminants (Unc_Type)
5756 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5757 or else Is_Constrained (Underlying_Type (Unc_Type))
5758 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5762 -- Case of derived type with unknown discriminants where the parent type
5763 -- also has unknown discriminants.
5765 elsif Is_Record_Type (Unc_Type)
5766 and then not Is_Class_Wide_Type (Unc_Type)
5767 and then Has_Unknown_Discriminants (Unc_Type)
5768 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5770 -- Nothing to be done if no underlying record view available
5772 -- If this is a limited type derived from a type with unknown
5773 -- discriminants, do not expand either, so that subsequent expansion
5774 -- of the call can add build-in-place parameters to call.
5776 if No (Underlying_Record_View (Unc_Type))
5777 or else Is_Limited_Type (Unc_Type)
5781 -- Otherwise use the Underlying_Record_View to create the proper
5782 -- constrained subtype for an object of a derived type with unknown
5786 Remove_Side_Effects (Exp);
5787 Rewrite (Subtype_Indic,
5788 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5791 -- Renamings of class-wide interface types require no equivalent
5792 -- constrained type declarations because we only need to reference
5793 -- the tag component associated with the interface. The same is
5794 -- presumably true for class-wide types in general, so this test
5795 -- is broadened to include all class-wide renamings, which also
5796 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5797 -- (Is this really correct, or are there some cases of class-wide
5798 -- renamings that require action in this procedure???)
5801 and then Nkind (N) = N_Object_Renaming_Declaration
5802 and then Is_Class_Wide_Type (Unc_Type)
5806 -- In Ada 95 nothing to be done if the type of the expression is limited
5807 -- because in this case the expression cannot be copied, and its use can
5808 -- only be by reference.
5810 -- In Ada 2005 the context can be an object declaration whose expression
5811 -- is a function that returns in place. If the nominal subtype has
5812 -- unknown discriminants, the call still provides constraints on the
5813 -- object, and we have to create an actual subtype from it.
5815 -- If the type is class-wide, the expression is dynamically tagged and
5816 -- we do not create an actual subtype either. Ditto for an interface.
5817 -- For now this applies only if the type is immutably limited, and the
5818 -- function being called is build-in-place. This will have to be revised
5819 -- when build-in-place functions are generalized to other types.
5821 elsif Is_Limited_View (Exp_Typ)
5823 (Is_Class_Wide_Type (Exp_Typ)
5824 or else Is_Interface (Exp_Typ)
5825 or else not Has_Unknown_Discriminants (Exp_Typ)
5826 or else not Is_Composite_Type (Unc_Type))
5830 -- For limited objects initialized with build-in-place function calls,
5831 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5832 -- node in the expression initializing the object, which breaks the
5833 -- circuitry that detects and adds the additional arguments to the
5836 elsif Is_Build_In_Place_Function_Call (Exp) then
5839 -- If the expression is an uninitialized aggregate, no need to build
5840 -- a subtype from the expression, because this may require the use of
5841 -- dynamic memory to create the object.
5843 elsif Is_Uninitialized_Aggregate (Exp, Exp_Typ) then
5844 Rewrite (Subtype_Indic, New_Occurrence_Of (Etype (Exp), Sloc (N)));
5845 if Nkind (N) = N_Object_Declaration then
5846 Set_Expression (N, Empty);
5847 Set_No_Initialization (N);
5851 Remove_Side_Effects (Exp);
5852 Rewrite (Subtype_Indic,
5853 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5855 end Expand_Subtype_From_Expr;
5857 ---------------------------------------------
5858 -- Expression_Contains_Primitives_Calls_Of --
5859 ---------------------------------------------
5861 function Expression_Contains_Primitives_Calls_Of
5863 Typ : Entity_Id) return Boolean
5865 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5867 Calls_OK : Boolean := False;
5868 -- This flag is set to True when expression Expr contains at least one
5869 -- call to a nondispatching primitive function of Typ.
5871 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5872 -- Search for nondispatching calls to primitive functions of type Typ
5874 ----------------------------
5875 -- Search_Primitive_Calls --
5876 ----------------------------
5878 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5879 Disp_Typ : Entity_Id;
5883 -- Detect a function call that could denote a nondispatching
5884 -- primitive of the input type.
5886 if Nkind (N) = N_Function_Call
5887 and then Is_Entity_Name (Name (N))
5889 Subp := Entity (Name (N));
5891 -- Do not consider function calls with a controlling argument, as
5892 -- those are always dispatching calls.
5894 if Is_Dispatching_Operation (Subp)
5895 and then No (Controlling_Argument (N))
5897 Disp_Typ := Find_Dispatching_Type (Subp);
5899 -- To qualify as a suitable primitive, the dispatching type of
5900 -- the function must be the input type.
5902 if Present (Disp_Typ)
5903 and then Unique_Entity (Disp_Typ) = U_Typ
5907 -- There is no need to continue the traversal, as one such
5916 end Search_Primitive_Calls;
5918 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5920 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5923 Search_Calls (Expr);
5925 end Expression_Contains_Primitives_Calls_Of;
5927 ----------------------
5928 -- Finalize_Address --
5929 ----------------------
5931 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5932 Btyp : constant Entity_Id := Base_Type (Typ);
5933 Utyp : Entity_Id := Typ;
5936 -- Handle protected class-wide or task class-wide types
5938 if Is_Class_Wide_Type (Utyp) then
5939 if Is_Concurrent_Type (Root_Type (Utyp)) then
5940 Utyp := Root_Type (Utyp);
5942 elsif Is_Private_Type (Root_Type (Utyp))
5943 and then Present (Full_View (Root_Type (Utyp)))
5944 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5946 Utyp := Full_View (Root_Type (Utyp));
5950 -- Handle private types
5952 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5953 Utyp := Full_View (Utyp);
5956 -- Handle protected and task types
5958 if Is_Concurrent_Type (Utyp)
5959 and then Present (Corresponding_Record_Type (Utyp))
5961 Utyp := Corresponding_Record_Type (Utyp);
5964 Utyp := Underlying_Type (Base_Type (Utyp));
5966 -- Deal with untagged derivation of private views. If the parent is
5967 -- now known to be protected, the finalization routine is the one
5968 -- defined on the corresponding record of the ancestor (corresponding
5969 -- records do not automatically inherit operations, but maybe they
5972 if Is_Untagged_Derivation (Btyp) then
5973 if Is_Protected_Type (Btyp) then
5974 Utyp := Corresponding_Record_Type (Root_Type (Btyp));
5977 Utyp := Underlying_Type (Root_Type (Btyp));
5979 if Is_Protected_Type (Utyp) then
5980 Utyp := Corresponding_Record_Type (Utyp);
5985 -- If the underlying_type is a subtype, we are dealing with the
5986 -- completion of a private type. We need to access the base type and
5987 -- generate a conversion to it.
5989 if Utyp /= Base_Type (Utyp) then
5990 pragma Assert (Is_Private_Type (Typ));
5992 Utyp := Base_Type (Utyp);
5995 -- When dealing with an internally built full view for a type with
5996 -- unknown discriminants, use the original record type.
5998 if Is_Underlying_Record_View (Utyp) then
5999 Utyp := Etype (Utyp);
6002 return TSS (Utyp, TSS_Finalize_Address);
6003 end Finalize_Address;
6005 ------------------------
6006 -- Find_Interface_ADT --
6007 ------------------------
6009 function Find_Interface_ADT
6011 Iface : Entity_Id) return Elmt_Id
6014 Typ : Entity_Id := T;
6017 pragma Assert (Is_Interface (Iface));
6019 -- Handle private types
6021 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
6022 Typ := Full_View (Typ);
6025 -- Handle access types
6027 if Is_Access_Type (Typ) then
6028 Typ := Designated_Type (Typ);
6031 -- Handle task and protected types implementing interfaces
6033 if Is_Concurrent_Type (Typ) then
6034 Typ := Corresponding_Record_Type (Typ);
6038 (not Is_Class_Wide_Type (Typ)
6039 and then Ekind (Typ) /= E_Incomplete_Type);
6041 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
6042 return First_Elmt (Access_Disp_Table (Typ));
6045 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
6047 and then Present (Related_Type (Node (ADT)))
6048 and then Related_Type (Node (ADT)) /= Iface
6049 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
6050 Use_Full_View => True)
6055 pragma Assert (Present (Related_Type (Node (ADT))));
6058 end Find_Interface_ADT;
6060 ------------------------
6061 -- Find_Interface_Tag --
6062 ------------------------
6064 function Find_Interface_Tag
6066 Iface : Entity_Id) return Entity_Id
6068 AI_Tag : Entity_Id := Empty;
6069 Found : Boolean := False;
6070 Typ : Entity_Id := T;
6072 procedure Find_Tag (Typ : Entity_Id);
6073 -- Internal subprogram used to recursively climb to the ancestors
6079 procedure Find_Tag (Typ : Entity_Id) is
6084 -- This routine does not handle the case in which the interface is an
6085 -- ancestor of Typ. That case is handled by the enclosing subprogram.
6087 pragma Assert (Typ /= Iface);
6089 -- Climb to the root type handling private types
6091 if Present (Full_View (Etype (Typ))) then
6092 if Full_View (Etype (Typ)) /= Typ then
6093 Find_Tag (Full_View (Etype (Typ)));
6096 elsif Etype (Typ) /= Typ then
6097 Find_Tag (Etype (Typ));
6100 -- Traverse the list of interfaces implemented by the type
6103 and then Present (Interfaces (Typ))
6104 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
6106 -- Skip the tag associated with the primary table
6108 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
6109 pragma Assert (Present (AI_Tag));
6111 AI_Elmt := First_Elmt (Interfaces (Typ));
6112 while Present (AI_Elmt) loop
6113 AI := Node (AI_Elmt);
6116 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
6122 AI_Tag := Next_Tag_Component (AI_Tag);
6123 Next_Elmt (AI_Elmt);
6128 -- Start of processing for Find_Interface_Tag
6131 pragma Assert (Is_Interface (Iface));
6133 -- Handle access types
6135 if Is_Access_Type (Typ) then
6136 Typ := Designated_Type (Typ);
6139 -- Handle class-wide types
6141 if Is_Class_Wide_Type (Typ) then
6142 Typ := Root_Type (Typ);
6145 -- Handle private types
6147 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
6148 Typ := Full_View (Typ);
6151 -- Handle entities from the limited view
6153 if Ekind (Typ) = E_Incomplete_Type then
6154 pragma Assert (Present (Non_Limited_View (Typ)));
6155 Typ := Non_Limited_View (Typ);
6158 -- Handle task and protected types implementing interfaces
6160 if Is_Concurrent_Type (Typ) then
6161 Typ := Corresponding_Record_Type (Typ);
6164 -- If the interface is an ancestor of the type, then it shared the
6165 -- primary dispatch table.
6167 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
6168 return First_Tag_Component (Typ);
6170 -- Otherwise we need to search for its associated tag component
6176 end Find_Interface_Tag;
6178 ---------------------------
6179 -- Find_Optional_Prim_Op --
6180 ---------------------------
6182 function Find_Optional_Prim_Op
6183 (T : Entity_Id; Name : Name_Id) return Entity_Id
6186 Typ : Entity_Id := T;
6190 if Is_Class_Wide_Type (Typ) then
6191 Typ := Root_Type (Typ);
6194 Typ := Underlying_Type (Typ);
6196 -- Loop through primitive operations
6198 Prim := First_Elmt (Primitive_Operations (Typ));
6199 while Present (Prim) loop
6202 -- We can retrieve primitive operations by name if it is an internal
6203 -- name. For equality we must check that both of its operands have
6204 -- the same type, to avoid confusion with user-defined equalities
6205 -- than may have a asymmetric signature.
6207 exit when Chars (Op) = Name
6210 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
6215 return Node (Prim); -- Empty if not found
6216 end Find_Optional_Prim_Op;
6218 ---------------------------
6219 -- Find_Optional_Prim_Op --
6220 ---------------------------
6222 function Find_Optional_Prim_Op
6224 Name : TSS_Name_Type) return Entity_Id
6226 Inher_Op : Entity_Id := Empty;
6227 Own_Op : Entity_Id := Empty;
6228 Prim_Elmt : Elmt_Id;
6229 Prim_Id : Entity_Id;
6230 Typ : Entity_Id := T;
6233 if Is_Class_Wide_Type (Typ) then
6234 Typ := Root_Type (Typ);
6237 Typ := Underlying_Type (Typ);
6239 -- This search is based on the assertion that the dispatching version
6240 -- of the TSS routine always precedes the real primitive.
6242 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
6243 while Present (Prim_Elmt) loop
6244 Prim_Id := Node (Prim_Elmt);
6246 if Is_TSS (Prim_Id, Name) then
6247 if Present (Alias (Prim_Id)) then
6248 Inher_Op := Prim_Id;
6254 Next_Elmt (Prim_Elmt);
6257 if Present (Own_Op) then
6259 elsif Present (Inher_Op) then
6264 end Find_Optional_Prim_Op;
6270 function Find_Prim_Op
6271 (T : Entity_Id; Name : Name_Id) return Entity_Id
6273 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
6276 raise Program_Error;
6286 function Find_Prim_Op
6288 Name : TSS_Name_Type) return Entity_Id
6290 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
6293 raise Program_Error;
6299 ----------------------------
6300 -- Find_Protection_Object --
6301 ----------------------------
6303 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
6308 while Present (S) loop
6309 if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure
6310 and then Present (Protection_Object (S))
6312 return Protection_Object (S);
6318 -- If we do not find a Protection object in the scope chain, then
6319 -- something has gone wrong, most likely the object was never created.
6321 raise Program_Error;
6322 end Find_Protection_Object;
6324 --------------------------
6325 -- Find_Protection_Type --
6326 --------------------------
6328 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
6330 Typ : Entity_Id := Conc_Typ;
6333 if Is_Concurrent_Type (Typ) then
6334 Typ := Corresponding_Record_Type (Typ);
6337 -- Since restriction violations are not considered serious errors, the
6338 -- expander remains active, but may leave the corresponding record type
6339 -- malformed. In such cases, component _object is not available so do
6342 if not Analyzed (Typ) then
6346 Comp := First_Component (Typ);
6347 while Present (Comp) loop
6348 if Chars (Comp) = Name_uObject then
6349 return Base_Type (Etype (Comp));
6352 Next_Component (Comp);
6355 -- The corresponding record of a protected type should always have an
6358 raise Program_Error;
6359 end Find_Protection_Type;
6361 -----------------------
6362 -- Find_Hook_Context --
6363 -----------------------
6365 function Find_Hook_Context (N : Node_Id) return Node_Id is
6369 Wrapped_Node : Node_Id;
6370 -- Note: if we are in a transient scope, we want to reuse it as
6371 -- the context for actions insertion, if possible. But if N is itself
6372 -- part of the stored actions for the current transient scope,
6373 -- then we need to insert at the appropriate (inner) location in
6374 -- the not as an action on Node_To_Be_Wrapped.
6376 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
6379 -- When the node is inside a case/if expression, the lifetime of any
6380 -- temporary controlled object is extended. Find a suitable insertion
6381 -- node by locating the topmost case or if expressions.
6383 if In_Cond_Expr then
6386 while Present (Par) loop
6387 if Nkind (Original_Node (Par)) in
6388 N_Case_Expression | N_If_Expression
6392 -- Prevent the search from going too far
6394 elsif Is_Body_Or_Package_Declaration (Par) then
6398 Par := Parent (Par);
6401 -- The topmost case or if expression is now recovered, but it may
6402 -- still not be the correct place to add generated code. Climb to
6403 -- find a parent that is part of a declarative or statement list,
6404 -- and is not a list of actuals in a call.
6407 while Present (Par) loop
6408 if Is_List_Member (Par)
6409 and then Nkind (Par) not in N_Component_Association
6410 | N_Discriminant_Association
6411 | N_Parameter_Association
6412 | N_Pragma_Argument_Association
6415 | N_Extension_Aggregate
6416 and then Nkind (Parent (Par)) not in N_Function_Call
6417 | N_Procedure_Call_Statement
6418 | N_Entry_Call_Statement
6423 -- Prevent the search from going too far
6425 elsif Is_Body_Or_Package_Declaration (Par) then
6429 Par := Parent (Par);
6436 while Present (Par) loop
6438 -- Keep climbing past various operators
6440 if Nkind (Parent (Par)) in N_Op
6441 or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else
6443 Par := Parent (Par);
6451 -- The node may be located in a pragma in which case return the
6454 -- pragma Precondition (... and then Ctrl_Func_Call ...);
6456 -- Similar case occurs when the node is related to an object
6457 -- declaration or assignment:
6459 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
6461 -- Another case to consider is when the node is part of a return
6464 -- return ... and then Ctrl_Func_Call ...;
6466 -- Another case is when the node acts as a formal in a procedure
6469 -- Proc (... and then Ctrl_Func_Call ...);
6471 if Scope_Is_Transient then
6472 Wrapped_Node := Node_To_Be_Wrapped;
6474 Wrapped_Node := Empty;
6477 while Present (Par) loop
6478 if Par = Wrapped_Node
6479 or else Nkind (Par) in N_Assignment_Statement
6480 | N_Object_Declaration
6482 | N_Procedure_Call_Statement
6483 | N_Simple_Return_Statement
6487 -- Prevent the search from going too far
6489 elsif Is_Body_Or_Package_Declaration (Par) then
6493 Par := Parent (Par);
6496 -- Return the topmost short circuit operator
6500 end Find_Hook_Context;
6502 ------------------------------
6503 -- Following_Address_Clause --
6504 ------------------------------
6506 function Following_Address_Clause (D : Node_Id) return Node_Id is
6507 Id : constant Entity_Id := Defining_Identifier (D);
6511 function Check_Decls (D : Node_Id) return Node_Id;
6512 -- This internal function differs from the main function in that it
6513 -- gets called to deal with a following package private part, and
6514 -- it checks declarations starting with D (the main function checks
6515 -- declarations following D). If D is Empty, then Empty is returned.
6521 function Check_Decls (D : Node_Id) return Node_Id is
6526 while Present (Decl) loop
6527 if Nkind (Decl) = N_At_Clause
6528 and then Chars (Identifier (Decl)) = Chars (Id)
6532 elsif Nkind (Decl) = N_Attribute_Definition_Clause
6533 and then Chars (Decl) = Name_Address
6534 and then Chars (Name (Decl)) = Chars (Id)
6542 -- Otherwise not found, return Empty
6547 -- Start of processing for Following_Address_Clause
6550 -- If parser detected no address clause for the identifier in question,
6551 -- then the answer is a quick NO, without the need for a search.
6553 if not Get_Name_Table_Boolean1 (Chars (Id)) then
6557 -- Otherwise search current declarative unit
6559 Result := Check_Decls (Next (D));
6561 if Present (Result) then
6565 -- Check for possible package private part following
6569 if Nkind (Par) = N_Package_Specification
6570 and then Visible_Declarations (Par) = List_Containing (D)
6571 and then Present (Private_Declarations (Par))
6573 -- Private part present, check declarations there
6575 return Check_Decls (First (Private_Declarations (Par)));
6578 -- No private part, clause not found, return Empty
6582 end Following_Address_Clause;
6584 ----------------------
6585 -- Force_Evaluation --
6586 ----------------------
6588 procedure Force_Evaluation
6590 Name_Req : Boolean := False;
6591 Related_Id : Entity_Id := Empty;
6592 Is_Low_Bound : Boolean := False;
6593 Is_High_Bound : Boolean := False;
6594 Mode : Force_Evaluation_Mode := Relaxed)
6599 Name_Req => Name_Req,
6600 Variable_Ref => True,
6601 Renaming_Req => False,
6602 Related_Id => Related_Id,
6603 Is_Low_Bound => Is_Low_Bound,
6604 Is_High_Bound => Is_High_Bound,
6605 Check_Side_Effects =>
6606 Is_Static_Expression (Exp)
6607 or else Mode = Relaxed);
6608 end Force_Evaluation;
6610 ---------------------------------
6611 -- Fully_Qualified_Name_String --
6612 ---------------------------------
6614 function Fully_Qualified_Name_String
6616 Append_NUL : Boolean := True) return String_Id
6618 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6619 -- Compute recursively the qualified name without NUL at the end, adding
6620 -- it to the currently started string being generated
6622 ----------------------------------
6623 -- Internal_Full_Qualified_Name --
6624 ----------------------------------
6626 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6630 -- Deal properly with child units
6632 if Nkind (E) = N_Defining_Program_Unit_Name then
6633 Ent := Defining_Identifier (E);
6638 -- Compute qualification recursively (only "Standard" has no scope)
6640 if Present (Scope (Scope (Ent))) then
6641 Internal_Full_Qualified_Name (Scope (Ent));
6642 Store_String_Char (Get_Char_Code ('.'));
6645 -- Every entity should have a name except some expanded blocks
6646 -- don't bother about those.
6648 if Chars (Ent) = No_Name then
6652 -- Generates the entity name in upper case
6654 Get_Decoded_Name_String (Chars (Ent));
6656 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6658 end Internal_Full_Qualified_Name;
6660 -- Start of processing for Full_Qualified_Name
6664 Internal_Full_Qualified_Name (E);
6667 Store_String_Char (Get_Char_Code (ASCII.NUL));
6671 end Fully_Qualified_Name_String;
6673 ---------------------------------
6674 -- Get_Current_Value_Condition --
6675 ---------------------------------
6677 -- Note: the implementation of this procedure is very closely tied to the
6678 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6679 -- interpret Current_Value fields set by the Set procedure, so the two
6680 -- procedures need to be closely coordinated.
6682 procedure Get_Current_Value_Condition
6687 Loc : constant Source_Ptr := Sloc (Var);
6688 Ent : constant Entity_Id := Entity (Var);
6690 procedure Process_Current_Value_Condition (N : Node_Id; S : Boolean);
6691 -- N is an expression which holds either True (S = True) or False (S =
6692 -- False) in the condition. This procedure digs out the expression and
6693 -- if it refers to Ent, sets Op and Val appropriately.
6695 -------------------------------------
6696 -- Process_Current_Value_Condition --
6697 -------------------------------------
6699 procedure Process_Current_Value_Condition
6704 Prev_Cond : Node_Id;
6714 -- Deal with NOT operators, inverting sense
6716 while Nkind (Cond) = N_Op_Not loop
6717 Cond := Right_Opnd (Cond);
6721 -- Deal with conversions, qualifications, and expressions with
6724 while Nkind (Cond) in N_Type_Conversion
6725 | N_Qualified_Expression
6726 | N_Expression_With_Actions
6728 Cond := Expression (Cond);
6731 exit when Cond = Prev_Cond;
6734 -- Deal with AND THEN and AND cases
6736 if Nkind (Cond) in N_And_Then | N_Op_And then
6738 -- Don't ever try to invert a condition that is of the form of an
6739 -- AND or AND THEN (since we are not doing sufficiently general
6740 -- processing to allow this).
6742 if Sens = False then
6748 -- Recursively process AND and AND THEN branches
6750 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6751 pragma Assert (Op'Valid);
6753 if Op /= N_Empty then
6757 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6760 -- Case of relational operator
6762 elsif Nkind (Cond) in N_Op_Compare then
6765 -- Invert sense of test if inverted test
6767 if Sens = False then
6769 when N_Op_Eq => Op := N_Op_Ne;
6770 when N_Op_Ne => Op := N_Op_Eq;
6771 when N_Op_Lt => Op := N_Op_Ge;
6772 when N_Op_Gt => Op := N_Op_Le;
6773 when N_Op_Le => Op := N_Op_Gt;
6774 when N_Op_Ge => Op := N_Op_Lt;
6775 when others => raise Program_Error;
6779 -- Case of entity op value
6781 if Is_Entity_Name (Left_Opnd (Cond))
6782 and then Ent = Entity (Left_Opnd (Cond))
6783 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6785 Val := Right_Opnd (Cond);
6787 -- Case of value op entity
6789 elsif Is_Entity_Name (Right_Opnd (Cond))
6790 and then Ent = Entity (Right_Opnd (Cond))
6791 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6793 Val := Left_Opnd (Cond);
6795 -- We are effectively swapping operands
6798 when N_Op_Eq => null;
6799 when N_Op_Ne => null;
6800 when N_Op_Lt => Op := N_Op_Gt;
6801 when N_Op_Gt => Op := N_Op_Lt;
6802 when N_Op_Le => Op := N_Op_Ge;
6803 when N_Op_Ge => Op := N_Op_Le;
6804 when others => raise Program_Error;
6813 elsif Nkind (Cond) in N_Type_Conversion
6814 | N_Qualified_Expression
6815 | N_Expression_With_Actions
6817 Cond := Expression (Cond);
6819 -- Case of Boolean variable reference, return as though the
6820 -- reference had said var = True.
6823 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6824 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6826 if Sens = False then
6833 end Process_Current_Value_Condition;
6835 -- Start of processing for Get_Current_Value_Condition
6841 -- Immediate return, nothing doing, if this is not an object
6843 if not Is_Object (Ent) then
6847 -- In GNATprove mode we don't want to use current value optimizer, in
6848 -- particular for loop invariant expressions and other assertions that
6849 -- act as cut points for proof. The optimizer often folds expressions
6850 -- into True/False where they trivially follow from the previous
6851 -- assignments, but this deprives proof from the information needed to
6852 -- discharge checks that are beyond the scope of the value optimizer.
6854 if GNATprove_Mode then
6858 -- Otherwise examine current value
6861 CV : constant Node_Id := Current_Value (Ent);
6866 -- If statement. Condition is known true in THEN section, known False
6867 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6869 if Nkind (CV) = N_If_Statement then
6871 -- Before start of IF statement
6873 if Loc < Sloc (CV) then
6876 -- After end of IF statement
6878 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6882 -- At this stage we know that we are within the IF statement, but
6883 -- unfortunately, the tree does not record the SLOC of the ELSE so
6884 -- we cannot use a simple SLOC comparison to distinguish between
6885 -- the then/else statements, so we have to climb the tree.
6892 while Parent (N) /= CV loop
6895 -- If we fall off the top of the tree, then that's odd, but
6896 -- perhaps it could occur in some error situation, and the
6897 -- safest response is simply to assume that the outcome of
6898 -- the condition is unknown. No point in bombing during an
6899 -- attempt to optimize things.
6906 -- Now we have N pointing to a node whose parent is the IF
6907 -- statement in question, so now we can tell if we are within
6908 -- the THEN statements.
6910 if Is_List_Member (N)
6911 and then List_Containing (N) = Then_Statements (CV)
6915 -- If the variable reference does not come from source, we
6916 -- cannot reliably tell whether it appears in the else part.
6917 -- In particular, if it appears in generated code for a node
6918 -- that requires finalization, it may be attached to a list
6919 -- that has not been yet inserted into the code. For now,
6920 -- treat it as unknown.
6922 elsif not Comes_From_Source (N) then
6925 -- Otherwise we must be in ELSIF or ELSE part
6932 -- ELSIF part. Condition is known true within the referenced
6933 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6934 -- and unknown before the ELSE part or after the IF statement.
6936 elsif Nkind (CV) = N_Elsif_Part then
6938 -- if the Elsif_Part had condition_actions, the elsif has been
6939 -- rewritten as a nested if, and the original elsif_part is
6940 -- detached from the tree, so there is no way to obtain useful
6941 -- information on the current value of the variable.
6942 -- Can this be improved ???
6944 if No (Parent (CV)) then
6950 -- If the tree has been otherwise rewritten there is nothing
6951 -- else to be done either.
6953 if Nkind (Stm) /= N_If_Statement then
6957 -- Before start of ELSIF part
6959 if Loc < Sloc (CV) then
6962 -- After end of IF statement
6964 elsif Loc >= Sloc (Stm) +
6965 Text_Ptr (UI_To_Int (End_Span (Stm)))
6970 -- Again we lack the SLOC of the ELSE, so we need to climb the
6971 -- tree to see if we are within the ELSIF part in question.
6978 while Parent (N) /= Stm loop
6981 -- If we fall off the top of the tree, then that's odd, but
6982 -- perhaps it could occur in some error situation, and the
6983 -- safest response is simply to assume that the outcome of
6984 -- the condition is unknown. No point in bombing during an
6985 -- attempt to optimize things.
6992 -- Now we have N pointing to a node whose parent is the IF
6993 -- statement in question, so see if is the ELSIF part we want.
6994 -- the THEN statements.
6999 -- Otherwise we must be in subsequent ELSIF or ELSE part
7006 -- Iteration scheme of while loop. The condition is known to be
7007 -- true within the body of the loop.
7009 elsif Nkind (CV) = N_Iteration_Scheme then
7011 Loop_Stmt : constant Node_Id := Parent (CV);
7014 -- Before start of body of loop
7016 if Loc < Sloc (Loop_Stmt) then
7019 -- After end of LOOP statement
7021 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
7024 -- We are within the body of the loop
7031 -- All other cases of Current_Value settings
7037 -- If we fall through here, then we have a reportable condition, Sens
7038 -- is True if the condition is true and False if it needs inverting.
7040 Process_Current_Value_Condition (Condition (CV), Sens);
7042 end Get_Current_Value_Condition;
7044 -----------------------
7045 -- Get_Index_Subtype --
7046 -----------------------
7048 function Get_Index_Subtype (N : Node_Id) return Node_Id is
7049 P_Type : Entity_Id := Etype (Prefix (N));
7054 if Is_Access_Type (P_Type) then
7055 P_Type := Designated_Type (P_Type);
7058 if No (Expressions (N)) then
7061 J := UI_To_Int (Expr_Value (First (Expressions (N))));
7064 Indx := First_Index (P_Type);
7070 return Etype (Indx);
7071 end Get_Index_Subtype;
7073 ---------------------
7074 -- Get_Stream_Size --
7075 ---------------------
7077 function Get_Stream_Size (E : Entity_Id) return Uint is
7079 -- If we have a Stream_Size clause for this type use it
7081 if Has_Stream_Size_Clause (E) then
7082 return Static_Integer (Expression (Stream_Size_Clause (E)));
7084 -- Otherwise the Stream_Size is the size of the type
7089 end Get_Stream_Size;
7091 ---------------------------
7092 -- Has_Access_Constraint --
7093 ---------------------------
7095 function Has_Access_Constraint (E : Entity_Id) return Boolean is
7097 T : constant Entity_Id := Etype (E);
7100 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
7101 Disc := First_Discriminant (T);
7102 while Present (Disc) loop
7103 if Is_Access_Type (Etype (Disc)) then
7107 Next_Discriminant (Disc);
7114 end Has_Access_Constraint;
7116 --------------------
7117 -- Homonym_Number --
7118 --------------------
7120 function Homonym_Number (Subp : Entity_Id) return Pos is
7121 Hom : Entity_Id := Homonym (Subp);
7125 while Present (Hom) loop
7126 if Scope (Hom) = Scope (Subp) then
7130 Hom := Homonym (Hom);
7136 -----------------------------------
7137 -- In_Library_Level_Package_Body --
7138 -----------------------------------
7140 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
7142 -- First determine whether the entity appears at the library level, then
7143 -- look at the containing unit.
7145 if Is_Library_Level_Entity (Id) then
7147 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
7150 return Nkind (Unit (Container)) = N_Package_Body;
7155 end In_Library_Level_Package_Body;
7157 ------------------------------
7158 -- In_Unconditional_Context --
7159 ------------------------------
7161 function In_Unconditional_Context (Node : Node_Id) return Boolean is
7166 while Present (P) loop
7168 when N_Subprogram_Body => return True;
7169 when N_If_Statement => return False;
7170 when N_Loop_Statement => return False;
7171 when N_Case_Statement => return False;
7172 when others => P := Parent (P);
7177 end In_Unconditional_Context;
7183 procedure Insert_Action
7184 (Assoc_Node : Node_Id;
7185 Ins_Action : Node_Id;
7186 Spec_Expr_OK : Boolean := False)
7189 if Present (Ins_Action) then
7191 (Assoc_Node => Assoc_Node,
7192 Ins_Actions => New_List (Ins_Action),
7193 Spec_Expr_OK => Spec_Expr_OK);
7197 -- Version with check(s) suppressed
7199 procedure Insert_Action
7200 (Assoc_Node : Node_Id;
7201 Ins_Action : Node_Id;
7202 Suppress : Check_Id;
7203 Spec_Expr_OK : Boolean := False)
7207 (Assoc_Node => Assoc_Node,
7208 Ins_Actions => New_List (Ins_Action),
7209 Suppress => Suppress,
7210 Spec_Expr_OK => Spec_Expr_OK);
7213 -------------------------
7214 -- Insert_Action_After --
7215 -------------------------
7217 procedure Insert_Action_After
7218 (Assoc_Node : Node_Id;
7219 Ins_Action : Node_Id)
7222 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
7223 end Insert_Action_After;
7225 --------------------
7226 -- Insert_Actions --
7227 --------------------
7229 procedure Insert_Actions
7230 (Assoc_Node : Node_Id;
7231 Ins_Actions : List_Id;
7232 Spec_Expr_OK : Boolean := False)
7237 Wrapped_Node : Node_Id := Empty;
7240 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
7244 -- Insert the action when the context is "Handling of Default and Per-
7245 -- Object Expressions" only when requested by the caller.
7247 if Spec_Expr_OK then
7250 -- Ignore insert of actions from inside default expression (or other
7251 -- similar "spec expression") in the special spec-expression analyze
7252 -- mode. Any insertions at this point have no relevance, since we are
7253 -- only doing the analyze to freeze the types of any static expressions.
7254 -- See section "Handling of Default and Per-Object Expressions" in the
7255 -- spec of package Sem for further details.
7257 elsif In_Spec_Expression then
7261 -- If the action derives from stuff inside a record, then the actions
7262 -- are attached to the current scope, to be inserted and analyzed on
7263 -- exit from the scope. The reason for this is that we may also be
7264 -- generating freeze actions at the same time, and they must eventually
7265 -- be elaborated in the correct order.
7267 if Is_Record_Type (Current_Scope)
7268 and then not Is_Frozen (Current_Scope)
7270 if No (Scope_Stack.Table
7271 (Scope_Stack.Last).Pending_Freeze_Actions)
7273 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
7278 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
7284 -- We now intend to climb up the tree to find the right point to
7285 -- insert the actions. We start at Assoc_Node, unless this node is a
7286 -- subexpression in which case we start with its parent. We do this for
7287 -- two reasons. First it speeds things up. Second, if Assoc_Node is
7288 -- itself one of the special nodes like N_And_Then, then we assume that
7289 -- an initial request to insert actions for such a node does not expect
7290 -- the actions to get deposited in the node for later handling when the
7291 -- node is expanded, since clearly the node is being dealt with by the
7292 -- caller. Note that in the subexpression case, N is always the child we
7295 -- N_Raise_xxx_Error is an annoying special case, it is a statement
7296 -- if it has type Standard_Void_Type, and a subexpression otherwise.
7297 -- Procedure calls, and similarly procedure attribute references, are
7300 if Nkind (Assoc_Node) in N_Subexpr
7301 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
7302 or else Etype (Assoc_Node) /= Standard_Void_Type)
7303 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
7304 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
7305 or else not Is_Procedure_Attribute_Name
7306 (Attribute_Name (Assoc_Node)))
7309 P := Parent (Assoc_Node);
7311 -- Nonsubexpression case. Note that N is initially Empty in this case
7312 -- (N is only guaranteed non-Empty in the subexpr case).
7319 -- Capture root of the transient scope
7321 if Scope_Is_Transient then
7322 Wrapped_Node := Node_To_Be_Wrapped;
7326 pragma Assert (Present (P));
7328 -- Make sure that inserted actions stay in the transient scope
7330 if Present (Wrapped_Node) and then N = Wrapped_Node then
7331 Store_Before_Actions_In_Scope (Ins_Actions);
7337 -- Case of right operand of AND THEN or OR ELSE. Put the actions
7338 -- in the Actions field of the right operand. They will be moved
7339 -- out further when the AND THEN or OR ELSE operator is expanded.
7340 -- Nothing special needs to be done for the left operand since
7341 -- in that case the actions are executed unconditionally.
7343 when N_Short_Circuit =>
7344 if N = Right_Opnd (P) then
7346 -- We are now going to either append the actions to the
7347 -- actions field of the short-circuit operation. We will
7348 -- also analyze the actions now.
7350 -- This analysis is really too early, the proper thing would
7351 -- be to just park them there now, and only analyze them if
7352 -- we find we really need them, and to it at the proper
7353 -- final insertion point. However attempting to this proved
7354 -- tricky, so for now we just kill current values before and
7355 -- after the analyze call to make sure we avoid peculiar
7356 -- optimizations from this out of order insertion.
7358 Kill_Current_Values;
7360 -- If P has already been expanded, we can't park new actions
7361 -- on it, so we need to expand them immediately, introducing
7362 -- an Expression_With_Actions. N can't be an expression
7363 -- with actions, or else then the actions would have been
7364 -- inserted at an inner level.
7366 if Analyzed (P) then
7367 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
7369 Make_Expression_With_Actions (Sloc (N),
7370 Actions => Ins_Actions,
7371 Expression => Relocate_Node (N)));
7372 Analyze_And_Resolve (N);
7374 elsif Present (Actions (P)) then
7375 Insert_List_After_And_Analyze
7376 (Last (Actions (P)), Ins_Actions);
7378 Set_Actions (P, Ins_Actions);
7379 Analyze_List (Actions (P));
7382 Kill_Current_Values;
7387 -- Then or Else dependent expression of an if expression. Add
7388 -- actions to Then_Actions or Else_Actions field as appropriate.
7389 -- The actions will be moved further out when the if is expanded.
7391 when N_If_Expression =>
7393 ThenX : constant Node_Id := Next (First (Expressions (P)));
7394 ElseX : constant Node_Id := Next (ThenX);
7397 -- If the enclosing expression is already analyzed, as
7398 -- is the case for nested elaboration checks, insert the
7399 -- conditional further out.
7401 if Analyzed (P) then
7404 -- Actions belong to the then expression, temporarily place
7405 -- them as Then_Actions of the if expression. They will be
7406 -- moved to the proper place later when the if expression is
7409 elsif N = ThenX then
7410 if Present (Then_Actions (P)) then
7411 Insert_List_After_And_Analyze
7412 (Last (Then_Actions (P)), Ins_Actions);
7414 Set_Then_Actions (P, Ins_Actions);
7415 Analyze_List (Then_Actions (P));
7420 -- Else_Actions is treated the same as Then_Actions above
7422 elsif N = ElseX then
7423 if Present (Else_Actions (P)) then
7424 Insert_List_After_And_Analyze
7425 (Last (Else_Actions (P)), Ins_Actions);
7427 Set_Else_Actions (P, Ins_Actions);
7428 Analyze_List (Else_Actions (P));
7433 -- Actions belong to the condition. In this case they are
7434 -- unconditionally executed, and so we can continue the
7435 -- search for the proper insert point.
7442 -- Alternative of case expression, we place the action in the
7443 -- Actions field of the case expression alternative, this will
7444 -- be handled when the case expression is expanded.
7446 when N_Case_Expression_Alternative =>
7447 if Present (Actions (P)) then
7448 Insert_List_After_And_Analyze
7449 (Last (Actions (P)), Ins_Actions);
7451 Set_Actions (P, Ins_Actions);
7452 Analyze_List (Actions (P));
7457 -- Case of appearing within an Expressions_With_Actions node. When
7458 -- the new actions come from the expression of the expression with
7459 -- actions, they must be added to the existing actions. The other
7460 -- alternative is when the new actions are related to one of the
7461 -- existing actions of the expression with actions, and should
7462 -- never reach here: if actions are inserted on a statement
7463 -- within the Actions of an expression with actions, or on some
7464 -- subexpression of such a statement, then the outermost proper
7465 -- insertion point is right before the statement, and we should
7466 -- never climb up as far as the N_Expression_With_Actions itself.
7468 when N_Expression_With_Actions =>
7469 if N = Expression (P) then
7470 if Is_Empty_List (Actions (P)) then
7471 Append_List_To (Actions (P), Ins_Actions);
7472 Analyze_List (Actions (P));
7474 Insert_List_After_And_Analyze
7475 (Last (Actions (P)), Ins_Actions);
7481 raise Program_Error;
7484 -- Case of appearing in the condition of a while expression or
7485 -- elsif. We insert the actions into the Condition_Actions field.
7486 -- They will be moved further out when the while loop or elsif
7490 | N_Iteration_Scheme
7492 if N = Condition (P) then
7493 if Present (Condition_Actions (P)) then
7494 Insert_List_After_And_Analyze
7495 (Last (Condition_Actions (P)), Ins_Actions);
7497 Set_Condition_Actions (P, Ins_Actions);
7499 -- Set the parent of the insert actions explicitly. This
7500 -- is not a syntactic field, but we need the parent field
7501 -- set, in particular so that freeze can understand that
7502 -- it is dealing with condition actions, and properly
7503 -- insert the freezing actions.
7505 Set_Parent (Ins_Actions, P);
7506 Analyze_List (Condition_Actions (P));
7512 -- Statements, declarations, pragmas, representation clauses
7517 N_Procedure_Call_Statement
7518 | N_Statement_Other_Than_Procedure_Call
7524 -- Representation_Clause
7527 | N_Attribute_Definition_Clause
7528 | N_Enumeration_Representation_Clause
7529 | N_Record_Representation_Clause
7533 | N_Abstract_Subprogram_Declaration
7535 | N_Exception_Declaration
7536 | N_Exception_Renaming_Declaration
7537 | N_Expression_Function
7538 | N_Formal_Abstract_Subprogram_Declaration
7539 | N_Formal_Concrete_Subprogram_Declaration
7540 | N_Formal_Object_Declaration
7541 | N_Formal_Type_Declaration
7542 | N_Full_Type_Declaration
7543 | N_Function_Instantiation
7544 | N_Generic_Function_Renaming_Declaration
7545 | N_Generic_Package_Declaration
7546 | N_Generic_Package_Renaming_Declaration
7547 | N_Generic_Procedure_Renaming_Declaration
7548 | N_Generic_Subprogram_Declaration
7549 | N_Implicit_Label_Declaration
7550 | N_Incomplete_Type_Declaration
7551 | N_Number_Declaration
7552 | N_Object_Declaration
7553 | N_Object_Renaming_Declaration
7555 | N_Package_Body_Stub
7556 | N_Package_Declaration
7557 | N_Package_Instantiation
7558 | N_Package_Renaming_Declaration
7559 | N_Private_Extension_Declaration
7560 | N_Private_Type_Declaration
7561 | N_Procedure_Instantiation
7563 | N_Protected_Body_Stub
7564 | N_Single_Task_Declaration
7566 | N_Subprogram_Body_Stub
7567 | N_Subprogram_Declaration
7568 | N_Subprogram_Renaming_Declaration
7569 | N_Subtype_Declaration
7573 -- Use clauses can appear in lists of declarations
7575 | N_Use_Package_Clause
7578 -- Freeze entity behaves like a declaration or statement
7581 | N_Freeze_Generic_Entity
7583 -- Do not insert here if the item is not a list member (this
7584 -- happens for example with a triggering statement, and the
7585 -- proper approach is to insert before the entire select).
7587 if not Is_List_Member (P) then
7590 -- Do not insert if parent of P is an N_Component_Association
7591 -- node (i.e. we are in the context of an N_Aggregate or
7592 -- N_Extension_Aggregate node. In this case we want to insert
7593 -- before the entire aggregate.
7595 elsif Nkind (Parent (P)) = N_Component_Association then
7598 -- Do not insert if the parent of P is either an N_Variant node
7599 -- or an N_Record_Definition node, meaning in either case that
7600 -- P is a member of a component list, and that therefore the
7601 -- actions should be inserted outside the complete record
7604 elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
7607 -- Do not insert freeze nodes within the loop generated for
7608 -- an aggregate, because they may be elaborated too late for
7609 -- subsequent use in the back end: within a package spec the
7610 -- loop is part of the elaboration procedure and is only
7611 -- elaborated during the second pass.
7613 -- If the loop comes from source, or the entity is local to the
7614 -- loop itself it must remain within.
7616 elsif Nkind (Parent (P)) = N_Loop_Statement
7617 and then not Comes_From_Source (Parent (P))
7618 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7620 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7624 -- Otherwise we can go ahead and do the insertion
7626 elsif P = Wrapped_Node then
7627 Store_Before_Actions_In_Scope (Ins_Actions);
7631 Insert_List_Before_And_Analyze (P, Ins_Actions);
7635 -- the expansion of Task and protected type declarations can
7636 -- create declarations for temporaries which, like other actions
7637 -- are inserted and analyzed before the current declaraation.
7638 -- However, the current scope is the synchronized type, and
7639 -- for unnesting it is critical that the proper scope for these
7640 -- generated entities be the enclosing one.
7642 when N_Task_Type_Declaration
7643 | N_Protected_Type_Declaration =>
7645 Push_Scope (Scope (Current_Scope));
7646 Insert_List_Before_And_Analyze (P, Ins_Actions);
7650 -- A special case, N_Raise_xxx_Error can act either as a statement
7651 -- or a subexpression. We tell the difference by looking at the
7652 -- Etype. It is set to Standard_Void_Type in the statement case.
7654 when N_Raise_xxx_Error =>
7655 if Etype (P) = Standard_Void_Type then
7656 if P = Wrapped_Node then
7657 Store_Before_Actions_In_Scope (Ins_Actions);
7659 Insert_List_Before_And_Analyze (P, Ins_Actions);
7664 -- In the subexpression case, keep climbing
7670 -- If a component association appears within a loop created for
7671 -- an array aggregate, attach the actions to the association so
7672 -- they can be subsequently inserted within the loop. For other
7673 -- component associations insert outside of the aggregate. For
7674 -- an association that will generate a loop, its Loop_Actions
7675 -- attribute is already initialized (see exp_aggr.adb).
7677 -- The list of Loop_Actions can in turn generate additional ones,
7678 -- that are inserted before the associated node. If the associated
7679 -- node is outside the aggregate, the new actions are collected
7680 -- at the end of the Loop_Actions, to respect the order in which
7681 -- they are to be elaborated.
7683 when N_Component_Association
7684 | N_Iterated_Component_Association
7685 | N_Iterated_Element_Association
7687 if Nkind (Parent (P)) = N_Aggregate
7688 and then Present (Loop_Actions (P))
7690 if Is_Empty_List (Loop_Actions (P)) then
7691 Set_Loop_Actions (P, Ins_Actions);
7692 Analyze_List (Ins_Actions);
7698 -- Check whether these actions were generated by a
7699 -- declaration that is part of the Loop_Actions for
7700 -- the component_association.
7703 while Present (Decl) loop
7704 exit when Parent (Decl) = P
7705 and then Is_List_Member (Decl)
7707 List_Containing (Decl) = Loop_Actions (P);
7708 Decl := Parent (Decl);
7711 if Present (Decl) then
7712 Insert_List_Before_And_Analyze
7713 (Decl, Ins_Actions);
7715 Insert_List_After_And_Analyze
7716 (Last (Loop_Actions (P)), Ins_Actions);
7727 -- Special case: an attribute denoting a procedure call
7729 when N_Attribute_Reference =>
7730 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7731 if P = Wrapped_Node then
7732 Store_Before_Actions_In_Scope (Ins_Actions);
7734 Insert_List_Before_And_Analyze (P, Ins_Actions);
7739 -- In the subexpression case, keep climbing
7745 -- Special case: a marker
7748 | N_Variable_Reference_Marker
7750 if Is_List_Member (P) then
7751 Insert_List_Before_And_Analyze (P, Ins_Actions);
7755 -- A contract node should not belong to the tree
7758 raise Program_Error;
7760 -- For all other node types, keep climbing tree
7762 when N_Abortable_Part
7763 | N_Accept_Alternative
7764 | N_Access_Definition
7765 | N_Access_Function_Definition
7766 | N_Access_Procedure_Definition
7767 | N_Access_To_Object_Definition
7770 | N_Aspect_Specification
7772 | N_Case_Statement_Alternative
7773 | N_Character_Literal
7774 | N_Compilation_Unit
7775 | N_Compilation_Unit_Aux
7776 | N_Component_Clause
7777 | N_Component_Declaration
7778 | N_Component_Definition
7780 | N_Constrained_Array_Definition
7781 | N_Decimal_Fixed_Point_Definition
7782 | N_Defining_Character_Literal
7783 | N_Defining_Identifier
7784 | N_Defining_Operator_Symbol
7785 | N_Defining_Program_Unit_Name
7786 | N_Delay_Alternative
7788 | N_Delta_Constraint
7789 | N_Derived_Type_Definition
7791 | N_Digits_Constraint
7792 | N_Discriminant_Association
7793 | N_Discriminant_Specification
7795 | N_Entry_Body_Formal_Part
7796 | N_Entry_Call_Alternative
7797 | N_Entry_Declaration
7798 | N_Entry_Index_Specification
7799 | N_Enumeration_Type_Definition
7801 | N_Exception_Handler
7803 | N_Explicit_Dereference
7804 | N_Extension_Aggregate
7805 | N_Floating_Point_Definition
7806 | N_Formal_Decimal_Fixed_Point_Definition
7807 | N_Formal_Derived_Type_Definition
7808 | N_Formal_Discrete_Type_Definition
7809 | N_Formal_Floating_Point_Definition
7810 | N_Formal_Modular_Type_Definition
7811 | N_Formal_Ordinary_Fixed_Point_Definition
7812 | N_Formal_Package_Declaration
7813 | N_Formal_Private_Type_Definition
7814 | N_Formal_Incomplete_Type_Definition
7815 | N_Formal_Signed_Integer_Type_Definition
7817 | N_Function_Specification
7818 | N_Generic_Association
7819 | N_Handled_Sequence_Of_Statements
7822 | N_Index_Or_Discriminant_Constraint
7823 | N_Indexed_Component
7825 | N_Iterator_Specification
7828 | N_Loop_Parameter_Specification
7830 | N_Modular_Type_Definition
7856 | N_Op_Shift_Right_Arithmetic
7860 | N_Ordinary_Fixed_Point_Definition
7862 | N_Package_Specification
7863 | N_Parameter_Association
7864 | N_Parameter_Specification
7865 | N_Pop_Constraint_Error_Label
7866 | N_Pop_Program_Error_Label
7867 | N_Pop_Storage_Error_Label
7868 | N_Pragma_Argument_Association
7869 | N_Procedure_Specification
7870 | N_Protected_Definition
7871 | N_Push_Constraint_Error_Label
7872 | N_Push_Program_Error_Label
7873 | N_Push_Storage_Error_Label
7874 | N_Qualified_Expression
7875 | N_Quantified_Expression
7876 | N_Raise_Expression
7878 | N_Range_Constraint
7880 | N_Real_Range_Specification
7881 | N_Record_Definition
7883 | N_SCIL_Dispatch_Table_Tag_Init
7884 | N_SCIL_Dispatching_Call
7885 | N_SCIL_Membership_Test
7886 | N_Selected_Component
7887 | N_Signed_Integer_Type_Definition
7888 | N_Single_Protected_Declaration
7891 | N_Subtype_Indication
7895 | N_Terminate_Alternative
7896 | N_Triggering_Alternative
7898 | N_Unchecked_Expression
7899 | N_Unchecked_Type_Conversion
7900 | N_Unconstrained_Array_Definition
7905 | N_Validate_Unchecked_Conversion
7911 -- If we fall through above tests, keep climbing tree
7915 if Nkind (Parent (N)) = N_Subunit then
7917 -- This is the proper body corresponding to a stub. Insertion must
7918 -- be done at the point of the stub, which is in the declarative
7919 -- part of the parent unit.
7921 P := Corresponding_Stub (Parent (N));
7929 -- Version with check(s) suppressed
7931 procedure Insert_Actions
7932 (Assoc_Node : Node_Id;
7933 Ins_Actions : List_Id;
7934 Suppress : Check_Id;
7935 Spec_Expr_OK : Boolean := False)
7938 if Suppress = All_Checks then
7940 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
7942 Scope_Suppress.Suppress := (others => True);
7943 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7944 Scope_Suppress.Suppress := Sva;
7949 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
7951 Scope_Suppress.Suppress (Suppress) := True;
7952 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7953 Scope_Suppress.Suppress (Suppress) := Svg;
7958 --------------------------
7959 -- Insert_Actions_After --
7960 --------------------------
7962 procedure Insert_Actions_After
7963 (Assoc_Node : Node_Id;
7964 Ins_Actions : List_Id)
7967 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
7968 Store_After_Actions_In_Scope (Ins_Actions);
7970 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
7972 end Insert_Actions_After;
7974 ------------------------
7975 -- Insert_Declaration --
7976 ------------------------
7978 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
7982 pragma Assert (Nkind (N) in N_Subexpr);
7984 -- Climb until we find a procedure or a package
7988 pragma Assert (Present (Parent (P)));
7991 if Is_List_Member (P) then
7992 exit when Nkind (Parent (P)) in
7993 N_Package_Specification | N_Subprogram_Body;
7995 -- Special handling for handled sequence of statements, we must
7996 -- insert in the statements not the exception handlers!
7998 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
7999 P := First (Statements (Parent (P)));
8005 -- Now do the insertion
8007 Insert_Before (P, Decl);
8009 end Insert_Declaration;
8011 ---------------------------------
8012 -- Insert_Library_Level_Action --
8013 ---------------------------------
8015 procedure Insert_Library_Level_Action (N : Node_Id) is
8016 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
8019 Push_Scope (Cunit_Entity (Current_Sem_Unit));
8020 -- And not Main_Unit as previously. If the main unit is a body,
8021 -- the scope needed to analyze the actions is the entity of the
8022 -- corresponding declaration.
8024 if No (Actions (Aux)) then
8025 Set_Actions (Aux, New_List (N));
8027 Append (N, Actions (Aux));
8032 end Insert_Library_Level_Action;
8034 ----------------------------------
8035 -- Insert_Library_Level_Actions --
8036 ----------------------------------
8038 procedure Insert_Library_Level_Actions (L : List_Id) is
8039 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
8042 if Is_Non_Empty_List (L) then
8043 Push_Scope (Cunit_Entity (Main_Unit));
8044 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
8046 if No (Actions (Aux)) then
8047 Set_Actions (Aux, L);
8050 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
8055 end Insert_Library_Level_Actions;
8057 ----------------------
8058 -- Inside_Init_Proc --
8059 ----------------------
8061 function Inside_Init_Proc return Boolean is
8062 Proc : constant Entity_Id := Enclosing_Init_Proc;
8065 return Proc /= Empty;
8066 end Inside_Init_Proc;
8068 ----------------------
8069 -- Integer_Type_For --
8070 ----------------------
8072 function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id is
8074 pragma Assert (S <= System_Max_Integer_Size);
8076 -- This is the canonical 32-bit type
8078 if S <= Standard_Integer_Size then
8080 return Standard_Unsigned;
8082 return Standard_Integer;
8085 -- This is the canonical 64-bit type
8087 elsif S <= Standard_Long_Long_Integer_Size then
8089 return Standard_Long_Long_Unsigned;
8091 return Standard_Long_Long_Integer;
8094 -- This is the canonical 128-bit type
8096 elsif S <= Standard_Long_Long_Long_Integer_Size then
8098 return Standard_Long_Long_Long_Unsigned;
8100 return Standard_Long_Long_Long_Integer;
8104 raise Program_Error;
8106 end Integer_Type_For;
8108 --------------------------------------------------
8109 -- Is_Displacement_Of_Object_Or_Function_Result --
8110 --------------------------------------------------
8112 function Is_Displacement_Of_Object_Or_Function_Result
8113 (Obj_Id : Entity_Id) return Boolean
8115 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
8116 -- Determine whether node N denotes a controlled function call
8118 function Is_Controlled_Indexing (N : Node_Id) return Boolean;
8119 -- Determine whether node N denotes a generalized indexing form which
8120 -- involves a controlled result.
8122 function Is_Displace_Call (N : Node_Id) return Boolean;
8123 -- Determine whether node N denotes a call to Ada.Tags.Displace
8125 function Is_Source_Object (N : Node_Id) return Boolean;
8126 -- Determine whether a particular node denotes a source object
8128 function Strip (N : Node_Id) return Node_Id;
8129 -- Examine arbitrary node N by stripping various indirections and return
8132 ---------------------------------
8133 -- Is_Controlled_Function_Call --
8134 ---------------------------------
8136 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
8140 -- When a function call appears in Object.Operation format, the
8141 -- original representation has several possible forms depending on
8142 -- the availability and form of actual parameters:
8144 -- Obj.Func N_Selected_Component
8145 -- Obj.Func (Actual) N_Indexed_Component
8146 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
8147 -- N_Selected_Component
8149 Expr := Original_Node (N);
8151 if Nkind (Expr) = N_Function_Call then
8152 Expr := Name (Expr);
8154 -- "Obj.Func (Actual)" case
8156 elsif Nkind (Expr) = N_Indexed_Component then
8157 Expr := Prefix (Expr);
8159 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
8161 elsif Nkind (Expr) = N_Selected_Component then
8162 Expr := Selector_Name (Expr);
8170 Nkind (Expr) in N_Has_Entity
8171 and then Present (Entity (Expr))
8172 and then Ekind (Entity (Expr)) = E_Function
8173 and then Needs_Finalization (Etype (Entity (Expr)));
8174 end Is_Controlled_Function_Call;
8176 ----------------------------
8177 -- Is_Controlled_Indexing --
8178 ----------------------------
8180 function Is_Controlled_Indexing (N : Node_Id) return Boolean is
8181 Expr : constant Node_Id := Original_Node (N);
8185 Nkind (Expr) = N_Indexed_Component
8186 and then Present (Generalized_Indexing (Expr))
8187 and then Needs_Finalization (Etype (Expr));
8188 end Is_Controlled_Indexing;
8190 ----------------------
8191 -- Is_Displace_Call --
8192 ----------------------
8194 function Is_Displace_Call (N : Node_Id) return Boolean is
8195 Call : constant Node_Id := Strip (N);
8200 and then Nkind (Call) = N_Function_Call
8201 and then Nkind (Name (Call)) in N_Has_Entity
8202 and then Is_RTE (Entity (Name (Call)), RE_Displace);
8203 end Is_Displace_Call;
8205 ----------------------
8206 -- Is_Source_Object --
8207 ----------------------
8209 function Is_Source_Object (N : Node_Id) return Boolean is
8210 Obj : constant Node_Id := Strip (N);
8215 and then Comes_From_Source (Obj)
8216 and then Nkind (Obj) in N_Has_Entity
8217 and then Is_Object (Entity (Obj));
8218 end Is_Source_Object;
8224 function Strip (N : Node_Id) return Node_Id is
8230 if Nkind (Result) = N_Explicit_Dereference then
8231 Result := Prefix (Result);
8233 elsif Nkind (Result) in
8234 N_Type_Conversion | N_Unchecked_Type_Conversion
8236 Result := Expression (Result);
8248 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
8249 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
8250 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
8251 Orig_Expr : Node_Id;
8253 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
8258 -- Obj : CW_Type := Function_Call (...);
8260 -- is rewritten into:
8262 -- Temp : ... := Function_Call (...)'reference;
8263 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
8265 -- where the return type of the function and the class-wide type require
8266 -- dispatch table pointer displacement.
8270 -- Obj : CW_Type := Container (...);
8272 -- is rewritten into:
8274 -- Temp : ... := Function_Call (Container, ...)'reference;
8275 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
8277 -- where the container element type and the class-wide type require
8278 -- dispatch table pointer dispacement.
8282 -- Obj : CW_Type := Src_Obj;
8284 -- is rewritten into:
8286 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
8288 -- where the type of the source object and the class-wide type require
8289 -- dispatch table pointer displacement.
8291 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
8292 and then Is_Class_Wide_Type (Obj_Typ)
8293 and then Is_Displace_Call (Renamed_Object (Obj_Id))
8294 and then Nkind (Orig_Decl) = N_Object_Declaration
8295 and then Comes_From_Source (Orig_Decl)
8297 Orig_Expr := Expression (Orig_Decl);
8300 Is_Controlled_Function_Call (Orig_Expr)
8301 or else Is_Controlled_Indexing (Orig_Expr)
8302 or else Is_Source_Object (Orig_Expr);
8306 end Is_Displacement_Of_Object_Or_Function_Result;
8308 ------------------------------
8309 -- Is_Finalizable_Transient --
8310 ------------------------------
8312 function Is_Finalizable_Transient
8314 Rel_Node : Node_Id) return Boolean
8316 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
8317 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
8319 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
8320 -- Determine whether transient object Trans_Id is initialized either
8321 -- by a function call which returns an access type or simply renames
8324 function Initialized_By_Aliased_BIP_Func_Call
8325 (Trans_Id : Entity_Id) return Boolean;
8326 -- Determine whether transient object Trans_Id is initialized by a
8327 -- build-in-place function call where the BIPalloc parameter is of
8328 -- value 1 and BIPaccess is not null. This case creates an aliasing
8329 -- between the returned value and the value denoted by BIPaccess.
8332 (Trans_Id : Entity_Id;
8333 First_Stmt : Node_Id) return Boolean;
8334 -- Determine whether transient object Trans_Id has been renamed or
8335 -- aliased through 'reference in the statement list starting from
8338 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
8339 -- Determine whether transient object Trans_Id is allocated on the heap
8341 function Is_Iterated_Container
8342 (Trans_Id : Entity_Id;
8343 First_Stmt : Node_Id) return Boolean;
8344 -- Determine whether transient object Trans_Id denotes a container which
8345 -- is in the process of being iterated in the statement list starting
8348 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean;
8349 -- Return True if N is directly part of a build-in-place return
8352 ---------------------------
8353 -- Initialized_By_Access --
8354 ---------------------------
8356 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
8357 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8362 and then Nkind (Expr) /= N_Reference
8363 and then Is_Access_Type (Etype (Expr));
8364 end Initialized_By_Access;
8366 ------------------------------------------
8367 -- Initialized_By_Aliased_BIP_Func_Call --
8368 ------------------------------------------
8370 function Initialized_By_Aliased_BIP_Func_Call
8371 (Trans_Id : Entity_Id) return Boolean
8373 Call : Node_Id := Expression (Parent (Trans_Id));
8376 -- Build-in-place calls usually appear in 'reference format
8378 if Nkind (Call) = N_Reference then
8379 Call := Prefix (Call);
8382 Call := Unqual_Conv (Call);
8384 if Is_Build_In_Place_Function_Call (Call) then
8386 Access_Nam : Name_Id := No_Name;
8387 Access_OK : Boolean := False;
8389 Alloc_Nam : Name_Id := No_Name;
8390 Alloc_OK : Boolean := False;
8392 Func_Id : Entity_Id;
8396 -- Examine all parameter associations of the function call
8398 Param := First (Parameter_Associations (Call));
8399 while Present (Param) loop
8400 if Nkind (Param) = N_Parameter_Association
8401 and then Nkind (Selector_Name (Param)) = N_Identifier
8403 Actual := Explicit_Actual_Parameter (Param);
8404 Formal := Selector_Name (Param);
8406 -- Construct the names of formals BIPaccess and BIPalloc
8407 -- using the function name retrieved from an arbitrary
8410 if Access_Nam = No_Name
8411 and then Alloc_Nam = No_Name
8412 and then Present (Entity (Formal))
8414 Func_Id := Scope (Entity (Formal));
8417 New_External_Name (Chars (Func_Id),
8418 BIP_Formal_Suffix (BIP_Object_Access));
8421 New_External_Name (Chars (Func_Id),
8422 BIP_Formal_Suffix (BIP_Alloc_Form));
8425 -- A match for BIPaccess => Temp has been found
8427 if Chars (Formal) = Access_Nam
8428 and then Nkind (Actual) /= N_Null
8433 -- A match for BIPalloc => 1 has been found
8435 if Chars (Formal) = Alloc_Nam
8436 and then Nkind (Actual) = N_Integer_Literal
8437 and then Intval (Actual) = Uint_1
8446 return Access_OK and Alloc_OK;
8451 end Initialized_By_Aliased_BIP_Func_Call;
8458 (Trans_Id : Entity_Id;
8459 First_Stmt : Node_Id) return Boolean
8461 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
8462 -- Given an object renaming declaration, retrieve the entity of the
8463 -- renamed name. Return Empty if the renamed name is anything other
8464 -- than a variable or a constant.
8466 -------------------------
8467 -- Find_Renamed_Object --
8468 -------------------------
8470 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
8471 Ren_Obj : Node_Id := Empty;
8473 function Find_Object (N : Node_Id) return Traverse_Result;
8474 -- Try to detect an object which is either a constant or a
8481 function Find_Object (N : Node_Id) return Traverse_Result is
8483 -- Stop the search once a constant or a variable has been
8486 if Nkind (N) = N_Identifier
8487 and then Present (Entity (N))
8488 and then Ekind (Entity (N)) in E_Constant | E_Variable
8490 Ren_Obj := Entity (N);
8497 procedure Search is new Traverse_Proc (Find_Object);
8501 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
8503 -- Start of processing for Find_Renamed_Object
8506 -- Actions related to dispatching calls may appear as renamings of
8507 -- tags. Do not process this type of renaming because it does not
8508 -- use the actual value of the object.
8510 if not Is_RTE (Typ, RE_Tag_Ptr) then
8511 Search (Name (Ren_Decl));
8515 end Find_Renamed_Object;
8520 Ren_Obj : Entity_Id;
8523 -- Start of processing for Is_Aliased
8526 -- A controlled transient object is not considered aliased when it
8527 -- appears inside an expression_with_actions node even when there are
8528 -- explicit aliases of it:
8531 -- Trans_Id : Ctrl_Typ ...; -- transient object
8532 -- Alias : ... := Trans_Id; -- object is aliased
8533 -- Val : constant Boolean :=
8534 -- ... Alias ...; -- aliasing ends
8535 -- <finalize Trans_Id> -- object safe to finalize
8538 -- Expansion ensures that all aliases are encapsulated in the actions
8539 -- list and do not leak to the expression by forcing the evaluation
8540 -- of the expression.
8542 if Nkind (Rel_Node) = N_Expression_With_Actions then
8545 -- Otherwise examine the statements after the controlled transient
8546 -- object and look for various forms of aliasing.
8550 while Present (Stmt) loop
8551 if Nkind (Stmt) = N_Object_Declaration then
8552 Expr := Expression (Stmt);
8554 -- Aliasing of the form:
8555 -- Obj : ... := Trans_Id'reference;
8558 and then Nkind (Expr) = N_Reference
8559 and then Nkind (Prefix (Expr)) = N_Identifier
8560 and then Entity (Prefix (Expr)) = Trans_Id
8565 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
8566 Ren_Obj := Find_Renamed_Object (Stmt);
8568 -- Aliasing of the form:
8569 -- Obj : ... renames ... Trans_Id ...;
8571 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
8587 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
8588 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8591 Is_Access_Type (Etype (Trans_Id))
8592 and then Present (Expr)
8593 and then Nkind (Expr) = N_Allocator;
8596 ---------------------------
8597 -- Is_Iterated_Container --
8598 ---------------------------
8600 function Is_Iterated_Container
8601 (Trans_Id : Entity_Id;
8602 First_Stmt : Node_Id) return Boolean
8612 -- It is not possible to iterate over containers in non-Ada 2012 code
8614 if Ada_Version < Ada_2012 then
8618 Typ := Etype (Trans_Id);
8620 -- Handle access type created for secondary stack use
8622 if Is_Access_Type (Typ) then
8623 Typ := Designated_Type (Typ);
8626 -- Look for aspect Default_Iterator. It may be part of a type
8627 -- declaration for a container, or inherited from a base type
8630 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8632 if Present (Aspect) then
8633 Iter := Entity (Aspect);
8635 -- Examine the statements following the container object and
8636 -- look for a call to the default iterate routine where the
8637 -- first parameter is the transient. Such a call appears as:
8639 -- It : Access_To_CW_Iterator :=
8640 -- Iterate (Tran_Id.all, ...)'reference;
8643 while Present (Stmt) loop
8645 -- Detect an object declaration which is initialized by a
8646 -- secondary stack function call.
8648 if Nkind (Stmt) = N_Object_Declaration
8649 and then Present (Expression (Stmt))
8650 and then Nkind (Expression (Stmt)) = N_Reference
8651 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8653 Call := Prefix (Expression (Stmt));
8655 -- The call must invoke the default iterate routine of
8656 -- the container and the transient object must appear as
8657 -- the first actual parameter. Skip any calls whose names
8658 -- are not entities.
8660 if Is_Entity_Name (Name (Call))
8661 and then Entity (Name (Call)) = Iter
8662 and then Present (Parameter_Associations (Call))
8664 Param := First (Parameter_Associations (Call));
8666 if Nkind (Param) = N_Explicit_Dereference
8667 and then Entity (Prefix (Param)) = Trans_Id
8679 end Is_Iterated_Container;
8681 -------------------------------------
8682 -- Is_Part_Of_BIP_Return_Statement --
8683 -------------------------------------
8685 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
8686 Subp : constant Entity_Id := Current_Subprogram;
8689 -- First check if N is part of a BIP function
8692 or else not Is_Build_In_Place_Function (Subp)
8697 -- Then check whether N is a complete part of a return statement
8698 -- Should we consider other node kinds to go up the tree???
8702 case Nkind (Context) is
8703 when N_Expression_With_Actions => Context := Parent (Context);
8704 when N_Simple_Return_Statement => return True;
8705 when others => return False;
8708 end Is_Part_Of_BIP_Return_Statement;
8712 Desig : Entity_Id := Obj_Typ;
8714 -- Start of processing for Is_Finalizable_Transient
8717 -- Handle access types
8719 if Is_Access_Type (Desig) then
8720 Desig := Available_View (Designated_Type (Desig));
8724 Ekind (Obj_Id) in E_Constant | E_Variable
8725 and then Needs_Finalization (Desig)
8726 and then Requires_Transient_Scope (Desig)
8727 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8728 and then not Is_Part_Of_BIP_Return_Statement (Rel_Node)
8730 -- Do not consider a transient object that was already processed
8732 and then not Is_Finalized_Transient (Obj_Id)
8734 -- Do not consider renamed or 'reference-d transient objects because
8735 -- the act of renaming extends the object's lifetime.
8737 and then not Is_Aliased (Obj_Id, Decl)
8739 -- Do not consider transient objects allocated on the heap since
8740 -- they are attached to a finalization master.
8742 and then not Is_Allocated (Obj_Id)
8744 -- If the transient object is a pointer, check that it is not
8745 -- initialized by a function that returns a pointer or acts as a
8746 -- renaming of another pointer.
8749 (Is_Access_Type (Obj_Typ) and then Initialized_By_Access (Obj_Id))
8751 -- Do not consider transient objects which act as indirect aliases
8752 -- of build-in-place function results.
8754 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8756 -- Do not consider conversions of tags to class-wide types
8758 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8760 -- Do not consider iterators because those are treated as normal
8761 -- controlled objects and are processed by the usual finalization
8762 -- machinery. This avoids the double finalization of an iterator.
8764 and then not Is_Iterator (Desig)
8766 -- Do not consider containers in the context of iterator loops. Such
8767 -- transient objects must exist for as long as the loop is around,
8768 -- otherwise any operation carried out by the iterator will fail.
8770 and then not Is_Iterated_Container (Obj_Id, Decl);
8771 end Is_Finalizable_Transient;
8773 ---------------------------------
8774 -- Is_Fully_Repped_Tagged_Type --
8775 ---------------------------------
8777 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8778 U : constant Entity_Id := Underlying_Type (T);
8782 if No (U) or else not Is_Tagged_Type (U) then
8784 elsif Has_Discriminants (U) then
8786 elsif not Has_Specified_Layout (U) then
8790 -- Here we have a tagged type, see if it has any component (other than
8791 -- tag and parent) with no component_clause. If so, we return False.
8793 Comp := First_Component (U);
8794 while Present (Comp) loop
8795 if not Is_Tag (Comp)
8796 and then Chars (Comp) /= Name_uParent
8797 and then No (Component_Clause (Comp))
8801 Next_Component (Comp);
8805 -- All components have clauses
8808 end Is_Fully_Repped_Tagged_Type;
8810 ----------------------------------
8811 -- Is_Library_Level_Tagged_Type --
8812 ----------------------------------
8814 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8816 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8817 end Is_Library_Level_Tagged_Type;
8819 --------------------------
8820 -- Is_Non_BIP_Func_Call --
8821 --------------------------
8823 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8825 -- The expected call is of the format
8827 -- Func_Call'reference
8830 Nkind (Expr) = N_Reference
8831 and then Nkind (Prefix (Expr)) = N_Function_Call
8832 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8833 end Is_Non_BIP_Func_Call;
8835 ----------------------------------
8836 -- Is_Possibly_Unaligned_Object --
8837 ----------------------------------
8839 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8840 T : constant Entity_Id := Etype (N);
8843 -- If renamed object, apply test to underlying object
8845 if Is_Entity_Name (N)
8846 and then Is_Object (Entity (N))
8847 and then Present (Renamed_Object (Entity (N)))
8849 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8852 -- Tagged and controlled types and aliased types are always aligned, as
8853 -- are concurrent types.
8856 or else Has_Controlled_Component (T)
8857 or else Is_Concurrent_Type (T)
8858 or else Is_Tagged_Type (T)
8859 or else Is_Controlled (T)
8864 -- If this is an element of a packed array, may be unaligned
8866 if Is_Ref_To_Bit_Packed_Array (N) then
8870 -- Case of indexed component reference: test whether prefix is unaligned
8872 if Nkind (N) = N_Indexed_Component then
8873 return Is_Possibly_Unaligned_Object (Prefix (N));
8875 -- Case of selected component reference
8877 elsif Nkind (N) = N_Selected_Component then
8879 P : constant Node_Id := Prefix (N);
8880 C : constant Entity_Id := Entity (Selector_Name (N));
8885 -- If component reference is for an array with nonstatic bounds,
8886 -- then it is always aligned: we can only process unaligned arrays
8887 -- with static bounds (more precisely compile time known bounds).
8889 if Is_Array_Type (T)
8890 and then not Compile_Time_Known_Bounds (T)
8895 -- If component is aliased, it is definitely properly aligned
8897 if Is_Aliased (C) then
8901 -- If component is for a type implemented as a scalar, and the
8902 -- record is packed, and the component is other than the first
8903 -- component of the record, then the component may be unaligned.
8905 if Is_Packed (Etype (P))
8906 and then Represented_As_Scalar (Etype (C))
8907 and then First_Entity (Scope (C)) /= C
8912 -- Compute maximum possible alignment for T
8914 -- If alignment is known, then that settles things
8916 if Known_Alignment (T) then
8917 M := UI_To_Int (Alignment (T));
8919 -- If alignment is not known, tentatively set max alignment
8922 M := Ttypes.Maximum_Alignment;
8924 -- We can reduce this if the Esize is known since the default
8925 -- alignment will never be more than the smallest power of 2
8926 -- that does not exceed this Esize value.
8928 if Known_Esize (T) then
8929 S := UI_To_Int (Esize (T));
8931 while (M / 2) >= S loop
8937 -- Case of component clause present which may specify an
8938 -- unaligned position.
8940 if Present (Component_Clause (C)) then
8942 -- Otherwise we can do a test to make sure that the actual
8943 -- start position in the record, and the length, are both
8944 -- consistent with the required alignment. If not, we know
8945 -- that we are unaligned.
8948 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8954 -- For a component inherited in a record extension, the
8955 -- clause is inherited but position and size are not set.
8957 if Is_Base_Type (Etype (P))
8958 and then Is_Tagged_Type (Etype (P))
8959 and then Present (Original_Record_Component (Comp))
8961 Comp := Original_Record_Component (Comp);
8964 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
8965 or else Esize (Comp) mod Align_In_Bits /= 0
8972 -- Otherwise, for a component reference, test prefix
8974 return Is_Possibly_Unaligned_Object (P);
8977 -- If not a component reference, must be aligned
8982 end Is_Possibly_Unaligned_Object;
8984 ---------------------------------
8985 -- Is_Possibly_Unaligned_Slice --
8986 ---------------------------------
8988 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
8990 -- Go to renamed object
8992 if Is_Entity_Name (N)
8993 and then Is_Object (Entity (N))
8994 and then Present (Renamed_Object (Entity (N)))
8996 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
8999 -- The reference must be a slice
9001 if Nkind (N) /= N_Slice then
9005 -- If it is a slice, then look at the array type being sliced
9008 Sarr : constant Node_Id := Prefix (N);
9009 -- Prefix of the slice, i.e. the array being sliced
9011 Styp : constant Entity_Id := Etype (Prefix (N));
9012 -- Type of the array being sliced
9018 -- The problems arise if the array object that is being sliced
9019 -- is a component of a record or array, and we cannot guarantee
9020 -- the alignment of the array within its containing object.
9022 -- To investigate this, we look at successive prefixes to see
9023 -- if we have a worrisome indexed or selected component.
9027 -- Case of array is part of an indexed component reference
9029 if Nkind (Pref) = N_Indexed_Component then
9030 Ptyp := Etype (Prefix (Pref));
9032 -- The only problematic case is when the array is packed, in
9033 -- which case we really know nothing about the alignment of
9034 -- individual components.
9036 if Is_Bit_Packed_Array (Ptyp) then
9040 -- Case of array is part of a selected component reference
9042 elsif Nkind (Pref) = N_Selected_Component then
9043 Ptyp := Etype (Prefix (Pref));
9045 -- We are definitely in trouble if the record in question
9046 -- has an alignment, and either we know this alignment is
9047 -- inconsistent with the alignment of the slice, or we don't
9048 -- know what the alignment of the slice should be. But this
9049 -- really matters only if the target has strict alignment.
9051 if Target_Strict_Alignment
9052 and then Known_Alignment (Ptyp)
9053 and then (Unknown_Alignment (Styp)
9054 or else Alignment (Styp) > Alignment (Ptyp))
9059 -- We are in potential trouble if the record type is packed.
9060 -- We could special case when we know that the array is the
9061 -- first component, but that's not such a simple case ???
9063 if Is_Packed (Ptyp) then
9067 -- We are in trouble if there is a component clause, and
9068 -- either we do not know the alignment of the slice, or
9069 -- the alignment of the slice is inconsistent with the
9070 -- bit position specified by the component clause.
9073 Field : constant Entity_Id := Entity (Selector_Name (Pref));
9075 if Present (Component_Clause (Field))
9077 (Unknown_Alignment (Styp)
9079 (Component_Bit_Offset (Field) mod
9080 (System_Storage_Unit * Alignment (Styp))) /= 0)
9086 -- For cases other than selected or indexed components we know we
9087 -- are OK, since no issues arise over alignment.
9093 -- We processed an indexed component or selected component
9094 -- reference that looked safe, so keep checking prefixes.
9096 Pref := Prefix (Pref);
9099 end Is_Possibly_Unaligned_Slice;
9101 -------------------------------
9102 -- Is_Related_To_Func_Return --
9103 -------------------------------
9105 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
9106 Expr : constant Node_Id := Related_Expression (Id);
9108 -- In the case of a function with a class-wide result that returns
9109 -- a call to a function with a specific result, we introduce a
9110 -- type conversion for the return expression. We do not want that
9111 -- type conversion to influence the result of this function.
9115 and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
9116 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
9117 end Is_Related_To_Func_Return;
9119 --------------------------------
9120 -- Is_Ref_To_Bit_Packed_Array --
9121 --------------------------------
9123 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
9128 if Is_Entity_Name (N)
9129 and then Is_Object (Entity (N))
9130 and then Present (Renamed_Object (Entity (N)))
9132 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
9135 if Nkind (N) in N_Indexed_Component | N_Selected_Component then
9136 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
9139 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
9142 if Result and then Nkind (N) = N_Indexed_Component then
9143 Expr := First (Expressions (N));
9144 while Present (Expr) loop
9145 Force_Evaluation (Expr);
9155 end Is_Ref_To_Bit_Packed_Array;
9157 --------------------------------
9158 -- Is_Ref_To_Bit_Packed_Slice --
9159 --------------------------------
9161 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
9163 if Nkind (N) = N_Type_Conversion then
9164 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
9166 elsif Is_Entity_Name (N)
9167 and then Is_Object (Entity (N))
9168 and then Present (Renamed_Object (Entity (N)))
9170 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
9172 elsif Nkind (N) = N_Slice
9173 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
9177 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
9178 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
9183 end Is_Ref_To_Bit_Packed_Slice;
9185 -----------------------
9186 -- Is_Renamed_Object --
9187 -----------------------
9189 function Is_Renamed_Object (N : Node_Id) return Boolean is
9190 Pnod : constant Node_Id := Parent (N);
9191 Kind : constant Node_Kind := Nkind (Pnod);
9193 if Kind = N_Object_Renaming_Declaration then
9195 elsif Kind in N_Indexed_Component | N_Selected_Component then
9196 return Is_Renamed_Object (Pnod);
9200 end Is_Renamed_Object;
9202 --------------------------------------
9203 -- Is_Secondary_Stack_BIP_Func_Call --
9204 --------------------------------------
9206 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
9208 Call : Node_Id := Expr;
9213 -- Build-in-place calls usually appear in 'reference format. Note that
9214 -- the accessibility check machinery may add an extra 'reference due to
9215 -- side effect removal.
9217 while Nkind (Call) = N_Reference loop
9218 Call := Prefix (Call);
9221 Call := Unqual_Conv (Call);
9223 if Is_Build_In_Place_Function_Call (Call) then
9225 -- Examine all parameter associations of the function call
9227 Param := First (Parameter_Associations (Call));
9228 while Present (Param) loop
9229 if Nkind (Param) = N_Parameter_Association then
9230 Formal := Selector_Name (Param);
9231 Actual := Explicit_Actual_Parameter (Param);
9233 -- A match for BIPalloc => 2 has been found
9235 if Is_Build_In_Place_Entity (Formal)
9236 and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
9237 and then Nkind (Actual) = N_Integer_Literal
9238 and then Intval (Actual) = Uint_2
9249 end Is_Secondary_Stack_BIP_Func_Call;
9251 -------------------------------------
9252 -- Is_Tag_To_Class_Wide_Conversion --
9253 -------------------------------------
9255 function Is_Tag_To_Class_Wide_Conversion
9256 (Obj_Id : Entity_Id) return Boolean
9258 Expr : constant Node_Id := Expression (Parent (Obj_Id));
9262 Is_Class_Wide_Type (Etype (Obj_Id))
9263 and then Present (Expr)
9264 and then Nkind (Expr) = N_Unchecked_Type_Conversion
9265 and then Is_RTE (Etype (Expression (Expr)), RE_Tag);
9266 end Is_Tag_To_Class_Wide_Conversion;
9268 --------------------------------
9269 -- Is_Uninitialized_Aggregate --
9270 --------------------------------
9272 function Is_Uninitialized_Aggregate
9274 T : Entity_Id) return Boolean
9277 Comp_Type : Entity_Id;
9281 if Nkind (Exp) /= N_Aggregate then
9285 Preanalyze_And_Resolve (Exp, T);
9289 or else Ekind (Typ) /= E_Array_Subtype
9290 or else Present (Expressions (Exp))
9291 or else No (Component_Associations (Exp))
9295 Comp_Type := Component_Type (Typ);
9296 Comp := First (Component_Associations (Exp));
9298 if not Box_Present (Comp)
9299 or else Present (Next (Comp))
9304 return Is_Scalar_Type (Comp_Type)
9305 and then No (Default_Aspect_Component_Value (Typ));
9307 end Is_Uninitialized_Aggregate;
9309 ----------------------------
9310 -- Is_Untagged_Derivation --
9311 ----------------------------
9313 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
9315 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
9317 (Is_Private_Type (T) and then Present (Full_View (T))
9318 and then not Is_Tagged_Type (Full_View (T))
9319 and then Is_Derived_Type (Full_View (T))
9320 and then Etype (Full_View (T)) /= T);
9321 end Is_Untagged_Derivation;
9323 ------------------------------------
9324 -- Is_Untagged_Private_Derivation --
9325 ------------------------------------
9327 function Is_Untagged_Private_Derivation
9328 (Priv_Typ : Entity_Id;
9329 Full_Typ : Entity_Id) return Boolean
9334 and then Is_Untagged_Derivation (Priv_Typ)
9335 and then Is_Private_Type (Etype (Priv_Typ))
9336 and then Present (Full_Typ)
9337 and then Is_Itype (Full_Typ);
9338 end Is_Untagged_Private_Derivation;
9340 ------------------------------
9341 -- Is_Verifiable_DIC_Pragma --
9342 ------------------------------
9344 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
9345 Args : constant List_Id := Pragma_Argument_Associations (Prag);
9348 -- To qualify as verifiable, a DIC pragma must have a non-null argument
9353 -- If there are args, but the first arg is Empty, then treat the
9354 -- pragma the same as having no args (there may be a second arg that
9355 -- is an implicitly added type arg, and Empty is a placeholder).
9357 and then Present (Get_Pragma_Arg (First (Args)))
9359 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
9360 end Is_Verifiable_DIC_Pragma;
9362 ---------------------------
9363 -- Is_Volatile_Reference --
9364 ---------------------------
9366 function Is_Volatile_Reference (N : Node_Id) return Boolean is
9368 -- Only source references are to be treated as volatile, internally
9369 -- generated stuff cannot have volatile external effects.
9371 if not Comes_From_Source (N) then
9374 -- Never true for reference to a type
9376 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
9379 -- Never true for a compile time known constant
9381 elsif Compile_Time_Known_Value (N) then
9384 -- True if object reference with volatile type
9386 elsif Is_Volatile_Object_Ref (N) then
9389 -- True if reference to volatile entity
9391 elsif Is_Entity_Name (N) then
9392 return Treat_As_Volatile (Entity (N));
9394 -- True for slice of volatile array
9396 elsif Nkind (N) = N_Slice then
9397 return Is_Volatile_Reference (Prefix (N));
9399 -- True if volatile component
9401 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
9402 if (Is_Entity_Name (Prefix (N))
9403 and then Has_Volatile_Components (Entity (Prefix (N))))
9404 or else (Present (Etype (Prefix (N)))
9405 and then Has_Volatile_Components (Etype (Prefix (N))))
9409 return Is_Volatile_Reference (Prefix (N));
9417 end Is_Volatile_Reference;
9419 --------------------
9420 -- Kill_Dead_Code --
9421 --------------------
9423 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
9424 W : Boolean := Warn;
9425 -- Set False if warnings suppressed
9429 Remove_Warning_Messages (N);
9431 -- Update the internal structures of the ABE mechanism in case the
9432 -- dead node is an elaboration scenario.
9434 Kill_Elaboration_Scenario (N);
9436 -- Generate warning if appropriate
9440 -- We suppress the warning if this code is under control of an
9441 -- if/case statement and either
9442 -- a) we are in an instance and the condition/selector
9443 -- has a statically known value; or
9444 -- b) the condition/selector is a simple identifier and
9445 -- warnings off is set for this identifier.
9446 -- Dead code is common and reasonable in instances, so we don't
9447 -- want a warning in that case.
9450 C : Node_Id := Empty;
9452 if Nkind (Parent (N)) = N_If_Statement then
9453 C := Condition (Parent (N));
9454 elsif Nkind (Parent (N)) = N_Case_Statement_Alternative then
9455 C := Expression (Parent (Parent (N)));
9459 if (In_Instance and Compile_Time_Known_Value (C))
9460 or else (Nkind (C) = N_Identifier
9461 and then Present (Entity (C))
9462 and then Has_Warnings_Off (Entity (C)))
9469 -- Generate warning if not suppressed
9473 ("?t?this code can never be executed and has been deleted!",
9478 -- Recurse into block statements and bodies to process declarations
9481 if Nkind (N) = N_Block_Statement
9482 or else Nkind (N) = N_Subprogram_Body
9483 or else Nkind (N) = N_Package_Body
9485 Kill_Dead_Code (Declarations (N), False);
9486 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
9488 if Nkind (N) = N_Subprogram_Body then
9489 Set_Is_Eliminated (Defining_Entity (N));
9492 elsif Nkind (N) = N_Package_Declaration then
9493 Kill_Dead_Code (Visible_Declarations (Specification (N)));
9494 Kill_Dead_Code (Private_Declarations (Specification (N)));
9496 -- ??? After this point, Delete_Tree has been called on all
9497 -- declarations in Specification (N), so references to entities
9498 -- therein look suspicious.
9501 E : Entity_Id := First_Entity (Defining_Entity (N));
9504 while Present (E) loop
9505 if Ekind (E) = E_Operator then
9506 Set_Is_Eliminated (E);
9513 -- Recurse into composite statement to kill individual statements in
9514 -- particular instantiations.
9516 elsif Nkind (N) = N_If_Statement then
9517 Kill_Dead_Code (Then_Statements (N));
9518 Kill_Dead_Code (Elsif_Parts (N));
9519 Kill_Dead_Code (Else_Statements (N));
9521 elsif Nkind (N) = N_Loop_Statement then
9522 Kill_Dead_Code (Statements (N));
9524 elsif Nkind (N) = N_Case_Statement then
9528 Alt := First (Alternatives (N));
9529 while Present (Alt) loop
9530 Kill_Dead_Code (Statements (Alt));
9535 elsif Nkind (N) = N_Case_Statement_Alternative then
9536 Kill_Dead_Code (Statements (N));
9538 -- Deal with dead instances caused by deleting instantiations
9540 elsif Nkind (N) in N_Generic_Instantiation then
9541 Remove_Dead_Instance (N);
9546 -- Case where argument is a list of nodes to be killed
9548 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
9555 if Is_Non_Empty_List (L) then
9557 while Present (N) loop
9558 Kill_Dead_Code (N, W);
9565 -----------------------------
9566 -- Make_CW_Equivalent_Type --
9567 -----------------------------
9569 -- Create a record type used as an equivalent of any member of the class
9570 -- which takes its size from exp.
9572 -- Generate the following code:
9574 -- type Equiv_T is record
9575 -- _parent : T (List of discriminant constraints taken from Exp);
9576 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
9579 -- ??? Note that this type does not guarantee same alignment as all
9582 -- Note: for the freezing circuitry, this looks like a record extension,
9583 -- and so we need to make sure that the scalar storage order is the same
9584 -- as that of the parent type. (This does not change anything for the
9585 -- representation of the extension part.)
9587 function Make_CW_Equivalent_Type
9589 E : Node_Id) return Entity_Id
9591 Loc : constant Source_Ptr := Sloc (E);
9592 Root_Typ : constant Entity_Id := Root_Type (T);
9593 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
9594 List_Def : constant List_Id := Empty_List;
9595 Comp_List : constant List_Id := New_List;
9596 Equiv_Type : Entity_Id;
9597 Range_Type : Entity_Id;
9598 Str_Type : Entity_Id;
9599 Constr_Root : Entity_Id;
9603 -- If the root type is already constrained, there are no discriminants
9604 -- in the expression.
9606 if not Has_Discriminants (Root_Typ)
9607 or else Is_Constrained (Root_Typ)
9609 Constr_Root := Root_Typ;
9611 -- At this point in the expansion, nonlimited view of the type
9612 -- must be available, otherwise the error will be reported later.
9614 if From_Limited_With (Constr_Root)
9615 and then Present (Non_Limited_View (Constr_Root))
9617 Constr_Root := Non_Limited_View (Constr_Root);
9621 Constr_Root := Make_Temporary (Loc, 'R');
9623 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9625 Append_To (List_Def,
9626 Make_Subtype_Declaration (Loc,
9627 Defining_Identifier => Constr_Root,
9628 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9631 -- Generate the range subtype declaration
9633 Range_Type := Make_Temporary (Loc, 'G');
9635 if not Is_Interface (Root_Typ) then
9637 -- subtype rg__xx is
9638 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
9641 Make_Op_Subtract (Loc,
9643 Make_Attribute_Reference (Loc,
9645 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9646 Attribute_Name => Name_Size),
9648 Make_Attribute_Reference (Loc,
9649 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9650 Attribute_Name => Name_Object_Size));
9652 -- subtype rg__xx is
9653 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
9656 Make_Attribute_Reference (Loc,
9658 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9659 Attribute_Name => Name_Size);
9662 Set_Paren_Count (Sizexpr, 1);
9664 Append_To (List_Def,
9665 Make_Subtype_Declaration (Loc,
9666 Defining_Identifier => Range_Type,
9667 Subtype_Indication =>
9668 Make_Subtype_Indication (Loc,
9669 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9670 Constraint => Make_Range_Constraint (Loc,
9673 Low_Bound => Make_Integer_Literal (Loc, 1),
9675 Make_Op_Divide (Loc,
9676 Left_Opnd => Sizexpr,
9677 Right_Opnd => Make_Integer_Literal (Loc,
9678 Intval => System_Storage_Unit)))))));
9680 -- subtype str__nn is Storage_Array (rg__x);
9682 Str_Type := Make_Temporary (Loc, 'S');
9683 Append_To (List_Def,
9684 Make_Subtype_Declaration (Loc,
9685 Defining_Identifier => Str_Type,
9686 Subtype_Indication =>
9687 Make_Subtype_Indication (Loc,
9688 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9690 Make_Index_Or_Discriminant_Constraint (Loc,
9692 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9694 -- type Equiv_T is record
9695 -- [ _parent : Tnn; ]
9699 Equiv_Type := Make_Temporary (Loc, 'T');
9700 Mutate_Ekind (Equiv_Type, E_Record_Type);
9701 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9703 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9704 -- treatment for this type. In particular, even though _parent's type
9705 -- is a controlled type or contains controlled components, we do not
9706 -- want to set Has_Controlled_Component on it to avoid making it gain
9707 -- an unwanted _controller component.
9709 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9711 -- A class-wide equivalent type does not require initialization
9713 Set_Suppress_Initialization (Equiv_Type);
9715 if not Is_Interface (Root_Typ) then
9716 Append_To (Comp_List,
9717 Make_Component_Declaration (Loc,
9718 Defining_Identifier =>
9719 Make_Defining_Identifier (Loc, Name_uParent),
9720 Component_Definition =>
9721 Make_Component_Definition (Loc,
9722 Aliased_Present => False,
9723 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9725 Set_Reverse_Storage_Order
9726 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
9727 Set_Reverse_Bit_Order
9728 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
9731 Append_To (Comp_List,
9732 Make_Component_Declaration (Loc,
9733 Defining_Identifier => Make_Temporary (Loc, 'C'),
9734 Component_Definition =>
9735 Make_Component_Definition (Loc,
9736 Aliased_Present => False,
9737 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9739 Append_To (List_Def,
9740 Make_Full_Type_Declaration (Loc,
9741 Defining_Identifier => Equiv_Type,
9743 Make_Record_Definition (Loc,
9745 Make_Component_List (Loc,
9746 Component_Items => Comp_List,
9747 Variant_Part => Empty))));
9749 -- Suppress all checks during the analysis of the expanded code to avoid
9750 -- the generation of spurious warnings under ZFP run-time.
9752 Insert_Actions (E, List_Def, Suppress => All_Checks);
9754 end Make_CW_Equivalent_Type;
9756 -------------------------
9757 -- Make_Invariant_Call --
9758 -------------------------
9760 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9761 Loc : constant Source_Ptr := Sloc (Expr);
9762 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9763 pragma Assert (Has_Invariants (Typ));
9764 Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
9765 pragma Assert (Present (Proc_Id));
9767 -- The invariant procedure has a null body if assertions are disabled or
9768 -- Assertion_Policy Ignore is in effect. In that case, generate a null
9769 -- statement instead of a call to the invariant procedure.
9771 if Has_Null_Body (Proc_Id) then
9772 return Make_Null_Statement (Loc);
9775 Make_Procedure_Call_Statement (Loc,
9776 Name => New_Occurrence_Of (Proc_Id, Loc),
9777 Parameter_Associations => New_List (Relocate_Node (Expr)));
9779 end Make_Invariant_Call;
9781 ------------------------
9782 -- Make_Literal_Range --
9783 ------------------------
9785 function Make_Literal_Range
9787 Literal_Typ : Entity_Id) return Node_Id
9789 Lo : constant Node_Id :=
9790 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9791 Index : constant Entity_Id := Etype (Lo);
9792 Length_Expr : constant Node_Id :=
9793 Make_Op_Subtract (Loc,
9795 Make_Integer_Literal (Loc,
9796 Intval => String_Literal_Length (Literal_Typ)),
9797 Right_Opnd => Make_Integer_Literal (Loc, 1));
9802 Set_Analyzed (Lo, False);
9804 if Is_Integer_Type (Index) then
9807 Left_Opnd => New_Copy_Tree (Lo),
9808 Right_Opnd => Length_Expr);
9811 Make_Attribute_Reference (Loc,
9812 Attribute_Name => Name_Val,
9813 Prefix => New_Occurrence_Of (Index, Loc),
9814 Expressions => New_List (
9817 Make_Attribute_Reference (Loc,
9818 Attribute_Name => Name_Pos,
9819 Prefix => New_Occurrence_Of (Index, Loc),
9820 Expressions => New_List (New_Copy_Tree (Lo))),
9821 Right_Opnd => Length_Expr)));
9828 end Make_Literal_Range;
9830 --------------------------
9831 -- Make_Non_Empty_Check --
9832 --------------------------
9834 function Make_Non_Empty_Check
9836 N : Node_Id) return Node_Id
9842 Make_Attribute_Reference (Loc,
9843 Attribute_Name => Name_Length,
9844 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9846 Make_Integer_Literal (Loc, 0));
9847 end Make_Non_Empty_Check;
9849 -------------------------
9850 -- Make_Predicate_Call --
9851 -------------------------
9853 -- WARNING: This routine manages Ghost regions. Return statements must be
9854 -- replaced by gotos which jump to the end of the routine and restore the
9857 function Make_Predicate_Call
9860 Mem : Boolean := False) return Node_Id
9862 Loc : constant Source_Ptr := Sloc (Expr);
9864 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9865 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9866 -- Save the Ghost-related attributes to restore on exit
9869 Func_Id : Entity_Id;
9872 Func_Id := Predicate_Function (Typ);
9873 pragma Assert (Present (Func_Id));
9875 -- The related type may be subject to pragma Ghost. Set the mode now to
9876 -- ensure that the call is properly marked as Ghost.
9878 Set_Ghost_Mode (Typ);
9880 -- Call special membership version if requested and available
9882 if Mem and then Present (Predicate_Function_M (Typ)) then
9883 Func_Id := Predicate_Function_M (Typ);
9886 -- Case of calling normal predicate function
9888 -- If the type is tagged, the expression may be class-wide, in which
9889 -- case it has to be converted to its root type, given that the
9890 -- generated predicate function is not dispatching. The conversion is
9891 -- type-safe and does not need validation, which matters when private
9892 -- extensions are involved.
9894 if Is_Tagged_Type (Typ) then
9896 Make_Function_Call (Loc,
9897 Name => New_Occurrence_Of (Func_Id, Loc),
9898 Parameter_Associations =>
9899 New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
9902 Make_Function_Call (Loc,
9903 Name => New_Occurrence_Of (Func_Id, Loc),
9904 Parameter_Associations => New_List (Relocate_Node (Expr)));
9907 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9910 end Make_Predicate_Call;
9912 --------------------------
9913 -- Make_Predicate_Check --
9914 --------------------------
9916 function Make_Predicate_Check
9918 Expr : Node_Id) return Node_Id
9920 Loc : constant Source_Ptr := Sloc (Expr);
9922 procedure Add_Failure_Expression (Args : List_Id);
9923 -- Add the failure expression of pragma Predicate_Failure (if any) to
9926 ----------------------------
9927 -- Add_Failure_Expression --
9928 ----------------------------
9930 procedure Add_Failure_Expression (Args : List_Id) is
9931 function Failure_Expression return Node_Id;
9932 pragma Inline (Failure_Expression);
9933 -- Find aspect or pragma Predicate_Failure that applies to type Typ
9934 -- and return its expression. Return Empty if no such annotation is
9937 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
9938 pragma Inline (Is_OK_PF_Aspect);
9939 -- Determine whether aspect Asp is a suitable Predicate_Failure
9940 -- aspect that applies to type Typ.
9942 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
9943 pragma Inline (Is_OK_PF_Pragma);
9944 -- Determine whether pragma Prag is a suitable Predicate_Failure
9945 -- pragma that applies to type Typ.
9947 procedure Replace_Subtype_Reference (N : Node_Id);
9948 -- Replace the current instance of type Typ denoted by N with
9951 ------------------------
9952 -- Failure_Expression --
9953 ------------------------
9955 function Failure_Expression return Node_Id is
9959 -- The management of the rep item chain involves "inheritance" of
9960 -- parent type chains. If a parent [sub]type is already subject to
9961 -- pragma Predicate_Failure, then the pragma will also appear in
9962 -- the chain of the child [sub]type, which in turn may possess a
9963 -- pragma of its own. Avoid order-dependent issues by inspecting
9964 -- the rep item chain directly. Note that routine Get_Pragma may
9965 -- return a parent pragma.
9967 Item := First_Rep_Item (Typ);
9968 while Present (Item) loop
9970 -- Predicate_Failure appears as an aspect
9972 if Nkind (Item) = N_Aspect_Specification
9973 and then Is_OK_PF_Aspect (Item)
9975 return Expression (Item);
9977 -- Predicate_Failure appears as a pragma
9979 elsif Nkind (Item) = N_Pragma
9980 and then Is_OK_PF_Pragma (Item)
9984 (Next (First (Pragma_Argument_Associations (Item))));
9987 Next_Rep_Item (Item);
9991 end Failure_Expression;
9993 ---------------------
9994 -- Is_OK_PF_Aspect --
9995 ---------------------
9997 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
9999 -- To qualify, the aspect must apply to the type subjected to the
10000 -- predicate check.
10003 Chars (Identifier (Asp)) = Name_Predicate_Failure
10004 and then Present (Entity (Asp))
10005 and then Entity (Asp) = Typ;
10006 end Is_OK_PF_Aspect;
10008 ---------------------
10009 -- Is_OK_PF_Pragma --
10010 ---------------------
10012 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
10013 Args : constant List_Id := Pragma_Argument_Associations (Prag);
10017 -- Nothing to do when the pragma does not denote Predicate_Failure
10019 if Pragma_Name (Prag) /= Name_Predicate_Failure then
10022 -- Nothing to do when the pragma lacks arguments, in which case it
10025 elsif No (Args) or else Is_Empty_List (Args) then
10029 Typ_Arg := Get_Pragma_Arg (First (Args));
10031 -- To qualify, the local name argument of the pragma must denote
10032 -- the type subjected to the predicate check.
10035 Is_Entity_Name (Typ_Arg)
10036 and then Present (Entity (Typ_Arg))
10037 and then Entity (Typ_Arg) = Typ;
10038 end Is_OK_PF_Pragma;
10040 --------------------------------
10041 -- Replace_Subtype_Reference --
10042 --------------------------------
10044 procedure Replace_Subtype_Reference (N : Node_Id) is
10046 Rewrite (N, New_Copy_Tree (Expr));
10047 end Replace_Subtype_Reference;
10049 procedure Replace_Subtype_References is
10050 new Replace_Type_References_Generic (Replace_Subtype_Reference);
10054 PF_Expr : constant Node_Id := Failure_Expression;
10057 -- Start of processing for Add_Failure_Expression
10060 if Present (PF_Expr) then
10062 -- Replace any occurrences of the current instance of the type
10063 -- with the object subjected to the predicate check.
10065 Expr := New_Copy_Tree (PF_Expr);
10066 Replace_Subtype_References (Expr, Typ);
10068 -- The failure expression appears as the third argument of the
10072 Make_Pragma_Argument_Association (Loc,
10073 Expression => Expr));
10075 end Add_Failure_Expression;
10082 -- Start of processing for Make_Predicate_Check
10085 -- If predicate checks are suppressed, then return a null statement. For
10086 -- this call, we check only the scope setting. If the caller wants to
10087 -- check a specific entity's setting, they must do it manually.
10089 if Predicate_Checks_Suppressed (Empty) then
10090 return Make_Null_Statement (Loc);
10093 -- Do not generate a check within stream functions and the like.
10095 if not Predicate_Check_In_Scope (Expr) then
10096 return Make_Null_Statement (Loc);
10099 -- Compute proper name to use, we need to get this right so that the
10100 -- right set of check policies apply to the Check pragma we are making.
10102 if Has_Dynamic_Predicate_Aspect (Typ) then
10103 Nam := Name_Dynamic_Predicate;
10104 elsif Has_Static_Predicate_Aspect (Typ) then
10105 Nam := Name_Static_Predicate;
10107 Nam := Name_Predicate;
10111 Make_Pragma_Argument_Association (Loc,
10112 Expression => Make_Identifier (Loc, Nam)),
10113 Make_Pragma_Argument_Association (Loc,
10114 Expression => Make_Predicate_Call (Typ, Expr)));
10116 -- If the subtype is subject to pragma Predicate_Failure, add the
10117 -- failure expression as an additional parameter.
10119 Add_Failure_Expression (Args);
10123 Chars => Name_Check,
10124 Pragma_Argument_Associations => Args);
10125 end Make_Predicate_Check;
10127 ----------------------------
10128 -- Make_Subtype_From_Expr --
10129 ----------------------------
10131 -- 1. If Expr is an unconstrained array expression, creates
10132 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
10134 -- 2. If Expr is a unconstrained discriminated type expression, creates
10135 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
10137 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
10139 function Make_Subtype_From_Expr
10141 Unc_Typ : Entity_Id;
10142 Related_Id : Entity_Id := Empty) return Node_Id
10144 List_Constr : constant List_Id := New_List;
10145 Loc : constant Source_Ptr := Sloc (E);
10147 Full_Exp : Node_Id;
10148 Full_Subtyp : Entity_Id;
10149 High_Bound : Entity_Id;
10150 Index_Typ : Entity_Id;
10151 Low_Bound : Entity_Id;
10152 Priv_Subtyp : Entity_Id;
10156 if Is_Private_Type (Unc_Typ)
10157 and then Has_Unknown_Discriminants (Unc_Typ)
10159 -- The caller requests a unique external name for both the private
10160 -- and the full subtype.
10162 if Present (Related_Id) then
10164 Make_Defining_Identifier (Loc,
10165 Chars => New_External_Name (Chars (Related_Id), 'C'));
10167 Make_Defining_Identifier (Loc,
10168 Chars => New_External_Name (Chars (Related_Id), 'P'));
10171 Full_Subtyp := Make_Temporary (Loc, 'C');
10172 Priv_Subtyp := Make_Temporary (Loc, 'P');
10175 -- Prepare the subtype completion. Use the base type to find the
10176 -- underlying type because the type may be a generic actual or an
10177 -- explicit subtype.
10179 Utyp := Underlying_Type (Base_Type (Unc_Typ));
10182 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
10183 Set_Parent (Full_Exp, Parent (E));
10186 Make_Subtype_Declaration (Loc,
10187 Defining_Identifier => Full_Subtyp,
10188 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
10190 -- Define the dummy private subtype
10192 Mutate_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
10193 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
10194 Set_Scope (Priv_Subtyp, Full_Subtyp);
10195 Set_Is_Constrained (Priv_Subtyp);
10196 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
10197 Set_Is_Itype (Priv_Subtyp);
10198 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
10200 if Is_Tagged_Type (Priv_Subtyp) then
10201 Set_Class_Wide_Type
10202 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
10203 Set_Direct_Primitive_Operations (Priv_Subtyp,
10204 Direct_Primitive_Operations (Unc_Typ));
10207 Set_Full_View (Priv_Subtyp, Full_Subtyp);
10209 return New_Occurrence_Of (Priv_Subtyp, Loc);
10211 elsif Is_Array_Type (Unc_Typ) then
10212 Index_Typ := First_Index (Unc_Typ);
10213 for J in 1 .. Number_Dimensions (Unc_Typ) loop
10215 -- Capture the bounds of each index constraint in case the context
10216 -- is an object declaration of an unconstrained type initialized
10217 -- by a function call:
10219 -- Obj : Unconstr_Typ := Func_Call;
10221 -- This scenario requires secondary scope management and the index
10222 -- constraint cannot depend on the temporary used to capture the
10223 -- result of the function call.
10226 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
10227 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
10228 -- Obj : S := Temp.all;
10229 -- SS_Release; -- Temp is gone at this point, bounds of S are
10230 -- -- non existent.
10233 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
10235 Low_Bound := Make_Temporary (Loc, 'B');
10237 Make_Object_Declaration (Loc,
10238 Defining_Identifier => Low_Bound,
10239 Object_Definition =>
10240 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
10241 Constant_Present => True,
10243 Make_Attribute_Reference (Loc,
10244 Prefix => Duplicate_Subexpr_No_Checks (E),
10245 Attribute_Name => Name_First,
10246 Expressions => New_List (
10247 Make_Integer_Literal (Loc, J)))));
10250 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
10252 High_Bound := Make_Temporary (Loc, 'B');
10254 Make_Object_Declaration (Loc,
10255 Defining_Identifier => High_Bound,
10256 Object_Definition =>
10257 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
10258 Constant_Present => True,
10260 Make_Attribute_Reference (Loc,
10261 Prefix => Duplicate_Subexpr_No_Checks (E),
10262 Attribute_Name => Name_Last,
10263 Expressions => New_List (
10264 Make_Integer_Literal (Loc, J)))));
10266 Append_To (List_Constr,
10268 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
10269 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
10271 Next_Index (Index_Typ);
10274 elsif Is_Class_Wide_Type (Unc_Typ) then
10276 CW_Subtype : Entity_Id;
10277 EQ_Typ : Entity_Id := Empty;
10280 -- A class-wide equivalent type is not needed on VM targets
10281 -- because the VM back-ends handle the class-wide object
10282 -- initialization itself (and doesn't need or want the
10283 -- additional intermediate type to handle the assignment).
10285 if Expander_Active and then Tagged_Type_Expansion then
10287 -- If this is the class-wide type of a completion that is a
10288 -- record subtype, set the type of the class-wide type to be
10289 -- the full base type, for use in the expanded code for the
10290 -- equivalent type. Should this be done earlier when the
10291 -- completion is analyzed ???
10293 if Is_Private_Type (Etype (Unc_Typ))
10295 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
10297 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
10300 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
10303 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
10304 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
10305 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
10307 return New_Occurrence_Of (CW_Subtype, Loc);
10310 -- Indefinite record type with discriminants
10313 D := First_Discriminant (Unc_Typ);
10314 while Present (D) loop
10315 Append_To (List_Constr,
10316 Make_Selected_Component (Loc,
10317 Prefix => Duplicate_Subexpr_No_Checks (E),
10318 Selector_Name => New_Occurrence_Of (D, Loc)));
10320 Next_Discriminant (D);
10325 Make_Subtype_Indication (Loc,
10326 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
10328 Make_Index_Or_Discriminant_Constraint (Loc,
10329 Constraints => List_Constr));
10330 end Make_Subtype_From_Expr;
10332 -----------------------------
10333 -- Make_Variant_Comparison --
10334 -----------------------------
10336 function Make_Variant_Comparison
10339 Curr_Val : Node_Id;
10340 Old_Val : Node_Id) return Node_Id
10343 if Mode = Name_Increases then
10344 return Make_Op_Gt (Loc, Curr_Val, Old_Val);
10345 else pragma Assert (Mode = Name_Decreases);
10346 return Make_Op_Lt (Loc, Curr_Val, Old_Val);
10348 end Make_Variant_Comparison;
10354 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
10356 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
10357 -- avoid deep indentation of code.
10359 -- NOTE: Routines which deal with discriminant mapping operate on the
10360 -- [underlying/record] full view of various types because those views
10361 -- contain all discriminants and stored constraints.
10363 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
10364 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
10365 -- overriding chain starting from Prim whose dispatching type is parent
10366 -- type Par_Typ and add a mapping between the result and primitive Prim.
10368 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
10369 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
10370 -- the inheritance or overriding chain of subprogram Subp. Return Empty
10371 -- if no such primitive is available.
10373 function Build_Chain
10374 (Par_Typ : Entity_Id;
10375 Deriv_Typ : Entity_Id) return Elist_Id;
10376 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
10377 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
10378 -- list has the form:
10382 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
10384 -- Note that Par_Typ is not part of the resulting derivation chain
10386 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
10387 -- Return the view of type Typ which could potentially contains either
10388 -- the discriminants or stored constraints of the type.
10390 function Find_Discriminant_Value
10391 (Discr : Entity_Id;
10392 Par_Typ : Entity_Id;
10393 Deriv_Typ : Entity_Id;
10394 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
10395 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
10396 -- in the derivation chain starting from parent type Par_Typ leading to
10397 -- derived type Deriv_Typ. The returned value is one of the following:
10399 -- * An entity which is either a discriminant or a nondiscriminant
10400 -- name, and renames/constraints Discr.
10402 -- * An expression which constraints Discr
10404 -- Typ_Elmt is an element of the derivation chain created by routine
10405 -- Build_Chain and denotes the current ancestor being examined.
10407 procedure Map_Discriminants
10408 (Par_Typ : Entity_Id;
10409 Deriv_Typ : Entity_Id);
10410 -- Map each discriminant of type Par_Typ to a meaningful constraint
10411 -- from the point of view of type Deriv_Typ.
10413 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
10414 -- Map each primitive of type Par_Typ to a corresponding primitive of
10417 -------------------
10418 -- Add_Primitive --
10419 -------------------
10421 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
10422 Par_Prim : Entity_Id;
10425 -- Inspect the inheritance chain through the Alias attribute and the
10426 -- overriding chain through the Overridden_Operation looking for an
10427 -- ancestor primitive with the appropriate dispatching type.
10430 while Present (Par_Prim) loop
10431 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
10432 Par_Prim := Ancestor_Primitive (Par_Prim);
10435 -- Create a mapping of the form:
10437 -- parent type primitive -> derived type primitive
10439 if Present (Par_Prim) then
10440 Type_Map.Set (Par_Prim, Prim);
10444 ------------------------
10445 -- Ancestor_Primitive --
10446 ------------------------
10448 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
10449 Inher_Prim : constant Entity_Id := Alias (Subp);
10450 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
10453 -- The current subprogram overrides an ancestor primitive
10455 if Present (Over_Prim) then
10458 -- The current subprogram is an internally generated alias of an
10459 -- inherited ancestor primitive.
10461 elsif Present (Inher_Prim) then
10464 -- Otherwise the current subprogram is the root of the inheritance or
10465 -- overriding chain.
10470 end Ancestor_Primitive;
10476 function Build_Chain
10477 (Par_Typ : Entity_Id;
10478 Deriv_Typ : Entity_Id) return Elist_Id
10480 Anc_Typ : Entity_Id;
10482 Curr_Typ : Entity_Id;
10485 Chain := New_Elmt_List;
10487 -- Add the derived type to the derivation chain
10489 Prepend_Elmt (Deriv_Typ, Chain);
10491 -- Examine all ancestors starting from the derived type climbing
10492 -- towards parent type Par_Typ.
10494 Curr_Typ := Deriv_Typ;
10496 -- Handle the case where the current type is a record which
10497 -- derives from a subtype.
10499 -- subtype Sub_Typ is Par_Typ ...
10500 -- type Deriv_Typ is Sub_Typ ...
10502 if Ekind (Curr_Typ) = E_Record_Type
10503 and then Present (Parent_Subtype (Curr_Typ))
10505 Anc_Typ := Parent_Subtype (Curr_Typ);
10507 -- Handle the case where the current type is a record subtype of
10508 -- another subtype.
10510 -- subtype Sub_Typ1 is Par_Typ ...
10511 -- subtype Sub_Typ2 is Sub_Typ1 ...
10513 elsif Ekind (Curr_Typ) = E_Record_Subtype
10514 and then Present (Cloned_Subtype (Curr_Typ))
10516 Anc_Typ := Cloned_Subtype (Curr_Typ);
10518 -- Otherwise use the direct parent type
10521 Anc_Typ := Etype (Curr_Typ);
10524 -- Use the first subtype when dealing with itypes
10526 if Is_Itype (Anc_Typ) then
10527 Anc_Typ := First_Subtype (Anc_Typ);
10530 -- Work with the view which contains the discriminants and stored
10533 Anc_Typ := Discriminated_View (Anc_Typ);
10535 -- Stop the climb when either the parent type has been reached or
10536 -- there are no more ancestors left to examine.
10538 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
10540 Prepend_Unique_Elmt (Anc_Typ, Chain);
10541 Curr_Typ := Anc_Typ;
10547 ------------------------
10548 -- Discriminated_View --
10549 ------------------------
10551 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
10557 -- Use the [underlying] full view when dealing with private types
10558 -- because the view contains all inherited discriminants or stored
10561 if Is_Private_Type (T) then
10562 if Present (Underlying_Full_View (T)) then
10563 T := Underlying_Full_View (T);
10565 elsif Present (Full_View (T)) then
10566 T := Full_View (T);
10570 -- Use the underlying record view when the type is an extenstion of
10571 -- a parent type with unknown discriminants because the view contains
10572 -- all inherited discriminants or stored constraints.
10574 if Ekind (T) = E_Record_Type
10575 and then Present (Underlying_Record_View (T))
10577 T := Underlying_Record_View (T);
10581 end Discriminated_View;
10583 -----------------------------
10584 -- Find_Discriminant_Value --
10585 -----------------------------
10587 function Find_Discriminant_Value
10588 (Discr : Entity_Id;
10589 Par_Typ : Entity_Id;
10590 Deriv_Typ : Entity_Id;
10591 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
10593 Discr_Pos : constant Uint := Discriminant_Number (Discr);
10594 Typ : constant Entity_Id := Node (Typ_Elmt);
10596 function Find_Constraint_Value
10597 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
10598 -- Given constraint Constr, find what it denotes. This is either:
10600 -- * An entity which is either a discriminant or a name
10604 ---------------------------
10605 -- Find_Constraint_Value --
10606 ---------------------------
10608 function Find_Constraint_Value
10609 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
10612 if Nkind (Constr) in N_Entity then
10614 -- The constraint denotes a discriminant of the curren type
10615 -- which renames the ancestor discriminant:
10618 -- type Typ (D1 : ...; DN : ...) is
10619 -- new Anc (Discr => D1) with ...
10622 if Ekind (Constr) = E_Discriminant then
10624 -- The discriminant belongs to derived type Deriv_Typ. This
10625 -- is the final value for the ancestor discriminant as the
10626 -- derivations chain has been fully exhausted.
10628 if Typ = Deriv_Typ then
10631 -- Otherwise the discriminant may be renamed or constrained
10632 -- at a lower level. Continue looking down the derivation
10637 Find_Discriminant_Value
10639 Par_Typ => Par_Typ,
10640 Deriv_Typ => Deriv_Typ,
10641 Typ_Elmt => Next_Elmt (Typ_Elmt));
10644 -- Otherwise the constraint denotes a reference to some name
10645 -- which results in a Girder discriminant:
10649 -- type Typ (D1 : ...; DN : ...) is
10650 -- new Anc (Discr => Name) with ...
10653 -- Return the name as this is the proper constraint of the
10660 -- The constraint denotes a reference to a name
10662 elsif Is_Entity_Name (Constr) then
10663 return Find_Constraint_Value (Entity (Constr));
10665 -- Otherwise the current constraint is an expression which yields
10666 -- a Girder discriminant:
10668 -- type Typ (D1 : ...; DN : ...) is
10669 -- new Anc (Discr => <expression>) with ...
10672 -- Return the expression as this is the proper constraint of the
10678 end Find_Constraint_Value;
10682 Constrs : constant Elist_Id := Stored_Constraint (Typ);
10684 Constr_Elmt : Elmt_Id;
10686 Typ_Discr : Entity_Id;
10688 -- Start of processing for Find_Discriminant_Value
10691 -- The algorithm for finding the value of a discriminant works as
10692 -- follows. First, it recreates the derivation chain from Par_Typ
10693 -- to Deriv_Typ as a list:
10695 -- Par_Typ (shown for completeness)
10697 -- Ancestor_N <-- head of chain
10701 -- Deriv_Typ <-- tail of chain
10703 -- The algorithm then traces the fate of a parent discriminant down
10704 -- the derivation chain. At each derivation level, the discriminant
10705 -- may be either inherited or constrained.
10707 -- 1) Discriminant is inherited: there are two cases, depending on
10708 -- which type is inheriting.
10710 -- 1.1) Deriv_Typ is inheriting:
10712 -- type Ancestor (D_1 : ...) is tagged ...
10713 -- type Deriv_Typ is new Ancestor ...
10715 -- In this case the inherited discriminant is the final value of
10716 -- the parent discriminant because the end of the derivation chain
10717 -- has been reached.
10719 -- 1.2) Some other type is inheriting:
10721 -- type Ancestor_1 (D_1 : ...) is tagged ...
10722 -- type Ancestor_2 is new Ancestor_1 ...
10724 -- In this case the algorithm continues to trace the fate of the
10725 -- inherited discriminant down the derivation chain because it may
10726 -- be further inherited or constrained.
10728 -- 2) Discriminant is constrained: there are three cases, depending
10729 -- on what the constraint is.
10731 -- 2.1) The constraint is another discriminant (aka renaming):
10733 -- type Ancestor_1 (D_1 : ...) is tagged ...
10734 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
10736 -- In this case the constraining discriminant becomes the one to
10737 -- track down the derivation chain. The algorithm already knows
10738 -- that D_2 constrains D_1, therefore if the algorithm finds the
10739 -- value of D_2, then this would also be the value for D_1.
10741 -- 2.2) The constraint is a name (aka Girder):
10744 -- type Ancestor_1 (D_1 : ...) is tagged ...
10745 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
10747 -- In this case the name is the final value of D_1 because the
10748 -- discriminant cannot be further constrained.
10750 -- 2.3) The constraint is an expression (aka Girder):
10752 -- type Ancestor_1 (D_1 : ...) is tagged ...
10753 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10755 -- Similar to 2.2, the expression is the final value of D_1
10759 -- When a derived type constrains its parent type, all constaints
10760 -- appear in the Stored_Constraint list. Examine the list looking
10761 -- for a positional match.
10763 if Present (Constrs) then
10764 Constr_Elmt := First_Elmt (Constrs);
10765 while Present (Constr_Elmt) loop
10767 -- The position of the current constraint matches that of the
10768 -- ancestor discriminant.
10770 if Pos = Discr_Pos then
10771 return Find_Constraint_Value (Node (Constr_Elmt));
10774 Next_Elmt (Constr_Elmt);
10778 -- Otherwise the derived type does not constraint its parent type in
10779 -- which case it inherits the parent discriminants.
10782 Typ_Discr := First_Discriminant (Typ);
10783 while Present (Typ_Discr) loop
10785 -- The position of the current discriminant matches that of the
10786 -- ancestor discriminant.
10788 if Pos = Discr_Pos then
10789 return Find_Constraint_Value (Typ_Discr);
10792 Next_Discriminant (Typ_Discr);
10797 -- A discriminant must always have a corresponding value. This is
10798 -- either another discriminant, a name, or an expression. If this
10799 -- point is reached, them most likely the derivation chain employs
10800 -- the wrong views of types.
10802 pragma Assert (False);
10805 end Find_Discriminant_Value;
10807 -----------------------
10808 -- Map_Discriminants --
10809 -----------------------
10811 procedure Map_Discriminants
10812 (Par_Typ : Entity_Id;
10813 Deriv_Typ : Entity_Id)
10815 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10818 Discr_Val : Node_Or_Entity_Id;
10821 -- Examine each discriminant of parent type Par_Typ and find a
10822 -- suitable value for it from the point of view of derived type
10825 if Has_Discriminants (Par_Typ) then
10826 Discr := First_Discriminant (Par_Typ);
10827 while Present (Discr) loop
10829 Find_Discriminant_Value
10831 Par_Typ => Par_Typ,
10832 Deriv_Typ => Deriv_Typ,
10833 Typ_Elmt => First_Elmt (Deriv_Chain));
10835 -- Create a mapping of the form:
10837 -- parent type discriminant -> value
10839 Type_Map.Set (Discr, Discr_Val);
10841 Next_Discriminant (Discr);
10844 end Map_Discriminants;
10846 --------------------
10847 -- Map_Primitives --
10848 --------------------
10850 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
10851 Deriv_Prim : Entity_Id;
10852 Par_Prim : Entity_Id;
10853 Par_Prims : Elist_Id;
10854 Prim_Elmt : Elmt_Id;
10857 -- Inspect the primitives of the derived type and determine whether
10858 -- they relate to the primitives of the parent type. If there is a
10859 -- meaningful relation, create a mapping of the form:
10861 -- parent type primitive -> perived type primitive
10863 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
10864 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
10865 while Present (Prim_Elmt) loop
10866 Deriv_Prim := Node (Prim_Elmt);
10868 if Is_Subprogram (Deriv_Prim)
10869 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
10871 Add_Primitive (Deriv_Prim, Par_Typ);
10874 Next_Elmt (Prim_Elmt);
10878 -- If the parent operation is an interface operation, the overriding
10879 -- indicator is not present. Instead, we get from the interface
10880 -- operation the primitive of the current type that implements it.
10882 if Is_Interface (Par_Typ) then
10883 Par_Prims := Collect_Primitive_Operations (Par_Typ);
10885 if Present (Par_Prims) then
10886 Prim_Elmt := First_Elmt (Par_Prims);
10888 while Present (Prim_Elmt) loop
10889 Par_Prim := Node (Prim_Elmt);
10891 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
10893 if Present (Deriv_Prim) then
10894 Type_Map.Set (Par_Prim, Deriv_Prim);
10897 Next_Elmt (Prim_Elmt);
10901 end Map_Primitives;
10903 -- Start of processing for Map_Types
10906 -- Nothing to do if there are no types to work with
10908 if No (Parent_Type) or else No (Derived_Type) then
10911 -- Nothing to do if the mapping already exists
10913 elsif Type_Map.Get (Parent_Type) = Derived_Type then
10916 -- Nothing to do if both types are not tagged. Note that untagged types
10917 -- do not have primitive operations and their discriminants are already
10918 -- handled by gigi.
10920 elsif not Is_Tagged_Type (Parent_Type)
10921 or else not Is_Tagged_Type (Derived_Type)
10926 -- Create a mapping of the form
10928 -- parent type -> derived type
10930 -- to prevent any subsequent attempts to produce the same relations
10932 Type_Map.Set (Parent_Type, Derived_Type);
10934 -- Create mappings of the form
10936 -- parent type discriminant -> derived type discriminant
10938 -- parent type discriminant -> constraint
10940 -- Note that mapping of discriminants breaks privacy because it needs to
10941 -- work with those views which contains the discriminants and any stored
10945 (Par_Typ => Discriminated_View (Parent_Type),
10946 Deriv_Typ => Discriminated_View (Derived_Type));
10948 -- Create mappings of the form
10950 -- parent type primitive -> derived type primitive
10953 (Par_Typ => Parent_Type,
10954 Deriv_Typ => Derived_Type);
10957 ----------------------------
10958 -- Matching_Standard_Type --
10959 ----------------------------
10961 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
10962 pragma Assert (Is_Scalar_Type (Typ));
10963 Siz : constant Uint := Esize (Typ);
10966 -- Floating-point cases
10968 if Is_Floating_Point_Type (Typ) then
10969 if Siz <= Esize (Standard_Short_Float) then
10970 return Standard_Short_Float;
10971 elsif Siz <= Esize (Standard_Float) then
10972 return Standard_Float;
10973 elsif Siz <= Esize (Standard_Long_Float) then
10974 return Standard_Long_Float;
10975 elsif Siz <= Esize (Standard_Long_Long_Float) then
10976 return Standard_Long_Long_Float;
10978 raise Program_Error;
10981 -- Integer cases (includes fixed-point types)
10983 -- Unsigned integer cases (includes normal enumeration types)
10986 return Small_Integer_Type_For (Siz, Is_Unsigned_Type (Typ));
10988 end Matching_Standard_Type;
10990 -----------------------------
10991 -- May_Generate_Large_Temp --
10992 -----------------------------
10994 -- At the current time, the only types that we return False for (i.e. where
10995 -- we decide we know they cannot generate large temps) are ones where we
10996 -- know the size is 256 bits or less at compile time, and we are still not
10997 -- doing a thorough job on arrays and records ???
10999 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
11001 if not Size_Known_At_Compile_Time (Typ) then
11004 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
11007 elsif Is_Array_Type (Typ)
11008 and then Present (Packed_Array_Impl_Type (Typ))
11010 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
11012 -- We could do more here to find other small types ???
11017 end May_Generate_Large_Temp;
11019 --------------------------------------------
11020 -- Needs_Conditional_Null_Excluding_Check --
11021 --------------------------------------------
11023 function Needs_Conditional_Null_Excluding_Check
11024 (Typ : Entity_Id) return Boolean
11028 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
11029 end Needs_Conditional_Null_Excluding_Check;
11031 ----------------------------
11032 -- Needs_Constant_Address --
11033 ----------------------------
11035 function Needs_Constant_Address
11037 Typ : Entity_Id) return Boolean
11040 -- If we have no initialization of any kind, then we don't need to place
11041 -- any restrictions on the address clause, because the object will be
11042 -- elaborated after the address clause is evaluated. This happens if the
11043 -- declaration has no initial expression, or the type has no implicit
11044 -- initialization, or the object is imported.
11046 -- The same holds for all initialized scalar types and all access types.
11047 -- Packed bit array types of size up to the maximum integer size are
11048 -- represented using a modular type with an initialization (to zero) and
11049 -- can be processed like other initialized scalar types.
11051 -- If the type is controlled, code to attach the object to a
11052 -- finalization chain is generated at the point of declaration, and
11053 -- therefore the elaboration of the object cannot be delayed: the
11054 -- address expression must be a constant.
11056 if No (Expression (Decl))
11057 and then not Needs_Finalization (Typ)
11059 (not Has_Non_Null_Base_Init_Proc (Typ)
11060 or else Is_Imported (Defining_Identifier (Decl)))
11064 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
11065 or else Is_Access_Type (Typ)
11067 (Is_Bit_Packed_Array (Typ)
11068 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
11073 -- Otherwise, we require the address clause to be constant because
11074 -- the call to the initialization procedure (or the attach code) has
11075 -- to happen at the point of the declaration.
11077 -- Actually the IP call has been moved to the freeze actions anyway,
11078 -- so maybe we can relax this restriction???
11082 end Needs_Constant_Address;
11084 ----------------------------
11085 -- New_Class_Wide_Subtype --
11086 ----------------------------
11088 function New_Class_Wide_Subtype
11089 (CW_Typ : Entity_Id;
11090 N : Node_Id) return Entity_Id
11092 Res : constant Entity_Id := Create_Itype (E_Void, N);
11094 -- Capture relevant attributes of the class-wide subtype which must be
11095 -- restored after the copy.
11097 Res_Chars : constant Name_Id := Chars (Res);
11098 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
11099 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
11100 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
11101 Res_Scope : constant Entity_Id := Scope (Res);
11104 Copy_Node (CW_Typ, Res);
11106 -- Restore the relevant attributes of the class-wide subtype
11108 Set_Chars (Res, Res_Chars);
11109 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
11110 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
11111 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
11112 Set_Scope (Res, Res_Scope);
11114 -- Decorate the class-wide subtype
11116 Set_Associated_Node_For_Itype (Res, N);
11117 Set_Comes_From_Source (Res, False);
11118 Mutate_Ekind (Res, E_Class_Wide_Subtype);
11119 Set_Etype (Res, Base_Type (CW_Typ));
11120 Set_Freeze_Node (Res, Empty);
11121 Set_Is_Frozen (Res, False);
11122 Set_Is_Itype (Res);
11123 Set_Is_Public (Res, False);
11124 Set_Next_Entity (Res, Empty);
11125 Set_Prev_Entity (Res, Empty);
11126 Set_Sloc (Res, Sloc (N));
11128 Set_Public_Status (Res);
11131 end New_Class_Wide_Subtype;
11133 -----------------------------------
11134 -- OK_To_Do_Constant_Replacement --
11135 -----------------------------------
11137 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
11138 ES : constant Entity_Id := Scope (E);
11142 -- Do not replace statically allocated objects, because they may be
11143 -- modified outside the current scope.
11145 if Is_Statically_Allocated (E) then
11148 -- Do not replace aliased or volatile objects, since we don't know what
11149 -- else might change the value.
11151 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
11154 -- Debug flag -gnatdM disconnects this optimization
11156 elsif Debug_Flag_MM then
11159 -- Otherwise check scopes
11162 CS := Current_Scope;
11165 -- If we are in right scope, replacement is safe
11170 -- Packages do not affect the determination of safety
11172 elsif Ekind (CS) = E_Package then
11173 exit when CS = Standard_Standard;
11176 -- Blocks do not affect the determination of safety
11178 elsif Ekind (CS) = E_Block then
11181 -- Loops do not affect the determination of safety. Note that we
11182 -- kill all current values on entry to a loop, so we are just
11183 -- talking about processing within a loop here.
11185 elsif Ekind (CS) = E_Loop then
11188 -- Otherwise, the reference is dubious, and we cannot be sure that
11189 -- it is safe to do the replacement.
11198 end OK_To_Do_Constant_Replacement;
11200 ------------------------------------
11201 -- Possible_Bit_Aligned_Component --
11202 ------------------------------------
11204 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
11206 -- Do not process an unanalyzed node because it is not yet decorated and
11207 -- most checks performed below will fail.
11209 if not Analyzed (N) then
11213 -- There are never alignment issues in CodePeer mode
11215 if CodePeer_Mode then
11221 -- Case of indexed component
11223 when N_Indexed_Component =>
11225 P : constant Node_Id := Prefix (N);
11226 Ptyp : constant Entity_Id := Etype (P);
11229 -- If we know the component size and it is not larger than the
11230 -- maximum integer size, then we are OK. The back end does the
11231 -- assignment of small misaligned objects correctly.
11233 if Known_Static_Component_Size (Ptyp)
11234 and then Component_Size (Ptyp) <= System_Max_Integer_Size
11238 -- Otherwise, we need to test the prefix, to see if we are
11239 -- indexing from a possibly unaligned component.
11242 return Possible_Bit_Aligned_Component (P);
11246 -- Case of selected component
11248 when N_Selected_Component =>
11250 P : constant Node_Id := Prefix (N);
11251 Comp : constant Entity_Id := Entity (Selector_Name (N));
11254 -- This is the crucial test: if the component itself causes
11255 -- trouble, then we can stop and return True.
11257 if Component_May_Be_Bit_Aligned (Comp) then
11260 -- Otherwise, we need to test the prefix, to see if we are
11261 -- selecting from a possibly unaligned component.
11264 return Possible_Bit_Aligned_Component (P);
11268 -- For a slice, test the prefix, if that is possibly misaligned,
11269 -- then for sure the slice is.
11272 return Possible_Bit_Aligned_Component (Prefix (N));
11274 -- For an unchecked conversion, check whether the expression may
11277 when N_Unchecked_Type_Conversion =>
11278 return Possible_Bit_Aligned_Component (Expression (N));
11280 -- If we have none of the above, it means that we have fallen off the
11281 -- top testing prefixes recursively, and we now have a stand alone
11282 -- object, where we don't have a problem, unless this is a renaming,
11283 -- in which case we need to look into the renamed object.
11286 if Is_Entity_Name (N)
11287 and then Present (Renamed_Object (Entity (N)))
11290 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
11295 end Possible_Bit_Aligned_Component;
11297 -----------------------------------------------
11298 -- Process_Statements_For_Controlled_Objects --
11299 -----------------------------------------------
11301 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
11302 Loc : constant Source_Ptr := Sloc (N);
11304 function Are_Wrapped (L : List_Id) return Boolean;
11305 -- Determine whether list L contains only one statement which is a block
11307 function Wrap_Statements_In_Block
11309 Scop : Entity_Id := Current_Scope) return Node_Id;
11310 -- Given a list of statements L, wrap it in a block statement and return
11311 -- the generated node. Scop is either the current scope or the scope of
11312 -- the context (if applicable).
11318 function Are_Wrapped (L : List_Id) return Boolean is
11319 Stmt : constant Node_Id := First (L);
11323 and then No (Next (Stmt))
11324 and then Nkind (Stmt) = N_Block_Statement;
11327 ------------------------------
11328 -- Wrap_Statements_In_Block --
11329 ------------------------------
11331 function Wrap_Statements_In_Block
11333 Scop : Entity_Id := Current_Scope) return Node_Id
11335 Block_Id : Entity_Id;
11336 Block_Nod : Node_Id;
11337 Iter_Loop : Entity_Id;
11341 Make_Block_Statement (Loc,
11342 Declarations => No_List,
11343 Handled_Statement_Sequence =>
11344 Make_Handled_Sequence_Of_Statements (Loc,
11347 -- Create a label for the block in case the block needs to manage the
11348 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
11350 Add_Block_Identifier (Block_Nod, Block_Id);
11352 -- When wrapping the statements of an iterator loop, check whether
11353 -- the loop requires secondary stack management and if so, propagate
11354 -- the appropriate flags to the block. This ensures that the cursor
11355 -- is properly cleaned up at each iteration of the loop.
11357 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
11359 if Present (Iter_Loop) then
11360 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
11362 -- Secondary stack reclamation is suppressed when the associated
11363 -- iterator loop contains a return statement which uses the stack.
11365 Set_Sec_Stack_Needed_For_Return
11366 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
11370 end Wrap_Statements_In_Block;
11376 -- Start of processing for Process_Statements_For_Controlled_Objects
11379 -- Whenever a non-handled statement list is wrapped in a block, the
11380 -- block must be explicitly analyzed to redecorate all entities in the
11381 -- list and ensure that a finalizer is properly built.
11384 when N_Conditional_Entry_Call
11387 | N_Selective_Accept
11389 -- Check the "then statements" for elsif parts and if statements
11391 if Nkind (N) in N_Elsif_Part | N_If_Statement
11392 and then not Is_Empty_List (Then_Statements (N))
11393 and then not Are_Wrapped (Then_Statements (N))
11394 and then Requires_Cleanup_Actions
11395 (L => Then_Statements (N),
11396 Lib_Level => False,
11397 Nested_Constructs => False)
11399 Block := Wrap_Statements_In_Block (Then_Statements (N));
11400 Set_Then_Statements (N, New_List (Block));
11405 -- Check the "else statements" for conditional entry calls, if
11406 -- statements and selective accepts.
11409 N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept
11410 and then not Is_Empty_List (Else_Statements (N))
11411 and then not Are_Wrapped (Else_Statements (N))
11412 and then Requires_Cleanup_Actions
11413 (L => Else_Statements (N),
11414 Lib_Level => False,
11415 Nested_Constructs => False)
11417 Block := Wrap_Statements_In_Block (Else_Statements (N));
11418 Set_Else_Statements (N, New_List (Block));
11423 when N_Abortable_Part
11424 | N_Accept_Alternative
11425 | N_Case_Statement_Alternative
11426 | N_Delay_Alternative
11427 | N_Entry_Call_Alternative
11428 | N_Exception_Handler
11430 | N_Triggering_Alternative
11432 if not Is_Empty_List (Statements (N))
11433 and then not Are_Wrapped (Statements (N))
11434 and then Requires_Cleanup_Actions
11435 (L => Statements (N),
11436 Lib_Level => False,
11437 Nested_Constructs => False)
11439 if Nkind (N) = N_Loop_Statement
11440 and then Present (Identifier (N))
11443 Wrap_Statements_In_Block
11444 (L => Statements (N),
11445 Scop => Entity (Identifier (N)));
11447 Block := Wrap_Statements_In_Block (Statements (N));
11450 Set_Statements (N, New_List (Block));
11454 -- Could be e.g. a loop that was transformed into a block or null
11455 -- statement. Do nothing for terminate alternatives.
11457 when N_Block_Statement
11459 | N_Terminate_Alternative
11464 raise Program_Error;
11466 end Process_Statements_For_Controlled_Objects;
11472 function Power_Of_Two (N : Node_Id) return Nat is
11473 Typ : constant Entity_Id := Etype (N);
11474 pragma Assert (Is_Integer_Type (Typ));
11476 Siz : constant Nat := UI_To_Int (Esize (Typ));
11480 if not Compile_Time_Known_Value (N) then
11484 Val := Expr_Value (N);
11485 for J in 1 .. Siz - 1 loop
11486 if Val = Uint_2 ** J then
11495 ----------------------
11496 -- Remove_Init_Call --
11497 ----------------------
11499 function Remove_Init_Call
11501 Rep_Clause : Node_Id) return Node_Id
11503 Par : constant Node_Id := Parent (Var);
11504 Typ : constant Entity_Id := Etype (Var);
11506 Init_Proc : Entity_Id;
11507 -- Initialization procedure for Typ
11509 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
11510 -- Look for init call for Var starting at From and scanning the
11511 -- enclosing list until Rep_Clause or the end of the list is reached.
11513 ----------------------------
11514 -- Find_Init_Call_In_List --
11515 ----------------------------
11517 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
11518 Init_Call : Node_Id;
11522 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
11523 if Nkind (Init_Call) = N_Procedure_Call_Statement
11524 and then Is_Entity_Name (Name (Init_Call))
11525 and then Entity (Name (Init_Call)) = Init_Proc
11534 end Find_Init_Call_In_List;
11536 Init_Call : Node_Id;
11538 -- Start of processing for Remove_Init_Call
11541 if Present (Initialization_Statements (Var)) then
11542 Init_Call := Initialization_Statements (Var);
11543 Set_Initialization_Statements (Var, Empty);
11545 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
11547 -- No init proc for the type, so obviously no call to be found
11552 -- We might be able to handle other cases below by just properly
11553 -- setting Initialization_Statements at the point where the init proc
11554 -- call is generated???
11556 Init_Proc := Base_Init_Proc (Typ);
11558 -- First scan the list containing the declaration of Var
11560 Init_Call := Find_Init_Call_In_List (From => Next (Par));
11562 -- If not found, also look on Var's freeze actions list, if any,
11563 -- since the init call may have been moved there (case of an address
11564 -- clause applying to Var).
11566 if No (Init_Call) and then Present (Freeze_Node (Var)) then
11568 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
11571 -- If the initialization call has actuals that use the secondary
11572 -- stack, the call may have been wrapped into a temporary block, in
11573 -- which case the block itself has to be removed.
11575 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
11577 Blk : constant Node_Id := Next (Par);
11580 (Find_Init_Call_In_List
11581 (First (Statements (Handled_Statement_Sequence (Blk)))))
11589 if Present (Init_Call) then
11590 -- If restrictions have forbidden Aborts, the initialization call
11591 -- for objects that require deep initialization has not been wrapped
11592 -- into the following block (see Exp_Ch3, Default_Initialize_Object)
11593 -- so if present remove it as well, and include the IP call in it,
11594 -- in the rare case the caller may need to simply displace the
11595 -- initialization, as is done for a later address specification.
11597 if Nkind (Next (Init_Call)) = N_Block_Statement
11598 and then Is_Initialization_Block (Next (Init_Call))
11601 IP_Call : constant Node_Id := Init_Call;
11603 Init_Call := Next (IP_Call);
11606 Statements (Handled_Statement_Sequence (Init_Call)));
11610 Remove (Init_Call);
11614 end Remove_Init_Call;
11616 -------------------------
11617 -- Remove_Side_Effects --
11618 -------------------------
11620 procedure Remove_Side_Effects
11622 Name_Req : Boolean := False;
11623 Renaming_Req : Boolean := False;
11624 Variable_Ref : Boolean := False;
11625 Related_Id : Entity_Id := Empty;
11626 Is_Low_Bound : Boolean := False;
11627 Is_High_Bound : Boolean := False;
11628 Check_Side_Effects : Boolean := True)
11630 function Build_Temporary
11633 Related_Nod : Node_Id := Empty) return Entity_Id;
11634 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
11635 -- is present (xxx is taken from the Chars field of Related_Nod),
11636 -- otherwise it generates an internal temporary. The created temporary
11637 -- entity is marked as internal.
11639 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean;
11640 -- Computes whether a side effect is possible in SPARK, which should
11641 -- be handled by removing it from the expression for GNATprove. Note
11642 -- that other side effects related to volatile variables are handled
11645 ---------------------
11646 -- Build_Temporary --
11647 ---------------------
11649 function Build_Temporary
11652 Related_Nod : Node_Id := Empty) return Entity_Id
11654 Temp_Id : Entity_Id;
11655 Temp_Nam : Name_Id;
11658 -- The context requires an external symbol
11660 if Present (Related_Id) then
11661 if Is_Low_Bound then
11662 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
11663 else pragma Assert (Is_High_Bound);
11664 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
11667 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
11669 -- Otherwise generate an internal temporary
11672 Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
11675 Set_Is_Internal (Temp_Id);
11678 end Build_Temporary;
11680 -----------------------------------
11681 -- Possible_Side_Effect_In_SPARK --
11682 -----------------------------------
11684 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean is
11686 -- Side-effect removal in SPARK should only occur when not inside a
11687 -- generic and not doing a preanalysis, inside an object renaming or
11688 -- a type declaration or a for-loop iteration scheme.
11690 return not Inside_A_Generic
11691 and then Full_Analysis
11692 and then Nkind (Enclosing_Declaration (Exp)) in
11693 N_Component_Declaration
11694 | N_Full_Type_Declaration
11695 | N_Iterator_Specification
11696 | N_Loop_Parameter_Specification
11697 | N_Object_Renaming_Declaration
11698 | N_Subtype_Declaration;
11699 end Possible_Side_Effect_In_SPARK;
11703 Loc : constant Source_Ptr := Sloc (Exp);
11704 Exp_Type : constant Entity_Id := Etype (Exp);
11705 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
11706 Def_Id : Entity_Id;
11709 Ptr_Typ_Decl : Node_Id;
11710 Ref_Type : Entity_Id;
11713 -- Start of processing for Remove_Side_Effects
11716 -- Handle cases in which there is nothing to do. In GNATprove mode,
11717 -- removal of side effects is useful for the light expansion of
11720 if not Expander_Active
11722 (GNATprove_Mode and then Possible_Side_Effect_In_SPARK (Exp))
11726 -- Cannot generate temporaries if the invocation to remove side effects
11727 -- was issued too early and the type of the expression is not resolved
11728 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
11729 -- Remove_Side_Effects).
11731 elsif No (Exp_Type)
11732 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11736 -- Nothing to do if prior expansion determined that a function call does
11737 -- not require side effect removal.
11739 elsif Nkind (Exp) = N_Function_Call
11740 and then No_Side_Effect_Removal (Exp)
11744 -- No action needed for side-effect free expressions
11746 elsif Check_Side_Effects
11747 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11751 -- Generating C code we cannot remove side effect of function returning
11752 -- class-wide types since there is no secondary stack (required to use
11755 elsif Modify_Tree_For_C
11756 and then Nkind (Exp) = N_Function_Call
11757 and then Is_Class_Wide_Type (Etype (Exp))
11762 -- The remaining processing is done with all checks suppressed
11764 -- Note: from now on, don't use return statements, instead do a goto
11765 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11767 Scope_Suppress.Suppress := (others => True);
11769 -- If this is a side-effect free attribute reference whose expressions
11770 -- are also side-effect free and whose prefix is not a name, remove the
11771 -- side effects of the prefix. A copy of the prefix is required in this
11772 -- case and it is better not to make an additional one for the attribute
11773 -- itself, because the return type of many of them is universal integer,
11774 -- which is a very large type for a temporary.
11776 if Nkind (Exp) = N_Attribute_Reference
11777 and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
11778 and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
11779 and then not Is_Name_Reference (Prefix (Exp))
11781 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11784 -- If this is an elementary or a small not-by-reference record type, and
11785 -- we need to capture the value, just make a constant; this is cheap and
11786 -- objects of both kinds of types can be bit aligned, so it might not be
11787 -- possible to generate a reference to them. Likewise if this is not a
11788 -- name reference, except for a type conversion, because we would enter
11789 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11790 -- type has predicates (and type conversions need a specific treatment
11791 -- anyway, see below). Also do it if we have a volatile reference and
11792 -- Name_Req is not set (see comments for Side_Effect_Free).
11794 elsif (Is_Elementary_Type (Exp_Type)
11795 or else (Is_Record_Type (Exp_Type)
11796 and then Known_Static_RM_Size (Exp_Type)
11797 and then RM_Size (Exp_Type) <= System_Max_Integer_Size
11798 and then not Has_Discriminants (Exp_Type)
11799 and then not Is_By_Reference_Type (Exp_Type)))
11800 and then (Variable_Ref
11801 or else (not Is_Name_Reference (Exp)
11802 and then Nkind (Exp) /= N_Type_Conversion)
11803 or else (not Name_Req
11804 and then Is_Volatile_Reference (Exp)))
11806 Def_Id := Build_Temporary (Loc, 'R', Exp);
11807 Set_Etype (Def_Id, Exp_Type);
11808 Res := New_Occurrence_Of (Def_Id, Loc);
11810 -- If the expression is a packed reference, it must be reanalyzed and
11811 -- expanded, depending on context. This is the case for actuals where
11812 -- a constraint check may capture the actual before expansion of the
11813 -- call is complete.
11815 if Nkind (Exp) = N_Indexed_Component
11816 and then Is_Packed (Etype (Prefix (Exp)))
11818 Set_Analyzed (Exp, False);
11819 Set_Analyzed (Prefix (Exp), False);
11823 -- Rnn : Exp_Type renames Expr;
11825 -- In GNATprove mode, we prefer to use renamings for intermediate
11826 -- variables to definition of constants, due to the implicit move
11827 -- operation that such a constant definition causes as part of the
11828 -- support in GNATprove for ownership pointers. Hence, we generate
11829 -- a renaming for a reference to an object of a nonscalar type.
11832 or else (GNATprove_Mode
11833 and then Is_Object_Reference (Exp)
11834 and then not Is_Scalar_Type (Exp_Type))
11837 Make_Object_Renaming_Declaration (Loc,
11838 Defining_Identifier => Def_Id,
11839 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11840 Name => Relocate_Node (Exp));
11843 -- Rnn : constant Exp_Type := Expr;
11847 Make_Object_Declaration (Loc,
11848 Defining_Identifier => Def_Id,
11849 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11850 Constant_Present => True,
11851 Expression => Relocate_Node (Exp));
11853 Set_Assignment_OK (E);
11856 Insert_Action (Exp, E);
11858 -- If the expression has the form v.all then we can just capture the
11859 -- pointer, and then do an explicit dereference on the result, but
11860 -- this is not right if this is a volatile reference.
11862 elsif Nkind (Exp) = N_Explicit_Dereference
11863 and then not Is_Volatile_Reference (Exp)
11865 Def_Id := Build_Temporary (Loc, 'R', Exp);
11867 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
11869 Insert_Action (Exp,
11870 Make_Object_Declaration (Loc,
11871 Defining_Identifier => Def_Id,
11872 Object_Definition =>
11873 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
11874 Constant_Present => True,
11875 Expression => Relocate_Node (Prefix (Exp))));
11877 -- Similar processing for an unchecked conversion of an expression of
11878 -- the form v.all, where we want the same kind of treatment.
11880 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11881 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
11883 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11886 -- If this is a type conversion, leave the type conversion and remove
11887 -- side effects in the expression, unless it is of universal integer,
11888 -- which is a very large type for a temporary. This is important in
11889 -- several circumstances: for change of representations and also when
11890 -- this is a view conversion to a smaller object, where gigi can end
11891 -- up creating its own temporary of the wrong size.
11893 elsif Nkind (Exp) = N_Type_Conversion
11894 and then Etype (Expression (Exp)) /= Universal_Integer
11896 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11898 -- Generating C code the type conversion of an access to constrained
11899 -- array type into an access to unconstrained array type involves
11900 -- initializing a fat pointer and the expression must be free of
11901 -- side effects to safely compute its bounds.
11903 if Modify_Tree_For_C
11904 and then Is_Access_Type (Etype (Exp))
11905 and then Is_Array_Type (Designated_Type (Etype (Exp)))
11906 and then not Is_Constrained (Designated_Type (Etype (Exp)))
11908 Def_Id := Build_Temporary (Loc, 'R', Exp);
11909 Set_Etype (Def_Id, Exp_Type);
11910 Res := New_Occurrence_Of (Def_Id, Loc);
11912 Insert_Action (Exp,
11913 Make_Object_Declaration (Loc,
11914 Defining_Identifier => Def_Id,
11915 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11916 Constant_Present => True,
11917 Expression => Relocate_Node (Exp)));
11922 -- If this is an unchecked conversion that Gigi can't handle, make
11923 -- a copy or a use a renaming to capture the value.
11925 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11926 and then not Safe_Unchecked_Type_Conversion (Exp)
11928 if CW_Or_Has_Controlled_Part (Exp_Type) then
11930 -- Use a renaming to capture the expression, rather than create
11931 -- a controlled temporary.
11933 Def_Id := Build_Temporary (Loc, 'R', Exp);
11934 Res := New_Occurrence_Of (Def_Id, Loc);
11936 Insert_Action (Exp,
11937 Make_Object_Renaming_Declaration (Loc,
11938 Defining_Identifier => Def_Id,
11939 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11940 Name => Relocate_Node (Exp)));
11943 Def_Id := Build_Temporary (Loc, 'R', Exp);
11944 Set_Etype (Def_Id, Exp_Type);
11945 Res := New_Occurrence_Of (Def_Id, Loc);
11948 Make_Object_Declaration (Loc,
11949 Defining_Identifier => Def_Id,
11950 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11951 Constant_Present => not Is_Variable (Exp),
11952 Expression => Relocate_Node (Exp));
11954 Set_Assignment_OK (E);
11955 Insert_Action (Exp, E);
11958 -- If this is a packed array component or a selected component with a
11959 -- nonstandard representation, we cannot generate a reference because
11960 -- the component may be unaligned, so we must use a renaming and this
11961 -- renaming is handled by the front end, as the back end may balk at
11962 -- the nonstandard representation (see Evaluation_Required in Exp_Ch8).
11964 elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
11965 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
11967 Def_Id := Build_Temporary (Loc, 'R', Exp);
11968 Res := New_Occurrence_Of (Def_Id, Loc);
11970 Insert_Action (Exp,
11971 Make_Object_Renaming_Declaration (Loc,
11972 Defining_Identifier => Def_Id,
11973 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11974 Name => Relocate_Node (Exp)));
11976 -- For an expression that denotes a name, we can use a renaming scheme.
11977 -- This is needed for correctness in the case of a volatile object of
11978 -- a nonvolatile type because the Make_Reference call of the "default"
11979 -- approach would generate an illegal access value (an access value
11980 -- cannot designate such an object - see Analyze_Reference).
11982 elsif Is_Name_Reference (Exp)
11984 -- We skip using this scheme if we have an object of a volatile
11985 -- type and we do not have Name_Req set true (see comments for
11986 -- Side_Effect_Free).
11988 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
11990 Def_Id := Build_Temporary (Loc, 'R', Exp);
11991 Res := New_Occurrence_Of (Def_Id, Loc);
11993 Insert_Action (Exp,
11994 Make_Object_Renaming_Declaration (Loc,
11995 Defining_Identifier => Def_Id,
11996 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11997 Name => Relocate_Node (Exp)));
11999 -- Avoid generating a variable-sized temporary, by generating the
12000 -- reference just for the function call. The transformation could be
12001 -- refined to apply only when the array component is constrained by a
12004 elsif Nkind (Exp) = N_Selected_Component
12005 and then Nkind (Prefix (Exp)) = N_Function_Call
12006 and then Is_Array_Type (Exp_Type)
12008 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
12011 -- Otherwise we generate a reference to the expression
12014 -- When generating C code we cannot consider side effect free object
12015 -- declarations that have discriminants and are initialized by means
12016 -- of a function call since on this target there is no secondary
12017 -- stack to store the return value and the expander may generate an
12018 -- extra call to the function to compute the discriminant value. In
12019 -- addition, for targets that have secondary stack, the expansion of
12020 -- functions with side effects involves the generation of an access
12021 -- type to capture the return value stored in the secondary stack;
12022 -- by contrast when generating C code such expansion generates an
12023 -- internal object declaration (no access type involved) which must
12024 -- be identified here to avoid entering into a never-ending loop
12025 -- generating internal object declarations.
12027 if Modify_Tree_For_C
12028 and then Nkind (Parent (Exp)) = N_Object_Declaration
12030 (Nkind (Exp) /= N_Function_Call
12031 or else not Has_Discriminants (Exp_Type)
12032 or else Is_Internal_Name
12033 (Chars (Defining_Identifier (Parent (Exp)))))
12038 -- Special processing for function calls that return a limited type.
12039 -- We need to build a declaration that will enable build-in-place
12040 -- expansion of the call. This is not done if the context is already
12041 -- an object declaration, to prevent infinite recursion.
12043 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
12044 -- to accommodate functions returning limited objects by reference.
12046 if Ada_Version >= Ada_2005
12047 and then Nkind (Exp) = N_Function_Call
12048 and then Is_Limited_View (Etype (Exp))
12049 and then Nkind (Parent (Exp)) /= N_Object_Declaration
12052 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
12057 Make_Object_Declaration (Loc,
12058 Defining_Identifier => Obj,
12059 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
12060 Expression => Relocate_Node (Exp));
12062 Insert_Action (Exp, Decl);
12063 Set_Etype (Obj, Exp_Type);
12064 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
12069 Def_Id := Build_Temporary (Loc, 'R', Exp);
12071 -- The regular expansion of functions with side effects involves the
12072 -- generation of an access type to capture the return value found on
12073 -- the secondary stack. Since SPARK (and why) cannot process access
12074 -- types, use a different approach which ignores the secondary stack
12075 -- and "copies" the returned object.
12076 -- When generating C code, no need for a 'reference since the
12077 -- secondary stack is not supported.
12079 if GNATprove_Mode or Modify_Tree_For_C then
12080 Res := New_Occurrence_Of (Def_Id, Loc);
12081 Ref_Type := Exp_Type;
12083 -- Regular expansion utilizing an access type and 'reference
12087 Make_Explicit_Dereference (Loc,
12088 Prefix => New_Occurrence_Of (Def_Id, Loc));
12091 -- type Ann is access all <Exp_Type>;
12093 Ref_Type := Make_Temporary (Loc, 'A');
12096 Make_Full_Type_Declaration (Loc,
12097 Defining_Identifier => Ref_Type,
12099 Make_Access_To_Object_Definition (Loc,
12100 All_Present => True,
12101 Subtype_Indication =>
12102 New_Occurrence_Of (Exp_Type, Loc)));
12104 Insert_Action (Exp, Ptr_Typ_Decl);
12108 if Nkind (E) = N_Explicit_Dereference then
12109 New_Exp := Relocate_Node (Prefix (E));
12112 E := Relocate_Node (E);
12114 -- Do not generate a 'reference in SPARK mode or C generation
12115 -- since the access type is not created in the first place.
12117 if GNATprove_Mode or Modify_Tree_For_C then
12120 -- Otherwise generate reference, marking the value as non-null
12121 -- since we know it cannot be null and we don't want a check.
12124 New_Exp := Make_Reference (Loc, E);
12125 Set_Is_Known_Non_Null (Def_Id);
12129 if Is_Delayed_Aggregate (E) then
12131 -- The expansion of nested aggregates is delayed until the
12132 -- enclosing aggregate is expanded. As aggregates are often
12133 -- qualified, the predicate applies to qualified expressions as
12134 -- well, indicating that the enclosing aggregate has not been
12135 -- expanded yet. At this point the aggregate is part of a
12136 -- stand-alone declaration, and must be fully expanded.
12138 if Nkind (E) = N_Qualified_Expression then
12139 Set_Expansion_Delayed (Expression (E), False);
12140 Set_Analyzed (Expression (E), False);
12142 Set_Expansion_Delayed (E, False);
12145 Set_Analyzed (E, False);
12148 -- Generating C code of object declarations that have discriminants
12149 -- and are initialized by means of a function call we propagate the
12150 -- discriminants of the parent type to the internally built object.
12151 -- This is needed to avoid generating an extra call to the called
12154 -- For example, if we generate here the following declaration, it
12155 -- will be expanded later adding an extra call to evaluate the value
12156 -- of the discriminant (needed to compute the size of the object).
12158 -- type Rec (D : Integer) is ...
12159 -- Obj : constant Rec := SomeFunc;
12161 if Modify_Tree_For_C
12162 and then Nkind (Parent (Exp)) = N_Object_Declaration
12163 and then Has_Discriminants (Exp_Type)
12164 and then Nkind (Exp) = N_Function_Call
12166 Insert_Action (Exp,
12167 Make_Object_Declaration (Loc,
12168 Defining_Identifier => Def_Id,
12169 Object_Definition => New_Copy_Tree
12170 (Object_Definition (Parent (Exp))),
12171 Constant_Present => True,
12172 Expression => New_Exp));
12174 Insert_Action (Exp,
12175 Make_Object_Declaration (Loc,
12176 Defining_Identifier => Def_Id,
12177 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
12178 Constant_Present => True,
12179 Expression => New_Exp));
12183 -- Preserve the Assignment_OK flag in all copies, since at least one
12184 -- copy may be used in a context where this flag must be set (otherwise
12185 -- why would the flag be set in the first place).
12187 Set_Assignment_OK (Res, Assignment_OK (Exp));
12189 -- Preserve the Do_Range_Check flag in all copies
12191 Set_Do_Range_Check (Res, Do_Range_Check (Exp));
12193 -- Finally rewrite the original expression and we are done
12195 Rewrite (Exp, Res);
12196 Analyze_And_Resolve (Exp, Exp_Type);
12199 Scope_Suppress := Svg_Suppress;
12200 end Remove_Side_Effects;
12202 ------------------------
12203 -- Replace_References --
12204 ------------------------
12206 procedure Replace_References
12208 Par_Typ : Entity_Id;
12209 Deriv_Typ : Entity_Id;
12210 Par_Obj : Entity_Id := Empty;
12211 Deriv_Obj : Entity_Id := Empty)
12213 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
12214 -- Determine whether node Ref denotes some component of Deriv_Obj
12216 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
12217 -- Substitute a reference to an entity with the corresponding value
12218 -- stored in table Type_Map.
12220 function Type_Of_Formal
12222 Actual : Node_Id) return Entity_Id;
12223 -- Find the type of the formal parameter which corresponds to actual
12224 -- parameter Actual in subprogram call Call.
12226 ----------------------
12227 -- Is_Deriv_Obj_Ref --
12228 ----------------------
12230 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
12231 Par : constant Node_Id := Parent (Ref);
12234 -- Detect the folowing selected component form:
12236 -- Deriv_Obj.(something)
12239 Nkind (Par) = N_Selected_Component
12240 and then Is_Entity_Name (Prefix (Par))
12241 and then Entity (Prefix (Par)) = Deriv_Obj;
12242 end Is_Deriv_Obj_Ref;
12248 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
12249 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
12250 -- Reset the Controlling_Argument of all function calls that
12251 -- encapsulate node From_Arg.
12253 ----------------------------------
12254 -- Remove_Controlling_Arguments --
12255 ----------------------------------
12257 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
12262 while Present (Par) loop
12263 if Nkind (Par) = N_Function_Call
12264 and then Present (Controlling_Argument (Par))
12266 Set_Controlling_Argument (Par, Empty);
12268 -- Prevent the search from going too far
12270 elsif Is_Body_Or_Package_Declaration (Par) then
12274 Par := Parent (Par);
12276 end Remove_Controlling_Arguments;
12280 Context : constant Node_Id := 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 Nkind (Parent (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;