1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Elists; use Elists;
33 with Errout; use Errout;
34 with Exp_Aggr; use Exp_Aggr;
35 with Exp_Ch2; use Exp_Ch2;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch11; use Exp_Ch11;
39 with Ghost; use Ghost;
40 with Inline; use Inline;
41 with Itypes; use Itypes;
43 with Nlists; use Nlists;
44 with Nmake; use Nmake;
46 with Restrict; use Restrict;
47 with Rident; use Rident;
49 with Sem_Aux; use Sem_Aux;
50 with Sem_Ch3; use Sem_Ch3;
51 with Sem_Ch6; use Sem_Ch6;
52 with Sem_Ch8; use Sem_Ch8;
53 with Sem_Ch12; use Sem_Ch12;
54 with Sem_Ch13; use Sem_Ch13;
55 with Sem_Disp; use Sem_Disp;
56 with Sem_Elab; use Sem_Elab;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Res; use Sem_Res;
59 with Sem_Type; use Sem_Type;
60 with Sem_Util; use Sem_Util;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Stringt; use Stringt;
64 with Targparm; use Targparm;
65 with Tbuild; use Tbuild;
66 with Ttypes; use Ttypes;
67 with Urealp; use Urealp;
68 with Validsw; use Validsw;
71 package body Exp_Util is
73 ---------------------------------------------------------
74 -- Handling of inherited class-wide pre/postconditions --
75 ---------------------------------------------------------
77 -- Following AI12-0113, the expression for a class-wide condition is
78 -- transformed for a subprogram that inherits it, by replacing calls
79 -- to primitive operations of the original controlling type into the
80 -- corresponding overriding operations of the derived type. The following
81 -- hash table manages this mapping, and is expanded on demand whenever
82 -- such inherited expression needs to be constructed.
84 -- The mapping is also used to check whether an inherited operation has
85 -- a condition that depends on overridden operations. For such an
86 -- operation we must create a wrapper that is then treated as a normal
87 -- overriding. In SPARK mode such operations are illegal.
89 -- For a given root type there may be several type extensions with their
90 -- own overriding operations, so at various times a given operation of
91 -- the root will be mapped into different overridings. The root type is
92 -- also mapped into the current type extension to indicate that its
93 -- operations are mapped into the overriding operations of that current
96 -- The contents of the map are as follows:
100 -- Discriminant (Entity_Id) Discriminant (Entity_Id)
101 -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
102 -- Discriminant (Entity_Id) Expression (Node_Id)
103 -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
104 -- Type (Entity_Id) Type (Entity_Id)
106 Type_Map_Size : constant := 511;
108 subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
109 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
111 package Type_Map is new GNAT.HTable.Simple_HTable
112 (Header_Num => Type_Map_Header,
114 Element => Node_Or_Entity_Id,
116 Hash => Type_Map_Hash,
119 -----------------------
120 -- Local Subprograms --
121 -----------------------
123 function Build_Task_Array_Image
127 Dyn : Boolean := False) return Node_Id;
128 -- Build function to generate the image string for a task that is an array
129 -- component, concatenating the images of each index. To avoid storage
130 -- leaks, the string is built with successive slice assignments. The flag
131 -- Dyn indicates whether this is called for the initialization procedure of
132 -- an array of tasks, or for the name of a dynamically created task that is
133 -- assigned to an indexed component.
135 function Build_Task_Image_Function
139 Res : Entity_Id) return Node_Id;
140 -- Common processing for Task_Array_Image and Task_Record_Image. Build
141 -- function body that computes image.
143 procedure Build_Task_Image_Prefix
152 -- Common processing for Task_Array_Image and Task_Record_Image. Create
153 -- local variables and assign prefix of name to result string.
155 function Build_Task_Record_Image
158 Dyn : Boolean := False) return Node_Id;
159 -- Build function to generate the image string for a task that is a record
160 -- component. Concatenate name of variable with that of selector. The flag
161 -- Dyn indicates whether this is called for the initialization procedure of
162 -- record with task components, or for a dynamically created task that is
163 -- assigned to a selected component.
165 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
166 -- Force evaluation of bounds of a slice, which may be given by a range
167 -- or by a subtype indication with or without a constraint.
169 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
170 -- Determine whether pragma Default_Initial_Condition denoted by Prag has
171 -- an assertion expression that should be verified at run time.
173 function Make_CW_Equivalent_Type
175 E : Node_Id) return Entity_Id;
176 -- T is a class-wide type entity, E is the initial expression node that
177 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
178 -- returns the entity of the Equivalent type and inserts on the fly the
179 -- necessary declaration such as:
181 -- type anon is record
182 -- _parent : Root_Type (T); constrained with E discriminants (if any)
183 -- Extension : String (1 .. expr to match size of E);
186 -- This record is compatible with any object of the class of T thanks to
187 -- the first field and has the same size as E thanks to the second.
189 function Make_Literal_Range
191 Literal_Typ : Entity_Id) return Node_Id;
192 -- Produce a Range node whose bounds are:
193 -- Low_Bound (Literal_Type) ..
194 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
195 -- this is used for expanding declarations like X : String := "sdfgdfg";
197 -- If the index type of the target array is not integer, we generate:
198 -- Low_Bound (Literal_Type) ..
200 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
201 -- + (Length (Literal_Typ) -1))
203 function Make_Non_Empty_Check
205 N : Node_Id) return Node_Id;
206 -- Produce a boolean expression checking that the unidimensional array
207 -- node N is not empty.
209 function New_Class_Wide_Subtype
211 N : Node_Id) return Entity_Id;
212 -- Create an implicit subtype of CW_Typ attached to node N
214 function Requires_Cleanup_Actions
217 Nested_Constructs : Boolean) return Boolean;
218 -- Given a list L, determine whether it contains one of the following:
220 -- 1) controlled objects
221 -- 2) library-level tagged types
223 -- Lib_Level is True when the list comes from a construct at the library
224 -- level, and False otherwise. Nested_Constructs is True when any nested
225 -- packages declared in L must be processed, and False otherwise.
227 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean;
228 -- Return True if the evaluation of the given attribute is considered
229 -- side-effect free, independently of its prefix and expressions.
231 -------------------------------------
232 -- Activate_Atomic_Synchronization --
233 -------------------------------------
235 procedure Activate_Atomic_Synchronization (N : Node_Id) is
239 case Nkind (Parent (N)) is
241 -- Check for cases of appearing in the prefix of a construct where we
242 -- don't need atomic synchronization for this kind of usage.
245 -- Nothing to do if we are the prefix of an attribute, since we
246 -- do not want an atomic sync operation for things like 'Size.
248 N_Attribute_Reference
250 -- The N_Reference node is like an attribute
254 -- Nothing to do for a reference to a component (or components)
255 -- of a composite object. Only reads and updates of the object
256 -- as a whole require atomic synchronization (RM C.6 (15)).
258 | N_Indexed_Component
259 | N_Selected_Component
262 -- For all the above cases, nothing to do if we are the prefix
264 if Prefix (Parent (N)) = N then
272 -- Nothing to do for the identifier in an object renaming declaration,
273 -- the renaming itself does not need atomic synchronization.
275 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
279 -- Go ahead and set the flag
281 Set_Atomic_Sync_Required (N);
283 -- Generate info message if requested
285 if Warn_On_Atomic_Synchronization then
291 | N_Selected_Component
293 Msg_Node := Selector_Name (N);
295 when N_Explicit_Dereference
296 | N_Indexed_Component
301 pragma Assert (False);
305 if Present (Msg_Node) then
307 ("info: atomic synchronization set for &?N?", Msg_Node);
310 ("info: atomic synchronization set?N?", N);
313 end Activate_Atomic_Synchronization;
315 ----------------------
316 -- Adjust_Condition --
317 ----------------------
319 procedure Adjust_Condition (N : Node_Id) is
326 Loc : constant Source_Ptr := Sloc (N);
327 T : constant Entity_Id := Etype (N);
331 -- Defend against a call where the argument has no type, or has a
332 -- type that is not Boolean. This can occur because of prior errors.
334 if No (T) or else not Is_Boolean_Type (T) then
338 -- Apply validity checking if needed
340 if Validity_Checks_On and Validity_Check_Tests then
344 -- Immediate return if standard boolean, the most common case,
345 -- where nothing needs to be done.
347 if Base_Type (T) = Standard_Boolean then
351 -- Case of zero/nonzero semantics or nonstandard enumeration
352 -- representation. In each case, we rewrite the node as:
354 -- ityp!(N) /= False'Enum_Rep
356 -- where ityp is an integer type with large enough size to hold any
359 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
360 if Esize (T) <= Esize (Standard_Integer) then
361 Ti := Standard_Integer;
363 Ti := Standard_Long_Long_Integer;
368 Left_Opnd => Unchecked_Convert_To (Ti, N),
370 Make_Attribute_Reference (Loc,
371 Attribute_Name => Name_Enum_Rep,
373 New_Occurrence_Of (First_Literal (T), Loc))));
374 Analyze_And_Resolve (N, Standard_Boolean);
377 Rewrite (N, Convert_To (Standard_Boolean, N));
378 Analyze_And_Resolve (N, Standard_Boolean);
381 end Adjust_Condition;
383 ------------------------
384 -- Adjust_Result_Type --
385 ------------------------
387 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
389 -- Ignore call if current type is not Standard.Boolean
391 if Etype (N) /= Standard_Boolean then
395 -- If result is already of correct type, nothing to do. Note that
396 -- this will get the most common case where everything has a type
397 -- of Standard.Boolean.
399 if Base_Type (T) = Standard_Boolean then
404 KP : constant Node_Kind := Nkind (Parent (N));
407 -- If result is to be used as a Condition in the syntax, no need
408 -- to convert it back, since if it was changed to Standard.Boolean
409 -- using Adjust_Condition, that is just fine for this usage.
411 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
414 -- If result is an operand of another logical operation, no need
415 -- to reset its type, since Standard.Boolean is just fine, and
416 -- such operations always do Adjust_Condition on their operands.
418 elsif KP in N_Op_Boolean
419 or else KP in N_Short_Circuit
420 or else KP = N_Op_Not
424 -- Otherwise we perform a conversion from the current type, which
425 -- must be Standard.Boolean, to the desired type. Use the base
426 -- type to prevent spurious constraint checks that are extraneous
427 -- to the transformation. The type and its base have the same
428 -- representation, standard or otherwise.
432 Rewrite (N, Convert_To (Base_Type (T), N));
433 Analyze_And_Resolve (N, Base_Type (T));
437 end Adjust_Result_Type;
439 --------------------------
440 -- Append_Freeze_Action --
441 --------------------------
443 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
447 Ensure_Freeze_Node (T);
448 Fnode := Freeze_Node (T);
450 if No (Actions (Fnode)) then
451 Set_Actions (Fnode, New_List (N));
453 Append (N, Actions (Fnode));
456 end Append_Freeze_Action;
458 ---------------------------
459 -- Append_Freeze_Actions --
460 ---------------------------
462 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
470 Ensure_Freeze_Node (T);
471 Fnode := Freeze_Node (T);
473 if No (Actions (Fnode)) then
474 Set_Actions (Fnode, L);
476 Append_List (L, Actions (Fnode));
478 end Append_Freeze_Actions;
480 --------------------------------------
481 -- Attr_Constrained_Statically_True --
482 --------------------------------------
484 function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
486 Ptyp : constant Entity_Id := Etype (Pref);
487 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
489 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
490 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
491 -- view of an aliased object whose subtype is constrained.
493 ---------------------------------
494 -- Is_Constrained_Aliased_View --
495 ---------------------------------
497 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
501 if Is_Entity_Name (Obj) then
504 if Present (Renamed_Object (E)) then
505 return Is_Constrained_Aliased_View (Renamed_Object (E));
507 return Is_Aliased (E) and then Is_Constrained (Etype (E));
511 return Is_Aliased_View (Obj)
513 (Is_Constrained (Etype (Obj))
515 (Nkind (Obj) = N_Explicit_Dereference
517 not Object_Type_Has_Constrained_Partial_View
518 (Typ => Base_Type (Etype (Obj)),
519 Scop => Current_Scope)));
521 end Is_Constrained_Aliased_View;
523 -- Start of processing for Attribute_Constrained_Static_Value
526 -- We are in a case where the attribute is known statically, and
527 -- implicit dereferences have been rewritten.
530 (not (Present (Formal_Ent)
531 and then Ekind (Formal_Ent) /= E_Constant
532 and then Present (Extra_Constrained (Formal_Ent)))
534 not (Is_Access_Type (Etype (Pref))
535 and then (not Is_Entity_Name (Pref)
536 or else Is_Object (Entity (Pref))))
538 not (Nkind (Pref) = N_Identifier
539 and then Ekind (Entity (Pref)) = E_Variable
540 and then Present (Extra_Constrained (Entity (Pref)))));
542 if Is_Entity_Name (Pref) then
544 Ent : constant Entity_Id := Entity (Pref);
548 -- (RM J.4) obsolescent cases
550 if Is_Type (Ent) then
554 if Is_Private_Type (Ent) then
555 Res := not Has_Discriminants (Ent)
556 or else Is_Constrained (Ent);
558 -- It not a private type, must be a generic actual type
559 -- that corresponded to a private type. We know that this
560 -- correspondence holds, since otherwise the reference
561 -- within the generic template would have been illegal.
564 if Is_Composite_Type (Underlying_Type (Ent)) then
565 Res := Is_Constrained (Ent);
573 -- If the prefix is not a variable or is aliased, then
574 -- definitely true; if it's a formal parameter without an
575 -- associated extra formal, then treat it as constrained.
577 -- Ada 2005 (AI-363): An aliased prefix must be known to be
578 -- constrained in order to set the attribute to True.
580 if not Is_Variable (Pref)
581 or else Present (Formal_Ent)
582 or else (Ada_Version < Ada_2005
583 and then Is_Aliased_View (Pref))
584 or else (Ada_Version >= Ada_2005
585 and then Is_Constrained_Aliased_View (Pref))
589 -- Variable case, look at type to see if it is constrained.
590 -- Note that the one case where this is not accurate (the
591 -- procedure formal case), has been handled above.
593 -- We use the Underlying_Type here (and below) in case the
594 -- type is private without discriminants, but the full type
595 -- has discriminants. This case is illegal, but we generate
596 -- it internally for passing to the Extra_Constrained
600 -- In Ada 2012, test for case of a limited tagged type,
601 -- in which case the attribute is always required to
602 -- return True. The underlying type is tested, to make
603 -- sure we also return True for cases where there is an
604 -- unconstrained object with an untagged limited partial
605 -- view which has defaulted discriminants (such objects
606 -- always produce a False in earlier versions of
607 -- Ada). (Ada 2012: AI05-0214)
610 Is_Constrained (Underlying_Type (Etype (Ent)))
612 (Ada_Version >= Ada_2012
613 and then Is_Tagged_Type (Underlying_Type (Ptyp))
614 and then Is_Limited_Type (Ptyp));
621 -- Prefix is not an entity name. These are also cases where we can
622 -- always tell at compile time by looking at the form and type of the
623 -- prefix. If an explicit dereference of an object with constrained
624 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
625 -- underlying type is a limited tagged type, then Constrained is
626 -- required to always return True (Ada 2012: AI05-0214).
629 return not Is_Variable (Pref)
631 (Nkind (Pref) = N_Explicit_Dereference
633 not Object_Type_Has_Constrained_Partial_View
634 (Typ => Base_Type (Ptyp),
635 Scop => Current_Scope))
636 or else Is_Constrained (Underlying_Type (Ptyp))
637 or else (Ada_Version >= Ada_2012
638 and then Is_Tagged_Type (Underlying_Type (Ptyp))
639 and then Is_Limited_Type (Ptyp));
641 end Attribute_Constrained_Static_Value;
643 ------------------------------------
644 -- Build_Allocate_Deallocate_Proc --
645 ------------------------------------
647 procedure Build_Allocate_Deallocate_Proc
649 Is_Allocate : Boolean)
651 function Find_Object (E : Node_Id) return Node_Id;
652 -- Given an arbitrary expression of an allocator, try to find an object
653 -- reference in it, otherwise return the original expression.
655 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
656 -- Determine whether subprogram Subp denotes a custom allocate or
663 function Find_Object (E : Node_Id) return Node_Id is
667 pragma Assert (Is_Allocate);
671 if Nkind (Expr) = N_Explicit_Dereference then
672 Expr := Prefix (Expr);
674 elsif Nkind (Expr) = N_Qualified_Expression then
675 Expr := Expression (Expr);
677 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
679 -- When interface class-wide types are involved in allocation,
680 -- the expander introduces several levels of address arithmetic
681 -- to perform dispatch table displacement. In this scenario the
682 -- object appears as:
684 -- Tag_Ptr (Base_Address (<object>'Address))
686 -- Detect this case and utilize the whole expression as the
687 -- "object" since it now points to the proper dispatch table.
689 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
692 -- Continue to strip the object
695 Expr := Expression (Expr);
706 ---------------------------------
707 -- Is_Allocate_Deallocate_Proc --
708 ---------------------------------
710 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
712 -- Look for a subprogram body with only one statement which is a
713 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
715 if Ekind (Subp) = E_Procedure
716 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
719 HSS : constant Node_Id :=
720 Handled_Statement_Sequence (Parent (Parent (Subp)));
724 if Present (Statements (HSS))
725 and then Nkind (First (Statements (HSS))) =
726 N_Procedure_Call_Statement
728 Proc := Entity (Name (First (Statements (HSS))));
731 Is_RTE (Proc, RE_Allocate_Any_Controlled)
732 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
738 end Is_Allocate_Deallocate_Proc;
742 Desig_Typ : Entity_Id;
746 Proc_To_Call : Node_Id := Empty;
749 -- Start of processing for Build_Allocate_Deallocate_Proc
752 -- Obtain the attributes of the allocation / deallocation
754 if Nkind (N) = N_Free_Statement then
755 Expr := Expression (N);
756 Ptr_Typ := Base_Type (Etype (Expr));
757 Proc_To_Call := Procedure_To_Call (N);
760 if Nkind (N) = N_Object_Declaration then
761 Expr := Expression (N);
766 -- In certain cases an allocator with a qualified expression may
767 -- be relocated and used as the initialization expression of a
771 -- Obj : Ptr_Typ := new Desig_Typ'(...);
774 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
775 -- Obj : Ptr_Typ := Tmp;
777 -- Since the allocator is always marked as analyzed to avoid infinite
778 -- expansion, it will never be processed by this routine given that
779 -- the designated type needs finalization actions. Detect this case
780 -- and complete the expansion of the allocator.
782 if Nkind (Expr) = N_Identifier
783 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
784 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
786 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
790 -- The allocator may have been rewritten into something else in which
791 -- case the expansion performed by this routine does not apply.
793 if Nkind (Expr) /= N_Allocator then
797 Ptr_Typ := Base_Type (Etype (Expr));
798 Proc_To_Call := Procedure_To_Call (Expr);
801 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
802 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
804 -- Handle concurrent types
806 if Is_Concurrent_Type (Desig_Typ)
807 and then Present (Corresponding_Record_Type (Desig_Typ))
809 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
812 -- Do not process allocations / deallocations without a pool
817 -- Do not process allocations on / deallocations from the secondary
820 elsif 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))
826 -- Optimize the case where we are using the default Global_Pool_Object,
827 -- and we don't need the heavy finalization machinery.
829 elsif Pool_Id = RTE (RE_Global_Pool_Object)
830 and then not Needs_Finalization (Desig_Typ)
834 -- Do not replicate the machinery if the allocator / free has already
835 -- been expanded and has a custom Allocate / Deallocate.
837 elsif Present (Proc_To_Call)
838 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
843 -- Finalization actions are required when the object to be allocated or
844 -- deallocated needs these actions and the associated access type is not
845 -- subject to pragma No_Heap_Finalization.
848 Needs_Finalization (Desig_Typ)
849 and then not No_Heap_Finalization (Ptr_Typ);
853 -- Do nothing if the access type may never allocate / deallocate
856 if No_Pool_Assigned (Ptr_Typ) then
860 -- The allocation / deallocation of a controlled object must be
861 -- chained on / detached from a finalization master.
863 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
865 -- The only other kind of allocation / deallocation supported by this
866 -- routine is on / from a subpool.
868 elsif Nkind (Expr) = N_Allocator
869 and then No (Subpool_Handle_Name (Expr))
875 Loc : constant Source_Ptr := Sloc (N);
876 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
877 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
878 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
879 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
882 Fin_Addr_Id : Entity_Id;
883 Fin_Mas_Act : Node_Id;
884 Fin_Mas_Id : Entity_Id;
885 Proc_To_Call : Entity_Id;
886 Subpool : Node_Id := Empty;
889 -- Step 1: Construct all the actuals for the call to library routine
890 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
894 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
900 if Nkind (Expr) = N_Allocator then
901 Subpool := Subpool_Handle_Name (Expr);
904 -- If a subpool is present it can be an arbitrary name, so make
905 -- the actual by copying the tree.
907 if Present (Subpool) then
908 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
910 Append_To (Actuals, Make_Null (Loc));
913 -- c) Finalization master
916 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
917 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
919 -- Handle the case where the master is actually a pointer to a
920 -- master. This case arises in build-in-place functions.
922 if Is_Access_Type (Etype (Fin_Mas_Id)) then
923 Append_To (Actuals, Fin_Mas_Act);
926 Make_Attribute_Reference (Loc,
927 Prefix => Fin_Mas_Act,
928 Attribute_Name => Name_Unrestricted_Access));
931 Append_To (Actuals, Make_Null (Loc));
934 -- d) Finalize_Address
936 -- Primitive Finalize_Address is never generated in CodePeer mode
937 -- since it contains an Unchecked_Conversion.
939 if Needs_Fin and then not CodePeer_Mode then
940 Fin_Addr_Id := Finalize_Address (Desig_Typ);
941 pragma Assert (Present (Fin_Addr_Id));
944 Make_Attribute_Reference (Loc,
945 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
946 Attribute_Name => Name_Unrestricted_Access));
948 Append_To (Actuals, Make_Null (Loc));
956 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
957 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
959 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
960 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
962 -- For deallocation of class-wide types we obtain the value of
963 -- alignment from the Type Specific Record of the deallocated object.
964 -- This is needed because the frontend expansion of class-wide types
965 -- into equivalent types confuses the back end.
971 -- ... because 'Alignment applied to class-wide types is expanded
972 -- into the code that reads the value of alignment from the TSD
973 -- (see Expand_N_Attribute_Reference)
976 Unchecked_Convert_To (RTE (RE_Storage_Offset),
977 Make_Attribute_Reference (Loc,
979 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
980 Attribute_Name => Name_Alignment)));
986 Is_Controlled : declare
987 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
995 Temp := Find_Object (Expression (Expr));
1000 -- Processing for allocations where the expression is a subtype
1004 and then Is_Entity_Name (Temp)
1005 and then Is_Type (Entity (Temp))
1010 (Needs_Finalization (Entity (Temp))), Loc);
1012 -- The allocation / deallocation of a class-wide object relies
1013 -- on a runtime check to determine whether the object is truly
1014 -- controlled or not. Depending on this check, the finalization
1015 -- machinery will request or reclaim extra storage reserved for
1018 elsif Is_Class_Wide_Type (Desig_Typ) then
1020 -- Detect a special case where interface class-wide types
1021 -- are involved as the object appears as:
1023 -- Tag_Ptr (Base_Address (<object>'Address))
1025 -- The expression already yields the proper tag, generate:
1029 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
1031 Make_Explicit_Dereference (Loc,
1032 Prefix => Relocate_Node (Temp));
1034 -- In the default case, obtain the tag of the object about
1035 -- to be allocated / deallocated. Generate:
1039 -- If the object is an unchecked conversion (typically to
1040 -- an access to class-wide type), we must preserve the
1041 -- conversion to ensure that the object is seen as tagged
1042 -- in the code that follows.
1047 if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion
1049 Pref := Parent (Pref);
1053 Make_Attribute_Reference (Loc,
1054 Prefix => Relocate_Node (Pref),
1055 Attribute_Name => Name_Tag);
1059 -- Needs_Finalization (<Param>)
1062 Make_Function_Call (Loc,
1064 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
1065 Parameter_Associations => New_List (Param));
1067 -- Processing for generic actuals
1069 elsif Is_Generic_Actual_Type (Desig_Typ) then
1071 New_Occurrence_Of (Boolean_Literals
1072 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
1074 -- The object does not require any specialized checks, it is
1075 -- known to be controlled.
1078 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
1081 -- Create the temporary which represents the finalization state
1082 -- of the expression. Generate:
1084 -- F : constant Boolean := <Flag_Expr>;
1087 Make_Object_Declaration (Loc,
1088 Defining_Identifier => Flag_Id,
1089 Constant_Present => True,
1090 Object_Definition =>
1091 New_Occurrence_Of (Standard_Boolean, Loc),
1092 Expression => Flag_Expr));
1094 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
1097 -- The object is not controlled
1100 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
1107 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
1110 -- Step 2: Build a wrapper Allocate / Deallocate which internally
1111 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
1113 -- Select the proper routine to call
1116 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
1118 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
1121 -- Create a custom Allocate / Deallocate routine which has identical
1122 -- profile to that of System.Storage_Pools.
1125 Make_Subprogram_Body (Loc,
1130 Make_Procedure_Specification (Loc,
1131 Defining_Unit_Name => Proc_Id,
1132 Parameter_Specifications => New_List (
1134 -- P : Root_Storage_Pool
1136 Make_Parameter_Specification (Loc,
1137 Defining_Identifier => Make_Temporary (Loc, 'P'),
1139 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
1141 -- A : [out] Address
1143 Make_Parameter_Specification (Loc,
1144 Defining_Identifier => Addr_Id,
1145 Out_Present => Is_Allocate,
1147 New_Occurrence_Of (RTE (RE_Address), Loc)),
1149 -- S : Storage_Count
1151 Make_Parameter_Specification (Loc,
1152 Defining_Identifier => Size_Id,
1154 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)),
1156 -- L : Storage_Count
1158 Make_Parameter_Specification (Loc,
1159 Defining_Identifier => Alig_Id,
1161 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
1163 Declarations => No_List,
1165 Handled_Statement_Sequence =>
1166 Make_Handled_Sequence_Of_Statements (Loc,
1167 Statements => New_List (
1168 Make_Procedure_Call_Statement (Loc,
1170 New_Occurrence_Of (Proc_To_Call, Loc),
1171 Parameter_Associations => Actuals)))),
1172 Suppress => All_Checks);
1174 -- The newly generated Allocate / Deallocate becomes the default
1175 -- procedure to call when the back end processes the allocation /
1179 Set_Procedure_To_Call (Expr, Proc_Id);
1181 Set_Procedure_To_Call (N, Proc_Id);
1184 end Build_Allocate_Deallocate_Proc;
1186 -------------------------------
1187 -- Build_Abort_Undefer_Block --
1188 -------------------------------
1190 function Build_Abort_Undefer_Block
1193 Context : Node_Id) return Node_Id
1195 Exceptions_OK : constant Boolean :=
1196 not Restriction_Active (No_Exception_Propagation);
1204 -- The block should be generated only when undeferring abort in the
1205 -- context of a potential exception.
1207 pragma Assert (Abort_Allowed and Exceptions_OK);
1213 -- Abort_Undefer_Direct;
1216 AUD := RTE (RE_Abort_Undefer_Direct);
1219 Make_Handled_Sequence_Of_Statements (Loc,
1220 Statements => Stmts,
1221 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1224 Make_Block_Statement (Loc,
1225 Handled_Statement_Sequence => HSS);
1226 Set_Is_Abort_Block (Blk);
1228 Add_Block_Identifier (Blk, Blk_Id);
1229 Expand_At_End_Handler (HSS, Blk_Id);
1231 -- Present the Abort_Undefer_Direct function to the back end to inline
1232 -- the call to the routine.
1234 Add_Inlined_Body (AUD, Context);
1237 end Build_Abort_Undefer_Block;
1239 ---------------------------------
1240 -- Build_Class_Wide_Expression --
1241 ---------------------------------
1243 procedure Build_Class_Wide_Expression
1246 Par_Subp : Entity_Id;
1247 Adjust_Sloc : Boolean;
1248 Needs_Wrapper : out Boolean)
1250 function Replace_Entity (N : Node_Id) return Traverse_Result;
1251 -- Replace reference to formal of inherited operation or to primitive
1252 -- operation of root type, with corresponding entity for derived type,
1253 -- when constructing the class-wide condition of an overriding
1256 --------------------
1257 -- Replace_Entity --
1258 --------------------
1260 function Replace_Entity (N : Node_Id) return Traverse_Result is
1265 Adjust_Inherited_Pragma_Sloc (N);
1268 if Nkind (N) = N_Identifier
1269 and then Present (Entity (N))
1271 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
1273 (Nkind (Parent (N)) /= N_Attribute_Reference
1274 or else Attribute_Name (Parent (N)) /= Name_Class)
1276 -- The replacement does not apply to dispatching calls within the
1277 -- condition, but only to calls whose static tag is that of the
1280 if Is_Subprogram (Entity (N))
1281 and then Nkind (Parent (N)) = N_Function_Call
1282 and then Present (Controlling_Argument (Parent (N)))
1287 -- Determine whether entity has a renaming
1289 New_E := Type_Map.Get (Entity (N));
1291 if Present (New_E) then
1292 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
1294 -- AI12-0166: a precondition for a protected operation
1295 -- cannot include an internal call to a protected function
1296 -- of the type. In the case of an inherited condition for an
1297 -- overriding operation, both the operation and the function
1298 -- are given by primitive wrappers.
1300 if Ekind (New_E) = E_Function
1301 and then Is_Primitive_Wrapper (New_E)
1302 and then Is_Primitive_Wrapper (Subp)
1303 and then Scope (Subp) = Scope (New_E)
1305 Error_Msg_Node_2 := Wrapped_Entity (Subp);
1307 ("internal call to& cannot appear in inherited "
1308 & "precondition of protected operation&",
1309 N, Wrapped_Entity (New_E));
1312 -- If the entity is an overridden primitive and we are not
1313 -- in GNATprove mode, we must build a wrapper for the current
1314 -- inherited operation. If the reference is the prefix of an
1315 -- attribute such as 'Result (or others ???) there is no need
1316 -- for a wrapper: the condition is just rewritten in terms of
1317 -- the inherited subprogram.
1319 if Is_Subprogram (New_E)
1320 and then Nkind (Parent (N)) /= N_Attribute_Reference
1321 and then not GNATprove_Mode
1323 Needs_Wrapper := True;
1327 -- Check that there are no calls left to abstract operations if
1328 -- the current subprogram is not abstract.
1330 if Nkind (Parent (N)) = N_Function_Call
1331 and then N = Name (Parent (N))
1333 if not Is_Abstract_Subprogram (Subp)
1334 and then Is_Abstract_Subprogram (Entity (N))
1336 Error_Msg_Sloc := Sloc (Current_Scope);
1337 Error_Msg_Node_2 := Subp;
1338 if Comes_From_Source (Subp) then
1340 ("cannot call abstract subprogram & in inherited "
1341 & "condition for&#", Subp, Entity (N));
1344 ("cannot call abstract subprogram & in inherited "
1345 & "condition for inherited&#", Subp, Entity (N));
1348 -- In SPARK mode, reject an inherited condition for an
1349 -- inherited operation if it contains a call to an overriding
1350 -- operation, because this implies that the pre/postconditions
1351 -- of the inherited operation have changed silently.
1353 elsif SPARK_Mode = On
1354 and then Warn_On_Suspicious_Contract
1355 and then Present (Alias (Subp))
1356 and then Present (New_E)
1357 and then Comes_From_Source (New_E)
1360 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
1362 Error_Msg_Sloc := Sloc (New_E);
1363 Error_Msg_Node_2 := Subp;
1365 ("\overriding of&# forces overriding of&",
1366 Parent (Subp), New_E);
1370 -- Update type of function call node, which should be the same as
1371 -- the function's return type.
1373 if Is_Subprogram (Entity (N))
1374 and then Nkind (Parent (N)) = N_Function_Call
1376 Set_Etype (Parent (N), Etype (Entity (N)));
1379 -- The whole expression will be reanalyzed
1381 elsif Nkind (N) in N_Has_Etype then
1382 Set_Analyzed (N, False);
1388 procedure Replace_Condition_Entities is
1389 new Traverse_Proc (Replace_Entity);
1393 Par_Formal : Entity_Id;
1394 Subp_Formal : Entity_Id;
1396 -- Start of processing for Build_Class_Wide_Expression
1399 Needs_Wrapper := False;
1401 -- Add mapping from old formals to new formals
1403 Par_Formal := First_Formal (Par_Subp);
1404 Subp_Formal := First_Formal (Subp);
1406 while Present (Par_Formal) and then Present (Subp_Formal) loop
1407 Type_Map.Set (Par_Formal, Subp_Formal);
1408 Next_Formal (Par_Formal);
1409 Next_Formal (Subp_Formal);
1412 Replace_Condition_Entities (Prag);
1413 end Build_Class_Wide_Expression;
1415 --------------------
1416 -- Build_DIC_Call --
1417 --------------------
1419 function Build_DIC_Call
1422 Typ : Entity_Id) return Node_Id
1424 Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
1425 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1429 Make_Procedure_Call_Statement (Loc,
1430 Name => New_Occurrence_Of (Proc_Id, Loc),
1431 Parameter_Associations => New_List (
1432 Make_Unchecked_Type_Conversion (Loc,
1433 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1434 Expression => New_Occurrence_Of (Obj_Id, Loc))));
1437 ------------------------------
1438 -- Build_DIC_Procedure_Body --
1439 ------------------------------
1441 -- WARNING: This routine manages Ghost regions. Return statements must be
1442 -- replaced by gotos which jump to the end of the routine and restore the
1445 procedure Build_DIC_Procedure_Body
1447 For_Freeze : Boolean := False)
1449 procedure Add_DIC_Check
1450 (DIC_Prag : Node_Id;
1452 Stmts : in out List_Id);
1453 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1454 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1455 -- is added to list Stmts.
1457 procedure Add_Inherited_DIC
1458 (DIC_Prag : Node_Id;
1459 Par_Typ : Entity_Id;
1460 Deriv_Typ : Entity_Id;
1461 Stmts : in out List_Id);
1462 -- Add a runtime check to verify the assertion expression of inherited
1463 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1464 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1465 -- pragma. All generated code is added to list Stmts.
1467 procedure Add_Inherited_Tagged_DIC
1468 (DIC_Prag : Node_Id;
1469 Par_Typ : Entity_Id;
1470 Deriv_Typ : Entity_Id;
1471 Stmts : in out List_Id);
1472 -- Add a runtime check to verify assertion expression DIC_Expr of
1473 -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
1474 -- postcondition-like runtime semantics to the check. Par_Typ is the
1475 -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
1476 -- derived type inheriting the DIC pragma. All generated code is added
1479 procedure Add_Own_DIC
1480 (DIC_Prag : Node_Id;
1481 DIC_Typ : Entity_Id;
1482 Stmts : in out List_Id);
1483 -- Add a runtime check to verify the assertion expression of pragma
1484 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
1485 -- is added to list Stmts.
1491 procedure Add_DIC_Check
1492 (DIC_Prag : Node_Id;
1494 Stmts : in out List_Id)
1496 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1497 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1500 -- The DIC pragma is ignored, nothing left to do
1502 if Is_Ignored (DIC_Prag) then
1505 -- Otherwise the DIC expression must be checked at run time.
1508 -- pragma Check (<Nam>, <DIC_Expr>);
1511 Append_New_To (Stmts,
1513 Pragma_Identifier =>
1514 Make_Identifier (Loc, Name_Check),
1516 Pragma_Argument_Associations => New_List (
1517 Make_Pragma_Argument_Association (Loc,
1518 Expression => Make_Identifier (Loc, Nam)),
1520 Make_Pragma_Argument_Association (Loc,
1521 Expression => DIC_Expr))));
1525 -----------------------
1526 -- Add_Inherited_DIC --
1527 -----------------------
1529 procedure Add_Inherited_DIC
1530 (DIC_Prag : Node_Id;
1531 Par_Typ : Entity_Id;
1532 Deriv_Typ : Entity_Id;
1533 Stmts : in out List_Id)
1535 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1536 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1537 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1538 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1539 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1542 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1544 -- Verify the inherited DIC assertion expression by calling the DIC
1545 -- procedure of the parent type.
1548 -- <Par_Typ>DIC (Par_Typ (_object));
1550 Append_New_To (Stmts,
1551 Make_Procedure_Call_Statement (Loc,
1552 Name => New_Occurrence_Of (Par_Proc, Loc),
1553 Parameter_Associations => New_List (
1555 (Typ => Etype (Par_Obj),
1556 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1557 end Add_Inherited_DIC;
1559 ------------------------------
1560 -- Add_Inherited_Tagged_DIC --
1561 ------------------------------
1563 procedure Add_Inherited_Tagged_DIC
1564 (DIC_Prag : Node_Id;
1565 Par_Typ : Entity_Id;
1566 Deriv_Typ : Entity_Id;
1567 Stmts : in out List_Id)
1569 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1570 DIC_Args : constant List_Id :=
1571 Pragma_Argument_Associations (DIC_Prag);
1572 DIC_Arg : constant Node_Id := First (DIC_Args);
1573 DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
1574 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1579 -- The processing of an inherited DIC assertion expression starts off
1580 -- with a copy of the original parent expression where all references
1581 -- to the parent type have already been replaced with references to
1582 -- the _object formal parameter of the parent type's DIC procedure.
1584 pragma Assert (Present (DIC_Expr));
1585 Expr := New_Copy_Tree (DIC_Expr);
1587 -- Perform the following substitutions:
1589 -- * Replace a reference to the _object parameter of the parent
1590 -- type's DIC procedure with a reference to the _object parameter
1591 -- of the derived types' DIC procedure.
1593 -- * Replace a reference to a discriminant of the parent type with
1594 -- a suitable value from the point of view of the derived type.
1596 -- * Replace a call to an overridden parent primitive with a call
1597 -- to the overriding derived type primitive.
1599 -- * Replace a call to an inherited parent primitive with a call to
1600 -- the internally-generated inherited derived type primitive.
1602 -- Note that primitives defined in the private part are automatically
1603 -- handled by the overriding/inheritance mechanism and do not require
1604 -- an extra replacement pass.
1606 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1611 Deriv_Typ => Deriv_Typ,
1612 Par_Obj => First_Formal (Par_Proc),
1613 Deriv_Obj => First_Formal (Deriv_Proc));
1615 -- Once the DIC assertion expression is fully processed, add a check
1616 -- to the statements of the DIC procedure.
1619 (DIC_Prag => DIC_Prag,
1622 end Add_Inherited_Tagged_DIC;
1628 procedure Add_Own_DIC
1629 (DIC_Prag : Node_Id;
1630 DIC_Typ : Entity_Id;
1631 Stmts : in out List_Id)
1633 DIC_Args : constant List_Id :=
1634 Pragma_Argument_Associations (DIC_Prag);
1635 DIC_Arg : constant Node_Id := First (DIC_Args);
1636 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1637 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1638 DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
1639 Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
1643 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1647 -- Start of processing for Add_Own_DIC
1650 pragma Assert (Present (DIC_Expr));
1651 Expr := New_Copy_Tree (DIC_Expr);
1653 -- Perform the following substitution:
1655 -- * Replace the current instance of DIC_Typ with a reference to
1656 -- the _object formal parameter of the DIC procedure.
1658 Replace_Type_References
1663 -- Preanalyze the DIC expression to detect errors and at the same
1664 -- time capture the visibility of the proper package part.
1666 Set_Parent (Expr, Typ_Decl);
1667 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1669 -- Save a copy of the expression with all replacements and analysis
1670 -- already taken place in case a derived type inherits the pragma.
1671 -- The copy will be used as the foundation of the derived type's own
1672 -- version of the DIC assertion expression.
1674 if Is_Tagged_Type (DIC_Typ) then
1675 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1678 -- If the pragma comes from an aspect specification, replace the
1679 -- saved expression because all type references must be substituted
1680 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1683 if Present (DIC_Asp) then
1684 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1687 -- Once the DIC assertion expression is fully processed, add a check
1688 -- to the statements of the DIC procedure.
1691 (DIC_Prag => DIC_Prag,
1698 Loc : constant Source_Ptr := Sloc (Typ);
1700 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1701 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1702 -- Save the Ghost-related attributes to restore on exit
1705 DIC_Typ : Entity_Id;
1706 Dummy_1 : Entity_Id;
1707 Dummy_2 : Entity_Id;
1708 Proc_Body : Node_Id;
1709 Proc_Body_Id : Entity_Id;
1710 Proc_Decl : Node_Id;
1711 Proc_Id : Entity_Id;
1712 Stmts : List_Id := No_List;
1714 Build_Body : Boolean := False;
1715 -- Flag set when the type requires a DIC procedure body to be built
1717 Work_Typ : Entity_Id;
1720 -- Start of processing for Build_DIC_Procedure_Body
1723 Work_Typ := Base_Type (Typ);
1725 -- Do not process class-wide types as these are Itypes, but lack a first
1726 -- subtype (see below).
1728 if Is_Class_Wide_Type (Work_Typ) then
1731 -- Do not process the underlying full view of a private type. There is
1732 -- no way to get back to the partial view, plus the body will be built
1733 -- by the full view or the base type.
1735 elsif Is_Underlying_Full_View (Work_Typ) then
1738 -- Use the first subtype when dealing with various base types
1740 elsif Is_Itype (Work_Typ) then
1741 Work_Typ := First_Subtype (Work_Typ);
1743 -- The input denotes the corresponding record type of a protected or a
1744 -- task type. Work with the concurrent type because the corresponding
1745 -- record type may not be visible to clients of the type.
1747 elsif Ekind (Work_Typ) = E_Record_Type
1748 and then Is_Concurrent_Record_Type (Work_Typ)
1750 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
1753 -- The working type may be subject to pragma Ghost. Set the mode now to
1754 -- ensure that the DIC procedure is properly marked as Ghost.
1756 Set_Ghost_Mode (Work_Typ);
1758 -- The working type must be either define a DIC pragma of its own or
1759 -- inherit one from a parent type.
1761 pragma Assert (Has_DIC (Work_Typ));
1763 -- Recover the type which defines the DIC pragma. This is either the
1764 -- working type itself or a parent type when the pragma is inherited.
1766 DIC_Typ := Find_DIC_Type (Work_Typ);
1767 pragma Assert (Present (DIC_Typ));
1769 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
1770 pragma Assert (Present (DIC_Prag));
1772 -- Nothing to do if pragma DIC appears without an argument or its sole
1773 -- argument is "null".
1775 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
1779 -- The working type may lack a DIC procedure declaration. This may be
1780 -- due to several reasons:
1782 -- * The working type's own DIC pragma does not contain a verifiable
1783 -- assertion expression. In this case there is no need to build a
1784 -- DIC procedure because there is nothing to check.
1786 -- * The working type derives from a parent type. In this case a DIC
1787 -- procedure should be built only when the inherited DIC pragma has
1788 -- a verifiable assertion expression.
1790 Proc_Id := DIC_Procedure (Work_Typ);
1792 -- Build a DIC procedure declaration when the working type derives from
1795 if No (Proc_Id) then
1796 Build_DIC_Procedure_Declaration (Work_Typ);
1797 Proc_Id := DIC_Procedure (Work_Typ);
1800 -- At this point there should be a DIC procedure declaration
1802 pragma Assert (Present (Proc_Id));
1803 Proc_Decl := Unit_Declaration_Node (Proc_Id);
1805 -- Nothing to do if the DIC procedure already has a body
1807 if Present (Corresponding_Body (Proc_Decl)) then
1811 -- Emulate the environment of the DIC procedure by installing its scope
1812 -- and formal parameters.
1814 Push_Scope (Proc_Id);
1815 Install_Formals (Proc_Id);
1817 -- The working type defines its own DIC pragma. Replace the current
1818 -- instance of the working type with the formal of the DIC procedure.
1819 -- Note that there is no need to consider inherited DIC pragmas from
1820 -- parent types because the working type's DIC pragma "hides" all
1821 -- inherited DIC pragmas.
1823 if Has_Own_DIC (Work_Typ) then
1824 pragma Assert (DIC_Typ = Work_Typ);
1827 (DIC_Prag => DIC_Prag,
1833 -- Otherwise the working type inherits a DIC pragma from a parent type.
1834 -- This processing is carried out when the type is frozen because the
1835 -- state of all parent discriminants is known at that point. Note that
1836 -- it is semantically sound to delay the creation of the DIC procedure
1837 -- body till the freeze point. If the type has a DIC pragma of its own,
1838 -- then the DIC procedure body would have already been constructed at
1839 -- the end of the visible declarations and all parent DIC pragmas are
1840 -- effectively "hidden" and irrelevant.
1842 elsif For_Freeze then
1843 pragma Assert (Has_Inherited_DIC (Work_Typ));
1844 pragma Assert (DIC_Typ /= Work_Typ);
1846 -- The working type is tagged. The verification of the assertion
1847 -- expression is subject to the same semantics as class-wide pre-
1848 -- and postconditions.
1850 if Is_Tagged_Type (Work_Typ) then
1851 Add_Inherited_Tagged_DIC
1852 (DIC_Prag => DIC_Prag,
1854 Deriv_Typ => Work_Typ,
1857 -- Otherwise the working type is not tagged. Verify the assertion
1858 -- expression of the inherited DIC pragma by directly calling the
1859 -- DIC procedure of the parent type.
1863 (DIC_Prag => DIC_Prag,
1865 Deriv_Typ => Work_Typ,
1876 -- Produce an empty completing body in the following cases:
1877 -- * Assertions are disabled
1878 -- * The DIC Assertion_Policy is Ignore
1881 Stmts := New_List (Make_Null_Statement (Loc));
1885 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
1888 -- end <Work_Typ>DIC;
1891 Make_Subprogram_Body (Loc,
1893 Copy_Subprogram_Spec (Parent (Proc_Id)),
1894 Declarations => Empty_List,
1895 Handled_Statement_Sequence =>
1896 Make_Handled_Sequence_Of_Statements (Loc,
1897 Statements => Stmts));
1898 Proc_Body_Id := Defining_Entity (Proc_Body);
1900 -- Perform minor decoration in case the body is not analyzed
1902 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
1903 Set_Etype (Proc_Body_Id, Standard_Void_Type);
1904 Set_Scope (Proc_Body_Id, Current_Scope);
1905 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
1906 Set_SPARK_Pragma_Inherited
1907 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
1909 -- Link both spec and body to avoid generating duplicates
1911 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
1912 Set_Corresponding_Spec (Proc_Body, Proc_Id);
1914 -- The body should not be inserted into the tree when the context
1915 -- is a generic unit because it is not part of the template.
1916 -- Note that the body must still be generated in order to resolve the
1917 -- DIC assertion expression.
1919 if Inside_A_Generic then
1922 -- Semi-insert the body into the tree for GNATprove by setting its
1923 -- Parent field. This allows for proper upstream tree traversals.
1925 elsif GNATprove_Mode then
1926 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
1928 -- Otherwise the body is part of the freezing actions of the working
1932 Append_Freeze_Action (Work_Typ, Proc_Body);
1937 Restore_Ghost_Region (Saved_GM, Saved_IGR);
1938 end Build_DIC_Procedure_Body;
1940 -------------------------------------
1941 -- Build_DIC_Procedure_Declaration --
1942 -------------------------------------
1944 -- WARNING: This routine manages Ghost regions. Return statements must be
1945 -- replaced by gotos which jump to the end of the routine and restore the
1948 procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is
1949 Loc : constant Source_Ptr := Sloc (Typ);
1951 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1952 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1953 -- Save the Ghost-related attributes to restore on exit
1956 DIC_Typ : Entity_Id;
1957 Proc_Decl : Node_Id;
1958 Proc_Id : Entity_Id;
1961 CRec_Typ : Entity_Id;
1962 -- The corresponding record type of Full_Typ
1964 Full_Base : Entity_Id;
1965 -- The base type of Full_Typ
1967 Full_Typ : Entity_Id;
1968 -- The full view of working type
1971 -- The _object formal parameter of the DIC procedure
1973 Priv_Typ : Entity_Id;
1974 -- The partial view of working type
1976 Work_Typ : Entity_Id;
1980 Work_Typ := Base_Type (Typ);
1982 -- Do not process class-wide types as these are Itypes, but lack a first
1983 -- subtype (see below).
1985 if Is_Class_Wide_Type (Work_Typ) then
1988 -- Do not process the underlying full view of a private type. There is
1989 -- no way to get back to the partial view, plus the body will be built
1990 -- by the full view or the base type.
1992 elsif Is_Underlying_Full_View (Work_Typ) then
1995 -- Use the first subtype when dealing with various base types
1997 elsif Is_Itype (Work_Typ) then
1998 Work_Typ := First_Subtype (Work_Typ);
2000 -- The input denotes the corresponding record type of a protected or a
2001 -- task type. Work with the concurrent type because the corresponding
2002 -- record type may not be visible to clients of the type.
2004 elsif Ekind (Work_Typ) = E_Record_Type
2005 and then Is_Concurrent_Record_Type (Work_Typ)
2007 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2010 -- The working type may be subject to pragma Ghost. Set the mode now to
2011 -- ensure that the DIC procedure is properly marked as Ghost.
2013 Set_Ghost_Mode (Work_Typ);
2015 -- The type must be either subject to a DIC pragma or inherit one from a
2018 pragma Assert (Has_DIC (Work_Typ));
2020 -- Recover the type which defines the DIC pragma. This is either the
2021 -- working type itself or a parent type when the pragma is inherited.
2023 DIC_Typ := Find_DIC_Type (Work_Typ);
2024 pragma Assert (Present (DIC_Typ));
2026 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2027 pragma Assert (Present (DIC_Prag));
2029 -- Nothing to do if pragma DIC appears without an argument or its sole
2030 -- argument is "null".
2032 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2035 -- Nothing to do if the type already has a DIC procedure
2037 elsif Present (DIC_Procedure (Work_Typ)) then
2042 Make_Defining_Identifier (Loc,
2044 New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
2046 -- Perform minor decoration in case the declaration is not analyzed
2048 Set_Ekind (Proc_Id, E_Procedure);
2049 Set_Etype (Proc_Id, Standard_Void_Type);
2050 Set_Is_DIC_Procedure (Proc_Id);
2051 Set_Scope (Proc_Id, Current_Scope);
2052 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
2053 Set_SPARK_Pragma_Inherited (Proc_Id);
2055 Set_DIC_Procedure (Work_Typ, Proc_Id);
2057 -- The DIC procedure requires debug info when the assertion expression
2058 -- is subject to Source Coverage Obligations.
2060 if Generate_SCO then
2061 Set_Debug_Info_Needed (Proc_Id);
2064 -- Obtain all views of the input type
2066 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
2068 -- Associate the DIC procedure and various relevant flags with all views
2070 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
2071 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
2072 Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ);
2073 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
2075 -- The declaration of the DIC procedure must be inserted after the
2076 -- declaration of the partial view as this allows for proper external
2079 if Present (Priv_Typ) then
2080 Typ_Decl := Declaration_Node (Priv_Typ);
2082 -- Derived types with the full view as parent do not have a partial
2083 -- view. Insert the DIC procedure after the derived type.
2086 Typ_Decl := Declaration_Node (Full_Typ);
2089 -- The type should have a declarative node
2091 pragma Assert (Present (Typ_Decl));
2093 -- Create the formal parameter which emulates the variable-like behavior
2094 -- of the type's current instance.
2096 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
2098 -- Perform minor decoration in case the declaration is not analyzed
2100 Set_Ekind (Obj_Id, E_In_Parameter);
2101 Set_Etype (Obj_Id, Work_Typ);
2102 Set_Scope (Obj_Id, Proc_Id);
2104 Set_First_Entity (Proc_Id, Obj_Id);
2105 Set_Last_Entity (Proc_Id, Obj_Id);
2108 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2111 Make_Subprogram_Declaration (Loc,
2113 Make_Procedure_Specification (Loc,
2114 Defining_Unit_Name => Proc_Id,
2115 Parameter_Specifications => New_List (
2116 Make_Parameter_Specification (Loc,
2117 Defining_Identifier => Obj_Id,
2119 New_Occurrence_Of (Work_Typ, Loc)))));
2121 -- The declaration should not be inserted into the tree when the context
2122 -- is a generic unit because it is not part of the template.
2124 if Inside_A_Generic then
2127 -- Semi-insert the declaration into the tree for GNATprove by setting
2128 -- its Parent field. This allows for proper upstream tree traversals.
2130 elsif GNATprove_Mode then
2131 Set_Parent (Proc_Decl, Parent (Typ_Decl));
2133 -- Otherwise insert the declaration
2136 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
2140 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2141 end Build_DIC_Procedure_Declaration;
2143 ------------------------------------
2144 -- Build_Invariant_Procedure_Body --
2145 ------------------------------------
2147 -- WARNING: This routine manages Ghost regions. Return statements must be
2148 -- replaced by gotos which jump to the end of the routine and restore the
2151 procedure Build_Invariant_Procedure_Body
2153 Partial_Invariant : Boolean := False)
2155 Loc : constant Source_Ptr := Sloc (Typ);
2157 Pragmas_Seen : Elist_Id := No_Elist;
2158 -- This list contains all invariant pragmas processed so far. The list
2159 -- is used to avoid generating redundant invariant checks.
2161 Produced_Check : Boolean := False;
2162 -- This flag tracks whether the type has produced at least one invariant
2163 -- check. The flag is used as a sanity check at the end of the routine.
2165 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2166 -- intentionally unnested to avoid deep indentation of code.
2168 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2169 -- they emit checks, loops (for arrays) and case statements (for record
2170 -- variant parts) only when there are invariants to verify. This keeps
2171 -- the body of the invariant procedure free of useless code.
2173 procedure Add_Array_Component_Invariants
2176 Checks : in out List_Id);
2177 -- Generate an invariant check for each component of array type T.
2178 -- Obj_Id denotes the entity of the _object formal parameter of the
2179 -- invariant procedure. All created checks are added to list Checks.
2181 procedure Add_Inherited_Invariants
2183 Priv_Typ : Entity_Id;
2184 Full_Typ : Entity_Id;
2186 Checks : in out List_Id);
2187 -- Generate an invariant check for each inherited class-wide invariant
2188 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2189 -- the partial and full view of the parent type. Obj_Id denotes the
2190 -- entity of the _object formal parameter of the invariant procedure.
2191 -- All created checks are added to list Checks.
2193 procedure Add_Interface_Invariants
2196 Checks : in out List_Id);
2197 -- Generate an invariant check for each inherited class-wide invariant
2198 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2199 -- entity of the _object formal parameter of the invariant procedure.
2200 -- All created checks are added to list Checks.
2202 procedure Add_Invariant_Check
2205 Checks : in out List_Id;
2206 Inherited : Boolean := False);
2207 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2208 -- verify assertion expression Expr of pragma Prag. All generated code
2209 -- is added to list Checks. Flag Inherited should be set when the pragma
2210 -- is inherited from a parent or interface type.
2212 procedure Add_Own_Invariants
2215 Checks : in out List_Id;
2216 Priv_Item : Node_Id := Empty);
2217 -- Generate an invariant check for each invariant found for type T.
2218 -- Obj_Id denotes the entity of the _object formal parameter of the
2219 -- invariant procedure. All created checks are added to list Checks.
2220 -- Priv_Item denotes the first rep item of the private type.
2222 procedure Add_Parent_Invariants
2225 Checks : in out List_Id);
2226 -- Generate an invariant check for each inherited class-wide invariant
2227 -- coming from all parent types of type T. Obj_Id denotes the entity of
2228 -- the _object formal parameter of the invariant procedure. All created
2229 -- checks are added to list Checks.
2231 procedure Add_Record_Component_Invariants
2234 Checks : in out List_Id);
2235 -- Generate an invariant check for each component of record type T.
2236 -- Obj_Id denotes the entity of the _object formal parameter of the
2237 -- invariant procedure. All created checks are added to list Checks.
2239 ------------------------------------
2240 -- Add_Array_Component_Invariants --
2241 ------------------------------------
2243 procedure Add_Array_Component_Invariants
2246 Checks : in out List_Id)
2248 Comp_Typ : constant Entity_Id := Component_Type (T);
2249 Dims : constant Pos := Number_Dimensions (T);
2251 procedure Process_Array_Component
2253 Comp_Checks : in out List_Id);
2254 -- Generate an invariant check for an array component identified by
2255 -- the indices in list Indices. All created checks are added to list
2258 procedure Process_One_Dimension
2261 Dim_Checks : in out List_Id);
2262 -- Generate a loop over the Nth dimension Dim of an array type. List
2263 -- Indices contains all array indices for the dimension. All created
2264 -- checks are added to list Dim_Checks.
2266 -----------------------------
2267 -- Process_Array_Component --
2268 -----------------------------
2270 procedure Process_Array_Component
2272 Comp_Checks : in out List_Id)
2274 Proc_Id : Entity_Id;
2277 if Has_Invariants (Comp_Typ) then
2279 -- In GNATprove mode, the component invariants are checked by
2280 -- other means. They should not be added to the array type
2281 -- invariant procedure, so that the procedure can be used to
2282 -- check the array type invariants if any.
2284 if GNATprove_Mode then
2288 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2290 -- The component type should have an invariant procedure
2291 -- if it has invariants of its own or inherits class-wide
2292 -- invariants from parent or interface types.
2294 pragma Assert (Present (Proc_Id));
2297 -- <Comp_Typ>Invariant (_object (<Indices>));
2299 -- Note that the invariant procedure may have a null body if
2300 -- assertions are disabled or Assertion_Policy Ignore is in
2303 if not Has_Null_Body (Proc_Id) then
2304 Append_New_To (Comp_Checks,
2305 Make_Procedure_Call_Statement (Loc,
2307 New_Occurrence_Of (Proc_Id, Loc),
2308 Parameter_Associations => New_List (
2309 Make_Indexed_Component (Loc,
2310 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2311 Expressions => New_Copy_List (Indices)))));
2315 Produced_Check := True;
2317 end Process_Array_Component;
2319 ---------------------------
2320 -- Process_One_Dimension --
2321 ---------------------------
2323 procedure Process_One_Dimension
2326 Dim_Checks : in out List_Id)
2328 Comp_Checks : List_Id := No_List;
2332 -- Generate the invariant checks for the array component after all
2333 -- dimensions have produced their respective loops.
2336 Process_Array_Component
2337 (Indices => Indices,
2338 Comp_Checks => Dim_Checks);
2340 -- Otherwise create a loop for the current dimension
2343 -- Create a new loop variable for each dimension
2346 Make_Defining_Identifier (Loc,
2347 Chars => New_External_Name ('I', Dim));
2348 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2350 Process_One_Dimension
2353 Dim_Checks => Comp_Checks);
2356 -- for I<Dim> in _object'Range (<Dim>) loop
2360 -- Note that the invariant procedure may have a null body if
2361 -- assertions are disabled or Assertion_Policy Ignore is in
2364 if Present (Comp_Checks) then
2365 Append_New_To (Dim_Checks,
2366 Make_Implicit_Loop_Statement (T,
2367 Identifier => Empty,
2369 Make_Iteration_Scheme (Loc,
2370 Loop_Parameter_Specification =>
2371 Make_Loop_Parameter_Specification (Loc,
2372 Defining_Identifier => Index,
2373 Discrete_Subtype_Definition =>
2374 Make_Attribute_Reference (Loc,
2376 New_Occurrence_Of (Obj_Id, Loc),
2377 Attribute_Name => Name_Range,
2378 Expressions => New_List (
2379 Make_Integer_Literal (Loc, Dim))))),
2380 Statements => Comp_Checks));
2383 end Process_One_Dimension;
2385 -- Start of processing for Add_Array_Component_Invariants
2388 Process_One_Dimension
2390 Indices => New_List,
2391 Dim_Checks => Checks);
2392 end Add_Array_Component_Invariants;
2394 ------------------------------
2395 -- Add_Inherited_Invariants --
2396 ------------------------------
2398 procedure Add_Inherited_Invariants
2400 Priv_Typ : Entity_Id;
2401 Full_Typ : Entity_Id;
2403 Checks : in out List_Id)
2405 Deriv_Typ : Entity_Id;
2408 Prag_Expr : Node_Id;
2409 Prag_Expr_Arg : Node_Id;
2411 Prag_Typ_Arg : Node_Id;
2413 Par_Proc : Entity_Id;
2414 -- The "partial" invariant procedure of Par_Typ
2416 Par_Typ : Entity_Id;
2417 -- The suitable view of the parent type used in the substitution of
2421 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2425 -- When the type inheriting the class-wide invariant is a concurrent
2426 -- type, use the corresponding record type because it contains all
2427 -- primitive operations of the concurrent type and allows for proper
2430 if Is_Concurrent_Type (T) then
2431 Deriv_Typ := Corresponding_Record_Type (T);
2436 pragma Assert (Present (Deriv_Typ));
2438 -- Determine which rep item chain to use. Precedence is given to that
2439 -- of the parent type's partial view since it usually carries all the
2440 -- class-wide invariants.
2442 if Present (Priv_Typ) then
2443 Prag := First_Rep_Item (Priv_Typ);
2445 Prag := First_Rep_Item (Full_Typ);
2448 while Present (Prag) loop
2449 if Nkind (Prag) = N_Pragma
2450 and then Pragma_Name (Prag) = Name_Invariant
2452 -- Nothing to do if the pragma was already processed
2454 if Contains (Pragmas_Seen, Prag) then
2457 -- Nothing to do when the caller requests the processing of all
2458 -- inherited class-wide invariants, but the pragma does not
2459 -- fall in this category.
2461 elsif not Class_Present (Prag) then
2465 -- Extract the arguments of the invariant pragma
2467 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2468 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2469 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2470 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2472 -- The pragma applies to the partial view of the parent type
2474 if Present (Priv_Typ)
2475 and then Entity (Prag_Typ) = Priv_Typ
2477 Par_Typ := Priv_Typ;
2479 -- The pragma applies to the full view of the parent type
2481 elsif Present (Full_Typ)
2482 and then Entity (Prag_Typ) = Full_Typ
2484 Par_Typ := Full_Typ;
2486 -- Otherwise the pragma does not belong to the parent type and
2487 -- should not be considered.
2493 -- Perform the following substitutions:
2495 -- * Replace a reference to the _object parameter of the
2496 -- parent type's partial invariant procedure with a
2497 -- reference to the _object parameter of the derived
2498 -- type's full invariant procedure.
2500 -- * Replace a reference to a discriminant of the parent type
2501 -- with a suitable value from the point of view of the
2504 -- * Replace a call to an overridden parent primitive with a
2505 -- call to the overriding derived type primitive.
2507 -- * Replace a call to an inherited parent primitive with a
2508 -- call to the internally-generated inherited derived type
2511 Expr := New_Copy_Tree (Prag_Expr);
2513 -- The parent type must have a "partial" invariant procedure
2514 -- because class-wide invariants are captured exclusively by
2517 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2518 pragma Assert (Present (Par_Proc));
2523 Deriv_Typ => Deriv_Typ,
2524 Par_Obj => First_Formal (Par_Proc),
2525 Deriv_Obj => Obj_Id);
2527 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2530 Next_Rep_Item (Prag);
2532 end Add_Inherited_Invariants;
2534 ------------------------------
2535 -- Add_Interface_Invariants --
2536 ------------------------------
2538 procedure Add_Interface_Invariants
2541 Checks : in out List_Id)
2543 Iface_Elmt : Elmt_Id;
2547 -- Generate an invariant check for each class-wide invariant coming
2548 -- from all interfaces implemented by type T.
2550 if Is_Tagged_Type (T) then
2551 Collect_Interfaces (T, Ifaces);
2553 -- Process the class-wide invariants of all implemented interfaces
2555 Iface_Elmt := First_Elmt (Ifaces);
2556 while Present (Iface_Elmt) loop
2558 -- The Full_Typ parameter is intentionally left Empty because
2559 -- interfaces are treated as the partial view of a private type
2560 -- in order to achieve uniformity with the general case.
2562 Add_Inherited_Invariants
2564 Priv_Typ => Node (Iface_Elmt),
2569 Next_Elmt (Iface_Elmt);
2572 end Add_Interface_Invariants;
2574 -------------------------
2575 -- Add_Invariant_Check --
2576 -------------------------
2578 procedure Add_Invariant_Check
2581 Checks : in out List_Id;
2582 Inherited : Boolean := False)
2584 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2585 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2586 Ploc : constant Source_Ptr := Sloc (Prag);
2587 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2593 -- The invariant is ignored, nothing left to do
2595 if Is_Ignored (Prag) then
2598 -- Otherwise the invariant is checked. Build a pragma Check to verify
2599 -- the expression at run time.
2603 Make_Pragma_Argument_Association (Ploc,
2604 Expression => Make_Identifier (Ploc, Nam)),
2605 Make_Pragma_Argument_Association (Ploc,
2606 Expression => Expr));
2608 -- Handle the String argument (if any)
2610 if Present (Str_Arg) then
2611 Str := Strval (Get_Pragma_Arg (Str_Arg));
2613 -- When inheriting an invariant, modify the message from
2614 -- "failed invariant" to "failed inherited invariant".
2617 String_To_Name_Buffer (Str);
2619 if Name_Buffer (1 .. 16) = "failed invariant" then
2620 Insert_Str_In_Name_Buffer ("inherited ", 8);
2621 Str := String_From_Name_Buffer;
2626 Make_Pragma_Argument_Association (Ploc,
2627 Expression => Make_String_Literal (Ploc, Str)));
2631 -- pragma Check (<Nam>, <Expr>, <Str>);
2633 Append_New_To (Checks,
2635 Chars => Name_Check,
2636 Pragma_Argument_Associations => Assoc));
2639 -- Output an info message when inheriting an invariant and the
2640 -- listing option is enabled.
2642 if Inherited and Opt.List_Inherited_Aspects then
2643 Error_Msg_Sloc := Sloc (Prag);
2645 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
2648 -- Add the pragma to the list of processed pragmas
2650 Append_New_Elmt (Prag, Pragmas_Seen);
2651 Produced_Check := True;
2652 end Add_Invariant_Check;
2654 ---------------------------
2655 -- Add_Parent_Invariants --
2656 ---------------------------
2658 procedure Add_Parent_Invariants
2661 Checks : in out List_Id)
2663 Dummy_1 : Entity_Id;
2664 Dummy_2 : Entity_Id;
2666 Curr_Typ : Entity_Id;
2667 -- The entity of the current type being examined
2669 Full_Typ : Entity_Id;
2670 -- The full view of Par_Typ
2672 Par_Typ : Entity_Id;
2673 -- The entity of the parent type
2675 Priv_Typ : Entity_Id;
2676 -- The partial view of Par_Typ
2679 -- Do not process array types because they cannot have true parent
2680 -- types. This also prevents the generation of a duplicate invariant
2681 -- check when the input type is an array base type because its Etype
2682 -- denotes the first subtype, both of which share the same component
2685 if Is_Array_Type (T) then
2689 -- Climb the parent type chain
2693 -- Do not consider subtypes as they inherit the invariants
2694 -- from their base types.
2696 Par_Typ := Base_Type (Etype (Curr_Typ));
2698 -- Stop the climb once the root of the parent chain is
2701 exit when Curr_Typ = Par_Typ;
2703 -- Process the class-wide invariants of the parent type
2705 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
2707 -- Process the elements of an array type
2709 if Is_Array_Type (Full_Typ) then
2710 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
2712 -- Process the components of a record type
2714 elsif Ekind (Full_Typ) = E_Record_Type then
2715 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
2718 Add_Inherited_Invariants
2720 Priv_Typ => Priv_Typ,
2721 Full_Typ => Full_Typ,
2725 Curr_Typ := Par_Typ;
2727 end Add_Parent_Invariants;
2729 ------------------------
2730 -- Add_Own_Invariants --
2731 ------------------------
2733 procedure Add_Own_Invariants
2736 Checks : in out List_Id;
2737 Priv_Item : Node_Id := Empty)
2742 Prag_Expr : Node_Id;
2743 Prag_Expr_Arg : Node_Id;
2745 Prag_Typ_Arg : Node_Id;
2748 if not Present (T) then
2752 Prag := First_Rep_Item (T);
2753 while Present (Prag) loop
2754 if Nkind (Prag) = N_Pragma
2755 and then Pragma_Name (Prag) = Name_Invariant
2757 -- Stop the traversal of the rep item chain once a specific
2758 -- item is encountered.
2760 if Present (Priv_Item) and then Prag = Priv_Item then
2764 -- Nothing to do if the pragma was already processed
2766 if Contains (Pragmas_Seen, Prag) then
2770 -- Extract the arguments of the invariant pragma
2772 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2773 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2774 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
2775 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2776 Prag_Asp := Corresponding_Aspect (Prag);
2778 -- Verify the pragma belongs to T, otherwise the pragma applies
2779 -- to a parent type in which case it will be processed later by
2780 -- Add_Parent_Invariants or Add_Interface_Invariants.
2782 if Entity (Prag_Typ) /= T then
2786 Expr := New_Copy_Tree (Prag_Expr);
2788 -- Substitute all references to type T with references to the
2789 -- _object formal parameter.
2791 Replace_Type_References (Expr, T, Obj_Id);
2793 -- Preanalyze the invariant expression to detect errors and at
2794 -- the same time capture the visibility of the proper package
2797 Set_Parent (Expr, Parent (Prag_Expr));
2798 Preanalyze_Assert_Expression (Expr, Any_Boolean);
2800 -- Save a copy of the expression when T is tagged to detect
2801 -- errors and capture the visibility of the proper package part
2802 -- for the generation of inherited type invariants.
2804 if Is_Tagged_Type (T) then
2805 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
2808 -- If the pragma comes from an aspect specification, replace
2809 -- the saved expression because all type references must be
2810 -- substituted for the call to Preanalyze_Spec_Expression in
2811 -- Check_Aspect_At_xxx routines.
2813 if Present (Prag_Asp) then
2814 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
2817 Add_Invariant_Check (Prag, Expr, Checks);
2820 Next_Rep_Item (Prag);
2822 end Add_Own_Invariants;
2824 -------------------------------------
2825 -- Add_Record_Component_Invariants --
2826 -------------------------------------
2828 procedure Add_Record_Component_Invariants
2831 Checks : in out List_Id)
2833 procedure Process_Component_List
2834 (Comp_List : Node_Id;
2835 CL_Checks : in out List_Id);
2836 -- Generate invariant checks for all record components found in
2837 -- component list Comp_List, including variant parts. All created
2838 -- checks are added to list CL_Checks.
2840 procedure Process_Record_Component
2841 (Comp_Id : Entity_Id;
2842 Comp_Checks : in out List_Id);
2843 -- Generate an invariant check for a record component identified by
2844 -- Comp_Id. All created checks are added to list Comp_Checks.
2846 ----------------------------
2847 -- Process_Component_List --
2848 ----------------------------
2850 procedure Process_Component_List
2851 (Comp_List : Node_Id;
2852 CL_Checks : in out List_Id)
2856 Var_Alts : List_Id := No_List;
2857 Var_Checks : List_Id := No_List;
2858 Var_Stmts : List_Id;
2860 Produced_Variant_Check : Boolean := False;
2861 -- This flag tracks whether the component has produced at least
2862 -- one invariant check.
2865 -- Traverse the component items
2867 Comp := First (Component_Items (Comp_List));
2868 while Present (Comp) loop
2869 if Nkind (Comp) = N_Component_Declaration then
2871 -- Generate the component invariant check
2873 Process_Record_Component
2874 (Comp_Id => Defining_Entity (Comp),
2875 Comp_Checks => CL_Checks);
2881 -- Traverse the variant part
2883 if Present (Variant_Part (Comp_List)) then
2884 Var := First (Variants (Variant_Part (Comp_List)));
2885 while Present (Var) loop
2886 Var_Checks := No_List;
2888 -- Generate invariant checks for all components and variant
2889 -- parts that qualify.
2891 Process_Component_List
2892 (Comp_List => Component_List (Var),
2893 CL_Checks => Var_Checks);
2895 -- The components of the current variant produced at least
2896 -- one invariant check.
2898 if Present (Var_Checks) then
2899 Var_Stmts := Var_Checks;
2900 Produced_Variant_Check := True;
2902 -- Otherwise there are either no components with invariants,
2903 -- assertions are disabled, or Assertion_Policy Ignore is in
2907 Var_Stmts := New_List (Make_Null_Statement (Loc));
2910 Append_New_To (Var_Alts,
2911 Make_Case_Statement_Alternative (Loc,
2913 New_Copy_List (Discrete_Choices (Var)),
2914 Statements => Var_Stmts));
2919 -- Create a case statement which verifies the invariant checks
2920 -- of a particular component list depending on the discriminant
2921 -- values only when there is at least one real invariant check.
2923 if Produced_Variant_Check then
2924 Append_New_To (CL_Checks,
2925 Make_Case_Statement (Loc,
2927 Make_Selected_Component (Loc,
2928 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2931 (Entity (Name (Variant_Part (Comp_List))), Loc)),
2932 Alternatives => Var_Alts));
2935 end Process_Component_List;
2937 ------------------------------
2938 -- Process_Record_Component --
2939 ------------------------------
2941 procedure Process_Record_Component
2942 (Comp_Id : Entity_Id;
2943 Comp_Checks : in out List_Id)
2945 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
2946 Proc_Id : Entity_Id;
2948 Produced_Component_Check : Boolean := False;
2949 -- This flag tracks whether the component has produced at least
2950 -- one invariant check.
2953 -- Nothing to do for internal component _parent. Note that it is
2954 -- not desirable to check whether the component comes from source
2955 -- because protected type components are relocated to an internal
2956 -- corresponding record, but still need processing.
2958 if Chars (Comp_Id) = Name_uParent then
2962 -- Verify the invariant of the component. Note that an access
2963 -- type may have an invariant when it acts as the full view of a
2964 -- private type and the invariant appears on the partial view. In
2965 -- this case verify the access value itself.
2967 if Has_Invariants (Comp_Typ) then
2969 -- In GNATprove mode, the component invariants are checked by
2970 -- other means. They should not be added to the record type
2971 -- invariant procedure, so that the procedure can be used to
2972 -- check the record type invariants if any.
2974 if GNATprove_Mode then
2978 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2980 -- The component type should have an invariant procedure
2981 -- if it has invariants of its own or inherits class-wide
2982 -- invariants from parent or interface types.
2984 pragma Assert (Present (Proc_Id));
2987 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
2989 -- Note that the invariant procedure may have a null body if
2990 -- assertions are disabled or Assertion_Policy Ignore is in
2993 if not Has_Null_Body (Proc_Id) then
2994 Append_New_To (Comp_Checks,
2995 Make_Procedure_Call_Statement (Loc,
2997 New_Occurrence_Of (Proc_Id, Loc),
2998 Parameter_Associations => New_List (
2999 Make_Selected_Component (Loc,
3001 Unchecked_Convert_To
3002 (T, New_Occurrence_Of (Obj_Id, Loc)),
3004 New_Occurrence_Of (Comp_Id, Loc)))));
3008 Produced_Check := True;
3009 Produced_Component_Check := True;
3012 if Produced_Component_Check and then Has_Unchecked_Union (T) then
3014 ("invariants cannot be checked on components of "
3015 & "unchecked_union type &?", Comp_Id, T);
3017 end Process_Record_Component;
3024 -- Start of processing for Add_Record_Component_Invariants
3027 -- An untagged derived type inherits the components of its parent
3028 -- type. In order to avoid creating redundant invariant checks, do
3029 -- not process the components now. Instead wait until the ultimate
3030 -- parent of the untagged derivation chain is reached.
3032 if not Is_Untagged_Derivation (T) then
3033 Def := Type_Definition (Parent (T));
3035 if Nkind (Def) = N_Derived_Type_Definition then
3036 Def := Record_Extension_Part (Def);
3039 pragma Assert (Nkind (Def) = N_Record_Definition);
3040 Comps := Component_List (Def);
3042 if Present (Comps) then
3043 Process_Component_List
3044 (Comp_List => Comps,
3045 CL_Checks => Checks);
3048 end Add_Record_Component_Invariants;
3052 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3053 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3054 -- Save the Ghost-related attributes to restore on exit
3057 Priv_Item : Node_Id;
3058 Proc_Body : Node_Id;
3059 Proc_Body_Id : Entity_Id;
3060 Proc_Decl : Node_Id;
3061 Proc_Id : Entity_Id;
3062 Stmts : List_Id := No_List;
3064 CRec_Typ : Entity_Id := Empty;
3065 -- The corresponding record type of Full_Typ
3067 Full_Proc : Entity_Id := Empty;
3068 -- The entity of the "full" invariant procedure
3070 Full_Typ : Entity_Id := Empty;
3071 -- The full view of the working type
3073 Obj_Id : Entity_Id := Empty;
3074 -- The _object formal parameter of the invariant procedure
3076 Part_Proc : Entity_Id := Empty;
3077 -- The entity of the "partial" invariant procedure
3079 Priv_Typ : Entity_Id := Empty;
3080 -- The partial view of the working type
3082 Work_Typ : Entity_Id := Empty;
3085 -- Start of processing for Build_Invariant_Procedure_Body
3090 -- The input type denotes the implementation base type of a constrained
3091 -- array type. Work with the first subtype as all invariant pragmas are
3092 -- on its rep item chain.
3094 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3095 Work_Typ := First_Subtype (Work_Typ);
3097 -- The input type denotes the corresponding record type of a protected
3098 -- or task type. Work with the concurrent type because the corresponding
3099 -- record type may not be visible to clients of the type.
3101 elsif Ekind (Work_Typ) = E_Record_Type
3102 and then Is_Concurrent_Record_Type (Work_Typ)
3104 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3107 -- The working type may be subject to pragma Ghost. Set the mode now to
3108 -- ensure that the invariant procedure is properly marked as Ghost.
3110 Set_Ghost_Mode (Work_Typ);
3112 -- The type must either have invariants of its own, inherit class-wide
3113 -- invariants from parent types or interfaces, or be an array or record
3114 -- type whose components have invariants.
3116 pragma Assert (Has_Invariants (Work_Typ));
3118 -- Interfaces are treated as the partial view of a private type in order
3119 -- to achieve uniformity with the general case.
3121 if Is_Interface (Work_Typ) then
3122 Priv_Typ := Work_Typ;
3124 -- Otherwise obtain both views of the type
3127 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
3130 -- The caller requests a body for the partial invariant procedure
3132 if Partial_Invariant then
3133 Full_Proc := Invariant_Procedure (Work_Typ);
3134 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3136 -- The "full" invariant procedure body was already created
3138 if Present (Full_Proc)
3140 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
3142 -- This scenario happens only when the type is an untagged
3143 -- derivation from a private parent and the underlying full
3144 -- view was processed before the partial view.
3147 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3149 -- Nothing to do because the processing of the underlying full
3150 -- view already checked the invariants of the partial view.
3155 -- Create a declaration for the "partial" invariant procedure if it
3156 -- is not available.
3158 if No (Proc_Id) then
3159 Build_Invariant_Procedure_Declaration
3161 Partial_Invariant => True);
3163 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3166 -- The caller requests a body for the "full" invariant procedure
3169 Proc_Id := Invariant_Procedure (Work_Typ);
3170 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3172 -- Create a declaration for the "full" invariant procedure if it is
3175 if No (Proc_Id) then
3176 Build_Invariant_Procedure_Declaration (Work_Typ);
3177 Proc_Id := Invariant_Procedure (Work_Typ);
3181 -- At this point there should be an invariant procedure declaration
3183 pragma Assert (Present (Proc_Id));
3184 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3186 -- Nothing to do if the invariant procedure already has a body
3188 if Present (Corresponding_Body (Proc_Decl)) then
3192 -- Emulate the environment of the invariant procedure by installing its
3193 -- scope and formal parameters. Note that this is not needed, but having
3194 -- the scope installed helps with the detection of invariant-related
3197 Push_Scope (Proc_Id);
3198 Install_Formals (Proc_Id);
3200 Obj_Id := First_Formal (Proc_Id);
3201 pragma Assert (Present (Obj_Id));
3203 -- The "partial" invariant procedure verifies the invariants of the
3204 -- partial view only.
3206 if Partial_Invariant then
3207 pragma Assert (Present (Priv_Typ));
3214 -- Otherwise the "full" invariant procedure verifies the invariants of
3215 -- the full view, all array or record components, as well as class-wide
3216 -- invariants inherited from parent types or interfaces. In addition, it
3217 -- indirectly verifies the invariants of the partial view by calling the
3218 -- "partial" invariant procedure.
3221 pragma Assert (Present (Full_Typ));
3223 -- Check the invariants of the partial view by calling the "partial"
3224 -- invariant procedure. Generate:
3226 -- <Work_Typ>Partial_Invariant (_object);
3228 if Present (Part_Proc) then
3229 Append_New_To (Stmts,
3230 Make_Procedure_Call_Statement (Loc,
3231 Name => New_Occurrence_Of (Part_Proc, Loc),
3232 Parameter_Associations => New_List (
3233 New_Occurrence_Of (Obj_Id, Loc))));
3235 Produced_Check := True;
3240 -- Derived subtypes do not have a partial view
3242 if Present (Priv_Typ) then
3244 -- The processing of the "full" invariant procedure intentionally
3245 -- skips the partial view because a) this may result in changes of
3246 -- visibility and b) lead to duplicate checks. However, when the
3247 -- full view is the underlying full view of an untagged derived
3248 -- type whose parent type is private, partial invariants appear on
3249 -- the rep item chain of the partial view only.
3251 -- package Pack_1 is
3252 -- type Root ... is private;
3254 -- <full view of Root>
3258 -- package Pack_2 is
3259 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3260 -- <underlying full view of Child>
3263 -- As a result, the processing of the full view must also consider
3264 -- all invariants of the partial view.
3266 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3269 -- Otherwise the invariants of the partial view are ignored
3272 -- Note that the rep item chain is shared between the partial
3273 -- and full views of a type. To avoid processing the invariants
3274 -- of the partial view, signal the logic to stop when the first
3275 -- rep item of the partial view has been reached.
3277 Priv_Item := First_Rep_Item (Priv_Typ);
3279 -- Ignore the invariants of the partial view by eliminating the
3286 -- Process the invariants of the full view and in certain cases those
3287 -- of the partial view. This also handles any invariants on array or
3288 -- record components.
3294 Priv_Item => Priv_Item);
3300 Priv_Item => Priv_Item);
3302 -- Process the elements of an array type
3304 if Is_Array_Type (Full_Typ) then
3305 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3307 -- Process the components of a record type
3309 elsif Ekind (Full_Typ) = E_Record_Type then
3310 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3312 -- Process the components of a corresponding record
3314 elsif Present (CRec_Typ) then
3315 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3318 -- Process the inherited class-wide invariants of all parent types.
3319 -- This also handles any invariants on record components.
3321 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3323 -- Process the inherited class-wide invariants of all implemented
3326 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3331 -- At this point there should be at least one invariant check. If this
3332 -- is not the case, then the invariant-related flags were not properly
3333 -- set, or there is a missing invariant procedure on one of the array
3334 -- or record components.
3336 pragma Assert (Produced_Check);
3338 -- Account for the case where assertions are disabled or all invariant
3339 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3343 Stmts := New_List (Make_Null_Statement (Loc));
3347 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3350 -- end <Work_Typ>[Partial_]Invariant;
3353 Make_Subprogram_Body (Loc,
3355 Copy_Subprogram_Spec (Parent (Proc_Id)),
3356 Declarations => Empty_List,
3357 Handled_Statement_Sequence =>
3358 Make_Handled_Sequence_Of_Statements (Loc,
3359 Statements => Stmts));
3360 Proc_Body_Id := Defining_Entity (Proc_Body);
3362 -- Perform minor decoration in case the body is not analyzed
3364 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
3365 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3366 Set_Scope (Proc_Body_Id, Current_Scope);
3368 -- Link both spec and body to avoid generating duplicates
3370 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3371 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3373 -- The body should not be inserted into the tree when the context is
3374 -- a generic unit because it is not part of the template. Note
3375 -- that the body must still be generated in order to resolve the
3378 if Inside_A_Generic then
3381 -- Semi-insert the body into the tree for GNATprove by setting its
3382 -- Parent field. This allows for proper upstream tree traversals.
3384 elsif GNATprove_Mode then
3385 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3387 -- Otherwise the body is part of the freezing actions of the type
3390 Append_Freeze_Action (Work_Typ, Proc_Body);
3394 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3395 end Build_Invariant_Procedure_Body;
3397 -------------------------------------------
3398 -- Build_Invariant_Procedure_Declaration --
3399 -------------------------------------------
3401 -- WARNING: This routine manages Ghost regions. Return statements must be
3402 -- replaced by gotos which jump to the end of the routine and restore the
3405 procedure Build_Invariant_Procedure_Declaration
3407 Partial_Invariant : Boolean := False)
3409 Loc : constant Source_Ptr := Sloc (Typ);
3411 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3412 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3413 -- Save the Ghost-related attributes to restore on exit
3415 Proc_Decl : Node_Id;
3416 Proc_Id : Entity_Id;
3420 CRec_Typ : Entity_Id;
3421 -- The corresponding record type of Full_Typ
3423 Full_Base : Entity_Id;
3424 -- The base type of Full_Typ
3426 Full_Typ : Entity_Id;
3427 -- The full view of working type
3430 -- The _object formal parameter of the invariant procedure
3432 Obj_Typ : Entity_Id;
3433 -- The type of the _object formal parameter
3435 Priv_Typ : Entity_Id;
3436 -- The partial view of working type
3438 Work_Typ : Entity_Id;
3444 -- The input type denotes the implementation base type of a constrained
3445 -- array type. Work with the first subtype as all invariant pragmas are
3446 -- on its rep item chain.
3448 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3449 Work_Typ := First_Subtype (Work_Typ);
3451 -- The input denotes the corresponding record type of a protected or a
3452 -- task type. Work with the concurrent type because the corresponding
3453 -- record type may not be visible to clients of the type.
3455 elsif Ekind (Work_Typ) = E_Record_Type
3456 and then Is_Concurrent_Record_Type (Work_Typ)
3458 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3461 -- The working type may be subject to pragma Ghost. Set the mode now to
3462 -- ensure that the invariant procedure is properly marked as Ghost.
3464 Set_Ghost_Mode (Work_Typ);
3466 -- The type must either have invariants of its own, inherit class-wide
3467 -- invariants from parent or interface types, or be an array or record
3468 -- type whose components have invariants.
3470 pragma Assert (Has_Invariants (Work_Typ));
3472 -- Nothing to do if the type already has a "partial" invariant procedure
3474 if Partial_Invariant then
3475 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3479 -- Nothing to do if the type already has a "full" invariant procedure
3481 elsif Present (Invariant_Procedure (Work_Typ)) then
3485 -- The caller requests the declaration of the "partial" invariant
3488 if Partial_Invariant then
3489 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3491 -- Otherwise the caller requests the declaration of the "full" invariant
3495 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3498 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3500 -- Perform minor decoration in case the declaration is not analyzed
3502 Set_Ekind (Proc_Id, E_Procedure);
3503 Set_Etype (Proc_Id, Standard_Void_Type);
3504 Set_Scope (Proc_Id, Current_Scope);
3506 if Partial_Invariant then
3507 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3508 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3510 Set_Is_Invariant_Procedure (Proc_Id);
3511 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3514 -- The invariant procedure requires debug info when the invariants are
3515 -- subject to Source Coverage Obligations.
3517 if Generate_SCO then
3518 Set_Debug_Info_Needed (Proc_Id);
3521 -- Obtain all views of the input type
3523 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
3525 -- Associate the invariant procedure with all views
3527 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3528 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3529 Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ);
3530 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3532 -- The declaration of the invariant procedure is inserted after the
3533 -- declaration of the partial view as this allows for proper external
3536 if Present (Priv_Typ) then
3537 Typ_Decl := Declaration_Node (Priv_Typ);
3539 -- Anonymous arrays in object declarations have no explicit declaration
3540 -- so use the related object declaration as the insertion point.
3542 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
3543 Typ_Decl := Associated_Node_For_Itype (Work_Typ);
3545 -- Derived types with the full view as parent do not have a partial
3546 -- view. Insert the invariant procedure after the derived type.
3549 Typ_Decl := Declaration_Node (Full_Typ);
3552 -- The type should have a declarative node
3554 pragma Assert (Present (Typ_Decl));
3556 -- Create the formal parameter which emulates the variable-like behavior
3557 -- of the current type instance.
3559 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3561 -- When generating an invariant procedure declaration for an abstract
3562 -- type (including interfaces), use the class-wide type as the _object
3563 -- type. This has several desirable effects:
3565 -- * The invariant procedure does not become a primitive of the type.
3566 -- This eliminates the need to either special case the treatment of
3567 -- invariant procedures, or to make it a predefined primitive and
3568 -- force every derived type to potentially provide an empty body.
3570 -- * The invariant procedure does not need to be declared as abstract.
3571 -- This allows for a proper body, which in turn avoids redundant
3572 -- processing of the same invariants for types with multiple views.
3574 -- * The class-wide type allows for calls to abstract primitives
3575 -- within a nonabstract subprogram. The calls are treated as
3576 -- dispatching and require additional processing when they are
3577 -- remapped to call primitives of derived types. See routine
3578 -- Replace_References for details.
3580 if Is_Abstract_Type (Work_Typ) then
3581 Obj_Typ := Class_Wide_Type (Work_Typ);
3583 Obj_Typ := Work_Typ;
3586 -- Perform minor decoration in case the declaration is not analyzed
3588 Set_Ekind (Obj_Id, E_In_Parameter);
3589 Set_Etype (Obj_Id, Obj_Typ);
3590 Set_Scope (Obj_Id, Proc_Id);
3592 Set_First_Entity (Proc_Id, Obj_Id);
3593 Set_Last_Entity (Proc_Id, Obj_Id);
3596 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3599 Make_Subprogram_Declaration (Loc,
3601 Make_Procedure_Specification (Loc,
3602 Defining_Unit_Name => Proc_Id,
3603 Parameter_Specifications => New_List (
3604 Make_Parameter_Specification (Loc,
3605 Defining_Identifier => Obj_Id,
3606 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3608 -- The declaration should not be inserted into the tree when the context
3609 -- is a generic unit because it is not part of the template.
3611 if Inside_A_Generic then
3614 -- Semi-insert the declaration into the tree for GNATprove by setting
3615 -- its Parent field. This allows for proper upstream tree traversals.
3617 elsif GNATprove_Mode then
3618 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3620 -- Otherwise insert the declaration
3623 pragma Assert (Present (Typ_Decl));
3624 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3628 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3629 end Build_Invariant_Procedure_Declaration;
3631 --------------------------
3632 -- Build_Procedure_Form --
3633 --------------------------
3635 procedure Build_Procedure_Form (N : Node_Id) is
3636 Loc : constant Source_Ptr := Sloc (N);
3637 Subp : constant Entity_Id := Defining_Entity (N);
3639 Func_Formal : Entity_Id;
3640 Proc_Formals : List_Id;
3641 Proc_Decl : Node_Id;
3644 -- No action needed if this transformation was already done, or in case
3645 -- of subprogram renaming declarations.
3647 if Nkind (Specification (N)) = N_Procedure_Specification
3648 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3653 -- Ditto when dealing with an expression function, where both the
3654 -- original expression and the generated declaration end up being
3657 if Rewritten_For_C (Subp) then
3661 Proc_Formals := New_List;
3663 -- Create a list of formal parameters with the same types as the
3666 Func_Formal := First_Formal (Subp);
3667 while Present (Func_Formal) loop
3668 Append_To (Proc_Formals,
3669 Make_Parameter_Specification (Loc,
3670 Defining_Identifier =>
3671 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
3673 New_Occurrence_Of (Etype (Func_Formal), Loc)));
3675 Next_Formal (Func_Formal);
3678 -- Add an extra out parameter to carry the function result
3681 Name_Buffer (1 .. Name_Len) := "RESULT";
3682 Append_To (Proc_Formals,
3683 Make_Parameter_Specification (Loc,
3684 Defining_Identifier =>
3685 Make_Defining_Identifier (Loc, Chars => Name_Find),
3686 Out_Present => True,
3687 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
3689 -- The new procedure declaration is inserted immediately after the
3690 -- function declaration. The processing in Build_Procedure_Body_Form
3691 -- relies on this order.
3694 Make_Subprogram_Declaration (Loc,
3696 Make_Procedure_Specification (Loc,
3697 Defining_Unit_Name =>
3698 Make_Defining_Identifier (Loc, Chars (Subp)),
3699 Parameter_Specifications => Proc_Formals));
3701 Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
3703 -- Entity of procedure must remain invisible so that it does not
3704 -- overload subsequent references to the original function.
3706 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
3708 -- Mark the function as having a procedure form and link the function
3709 -- and its internally built procedure.
3711 Set_Rewritten_For_C (Subp);
3712 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
3713 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
3714 end Build_Procedure_Form;
3716 ------------------------
3717 -- Build_Runtime_Call --
3718 ------------------------
3720 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
3722 -- If entity is not available, we can skip making the call (this avoids
3723 -- junk duplicated error messages in a number of cases).
3725 if not RTE_Available (RE) then
3726 return Make_Null_Statement (Loc);
3729 Make_Procedure_Call_Statement (Loc,
3730 Name => New_Occurrence_Of (RTE (RE), Loc));
3732 end Build_Runtime_Call;
3734 ------------------------
3735 -- Build_SS_Mark_Call --
3736 ------------------------
3738 function Build_SS_Mark_Call
3740 Mark : Entity_Id) return Node_Id
3744 -- Mark : constant Mark_Id := SS_Mark;
3747 Make_Object_Declaration (Loc,
3748 Defining_Identifier => Mark,
3749 Constant_Present => True,
3750 Object_Definition =>
3751 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
3753 Make_Function_Call (Loc,
3754 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
3755 end Build_SS_Mark_Call;
3757 ---------------------------
3758 -- Build_SS_Release_Call --
3759 ---------------------------
3761 function Build_SS_Release_Call
3763 Mark : Entity_Id) return Node_Id
3767 -- SS_Release (Mark);
3770 Make_Procedure_Call_Statement (Loc,
3772 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
3773 Parameter_Associations => New_List (
3774 New_Occurrence_Of (Mark, Loc)));
3775 end Build_SS_Release_Call;
3777 ----------------------------
3778 -- Build_Task_Array_Image --
3779 ----------------------------
3781 -- This function generates the body for a function that constructs the
3782 -- image string for a task that is an array component. The function is
3783 -- local to the init proc for the array type, and is called for each one
3784 -- of the components. The constructed image has the form of an indexed
3785 -- component, whose prefix is the outer variable of the array type.
3786 -- The n-dimensional array type has known indexes Index, Index2...
3788 -- Id_Ref is an indexed component form created by the enclosing init proc.
3789 -- Its successive indexes are Val1, Val2, ... which are the loop variables
3790 -- in the loops that call the individual task init proc on each component.
3792 -- The generated function has the following structure:
3794 -- function F return String is
3795 -- Pref : string renames Task_Name;
3796 -- T1 : String := Index1'Image (Val1);
3798 -- Tn : String := indexn'image (Valn);
3799 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
3800 -- -- Len includes commas and the end parentheses.
3801 -- Res : String (1..Len);
3802 -- Pos : Integer := Pref'Length;
3805 -- Res (1 .. Pos) := Pref;
3807 -- Res (Pos) := '(';
3809 -- Res (Pos .. Pos + T1'Length - 1) := T1;
3810 -- Pos := Pos + T1'Length;
3811 -- Res (Pos) := '.';
3814 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
3815 -- Res (Len) := ')';
3820 -- Needless to say, multidimensional arrays of tasks are rare enough that
3821 -- the bulkiness of this code is not really a concern.
3823 function Build_Task_Array_Image
3827 Dyn : Boolean := False) return Node_Id
3829 Dims : constant Nat := Number_Dimensions (A_Type);
3830 -- Number of dimensions for array of tasks
3832 Temps : array (1 .. Dims) of Entity_Id;
3833 -- Array of temporaries to hold string for each index
3839 -- Total length of generated name
3842 -- Running index for substring assignments
3844 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
3845 -- Name of enclosing variable, prefix of resulting name
3848 -- String to hold result
3851 -- Value of successive indexes
3854 -- Expression to compute total size of string
3857 -- Entity for name at one index position
3859 Decls : constant List_Id := New_List;
3860 Stats : constant List_Id := New_List;
3863 -- For a dynamic task, the name comes from the target variable. For a
3864 -- static one it is a formal of the enclosing init proc.
3867 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
3869 Make_Object_Declaration (Loc,
3870 Defining_Identifier => Pref,
3871 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3873 Make_String_Literal (Loc,
3874 Strval => String_From_Name_Buffer)));
3878 Make_Object_Renaming_Declaration (Loc,
3879 Defining_Identifier => Pref,
3880 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
3881 Name => Make_Identifier (Loc, Name_uTask_Name)));
3884 Indx := First_Index (A_Type);
3885 Val := First (Expressions (Id_Ref));
3887 for J in 1 .. Dims loop
3888 T := Make_Temporary (Loc, 'T');
3892 Make_Object_Declaration (Loc,
3893 Defining_Identifier => T,
3894 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3896 Make_Attribute_Reference (Loc,
3897 Attribute_Name => Name_Image,
3898 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
3899 Expressions => New_List (New_Copy_Tree (Val)))));
3905 Sum := Make_Integer_Literal (Loc, Dims + 1);
3911 Make_Attribute_Reference (Loc,
3912 Attribute_Name => Name_Length,
3913 Prefix => New_Occurrence_Of (Pref, Loc),
3914 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3916 for J in 1 .. Dims loop
3921 Make_Attribute_Reference (Loc,
3922 Attribute_Name => Name_Length,
3924 New_Occurrence_Of (Temps (J), Loc),
3925 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3928 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
3930 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
3933 Make_Assignment_Statement (Loc,
3935 Make_Indexed_Component (Loc,
3936 Prefix => New_Occurrence_Of (Res, Loc),
3937 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
3939 Make_Character_Literal (Loc,
3941 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
3944 Make_Assignment_Statement (Loc,
3945 Name => New_Occurrence_Of (Pos, Loc),
3948 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3949 Right_Opnd => Make_Integer_Literal (Loc, 1))));
3951 for J in 1 .. Dims loop
3954 Make_Assignment_Statement (Loc,
3957 Prefix => New_Occurrence_Of (Res, Loc),
3960 Low_Bound => New_Occurrence_Of (Pos, Loc),
3962 Make_Op_Subtract (Loc,
3965 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3967 Make_Attribute_Reference (Loc,
3968 Attribute_Name => Name_Length,
3970 New_Occurrence_Of (Temps (J), Loc),
3972 New_List (Make_Integer_Literal (Loc, 1)))),
3973 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
3975 Expression => New_Occurrence_Of (Temps (J), Loc)));
3979 Make_Assignment_Statement (Loc,
3980 Name => New_Occurrence_Of (Pos, Loc),
3983 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3985 Make_Attribute_Reference (Loc,
3986 Attribute_Name => Name_Length,
3987 Prefix => New_Occurrence_Of (Temps (J), Loc),
3989 New_List (Make_Integer_Literal (Loc, 1))))));
3991 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
3994 Make_Assignment_Statement (Loc,
3995 Name => Make_Indexed_Component (Loc,
3996 Prefix => New_Occurrence_Of (Res, Loc),
3997 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
3999 Make_Character_Literal (Loc,
4001 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
4004 Make_Assignment_Statement (Loc,
4005 Name => New_Occurrence_Of (Pos, Loc),
4008 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4009 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4013 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
4016 Make_Assignment_Statement (Loc,
4018 Make_Indexed_Component (Loc,
4019 Prefix => New_Occurrence_Of (Res, Loc),
4020 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
4022 Make_Character_Literal (Loc,
4024 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
4025 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4026 end Build_Task_Array_Image;
4028 ----------------------------
4029 -- Build_Task_Image_Decls --
4030 ----------------------------
4032 function Build_Task_Image_Decls
4036 In_Init_Proc : Boolean := False) return List_Id
4038 Decls : constant List_Id := New_List;
4039 T_Id : Entity_Id := Empty;
4041 Expr : Node_Id := Empty;
4042 Fun : Node_Id := Empty;
4043 Is_Dyn : constant Boolean :=
4044 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
4046 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
4049 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
4050 -- generate a dummy declaration only.
4052 if Restriction_Active (No_Implicit_Heap_Allocations)
4053 or else Global_Discard_Names
4055 T_Id := Make_Temporary (Loc, 'J');
4060 Make_Object_Declaration (Loc,
4061 Defining_Identifier => T_Id,
4062 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4064 Make_String_Literal (Loc,
4065 Strval => String_From_Name_Buffer)));
4068 if Nkind (Id_Ref) = N_Identifier
4069 or else Nkind (Id_Ref) = N_Defining_Identifier
4071 -- For a simple variable, the image of the task is built from
4072 -- the name of the variable. To avoid possible conflict with the
4073 -- anonymous type created for a single protected object, add a
4077 Make_Defining_Identifier (Loc,
4078 New_External_Name (Chars (Id_Ref), 'T', 1));
4080 Get_Name_String (Chars (Id_Ref));
4083 Make_String_Literal (Loc,
4084 Strval => String_From_Name_Buffer);
4086 elsif Nkind (Id_Ref) = N_Selected_Component then
4088 Make_Defining_Identifier (Loc,
4089 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
4090 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
4092 elsif Nkind (Id_Ref) = N_Indexed_Component then
4094 Make_Defining_Identifier (Loc,
4095 New_External_Name (Chars (A_Type), 'N'));
4097 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
4101 if Present (Fun) then
4102 Append (Fun, Decls);
4103 Expr := Make_Function_Call (Loc,
4104 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
4106 if not In_Init_Proc then
4107 Set_Uses_Sec_Stack (Defining_Entity (Fun));
4111 Decl := Make_Object_Declaration (Loc,
4112 Defining_Identifier => T_Id,
4113 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4114 Constant_Present => True,
4115 Expression => Expr);
4117 Append (Decl, Decls);
4119 end Build_Task_Image_Decls;
4121 -------------------------------
4122 -- Build_Task_Image_Function --
4123 -------------------------------
4125 function Build_Task_Image_Function
4129 Res : Entity_Id) return Node_Id
4135 Make_Simple_Return_Statement (Loc,
4136 Expression => New_Occurrence_Of (Res, Loc)));
4138 Spec := Make_Function_Specification (Loc,
4139 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
4140 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
4142 -- Calls to 'Image use the secondary stack, which must be cleaned up
4143 -- after the task name is built.
4145 return Make_Subprogram_Body (Loc,
4146 Specification => Spec,
4147 Declarations => Decls,
4148 Handled_Statement_Sequence =>
4149 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
4150 end Build_Task_Image_Function;
4152 -----------------------------
4153 -- Build_Task_Image_Prefix --
4154 -----------------------------
4156 procedure Build_Task_Image_Prefix
4158 Len : out Entity_Id;
4159 Res : out Entity_Id;
4160 Pos : out Entity_Id;
4167 Len := Make_Temporary (Loc, 'L', Sum);
4170 Make_Object_Declaration (Loc,
4171 Defining_Identifier => Len,
4172 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4173 Expression => Sum));
4175 Res := Make_Temporary (Loc, 'R');
4178 Make_Object_Declaration (Loc,
4179 Defining_Identifier => Res,
4180 Object_Definition =>
4181 Make_Subtype_Indication (Loc,
4182 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4184 Make_Index_Or_Discriminant_Constraint (Loc,
4188 Low_Bound => Make_Integer_Literal (Loc, 1),
4189 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4191 -- Indicate that the result is an internal temporary, so it does not
4192 -- receive a bogus initialization when declaration is expanded. This
4193 -- is both efficient, and prevents anomalies in the handling of
4194 -- dynamic objects on the secondary stack.
4196 Set_Is_Internal (Res);
4197 Pos := Make_Temporary (Loc, 'P');
4200 Make_Object_Declaration (Loc,
4201 Defining_Identifier => Pos,
4202 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4204 -- Pos := Prefix'Length;
4207 Make_Assignment_Statement (Loc,
4208 Name => New_Occurrence_Of (Pos, Loc),
4210 Make_Attribute_Reference (Loc,
4211 Attribute_Name => Name_Length,
4212 Prefix => New_Occurrence_Of (Prefix, Loc),
4213 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4215 -- Res (1 .. Pos) := Prefix;
4218 Make_Assignment_Statement (Loc,
4221 Prefix => New_Occurrence_Of (Res, Loc),
4224 Low_Bound => Make_Integer_Literal (Loc, 1),
4225 High_Bound => New_Occurrence_Of (Pos, Loc))),
4227 Expression => New_Occurrence_Of (Prefix, Loc)));
4230 Make_Assignment_Statement (Loc,
4231 Name => New_Occurrence_Of (Pos, Loc),
4234 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4235 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4236 end Build_Task_Image_Prefix;
4238 -----------------------------
4239 -- Build_Task_Record_Image --
4240 -----------------------------
4242 function Build_Task_Record_Image
4245 Dyn : Boolean := False) return Node_Id
4248 -- Total length of generated name
4251 -- Index into result
4254 -- String to hold result
4256 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4257 -- Name of enclosing variable, prefix of resulting name
4260 -- Expression to compute total size of string
4263 -- Entity for selector name
4265 Decls : constant List_Id := New_List;
4266 Stats : constant List_Id := New_List;
4269 -- For a dynamic task, the name comes from the target variable. For a
4270 -- static one it is a formal of the enclosing init proc.
4273 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4275 Make_Object_Declaration (Loc,
4276 Defining_Identifier => Pref,
4277 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4279 Make_String_Literal (Loc,
4280 Strval => String_From_Name_Buffer)));
4284 Make_Object_Renaming_Declaration (Loc,
4285 Defining_Identifier => Pref,
4286 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4287 Name => Make_Identifier (Loc, Name_uTask_Name)));
4290 Sel := Make_Temporary (Loc, 'S');
4292 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4295 Make_Object_Declaration (Loc,
4296 Defining_Identifier => Sel,
4297 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4299 Make_String_Literal (Loc,
4300 Strval => String_From_Name_Buffer)));
4302 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4308 Make_Attribute_Reference (Loc,
4309 Attribute_Name => Name_Length,
4311 New_Occurrence_Of (Pref, Loc),
4312 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4314 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4316 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
4318 -- Res (Pos) := '.';
4321 Make_Assignment_Statement (Loc,
4322 Name => Make_Indexed_Component (Loc,
4323 Prefix => New_Occurrence_Of (Res, Loc),
4324 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4326 Make_Character_Literal (Loc,
4328 Char_Literal_Value =>
4329 UI_From_Int (Character'Pos ('.')))));
4332 Make_Assignment_Statement (Loc,
4333 Name => New_Occurrence_Of (Pos, Loc),
4336 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4337 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4339 -- Res (Pos .. Len) := Selector;
4342 Make_Assignment_Statement (Loc,
4343 Name => Make_Slice (Loc,
4344 Prefix => New_Occurrence_Of (Res, Loc),
4347 Low_Bound => New_Occurrence_Of (Pos, Loc),
4348 High_Bound => New_Occurrence_Of (Len, Loc))),
4349 Expression => New_Occurrence_Of (Sel, Loc)));
4351 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4352 end Build_Task_Record_Image;
4354 ---------------------------------------
4355 -- Build_Transient_Object_Statements --
4356 ---------------------------------------
4358 procedure Build_Transient_Object_Statements
4359 (Obj_Decl : Node_Id;
4360 Fin_Call : out Node_Id;
4361 Hook_Assign : out Node_Id;
4362 Hook_Clear : out Node_Id;
4363 Hook_Decl : out Node_Id;
4364 Ptr_Decl : out Node_Id;
4365 Finalize_Obj : Boolean := True)
4367 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4368 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4369 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4371 Desig_Typ : Entity_Id;
4372 Hook_Expr : Node_Id;
4373 Hook_Id : Entity_Id;
4375 Ptr_Typ : Entity_Id;
4378 -- Recover the type of the object
4380 Desig_Typ := Obj_Typ;
4382 if Is_Access_Type (Desig_Typ) then
4383 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4386 -- Create an access type which provides a reference to the transient
4387 -- object. Generate:
4389 -- type Ptr_Typ is access all Desig_Typ;
4391 Ptr_Typ := Make_Temporary (Loc, 'A');
4392 Set_Ekind (Ptr_Typ, E_General_Access_Type);
4393 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4396 Make_Full_Type_Declaration (Loc,
4397 Defining_Identifier => Ptr_Typ,
4399 Make_Access_To_Object_Definition (Loc,
4400 All_Present => True,
4401 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4403 -- Create a temporary check which acts as a hook to the transient
4404 -- object. Generate:
4406 -- Hook : Ptr_Typ := null;
4408 Hook_Id := Make_Temporary (Loc, 'T');
4409 Set_Ekind (Hook_Id, E_Variable);
4410 Set_Etype (Hook_Id, Ptr_Typ);
4413 Make_Object_Declaration (Loc,
4414 Defining_Identifier => Hook_Id,
4415 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4416 Expression => Make_Null (Loc));
4418 -- Mark the temporary as a hook. This signals the machinery in
4419 -- Build_Finalizer to recognize this special case.
4421 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4423 -- Hook the transient object to the temporary. Generate:
4425 -- Hook := Ptr_Typ (Obj_Id);
4427 -- Hool := Obj_Id'Unrestricted_Access;
4429 if Is_Access_Type (Obj_Typ) then
4431 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4434 Make_Attribute_Reference (Loc,
4435 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4436 Attribute_Name => Name_Unrestricted_Access);
4440 Make_Assignment_Statement (Loc,
4441 Name => New_Occurrence_Of (Hook_Id, Loc),
4442 Expression => Hook_Expr);
4444 -- Crear the hook prior to finalizing the object. Generate:
4449 Make_Assignment_Statement (Loc,
4450 Name => New_Occurrence_Of (Hook_Id, Loc),
4451 Expression => Make_Null (Loc));
4453 -- Finalize the object. Generate:
4455 -- [Deep_]Finalize (Obj_Ref[.all]);
4457 if Finalize_Obj then
4458 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4460 if Is_Access_Type (Obj_Typ) then
4461 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4462 Set_Etype (Obj_Ref, Desig_Typ);
4467 (Obj_Ref => Obj_Ref,
4470 -- Otherwise finalize the hook. Generate:
4472 -- [Deep_]Finalize (Hook.all);
4478 Make_Explicit_Dereference (Loc,
4479 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4482 end Build_Transient_Object_Statements;
4484 -----------------------------
4485 -- Check_Float_Op_Overflow --
4486 -----------------------------
4488 procedure Check_Float_Op_Overflow (N : Node_Id) is
4490 -- Return if no check needed
4492 if not Is_Floating_Point_Type (Etype (N))
4493 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4495 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4496 -- and do not expand the code for float overflow checking.
4498 or else CodePeer_Mode
4503 -- Otherwise we replace the expression by
4505 -- do Tnn : constant ftype := expression;
4506 -- constraint_error when not Tnn'Valid;
4510 Loc : constant Source_Ptr := Sloc (N);
4511 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4512 Typ : constant Entity_Id := Etype (N);
4515 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4516 -- right here. We also set the node as analyzed to prevent infinite
4517 -- recursion from repeating the operation in the expansion.
4519 Set_Do_Overflow_Check (N, False);
4520 Set_Analyzed (N, True);
4522 -- Do the rewrite to include the check
4525 Make_Expression_With_Actions (Loc,
4526 Actions => New_List (
4527 Make_Object_Declaration (Loc,
4528 Defining_Identifier => Tnn,
4529 Object_Definition => New_Occurrence_Of (Typ, Loc),
4530 Constant_Present => True,
4531 Expression => Relocate_Node (N)),
4532 Make_Raise_Constraint_Error (Loc,
4536 Make_Attribute_Reference (Loc,
4537 Prefix => New_Occurrence_Of (Tnn, Loc),
4538 Attribute_Name => Name_Valid)),
4539 Reason => CE_Overflow_Check_Failed)),
4540 Expression => New_Occurrence_Of (Tnn, Loc)));
4542 Analyze_And_Resolve (N, Typ);
4544 end Check_Float_Op_Overflow;
4546 ----------------------------------
4547 -- Component_May_Be_Bit_Aligned --
4548 ----------------------------------
4550 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4554 -- If no component clause, then everything is fine, since the back end
4555 -- never misaligns from byte boundaries by default, even if there is a
4556 -- pragma Pack for the record.
4558 if No (Comp) or else No (Component_Clause (Comp)) then
4562 UT := Underlying_Type (Etype (Comp));
4564 -- It is only array and record types that cause trouble
4566 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4569 -- If we know that we have a small (64 bits or less) record or small
4570 -- bit-packed array, then everything is fine, since the back end can
4571 -- handle these cases correctly.
4573 elsif Esize (Comp) <= 64
4574 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4578 -- Otherwise if the component is not byte aligned, we know we have the
4579 -- nasty unaligned case.
4581 elsif Normalized_First_Bit (Comp) /= Uint_0
4582 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4586 -- If we are large and byte aligned, then OK at this level
4591 end Component_May_Be_Bit_Aligned;
4593 ----------------------------------------
4594 -- Containing_Package_With_Ext_Axioms --
4595 ----------------------------------------
4597 function Containing_Package_With_Ext_Axioms
4598 (E : Entity_Id) return Entity_Id
4601 -- E is the package or generic package which is externally axiomatized
4603 if Is_Package_Or_Generic_Package (E)
4604 and then Has_Annotate_Pragma_For_External_Axiomatization (E)
4609 -- If E's scope is axiomatized, E is axiomatized
4611 if Present (Scope (E)) then
4613 First_Ax_Parent_Scope : constant Entity_Id :=
4614 Containing_Package_With_Ext_Axioms (Scope (E));
4616 if Present (First_Ax_Parent_Scope) then
4617 return First_Ax_Parent_Scope;
4622 -- Otherwise, if E is a package instance, it is axiomatized if the
4623 -- corresponding generic package is axiomatized.
4625 if Ekind (E) = E_Package then
4627 Par : constant Node_Id := Parent (E);
4631 if Nkind (Par) = N_Defining_Program_Unit_Name then
4632 Decl := Parent (Par);
4637 if Present (Generic_Parent (Decl)) then
4639 Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
4645 end Containing_Package_With_Ext_Axioms;
4647 -------------------------------
4648 -- Convert_To_Actual_Subtype --
4649 -------------------------------
4651 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
4655 Act_ST := Get_Actual_Subtype (Exp);
4657 if Act_ST = Etype (Exp) then
4660 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4661 Analyze_And_Resolve (Exp, Act_ST);
4663 end Convert_To_Actual_Subtype;
4665 -----------------------------------
4666 -- Corresponding_Runtime_Package --
4667 -----------------------------------
4669 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4670 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4671 -- Return True if protected type T has one entry and the maximum queue
4674 --------------------------------
4675 -- Has_One_Entry_And_No_Queue --
4676 --------------------------------
4678 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4680 Is_First : Boolean := True;
4683 Item := First_Entity (T);
4684 while Present (Item) loop
4685 if Is_Entry (Item) then
4687 -- The protected type has more than one entry
4689 if not Is_First then
4693 -- The queue length is not one
4695 if not Restriction_Active (No_Entry_Queue)
4696 and then Get_Max_Queue_Length (Item) /= Uint_1
4708 end Has_One_Entry_And_No_Queue;
4712 Pkg_Id : RTU_Id := RTU_Null;
4714 -- Start of processing for Corresponding_Runtime_Package
4717 pragma Assert (Is_Concurrent_Type (Typ));
4719 if Is_Protected_Type (Typ) then
4720 if Has_Entries (Typ)
4722 -- A protected type without entries that covers an interface and
4723 -- overrides the abstract routines with protected procedures is
4724 -- considered equivalent to a protected type with entries in the
4725 -- context of dispatching select statements. It is sufficient to
4726 -- check for the presence of an interface list in the declaration
4727 -- node to recognize this case.
4729 or else Present (Interface_List (Parent (Typ)))
4731 -- Protected types with interrupt handlers (when not using a
4732 -- restricted profile) are also considered equivalent to
4733 -- protected types with entries. The types which are used
4734 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
4735 -- are derived from Protection_Entries.
4737 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
4738 or else Has_Interrupt_Handler (Typ)
4741 or else Restriction_Active (No_Select_Statements) = False
4742 or else not Has_One_Entry_And_No_Queue (Typ)
4743 or else (Has_Attach_Handler (Typ)
4744 and then not Restricted_Profile)
4746 Pkg_Id := System_Tasking_Protected_Objects_Entries;
4748 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
4752 Pkg_Id := System_Tasking_Protected_Objects;
4757 end Corresponding_Runtime_Package;
4759 -----------------------------------
4760 -- Current_Sem_Unit_Declarations --
4761 -----------------------------------
4763 function Current_Sem_Unit_Declarations return List_Id is
4764 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
4768 -- If the current unit is a package body, locate the visible
4769 -- declarations of the package spec.
4771 if Nkind (U) = N_Package_Body then
4772 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
4775 if Nkind (U) = N_Package_Declaration then
4776 U := Specification (U);
4777 Decls := Visible_Declarations (U);
4781 Set_Visible_Declarations (U, Decls);
4785 Decls := Declarations (U);
4789 Set_Declarations (U, Decls);
4794 end Current_Sem_Unit_Declarations;
4796 -----------------------
4797 -- Duplicate_Subexpr --
4798 -----------------------
4800 function Duplicate_Subexpr
4802 Name_Req : Boolean := False;
4803 Renaming_Req : Boolean := False) return Node_Id
4806 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4807 return New_Copy_Tree (Exp);
4808 end Duplicate_Subexpr;
4810 ---------------------------------
4811 -- Duplicate_Subexpr_No_Checks --
4812 ---------------------------------
4814 function Duplicate_Subexpr_No_Checks
4816 Name_Req : Boolean := False;
4817 Renaming_Req : Boolean := False;
4818 Related_Id : Entity_Id := Empty;
4819 Is_Low_Bound : Boolean := False;
4820 Is_High_Bound : Boolean := False) return Node_Id
4827 Name_Req => Name_Req,
4828 Renaming_Req => Renaming_Req,
4829 Related_Id => Related_Id,
4830 Is_Low_Bound => Is_Low_Bound,
4831 Is_High_Bound => Is_High_Bound);
4833 New_Exp := New_Copy_Tree (Exp);
4834 Remove_Checks (New_Exp);
4836 end Duplicate_Subexpr_No_Checks;
4838 -----------------------------------
4839 -- Duplicate_Subexpr_Move_Checks --
4840 -----------------------------------
4842 function Duplicate_Subexpr_Move_Checks
4844 Name_Req : Boolean := False;
4845 Renaming_Req : Boolean := False) return Node_Id
4850 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4851 New_Exp := New_Copy_Tree (Exp);
4852 Remove_Checks (Exp);
4854 end Duplicate_Subexpr_Move_Checks;
4856 -------------------------
4857 -- Enclosing_Init_Proc --
4858 -------------------------
4860 function Enclosing_Init_Proc return Entity_Id is
4865 while Present (S) and then S /= Standard_Standard loop
4866 if Is_Init_Proc (S) then
4874 end Enclosing_Init_Proc;
4876 --------------------
4877 -- Ensure_Defined --
4878 --------------------
4880 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
4884 -- An itype reference must only be created if this is a local itype, so
4885 -- that gigi can elaborate it on the proper objstack.
4887 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
4888 IR := Make_Itype_Reference (Sloc (N));
4889 Set_Itype (IR, Typ);
4890 Insert_Action (N, IR);
4894 --------------------
4895 -- Entry_Names_OK --
4896 --------------------
4898 function Entry_Names_OK return Boolean is
4901 not Restricted_Profile
4902 and then not Global_Discard_Names
4903 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4904 and then not Restriction_Active (No_Local_Allocators);
4911 procedure Evaluate_Name (Nam : Node_Id) is
4913 -- For an attribute reference or an indexed component, evaluate the
4914 -- prefix, which is itself a name, recursively, and then force the
4915 -- evaluation of all the subscripts (or attribute expressions).
4918 when N_Attribute_Reference
4919 | N_Indexed_Component
4921 Evaluate_Name (Prefix (Nam));
4927 E := First (Expressions (Nam));
4928 while Present (E) loop
4929 Force_Evaluation (E);
4931 if Is_Rewrite_Substitution (E) then
4933 (E, Do_Range_Check (Original_Node (E)));
4940 -- For an explicit dereference, we simply force the evaluation of
4941 -- the name expression. The dereference provides a value that is the
4942 -- address for the renamed object, and it is precisely this value
4943 -- that we want to preserve.
4945 when N_Explicit_Dereference =>
4946 Force_Evaluation (Prefix (Nam));
4948 -- For a function call, we evaluate the call
4950 when N_Function_Call =>
4951 Force_Evaluation (Nam);
4953 -- For a qualified expression, we evaluate the underlying object
4954 -- name if any, otherwise we force the evaluation of the underlying
4957 when N_Qualified_Expression =>
4958 if Is_Object_Reference (Expression (Nam)) then
4959 Evaluate_Name (Expression (Nam));
4961 Force_Evaluation (Expression (Nam));
4964 -- For a selected component, we simply evaluate the prefix
4966 when N_Selected_Component =>
4967 Evaluate_Name (Prefix (Nam));
4969 -- For a slice, we evaluate the prefix, as for the indexed component
4970 -- case and then, if there is a range present, either directly or as
4971 -- the constraint of a discrete subtype indication, we evaluate the
4972 -- two bounds of this range.
4975 Evaluate_Name (Prefix (Nam));
4976 Evaluate_Slice_Bounds (Nam);
4978 -- For a type conversion, the expression of the conversion must be
4979 -- the name of an object, and we simply need to evaluate this name.
4981 when N_Type_Conversion =>
4982 Evaluate_Name (Expression (Nam));
4984 -- The remaining cases are direct name, operator symbol and character
4985 -- literal. In all these cases, we do nothing, since we want to
4986 -- reevaluate each time the renamed object is used.
4993 ---------------------------
4994 -- Evaluate_Slice_Bounds --
4995 ---------------------------
4997 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
4998 DR : constant Node_Id := Discrete_Range (Slice);
5003 if Nkind (DR) = N_Range then
5004 Force_Evaluation (Low_Bound (DR));
5005 Force_Evaluation (High_Bound (DR));
5007 elsif Nkind (DR) = N_Subtype_Indication then
5008 Constr := Constraint (DR);
5010 if Nkind (Constr) = N_Range_Constraint then
5011 Rexpr := Range_Expression (Constr);
5013 Force_Evaluation (Low_Bound (Rexpr));
5014 Force_Evaluation (High_Bound (Rexpr));
5017 end Evaluate_Slice_Bounds;
5019 ---------------------
5020 -- Evolve_And_Then --
5021 ---------------------
5023 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
5029 Make_And_Then (Sloc (Cond1),
5031 Right_Opnd => Cond1);
5033 end Evolve_And_Then;
5035 --------------------
5036 -- Evolve_Or_Else --
5037 --------------------
5039 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
5045 Make_Or_Else (Sloc (Cond1),
5047 Right_Opnd => Cond1);
5051 -----------------------------------------
5052 -- Expand_Static_Predicates_In_Choices --
5053 -----------------------------------------
5055 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
5056 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
5058 Choices : constant List_Id := Discrete_Choices (N);
5066 Choice := First (Choices);
5067 while Present (Choice) loop
5068 Next_C := Next (Choice);
5070 -- Check for name of subtype with static predicate
5072 if Is_Entity_Name (Choice)
5073 and then Is_Type (Entity (Choice))
5074 and then Has_Predicates (Entity (Choice))
5076 -- Loop through entries in predicate list, converting to choices
5077 -- and inserting in the list before the current choice. Note that
5078 -- if the list is empty, corresponding to a False predicate, then
5079 -- no choices are inserted.
5081 P := First (Static_Discrete_Predicate (Entity (Choice)));
5082 while Present (P) loop
5084 -- If low bound and high bounds are equal, copy simple choice
5086 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
5087 C := New_Copy (Low_Bound (P));
5089 -- Otherwise copy a range
5095 -- Change Sloc to referencing choice (rather than the Sloc of
5096 -- the predicate declaration element itself).
5098 Set_Sloc (C, Sloc (Choice));
5099 Insert_Before (Choice, C);
5103 -- Delete the predicated entry
5108 -- Move to next choice to check
5113 Set_Has_SP_Choice (N, False);
5114 end Expand_Static_Predicates_In_Choices;
5116 ------------------------------
5117 -- Expand_Subtype_From_Expr --
5118 ------------------------------
5120 -- This function is applicable for both static and dynamic allocation of
5121 -- objects which are constrained by an initial expression. Basically it
5122 -- transforms an unconstrained subtype indication into a constrained one.
5124 -- The expression may also be transformed in certain cases in order to
5125 -- avoid multiple evaluation. In the static allocation case, the general
5130 -- is transformed into
5132 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
5134 -- Here are the main cases :
5136 -- <if Expr is a Slice>
5137 -- Val : T ([Index_Subtype (Expr)]) := Expr;
5139 -- <elsif Expr is a String Literal>
5140 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
5142 -- <elsif Expr is Constrained>
5143 -- subtype T is Type_Of_Expr
5146 -- <elsif Expr is an entity_name>
5147 -- Val : T (constraints taken from Expr) := Expr;
5150 -- type Axxx is access all T;
5151 -- Rval : Axxx := Expr'ref;
5152 -- Val : T (constraints taken from Rval) := Rval.all;
5154 -- ??? note: when the Expression is allocated in the secondary stack
5155 -- we could use it directly instead of copying it by declaring
5156 -- Val : T (...) renames Rval.all
5158 procedure Expand_Subtype_From_Expr
5160 Unc_Type : Entity_Id;
5161 Subtype_Indic : Node_Id;
5163 Related_Id : Entity_Id := Empty)
5165 Loc : constant Source_Ptr := Sloc (N);
5166 Exp_Typ : constant Entity_Id := Etype (Exp);
5170 -- In general we cannot build the subtype if expansion is disabled,
5171 -- because internal entities may not have been defined. However, to
5172 -- avoid some cascaded errors, we try to continue when the expression is
5173 -- an array (or string), because it is safe to compute the bounds. It is
5174 -- in fact required to do so even in a generic context, because there
5175 -- may be constants that depend on the bounds of a string literal, both
5176 -- standard string types and more generally arrays of characters.
5178 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is
5179 -- a static expression. In that case, the subtype will be constrained
5180 -- while the original type might be unconstrained, so expanding the type
5181 -- is necessary both for passing legality checks in GNAT and for precise
5182 -- analysis in GNATprove.
5184 if GNATprove_Mode and then not Is_Static_Expression (Exp) then
5188 if not Expander_Active
5189 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5194 if Nkind (Exp) = N_Slice then
5196 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5199 Rewrite (Subtype_Indic,
5200 Make_Subtype_Indication (Loc,
5201 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5203 Make_Index_Or_Discriminant_Constraint (Loc,
5204 Constraints => New_List
5205 (New_Occurrence_Of (Slice_Type, Loc)))));
5207 -- This subtype indication may be used later for constraint checks
5208 -- we better make sure that if a variable was used as a bound of
5209 -- the original slice, its value is frozen.
5211 Evaluate_Slice_Bounds (Exp);
5214 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5215 Rewrite (Subtype_Indic,
5216 Make_Subtype_Indication (Loc,
5217 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5219 Make_Index_Or_Discriminant_Constraint (Loc,
5220 Constraints => New_List (
5221 Make_Literal_Range (Loc,
5222 Literal_Typ => Exp_Typ)))));
5224 -- If the type of the expression is an internally generated type it
5225 -- may not be necessary to create a new subtype. However there are two
5226 -- exceptions: references to the current instances, and aliased array
5227 -- object declarations for which the back end has to create a template.
5229 elsif Is_Constrained (Exp_Typ)
5230 and then not Is_Class_Wide_Type (Unc_Type)
5232 (Nkind (N) /= N_Object_Declaration
5233 or else not Is_Entity_Name (Expression (N))
5234 or else not Comes_From_Source (Entity (Expression (N)))
5235 or else not Is_Array_Type (Exp_Typ)
5236 or else not Aliased_Present (N))
5238 if Is_Itype (Exp_Typ) then
5240 -- Within an initialization procedure, a selected component
5241 -- denotes a component of the enclosing record, and it appears as
5242 -- an actual in a call to its own initialization procedure. If
5243 -- this component depends on the outer discriminant, we must
5244 -- generate the proper actual subtype for it.
5246 if Nkind (Exp) = N_Selected_Component
5247 and then Within_Init_Proc
5250 Decl : constant Node_Id :=
5251 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5253 if Present (Decl) then
5254 Insert_Action (N, Decl);
5255 T := Defining_Identifier (Decl);
5261 -- No need to generate a new subtype
5268 T := Make_Temporary (Loc, 'T');
5271 Make_Subtype_Declaration (Loc,
5272 Defining_Identifier => T,
5273 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5275 -- This type is marked as an itype even though it has an explicit
5276 -- declaration since otherwise Is_Generic_Actual_Type can get
5277 -- set, resulting in the generation of spurious errors. (See
5278 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5281 Set_Associated_Node_For_Itype (T, Exp);
5284 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5286 -- Nothing needs to be done for private types with unknown discriminants
5287 -- if the underlying type is not an unconstrained composite type or it
5288 -- is an unchecked union.
5290 elsif Is_Private_Type (Unc_Type)
5291 and then Has_Unknown_Discriminants (Unc_Type)
5292 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5293 or else Is_Constrained (Underlying_Type (Unc_Type))
5294 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5298 -- Case of derived type with unknown discriminants where the parent type
5299 -- also has unknown discriminants.
5301 elsif Is_Record_Type (Unc_Type)
5302 and then not Is_Class_Wide_Type (Unc_Type)
5303 and then Has_Unknown_Discriminants (Unc_Type)
5304 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5306 -- Nothing to be done if no underlying record view available
5308 -- If this is a limited type derived from a type with unknown
5309 -- discriminants, do not expand either, so that subsequent expansion
5310 -- of the call can add build-in-place parameters to call.
5312 if No (Underlying_Record_View (Unc_Type))
5313 or else Is_Limited_Type (Unc_Type)
5317 -- Otherwise use the Underlying_Record_View to create the proper
5318 -- constrained subtype for an object of a derived type with unknown
5322 Remove_Side_Effects (Exp);
5323 Rewrite (Subtype_Indic,
5324 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5327 -- Renamings of class-wide interface types require no equivalent
5328 -- constrained type declarations because we only need to reference
5329 -- the tag component associated with the interface. The same is
5330 -- presumably true for class-wide types in general, so this test
5331 -- is broadened to include all class-wide renamings, which also
5332 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5333 -- (Is this really correct, or are there some cases of class-wide
5334 -- renamings that require action in this procedure???)
5337 and then Nkind (N) = N_Object_Renaming_Declaration
5338 and then Is_Class_Wide_Type (Unc_Type)
5342 -- In Ada 95 nothing to be done if the type of the expression is limited
5343 -- because in this case the expression cannot be copied, and its use can
5344 -- only be by reference.
5346 -- In Ada 2005 the context can be an object declaration whose expression
5347 -- is a function that returns in place. If the nominal subtype has
5348 -- unknown discriminants, the call still provides constraints on the
5349 -- object, and we have to create an actual subtype from it.
5351 -- If the type is class-wide, the expression is dynamically tagged and
5352 -- we do not create an actual subtype either. Ditto for an interface.
5353 -- For now this applies only if the type is immutably limited, and the
5354 -- function being called is build-in-place. This will have to be revised
5355 -- when build-in-place functions are generalized to other types.
5357 elsif Is_Limited_View (Exp_Typ)
5359 (Is_Class_Wide_Type (Exp_Typ)
5360 or else Is_Interface (Exp_Typ)
5361 or else not Has_Unknown_Discriminants (Exp_Typ)
5362 or else not Is_Composite_Type (Unc_Type))
5366 -- For limited objects initialized with build in place function calls,
5367 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5368 -- node in the expression initializing the object, which breaks the
5369 -- circuitry that detects and adds the additional arguments to the
5372 elsif Is_Build_In_Place_Function_Call (Exp) then
5376 Remove_Side_Effects (Exp);
5377 Rewrite (Subtype_Indic,
5378 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5380 end Expand_Subtype_From_Expr;
5382 ---------------------------------------------
5383 -- Expression_Contains_Primitives_Calls_Of --
5384 ---------------------------------------------
5386 function Expression_Contains_Primitives_Calls_Of
5388 Typ : Entity_Id) return Boolean
5390 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5392 Calls_OK : Boolean := False;
5393 -- This flag is set to True when expression Expr contains at least one
5394 -- call to a nondispatching primitive function of Typ.
5396 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5397 -- Search for nondispatching calls to primitive functions of type Typ
5399 ----------------------------
5400 -- Search_Primitive_Calls --
5401 ----------------------------
5403 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5404 Disp_Typ : Entity_Id;
5408 -- Detect a function call that could denote a nondispatching
5409 -- primitive of the input type.
5411 if Nkind (N) = N_Function_Call
5412 and then Is_Entity_Name (Name (N))
5414 Subp := Entity (Name (N));
5416 -- Do not consider function calls with a controlling argument, as
5417 -- those are always dispatching calls.
5419 if Is_Dispatching_Operation (Subp)
5420 and then No (Controlling_Argument (N))
5422 Disp_Typ := Find_Dispatching_Type (Subp);
5424 -- To qualify as a suitable primitive, the dispatching type of
5425 -- the function must be the input type.
5427 if Present (Disp_Typ)
5428 and then Unique_Entity (Disp_Typ) = U_Typ
5432 -- There is no need to continue the traversal, as one such
5441 end Search_Primitive_Calls;
5443 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5445 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5448 Search_Calls (Expr);
5450 end Expression_Contains_Primitives_Calls_Of;
5452 ----------------------
5453 -- Finalize_Address --
5454 ----------------------
5456 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5457 Btyp : constant Entity_Id := Base_Type (Typ);
5458 Utyp : Entity_Id := Typ;
5461 -- Handle protected class-wide or task class-wide types
5463 if Is_Class_Wide_Type (Utyp) then
5464 if Is_Concurrent_Type (Root_Type (Utyp)) then
5465 Utyp := Root_Type (Utyp);
5467 elsif Is_Private_Type (Root_Type (Utyp))
5468 and then Present (Full_View (Root_Type (Utyp)))
5469 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5471 Utyp := Full_View (Root_Type (Utyp));
5475 -- Handle private types
5477 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5478 Utyp := Full_View (Utyp);
5481 -- Handle protected and task types
5483 if Is_Concurrent_Type (Utyp)
5484 and then Present (Corresponding_Record_Type (Utyp))
5486 Utyp := Corresponding_Record_Type (Utyp);
5489 Utyp := Underlying_Type (Base_Type (Utyp));
5491 -- Deal with untagged derivation of private views. If the parent is
5492 -- now known to be protected, the finalization routine is the one
5493 -- defined on the corresponding record of the ancestor (corresponding
5494 -- records do not automatically inherit operations, but maybe they
5497 if Is_Untagged_Derivation (Btyp) then
5498 if Is_Protected_Type (Btyp) then
5499 Utyp := Corresponding_Record_Type (Root_Type (Btyp));
5502 Utyp := Underlying_Type (Root_Type (Btyp));
5504 if Is_Protected_Type (Utyp) then
5505 Utyp := Corresponding_Record_Type (Utyp);
5510 -- If the underlying_type is a subtype, we are dealing with the
5511 -- completion of a private type. We need to access the base type and
5512 -- generate a conversion to it.
5514 if Utyp /= Base_Type (Utyp) then
5515 pragma Assert (Is_Private_Type (Typ));
5517 Utyp := Base_Type (Utyp);
5520 -- When dealing with an internally built full view for a type with
5521 -- unknown discriminants, use the original record type.
5523 if Is_Underlying_Record_View (Utyp) then
5524 Utyp := Etype (Utyp);
5527 return TSS (Utyp, TSS_Finalize_Address);
5528 end Finalize_Address;
5530 ------------------------
5531 -- Find_Interface_ADT --
5532 ------------------------
5534 function Find_Interface_ADT
5536 Iface : Entity_Id) return Elmt_Id
5539 Typ : Entity_Id := T;
5542 pragma Assert (Is_Interface (Iface));
5544 -- Handle private types
5546 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5547 Typ := Full_View (Typ);
5550 -- Handle access types
5552 if Is_Access_Type (Typ) then
5553 Typ := Designated_Type (Typ);
5556 -- Handle task and protected types implementing interfaces
5558 if Is_Concurrent_Type (Typ) then
5559 Typ := Corresponding_Record_Type (Typ);
5563 (not Is_Class_Wide_Type (Typ)
5564 and then Ekind (Typ) /= E_Incomplete_Type);
5566 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5567 return First_Elmt (Access_Disp_Table (Typ));
5570 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5572 and then Present (Related_Type (Node (ADT)))
5573 and then Related_Type (Node (ADT)) /= Iface
5574 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
5575 Use_Full_View => True)
5580 pragma Assert (Present (Related_Type (Node (ADT))));
5583 end Find_Interface_ADT;
5585 ------------------------
5586 -- Find_Interface_Tag --
5587 ------------------------
5589 function Find_Interface_Tag
5591 Iface : Entity_Id) return Entity_Id
5593 AI_Tag : Entity_Id := Empty;
5594 Found : Boolean := False;
5595 Typ : Entity_Id := T;
5597 procedure Find_Tag (Typ : Entity_Id);
5598 -- Internal subprogram used to recursively climb to the ancestors
5604 procedure Find_Tag (Typ : Entity_Id) is
5609 -- This routine does not handle the case in which the interface is an
5610 -- ancestor of Typ. That case is handled by the enclosing subprogram.
5612 pragma Assert (Typ /= Iface);
5614 -- Climb to the root type handling private types
5616 if Present (Full_View (Etype (Typ))) then
5617 if Full_View (Etype (Typ)) /= Typ then
5618 Find_Tag (Full_View (Etype (Typ)));
5621 elsif Etype (Typ) /= Typ then
5622 Find_Tag (Etype (Typ));
5625 -- Traverse the list of interfaces implemented by the type
5628 and then Present (Interfaces (Typ))
5629 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
5631 -- Skip the tag associated with the primary table
5633 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
5634 pragma Assert (Present (AI_Tag));
5636 AI_Elmt := First_Elmt (Interfaces (Typ));
5637 while Present (AI_Elmt) loop
5638 AI := Node (AI_Elmt);
5641 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
5647 AI_Tag := Next_Tag_Component (AI_Tag);
5648 Next_Elmt (AI_Elmt);
5653 -- Start of processing for Find_Interface_Tag
5656 pragma Assert (Is_Interface (Iface));
5658 -- Handle access types
5660 if Is_Access_Type (Typ) then
5661 Typ := Designated_Type (Typ);
5664 -- Handle class-wide types
5666 if Is_Class_Wide_Type (Typ) then
5667 Typ := Root_Type (Typ);
5670 -- Handle private types
5672 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5673 Typ := Full_View (Typ);
5676 -- Handle entities from the limited view
5678 if Ekind (Typ) = E_Incomplete_Type then
5679 pragma Assert (Present (Non_Limited_View (Typ)));
5680 Typ := Non_Limited_View (Typ);
5683 -- Handle task and protected types implementing interfaces
5685 if Is_Concurrent_Type (Typ) then
5686 Typ := Corresponding_Record_Type (Typ);
5689 -- If the interface is an ancestor of the type, then it shared the
5690 -- primary dispatch table.
5692 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5693 return First_Tag_Component (Typ);
5695 -- Otherwise we need to search for its associated tag component
5701 end Find_Interface_Tag;
5703 ---------------------------
5704 -- Find_Optional_Prim_Op --
5705 ---------------------------
5707 function Find_Optional_Prim_Op
5708 (T : Entity_Id; Name : Name_Id) return Entity_Id
5711 Typ : Entity_Id := T;
5715 if Is_Class_Wide_Type (Typ) then
5716 Typ := Root_Type (Typ);
5719 Typ := Underlying_Type (Typ);
5721 -- Loop through primitive operations
5723 Prim := First_Elmt (Primitive_Operations (Typ));
5724 while Present (Prim) loop
5727 -- We can retrieve primitive operations by name if it is an internal
5728 -- name. For equality we must check that both of its operands have
5729 -- the same type, to avoid confusion with user-defined equalities
5730 -- than may have a asymmetric signature.
5732 exit when Chars (Op) = Name
5735 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
5740 return Node (Prim); -- Empty if not found
5741 end Find_Optional_Prim_Op;
5743 ---------------------------
5744 -- Find_Optional_Prim_Op --
5745 ---------------------------
5747 function Find_Optional_Prim_Op
5749 Name : TSS_Name_Type) return Entity_Id
5751 Inher_Op : Entity_Id := Empty;
5752 Own_Op : Entity_Id := Empty;
5753 Prim_Elmt : Elmt_Id;
5754 Prim_Id : Entity_Id;
5755 Typ : Entity_Id := T;
5758 if Is_Class_Wide_Type (Typ) then
5759 Typ := Root_Type (Typ);
5762 Typ := Underlying_Type (Typ);
5764 -- This search is based on the assertion that the dispatching version
5765 -- of the TSS routine always precedes the real primitive.
5767 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5768 while Present (Prim_Elmt) loop
5769 Prim_Id := Node (Prim_Elmt);
5771 if Is_TSS (Prim_Id, Name) then
5772 if Present (Alias (Prim_Id)) then
5773 Inher_Op := Prim_Id;
5779 Next_Elmt (Prim_Elmt);
5782 if Present (Own_Op) then
5784 elsif Present (Inher_Op) then
5789 end Find_Optional_Prim_Op;
5795 function Find_Prim_Op
5796 (T : Entity_Id; Name : Name_Id) return Entity_Id
5798 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5801 raise Program_Error;
5811 function Find_Prim_Op
5813 Name : TSS_Name_Type) return Entity_Id
5815 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5818 raise Program_Error;
5824 ----------------------------
5825 -- Find_Protection_Object --
5826 ----------------------------
5828 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
5833 while Present (S) loop
5834 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
5835 and then Present (Protection_Object (S))
5837 return Protection_Object (S);
5843 -- If we do not find a Protection object in the scope chain, then
5844 -- something has gone wrong, most likely the object was never created.
5846 raise Program_Error;
5847 end Find_Protection_Object;
5849 --------------------------
5850 -- Find_Protection_Type --
5851 --------------------------
5853 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
5855 Typ : Entity_Id := Conc_Typ;
5858 if Is_Concurrent_Type (Typ) then
5859 Typ := Corresponding_Record_Type (Typ);
5862 -- Since restriction violations are not considered serious errors, the
5863 -- expander remains active, but may leave the corresponding record type
5864 -- malformed. In such cases, component _object is not available so do
5867 if not Analyzed (Typ) then
5871 Comp := First_Component (Typ);
5872 while Present (Comp) loop
5873 if Chars (Comp) = Name_uObject then
5874 return Base_Type (Etype (Comp));
5877 Next_Component (Comp);
5880 -- The corresponding record of a protected type should always have an
5883 raise Program_Error;
5884 end Find_Protection_Type;
5886 -----------------------
5887 -- Find_Hook_Context --
5888 -----------------------
5890 function Find_Hook_Context (N : Node_Id) return Node_Id is
5894 Wrapped_Node : Node_Id;
5895 -- Note: if we are in a transient scope, we want to reuse it as
5896 -- the context for actions insertion, if possible. But if N is itself
5897 -- part of the stored actions for the current transient scope,
5898 -- then we need to insert at the appropriate (inner) location in
5899 -- the not as an action on Node_To_Be_Wrapped.
5901 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
5904 -- When the node is inside a case/if expression, the lifetime of any
5905 -- temporary controlled object is extended. Find a suitable insertion
5906 -- node by locating the topmost case or if expressions.
5908 if In_Cond_Expr then
5911 while Present (Par) loop
5912 if Nkind_In (Original_Node (Par), N_Case_Expression,
5917 -- Prevent the search from going too far
5919 elsif Is_Body_Or_Package_Declaration (Par) then
5923 Par := Parent (Par);
5926 -- The topmost case or if expression is now recovered, but it may
5927 -- still not be the correct place to add generated code. Climb to
5928 -- find a parent that is part of a declarative or statement list,
5929 -- and is not a list of actuals in a call.
5932 while Present (Par) loop
5933 if Is_List_Member (Par)
5934 and then not Nkind_In (Par, N_Component_Association,
5935 N_Discriminant_Association,
5936 N_Parameter_Association,
5937 N_Pragma_Argument_Association)
5938 and then not Nkind_In (Parent (Par), N_Function_Call,
5939 N_Procedure_Call_Statement,
5940 N_Entry_Call_Statement)
5945 -- Prevent the search from going too far
5947 elsif Is_Body_Or_Package_Declaration (Par) then
5951 Par := Parent (Par);
5958 while Present (Par) loop
5960 -- Keep climbing past various operators
5962 if Nkind (Parent (Par)) in N_Op
5963 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
5965 Par := Parent (Par);
5973 -- The node may be located in a pragma in which case return the
5976 -- pragma Precondition (... and then Ctrl_Func_Call ...);
5978 -- Similar case occurs when the node is related to an object
5979 -- declaration or assignment:
5981 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
5983 -- Another case to consider is when the node is part of a return
5986 -- return ... and then Ctrl_Func_Call ...;
5988 -- Another case is when the node acts as a formal in a procedure
5991 -- Proc (... and then Ctrl_Func_Call ...);
5993 if Scope_Is_Transient then
5994 Wrapped_Node := Node_To_Be_Wrapped;
5996 Wrapped_Node := Empty;
5999 while Present (Par) loop
6000 if Par = Wrapped_Node
6001 or else Nkind_In (Par, N_Assignment_Statement,
6002 N_Object_Declaration,
6004 N_Procedure_Call_Statement,
6005 N_Simple_Return_Statement)
6009 -- Prevent the search from going too far
6011 elsif Is_Body_Or_Package_Declaration (Par) then
6015 Par := Parent (Par);
6018 -- Return the topmost short circuit operator
6022 end Find_Hook_Context;
6024 ------------------------------
6025 -- Following_Address_Clause --
6026 ------------------------------
6028 function Following_Address_Clause (D : Node_Id) return Node_Id is
6029 Id : constant Entity_Id := Defining_Identifier (D);
6033 function Check_Decls (D : Node_Id) return Node_Id;
6034 -- This internal function differs from the main function in that it
6035 -- gets called to deal with a following package private part, and
6036 -- it checks declarations starting with D (the main function checks
6037 -- declarations following D). If D is Empty, then Empty is returned.
6043 function Check_Decls (D : Node_Id) return Node_Id is
6048 while Present (Decl) loop
6049 if Nkind (Decl) = N_At_Clause
6050 and then Chars (Identifier (Decl)) = Chars (Id)
6054 elsif Nkind (Decl) = N_Attribute_Definition_Clause
6055 and then Chars (Decl) = Name_Address
6056 and then Chars (Name (Decl)) = Chars (Id)
6064 -- Otherwise not found, return Empty
6069 -- Start of processing for Following_Address_Clause
6072 -- If parser detected no address clause for the identifier in question,
6073 -- then the answer is a quick NO, without the need for a search.
6075 if not Get_Name_Table_Boolean1 (Chars (Id)) then
6079 -- Otherwise search current declarative unit
6081 Result := Check_Decls (Next (D));
6083 if Present (Result) then
6087 -- Check for possible package private part following
6091 if Nkind (Par) = N_Package_Specification
6092 and then Visible_Declarations (Par) = List_Containing (D)
6093 and then Present (Private_Declarations (Par))
6095 -- Private part present, check declarations there
6097 return Check_Decls (First (Private_Declarations (Par)));
6100 -- No private part, clause not found, return Empty
6104 end Following_Address_Clause;
6106 ----------------------
6107 -- Force_Evaluation --
6108 ----------------------
6110 procedure Force_Evaluation
6112 Name_Req : Boolean := False;
6113 Related_Id : Entity_Id := Empty;
6114 Is_Low_Bound : Boolean := False;
6115 Is_High_Bound : Boolean := False;
6116 Mode : Force_Evaluation_Mode := Relaxed)
6121 Name_Req => Name_Req,
6122 Variable_Ref => True,
6123 Renaming_Req => False,
6124 Related_Id => Related_Id,
6125 Is_Low_Bound => Is_Low_Bound,
6126 Is_High_Bound => Is_High_Bound,
6127 Check_Side_Effects =>
6128 Is_Static_Expression (Exp)
6129 or else Mode = Relaxed);
6130 end Force_Evaluation;
6132 ---------------------------------
6133 -- Fully_Qualified_Name_String --
6134 ---------------------------------
6136 function Fully_Qualified_Name_String
6138 Append_NUL : Boolean := True) return String_Id
6140 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6141 -- Compute recursively the qualified name without NUL at the end, adding
6142 -- it to the currently started string being generated
6144 ----------------------------------
6145 -- Internal_Full_Qualified_Name --
6146 ----------------------------------
6148 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6152 -- Deal properly with child units
6154 if Nkind (E) = N_Defining_Program_Unit_Name then
6155 Ent := Defining_Identifier (E);
6160 -- Compute qualification recursively (only "Standard" has no scope)
6162 if Present (Scope (Scope (Ent))) then
6163 Internal_Full_Qualified_Name (Scope (Ent));
6164 Store_String_Char (Get_Char_Code ('.'));
6167 -- Every entity should have a name except some expanded blocks
6168 -- don't bother about those.
6170 if Chars (Ent) = No_Name then
6174 -- Generates the entity name in upper case
6176 Get_Decoded_Name_String (Chars (Ent));
6178 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6180 end Internal_Full_Qualified_Name;
6182 -- Start of processing for Full_Qualified_Name
6186 Internal_Full_Qualified_Name (E);
6189 Store_String_Char (Get_Char_Code (ASCII.NUL));
6193 end Fully_Qualified_Name_String;
6195 ------------------------
6196 -- Generate_Poll_Call --
6197 ------------------------
6199 procedure Generate_Poll_Call (N : Node_Id) is
6201 -- No poll call if polling not active
6203 if not Polling_Required then
6206 -- Otherwise generate require poll call
6209 Insert_Before_And_Analyze (N,
6210 Make_Procedure_Call_Statement (Sloc (N),
6211 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
6213 end Generate_Poll_Call;
6215 ---------------------------------
6216 -- Get_Current_Value_Condition --
6217 ---------------------------------
6219 -- Note: the implementation of this procedure is very closely tied to the
6220 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6221 -- interpret Current_Value fields set by the Set procedure, so the two
6222 -- procedures need to be closely coordinated.
6224 procedure Get_Current_Value_Condition
6229 Loc : constant Source_Ptr := Sloc (Var);
6230 Ent : constant Entity_Id := Entity (Var);
6232 procedure Process_Current_Value_Condition
6235 -- N is an expression which holds either True (S = True) or False (S =
6236 -- False) in the condition. This procedure digs out the expression and
6237 -- if it refers to Ent, sets Op and Val appropriately.
6239 -------------------------------------
6240 -- Process_Current_Value_Condition --
6241 -------------------------------------
6243 procedure Process_Current_Value_Condition
6248 Prev_Cond : Node_Id;
6258 -- Deal with NOT operators, inverting sense
6260 while Nkind (Cond) = N_Op_Not loop
6261 Cond := Right_Opnd (Cond);
6265 -- Deal with conversions, qualifications, and expressions with
6268 while Nkind_In (Cond,
6270 N_Qualified_Expression,
6271 N_Expression_With_Actions)
6273 Cond := Expression (Cond);
6276 exit when Cond = Prev_Cond;
6279 -- Deal with AND THEN and AND cases
6281 if Nkind_In (Cond, N_And_Then, N_Op_And) then
6283 -- Don't ever try to invert a condition that is of the form of an
6284 -- AND or AND THEN (since we are not doing sufficiently general
6285 -- processing to allow this).
6287 if Sens = False then
6293 -- Recursively process AND and AND THEN branches
6295 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6297 if Op /= N_Empty then
6301 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6304 -- Case of relational operator
6306 elsif Nkind (Cond) in N_Op_Compare then
6309 -- Invert sense of test if inverted test
6311 if Sens = False then
6313 when N_Op_Eq => Op := N_Op_Ne;
6314 when N_Op_Ne => Op := N_Op_Eq;
6315 when N_Op_Lt => Op := N_Op_Ge;
6316 when N_Op_Gt => Op := N_Op_Le;
6317 when N_Op_Le => Op := N_Op_Gt;
6318 when N_Op_Ge => Op := N_Op_Lt;
6319 when others => raise Program_Error;
6323 -- Case of entity op value
6325 if Is_Entity_Name (Left_Opnd (Cond))
6326 and then Ent = Entity (Left_Opnd (Cond))
6327 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6329 Val := Right_Opnd (Cond);
6331 -- Case of value op entity
6333 elsif Is_Entity_Name (Right_Opnd (Cond))
6334 and then Ent = Entity (Right_Opnd (Cond))
6335 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6337 Val := Left_Opnd (Cond);
6339 -- We are effectively swapping operands
6342 when N_Op_Eq => null;
6343 when N_Op_Ne => null;
6344 when N_Op_Lt => Op := N_Op_Gt;
6345 when N_Op_Gt => Op := N_Op_Lt;
6346 when N_Op_Le => Op := N_Op_Ge;
6347 when N_Op_Ge => Op := N_Op_Le;
6348 when others => raise Program_Error;
6357 elsif Nkind_In (Cond,
6359 N_Qualified_Expression,
6360 N_Expression_With_Actions)
6362 Cond := Expression (Cond);
6364 -- Case of Boolean variable reference, return as though the
6365 -- reference had said var = True.
6368 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6369 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6371 if Sens = False then
6378 end Process_Current_Value_Condition;
6380 -- Start of processing for Get_Current_Value_Condition
6386 -- Immediate return, nothing doing, if this is not an object
6388 if Ekind (Ent) not in Object_Kind then
6392 -- Otherwise examine current value
6395 CV : constant Node_Id := Current_Value (Ent);
6400 -- If statement. Condition is known true in THEN section, known False
6401 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6403 if Nkind (CV) = N_If_Statement then
6405 -- Before start of IF statement
6407 if Loc < Sloc (CV) then
6410 -- After end of IF statement
6412 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6416 -- At this stage we know that we are within the IF statement, but
6417 -- unfortunately, the tree does not record the SLOC of the ELSE so
6418 -- we cannot use a simple SLOC comparison to distinguish between
6419 -- the then/else statements, so we have to climb the tree.
6426 while Parent (N) /= CV loop
6429 -- If we fall off the top of the tree, then that's odd, but
6430 -- perhaps it could occur in some error situation, and the
6431 -- safest response is simply to assume that the outcome of
6432 -- the condition is unknown. No point in bombing during an
6433 -- attempt to optimize things.
6440 -- Now we have N pointing to a node whose parent is the IF
6441 -- statement in question, so now we can tell if we are within
6442 -- the THEN statements.
6444 if Is_List_Member (N)
6445 and then List_Containing (N) = Then_Statements (CV)
6449 -- If the variable reference does not come from source, we
6450 -- cannot reliably tell whether it appears in the else part.
6451 -- In particular, if it appears in generated code for a node
6452 -- that requires finalization, it may be attached to a list
6453 -- that has not been yet inserted into the code. For now,
6454 -- treat it as unknown.
6456 elsif not Comes_From_Source (N) then
6459 -- Otherwise we must be in ELSIF or ELSE part
6466 -- ELSIF part. Condition is known true within the referenced
6467 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6468 -- and unknown before the ELSE part or after the IF statement.
6470 elsif Nkind (CV) = N_Elsif_Part then
6472 -- if the Elsif_Part had condition_actions, the elsif has been
6473 -- rewritten as a nested if, and the original elsif_part is
6474 -- detached from the tree, so there is no way to obtain useful
6475 -- information on the current value of the variable.
6476 -- Can this be improved ???
6478 if No (Parent (CV)) then
6484 -- If the tree has been otherwise rewritten there is nothing
6485 -- else to be done either.
6487 if Nkind (Stm) /= N_If_Statement then
6491 -- Before start of ELSIF part
6493 if Loc < Sloc (CV) then
6496 -- After end of IF statement
6498 elsif Loc >= Sloc (Stm) +
6499 Text_Ptr (UI_To_Int (End_Span (Stm)))
6504 -- Again we lack the SLOC of the ELSE, so we need to climb the
6505 -- tree to see if we are within the ELSIF part in question.
6512 while Parent (N) /= Stm loop
6515 -- If we fall off the top of the tree, then that's odd, but
6516 -- perhaps it could occur in some error situation, and the
6517 -- safest response is simply to assume that the outcome of
6518 -- the condition is unknown. No point in bombing during an
6519 -- attempt to optimize things.
6526 -- Now we have N pointing to a node whose parent is the IF
6527 -- statement in question, so see if is the ELSIF part we want.
6528 -- the THEN statements.
6533 -- Otherwise we must be in subsequent ELSIF or ELSE part
6540 -- Iteration scheme of while loop. The condition is known to be
6541 -- true within the body of the loop.
6543 elsif Nkind (CV) = N_Iteration_Scheme then
6545 Loop_Stmt : constant Node_Id := Parent (CV);
6548 -- Before start of body of loop
6550 if Loc < Sloc (Loop_Stmt) then
6553 -- After end of LOOP statement
6555 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
6558 -- We are within the body of the loop
6565 -- All other cases of Current_Value settings
6571 -- If we fall through here, then we have a reportable condition, Sens
6572 -- is True if the condition is true and False if it needs inverting.
6574 Process_Current_Value_Condition (Condition (CV), Sens);
6576 end Get_Current_Value_Condition;
6578 ---------------------
6579 -- Get_Stream_Size --
6580 ---------------------
6582 function Get_Stream_Size (E : Entity_Id) return Uint is
6584 -- If we have a Stream_Size clause for this type use it
6586 if Has_Stream_Size_Clause (E) then
6587 return Static_Integer (Expression (Stream_Size_Clause (E)));
6589 -- Otherwise the Stream_Size if the size of the type
6594 end Get_Stream_Size;
6596 ---------------------------
6597 -- Has_Access_Constraint --
6598 ---------------------------
6600 function Has_Access_Constraint (E : Entity_Id) return Boolean is
6602 T : constant Entity_Id := Etype (E);
6605 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
6606 Disc := First_Discriminant (T);
6607 while Present (Disc) loop
6608 if Is_Access_Type (Etype (Disc)) then
6612 Next_Discriminant (Disc);
6619 end Has_Access_Constraint;
6621 -----------------------------------------------------
6622 -- Has_Annotate_Pragma_For_External_Axiomatization --
6623 -----------------------------------------------------
6625 function Has_Annotate_Pragma_For_External_Axiomatization
6626 (E : Entity_Id) return Boolean
6628 function Is_Annotate_Pragma_For_External_Axiomatization
6629 (N : Node_Id) return Boolean;
6630 -- Returns whether N is
6631 -- pragma Annotate (GNATprove, External_Axiomatization);
6633 ----------------------------------------------------
6634 -- Is_Annotate_Pragma_For_External_Axiomatization --
6635 ----------------------------------------------------
6637 -- The general form of pragma Annotate is
6639 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
6640 -- ARG ::= NAME | EXPRESSION
6642 -- The first two arguments are by convention intended to refer to an
6643 -- external tool and a tool-specific function. These arguments are
6646 -- The following is used to annotate a package specification which
6647 -- GNATprove should treat specially, because the axiomatization of
6648 -- this unit is given by the user instead of being automatically
6651 -- pragma Annotate (GNATprove, External_Axiomatization);
6653 function Is_Annotate_Pragma_For_External_Axiomatization
6654 (N : Node_Id) return Boolean
6656 Name_GNATprove : constant String :=
6658 Name_External_Axiomatization : constant String :=
6659 "external_axiomatization";
6663 if Nkind (N) = N_Pragma
6664 and then Get_Pragma_Id (N) = Pragma_Annotate
6665 and then List_Length (Pragma_Argument_Associations (N)) = 2
6668 Arg1 : constant Node_Id :=
6669 First (Pragma_Argument_Associations (N));
6670 Arg2 : constant Node_Id := Next (Arg1);
6675 -- Fill in Name_Buffer with Name_GNATprove first, and then with
6676 -- Name_External_Axiomatization so that Name_Find returns the
6677 -- corresponding name. This takes care of all possible casings.
6680 Add_Str_To_Name_Buffer (Name_GNATprove);
6684 Add_Str_To_Name_Buffer (Name_External_Axiomatization);
6687 return Chars (Get_Pragma_Arg (Arg1)) = Nam1
6689 Chars (Get_Pragma_Arg (Arg2)) = Nam2;
6695 end Is_Annotate_Pragma_For_External_Axiomatization;
6700 Vis_Decls : List_Id;
6703 -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
6706 if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
6707 Decl := Parent (Parent (E));
6712 Vis_Decls := Visible_Declarations (Decl);
6714 N := First (Vis_Decls);
6715 while Present (N) loop
6717 -- Skip declarations generated by the frontend. Skip all pragmas
6718 -- that are not the desired Annotate pragma. Stop the search on
6719 -- the first non-pragma source declaration.
6721 if Comes_From_Source (N) then
6722 if Nkind (N) = N_Pragma then
6723 if Is_Annotate_Pragma_For_External_Axiomatization (N) then
6735 end Has_Annotate_Pragma_For_External_Axiomatization;
6737 --------------------
6738 -- Homonym_Number --
6739 --------------------
6741 function Homonym_Number (Subp : Entity_Id) return Pos is
6742 Hom : Entity_Id := Homonym (Subp);
6746 while Present (Hom) loop
6747 if Scope (Hom) = Scope (Subp) then
6751 Hom := Homonym (Hom);
6757 -----------------------------------
6758 -- In_Library_Level_Package_Body --
6759 -----------------------------------
6761 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
6763 -- First determine whether the entity appears at the library level, then
6764 -- look at the containing unit.
6766 if Is_Library_Level_Entity (Id) then
6768 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
6771 return Nkind (Unit (Container)) = N_Package_Body;
6776 end In_Library_Level_Package_Body;
6778 ------------------------------
6779 -- In_Unconditional_Context --
6780 ------------------------------
6782 function In_Unconditional_Context (Node : Node_Id) return Boolean is
6787 while Present (P) loop
6789 when N_Subprogram_Body => return True;
6790 when N_If_Statement => return False;
6791 when N_Loop_Statement => return False;
6792 when N_Case_Statement => return False;
6793 when others => P := Parent (P);
6798 end In_Unconditional_Context;
6804 procedure Insert_Action
6805 (Assoc_Node : Node_Id;
6806 Ins_Action : Node_Id;
6807 Spec_Expr_OK : Boolean := False)
6810 if Present (Ins_Action) then
6812 (Assoc_Node => Assoc_Node,
6813 Ins_Actions => New_List (Ins_Action),
6814 Spec_Expr_OK => Spec_Expr_OK);
6818 -- Version with check(s) suppressed
6820 procedure Insert_Action
6821 (Assoc_Node : Node_Id;
6822 Ins_Action : Node_Id;
6823 Suppress : Check_Id;
6824 Spec_Expr_OK : Boolean := False)
6828 (Assoc_Node => Assoc_Node,
6829 Ins_Actions => New_List (Ins_Action),
6830 Suppress => Suppress,
6831 Spec_Expr_OK => Spec_Expr_OK);
6834 -------------------------
6835 -- Insert_Action_After --
6836 -------------------------
6838 procedure Insert_Action_After
6839 (Assoc_Node : Node_Id;
6840 Ins_Action : Node_Id)
6843 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
6844 end Insert_Action_After;
6846 --------------------
6847 -- Insert_Actions --
6848 --------------------
6850 procedure Insert_Actions
6851 (Assoc_Node : Node_Id;
6852 Ins_Actions : List_Id;
6853 Spec_Expr_OK : Boolean := False)
6858 Wrapped_Node : Node_Id := Empty;
6861 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
6865 -- Insert the action when the context is "Handling of Default and Per-
6866 -- Object Expressions" only when requested by the caller.
6868 if Spec_Expr_OK then
6871 -- Ignore insert of actions from inside default expression (or other
6872 -- similar "spec expression") in the special spec-expression analyze
6873 -- mode. Any insertions at this point have no relevance, since we are
6874 -- only doing the analyze to freeze the types of any static expressions.
6875 -- See section "Handling of Default and Per-Object Expressions" in the
6876 -- spec of package Sem for further details.
6878 elsif In_Spec_Expression then
6882 -- If the action derives from stuff inside a record, then the actions
6883 -- are attached to the current scope, to be inserted and analyzed on
6884 -- exit from the scope. The reason for this is that we may also be
6885 -- generating freeze actions at the same time, and they must eventually
6886 -- be elaborated in the correct order.
6888 if Is_Record_Type (Current_Scope)
6889 and then not Is_Frozen (Current_Scope)
6891 if No (Scope_Stack.Table
6892 (Scope_Stack.Last).Pending_Freeze_Actions)
6894 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
6899 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
6905 -- We now intend to climb up the tree to find the right point to
6906 -- insert the actions. We start at Assoc_Node, unless this node is a
6907 -- subexpression in which case we start with its parent. We do this for
6908 -- two reasons. First it speeds things up. Second, if Assoc_Node is
6909 -- itself one of the special nodes like N_And_Then, then we assume that
6910 -- an initial request to insert actions for such a node does not expect
6911 -- the actions to get deposited in the node for later handling when the
6912 -- node is expanded, since clearly the node is being dealt with by the
6913 -- caller. Note that in the subexpression case, N is always the child we
6916 -- N_Raise_xxx_Error is an annoying special case, it is a statement
6917 -- if it has type Standard_Void_Type, and a subexpression otherwise.
6918 -- Procedure calls, and similarly procedure attribute references, are
6921 if Nkind (Assoc_Node) in N_Subexpr
6922 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
6923 or else Etype (Assoc_Node) /= Standard_Void_Type)
6924 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
6925 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
6926 or else not Is_Procedure_Attribute_Name
6927 (Attribute_Name (Assoc_Node)))
6930 P := Parent (Assoc_Node);
6932 -- Nonsubexpression case. Note that N is initially Empty in this case
6933 -- (N is only guaranteed non-Empty in the subexpr case).
6940 -- Capture root of the transient scope
6942 if Scope_Is_Transient then
6943 Wrapped_Node := Node_To_Be_Wrapped;
6947 pragma Assert (Present (P));
6949 -- Make sure that inserted actions stay in the transient scope
6951 if Present (Wrapped_Node) and then N = Wrapped_Node then
6952 Store_Before_Actions_In_Scope (Ins_Actions);
6958 -- Case of right operand of AND THEN or OR ELSE. Put the actions
6959 -- in the Actions field of the right operand. They will be moved
6960 -- out further when the AND THEN or OR ELSE operator is expanded.
6961 -- Nothing special needs to be done for the left operand since
6962 -- in that case the actions are executed unconditionally.
6964 when N_Short_Circuit =>
6965 if N = Right_Opnd (P) then
6967 -- We are now going to either append the actions to the
6968 -- actions field of the short-circuit operation. We will
6969 -- also analyze the actions now.
6971 -- This analysis is really too early, the proper thing would
6972 -- be to just park them there now, and only analyze them if
6973 -- we find we really need them, and to it at the proper
6974 -- final insertion point. However attempting to this proved
6975 -- tricky, so for now we just kill current values before and
6976 -- after the analyze call to make sure we avoid peculiar
6977 -- optimizations from this out of order insertion.
6979 Kill_Current_Values;
6981 -- If P has already been expanded, we can't park new actions
6982 -- on it, so we need to expand them immediately, introducing
6983 -- an Expression_With_Actions. N can't be an expression
6984 -- with actions, or else then the actions would have been
6985 -- inserted at an inner level.
6987 if Analyzed (P) then
6988 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
6990 Make_Expression_With_Actions (Sloc (N),
6991 Actions => Ins_Actions,
6992 Expression => Relocate_Node (N)));
6993 Analyze_And_Resolve (N);
6995 elsif Present (Actions (P)) then
6996 Insert_List_After_And_Analyze
6997 (Last (Actions (P)), Ins_Actions);
6999 Set_Actions (P, Ins_Actions);
7000 Analyze_List (Actions (P));
7003 Kill_Current_Values;
7008 -- Then or Else dependent expression of an if expression. Add
7009 -- actions to Then_Actions or Else_Actions field as appropriate.
7010 -- The actions will be moved further out when the if is expanded.
7012 when N_If_Expression =>
7014 ThenX : constant Node_Id := Next (First (Expressions (P)));
7015 ElseX : constant Node_Id := Next (ThenX);
7018 -- If the enclosing expression is already analyzed, as
7019 -- is the case for nested elaboration checks, insert the
7020 -- conditional further out.
7022 if Analyzed (P) then
7025 -- Actions belong to the then expression, temporarily place
7026 -- them as Then_Actions of the if expression. They will be
7027 -- moved to the proper place later when the if expression
7030 elsif N = ThenX then
7031 if Present (Then_Actions (P)) then
7032 Insert_List_After_And_Analyze
7033 (Last (Then_Actions (P)), Ins_Actions);
7035 Set_Then_Actions (P, Ins_Actions);
7036 Analyze_List (Then_Actions (P));
7041 -- Actions belong to the else expression, temporarily place
7042 -- them as Else_Actions of the if expression. They will be
7043 -- moved to the proper place later when the if expression
7046 elsif N = ElseX then
7047 if Present (Else_Actions (P)) then
7048 Insert_List_After_And_Analyze
7049 (Last (Else_Actions (P)), Ins_Actions);
7051 Set_Else_Actions (P, Ins_Actions);
7052 Analyze_List (Else_Actions (P));
7057 -- Actions belong to the condition. In this case they are
7058 -- unconditionally executed, and so we can continue the
7059 -- search for the proper insert point.
7066 -- Alternative of case expression, we place the action in the
7067 -- Actions field of the case expression alternative, this will
7068 -- be handled when the case expression is expanded.
7070 when N_Case_Expression_Alternative =>
7071 if Present (Actions (P)) then
7072 Insert_List_After_And_Analyze
7073 (Last (Actions (P)), Ins_Actions);
7075 Set_Actions (P, Ins_Actions);
7076 Analyze_List (Actions (P));
7081 -- Case of appearing within an Expressions_With_Actions node. When
7082 -- the new actions come from the expression of the expression with
7083 -- actions, they must be added to the existing actions. The other
7084 -- alternative is when the new actions are related to one of the
7085 -- existing actions of the expression with actions, and should
7086 -- never reach here: if actions are inserted on a statement
7087 -- within the Actions of an expression with actions, or on some
7088 -- subexpression of such a statement, then the outermost proper
7089 -- insertion point is right before the statement, and we should
7090 -- never climb up as far as the N_Expression_With_Actions itself.
7092 when N_Expression_With_Actions =>
7093 if N = Expression (P) then
7094 if Is_Empty_List (Actions (P)) then
7095 Append_List_To (Actions (P), Ins_Actions);
7096 Analyze_List (Actions (P));
7098 Insert_List_After_And_Analyze
7099 (Last (Actions (P)), Ins_Actions);
7105 raise Program_Error;
7108 -- Case of appearing in the condition of a while expression or
7109 -- elsif. We insert the actions into the Condition_Actions field.
7110 -- They will be moved further out when the while loop or elsif
7114 | N_Iteration_Scheme
7116 if N = Condition (P) then
7117 if Present (Condition_Actions (P)) then
7118 Insert_List_After_And_Analyze
7119 (Last (Condition_Actions (P)), Ins_Actions);
7121 Set_Condition_Actions (P, Ins_Actions);
7123 -- Set the parent of the insert actions explicitly. This
7124 -- is not a syntactic field, but we need the parent field
7125 -- set, in particular so that freeze can understand that
7126 -- it is dealing with condition actions, and properly
7127 -- insert the freezing actions.
7129 Set_Parent (Ins_Actions, P);
7130 Analyze_List (Condition_Actions (P));
7136 -- Statements, declarations, pragmas, representation clauses
7141 N_Procedure_Call_Statement
7142 | N_Statement_Other_Than_Procedure_Call
7148 -- Representation_Clause
7151 | N_Attribute_Definition_Clause
7152 | N_Enumeration_Representation_Clause
7153 | N_Record_Representation_Clause
7157 | N_Abstract_Subprogram_Declaration
7159 | N_Exception_Declaration
7160 | N_Exception_Renaming_Declaration
7161 | N_Expression_Function
7162 | N_Formal_Abstract_Subprogram_Declaration
7163 | N_Formal_Concrete_Subprogram_Declaration
7164 | N_Formal_Object_Declaration
7165 | N_Formal_Type_Declaration
7166 | N_Full_Type_Declaration
7167 | N_Function_Instantiation
7168 | N_Generic_Function_Renaming_Declaration
7169 | N_Generic_Package_Declaration
7170 | N_Generic_Package_Renaming_Declaration
7171 | N_Generic_Procedure_Renaming_Declaration
7172 | N_Generic_Subprogram_Declaration
7173 | N_Implicit_Label_Declaration
7174 | N_Incomplete_Type_Declaration
7175 | N_Number_Declaration
7176 | N_Object_Declaration
7177 | N_Object_Renaming_Declaration
7179 | N_Package_Body_Stub
7180 | N_Package_Declaration
7181 | N_Package_Instantiation
7182 | N_Package_Renaming_Declaration
7183 | N_Private_Extension_Declaration
7184 | N_Private_Type_Declaration
7185 | N_Procedure_Instantiation
7187 | N_Protected_Body_Stub
7188 | N_Single_Task_Declaration
7190 | N_Subprogram_Body_Stub
7191 | N_Subprogram_Declaration
7192 | N_Subprogram_Renaming_Declaration
7193 | N_Subtype_Declaration
7197 -- Use clauses can appear in lists of declarations
7199 | N_Use_Package_Clause
7202 -- Freeze entity behaves like a declaration or statement
7205 | N_Freeze_Generic_Entity
7207 -- Do not insert here if the item is not a list member (this
7208 -- happens for example with a triggering statement, and the
7209 -- proper approach is to insert before the entire select).
7211 if not Is_List_Member (P) then
7214 -- Do not insert if parent of P is an N_Component_Association
7215 -- node (i.e. we are in the context of an N_Aggregate or
7216 -- N_Extension_Aggregate node. In this case we want to insert
7217 -- before the entire aggregate.
7219 elsif Nkind (Parent (P)) = N_Component_Association then
7222 -- Do not insert if the parent of P is either an N_Variant node
7223 -- or an N_Record_Definition node, meaning in either case that
7224 -- P is a member of a component list, and that therefore the
7225 -- actions should be inserted outside the complete record
7228 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
7231 -- Do not insert freeze nodes within the loop generated for
7232 -- an aggregate, because they may be elaborated too late for
7233 -- subsequent use in the back end: within a package spec the
7234 -- loop is part of the elaboration procedure and is only
7235 -- elaborated during the second pass.
7237 -- If the loop comes from source, or the entity is local to the
7238 -- loop itself it must remain within.
7240 elsif Nkind (Parent (P)) = N_Loop_Statement
7241 and then not Comes_From_Source (Parent (P))
7242 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7244 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7248 -- Otherwise we can go ahead and do the insertion
7250 elsif P = Wrapped_Node then
7251 Store_Before_Actions_In_Scope (Ins_Actions);
7255 Insert_List_Before_And_Analyze (P, Ins_Actions);
7259 -- the expansion of Task and protected type declarations can
7260 -- create declarations for temporaries which, like other actions
7261 -- are inserted and analyzed before the current declaraation.
7262 -- However, the current scope is the synchronized type, and
7263 -- for unnesting it is critical that the proper scope for these
7264 -- generated entities be the enclosing one.
7266 when N_Task_Type_Declaration
7267 | N_Protected_Type_Declaration =>
7269 Push_Scope (Scope (Current_Scope));
7270 Insert_List_Before_And_Analyze (P, Ins_Actions);
7274 -- A special case, N_Raise_xxx_Error can act either as a statement
7275 -- or a subexpression. We tell the difference by looking at the
7276 -- Etype. It is set to Standard_Void_Type in the statement case.
7278 when N_Raise_xxx_Error =>
7279 if Etype (P) = Standard_Void_Type then
7280 if P = Wrapped_Node then
7281 Store_Before_Actions_In_Scope (Ins_Actions);
7283 Insert_List_Before_And_Analyze (P, Ins_Actions);
7288 -- In the subexpression case, keep climbing
7294 -- If a component association appears within a loop created for
7295 -- an array aggregate, attach the actions to the association so
7296 -- they can be subsequently inserted within the loop. For other
7297 -- component associations insert outside of the aggregate. For
7298 -- an association that will generate a loop, its Loop_Actions
7299 -- attribute is already initialized (see exp_aggr.adb).
7301 -- The list of Loop_Actions can in turn generate additional ones,
7302 -- that are inserted before the associated node. If the associated
7303 -- node is outside the aggregate, the new actions are collected
7304 -- at the end of the Loop_Actions, to respect the order in which
7305 -- they are to be elaborated.
7307 when N_Component_Association
7308 | N_Iterated_Component_Association
7310 if Nkind (Parent (P)) = N_Aggregate
7311 and then Present (Loop_Actions (P))
7313 if Is_Empty_List (Loop_Actions (P)) then
7314 Set_Loop_Actions (P, Ins_Actions);
7315 Analyze_List (Ins_Actions);
7321 -- Check whether these actions were generated by a
7322 -- declaration that is part of the Loop_Actions for
7323 -- the component_association.
7326 while Present (Decl) loop
7327 exit when Parent (Decl) = P
7328 and then Is_List_Member (Decl)
7330 List_Containing (Decl) = Loop_Actions (P);
7331 Decl := Parent (Decl);
7334 if Present (Decl) then
7335 Insert_List_Before_And_Analyze
7336 (Decl, Ins_Actions);
7338 Insert_List_After_And_Analyze
7339 (Last (Loop_Actions (P)), Ins_Actions);
7350 -- Special case: an attribute denoting a procedure call
7352 when N_Attribute_Reference =>
7353 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7354 if P = Wrapped_Node then
7355 Store_Before_Actions_In_Scope (Ins_Actions);
7357 Insert_List_Before_And_Analyze (P, Ins_Actions);
7362 -- In the subexpression case, keep climbing
7368 -- Special case: a marker
7371 | N_Variable_Reference_Marker
7373 if Is_List_Member (P) then
7374 Insert_List_Before_And_Analyze (P, Ins_Actions);
7378 -- A contract node should not belong to the tree
7381 raise Program_Error;
7383 -- For all other node types, keep climbing tree
7385 when N_Abortable_Part
7386 | N_Accept_Alternative
7387 | N_Access_Definition
7388 | N_Access_Function_Definition
7389 | N_Access_Procedure_Definition
7390 | N_Access_To_Object_Definition
7393 | N_Aspect_Specification
7395 | N_Case_Statement_Alternative
7396 | N_Character_Literal
7397 | N_Compilation_Unit
7398 | N_Compilation_Unit_Aux
7399 | N_Component_Clause
7400 | N_Component_Declaration
7401 | N_Component_Definition
7403 | N_Constrained_Array_Definition
7404 | N_Decimal_Fixed_Point_Definition
7405 | N_Defining_Character_Literal
7406 | N_Defining_Identifier
7407 | N_Defining_Operator_Symbol
7408 | N_Defining_Program_Unit_Name
7409 | N_Delay_Alternative
7411 | N_Delta_Constraint
7412 | N_Derived_Type_Definition
7414 | N_Digits_Constraint
7415 | N_Discriminant_Association
7416 | N_Discriminant_Specification
7418 | N_Entry_Body_Formal_Part
7419 | N_Entry_Call_Alternative
7420 | N_Entry_Declaration
7421 | N_Entry_Index_Specification
7422 | N_Enumeration_Type_Definition
7424 | N_Exception_Handler
7426 | N_Explicit_Dereference
7427 | N_Extension_Aggregate
7428 | N_Floating_Point_Definition
7429 | N_Formal_Decimal_Fixed_Point_Definition
7430 | N_Formal_Derived_Type_Definition
7431 | N_Formal_Discrete_Type_Definition
7432 | N_Formal_Floating_Point_Definition
7433 | N_Formal_Modular_Type_Definition
7434 | N_Formal_Ordinary_Fixed_Point_Definition
7435 | N_Formal_Package_Declaration
7436 | N_Formal_Private_Type_Definition
7437 | N_Formal_Incomplete_Type_Definition
7438 | N_Formal_Signed_Integer_Type_Definition
7440 | N_Function_Specification
7441 | N_Generic_Association
7442 | N_Handled_Sequence_Of_Statements
7445 | N_Index_Or_Discriminant_Constraint
7446 | N_Indexed_Component
7448 | N_Iterator_Specification
7451 | N_Loop_Parameter_Specification
7453 | N_Modular_Type_Definition
7479 | N_Op_Shift_Right_Arithmetic
7483 | N_Ordinary_Fixed_Point_Definition
7485 | N_Package_Specification
7486 | N_Parameter_Association
7487 | N_Parameter_Specification
7488 | N_Pop_Constraint_Error_Label
7489 | N_Pop_Program_Error_Label
7490 | N_Pop_Storage_Error_Label
7491 | N_Pragma_Argument_Association
7492 | N_Procedure_Specification
7493 | N_Protected_Definition
7494 | N_Push_Constraint_Error_Label
7495 | N_Push_Program_Error_Label
7496 | N_Push_Storage_Error_Label
7497 | N_Qualified_Expression
7498 | N_Quantified_Expression
7499 | N_Raise_Expression
7501 | N_Range_Constraint
7503 | N_Real_Range_Specification
7504 | N_Record_Definition
7506 | N_SCIL_Dispatch_Table_Tag_Init
7507 | N_SCIL_Dispatching_Call
7508 | N_SCIL_Membership_Test
7509 | N_Selected_Component
7510 | N_Signed_Integer_Type_Definition
7511 | N_Single_Protected_Declaration
7514 | N_Subtype_Indication
7518 | N_Terminate_Alternative
7519 | N_Triggering_Alternative
7521 | N_Unchecked_Expression
7522 | N_Unchecked_Type_Conversion
7523 | N_Unconstrained_Array_Definition
7528 | N_Validate_Unchecked_Conversion
7534 -- If we fall through above tests, keep climbing tree
7538 if Nkind (Parent (N)) = N_Subunit then
7540 -- This is the proper body corresponding to a stub. Insertion must
7541 -- be done at the point of the stub, which is in the declarative
7542 -- part of the parent unit.
7544 P := Corresponding_Stub (Parent (N));
7552 -- Version with check(s) suppressed
7554 procedure Insert_Actions
7555 (Assoc_Node : Node_Id;
7556 Ins_Actions : List_Id;
7557 Suppress : Check_Id;
7558 Spec_Expr_OK : Boolean := False)
7561 if Suppress = All_Checks then
7563 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
7565 Scope_Suppress.Suppress := (others => True);
7566 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7567 Scope_Suppress.Suppress := Sva;
7572 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
7574 Scope_Suppress.Suppress (Suppress) := True;
7575 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7576 Scope_Suppress.Suppress (Suppress) := Svg;
7581 --------------------------
7582 -- Insert_Actions_After --
7583 --------------------------
7585 procedure Insert_Actions_After
7586 (Assoc_Node : Node_Id;
7587 Ins_Actions : List_Id)
7590 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
7591 Store_After_Actions_In_Scope (Ins_Actions);
7593 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
7595 end Insert_Actions_After;
7597 ------------------------
7598 -- Insert_Declaration --
7599 ------------------------
7601 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
7605 pragma Assert (Nkind (N) in N_Subexpr);
7607 -- Climb until we find a procedure or a package
7611 pragma Assert (Present (Parent (P)));
7614 if Is_List_Member (P) then
7615 exit when Nkind_In (Parent (P), N_Package_Specification,
7618 -- Special handling for handled sequence of statements, we must
7619 -- insert in the statements not the exception handlers!
7621 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
7622 P := First (Statements (Parent (P)));
7628 -- Now do the insertion
7630 Insert_Before (P, Decl);
7632 end Insert_Declaration;
7634 ---------------------------------
7635 -- Insert_Library_Level_Action --
7636 ---------------------------------
7638 procedure Insert_Library_Level_Action (N : Node_Id) is
7639 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7642 Push_Scope (Cunit_Entity (Current_Sem_Unit));
7643 -- And not Main_Unit as previously. If the main unit is a body,
7644 -- the scope needed to analyze the actions is the entity of the
7645 -- corresponding declaration.
7647 if No (Actions (Aux)) then
7648 Set_Actions (Aux, New_List (N));
7650 Append (N, Actions (Aux));
7655 end Insert_Library_Level_Action;
7657 ----------------------------------
7658 -- Insert_Library_Level_Actions --
7659 ----------------------------------
7661 procedure Insert_Library_Level_Actions (L : List_Id) is
7662 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7665 if Is_Non_Empty_List (L) then
7666 Push_Scope (Cunit_Entity (Main_Unit));
7667 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
7669 if No (Actions (Aux)) then
7670 Set_Actions (Aux, L);
7673 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
7678 end Insert_Library_Level_Actions;
7680 ----------------------
7681 -- Inside_Init_Proc --
7682 ----------------------
7684 function Inside_Init_Proc return Boolean is
7685 Proc : constant Entity_Id := Enclosing_Init_Proc;
7688 return Proc /= Empty;
7689 end Inside_Init_Proc;
7691 ----------------------------
7692 -- Is_All_Null_Statements --
7693 ----------------------------
7695 function Is_All_Null_Statements (L : List_Id) return Boolean is
7700 while Present (Stm) loop
7701 if Nkind (Stm) /= N_Null_Statement then
7709 end Is_All_Null_Statements;
7711 --------------------------------------------------
7712 -- Is_Displacement_Of_Object_Or_Function_Result --
7713 --------------------------------------------------
7715 function Is_Displacement_Of_Object_Or_Function_Result
7716 (Obj_Id : Entity_Id) return Boolean
7718 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
7719 -- Determine whether node N denotes a controlled function call
7721 function Is_Controlled_Indexing (N : Node_Id) return Boolean;
7722 -- Determine whether node N denotes a generalized indexing form which
7723 -- involves a controlled result.
7725 function Is_Displace_Call (N : Node_Id) return Boolean;
7726 -- Determine whether node N denotes a call to Ada.Tags.Displace
7728 function Is_Source_Object (N : Node_Id) return Boolean;
7729 -- Determine whether a particular node denotes a source object
7731 function Strip (N : Node_Id) return Node_Id;
7732 -- Examine arbitrary node N by stripping various indirections and return
7735 ---------------------------------
7736 -- Is_Controlled_Function_Call --
7737 ---------------------------------
7739 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
7743 -- When a function call appears in Object.Operation format, the
7744 -- original representation has several possible forms depending on
7745 -- the availability and form of actual parameters:
7747 -- Obj.Func N_Selected_Component
7748 -- Obj.Func (Actual) N_Indexed_Component
7749 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
7750 -- N_Selected_Component
7752 Expr := Original_Node (N);
7754 if Nkind (Expr) = N_Function_Call then
7755 Expr := Name (Expr);
7757 -- "Obj.Func (Actual)" case
7759 elsif Nkind (Expr) = N_Indexed_Component then
7760 Expr := Prefix (Expr);
7762 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
7764 elsif Nkind (Expr) = N_Selected_Component then
7765 Expr := Selector_Name (Expr);
7773 Nkind (Expr) in N_Has_Entity
7774 and then Present (Entity (Expr))
7775 and then Ekind (Entity (Expr)) = E_Function
7776 and then Needs_Finalization (Etype (Entity (Expr)));
7777 end Is_Controlled_Function_Call;
7779 ----------------------------
7780 -- Is_Controlled_Indexing --
7781 ----------------------------
7783 function Is_Controlled_Indexing (N : Node_Id) return Boolean is
7784 Expr : constant Node_Id := Original_Node (N);
7788 Nkind (Expr) = N_Indexed_Component
7789 and then Present (Generalized_Indexing (Expr))
7790 and then Needs_Finalization (Etype (Expr));
7791 end Is_Controlled_Indexing;
7793 ----------------------
7794 -- Is_Displace_Call --
7795 ----------------------
7797 function Is_Displace_Call (N : Node_Id) return Boolean is
7798 Call : constant Node_Id := Strip (N);
7803 and then Nkind (Call) = N_Function_Call
7804 and then Nkind (Name (Call)) in N_Has_Entity
7805 and then Is_RTE (Entity (Name (Call)), RE_Displace);
7806 end Is_Displace_Call;
7808 ----------------------
7809 -- Is_Source_Object --
7810 ----------------------
7812 function Is_Source_Object (N : Node_Id) return Boolean is
7813 Obj : constant Node_Id := Strip (N);
7818 and then Comes_From_Source (Obj)
7819 and then Nkind (Obj) in N_Has_Entity
7820 and then Is_Object (Entity (Obj));
7821 end Is_Source_Object;
7827 function Strip (N : Node_Id) return Node_Id is
7833 if Nkind (Result) = N_Explicit_Dereference then
7834 Result := Prefix (Result);
7836 elsif Nkind_In (Result, N_Type_Conversion,
7837 N_Unchecked_Type_Conversion)
7839 Result := Expression (Result);
7851 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
7852 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7853 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
7854 Orig_Expr : Node_Id;
7856 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
7861 -- Obj : CW_Type := Function_Call (...);
7863 -- is rewritten into:
7865 -- Temp : ... := Function_Call (...)'reference;
7866 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
7868 -- where the return type of the function and the class-wide type require
7869 -- dispatch table pointer displacement.
7873 -- Obj : CW_Type := Container (...);
7875 -- is rewritten into:
7877 -- Temp : ... := Function_Call (Container, ...)'reference;
7878 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
7880 -- where the container element type and the class-wide type require
7881 -- dispatch table pointer dispacement.
7885 -- Obj : CW_Type := Src_Obj;
7887 -- is rewritten into:
7889 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7891 -- where the type of the source object and the class-wide type require
7892 -- dispatch table pointer displacement.
7894 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
7895 and then Is_Class_Wide_Type (Obj_Typ)
7896 and then Is_Displace_Call (Renamed_Object (Obj_Id))
7897 and then Nkind (Orig_Decl) = N_Object_Declaration
7898 and then Comes_From_Source (Orig_Decl)
7900 Orig_Expr := Expression (Orig_Decl);
7903 Is_Controlled_Function_Call (Orig_Expr)
7904 or else Is_Controlled_Indexing (Orig_Expr)
7905 or else Is_Source_Object (Orig_Expr);
7909 end Is_Displacement_Of_Object_Or_Function_Result;
7911 ------------------------------
7912 -- Is_Finalizable_Transient --
7913 ------------------------------
7915 function Is_Finalizable_Transient
7917 Rel_Node : Node_Id) return Boolean
7919 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
7920 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7922 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
7923 -- Determine whether transient object Trans_Id is initialized either
7924 -- by a function call which returns an access type or simply renames
7927 function Initialized_By_Aliased_BIP_Func_Call
7928 (Trans_Id : Entity_Id) return Boolean;
7929 -- Determine whether transient object Trans_Id is initialized by a
7930 -- build-in-place function call where the BIPalloc parameter is of
7931 -- value 1 and BIPaccess is not null. This case creates an aliasing
7932 -- between the returned value and the value denoted by BIPaccess.
7935 (Trans_Id : Entity_Id;
7936 First_Stmt : Node_Id) return Boolean;
7937 -- Determine whether transient object Trans_Id has been renamed or
7938 -- aliased through 'reference in the statement list starting from
7941 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
7942 -- Determine whether transient object Trans_Id is allocated on the heap
7944 function Is_Iterated_Container
7945 (Trans_Id : Entity_Id;
7946 First_Stmt : Node_Id) return Boolean;
7947 -- Determine whether transient object Trans_Id denotes a container which
7948 -- is in the process of being iterated in the statement list starting
7951 ---------------------------
7952 -- Initialized_By_Access --
7953 ---------------------------
7955 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
7956 Expr : constant Node_Id := Expression (Parent (Trans_Id));
7961 and then Nkind (Expr) /= N_Reference
7962 and then Is_Access_Type (Etype (Expr));
7963 end Initialized_By_Access;
7965 ------------------------------------------
7966 -- Initialized_By_Aliased_BIP_Func_Call --
7967 ------------------------------------------
7969 function Initialized_By_Aliased_BIP_Func_Call
7970 (Trans_Id : Entity_Id) return Boolean
7972 Call : Node_Id := Expression (Parent (Trans_Id));
7975 -- Build-in-place calls usually appear in 'reference format
7977 if Nkind (Call) = N_Reference then
7978 Call := Prefix (Call);
7981 Call := Unqual_Conv (Call);
7983 if Is_Build_In_Place_Function_Call (Call) then
7985 Access_Nam : Name_Id := No_Name;
7986 Access_OK : Boolean := False;
7988 Alloc_Nam : Name_Id := No_Name;
7989 Alloc_OK : Boolean := False;
7991 Func_Id : Entity_Id;
7995 -- Examine all parameter associations of the function call
7997 Param := First (Parameter_Associations (Call));
7998 while Present (Param) loop
7999 if Nkind (Param) = N_Parameter_Association
8000 and then Nkind (Selector_Name (Param)) = N_Identifier
8002 Actual := Explicit_Actual_Parameter (Param);
8003 Formal := Selector_Name (Param);
8005 -- Construct the names of formals BIPaccess and BIPalloc
8006 -- using the function name retrieved from an arbitrary
8009 if Access_Nam = No_Name
8010 and then Alloc_Nam = No_Name
8011 and then Present (Entity (Formal))
8013 Func_Id := Scope (Entity (Formal));
8016 New_External_Name (Chars (Func_Id),
8017 BIP_Formal_Suffix (BIP_Object_Access));
8020 New_External_Name (Chars (Func_Id),
8021 BIP_Formal_Suffix (BIP_Alloc_Form));
8024 -- A match for BIPaccess => Temp has been found
8026 if Chars (Formal) = Access_Nam
8027 and then Nkind (Actual) /= N_Null
8032 -- A match for BIPalloc => 1 has been found
8034 if Chars (Formal) = Alloc_Nam
8035 and then Nkind (Actual) = N_Integer_Literal
8036 and then Intval (Actual) = Uint_1
8045 return Access_OK and Alloc_OK;
8050 end Initialized_By_Aliased_BIP_Func_Call;
8057 (Trans_Id : Entity_Id;
8058 First_Stmt : Node_Id) return Boolean
8060 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
8061 -- Given an object renaming declaration, retrieve the entity of the
8062 -- renamed name. Return Empty if the renamed name is anything other
8063 -- than a variable or a constant.
8065 -------------------------
8066 -- Find_Renamed_Object --
8067 -------------------------
8069 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
8070 Ren_Obj : Node_Id := Empty;
8072 function Find_Object (N : Node_Id) return Traverse_Result;
8073 -- Try to detect an object which is either a constant or a
8080 function Find_Object (N : Node_Id) return Traverse_Result is
8082 -- Stop the search once a constant or a variable has been
8085 if Nkind (N) = N_Identifier
8086 and then Present (Entity (N))
8087 and then Ekind_In (Entity (N), E_Constant, E_Variable)
8089 Ren_Obj := Entity (N);
8096 procedure Search is new Traverse_Proc (Find_Object);
8100 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
8102 -- Start of processing for Find_Renamed_Object
8105 -- Actions related to dispatching calls may appear as renamings of
8106 -- tags. Do not process this type of renaming because it does not
8107 -- use the actual value of the object.
8109 if not Is_RTE (Typ, RE_Tag_Ptr) then
8110 Search (Name (Ren_Decl));
8114 end Find_Renamed_Object;
8119 Ren_Obj : Entity_Id;
8122 -- Start of processing for Is_Aliased
8125 -- A controlled transient object is not considered aliased when it
8126 -- appears inside an expression_with_actions node even when there are
8127 -- explicit aliases of it:
8130 -- Trans_Id : Ctrl_Typ ...; -- transient object
8131 -- Alias : ... := Trans_Id; -- object is aliased
8132 -- Val : constant Boolean :=
8133 -- ... Alias ...; -- aliasing ends
8134 -- <finalize Trans_Id> -- object safe to finalize
8137 -- Expansion ensures that all aliases are encapsulated in the actions
8138 -- list and do not leak to the expression by forcing the evaluation
8139 -- of the expression.
8141 if Nkind (Rel_Node) = N_Expression_With_Actions then
8144 -- Otherwise examine the statements after the controlled transient
8145 -- object and look for various forms of aliasing.
8149 while Present (Stmt) loop
8150 if Nkind (Stmt) = N_Object_Declaration then
8151 Expr := Expression (Stmt);
8153 -- Aliasing of the form:
8154 -- Obj : ... := Trans_Id'reference;
8157 and then Nkind (Expr) = N_Reference
8158 and then Nkind (Prefix (Expr)) = N_Identifier
8159 and then Entity (Prefix (Expr)) = Trans_Id
8164 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
8165 Ren_Obj := Find_Renamed_Object (Stmt);
8167 -- Aliasing of the form:
8168 -- Obj : ... renames ... Trans_Id ...;
8170 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
8186 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
8187 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8190 Is_Access_Type (Etype (Trans_Id))
8191 and then Present (Expr)
8192 and then Nkind (Expr) = N_Allocator;
8195 ---------------------------
8196 -- Is_Iterated_Container --
8197 ---------------------------
8199 function Is_Iterated_Container
8200 (Trans_Id : Entity_Id;
8201 First_Stmt : Node_Id) return Boolean
8211 -- It is not possible to iterate over containers in non-Ada 2012 code
8213 if Ada_Version < Ada_2012 then
8217 Typ := Etype (Trans_Id);
8219 -- Handle access type created for secondary stack use
8221 if Is_Access_Type (Typ) then
8222 Typ := Designated_Type (Typ);
8225 -- Look for aspect Default_Iterator. It may be part of a type
8226 -- declaration for a container, or inherited from a base type
8229 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8231 if Present (Aspect) then
8232 Iter := Entity (Aspect);
8234 -- Examine the statements following the container object and
8235 -- look for a call to the default iterate routine where the
8236 -- first parameter is the transient. Such a call appears as:
8238 -- It : Access_To_CW_Iterator :=
8239 -- Iterate (Tran_Id.all, ...)'reference;
8242 while Present (Stmt) loop
8244 -- Detect an object declaration which is initialized by a
8245 -- secondary stack function call.
8247 if Nkind (Stmt) = N_Object_Declaration
8248 and then Present (Expression (Stmt))
8249 and then Nkind (Expression (Stmt)) = N_Reference
8250 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8252 Call := Prefix (Expression (Stmt));
8254 -- The call must invoke the default iterate routine of
8255 -- the container and the transient object must appear as
8256 -- the first actual parameter. Skip any calls whose names
8257 -- are not entities.
8259 if Is_Entity_Name (Name (Call))
8260 and then Entity (Name (Call)) = Iter
8261 and then Present (Parameter_Associations (Call))
8263 Param := First (Parameter_Associations (Call));
8265 if Nkind (Param) = N_Explicit_Dereference
8266 and then Entity (Prefix (Param)) = Trans_Id
8278 end Is_Iterated_Container;
8282 Desig : Entity_Id := Obj_Typ;
8284 -- Start of processing for Is_Finalizable_Transient
8287 -- Handle access types
8289 if Is_Access_Type (Desig) then
8290 Desig := Available_View (Designated_Type (Desig));
8294 Ekind_In (Obj_Id, E_Constant, E_Variable)
8295 and then Needs_Finalization (Desig)
8296 and then Requires_Transient_Scope (Desig)
8297 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8299 -- Do not consider a transient object that was already processed
8301 and then not Is_Finalized_Transient (Obj_Id)
8303 -- Do not consider renamed or 'reference-d transient objects because
8304 -- the act of renaming extends the object's lifetime.
8306 and then not Is_Aliased (Obj_Id, Decl)
8308 -- Do not consider transient objects allocated on the heap since
8309 -- they are attached to a finalization master.
8311 and then not Is_Allocated (Obj_Id)
8313 -- If the transient object is a pointer, check that it is not
8314 -- initialized by a function that returns a pointer or acts as a
8315 -- renaming of another pointer.
8318 (not Is_Access_Type (Obj_Typ)
8319 or else not Initialized_By_Access (Obj_Id))
8321 -- Do not consider transient objects which act as indirect aliases
8322 -- of build-in-place function results.
8324 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8326 -- Do not consider conversions of tags to class-wide types
8328 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8330 -- Do not consider iterators because those are treated as normal
8331 -- controlled objects and are processed by the usual finalization
8332 -- machinery. This avoids the double finalization of an iterator.
8334 and then not Is_Iterator (Desig)
8336 -- Do not consider containers in the context of iterator loops. Such
8337 -- transient objects must exist for as long as the loop is around,
8338 -- otherwise any operation carried out by the iterator will fail.
8340 and then not Is_Iterated_Container (Obj_Id, Decl);
8341 end Is_Finalizable_Transient;
8343 ---------------------------------
8344 -- Is_Fully_Repped_Tagged_Type --
8345 ---------------------------------
8347 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8348 U : constant Entity_Id := Underlying_Type (T);
8352 if No (U) or else not Is_Tagged_Type (U) then
8354 elsif Has_Discriminants (U) then
8356 elsif not Has_Specified_Layout (U) then
8360 -- Here we have a tagged type, see if it has any component (other than
8361 -- tag and parent) with no component_clause. If so, we return False.
8363 Comp := First_Component (U);
8364 while Present (Comp) loop
8365 if not Is_Tag (Comp)
8366 and then Chars (Comp) /= Name_uParent
8367 and then No (Component_Clause (Comp))
8371 Next_Component (Comp);
8375 -- All components have clauses
8378 end Is_Fully_Repped_Tagged_Type;
8380 ----------------------------------
8381 -- Is_Library_Level_Tagged_Type --
8382 ----------------------------------
8384 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8386 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8387 end Is_Library_Level_Tagged_Type;
8389 --------------------------
8390 -- Is_Non_BIP_Func_Call --
8391 --------------------------
8393 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8395 -- The expected call is of the format
8397 -- Func_Call'reference
8400 Nkind (Expr) = N_Reference
8401 and then Nkind (Prefix (Expr)) = N_Function_Call
8402 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8403 end Is_Non_BIP_Func_Call;
8405 ----------------------------------
8406 -- Is_Possibly_Unaligned_Object --
8407 ----------------------------------
8409 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8410 T : constant Entity_Id := Etype (N);
8413 -- If renamed object, apply test to underlying object
8415 if Is_Entity_Name (N)
8416 and then Is_Object (Entity (N))
8417 and then Present (Renamed_Object (Entity (N)))
8419 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8422 -- Tagged and controlled types and aliased types are always aligned, as
8423 -- are concurrent types.
8426 or else Has_Controlled_Component (T)
8427 or else Is_Concurrent_Type (T)
8428 or else Is_Tagged_Type (T)
8429 or else Is_Controlled (T)
8434 -- If this is an element of a packed array, may be unaligned
8436 if Is_Ref_To_Bit_Packed_Array (N) then
8440 -- Case of indexed component reference: test whether prefix is unaligned
8442 if Nkind (N) = N_Indexed_Component then
8443 return Is_Possibly_Unaligned_Object (Prefix (N));
8445 -- Case of selected component reference
8447 elsif Nkind (N) = N_Selected_Component then
8449 P : constant Node_Id := Prefix (N);
8450 C : constant Entity_Id := Entity (Selector_Name (N));
8455 -- If component reference is for an array with nonstatic bounds,
8456 -- then it is always aligned: we can only process unaligned arrays
8457 -- with static bounds (more precisely compile time known bounds).
8459 if Is_Array_Type (T)
8460 and then not Compile_Time_Known_Bounds (T)
8465 -- If component is aliased, it is definitely properly aligned
8467 if Is_Aliased (C) then
8471 -- If component is for a type implemented as a scalar, and the
8472 -- record is packed, and the component is other than the first
8473 -- component of the record, then the component may be unaligned.
8475 if Is_Packed (Etype (P))
8476 and then Represented_As_Scalar (Etype (C))
8477 and then First_Entity (Scope (C)) /= C
8482 -- Compute maximum possible alignment for T
8484 -- If alignment is known, then that settles things
8486 if Known_Alignment (T) then
8487 M := UI_To_Int (Alignment (T));
8489 -- If alignment is not known, tentatively set max alignment
8492 M := Ttypes.Maximum_Alignment;
8494 -- We can reduce this if the Esize is known since the default
8495 -- alignment will never be more than the smallest power of 2
8496 -- that does not exceed this Esize value.
8498 if Known_Esize (T) then
8499 S := UI_To_Int (Esize (T));
8501 while (M / 2) >= S loop
8507 -- The following code is historical, it used to be present but it
8508 -- is too cautious, because the front-end does not know the proper
8509 -- default alignments for the target. Also, if the alignment is
8510 -- not known, the front end can't know in any case. If a copy is
8511 -- needed, the back-end will take care of it. This whole section
8512 -- including this comment can be removed later ???
8514 -- If the component reference is for a record that has a specified
8515 -- alignment, and we either know it is too small, or cannot tell,
8516 -- then the component may be unaligned.
8518 -- What is the following commented out code ???
8520 -- if Known_Alignment (Etype (P))
8521 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
8522 -- and then M > Alignment (Etype (P))
8527 -- Case of component clause present which may specify an
8528 -- unaligned position.
8530 if Present (Component_Clause (C)) then
8532 -- Otherwise we can do a test to make sure that the actual
8533 -- start position in the record, and the length, are both
8534 -- consistent with the required alignment. If not, we know
8535 -- that we are unaligned.
8538 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8544 -- For a component inherited in a record extension, the
8545 -- clause is inherited but position and size are not set.
8547 if Is_Base_Type (Etype (P))
8548 and then Is_Tagged_Type (Etype (P))
8549 and then Present (Original_Record_Component (Comp))
8551 Comp := Original_Record_Component (Comp);
8554 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
8555 or else Esize (Comp) mod Align_In_Bits /= 0
8562 -- Otherwise, for a component reference, test prefix
8564 return Is_Possibly_Unaligned_Object (P);
8567 -- If not a component reference, must be aligned
8572 end Is_Possibly_Unaligned_Object;
8574 ---------------------------------
8575 -- Is_Possibly_Unaligned_Slice --
8576 ---------------------------------
8578 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
8580 -- Go to renamed object
8582 if Is_Entity_Name (N)
8583 and then Is_Object (Entity (N))
8584 and then Present (Renamed_Object (Entity (N)))
8586 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
8589 -- The reference must be a slice
8591 if Nkind (N) /= N_Slice then
8595 -- If it is a slice, then look at the array type being sliced
8598 Sarr : constant Node_Id := Prefix (N);
8599 -- Prefix of the slice, i.e. the array being sliced
8601 Styp : constant Entity_Id := Etype (Prefix (N));
8602 -- Type of the array being sliced
8608 -- The problems arise if the array object that is being sliced
8609 -- is a component of a record or array, and we cannot guarantee
8610 -- the alignment of the array within its containing object.
8612 -- To investigate this, we look at successive prefixes to see
8613 -- if we have a worrisome indexed or selected component.
8617 -- Case of array is part of an indexed component reference
8619 if Nkind (Pref) = N_Indexed_Component then
8620 Ptyp := Etype (Prefix (Pref));
8622 -- The only problematic case is when the array is packed, in
8623 -- which case we really know nothing about the alignment of
8624 -- individual components.
8626 if Is_Bit_Packed_Array (Ptyp) then
8630 -- Case of array is part of a selected component reference
8632 elsif Nkind (Pref) = N_Selected_Component then
8633 Ptyp := Etype (Prefix (Pref));
8635 -- We are definitely in trouble if the record in question
8636 -- has an alignment, and either we know this alignment is
8637 -- inconsistent with the alignment of the slice, or we don't
8638 -- know what the alignment of the slice should be. But this
8639 -- really matters only if the target has strict alignment.
8641 if Target_Strict_Alignment
8642 and then Known_Alignment (Ptyp)
8643 and then (Unknown_Alignment (Styp)
8644 or else Alignment (Styp) > Alignment (Ptyp))
8649 -- We are in potential trouble if the record type is packed.
8650 -- We could special case when we know that the array is the
8651 -- first component, but that's not such a simple case ???
8653 if Is_Packed (Ptyp) then
8657 -- We are in trouble if there is a component clause, and
8658 -- either we do not know the alignment of the slice, or
8659 -- the alignment of the slice is inconsistent with the
8660 -- bit position specified by the component clause.
8663 Field : constant Entity_Id := Entity (Selector_Name (Pref));
8665 if Present (Component_Clause (Field))
8667 (Unknown_Alignment (Styp)
8669 (Component_Bit_Offset (Field) mod
8670 (System_Storage_Unit * Alignment (Styp))) /= 0)
8676 -- For cases other than selected or indexed components we know we
8677 -- are OK, since no issues arise over alignment.
8683 -- We processed an indexed component or selected component
8684 -- reference that looked safe, so keep checking prefixes.
8686 Pref := Prefix (Pref);
8689 end Is_Possibly_Unaligned_Slice;
8691 -------------------------------
8692 -- Is_Related_To_Func_Return --
8693 -------------------------------
8695 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
8696 Expr : constant Node_Id := Related_Expression (Id);
8700 and then Nkind (Expr) = N_Explicit_Dereference
8701 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
8702 end Is_Related_To_Func_Return;
8704 --------------------------------
8705 -- Is_Ref_To_Bit_Packed_Array --
8706 --------------------------------
8708 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
8713 if Is_Entity_Name (N)
8714 and then Is_Object (Entity (N))
8715 and then Present (Renamed_Object (Entity (N)))
8717 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
8720 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8721 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
8724 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
8727 if Result and then Nkind (N) = N_Indexed_Component then
8728 Expr := First (Expressions (N));
8729 while Present (Expr) loop
8730 Force_Evaluation (Expr);
8740 end Is_Ref_To_Bit_Packed_Array;
8742 --------------------------------
8743 -- Is_Ref_To_Bit_Packed_Slice --
8744 --------------------------------
8746 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
8748 if Nkind (N) = N_Type_Conversion then
8749 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
8751 elsif Is_Entity_Name (N)
8752 and then Is_Object (Entity (N))
8753 and then Present (Renamed_Object (Entity (N)))
8755 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
8757 elsif Nkind (N) = N_Slice
8758 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
8762 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8763 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
8768 end Is_Ref_To_Bit_Packed_Slice;
8770 -----------------------
8771 -- Is_Renamed_Object --
8772 -----------------------
8774 function Is_Renamed_Object (N : Node_Id) return Boolean is
8775 Pnod : constant Node_Id := Parent (N);
8776 Kind : constant Node_Kind := Nkind (Pnod);
8778 if Kind = N_Object_Renaming_Declaration then
8780 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
8781 return Is_Renamed_Object (Pnod);
8785 end Is_Renamed_Object;
8787 --------------------------------------
8788 -- Is_Secondary_Stack_BIP_Func_Call --
8789 --------------------------------------
8791 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
8792 Alloc_Nam : Name_Id := No_Name;
8794 Call : Node_Id := Expr;
8799 -- Build-in-place calls usually appear in 'reference format. Note that
8800 -- the accessibility check machinery may add an extra 'reference due to
8801 -- side effect removal.
8803 while Nkind (Call) = N_Reference loop
8804 Call := Prefix (Call);
8807 Call := Unqual_Conv (Call);
8809 if Is_Build_In_Place_Function_Call (Call) then
8811 -- Examine all parameter associations of the function call
8813 Param := First (Parameter_Associations (Call));
8814 while Present (Param) loop
8815 if Nkind (Param) = N_Parameter_Association then
8816 Formal := Selector_Name (Param);
8817 Actual := Explicit_Actual_Parameter (Param);
8819 -- Construct the name of formal BIPalloc. It is much easier to
8820 -- extract the name of the function using an arbitrary formal's
8821 -- scope rather than the Name field of Call.
8823 if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
8826 (Chars (Scope (Entity (Formal))),
8827 BIP_Formal_Suffix (BIP_Alloc_Form));
8830 -- A match for BIPalloc => 2 has been found
8832 if Chars (Formal) = Alloc_Nam
8833 and then Nkind (Actual) = N_Integer_Literal
8834 and then Intval (Actual) = Uint_2
8845 end Is_Secondary_Stack_BIP_Func_Call;
8847 -------------------------------------
8848 -- Is_Tag_To_Class_Wide_Conversion --
8849 -------------------------------------
8851 function Is_Tag_To_Class_Wide_Conversion
8852 (Obj_Id : Entity_Id) return Boolean
8854 Expr : constant Node_Id := Expression (Parent (Obj_Id));
8858 Is_Class_Wide_Type (Etype (Obj_Id))
8859 and then Present (Expr)
8860 and then Nkind (Expr) = N_Unchecked_Type_Conversion
8861 and then Etype (Expression (Expr)) = RTE (RE_Tag);
8862 end Is_Tag_To_Class_Wide_Conversion;
8864 ----------------------------
8865 -- Is_Untagged_Derivation --
8866 ----------------------------
8868 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
8870 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
8872 (Is_Private_Type (T) and then Present (Full_View (T))
8873 and then not Is_Tagged_Type (Full_View (T))
8874 and then Is_Derived_Type (Full_View (T))
8875 and then Etype (Full_View (T)) /= T);
8876 end Is_Untagged_Derivation;
8878 ------------------------------------
8879 -- Is_Untagged_Private_Derivation --
8880 ------------------------------------
8882 function Is_Untagged_Private_Derivation
8883 (Priv_Typ : Entity_Id;
8884 Full_Typ : Entity_Id) return Boolean
8889 and then Is_Untagged_Derivation (Priv_Typ)
8890 and then Is_Private_Type (Etype (Priv_Typ))
8891 and then Present (Full_Typ)
8892 and then Is_Itype (Full_Typ);
8893 end Is_Untagged_Private_Derivation;
8895 ------------------------------
8896 -- Is_Verifiable_DIC_Pragma --
8897 ------------------------------
8899 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
8900 Args : constant List_Id := Pragma_Argument_Associations (Prag);
8903 -- To qualify as verifiable, a DIC pragma must have a non-null argument
8907 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
8908 end Is_Verifiable_DIC_Pragma;
8910 ---------------------------
8911 -- Is_Volatile_Reference --
8912 ---------------------------
8914 function Is_Volatile_Reference (N : Node_Id) return Boolean is
8916 -- Only source references are to be treated as volatile, internally
8917 -- generated stuff cannot have volatile external effects.
8919 if not Comes_From_Source (N) then
8922 -- Never true for reference to a type
8924 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
8927 -- Never true for a compile time known constant
8929 elsif Compile_Time_Known_Value (N) then
8932 -- True if object reference with volatile type
8934 elsif Is_Volatile_Object (N) then
8937 -- True if reference to volatile entity
8939 elsif Is_Entity_Name (N) then
8940 return Treat_As_Volatile (Entity (N));
8942 -- True for slice of volatile array
8944 elsif Nkind (N) = N_Slice then
8945 return Is_Volatile_Reference (Prefix (N));
8947 -- True if volatile component
8949 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8950 if (Is_Entity_Name (Prefix (N))
8951 and then Has_Volatile_Components (Entity (Prefix (N))))
8952 or else (Present (Etype (Prefix (N)))
8953 and then Has_Volatile_Components (Etype (Prefix (N))))
8957 return Is_Volatile_Reference (Prefix (N));
8965 end Is_Volatile_Reference;
8967 --------------------
8968 -- Kill_Dead_Code --
8969 --------------------
8971 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
8972 W : Boolean := Warn;
8973 -- Set False if warnings suppressed
8977 Remove_Warning_Messages (N);
8979 -- Update the internal structures of the ABE mechanism in case the
8980 -- dead node is an elaboration scenario.
8982 Kill_Elaboration_Scenario (N);
8984 -- Generate warning if appropriate
8988 -- We suppress the warning if this code is under control of an
8989 -- if statement, whose condition is a simple identifier, and
8990 -- either we are in an instance, or warnings off is set for this
8991 -- identifier. The reason for killing it in the instance case is
8992 -- that it is common and reasonable for code to be deleted in
8993 -- instances for various reasons.
8995 -- Could we use Is_Statically_Unevaluated here???
8997 if Nkind (Parent (N)) = N_If_Statement then
8999 C : constant Node_Id := Condition (Parent (N));
9001 if Nkind (C) = N_Identifier
9004 or else (Present (Entity (C))
9005 and then Has_Warnings_Off (Entity (C))))
9012 -- Generate warning if not suppressed
9016 ("?t?this code can never be executed and has been deleted!",
9021 -- Recurse into block statements and bodies to process declarations
9024 if Nkind (N) = N_Block_Statement
9025 or else Nkind (N) = N_Subprogram_Body
9026 or else Nkind (N) = N_Package_Body
9028 Kill_Dead_Code (Declarations (N), False);
9029 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
9031 if Nkind (N) = N_Subprogram_Body then
9032 Set_Is_Eliminated (Defining_Entity (N));
9035 elsif Nkind (N) = N_Package_Declaration then
9036 Kill_Dead_Code (Visible_Declarations (Specification (N)));
9037 Kill_Dead_Code (Private_Declarations (Specification (N)));
9039 -- ??? After this point, Delete_Tree has been called on all
9040 -- declarations in Specification (N), so references to entities
9041 -- therein look suspicious.
9044 E : Entity_Id := First_Entity (Defining_Entity (N));
9047 while Present (E) loop
9048 if Ekind (E) = E_Operator then
9049 Set_Is_Eliminated (E);
9056 -- Recurse into composite statement to kill individual statements in
9057 -- particular instantiations.
9059 elsif Nkind (N) = N_If_Statement then
9060 Kill_Dead_Code (Then_Statements (N));
9061 Kill_Dead_Code (Elsif_Parts (N));
9062 Kill_Dead_Code (Else_Statements (N));
9064 elsif Nkind (N) = N_Loop_Statement then
9065 Kill_Dead_Code (Statements (N));
9067 elsif Nkind (N) = N_Case_Statement then
9071 Alt := First (Alternatives (N));
9072 while Present (Alt) loop
9073 Kill_Dead_Code (Statements (Alt));
9078 elsif Nkind (N) = N_Case_Statement_Alternative then
9079 Kill_Dead_Code (Statements (N));
9081 -- Deal with dead instances caused by deleting instantiations
9083 elsif Nkind (N) in N_Generic_Instantiation then
9084 Remove_Dead_Instance (N);
9089 -- Case where argument is a list of nodes to be killed
9091 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
9098 if Is_Non_Empty_List (L) then
9100 while Present (N) loop
9101 Kill_Dead_Code (N, W);
9108 ------------------------
9109 -- Known_Non_Negative --
9110 ------------------------
9112 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
9114 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
9119 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
9122 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
9125 end Known_Non_Negative;
9127 -----------------------------
9128 -- Make_CW_Equivalent_Type --
9129 -----------------------------
9131 -- Create a record type used as an equivalent of any member of the class
9132 -- which takes its size from exp.
9134 -- Generate the following code:
9136 -- type Equiv_T is record
9137 -- _parent : T (List of discriminant constraints taken from Exp);
9138 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
9141 -- ??? Note that this type does not guarantee same alignment as all
9144 -- Note: for the freezing circuitry, this looks like a record extension,
9145 -- and so we need to make sure that the scalar storage order is the same
9146 -- as that of the parent type. (This does not change anything for the
9147 -- representation of the extension part.)
9149 function Make_CW_Equivalent_Type
9151 E : Node_Id) return Entity_Id
9153 Loc : constant Source_Ptr := Sloc (E);
9154 Root_Typ : constant Entity_Id := Root_Type (T);
9155 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
9156 List_Def : constant List_Id := Empty_List;
9157 Comp_List : constant List_Id := New_List;
9158 Equiv_Type : Entity_Id;
9159 Range_Type : Entity_Id;
9160 Str_Type : Entity_Id;
9161 Constr_Root : Entity_Id;
9165 -- If the root type is already constrained, there are no discriminants
9166 -- in the expression.
9168 if not Has_Discriminants (Root_Typ)
9169 or else Is_Constrained (Root_Typ)
9171 Constr_Root := Root_Typ;
9173 -- At this point in the expansion, nonlimited view of the type
9174 -- must be available, otherwise the error will be reported later.
9176 if From_Limited_With (Constr_Root)
9177 and then Present (Non_Limited_View (Constr_Root))
9179 Constr_Root := Non_Limited_View (Constr_Root);
9183 Constr_Root := Make_Temporary (Loc, 'R');
9185 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9187 Append_To (List_Def,
9188 Make_Subtype_Declaration (Loc,
9189 Defining_Identifier => Constr_Root,
9190 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9193 -- Generate the range subtype declaration
9195 Range_Type := Make_Temporary (Loc, 'G');
9197 if not Is_Interface (Root_Typ) then
9199 -- subtype rg__xx is
9200 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
9203 Make_Op_Subtract (Loc,
9205 Make_Attribute_Reference (Loc,
9207 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9208 Attribute_Name => Name_Size),
9210 Make_Attribute_Reference (Loc,
9211 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9212 Attribute_Name => Name_Object_Size));
9214 -- subtype rg__xx is
9215 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
9218 Make_Attribute_Reference (Loc,
9220 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9221 Attribute_Name => Name_Size);
9224 Set_Paren_Count (Sizexpr, 1);
9226 Append_To (List_Def,
9227 Make_Subtype_Declaration (Loc,
9228 Defining_Identifier => Range_Type,
9229 Subtype_Indication =>
9230 Make_Subtype_Indication (Loc,
9231 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9232 Constraint => Make_Range_Constraint (Loc,
9235 Low_Bound => Make_Integer_Literal (Loc, 1),
9237 Make_Op_Divide (Loc,
9238 Left_Opnd => Sizexpr,
9239 Right_Opnd => Make_Integer_Literal (Loc,
9240 Intval => System_Storage_Unit)))))));
9242 -- subtype str__nn is Storage_Array (rg__x);
9244 Str_Type := Make_Temporary (Loc, 'S');
9245 Append_To (List_Def,
9246 Make_Subtype_Declaration (Loc,
9247 Defining_Identifier => Str_Type,
9248 Subtype_Indication =>
9249 Make_Subtype_Indication (Loc,
9250 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9252 Make_Index_Or_Discriminant_Constraint (Loc,
9254 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9256 -- type Equiv_T is record
9257 -- [ _parent : Tnn; ]
9261 Equiv_Type := Make_Temporary (Loc, 'T');
9262 Set_Ekind (Equiv_Type, E_Record_Type);
9263 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9265 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9266 -- treatment for this type. In particular, even though _parent's type
9267 -- is a controlled type or contains controlled components, we do not
9268 -- want to set Has_Controlled_Component on it to avoid making it gain
9269 -- an unwanted _controller component.
9271 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9273 -- A class-wide equivalent type does not require initialization
9275 Set_Suppress_Initialization (Equiv_Type);
9277 if not Is_Interface (Root_Typ) then
9278 Append_To (Comp_List,
9279 Make_Component_Declaration (Loc,
9280 Defining_Identifier =>
9281 Make_Defining_Identifier (Loc, Name_uParent),
9282 Component_Definition =>
9283 Make_Component_Definition (Loc,
9284 Aliased_Present => False,
9285 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9287 Set_Reverse_Storage_Order
9288 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
9289 Set_Reverse_Bit_Order
9290 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
9293 Append_To (Comp_List,
9294 Make_Component_Declaration (Loc,
9295 Defining_Identifier => Make_Temporary (Loc, 'C'),
9296 Component_Definition =>
9297 Make_Component_Definition (Loc,
9298 Aliased_Present => False,
9299 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9301 Append_To (List_Def,
9302 Make_Full_Type_Declaration (Loc,
9303 Defining_Identifier => Equiv_Type,
9305 Make_Record_Definition (Loc,
9307 Make_Component_List (Loc,
9308 Component_Items => Comp_List,
9309 Variant_Part => Empty))));
9311 -- Suppress all checks during the analysis of the expanded code to avoid
9312 -- the generation of spurious warnings under ZFP run-time.
9314 Insert_Actions (E, List_Def, Suppress => All_Checks);
9316 end Make_CW_Equivalent_Type;
9318 -------------------------
9319 -- Make_Invariant_Call --
9320 -------------------------
9322 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9323 Loc : constant Source_Ptr := Sloc (Expr);
9324 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9326 Proc_Id : Entity_Id;
9329 pragma Assert (Has_Invariants (Typ));
9331 Proc_Id := Invariant_Procedure (Typ);
9332 pragma Assert (Present (Proc_Id));
9334 -- Ignore the invariant if that policy is in effect
9336 if Invariants_Ignored (Typ) then
9337 return Make_Null_Statement (Loc);
9340 Make_Procedure_Call_Statement (Loc,
9341 Name => New_Occurrence_Of (Proc_Id, Loc),
9342 Parameter_Associations => New_List (Relocate_Node (Expr)));
9344 end Make_Invariant_Call;
9346 ------------------------
9347 -- Make_Literal_Range --
9348 ------------------------
9350 function Make_Literal_Range
9352 Literal_Typ : Entity_Id) return Node_Id
9354 Lo : constant Node_Id :=
9355 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9356 Index : constant Entity_Id := Etype (Lo);
9357 Length_Expr : constant Node_Id :=
9358 Make_Op_Subtract (Loc,
9360 Make_Integer_Literal (Loc,
9361 Intval => String_Literal_Length (Literal_Typ)),
9362 Right_Opnd => Make_Integer_Literal (Loc, 1));
9367 Set_Analyzed (Lo, False);
9369 if Is_Integer_Type (Index) then
9372 Left_Opnd => New_Copy_Tree (Lo),
9373 Right_Opnd => Length_Expr);
9376 Make_Attribute_Reference (Loc,
9377 Attribute_Name => Name_Val,
9378 Prefix => New_Occurrence_Of (Index, Loc),
9379 Expressions => New_List (
9382 Make_Attribute_Reference (Loc,
9383 Attribute_Name => Name_Pos,
9384 Prefix => New_Occurrence_Of (Index, Loc),
9385 Expressions => New_List (New_Copy_Tree (Lo))),
9386 Right_Opnd => Length_Expr)));
9393 end Make_Literal_Range;
9395 --------------------------
9396 -- Make_Non_Empty_Check --
9397 --------------------------
9399 function Make_Non_Empty_Check
9401 N : Node_Id) return Node_Id
9407 Make_Attribute_Reference (Loc,
9408 Attribute_Name => Name_Length,
9409 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9411 Make_Integer_Literal (Loc, 0));
9412 end Make_Non_Empty_Check;
9414 -------------------------
9415 -- Make_Predicate_Call --
9416 -------------------------
9418 -- WARNING: This routine manages Ghost regions. Return statements must be
9419 -- replaced by gotos which jump to the end of the routine and restore the
9422 function Make_Predicate_Call
9425 Mem : Boolean := False) return Node_Id
9427 Loc : constant Source_Ptr := Sloc (Expr);
9429 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9430 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9431 -- Save the Ghost-related attributes to restore on exit
9434 Func_Id : Entity_Id;
9437 Func_Id := Predicate_Function (Typ);
9438 pragma Assert (Present (Func_Id));
9440 -- The related type may be subject to pragma Ghost. Set the mode now to
9441 -- ensure that the call is properly marked as Ghost.
9443 Set_Ghost_Mode (Typ);
9445 -- Call special membership version if requested and available
9447 if Mem and then Present (Predicate_Function_M (Typ)) then
9448 Func_Id := Predicate_Function_M (Typ);
9451 -- Case of calling normal predicate function
9453 -- If the type is tagged, the expression may be class-wide, in which
9454 -- case it has to be converted to its root type, given that the
9455 -- generated predicate function is not dispatching. The conversion is
9456 -- type-safe and does not need validation, which matters when private
9457 -- extensions are involved.
9459 if Is_Tagged_Type (Typ) then
9461 Make_Function_Call (Loc,
9462 Name => New_Occurrence_Of (Func_Id, Loc),
9463 Parameter_Associations =>
9464 New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
9467 Make_Function_Call (Loc,
9468 Name => New_Occurrence_Of (Func_Id, Loc),
9469 Parameter_Associations => New_List (Relocate_Node (Expr)));
9472 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9475 end Make_Predicate_Call;
9477 --------------------------
9478 -- Make_Predicate_Check --
9479 --------------------------
9481 function Make_Predicate_Check
9483 Expr : Node_Id) return Node_Id
9485 Loc : constant Source_Ptr := Sloc (Expr);
9487 procedure Add_Failure_Expression (Args : List_Id);
9488 -- Add the failure expression of pragma Predicate_Failure (if any) to
9491 ----------------------------
9492 -- Add_Failure_Expression --
9493 ----------------------------
9495 procedure Add_Failure_Expression (Args : List_Id) is
9496 function Failure_Expression return Node_Id;
9497 pragma Inline (Failure_Expression);
9498 -- Find aspect or pragma Predicate_Failure that applies to type Typ
9499 -- and return its expression. Return Empty if no such annotation is
9502 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
9503 pragma Inline (Is_OK_PF_Aspect);
9504 -- Determine whether aspect Asp is a suitable Predicate_Failure
9505 -- aspect that applies to type Typ.
9507 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
9508 pragma Inline (Is_OK_PF_Pragma);
9509 -- Determine whether pragma Prag is a suitable Predicate_Failure
9510 -- pragma that applies to type Typ.
9512 procedure Replace_Subtype_Reference (N : Node_Id);
9513 -- Replace the current instance of type Typ denoted by N with
9516 ------------------------
9517 -- Failure_Expression --
9518 ------------------------
9520 function Failure_Expression return Node_Id is
9524 -- The management of the rep item chain involves "inheritance" of
9525 -- parent type chains. If a parent [sub]type is already subject to
9526 -- pragma Predicate_Failure, then the pragma will also appear in
9527 -- the chain of the child [sub]type, which in turn may possess a
9528 -- pragma of its own. Avoid order-dependent issues by inspecting
9529 -- the rep item chain directly. Note that routine Get_Pragma may
9530 -- return a parent pragma.
9532 Item := First_Rep_Item (Typ);
9533 while Present (Item) loop
9535 -- Predicate_Failure appears as an aspect
9537 if Nkind (Item) = N_Aspect_Specification
9538 and then Is_OK_PF_Aspect (Item)
9540 return Expression (Item);
9542 -- Predicate_Failure appears as a pragma
9544 elsif Nkind (Item) = N_Pragma
9545 and then Is_OK_PF_Pragma (Item)
9549 (Next (First (Pragma_Argument_Associations (Item))));
9552 Next_Rep_Item (Item);
9556 end Failure_Expression;
9558 ---------------------
9559 -- Is_OK_PF_Aspect --
9560 ---------------------
9562 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
9564 -- To qualify, the aspect must apply to the type subjected to the
9568 Chars (Identifier (Asp)) = Name_Predicate_Failure
9569 and then Present (Entity (Asp))
9570 and then Entity (Asp) = Typ;
9571 end Is_OK_PF_Aspect;
9573 ---------------------
9574 -- Is_OK_PF_Pragma --
9575 ---------------------
9577 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
9578 Args : constant List_Id := Pragma_Argument_Associations (Prag);
9582 -- Nothing to do when the pragma does not denote Predicate_Failure
9584 if Pragma_Name (Prag) /= Name_Predicate_Failure then
9587 -- Nothing to do when the pragma lacks arguments, in which case it
9590 elsif No (Args) or else Is_Empty_List (Args) then
9594 Typ_Arg := Get_Pragma_Arg (First (Args));
9596 -- To qualify, the local name argument of the pragma must denote
9597 -- the type subjected to the predicate check.
9600 Is_Entity_Name (Typ_Arg)
9601 and then Present (Entity (Typ_Arg))
9602 and then Entity (Typ_Arg) = Typ;
9603 end Is_OK_PF_Pragma;
9605 --------------------------------
9606 -- Replace_Subtype_Reference --
9607 --------------------------------
9609 procedure Replace_Subtype_Reference (N : Node_Id) is
9611 Rewrite (N, New_Copy_Tree (Expr));
9612 end Replace_Subtype_Reference;
9614 procedure Replace_Subtype_References is
9615 new Replace_Type_References_Generic (Replace_Subtype_Reference);
9619 PF_Expr : constant Node_Id := Failure_Expression;
9622 -- Start of processing for Add_Failure_Expression
9625 if Present (PF_Expr) then
9627 -- Replace any occurrences of the current instance of the type
9628 -- with the object subjected to the predicate check.
9630 Expr := New_Copy_Tree (PF_Expr);
9631 Replace_Subtype_References (Expr, Typ);
9633 -- The failure expression appears as the third argument of the
9637 Make_Pragma_Argument_Association (Loc,
9638 Expression => Expr));
9640 end Add_Failure_Expression;
9647 -- Start of processing for Make_Predicate_Check
9650 -- If predicate checks are suppressed, then return a null statement. For
9651 -- this call, we check only the scope setting. If the caller wants to
9652 -- check a specific entity's setting, they must do it manually.
9654 if Predicate_Checks_Suppressed (Empty) then
9655 return Make_Null_Statement (Loc);
9658 -- Do not generate a check within an internal subprogram (stream
9659 -- functions and the like, including predicate functions).
9661 if Within_Internal_Subprogram then
9662 return Make_Null_Statement (Loc);
9665 -- Compute proper name to use, we need to get this right so that the
9666 -- right set of check policies apply to the Check pragma we are making.
9668 if Has_Dynamic_Predicate_Aspect (Typ) then
9669 Nam := Name_Dynamic_Predicate;
9670 elsif Has_Static_Predicate_Aspect (Typ) then
9671 Nam := Name_Static_Predicate;
9673 Nam := Name_Predicate;
9677 Make_Pragma_Argument_Association (Loc,
9678 Expression => Make_Identifier (Loc, Nam)),
9679 Make_Pragma_Argument_Association (Loc,
9680 Expression => Make_Predicate_Call (Typ, Expr)));
9682 -- If the subtype is subject to pragma Predicate_Failure, add the
9683 -- failure expression as an additional parameter.
9685 Add_Failure_Expression (Args);
9689 Chars => Name_Check,
9690 Pragma_Argument_Associations => Args);
9691 end Make_Predicate_Check;
9693 ----------------------------
9694 -- Make_Subtype_From_Expr --
9695 ----------------------------
9697 -- 1. If Expr is an unconstrained array expression, creates
9698 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
9700 -- 2. If Expr is a unconstrained discriminated type expression, creates
9701 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
9703 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
9705 function Make_Subtype_From_Expr
9707 Unc_Typ : Entity_Id;
9708 Related_Id : Entity_Id := Empty) return Node_Id
9710 List_Constr : constant List_Id := New_List;
9711 Loc : constant Source_Ptr := Sloc (E);
9714 Full_Subtyp : Entity_Id;
9715 High_Bound : Entity_Id;
9716 Index_Typ : Entity_Id;
9717 Low_Bound : Entity_Id;
9718 Priv_Subtyp : Entity_Id;
9722 if Is_Private_Type (Unc_Typ)
9723 and then Has_Unknown_Discriminants (Unc_Typ)
9725 -- The caller requests a unique external name for both the private
9726 -- and the full subtype.
9728 if Present (Related_Id) then
9730 Make_Defining_Identifier (Loc,
9731 Chars => New_External_Name (Chars (Related_Id), 'C'));
9733 Make_Defining_Identifier (Loc,
9734 Chars => New_External_Name (Chars (Related_Id), 'P'));
9737 Full_Subtyp := Make_Temporary (Loc, 'C');
9738 Priv_Subtyp := Make_Temporary (Loc, 'P');
9741 -- Prepare the subtype completion. Use the base type to find the
9742 -- underlying type because the type may be a generic actual or an
9743 -- explicit subtype.
9745 Utyp := Underlying_Type (Base_Type (Unc_Typ));
9748 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
9749 Set_Parent (Full_Exp, Parent (E));
9752 Make_Subtype_Declaration (Loc,
9753 Defining_Identifier => Full_Subtyp,
9754 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
9756 -- Define the dummy private subtype
9758 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
9759 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
9760 Set_Scope (Priv_Subtyp, Full_Subtyp);
9761 Set_Is_Constrained (Priv_Subtyp);
9762 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
9763 Set_Is_Itype (Priv_Subtyp);
9764 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
9766 if Is_Tagged_Type (Priv_Subtyp) then
9768 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
9769 Set_Direct_Primitive_Operations (Priv_Subtyp,
9770 Direct_Primitive_Operations (Unc_Typ));
9773 Set_Full_View (Priv_Subtyp, Full_Subtyp);
9775 return New_Occurrence_Of (Priv_Subtyp, Loc);
9777 elsif Is_Array_Type (Unc_Typ) then
9778 Index_Typ := First_Index (Unc_Typ);
9779 for J in 1 .. Number_Dimensions (Unc_Typ) loop
9781 -- Capture the bounds of each index constraint in case the context
9782 -- is an object declaration of an unconstrained type initialized
9783 -- by a function call:
9785 -- Obj : Unconstr_Typ := Func_Call;
9787 -- This scenario requires secondary scope management and the index
9788 -- constraint cannot depend on the temporary used to capture the
9789 -- result of the function call.
9792 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
9793 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
9794 -- Obj : S := Temp.all;
9795 -- SS_Release; -- Temp is gone at this point, bounds of S are
9799 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
9801 Low_Bound := Make_Temporary (Loc, 'B');
9803 Make_Object_Declaration (Loc,
9804 Defining_Identifier => Low_Bound,
9805 Object_Definition =>
9806 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
9807 Constant_Present => True,
9809 Make_Attribute_Reference (Loc,
9810 Prefix => Duplicate_Subexpr_No_Checks (E),
9811 Attribute_Name => Name_First,
9812 Expressions => New_List (
9813 Make_Integer_Literal (Loc, J)))));
9816 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
9818 High_Bound := Make_Temporary (Loc, 'B');
9820 Make_Object_Declaration (Loc,
9821 Defining_Identifier => High_Bound,
9822 Object_Definition =>
9823 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
9824 Constant_Present => True,
9826 Make_Attribute_Reference (Loc,
9827 Prefix => Duplicate_Subexpr_No_Checks (E),
9828 Attribute_Name => Name_Last,
9829 Expressions => New_List (
9830 Make_Integer_Literal (Loc, J)))));
9832 Append_To (List_Constr,
9834 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
9835 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
9837 Next_Index (Index_Typ);
9840 elsif Is_Class_Wide_Type (Unc_Typ) then
9842 CW_Subtype : Entity_Id;
9843 EQ_Typ : Entity_Id := Empty;
9846 -- A class-wide equivalent type is not needed on VM targets
9847 -- because the VM back-ends handle the class-wide object
9848 -- initialization itself (and doesn't need or want the
9849 -- additional intermediate type to handle the assignment).
9851 if Expander_Active and then Tagged_Type_Expansion then
9853 -- If this is the class-wide type of a completion that is a
9854 -- record subtype, set the type of the class-wide type to be
9855 -- the full base type, for use in the expanded code for the
9856 -- equivalent type. Should this be done earlier when the
9857 -- completion is analyzed ???
9859 if Is_Private_Type (Etype (Unc_Typ))
9861 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
9863 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
9866 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
9869 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
9870 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
9871 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
9873 return New_Occurrence_Of (CW_Subtype, Loc);
9876 -- Indefinite record type with discriminants
9879 D := First_Discriminant (Unc_Typ);
9880 while Present (D) loop
9881 Append_To (List_Constr,
9882 Make_Selected_Component (Loc,
9883 Prefix => Duplicate_Subexpr_No_Checks (E),
9884 Selector_Name => New_Occurrence_Of (D, Loc)));
9886 Next_Discriminant (D);
9891 Make_Subtype_Indication (Loc,
9892 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
9894 Make_Index_Or_Discriminant_Constraint (Loc,
9895 Constraints => List_Constr));
9896 end Make_Subtype_From_Expr;
9902 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
9904 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
9905 -- avoid deep indentation of code.
9907 -- NOTE: Routines which deal with discriminant mapping operate on the
9908 -- [underlying/record] full view of various types because those views
9909 -- contain all discriminants and stored constraints.
9911 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
9912 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
9913 -- overriding chain starting from Prim whose dispatching type is parent
9914 -- type Par_Typ and add a mapping between the result and primitive Prim.
9916 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
9917 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
9918 -- the inheritance or overriding chain of subprogram Subp. Return Empty
9919 -- if no such primitive is available.
9921 function Build_Chain
9922 (Par_Typ : Entity_Id;
9923 Deriv_Typ : Entity_Id) return Elist_Id;
9924 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
9925 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
9926 -- list has the form:
9930 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
9932 -- Note that Par_Typ is not part of the resulting derivation chain
9934 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
9935 -- Return the view of type Typ which could potentially contains either
9936 -- the discriminants or stored constraints of the type.
9938 function Find_Discriminant_Value
9940 Par_Typ : Entity_Id;
9941 Deriv_Typ : Entity_Id;
9942 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
9943 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
9944 -- in the derivation chain starting from parent type Par_Typ leading to
9945 -- derived type Deriv_Typ. The returned value is one of the following:
9947 -- * An entity which is either a discriminant or a nondiscriminant
9948 -- name, and renames/constraints Discr.
9950 -- * An expression which constraints Discr
9952 -- Typ_Elmt is an element of the derivation chain created by routine
9953 -- Build_Chain and denotes the current ancestor being examined.
9955 procedure Map_Discriminants
9956 (Par_Typ : Entity_Id;
9957 Deriv_Typ : Entity_Id);
9958 -- Map each discriminant of type Par_Typ to a meaningful constraint
9959 -- from the point of view of type Deriv_Typ.
9961 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
9962 -- Map each primitive of type Par_Typ to a corresponding primitive of
9969 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
9970 Par_Prim : Entity_Id;
9973 -- Inspect the inheritance chain through the Alias attribute and the
9974 -- overriding chain through the Overridden_Operation looking for an
9975 -- ancestor primitive with the appropriate dispatching type.
9978 while Present (Par_Prim) loop
9979 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
9980 Par_Prim := Ancestor_Primitive (Par_Prim);
9983 -- Create a mapping of the form:
9985 -- parent type primitive -> derived type primitive
9987 if Present (Par_Prim) then
9988 Type_Map.Set (Par_Prim, Prim);
9992 ------------------------
9993 -- Ancestor_Primitive --
9994 ------------------------
9996 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
9997 Inher_Prim : constant Entity_Id := Alias (Subp);
9998 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
10001 -- The current subprogram overrides an ancestor primitive
10003 if Present (Over_Prim) then
10006 -- The current subprogram is an internally generated alias of an
10007 -- inherited ancestor primitive.
10009 elsif Present (Inher_Prim) then
10012 -- Otherwise the current subprogram is the root of the inheritance or
10013 -- overriding chain.
10018 end Ancestor_Primitive;
10024 function Build_Chain
10025 (Par_Typ : Entity_Id;
10026 Deriv_Typ : Entity_Id) return Elist_Id
10028 Anc_Typ : Entity_Id;
10030 Curr_Typ : Entity_Id;
10033 Chain := New_Elmt_List;
10035 -- Add the derived type to the derivation chain
10037 Prepend_Elmt (Deriv_Typ, Chain);
10039 -- Examine all ancestors starting from the derived type climbing
10040 -- towards parent type Par_Typ.
10042 Curr_Typ := Deriv_Typ;
10044 -- Handle the case where the current type is a record which
10045 -- derives from a subtype.
10047 -- subtype Sub_Typ is Par_Typ ...
10048 -- type Deriv_Typ is Sub_Typ ...
10050 if Ekind (Curr_Typ) = E_Record_Type
10051 and then Present (Parent_Subtype (Curr_Typ))
10053 Anc_Typ := Parent_Subtype (Curr_Typ);
10055 -- Handle the case where the current type is a record subtype of
10056 -- another subtype.
10058 -- subtype Sub_Typ1 is Par_Typ ...
10059 -- subtype Sub_Typ2 is Sub_Typ1 ...
10061 elsif Ekind (Curr_Typ) = E_Record_Subtype
10062 and then Present (Cloned_Subtype (Curr_Typ))
10064 Anc_Typ := Cloned_Subtype (Curr_Typ);
10066 -- Otherwise use the direct parent type
10069 Anc_Typ := Etype (Curr_Typ);
10072 -- Use the first subtype when dealing with itypes
10074 if Is_Itype (Anc_Typ) then
10075 Anc_Typ := First_Subtype (Anc_Typ);
10078 -- Work with the view which contains the discriminants and stored
10081 Anc_Typ := Discriminated_View (Anc_Typ);
10083 -- Stop the climb when either the parent type has been reached or
10084 -- there are no more ancestors left to examine.
10086 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
10088 Prepend_Unique_Elmt (Anc_Typ, Chain);
10089 Curr_Typ := Anc_Typ;
10095 ------------------------
10096 -- Discriminated_View --
10097 ------------------------
10099 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
10105 -- Use the [underlying] full view when dealing with private types
10106 -- because the view contains all inherited discriminants or stored
10109 if Is_Private_Type (T) then
10110 if Present (Underlying_Full_View (T)) then
10111 T := Underlying_Full_View (T);
10113 elsif Present (Full_View (T)) then
10114 T := Full_View (T);
10118 -- Use the underlying record view when the type is an extenstion of
10119 -- a parent type with unknown discriminants because the view contains
10120 -- all inherited discriminants or stored constraints.
10122 if Ekind (T) = E_Record_Type
10123 and then Present (Underlying_Record_View (T))
10125 T := Underlying_Record_View (T);
10129 end Discriminated_View;
10131 -----------------------------
10132 -- Find_Discriminant_Value --
10133 -----------------------------
10135 function Find_Discriminant_Value
10136 (Discr : Entity_Id;
10137 Par_Typ : Entity_Id;
10138 Deriv_Typ : Entity_Id;
10139 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
10141 Discr_Pos : constant Uint := Discriminant_Number (Discr);
10142 Typ : constant Entity_Id := Node (Typ_Elmt);
10144 function Find_Constraint_Value
10145 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
10146 -- Given constraint Constr, find what it denotes. This is either:
10148 -- * An entity which is either a discriminant or a name
10152 ---------------------------
10153 -- Find_Constraint_Value --
10154 ---------------------------
10156 function Find_Constraint_Value
10157 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
10160 if Nkind (Constr) in N_Entity then
10162 -- The constraint denotes a discriminant of the curren type
10163 -- which renames the ancestor discriminant:
10166 -- type Typ (D1 : ...; DN : ...) is
10167 -- new Anc (Discr => D1) with ...
10170 if Ekind (Constr) = E_Discriminant then
10172 -- The discriminant belongs to derived type Deriv_Typ. This
10173 -- is the final value for the ancestor discriminant as the
10174 -- derivations chain has been fully exhausted.
10176 if Typ = Deriv_Typ then
10179 -- Otherwise the discriminant may be renamed or constrained
10180 -- at a lower level. Continue looking down the derivation
10185 Find_Discriminant_Value
10187 Par_Typ => Par_Typ,
10188 Deriv_Typ => Deriv_Typ,
10189 Typ_Elmt => Next_Elmt (Typ_Elmt));
10192 -- Otherwise the constraint denotes a reference to some name
10193 -- which results in a Girder discriminant:
10197 -- type Typ (D1 : ...; DN : ...) is
10198 -- new Anc (Discr => Name) with ...
10201 -- Return the name as this is the proper constraint of the
10208 -- The constraint denotes a reference to a name
10210 elsif Is_Entity_Name (Constr) then
10211 return Find_Constraint_Value (Entity (Constr));
10213 -- Otherwise the current constraint is an expression which yields
10214 -- a Girder discriminant:
10216 -- type Typ (D1 : ...; DN : ...) is
10217 -- new Anc (Discr => <expression>) with ...
10220 -- Return the expression as this is the proper constraint of the
10226 end Find_Constraint_Value;
10230 Constrs : constant Elist_Id := Stored_Constraint (Typ);
10232 Constr_Elmt : Elmt_Id;
10234 Typ_Discr : Entity_Id;
10236 -- Start of processing for Find_Discriminant_Value
10239 -- The algorithm for finding the value of a discriminant works as
10240 -- follows. First, it recreates the derivation chain from Par_Typ
10241 -- to Deriv_Typ as a list:
10243 -- Par_Typ (shown for completeness)
10245 -- Ancestor_N <-- head of chain
10249 -- Deriv_Typ <-- tail of chain
10251 -- The algorithm then traces the fate of a parent discriminant down
10252 -- the derivation chain. At each derivation level, the discriminant
10253 -- may be either inherited or constrained.
10255 -- 1) Discriminant is inherited: there are two cases, depending on
10256 -- which type is inheriting.
10258 -- 1.1) Deriv_Typ is inheriting:
10260 -- type Ancestor (D_1 : ...) is tagged ...
10261 -- type Deriv_Typ is new Ancestor ...
10263 -- In this case the inherited discriminant is the final value of
10264 -- the parent discriminant because the end of the derivation chain
10265 -- has been reached.
10267 -- 1.2) Some other type is inheriting:
10269 -- type Ancestor_1 (D_1 : ...) is tagged ...
10270 -- type Ancestor_2 is new Ancestor_1 ...
10272 -- In this case the algorithm continues to trace the fate of the
10273 -- inherited discriminant down the derivation chain because it may
10274 -- be further inherited or constrained.
10276 -- 2) Discriminant is constrained: there are three cases, depending
10277 -- on what the constraint is.
10279 -- 2.1) The constraint is another discriminant (aka renaming):
10281 -- type Ancestor_1 (D_1 : ...) is tagged ...
10282 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
10284 -- In this case the constraining discriminant becomes the one to
10285 -- track down the derivation chain. The algorithm already knows
10286 -- that D_2 constrains D_1, therefore if the algorithm finds the
10287 -- value of D_2, then this would also be the value for D_1.
10289 -- 2.2) The constraint is a name (aka Girder):
10292 -- type Ancestor_1 (D_1 : ...) is tagged ...
10293 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
10295 -- In this case the name is the final value of D_1 because the
10296 -- discriminant cannot be further constrained.
10298 -- 2.3) The constraint is an expression (aka Girder):
10300 -- type Ancestor_1 (D_1 : ...) is tagged ...
10301 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10303 -- Similar to 2.2, the expression is the final value of D_1
10307 -- When a derived type constrains its parent type, all constaints
10308 -- appear in the Stored_Constraint list. Examine the list looking
10309 -- for a positional match.
10311 if Present (Constrs) then
10312 Constr_Elmt := First_Elmt (Constrs);
10313 while Present (Constr_Elmt) loop
10315 -- The position of the current constraint matches that of the
10316 -- ancestor discriminant.
10318 if Pos = Discr_Pos then
10319 return Find_Constraint_Value (Node (Constr_Elmt));
10322 Next_Elmt (Constr_Elmt);
10326 -- Otherwise the derived type does not constraint its parent type in
10327 -- which case it inherits the parent discriminants.
10330 Typ_Discr := First_Discriminant (Typ);
10331 while Present (Typ_Discr) loop
10333 -- The position of the current discriminant matches that of the
10334 -- ancestor discriminant.
10336 if Pos = Discr_Pos then
10337 return Find_Constraint_Value (Typ_Discr);
10340 Next_Discriminant (Typ_Discr);
10345 -- A discriminant must always have a corresponding value. This is
10346 -- either another discriminant, a name, or an expression. If this
10347 -- point is reached, them most likely the derivation chain employs
10348 -- the wrong views of types.
10350 pragma Assert (False);
10353 end Find_Discriminant_Value;
10355 -----------------------
10356 -- Map_Discriminants --
10357 -----------------------
10359 procedure Map_Discriminants
10360 (Par_Typ : Entity_Id;
10361 Deriv_Typ : Entity_Id)
10363 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10366 Discr_Val : Node_Or_Entity_Id;
10369 -- Examine each discriminant of parent type Par_Typ and find a
10370 -- suitable value for it from the point of view of derived type
10373 if Has_Discriminants (Par_Typ) then
10374 Discr := First_Discriminant (Par_Typ);
10375 while Present (Discr) loop
10377 Find_Discriminant_Value
10379 Par_Typ => Par_Typ,
10380 Deriv_Typ => Deriv_Typ,
10381 Typ_Elmt => First_Elmt (Deriv_Chain));
10383 -- Create a mapping of the form:
10385 -- parent type discriminant -> value
10387 Type_Map.Set (Discr, Discr_Val);
10389 Next_Discriminant (Discr);
10392 end Map_Discriminants;
10394 --------------------
10395 -- Map_Primitives --
10396 --------------------
10398 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
10399 Deriv_Prim : Entity_Id;
10400 Par_Prim : Entity_Id;
10401 Par_Prims : Elist_Id;
10402 Prim_Elmt : Elmt_Id;
10405 -- Inspect the primitives of the derived type and determine whether
10406 -- they relate to the primitives of the parent type. If there is a
10407 -- meaningful relation, create a mapping of the form:
10409 -- parent type primitive -> perived type primitive
10411 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
10412 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
10413 while Present (Prim_Elmt) loop
10414 Deriv_Prim := Node (Prim_Elmt);
10416 if Is_Subprogram (Deriv_Prim)
10417 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
10419 Add_Primitive (Deriv_Prim, Par_Typ);
10422 Next_Elmt (Prim_Elmt);
10426 -- If the parent operation is an interface operation, the overriding
10427 -- indicator is not present. Instead, we get from the interface
10428 -- operation the primitive of the current type that implements it.
10430 if Is_Interface (Par_Typ) then
10431 Par_Prims := Collect_Primitive_Operations (Par_Typ);
10433 if Present (Par_Prims) then
10434 Prim_Elmt := First_Elmt (Par_Prims);
10436 while Present (Prim_Elmt) loop
10437 Par_Prim := Node (Prim_Elmt);
10439 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
10441 if Present (Deriv_Prim) then
10442 Type_Map.Set (Par_Prim, Deriv_Prim);
10445 Next_Elmt (Prim_Elmt);
10449 end Map_Primitives;
10451 -- Start of processing for Map_Types
10454 -- Nothing to do if there are no types to work with
10456 if No (Parent_Type) or else No (Derived_Type) then
10459 -- Nothing to do if the mapping already exists
10461 elsif Type_Map.Get (Parent_Type) = Derived_Type then
10464 -- Nothing to do if both types are not tagged. Note that untagged types
10465 -- do not have primitive operations and their discriminants are already
10466 -- handled by gigi.
10468 elsif not Is_Tagged_Type (Parent_Type)
10469 or else not Is_Tagged_Type (Derived_Type)
10474 -- Create a mapping of the form
10476 -- parent type -> derived type
10478 -- to prevent any subsequent attempts to produce the same relations
10480 Type_Map.Set (Parent_Type, Derived_Type);
10482 -- Create mappings of the form
10484 -- parent type discriminant -> derived type discriminant
10486 -- parent type discriminant -> constraint
10488 -- Note that mapping of discriminants breaks privacy because it needs to
10489 -- work with those views which contains the discriminants and any stored
10493 (Par_Typ => Discriminated_View (Parent_Type),
10494 Deriv_Typ => Discriminated_View (Derived_Type));
10496 -- Create mappings of the form
10498 -- parent type primitive -> derived type primitive
10501 (Par_Typ => Parent_Type,
10502 Deriv_Typ => Derived_Type);
10505 ----------------------------
10506 -- Matching_Standard_Type --
10507 ----------------------------
10509 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
10510 pragma Assert (Is_Scalar_Type (Typ));
10511 Siz : constant Uint := Esize (Typ);
10514 -- Floating-point cases
10516 if Is_Floating_Point_Type (Typ) then
10517 if Siz <= Esize (Standard_Short_Float) then
10518 return Standard_Short_Float;
10519 elsif Siz <= Esize (Standard_Float) then
10520 return Standard_Float;
10521 elsif Siz <= Esize (Standard_Long_Float) then
10522 return Standard_Long_Float;
10523 elsif Siz <= Esize (Standard_Long_Long_Float) then
10524 return Standard_Long_Long_Float;
10526 raise Program_Error;
10529 -- Integer cases (includes fixed-point types)
10531 -- Unsigned integer cases (includes normal enumeration types)
10533 elsif Is_Unsigned_Type (Typ) then
10534 if Siz <= Esize (Standard_Short_Short_Unsigned) then
10535 return Standard_Short_Short_Unsigned;
10536 elsif Siz <= Esize (Standard_Short_Unsigned) then
10537 return Standard_Short_Unsigned;
10538 elsif Siz <= Esize (Standard_Unsigned) then
10539 return Standard_Unsigned;
10540 elsif Siz <= Esize (Standard_Long_Unsigned) then
10541 return Standard_Long_Unsigned;
10542 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
10543 return Standard_Long_Long_Unsigned;
10545 raise Program_Error;
10548 -- Signed integer cases
10551 if Siz <= Esize (Standard_Short_Short_Integer) then
10552 return Standard_Short_Short_Integer;
10553 elsif Siz <= Esize (Standard_Short_Integer) then
10554 return Standard_Short_Integer;
10555 elsif Siz <= Esize (Standard_Integer) then
10556 return Standard_Integer;
10557 elsif Siz <= Esize (Standard_Long_Integer) then
10558 return Standard_Long_Integer;
10559 elsif Siz <= Esize (Standard_Long_Long_Integer) then
10560 return Standard_Long_Long_Integer;
10562 raise Program_Error;
10565 end Matching_Standard_Type;
10567 -----------------------------
10568 -- May_Generate_Large_Temp --
10569 -----------------------------
10571 -- At the current time, the only types that we return False for (i.e. where
10572 -- we decide we know they cannot generate large temps) are ones where we
10573 -- know the size is 256 bits or less at compile time, and we are still not
10574 -- doing a thorough job on arrays and records ???
10576 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
10578 if not Size_Known_At_Compile_Time (Typ) then
10581 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
10584 elsif Is_Array_Type (Typ)
10585 and then Present (Packed_Array_Impl_Type (Typ))
10587 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
10589 -- We could do more here to find other small types ???
10594 end May_Generate_Large_Temp;
10596 --------------------------------------------
10597 -- Needs_Conditional_Null_Excluding_Check --
10598 --------------------------------------------
10600 function Needs_Conditional_Null_Excluding_Check
10601 (Typ : Entity_Id) return Boolean
10605 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
10606 end Needs_Conditional_Null_Excluding_Check;
10608 ----------------------------
10609 -- Needs_Constant_Address --
10610 ----------------------------
10612 function Needs_Constant_Address
10614 Typ : Entity_Id) return Boolean
10617 -- If we have no initialization of any kind, then we don't need to place
10618 -- any restrictions on the address clause, because the object will be
10619 -- elaborated after the address clause is evaluated. This happens if the
10620 -- declaration has no initial expression, or the type has no implicit
10621 -- initialization, or the object is imported.
10623 -- The same holds for all initialized scalar types and all access types.
10624 -- Packed bit arrays of size up to 64 are represented using a modular
10625 -- type with an initialization (to zero) and can be processed like other
10626 -- initialized scalar types.
10628 -- If the type is controlled, code to attach the object to a
10629 -- finalization chain is generated at the point of declaration, and
10630 -- therefore the elaboration of the object cannot be delayed: the
10631 -- address expression must be a constant.
10633 if No (Expression (Decl))
10634 and then not Needs_Finalization (Typ)
10636 (not Has_Non_Null_Base_Init_Proc (Typ)
10637 or else Is_Imported (Defining_Identifier (Decl)))
10641 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
10642 or else Is_Access_Type (Typ)
10644 (Is_Bit_Packed_Array (Typ)
10645 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
10650 -- Otherwise, we require the address clause to be constant because
10651 -- the call to the initialization procedure (or the attach code) has
10652 -- to happen at the point of the declaration.
10654 -- Actually the IP call has been moved to the freeze actions anyway,
10655 -- so maybe we can relax this restriction???
10659 end Needs_Constant_Address;
10661 ----------------------------
10662 -- New_Class_Wide_Subtype --
10663 ----------------------------
10665 function New_Class_Wide_Subtype
10666 (CW_Typ : Entity_Id;
10667 N : Node_Id) return Entity_Id
10669 Res : constant Entity_Id := Create_Itype (E_Void, N);
10671 -- Capture relevant attributes of the class-wide subtype which must be
10672 -- restored after the copy.
10674 Res_Chars : constant Name_Id := Chars (Res);
10675 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
10676 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
10677 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
10678 Res_Scope : constant Entity_Id := Scope (Res);
10681 Copy_Node (CW_Typ, Res);
10683 -- Restore the relevant attributes of the class-wide subtype
10685 Set_Chars (Res, Res_Chars);
10686 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
10687 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
10688 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
10689 Set_Scope (Res, Res_Scope);
10691 -- Decorate the class-wide subtype
10693 Set_Associated_Node_For_Itype (Res, N);
10694 Set_Comes_From_Source (Res, False);
10695 Set_Ekind (Res, E_Class_Wide_Subtype);
10696 Set_Etype (Res, Base_Type (CW_Typ));
10697 Set_Freeze_Node (Res, Empty);
10698 Set_Is_Frozen (Res, False);
10699 Set_Is_Itype (Res);
10700 Set_Is_Public (Res, False);
10701 Set_Next_Entity (Res, Empty);
10702 Set_Prev_Entity (Res, Empty);
10703 Set_Sloc (Res, Sloc (N));
10705 Set_Public_Status (Res);
10708 end New_Class_Wide_Subtype;
10710 --------------------------------
10711 -- Non_Limited_Designated_Type --
10712 ---------------------------------
10714 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
10715 Desig : constant Entity_Id := Designated_Type (T);
10717 if Has_Non_Limited_View (Desig) then
10718 return Non_Limited_View (Desig);
10722 end Non_Limited_Designated_Type;
10724 -----------------------------------
10725 -- OK_To_Do_Constant_Replacement --
10726 -----------------------------------
10728 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
10729 ES : constant Entity_Id := Scope (E);
10733 -- Do not replace statically allocated objects, because they may be
10734 -- modified outside the current scope.
10736 if Is_Statically_Allocated (E) then
10739 -- Do not replace aliased or volatile objects, since we don't know what
10740 -- else might change the value.
10742 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
10745 -- Debug flag -gnatdM disconnects this optimization
10747 elsif Debug_Flag_MM then
10750 -- Otherwise check scopes
10753 CS := Current_Scope;
10756 -- If we are in right scope, replacement is safe
10761 -- Packages do not affect the determination of safety
10763 elsif Ekind (CS) = E_Package then
10764 exit when CS = Standard_Standard;
10767 -- Blocks do not affect the determination of safety
10769 elsif Ekind (CS) = E_Block then
10772 -- Loops do not affect the determination of safety. Note that we
10773 -- kill all current values on entry to a loop, so we are just
10774 -- talking about processing within a loop here.
10776 elsif Ekind (CS) = E_Loop then
10779 -- Otherwise, the reference is dubious, and we cannot be sure that
10780 -- it is safe to do the replacement.
10789 end OK_To_Do_Constant_Replacement;
10791 ------------------------------------
10792 -- Possible_Bit_Aligned_Component --
10793 ------------------------------------
10795 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
10797 -- Do not process an unanalyzed node because it is not yet decorated and
10798 -- most checks performed below will fail.
10800 if not Analyzed (N) then
10804 -- There are never alignment issues in CodePeer mode
10806 if CodePeer_Mode then
10812 -- Case of indexed component
10814 when N_Indexed_Component =>
10816 P : constant Node_Id := Prefix (N);
10817 Ptyp : constant Entity_Id := Etype (P);
10820 -- If we know the component size and it is not larger than 64,
10821 -- then we are definitely OK. The back end does the assignment
10822 -- of misaligned small objects correctly.
10824 if Known_Static_Component_Size (Ptyp)
10825 and then Component_Size (Ptyp) <= 64
10829 -- Otherwise, we need to test the prefix, to see if we are
10830 -- indexing from a possibly unaligned component.
10833 return Possible_Bit_Aligned_Component (P);
10837 -- Case of selected component
10839 when N_Selected_Component =>
10841 P : constant Node_Id := Prefix (N);
10842 Comp : constant Entity_Id := Entity (Selector_Name (N));
10845 -- This is the crucial test: if the component itself causes
10846 -- trouble, then we can stop and return True.
10848 if Component_May_Be_Bit_Aligned (Comp) then
10851 -- Otherwise, we need to test the prefix, to see if we are
10852 -- selecting from a possibly unaligned component.
10855 return Possible_Bit_Aligned_Component (P);
10859 -- For a slice, test the prefix, if that is possibly misaligned,
10860 -- then for sure the slice is.
10863 return Possible_Bit_Aligned_Component (Prefix (N));
10865 -- For an unchecked conversion, check whether the expression may
10868 when N_Unchecked_Type_Conversion =>
10869 return Possible_Bit_Aligned_Component (Expression (N));
10871 -- If we have none of the above, it means that we have fallen off the
10872 -- top testing prefixes recursively, and we now have a stand alone
10873 -- object, where we don't have a problem, unless this is a renaming,
10874 -- in which case we need to look into the renamed object.
10877 if Is_Entity_Name (N)
10878 and then Present (Renamed_Object (Entity (N)))
10881 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
10886 end Possible_Bit_Aligned_Component;
10888 -----------------------------------------------
10889 -- Process_Statements_For_Controlled_Objects --
10890 -----------------------------------------------
10892 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
10893 Loc : constant Source_Ptr := Sloc (N);
10895 function Are_Wrapped (L : List_Id) return Boolean;
10896 -- Determine whether list L contains only one statement which is a block
10898 function Wrap_Statements_In_Block
10900 Scop : Entity_Id := Current_Scope) return Node_Id;
10901 -- Given a list of statements L, wrap it in a block statement and return
10902 -- the generated node. Scop is either the current scope or the scope of
10903 -- the context (if applicable).
10909 function Are_Wrapped (L : List_Id) return Boolean is
10910 Stmt : constant Node_Id := First (L);
10914 and then No (Next (Stmt))
10915 and then Nkind (Stmt) = N_Block_Statement;
10918 ------------------------------
10919 -- Wrap_Statements_In_Block --
10920 ------------------------------
10922 function Wrap_Statements_In_Block
10924 Scop : Entity_Id := Current_Scope) return Node_Id
10926 Block_Id : Entity_Id;
10927 Block_Nod : Node_Id;
10928 Iter_Loop : Entity_Id;
10932 Make_Block_Statement (Loc,
10933 Declarations => No_List,
10934 Handled_Statement_Sequence =>
10935 Make_Handled_Sequence_Of_Statements (Loc,
10938 -- Create a label for the block in case the block needs to manage the
10939 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
10941 Add_Block_Identifier (Block_Nod, Block_Id);
10943 -- When wrapping the statements of an iterator loop, check whether
10944 -- the loop requires secondary stack management and if so, propagate
10945 -- the appropriate flags to the block. This ensures that the cursor
10946 -- is properly cleaned up at each iteration of the loop.
10948 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
10950 if Present (Iter_Loop) then
10951 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
10953 -- Secondary stack reclamation is suppressed when the associated
10954 -- iterator loop contains a return statement which uses the stack.
10956 Set_Sec_Stack_Needed_For_Return
10957 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
10961 end Wrap_Statements_In_Block;
10967 -- Start of processing for Process_Statements_For_Controlled_Objects
10970 -- Whenever a non-handled statement list is wrapped in a block, the
10971 -- block must be explicitly analyzed to redecorate all entities in the
10972 -- list and ensure that a finalizer is properly built.
10975 when N_Conditional_Entry_Call
10978 | N_Selective_Accept
10980 -- Check the "then statements" for elsif parts and if statements
10982 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
10983 and then not Is_Empty_List (Then_Statements (N))
10984 and then not Are_Wrapped (Then_Statements (N))
10985 and then Requires_Cleanup_Actions
10986 (L => Then_Statements (N),
10987 Lib_Level => False,
10988 Nested_Constructs => False)
10990 Block := Wrap_Statements_In_Block (Then_Statements (N));
10991 Set_Then_Statements (N, New_List (Block));
10996 -- Check the "else statements" for conditional entry calls, if
10997 -- statements and selective accepts.
10999 if Nkind_In (N, N_Conditional_Entry_Call,
11001 N_Selective_Accept)
11002 and then not Is_Empty_List (Else_Statements (N))
11003 and then not Are_Wrapped (Else_Statements (N))
11004 and then Requires_Cleanup_Actions
11005 (L => Else_Statements (N),
11006 Lib_Level => False,
11007 Nested_Constructs => False)
11009 Block := Wrap_Statements_In_Block (Else_Statements (N));
11010 Set_Else_Statements (N, New_List (Block));
11015 when N_Abortable_Part
11016 | N_Accept_Alternative
11017 | N_Case_Statement_Alternative
11018 | N_Delay_Alternative
11019 | N_Entry_Call_Alternative
11020 | N_Exception_Handler
11022 | N_Triggering_Alternative
11024 if not Is_Empty_List (Statements (N))
11025 and then not Are_Wrapped (Statements (N))
11026 and then Requires_Cleanup_Actions
11027 (L => Statements (N),
11028 Lib_Level => False,
11029 Nested_Constructs => False)
11031 if Nkind (N) = N_Loop_Statement
11032 and then Present (Identifier (N))
11035 Wrap_Statements_In_Block
11036 (L => Statements (N),
11037 Scop => Entity (Identifier (N)));
11039 Block := Wrap_Statements_In_Block (Statements (N));
11042 Set_Statements (N, New_List (Block));
11046 -- Could be e.g. a loop that was transformed into a block or null
11047 -- statement. Do nothing for terminate alternatives.
11049 when N_Block_Statement
11051 | N_Terminate_Alternative
11056 raise Program_Error;
11058 end Process_Statements_For_Controlled_Objects;
11064 function Power_Of_Two (N : Node_Id) return Nat is
11065 Typ : constant Entity_Id := Etype (N);
11066 pragma Assert (Is_Integer_Type (Typ));
11068 Siz : constant Nat := UI_To_Int (Esize (Typ));
11072 if not Compile_Time_Known_Value (N) then
11076 Val := Expr_Value (N);
11077 for J in 1 .. Siz - 1 loop
11078 if Val = Uint_2 ** J then
11087 ----------------------
11088 -- Remove_Init_Call --
11089 ----------------------
11091 function Remove_Init_Call
11093 Rep_Clause : Node_Id) return Node_Id
11095 Par : constant Node_Id := Parent (Var);
11096 Typ : constant Entity_Id := Etype (Var);
11098 Init_Proc : Entity_Id;
11099 -- Initialization procedure for Typ
11101 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
11102 -- Look for init call for Var starting at From and scanning the
11103 -- enclosing list until Rep_Clause or the end of the list is reached.
11105 ----------------------------
11106 -- Find_Init_Call_In_List --
11107 ----------------------------
11109 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
11110 Init_Call : Node_Id;
11114 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
11115 if Nkind (Init_Call) = N_Procedure_Call_Statement
11116 and then Is_Entity_Name (Name (Init_Call))
11117 and then Entity (Name (Init_Call)) = Init_Proc
11126 end Find_Init_Call_In_List;
11128 Init_Call : Node_Id;
11130 -- Start of processing for Find_Init_Call
11133 if Present (Initialization_Statements (Var)) then
11134 Init_Call := Initialization_Statements (Var);
11135 Set_Initialization_Statements (Var, Empty);
11137 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
11139 -- No init proc for the type, so obviously no call to be found
11144 -- We might be able to handle other cases below by just properly
11145 -- setting Initialization_Statements at the point where the init proc
11146 -- call is generated???
11148 Init_Proc := Base_Init_Proc (Typ);
11150 -- First scan the list containing the declaration of Var
11152 Init_Call := Find_Init_Call_In_List (From => Next (Par));
11154 -- If not found, also look on Var's freeze actions list, if any,
11155 -- since the init call may have been moved there (case of an address
11156 -- clause applying to Var).
11158 if No (Init_Call) and then Present (Freeze_Node (Var)) then
11160 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
11163 -- If the initialization call has actuals that use the secondary
11164 -- stack, the call may have been wrapped into a temporary block, in
11165 -- which case the block itself has to be removed.
11167 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
11169 Blk : constant Node_Id := Next (Par);
11172 (Find_Init_Call_In_List
11173 (First (Statements (Handled_Statement_Sequence (Blk)))))
11181 if Present (Init_Call) then
11182 Remove (Init_Call);
11185 end Remove_Init_Call;
11187 -------------------------
11188 -- Remove_Side_Effects --
11189 -------------------------
11191 procedure Remove_Side_Effects
11193 Name_Req : Boolean := False;
11194 Renaming_Req : Boolean := False;
11195 Variable_Ref : Boolean := False;
11196 Related_Id : Entity_Id := Empty;
11197 Is_Low_Bound : Boolean := False;
11198 Is_High_Bound : Boolean := False;
11199 Check_Side_Effects : Boolean := True)
11201 function Build_Temporary
11204 Related_Nod : Node_Id := Empty) return Entity_Id;
11205 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
11206 -- is present (xxx is taken from the Chars field of Related_Nod),
11207 -- otherwise it generates an internal temporary. The created temporary
11208 -- entity is marked as internal.
11210 ---------------------
11211 -- Build_Temporary --
11212 ---------------------
11214 function Build_Temporary
11217 Related_Nod : Node_Id := Empty) return Entity_Id
11219 Temp_Id : Entity_Id;
11220 Temp_Nam : Name_Id;
11223 -- The context requires an external symbol
11225 if Present (Related_Id) then
11226 if Is_Low_Bound then
11227 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
11228 else pragma Assert (Is_High_Bound);
11229 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
11232 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
11234 -- Otherwise generate an internal temporary
11237 Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
11240 Set_Is_Internal (Temp_Id);
11243 end Build_Temporary;
11247 Loc : constant Source_Ptr := Sloc (Exp);
11248 Exp_Type : constant Entity_Id := Etype (Exp);
11249 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
11250 Def_Id : Entity_Id;
11253 Ptr_Typ_Decl : Node_Id;
11254 Ref_Type : Entity_Id;
11257 -- Start of processing for Remove_Side_Effects
11260 -- Handle cases in which there is nothing to do. In GNATprove mode,
11261 -- removal of side effects is useful for the light expansion of
11262 -- renamings. This removal should only occur when not inside a
11263 -- generic and not doing a preanalysis.
11265 if not Expander_Active
11266 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
11270 -- Cannot generate temporaries if the invocation to remove side effects
11271 -- was issued too early and the type of the expression is not resolved
11272 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
11273 -- Remove_Side_Effects).
11275 elsif No (Exp_Type)
11276 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11280 -- Nothing to do if prior expansion determined that a function call does
11281 -- not require side effect removal.
11283 elsif Nkind (Exp) = N_Function_Call
11284 and then No_Side_Effect_Removal (Exp)
11288 -- No action needed for side-effect free expressions
11290 elsif Check_Side_Effects
11291 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11295 -- Generating C code we cannot remove side effect of function returning
11296 -- class-wide types since there is no secondary stack (required to use
11299 elsif Modify_Tree_For_C
11300 and then Nkind (Exp) = N_Function_Call
11301 and then Is_Class_Wide_Type (Etype (Exp))
11306 -- The remaining processing is done with all checks suppressed
11308 -- Note: from now on, don't use return statements, instead do a goto
11309 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11311 Scope_Suppress.Suppress := (others => True);
11313 -- If this is a side-effect free attribute reference whose expressions
11314 -- are also side-effect free and whose prefix is not a name, remove the
11315 -- side effects of the prefix. A copy of the prefix is required in this
11316 -- case and it is better not to make an additional one for the attribute
11317 -- itself, because the return type of many of them is universal integer,
11318 -- which is a very large type for a temporary.
11320 if Nkind (Exp) = N_Attribute_Reference
11321 and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
11322 and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
11323 and then not Is_Name_Reference (Prefix (Exp))
11325 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11328 -- If this is an elementary or a small not-by-reference record type, and
11329 -- we need to capture the value, just make a constant; this is cheap and
11330 -- objects of both kinds of types can be bit aligned, so it might not be
11331 -- possible to generate a reference to them. Likewise if this is not a
11332 -- name reference, except for a type conversion, because we would enter
11333 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11334 -- type has predicates (and type conversions need a specific treatment
11335 -- anyway, see below). Also do it if we have a volatile reference and
11336 -- Name_Req is not set (see comments for Side_Effect_Free).
11338 elsif (Is_Elementary_Type (Exp_Type)
11339 or else (Is_Record_Type (Exp_Type)
11340 and then Known_Static_RM_Size (Exp_Type)
11341 and then RM_Size (Exp_Type) <= 64
11342 and then not Has_Discriminants (Exp_Type)
11343 and then not Is_By_Reference_Type (Exp_Type)))
11344 and then (Variable_Ref
11345 or else (not Is_Name_Reference (Exp)
11346 and then Nkind (Exp) /= N_Type_Conversion)
11347 or else (not Name_Req
11348 and then Is_Volatile_Reference (Exp)))
11350 Def_Id := Build_Temporary (Loc, 'R', Exp);
11351 Set_Etype (Def_Id, Exp_Type);
11352 Res := New_Occurrence_Of (Def_Id, Loc);
11354 -- If the expression is a packed reference, it must be reanalyzed and
11355 -- expanded, depending on context. This is the case for actuals where
11356 -- a constraint check may capture the actual before expansion of the
11357 -- call is complete.
11359 if Nkind (Exp) = N_Indexed_Component
11360 and then Is_Packed (Etype (Prefix (Exp)))
11362 Set_Analyzed (Exp, False);
11363 Set_Analyzed (Prefix (Exp), False);
11367 -- Rnn : Exp_Type renames Expr;
11369 -- In GNATprove mode, we prefer to use renamings for intermediate
11370 -- variables to definition of constants, due to the implicit move
11371 -- operation that such a constant definition causes as part of the
11372 -- support in GNATprove for ownership pointers. Hence, we generate
11373 -- a renaming for a reference to an object of a nonscalar type.
11376 or else (GNATprove_Mode
11377 and then Is_Object_Reference (Exp)
11378 and then not Is_Scalar_Type (Exp_Type))
11381 Make_Object_Renaming_Declaration (Loc,
11382 Defining_Identifier => Def_Id,
11383 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11384 Name => Relocate_Node (Exp));
11387 -- Rnn : constant Exp_Type := Expr;
11391 Make_Object_Declaration (Loc,
11392 Defining_Identifier => Def_Id,
11393 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11394 Constant_Present => True,
11395 Expression => Relocate_Node (Exp));
11397 Set_Assignment_OK (E);
11400 Insert_Action (Exp, E);
11402 -- If the expression has the form v.all then we can just capture the
11403 -- pointer, and then do an explicit dereference on the result, but
11404 -- this is not right if this is a volatile reference.
11406 elsif Nkind (Exp) = N_Explicit_Dereference
11407 and then not Is_Volatile_Reference (Exp)
11409 Def_Id := Build_Temporary (Loc, 'R', Exp);
11411 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
11413 Insert_Action (Exp,
11414 Make_Object_Declaration (Loc,
11415 Defining_Identifier => Def_Id,
11416 Object_Definition =>
11417 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
11418 Constant_Present => True,
11419 Expression => Relocate_Node (Prefix (Exp))));
11421 -- Similar processing for an unchecked conversion of an expression of
11422 -- the form v.all, where we want the same kind of treatment.
11424 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11425 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
11427 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11430 -- If this is a type conversion, leave the type conversion and remove
11431 -- the side effects in the expression. This is important in several
11432 -- circumstances: for change of representations, and also when this is a
11433 -- view conversion to a smaller object, where gigi can end up creating
11434 -- its own temporary of the wrong size.
11436 elsif Nkind (Exp) = N_Type_Conversion then
11437 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11439 -- Generating C code the type conversion of an access to constrained
11440 -- array type into an access to unconstrained array type involves
11441 -- initializing a fat pointer and the expression must be free of
11442 -- side effects to safely compute its bounds.
11444 if Modify_Tree_For_C
11445 and then Is_Access_Type (Etype (Exp))
11446 and then Is_Array_Type (Designated_Type (Etype (Exp)))
11447 and then not Is_Constrained (Designated_Type (Etype (Exp)))
11449 Def_Id := Build_Temporary (Loc, 'R', Exp);
11450 Set_Etype (Def_Id, Exp_Type);
11451 Res := New_Occurrence_Of (Def_Id, Loc);
11453 Insert_Action (Exp,
11454 Make_Object_Declaration (Loc,
11455 Defining_Identifier => Def_Id,
11456 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11457 Constant_Present => True,
11458 Expression => Relocate_Node (Exp)));
11463 -- If this is an unchecked conversion that Gigi can't handle, make
11464 -- a copy or a use a renaming to capture the value.
11466 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11467 and then not Safe_Unchecked_Type_Conversion (Exp)
11469 if CW_Or_Has_Controlled_Part (Exp_Type) then
11471 -- Use a renaming to capture the expression, rather than create
11472 -- a controlled temporary.
11474 Def_Id := Build_Temporary (Loc, 'R', Exp);
11475 Res := New_Occurrence_Of (Def_Id, Loc);
11477 Insert_Action (Exp,
11478 Make_Object_Renaming_Declaration (Loc,
11479 Defining_Identifier => Def_Id,
11480 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11481 Name => Relocate_Node (Exp)));
11484 Def_Id := Build_Temporary (Loc, 'R', Exp);
11485 Set_Etype (Def_Id, Exp_Type);
11486 Res := New_Occurrence_Of (Def_Id, Loc);
11489 Make_Object_Declaration (Loc,
11490 Defining_Identifier => Def_Id,
11491 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11492 Constant_Present => not Is_Variable (Exp),
11493 Expression => Relocate_Node (Exp));
11495 Set_Assignment_OK (E);
11496 Insert_Action (Exp, E);
11499 -- For expressions that denote names, we can use a renaming scheme.
11500 -- This is needed for correctness in the case of a volatile object of
11501 -- a nonvolatile type because the Make_Reference call of the "default"
11502 -- approach would generate an illegal access value (an access value
11503 -- cannot designate such an object - see Analyze_Reference).
11505 elsif Is_Name_Reference (Exp)
11507 -- We skip using this scheme if we have an object of a volatile
11508 -- type and we do not have Name_Req set true (see comments for
11509 -- Side_Effect_Free).
11511 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
11513 Def_Id := Build_Temporary (Loc, 'R', Exp);
11514 Res := New_Occurrence_Of (Def_Id, Loc);
11516 Insert_Action (Exp,
11517 Make_Object_Renaming_Declaration (Loc,
11518 Defining_Identifier => Def_Id,
11519 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11520 Name => Relocate_Node (Exp)));
11522 -- If this is a packed reference, or a selected component with
11523 -- a nonstandard representation, a reference to the temporary
11524 -- will be replaced by a copy of the original expression (see
11525 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
11526 -- elaborated by gigi, and is of course not to be replaced in-line
11527 -- by the expression it renames, which would defeat the purpose of
11528 -- removing the side effect.
11530 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
11531 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
11535 Set_Is_Renaming_Of_Object (Def_Id, False);
11538 -- Avoid generating a variable-sized temporary, by generating the
11539 -- reference just for the function call. The transformation could be
11540 -- refined to apply only when the array component is constrained by a
11543 elsif Nkind (Exp) = N_Selected_Component
11544 and then Nkind (Prefix (Exp)) = N_Function_Call
11545 and then Is_Array_Type (Exp_Type)
11547 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11550 -- Otherwise we generate a reference to the expression
11553 -- An expression which is in SPARK mode is considered side effect
11554 -- free if the resulting value is captured by a variable or a
11558 and then Nkind (Parent (Exp)) = N_Object_Declaration
11562 -- When generating C code we cannot consider side effect free object
11563 -- declarations that have discriminants and are initialized by means
11564 -- of a function call since on this target there is no secondary
11565 -- stack to store the return value and the expander may generate an
11566 -- extra call to the function to compute the discriminant value. In
11567 -- addition, for targets that have secondary stack, the expansion of
11568 -- functions with side effects involves the generation of an access
11569 -- type to capture the return value stored in the secondary stack;
11570 -- by contrast when generating C code such expansion generates an
11571 -- internal object declaration (no access type involved) which must
11572 -- be identified here to avoid entering into a never-ending loop
11573 -- generating internal object declarations.
11575 elsif Modify_Tree_For_C
11576 and then Nkind (Parent (Exp)) = N_Object_Declaration
11578 (Nkind (Exp) /= N_Function_Call
11579 or else not Has_Discriminants (Exp_Type)
11580 or else Is_Internal_Name
11581 (Chars (Defining_Identifier (Parent (Exp)))))
11586 -- Special processing for function calls that return a limited type.
11587 -- We need to build a declaration that will enable build-in-place
11588 -- expansion of the call. This is not done if the context is already
11589 -- an object declaration, to prevent infinite recursion.
11591 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
11592 -- to accommodate functions returning limited objects by reference.
11594 if Ada_Version >= Ada_2005
11595 and then Nkind (Exp) = N_Function_Call
11596 and then Is_Limited_View (Etype (Exp))
11597 and then Nkind (Parent (Exp)) /= N_Object_Declaration
11600 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
11605 Make_Object_Declaration (Loc,
11606 Defining_Identifier => Obj,
11607 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11608 Expression => Relocate_Node (Exp));
11610 Insert_Action (Exp, Decl);
11611 Set_Etype (Obj, Exp_Type);
11612 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
11617 Def_Id := Build_Temporary (Loc, 'R', Exp);
11619 -- The regular expansion of functions with side effects involves the
11620 -- generation of an access type to capture the return value found on
11621 -- the secondary stack. Since SPARK (and why) cannot process access
11622 -- types, use a different approach which ignores the secondary stack
11623 -- and "copies" the returned object.
11624 -- When generating C code, no need for a 'reference since the
11625 -- secondary stack is not supported.
11627 if GNATprove_Mode or Modify_Tree_For_C then
11628 Res := New_Occurrence_Of (Def_Id, Loc);
11629 Ref_Type := Exp_Type;
11631 -- Regular expansion utilizing an access type and 'reference
11635 Make_Explicit_Dereference (Loc,
11636 Prefix => New_Occurrence_Of (Def_Id, Loc));
11639 -- type Ann is access all <Exp_Type>;
11641 Ref_Type := Make_Temporary (Loc, 'A');
11644 Make_Full_Type_Declaration (Loc,
11645 Defining_Identifier => Ref_Type,
11647 Make_Access_To_Object_Definition (Loc,
11648 All_Present => True,
11649 Subtype_Indication =>
11650 New_Occurrence_Of (Exp_Type, Loc)));
11652 Insert_Action (Exp, Ptr_Typ_Decl);
11656 if Nkind (E) = N_Explicit_Dereference then
11657 New_Exp := Relocate_Node (Prefix (E));
11660 E := Relocate_Node (E);
11662 -- Do not generate a 'reference in SPARK mode or C generation
11663 -- since the access type is not created in the first place.
11665 if GNATprove_Mode or Modify_Tree_For_C then
11668 -- Otherwise generate reference, marking the value as non-null
11669 -- since we know it cannot be null and we don't want a check.
11672 New_Exp := Make_Reference (Loc, E);
11673 Set_Is_Known_Non_Null (Def_Id);
11677 if Is_Delayed_Aggregate (E) then
11679 -- The expansion of nested aggregates is delayed until the
11680 -- enclosing aggregate is expanded. As aggregates are often
11681 -- qualified, the predicate applies to qualified expressions as
11682 -- well, indicating that the enclosing aggregate has not been
11683 -- expanded yet. At this point the aggregate is part of a
11684 -- stand-alone declaration, and must be fully expanded.
11686 if Nkind (E) = N_Qualified_Expression then
11687 Set_Expansion_Delayed (Expression (E), False);
11688 Set_Analyzed (Expression (E), False);
11690 Set_Expansion_Delayed (E, False);
11693 Set_Analyzed (E, False);
11696 -- Generating C code of object declarations that have discriminants
11697 -- and are initialized by means of a function call we propagate the
11698 -- discriminants of the parent type to the internally built object.
11699 -- This is needed to avoid generating an extra call to the called
11702 -- For example, if we generate here the following declaration, it
11703 -- will be expanded later adding an extra call to evaluate the value
11704 -- of the discriminant (needed to compute the size of the object).
11706 -- type Rec (D : Integer) is ...
11707 -- Obj : constant Rec := SomeFunc;
11709 if Modify_Tree_For_C
11710 and then Nkind (Parent (Exp)) = N_Object_Declaration
11711 and then Has_Discriminants (Exp_Type)
11712 and then Nkind (Exp) = N_Function_Call
11714 Insert_Action (Exp,
11715 Make_Object_Declaration (Loc,
11716 Defining_Identifier => Def_Id,
11717 Object_Definition => New_Copy_Tree
11718 (Object_Definition (Parent (Exp))),
11719 Constant_Present => True,
11720 Expression => New_Exp));
11722 Insert_Action (Exp,
11723 Make_Object_Declaration (Loc,
11724 Defining_Identifier => Def_Id,
11725 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
11726 Constant_Present => True,
11727 Expression => New_Exp));
11731 -- Preserve the Assignment_OK flag in all copies, since at least one
11732 -- copy may be used in a context where this flag must be set (otherwise
11733 -- why would the flag be set in the first place).
11735 Set_Assignment_OK (Res, Assignment_OK (Exp));
11737 -- Preserve the Do_Range_Check flag in all copies
11739 Set_Do_Range_Check (Res, Do_Range_Check (Exp));
11741 -- Finally rewrite the original expression and we are done
11743 Rewrite (Exp, Res);
11744 Analyze_And_Resolve (Exp, Exp_Type);
11747 Scope_Suppress := Svg_Suppress;
11748 end Remove_Side_Effects;
11750 ------------------------
11751 -- Replace_References --
11752 ------------------------
11754 procedure Replace_References
11756 Par_Typ : Entity_Id;
11757 Deriv_Typ : Entity_Id;
11758 Par_Obj : Entity_Id := Empty;
11759 Deriv_Obj : Entity_Id := Empty)
11761 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
11762 -- Determine whether node Ref denotes some component of Deriv_Obj
11764 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
11765 -- Substitute a reference to an entity with the corresponding value
11766 -- stored in table Type_Map.
11768 function Type_Of_Formal
11770 Actual : Node_Id) return Entity_Id;
11771 -- Find the type of the formal parameter which corresponds to actual
11772 -- parameter Actual in subprogram call Call.
11774 ----------------------
11775 -- Is_Deriv_Obj_Ref --
11776 ----------------------
11778 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
11779 Par : constant Node_Id := Parent (Ref);
11782 -- Detect the folowing selected component form:
11784 -- Deriv_Obj.(something)
11787 Nkind (Par) = N_Selected_Component
11788 and then Is_Entity_Name (Prefix (Par))
11789 and then Entity (Prefix (Par)) = Deriv_Obj;
11790 end Is_Deriv_Obj_Ref;
11796 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
11797 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
11798 -- Reset the Controlling_Argument of all function calls that
11799 -- encapsulate node From_Arg.
11801 ----------------------------------
11802 -- Remove_Controlling_Arguments --
11803 ----------------------------------
11805 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
11810 while Present (Par) loop
11811 if Nkind (Par) = N_Function_Call
11812 and then Present (Controlling_Argument (Par))
11814 Set_Controlling_Argument (Par, Empty);
11816 -- Prevent the search from going too far
11818 elsif Is_Body_Or_Package_Declaration (Par) then
11822 Par := Parent (Par);
11824 end Remove_Controlling_Arguments;
11828 Context : constant Node_Id := Parent (Ref);
11829 Loc : constant Source_Ptr := Sloc (Ref);
11830 Ref_Id : Entity_Id;
11831 Result : Traverse_Result;
11834 -- The new reference which is intended to substitute the old one
11837 -- The reference designated for replacement. In certain cases this
11838 -- may be a node other than Ref.
11840 Val : Node_Or_Entity_Id;
11841 -- The corresponding value of Ref from the type map
11843 -- Start of processing for Replace_Ref
11846 -- Assume that the input reference is to be replaced and that the
11847 -- traversal should examine the children of the reference.
11852 -- The input denotes a meaningful reference
11854 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
11855 Ref_Id := Entity (Ref);
11856 Val := Type_Map.Get (Ref_Id);
11858 -- The reference has a corresponding value in the type map, a
11859 -- substitution is possible.
11861 if Present (Val) then
11863 -- The reference denotes a discriminant
11865 if Ekind (Ref_Id) = E_Discriminant then
11866 if Nkind (Val) in N_Entity then
11868 -- The value denotes another discriminant. Replace as
11871 -- _object.Discr -> _object.Val
11873 if Ekind (Val) = E_Discriminant then
11874 New_Ref := New_Occurrence_Of (Val, Loc);
11876 -- Otherwise the value denotes the entity of a name which
11877 -- constraints the discriminant. Replace as follows:
11879 -- _object.Discr -> Val
11882 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11884 New_Ref := New_Occurrence_Of (Val, Loc);
11885 Old_Ref := Parent (Old_Ref);
11888 -- Otherwise the value denotes an arbitrary expression which
11889 -- constraints the discriminant. Replace as follows:
11891 -- _object.Discr -> Val
11894 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11896 New_Ref := New_Copy_Tree (Val);
11897 Old_Ref := Parent (Old_Ref);
11900 -- Otherwise the reference denotes a primitive. Replace as
11903 -- Primitive -> Val
11906 pragma Assert (Nkind (Val) in N_Entity);
11907 New_Ref := New_Occurrence_Of (Val, Loc);
11910 -- The reference mentions the _object parameter of the parent
11911 -- type's DIC or type invariant procedure. Replace as follows:
11913 -- _object -> _object
11915 elsif Present (Par_Obj)
11916 and then Present (Deriv_Obj)
11917 and then Ref_Id = Par_Obj
11919 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
11921 -- The type of the _object parameter is class-wide when the
11922 -- expression comes from an assertion pragma that applies to
11923 -- an abstract parent type or an interface. The class-wide type
11924 -- facilitates the preanalysis of the expression by treating
11925 -- calls to abstract primitives that mention the current
11926 -- instance of the type as dispatching. Once the calls are
11927 -- remapped to invoke overriding or inherited primitives, the
11928 -- calls no longer need to be dispatching. Examine all function
11929 -- calls that encapsulate the _object parameter and reset their
11930 -- Controlling_Argument attribute.
11932 if Is_Class_Wide_Type (Etype (Par_Obj))
11933 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
11935 Remove_Controlling_Arguments (Old_Ref);
11938 -- The reference to _object acts as an actual parameter in a
11939 -- subprogram call which may be invoking a primitive of the
11942 -- Primitive (... _object ...);
11944 -- The parent type primitive may not be overridden nor
11945 -- inherited when it is declared after the derived type
11948 -- type Parent is tagged private;
11949 -- type Child is new Parent with private;
11950 -- procedure Primitive (Obj : Parent);
11952 -- In this scenario the _object parameter is converted to the
11953 -- parent type. Due to complications with partial/full views
11954 -- and view swaps, the parent type is taken from the formal
11955 -- parameter of the subprogram being called.
11957 if Nkind_In (Context, N_Function_Call,
11958 N_Procedure_Call_Statement)
11959 and then No (Type_Map.Get (Entity (Name (Context))))
11962 Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
11964 -- Do not process the generated type conversion because
11965 -- both the parent type and the derived type are in the
11966 -- Type_Map table. This will clobber the type conversion
11967 -- by resetting its subtype mark.
11972 -- Otherwise there is nothing to replace
11978 if Present (New_Ref) then
11979 Rewrite (Old_Ref, New_Ref);
11981 -- Update the return type when the context of the reference
11982 -- acts as the name of a function call. Note that the update
11983 -- should not be performed when the reference appears as an
11984 -- actual in the call.
11986 if Nkind (Context) = N_Function_Call
11987 and then Name (Context) = Old_Ref
11989 Set_Etype (Context, Etype (Val));
11994 -- Reanalyze the reference due to potential replacements
11996 if Nkind (Old_Ref) in N_Has_Etype then
11997 Set_Analyzed (Old_Ref, False);
12003 procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
12005 --------------------
12006 -- Type_Of_Formal --
12007 --------------------
12009 function Type_Of_Formal
12011 Actual : Node_Id) return Entity_Id
12017 -- Examine the list of actual and formal parameters in parallel
12019 A := First (Parameter_Associations (Call));
12020 F := First_Formal (Entity (Name (Call)));
12021 while Present (A) and then Present (F) loop
12030 -- The actual parameter must always have a corresponding formal
12032 pragma Assert (False);
12035 end Type_Of_Formal;
12037 -- Start of processing for Replace_References
12040 -- Map the attributes of the parent type to the proper corresponding
12041 -- attributes of the derived type.
12044 (Parent_Type => Par_Typ,
12045 Derived_Type => Deriv_Typ);
12047 -- Inspect the input expression and perform substitutions where
12050 Replace_Refs (Expr);
12051 end Replace_References;
12053 -----------------------------
12054 -- Replace_Type_References --
12055 -----------------------------
12057 procedure Replace_Type_References
12060 Obj_Id : Entity_Id)
12062 procedure Replace_Type_Ref (N : Node_Id);
12063 -- Substitute a single reference of the current instance of type Typ
12064 -- with a reference to Obj_Id.
12066 ----------------------
12067 -- Replace_Type_Ref --
12068 ----------------------
12070 procedure Replace_Type_Ref (N : Node_Id) is
12072 -- Decorate the reference to Typ even though it may be rewritten
12073 -- further down. This is done so that routines which examine
12074 -- properties of the Original_Node have some semantic information.
12076 if Nkind (N) = N_Identifier then
12077 Set_Entity (N, Typ);
12078 Set_Etype (N, Typ);
12080 elsif Nkind (N) = N_Selected_Component then
12081 Analyze (Prefix (N));
12082 Set_Entity (Selector_Name (N), Typ);
12083 Set_Etype (Selector_Name (N), Typ);
12086 -- Perform the following substitution:
12090 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
12091 Set_Comes_From_Source (N, True);
12092 end Replace_Type_Ref;
12094 procedure Replace_Type_Refs is
12095 new Replace_Type_References_Generic (Replace_Type_Ref);
12097 -- Start of processing for Replace_Type_References
12100 Replace_Type_Refs (Expr, Typ);
12101 end Replace_Type_References;
12103 ---------------------------
12104 -- Represented_As_Scalar --
12105 ---------------------------
12107 function Represented_As_Scalar (T : Entity_Id) return Boolean is
12108 UT : constant Entity_Id := Underlying_Type (T);
12110 return Is_Scalar_Type (UT)
12111 or else (Is_Bit_Packed_Array (UT)
12112 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
12113 end Represented_As_Scalar;
12115 ------------------------------
12116 -- Requires_Cleanup_Actions --
12117 ------------------------------
12119 function Requires_Cleanup_Actions
12121 Lib_Level : Boolean) return Boolean
12123 At_Lib_Level : constant Boolean :=
12125 and then Nkind_In (N, N_Package_Body,
12126 N_Package_Specification);
12127 -- N is at the library level if the top-most context is a package and
12128 -- the path taken to reach N does not include nonpackage constructs.
12132 when N_Accept_Statement
12133 | N_Block_Statement
12137 | N_Subprogram_Body
12141 Requires_Cleanup_Actions
12142 (L => Declarations (N),
12143 Lib_Level => At_Lib_Level,
12144 Nested_Constructs => True)
12146 (Present (Handled_Statement_Sequence (N))
12148 Requires_Cleanup_Actions
12150 Statements (Handled_Statement_Sequence (N)),
12151 Lib_Level => At_Lib_Level,
12152 Nested_Constructs => True));
12154 -- Extended return statements are the same as the above, except that
12155 -- there is no Declarations field. We do not want to clean up the
12156 -- Return_Object_Declarations.
12158 when N_Extended_Return_Statement =>
12160 Present (Handled_Statement_Sequence (N))
12161 and then Requires_Cleanup_Actions
12163 Statements (Handled_Statement_Sequence (N)),
12164 Lib_Level => At_Lib_Level,
12165 Nested_Constructs => True);
12167 when N_Package_Specification =>
12169 Requires_Cleanup_Actions
12170 (L => Visible_Declarations (N),
12171 Lib_Level => At_Lib_Level,
12172 Nested_Constructs => True)
12174 Requires_Cleanup_Actions
12175 (L => Private_Declarations (N),
12176 Lib_Level => At_Lib_Level,
12177 Nested_Constructs => True);
12180 raise Program_Error;
12182 end Requires_Cleanup_Actions;
12184 ------------------------------
12185 -- Requires_Cleanup_Actions --
12186 ------------------------------
12188 function Requires_Cleanup_Actions
12190 Lib_Level : Boolean;
12191 Nested_Constructs : Boolean) return Boolean
12195 Obj_Id : Entity_Id;
12196 Obj_Typ : Entity_Id;
12197 Pack_Id : Entity_Id;
12201 if No (L) or else Is_Empty_List (L) then
12206 while Present (Decl) loop
12208 -- Library-level tagged types
12210 if Nkind (Decl) = N_Full_Type_Declaration then
12211 Typ := Defining_Identifier (Decl);
12213 -- Ignored Ghost types do not need any cleanup actions because
12214 -- they will not appear in the final tree.
12216 if Is_Ignored_Ghost_Entity (Typ) then
12219 elsif Is_Tagged_Type (Typ)
12220 and then Is_Library_Level_Entity (Typ)
12221 and then Convention (Typ) = Convention_Ada
12222 and then Present (Access_Disp_Table (Typ))
12223 and then RTE_Available (RE_Unregister_Tag)
12224 and then not Is_Abstract_Type (Typ)
12225 and then not No_Run_Time_Mode
12230 -- Regular object declarations
12232 elsif Nkind (Decl) = N_Object_Declaration then
12233 Obj_Id := Defining_Identifier (Decl);
12234 Obj_Typ := Base_Type (Etype (Obj_Id));
12235 Expr := Expression (Decl);
12237 -- Bypass any form of processing for objects which have their
12238 -- finalization disabled. This applies only to objects at the
12241 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12244 -- Finalization of transient objects are treated separately in
12245 -- order to handle sensitive cases. These include:
12247 -- * Aggregate expansion
12248 -- * If, case, and expression with actions expansion
12249 -- * Transient scopes
12251 -- If one of those contexts has marked the transient object as
12252 -- ignored, do not generate finalization actions for it.
12254 elsif Is_Finalized_Transient (Obj_Id)
12255 or else Is_Ignored_Transient (Obj_Id)
12259 -- Ignored Ghost objects do not need any cleanup actions because
12260 -- they will not appear in the final tree.
12262 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12265 -- The object is of the form:
12266 -- Obj : [constant] Typ [:= Expr];
12268 -- Do not process tag-to-class-wide conversions because they do
12269 -- not yield an object. Do not process the incomplete view of a
12270 -- deferred constant. Note that an object initialized by means
12271 -- of a build-in-place function call may appear as a deferred
12272 -- constant after expansion activities. These kinds of objects
12273 -- must be finalized.
12275 elsif not Is_Imported (Obj_Id)
12276 and then Needs_Finalization (Obj_Typ)
12277 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
12278 and then not (Ekind (Obj_Id) = E_Constant
12279 and then not Has_Completion (Obj_Id)
12280 and then No (BIP_Initialization_Call (Obj_Id)))
12284 -- The object is of the form:
12285 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
12287 -- Obj : Access_Typ :=
12288 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
12290 elsif Is_Access_Type (Obj_Typ)
12291 and then Needs_Finalization
12292 (Available_View (Designated_Type (Obj_Typ)))
12293 and then Present (Expr)
12295 (Is_Secondary_Stack_BIP_Func_Call (Expr)
12297 (Is_Non_BIP_Func_Call (Expr)
12298 and then not Is_Related_To_Func_Return (Obj_Id)))
12302 -- Processing for "hook" objects generated for transient objects
12303 -- declared inside an Expression_With_Actions.
12305 elsif Is_Access_Type (Obj_Typ)
12306 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12307 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12308 N_Object_Declaration
12312 -- Processing for intermediate results of if expressions where
12313 -- one of the alternatives uses a controlled function call.
12315 elsif Is_Access_Type (Obj_Typ)
12316 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12317 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12318 N_Defining_Identifier
12319 and then Present (Expr)
12320 and then Nkind (Expr) = N_Null
12324 -- Simple protected objects which use type System.Tasking.
12325 -- Protected_Objects.Protection to manage their locks should be
12326 -- treated as controlled since they require manual cleanup.
12328 elsif Ekind (Obj_Id) = E_Variable
12329 and then (Is_Simple_Protected_Type (Obj_Typ)
12330 or else Has_Simple_Protected_Object (Obj_Typ))
12335 -- Specific cases of object renamings
12337 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
12338 Obj_Id := Defining_Identifier (Decl);
12339 Obj_Typ := Base_Type (Etype (Obj_Id));
12341 -- Bypass any form of processing for objects which have their
12342 -- finalization disabled. This applies only to objects at the
12345 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12348 -- Ignored Ghost object renamings do not need any cleanup actions
12349 -- because they will not appear in the final tree.
12351 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12354 -- Return object of a build-in-place function. This case is
12355 -- recognized and marked by the expansion of an extended return
12356 -- statement (see Expand_N_Extended_Return_Statement).
12358 elsif Needs_Finalization (Obj_Typ)
12359 and then Is_Return_Object (Obj_Id)
12360 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12364 -- Detect a case where a source object has been initialized by
12365 -- a controlled function call or another object which was later
12366 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
12368 -- Obj1 : CW_Type := Src_Obj;
12369 -- Obj2 : CW_Type := Function_Call (...);
12371 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
12372 -- Tmp : ... := Function_Call (...)'reference;
12373 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
12375 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
12379 -- Inspect the freeze node of an access-to-controlled type and look
12380 -- for a delayed finalization master. This case arises when the
12381 -- freeze actions are inserted at a later time than the expansion of
12382 -- the context. Since Build_Finalizer is never called on a single
12383 -- construct twice, the master will be ultimately left out and never
12384 -- finalized. This is also needed for freeze actions of designated
12385 -- types themselves, since in some cases the finalization master is
12386 -- associated with a designated type's freeze node rather than that
12387 -- of the access type (see handling for freeze actions in
12388 -- Build_Finalization_Master).
12390 elsif Nkind (Decl) = N_Freeze_Entity
12391 and then Present (Actions (Decl))
12393 Typ := Entity (Decl);
12395 -- Freeze nodes for ignored Ghost types do not need cleanup
12396 -- actions because they will never appear in the final tree.
12398 if Is_Ignored_Ghost_Entity (Typ) then
12401 elsif ((Is_Access_Type (Typ)
12402 and then not Is_Access_Subprogram_Type (Typ)
12403 and then Needs_Finalization
12404 (Available_View (Designated_Type (Typ))))
12405 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
12406 and then Requires_Cleanup_Actions
12407 (Actions (Decl), Lib_Level, Nested_Constructs)
12412 -- Nested package declarations
12414 elsif Nested_Constructs
12415 and then Nkind (Decl) = N_Package_Declaration
12417 Pack_Id := Defining_Entity (Decl);
12419 -- Do not inspect an ignored Ghost package because all code found
12420 -- within will not appear in the final tree.
12422 if Is_Ignored_Ghost_Entity (Pack_Id) then
12425 elsif Ekind (Pack_Id) /= E_Generic_Package
12426 and then Requires_Cleanup_Actions
12427 (Specification (Decl), Lib_Level)
12432 -- Nested package bodies
12434 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
12436 -- Do not inspect an ignored Ghost package body because all code
12437 -- found within will not appear in the final tree.
12439 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
12442 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
12443 and then Requires_Cleanup_Actions (Decl, Lib_Level)
12448 elsif Nkind (Decl) = N_Block_Statement
12451 -- Handle a rare case caused by a controlled transient object
12452 -- created as part of a record init proc. The variable is wrapped
12453 -- in a block, but the block is not associated with a transient
12458 -- Handle the case where the original context has been wrapped in
12459 -- a block to avoid interference between exception handlers and
12460 -- At_End handlers. Treat the block as transparent and process its
12463 or else Is_Finalization_Wrapper (Decl))
12465 if Requires_Cleanup_Actions (Decl, Lib_Level) then
12474 end Requires_Cleanup_Actions;
12476 ------------------------------------
12477 -- Safe_Unchecked_Type_Conversion --
12478 ------------------------------------
12480 -- Note: this function knows quite a bit about the exact requirements of
12481 -- Gigi with respect to unchecked type conversions, and its code must be
12482 -- coordinated with any changes in Gigi in this area.
12484 -- The above requirements should be documented in Sinfo ???
12486 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
12491 Pexp : constant Node_Id := Parent (Exp);
12494 -- If the expression is the RHS of an assignment or object declaration
12495 -- we are always OK because there will always be a target.
12497 -- Object renaming declarations, (generated for view conversions of
12498 -- actuals in inlined calls), like object declarations, provide an
12499 -- explicit type, and are safe as well.
12501 if (Nkind (Pexp) = N_Assignment_Statement
12502 and then Expression (Pexp) = Exp)
12503 or else Nkind_In (Pexp, N_Object_Declaration,
12504 N_Object_Renaming_Declaration)
12508 -- If the expression is the prefix of an N_Selected_Component we should
12509 -- also be OK because GCC knows to look inside the conversion except if
12510 -- the type is discriminated. We assume that we are OK anyway if the
12511 -- type is not set yet or if it is controlled since we can't afford to
12512 -- introduce a temporary in this case.
12514 elsif Nkind (Pexp) = N_Selected_Component
12515 and then Prefix (Pexp) = Exp
12517 if No (Etype (Pexp)) then
12521 not Has_Discriminants (Etype (Pexp))
12522 or else Is_Constrained (Etype (Pexp));
12526 -- Set the output type, this comes from Etype if it is set, otherwise we
12527 -- take it from the subtype mark, which we assume was already fully
12530 if Present (Etype (Exp)) then
12531 Otyp := Etype (Exp);
12533 Otyp := Entity (Subtype_Mark (Exp));
12536 -- The input type always comes from the expression, and we assume this
12537 -- is indeed always analyzed, so we can simply get the Etype.
12539 Ityp := Etype (Expression (Exp));
12541 -- Initialize alignments to unknown so far
12546 -- Replace a concurrent type by its corresponding record type and each
12547 -- type by its underlying type and do the tests on those. The original
12548 -- type may be a private type whose completion is a concurrent type, so
12549 -- find the underlying type first.
12551 if Present (Underlying_Type (Otyp)) then
12552 Otyp := Underlying_Type (Otyp);
12555 if Present (Underlying_Type (Ityp)) then
12556 Ityp := Underlying_Type (Ityp);
12559 if Is_Concurrent_Type (Otyp) then
12560 Otyp := Corresponding_Record_Type (Otyp);
12563 if Is_Concurrent_Type (Ityp) then
12564 Ityp := Corresponding_Record_Type (Ityp);
12567 -- If the base types are the same, we know there is no problem since
12568 -- this conversion will be a noop.
12570 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
12573 -- Same if this is an upwards conversion of an untagged type, and there
12574 -- are no constraints involved (could be more general???)
12576 elsif Etype (Ityp) = Otyp
12577 and then not Is_Tagged_Type (Ityp)
12578 and then not Has_Discriminants (Ityp)
12579 and then No (First_Rep_Item (Base_Type (Ityp)))
12583 -- If the expression has an access type (object or subprogram) we assume
12584 -- that the conversion is safe, because the size of the target is safe,
12585 -- even if it is a record (which might be treated as having unknown size
12588 elsif Is_Access_Type (Ityp) then
12591 -- If the size of output type is known at compile time, there is never
12592 -- a problem. Note that unconstrained records are considered to be of
12593 -- known size, but we can't consider them that way here, because we are
12594 -- talking about the actual size of the object.
12596 -- We also make sure that in addition to the size being known, we do not
12597 -- have a case which might generate an embarrassingly large temp in
12598 -- stack checking mode.
12600 elsif Size_Known_At_Compile_Time (Otyp)
12602 (not Stack_Checking_Enabled
12603 or else not May_Generate_Large_Temp (Otyp))
12604 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
12608 -- If either type is tagged, then we know the alignment is OK so Gigi
12609 -- will be able to use pointer punning.
12611 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
12614 -- If either type is a limited record type, we cannot do a copy, so say
12615 -- safe since there's nothing else we can do.
12617 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
12620 -- Conversions to and from packed array types are always ignored and
12623 elsif Is_Packed_Array_Impl_Type (Otyp)
12624 or else Is_Packed_Array_Impl_Type (Ityp)
12629 -- The only other cases known to be safe is if the input type's
12630 -- alignment is known to be at least the maximum alignment for the
12631 -- target or if both alignments are known and the output type's
12632 -- alignment is no stricter than the input's. We can use the component
12633 -- type alignment for an array if a type is an unpacked array type.
12635 if Present (Alignment_Clause (Otyp)) then
12636 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
12638 elsif Is_Array_Type (Otyp)
12639 and then Present (Alignment_Clause (Component_Type (Otyp)))
12641 Oalign := Expr_Value (Expression (Alignment_Clause
12642 (Component_Type (Otyp))));
12645 if Present (Alignment_Clause (Ityp)) then
12646 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
12648 elsif Is_Array_Type (Ityp)
12649 and then Present (Alignment_Clause (Component_Type (Ityp)))
12651 Ialign := Expr_Value (Expression (Alignment_Clause
12652 (Component_Type (Ityp))));
12655 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
12658 elsif Ialign /= No_Uint
12659 and then Oalign /= No_Uint
12660 and then Ialign <= Oalign
12664 -- Otherwise, Gigi cannot handle this and we must make a temporary
12669 end Safe_Unchecked_Type_Conversion;
12671 ---------------------------------
12672 -- Set_Current_Value_Condition --
12673 ---------------------------------
12675 -- Note: the implementation of this procedure is very closely tied to the
12676 -- implementation of Get_Current_Value_Condition. Here we set required
12677 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
12678 -- them, so they must have a consistent view.
12680 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
12682 procedure Set_Entity_Current_Value (N : Node_Id);
12683 -- If N is an entity reference, where the entity is of an appropriate
12684 -- kind, then set the current value of this entity to Cnode, unless
12685 -- there is already a definite value set there.
12687 procedure Set_Expression_Current_Value (N : Node_Id);
12688 -- If N is of an appropriate form, sets an appropriate entry in current
12689 -- value fields of relevant entities. Multiple entities can be affected
12690 -- in the case of an AND or AND THEN.
12692 ------------------------------
12693 -- Set_Entity_Current_Value --
12694 ------------------------------
12696 procedure Set_Entity_Current_Value (N : Node_Id) is
12698 if Is_Entity_Name (N) then
12700 Ent : constant Entity_Id := Entity (N);
12703 -- Don't capture if not safe to do so
12705 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
12709 -- Here we have a case where the Current_Value field may need
12710 -- to be set. We set it if it is not already set to a compile
12711 -- time expression value.
12713 -- Note that this represents a decision that one condition
12714 -- blots out another previous one. That's certainly right if
12715 -- they occur at the same level. If the second one is nested,
12716 -- then the decision is neither right nor wrong (it would be
12717 -- equally OK to leave the outer one in place, or take the new
12718 -- inner one. Really we should record both, but our data
12719 -- structures are not that elaborate.
12721 if Nkind (Current_Value (Ent)) not in N_Subexpr then
12722 Set_Current_Value (Ent, Cnode);
12726 end Set_Entity_Current_Value;
12728 ----------------------------------
12729 -- Set_Expression_Current_Value --
12730 ----------------------------------
12732 procedure Set_Expression_Current_Value (N : Node_Id) is
12738 -- Loop to deal with (ignore for now) any NOT operators present. The
12739 -- presence of NOT operators will be handled properly when we call
12740 -- Get_Current_Value_Condition.
12742 while Nkind (Cond) = N_Op_Not loop
12743 Cond := Right_Opnd (Cond);
12746 -- For an AND or AND THEN, recursively process operands
12748 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
12749 Set_Expression_Current_Value (Left_Opnd (Cond));
12750 Set_Expression_Current_Value (Right_Opnd (Cond));
12754 -- Check possible relational operator
12756 if Nkind (Cond) in N_Op_Compare then
12757 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
12758 Set_Entity_Current_Value (Left_Opnd (Cond));
12759 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
12760 Set_Entity_Current_Value (Right_Opnd (Cond));
12763 elsif Nkind_In (Cond,
12765 N_Qualified_Expression,
12766 N_Expression_With_Actions)
12768 Set_Expression_Current_Value (Expression (Cond));
12770 -- Check possible boolean variable reference
12773 Set_Entity_Current_Value (Cond);
12775 end Set_Expression_Current_Value;
12777 -- Start of processing for Set_Current_Value_Condition
12780 Set_Expression_Current_Value (Condition (Cnode));
12781 end Set_Current_Value_Condition;
12783 --------------------------
12784 -- Set_Elaboration_Flag --
12785 --------------------------
12787 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
12788 Loc : constant Source_Ptr := Sloc (N);
12789 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
12793 if Present (Ent) then
12795 -- Nothing to do if at the compilation unit level, because in this
12796 -- case the flag is set by the binder generated elaboration routine.
12798 if Nkind (Parent (N)) = N_Compilation_Unit then
12801 -- Here we do need to generate an assignment statement
12804 Check_Restriction (No_Elaboration_Code, N);
12807 Make_Assignment_Statement (Loc,
12808 Name => New_Occurrence_Of (Ent, Loc),
12809 Expression => Make_Integer_Literal (Loc, Uint_1));
12811 -- Mark the assignment statement as elaboration code. This allows
12812 -- the early call region mechanism (see Sem_Elab) to properly
12813 -- ignore such assignments even though they are nonpreelaborable
12816 Set_Is_Elaboration_Code (Asn);
12818 if Nkind (Parent (N)) = N_Subunit then
12819 Insert_After (Corresponding_Stub (Parent (N)), Asn);
12821 Insert_After (N, Asn);
12826 -- Kill current value indication. This is necessary because the
12827 -- tests of this flag are inserted out of sequence and must not
12828 -- pick up bogus indications of the wrong constant value.
12830 Set_Current_Value (Ent, Empty);
12832 -- If the subprogram is in the current declarative part and
12833 -- 'access has been applied to it, generate an elaboration
12834 -- check at the beginning of the declarations of the body.
12836 if Nkind (N) = N_Subprogram_Body
12837 and then Address_Taken (Spec_Id)
12839 Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function)
12842 Loc : constant Source_Ptr := Sloc (N);
12843 Decls : constant List_Id := Declarations (N);
12847 -- No need to generate this check if first entry in the
12848 -- declaration list is a raise of Program_Error now.
12851 and then Nkind (First (Decls)) = N_Raise_Program_Error
12856 -- Otherwise generate the check
12859 Make_Raise_Program_Error (Loc,
12862 Left_Opnd => New_Occurrence_Of (Ent, Loc),
12863 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
12864 Reason => PE_Access_Before_Elaboration);
12867 Set_Declarations (N, New_List (Chk));
12869 Prepend (Chk, Decls);
12877 end Set_Elaboration_Flag;
12879 ----------------------------
12880 -- Set_Renamed_Subprogram --
12881 ----------------------------
12883 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
12885 -- If input node is an identifier, we can just reset it
12887 if Nkind (N) = N_Identifier then
12888 Set_Chars (N, Chars (E));
12891 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
12895 CS : constant Boolean := Comes_From_Source (N);
12897 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
12899 Set_Comes_From_Source (N, CS);
12900 Set_Analyzed (N, True);
12903 end Set_Renamed_Subprogram;
12905 ----------------------
12906 -- Side_Effect_Free --
12907 ----------------------
12909 function Side_Effect_Free
12911 Name_Req : Boolean := False;
12912 Variable_Ref : Boolean := False) return Boolean
12914 Typ : constant Entity_Id := Etype (N);
12915 -- Result type of the expression
12917 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
12918 -- The argument N is a construct where the Prefix is dereferenced if it
12919 -- is an access type and the result is a variable. The call returns True
12920 -- if the construct is side effect free (not considering side effects in
12921 -- other than the prefix which are to be tested by the caller).
12923 function Within_In_Parameter (N : Node_Id) return Boolean;
12924 -- Determines if N is a subcomponent of a composite in-parameter. If so,
12925 -- N is not side-effect free when the actual is global and modifiable
12926 -- indirectly from within a subprogram, because it may be passed by
12927 -- reference. The front-end must be conservative here and assume that
12928 -- this may happen with any array or record type. On the other hand, we
12929 -- cannot create temporaries for all expressions for which this
12930 -- condition is true, for various reasons that might require clearing up
12931 -- ??? For example, discriminant references that appear out of place, or
12932 -- spurious type errors with class-wide expressions. As a result, we
12933 -- limit the transformation to loop bounds, which is so far the only
12934 -- case that requires it.
12936 -----------------------------
12937 -- Safe_Prefixed_Reference --
12938 -----------------------------
12940 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
12942 -- If prefix is not side effect free, definitely not safe
12944 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
12947 -- If the prefix is of an access type that is not access-to-constant,
12948 -- then this construct is a variable reference, which means it is to
12949 -- be considered to have side effects if Variable_Ref is set True.
12951 elsif Is_Access_Type (Etype (Prefix (N)))
12952 and then not Is_Access_Constant (Etype (Prefix (N)))
12953 and then Variable_Ref
12955 -- Exception is a prefix that is the result of a previous removal
12956 -- of side effects.
12958 return Is_Entity_Name (Prefix (N))
12959 and then not Comes_From_Source (Prefix (N))
12960 and then Ekind (Entity (Prefix (N))) = E_Constant
12961 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
12963 -- If the prefix is an explicit dereference then this construct is a
12964 -- variable reference, which means it is to be considered to have
12965 -- side effects if Variable_Ref is True.
12967 -- We do NOT exclude dereferences of access-to-constant types because
12968 -- we handle them as constant view of variables.
12970 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
12971 and then Variable_Ref
12975 -- Note: The following test is the simplest way of solving a complex
12976 -- problem uncovered by the following test (Side effect on loop bound
12977 -- that is a subcomponent of a global variable:
12979 -- with Text_Io; use Text_Io;
12980 -- procedure Tloop is
12983 -- V : Natural := 4;
12984 -- S : String (1..5) := (others => 'a');
12991 -- with procedure Action;
12992 -- procedure Loop_G (Arg : X; Msg : String)
12994 -- procedure Loop_G (Arg : X; Msg : String) is
12996 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
12997 -- & Natural'Image (Arg.V));
12998 -- for Index in 1 .. Arg.V loop
12999 -- Text_Io.Put_Line
13000 -- (Natural'Image (Index) & " " & Arg.S (Index));
13001 -- if Index > 2 then
13005 -- Put_Line ("end loop_g " & Msg);
13008 -- procedure Loop1 is new Loop_G (Modi);
13009 -- procedure Modi is
13012 -- Loop1 (X1, "from modi");
13016 -- Loop1 (X1, "initial");
13019 -- The output of the above program should be:
13021 -- begin loop_g initial will loop till: 4
13025 -- begin loop_g from modi will loop till: 1
13027 -- end loop_g from modi
13029 -- begin loop_g from modi will loop till: 1
13031 -- end loop_g from modi
13032 -- end loop_g initial
13034 -- If a loop bound is a subcomponent of a global variable, a
13035 -- modification of that variable within the loop may incorrectly
13036 -- affect the execution of the loop.
13038 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
13039 and then Within_In_Parameter (Prefix (N))
13040 and then Variable_Ref
13044 -- All other cases are side effect free
13049 end Safe_Prefixed_Reference;
13051 -------------------------
13052 -- Within_In_Parameter --
13053 -------------------------
13055 function Within_In_Parameter (N : Node_Id) return Boolean is
13057 if not Comes_From_Source (N) then
13060 elsif Is_Entity_Name (N) then
13061 return Ekind (Entity (N)) = E_In_Parameter;
13063 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
13064 return Within_In_Parameter (Prefix (N));
13069 end Within_In_Parameter;
13071 -- Start of processing for Side_Effect_Free
13074 -- If volatile reference, always consider it to have side effects
13076 if Is_Volatile_Reference (N) then
13080 -- Note on checks that could raise Constraint_Error. Strictly, if we
13081 -- take advantage of 11.6, these checks do not count as side effects.
13082 -- However, we would prefer to consider that they are side effects,
13083 -- since the back end CSE does not work very well on expressions which
13084 -- can raise Constraint_Error. On the other hand if we don't consider
13085 -- them to be side effect free, then we get some awkward expansions
13086 -- in -gnato mode, resulting in code insertions at a point where we
13087 -- do not have a clear model for performing the insertions.
13089 -- Special handling for entity names
13091 if Is_Entity_Name (N) then
13093 -- A type reference is always side effect free
13095 if Is_Type (Entity (N)) then
13098 -- Variables are considered to be a side effect if Variable_Ref
13099 -- is set or if we have a volatile reference and Name_Req is off.
13100 -- If Name_Req is True then we can't help returning a name which
13101 -- effectively allows multiple references in any case.
13103 elsif Is_Variable (N, Use_Original_Node => False) then
13104 return not Variable_Ref
13105 and then (not Is_Volatile_Reference (N) or else Name_Req);
13107 -- Any other entity (e.g. a subtype name) is definitely side
13114 -- A value known at compile time is always side effect free
13116 elsif Compile_Time_Known_Value (N) then
13119 -- A variable renaming is not side-effect free, because the renaming
13120 -- will function like a macro in the front-end in some cases, and an
13121 -- assignment can modify the component designated by N, so we need to
13122 -- create a temporary for it.
13124 -- The guard testing for Entity being present is needed at least in
13125 -- the case of rewritten predicate expressions, and may well also be
13126 -- appropriate elsewhere. Obviously we can't go testing the entity
13127 -- field if it does not exist, so it's reasonable to say that this is
13128 -- not the renaming case if it does not exist.
13130 elsif Is_Entity_Name (Original_Node (N))
13131 and then Present (Entity (Original_Node (N)))
13132 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
13133 and then Ekind (Entity (Original_Node (N))) /= E_Constant
13136 RO : constant Node_Id :=
13137 Renamed_Object (Entity (Original_Node (N)));
13140 -- If the renamed object is an indexed component, or an
13141 -- explicit dereference, then the designated object could
13142 -- be modified by an assignment.
13144 if Nkind_In (RO, N_Indexed_Component,
13145 N_Explicit_Dereference)
13149 -- A selected component must have a safe prefix
13151 elsif Nkind (RO) = N_Selected_Component then
13152 return Safe_Prefixed_Reference (RO);
13154 -- In all other cases, designated object cannot be changed so
13155 -- we are side effect free.
13162 -- Remove_Side_Effects generates an object renaming declaration to
13163 -- capture the expression of a class-wide expression. In VM targets
13164 -- the frontend performs no expansion for dispatching calls to
13165 -- class- wide types since they are handled by the VM. Hence, we must
13166 -- locate here if this node corresponds to a previous invocation of
13167 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
13169 elsif not Tagged_Type_Expansion
13170 and then not Comes_From_Source (N)
13171 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
13172 and then Is_Class_Wide_Type (Typ)
13176 -- Generating C the type conversion of an access to constrained array
13177 -- type into an access to unconstrained array type involves initializing
13178 -- a fat pointer and the expression cannot be assumed to be free of side
13179 -- effects since it must referenced several times to compute its bounds.
13181 elsif Modify_Tree_For_C
13182 and then Nkind (N) = N_Type_Conversion
13183 and then Is_Access_Type (Typ)
13184 and then Is_Array_Type (Designated_Type (Typ))
13185 and then not Is_Constrained (Designated_Type (Typ))
13190 -- For other than entity names and compile time known values,
13191 -- check the node kind for special processing.
13195 -- An attribute reference is side-effect free if its expressions
13196 -- are side-effect free and its prefix is side-effect free or is
13197 -- an entity reference.
13199 when N_Attribute_Reference =>
13200 return Side_Effect_Free_Attribute (Attribute_Name (N))
13202 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13204 (Is_Entity_Name (Prefix (N))
13206 Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
13208 -- A binary operator is side effect free if and both operands are
13209 -- side effect free. For this purpose binary operators include
13210 -- membership tests and short circuit forms.
13213 | N_Membership_Test
13216 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13218 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13220 -- An explicit dereference is side effect free only if it is
13221 -- a side effect free prefixed reference.
13223 when N_Explicit_Dereference =>
13224 return Safe_Prefixed_Reference (N);
13226 -- An expression with action is side effect free if its expression
13227 -- is side effect free and it has no actions.
13229 when N_Expression_With_Actions =>
13231 Is_Empty_List (Actions (N))
13232 and then Side_Effect_Free
13233 (Expression (N), Name_Req, Variable_Ref);
13235 -- A call to _rep_to_pos is side effect free, since we generate
13236 -- this pure function call ourselves. Moreover it is critically
13237 -- important to make this exception, since otherwise we can have
13238 -- discriminants in array components which don't look side effect
13239 -- free in the case of an array whose index type is an enumeration
13240 -- type with an enumeration rep clause.
13242 -- All other function calls are not side effect free
13244 when N_Function_Call =>
13246 Nkind (Name (N)) = N_Identifier
13247 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
13248 and then Side_Effect_Free
13249 (First (Parameter_Associations (N)),
13250 Name_Req, Variable_Ref);
13252 -- An IF expression is side effect free if it's of a scalar type, and
13253 -- all its components are all side effect free (conditions and then
13254 -- actions and else actions). We restrict to scalar types, since it
13255 -- is annoying to deal with things like (if A then B else C)'First
13256 -- where the type involved is a string type.
13258 when N_If_Expression =>
13260 Is_Scalar_Type (Typ)
13261 and then Side_Effect_Free
13262 (Expressions (N), Name_Req, Variable_Ref);
13264 -- An indexed component is side effect free if it is a side
13265 -- effect free prefixed reference and all the indexing
13266 -- expressions are side effect free.
13268 when N_Indexed_Component =>
13270 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13271 and then Safe_Prefixed_Reference (N);
13273 -- A type qualification, type conversion, or unchecked expression is
13274 -- side effect free if the expression is side effect free.
13276 when N_Qualified_Expression
13277 | N_Type_Conversion
13278 | N_Unchecked_Expression
13280 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
13282 -- A selected component is side effect free only if it is a side
13283 -- effect free prefixed reference.
13285 when N_Selected_Component =>
13286 return Safe_Prefixed_Reference (N);
13288 -- A range is side effect free if the bounds are side effect free
13291 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
13293 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
13295 -- A slice is side effect free if it is a side effect free
13296 -- prefixed reference and the bounds are side effect free.
13300 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
13301 and then Safe_Prefixed_Reference (N);
13303 -- A unary operator is side effect free if the operand
13304 -- is side effect free.
13307 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13309 -- An unchecked type conversion is side effect free only if it
13310 -- is safe and its argument is side effect free.
13312 when N_Unchecked_Type_Conversion =>
13314 Safe_Unchecked_Type_Conversion (N)
13315 and then Side_Effect_Free
13316 (Expression (N), Name_Req, Variable_Ref);
13318 -- A literal is side effect free
13320 when N_Character_Literal
13321 | N_Integer_Literal
13327 -- We consider that anything else has side effects. This is a bit
13328 -- crude, but we are pretty close for most common cases, and we
13329 -- are certainly correct (i.e. we never return True when the
13330 -- answer should be False).
13335 end Side_Effect_Free;
13337 -- A list is side effect free if all elements of the list are side
13340 function Side_Effect_Free
13342 Name_Req : Boolean := False;
13343 Variable_Ref : Boolean := False) return Boolean
13348 if L = No_List or else L = Error_List then
13353 while Present (N) loop
13354 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
13363 end Side_Effect_Free;
13365 --------------------------------
13366 -- Side_Effect_Free_Attribute --
13367 --------------------------------
13369 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
13378 | Name_Wide_Wide_Image
13380 -- CodePeer doesn't want to see replicated copies of 'Image calls
13382 return not CodePeer_Mode;
13387 end Side_Effect_Free_Attribute;
13389 ----------------------------------
13390 -- Silly_Boolean_Array_Not_Test --
13391 ----------------------------------
13393 -- This procedure implements an odd and silly test. We explicitly check
13394 -- for the case where the 'First of the component type is equal to the
13395 -- 'Last of this component type, and if this is the case, we make sure
13396 -- that constraint error is raised. The reason is that the NOT is bound
13397 -- to cause CE in this case, and we will not otherwise catch it.
13399 -- No such check is required for AND and OR, since for both these cases
13400 -- False op False = False, and True op True = True. For the XOR case,
13401 -- see Silly_Boolean_Array_Xor_Test.
13403 -- Believe it or not, this was reported as a bug. Note that nearly always,
13404 -- the test will evaluate statically to False, so the code will be
13405 -- statically removed, and no extra overhead caused.
13407 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
13408 Loc : constant Source_Ptr := Sloc (N);
13409 CT : constant Entity_Id := Component_Type (T);
13412 -- The check we install is
13414 -- constraint_error when
13415 -- component_type'first = component_type'last
13416 -- and then array_type'Length /= 0)
13418 -- We need the last guard because we don't want to raise CE for empty
13419 -- arrays since no out of range values result. (Empty arrays with a
13420 -- component type of True .. True -- very useful -- even the ACATS
13421 -- does not test that marginal case).
13424 Make_Raise_Constraint_Error (Loc,
13426 Make_And_Then (Loc,
13430 Make_Attribute_Reference (Loc,
13431 Prefix => New_Occurrence_Of (CT, Loc),
13432 Attribute_Name => Name_First),
13435 Make_Attribute_Reference (Loc,
13436 Prefix => New_Occurrence_Of (CT, Loc),
13437 Attribute_Name => Name_Last)),
13439 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
13440 Reason => CE_Range_Check_Failed));
13441 end Silly_Boolean_Array_Not_Test;
13443 ----------------------------------
13444 -- Silly_Boolean_Array_Xor_Test --
13445 ----------------------------------
13447 -- This procedure implements an odd and silly test. We explicitly check
13448 -- for the XOR case where the component type is True .. True, since this
13449 -- will raise constraint error. A special check is required since CE
13450 -- will not be generated otherwise (cf Expand_Packed_Not).
13452 -- No such check is required for AND and OR, since for both these cases
13453 -- False op False = False, and True op True = True, and no check is
13454 -- required for the case of False .. False, since False xor False = False.
13455 -- See also Silly_Boolean_Array_Not_Test
13457 procedure Silly_Boolean_Array_Xor_Test
13462 Loc : constant Source_Ptr := Sloc (N);
13463 CT : constant Entity_Id := Component_Type (T);
13466 -- The check we install is
13468 -- constraint_error when
13469 -- Boolean (component_type'First)
13470 -- and then Boolean (component_type'Last)
13471 -- and then array_type'Length /= 0)
13473 -- We need the last guard because we don't want to raise CE for empty
13474 -- arrays since no out of range values result (Empty arrays with a
13475 -- component type of True .. True -- very useful -- even the ACATS
13476 -- does not test that marginal case).
13479 Make_Raise_Constraint_Error (Loc,
13481 Make_And_Then (Loc,
13483 Make_And_Then (Loc,
13485 Convert_To (Standard_Boolean,
13486 Make_Attribute_Reference (Loc,
13487 Prefix => New_Occurrence_Of (CT, Loc),
13488 Attribute_Name => Name_First)),
13491 Convert_To (Standard_Boolean,
13492 Make_Attribute_Reference (Loc,
13493 Prefix => New_Occurrence_Of (CT, Loc),
13494 Attribute_Name => Name_Last))),
13496 Right_Opnd => Make_Non_Empty_Check (Loc, R)),
13497 Reason => CE_Range_Check_Failed));
13498 end Silly_Boolean_Array_Xor_Test;
13500 --------------------------
13501 -- Target_Has_Fixed_Ops --
13502 --------------------------
13504 Integer_Sized_Small : Ureal;
13505 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
13506 -- called (we don't want to compute it more than once).
13508 Long_Integer_Sized_Small : Ureal;
13509 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
13510 -- is called (we don't want to compute it more than once)
13512 First_Time_For_THFO : Boolean := True;
13513 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
13515 function Target_Has_Fixed_Ops
13516 (Left_Typ : Entity_Id;
13517 Right_Typ : Entity_Id;
13518 Result_Typ : Entity_Id) return Boolean
13520 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
13521 -- Return True if the given type is a fixed-point type with a small
13522 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
13523 -- an absolute value less than 1.0. This is currently limited to
13524 -- fixed-point types that map to Integer or Long_Integer.
13526 ------------------------
13527 -- Is_Fractional_Type --
13528 ------------------------
13530 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
13532 if Esize (Typ) = Standard_Integer_Size then
13533 return Small_Value (Typ) = Integer_Sized_Small;
13535 elsif Esize (Typ) = Standard_Long_Integer_Size then
13536 return Small_Value (Typ) = Long_Integer_Sized_Small;
13541 end Is_Fractional_Type;
13543 -- Start of processing for Target_Has_Fixed_Ops
13546 -- Return False if Fractional_Fixed_Ops_On_Target is false
13548 if not Fractional_Fixed_Ops_On_Target then
13552 -- Here the target has Fractional_Fixed_Ops, if first time, compute
13553 -- standard constants used by Is_Fractional_Type.
13555 if First_Time_For_THFO then
13556 First_Time_For_THFO := False;
13558 Integer_Sized_Small :=
13561 Den => UI_From_Int (Standard_Integer_Size - 1),
13564 Long_Integer_Sized_Small :=
13567 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
13571 -- Return True if target supports fixed-by-fixed multiply/divide for
13572 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
13573 -- and result types are equivalent fractional types.
13575 return Is_Fractional_Type (Base_Type (Left_Typ))
13576 and then Is_Fractional_Type (Base_Type (Right_Typ))
13577 and then Is_Fractional_Type (Base_Type (Result_Typ))
13578 and then Esize (Left_Typ) = Esize (Right_Typ)
13579 and then Esize (Left_Typ) = Esize (Result_Typ);
13580 end Target_Has_Fixed_Ops;
13582 -------------------
13583 -- Type_Map_Hash --
13584 -------------------
13586 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
13588 return Type_Map_Header (Id mod Type_Map_Size);
13591 ------------------------------------------
13592 -- Type_May_Have_Bit_Aligned_Components --
13593 ------------------------------------------
13595 function Type_May_Have_Bit_Aligned_Components
13596 (Typ : Entity_Id) return Boolean
13599 -- Array type, check component type
13601 if Is_Array_Type (Typ) then
13603 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
13605 -- Record type, check components
13607 elsif Is_Record_Type (Typ) then
13612 E := First_Component_Or_Discriminant (Typ);
13613 while Present (E) loop
13614 -- This is the crucial test: if the component itself causes
13615 -- trouble, then we can stop and return True.
13617 if Component_May_Be_Bit_Aligned (E) then
13621 -- Otherwise, we need to test its type, to see if it may
13622 -- itself contain a troublesome component.
13624 if Type_May_Have_Bit_Aligned_Components (Etype (E)) then
13628 Next_Component_Or_Discriminant (E);
13634 -- Type other than array or record is always OK
13639 end Type_May_Have_Bit_Aligned_Components;
13641 -------------------------------
13642 -- Update_Primitives_Mapping --
13643 -------------------------------
13645 procedure Update_Primitives_Mapping
13646 (Inher_Id : Entity_Id;
13647 Subp_Id : Entity_Id)
13651 (Parent_Type => Find_Dispatching_Type (Inher_Id),
13652 Derived_Type => Find_Dispatching_Type (Subp_Id));
13653 end Update_Primitives_Mapping;
13655 ----------------------------------
13656 -- Within_Case_Or_If_Expression --
13657 ----------------------------------
13659 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
13663 -- Locate an enclosing case or if expression. Note that these constructs
13664 -- can be expanded into Expression_With_Actions, hence the test of the
13668 while Present (Par) loop
13669 if Nkind_In (Original_Node (Par), N_Case_Expression,
13674 -- Prevent the search from going too far
13676 elsif Is_Body_Or_Package_Declaration (Par) then
13680 Par := Parent (Par);
13684 end Within_Case_Or_If_Expression;
13686 --------------------------------
13687 -- Within_Internal_Subprogram --
13688 --------------------------------
13690 function Within_Internal_Subprogram return Boolean is
13694 S := Current_Scope;
13695 while Present (S) and then not Is_Subprogram (S) loop
13700 and then Get_TSS_Name (S) /= TSS_Null
13701 and then not Is_Predicate_Function (S)
13702 and then not Is_Predicate_Function_M (S);
13703 end Within_Internal_Subprogram;