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_Ch6; use Exp_Ch6;
36 with Exp_Ch7; use Exp_Ch7;
37 with Exp_Ch11; use Exp_Ch11;
38 with Ghost; use Ghost;
39 with Inline; use Inline;
40 with Itypes; use Itypes;
42 with Nlists; use Nlists;
43 with Nmake; use Nmake;
45 with Restrict; use Restrict;
46 with Rident; use Rident;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch6; use Sem_Ch6;
51 with Sem_Ch8; use Sem_Ch8;
52 with Sem_Ch12; use Sem_Ch12;
53 with Sem_Ch13; use Sem_Ch13;
54 with Sem_Disp; use Sem_Disp;
55 with Sem_Elab; use Sem_Elab;
56 with Sem_Eval; use Sem_Eval;
57 with Sem_Res; use Sem_Res;
58 with Sem_Type; use Sem_Type;
59 with Sem_Util; use Sem_Util;
60 with Snames; use Snames;
61 with Stand; use Stand;
62 with Stringt; use Stringt;
63 with Targparm; use Targparm;
64 with Tbuild; use Tbuild;
65 with Ttypes; use Ttypes;
66 with Urealp; use Urealp;
67 with Validsw; use Validsw;
70 package body Exp_Util is
72 ---------------------------------------------------------
73 -- Handling of inherited class-wide pre/postconditions --
74 ---------------------------------------------------------
76 -- Following AI12-0113, the expression for a class-wide condition is
77 -- transformed for a subprogram that inherits it, by replacing calls
78 -- to primitive operations of the original controlling type into the
79 -- corresponding overriding operations of the derived type. The following
80 -- hash table manages this mapping, and is expanded on demand whenever
81 -- such inherited expression needs to be constructed.
83 -- The mapping is also used to check whether an inherited operation has
84 -- a condition that depends on overridden operations. For such an
85 -- operation we must create a wrapper that is then treated as a normal
86 -- overriding. In SPARK mode such operations are illegal.
88 -- For a given root type there may be several type extensions with their
89 -- own overriding operations, so at various times a given operation of
90 -- the root will be mapped into different overridings. The root type is
91 -- also mapped into the current type extension to indicate that its
92 -- operations are mapped into the overriding operations of that current
95 -- The contents of the map are as follows:
99 -- Discriminant (Entity_Id) Discriminant (Entity_Id)
100 -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
101 -- Discriminant (Entity_Id) Expression (Node_Id)
102 -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
103 -- Type (Entity_Id) Type (Entity_Id)
105 Type_Map_Size : constant := 511;
107 subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
108 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
110 package Type_Map is new GNAT.HTable.Simple_HTable
111 (Header_Num => Type_Map_Header,
113 Element => Node_Or_Entity_Id,
115 Hash => Type_Map_Hash,
118 -----------------------
119 -- Local Subprograms --
120 -----------------------
122 function Build_Task_Array_Image
126 Dyn : Boolean := False) return Node_Id;
127 -- Build function to generate the image string for a task that is an array
128 -- component, concatenating the images of each index. To avoid storage
129 -- leaks, the string is built with successive slice assignments. The flag
130 -- Dyn indicates whether this is called for the initialization procedure of
131 -- an array of tasks, or for the name of a dynamically created task that is
132 -- assigned to an indexed component.
134 function Build_Task_Image_Function
138 Res : Entity_Id) return Node_Id;
139 -- Common processing for Task_Array_Image and Task_Record_Image. Build
140 -- function body that computes image.
142 procedure Build_Task_Image_Prefix
151 -- Common processing for Task_Array_Image and Task_Record_Image. Create
152 -- local variables and assign prefix of name to result string.
154 function Build_Task_Record_Image
157 Dyn : Boolean := False) return Node_Id;
158 -- Build function to generate the image string for a task that is a record
159 -- component. Concatenate name of variable with that of selector. The flag
160 -- Dyn indicates whether this is called for the initialization procedure of
161 -- record with task components, or for a dynamically created task that is
162 -- assigned to a selected component.
164 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
165 -- Force evaluation of bounds of a slice, which may be given by a range
166 -- or by a subtype indication with or without a constraint.
168 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
169 -- Determine whether pragma Default_Initial_Condition denoted by Prag has
170 -- an assertion expression that should be verified at run time.
172 function Is_Uninitialized_Aggregate
174 T : Entity_Id) return Boolean;
175 -- Determine whether an array aggregate used in an object declaration
176 -- is uninitialized, when the aggregate is declared with a box and
177 -- the component type has no default value. Such an aggregate can be
178 -- optimized away to prevent the copying of uninitialized data, and
179 -- the bounds of the aggregate can be propagated directly to the
180 -- object declaration.
182 function Make_CW_Equivalent_Type
184 E : Node_Id) return Entity_Id;
185 -- T is a class-wide type entity, E is the initial expression node that
186 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
187 -- returns the entity of the Equivalent type and inserts on the fly the
188 -- necessary declaration such as:
190 -- type anon is record
191 -- _parent : Root_Type (T); constrained with E discriminants (if any)
192 -- Extension : String (1 .. expr to match size of E);
195 -- This record is compatible with any object of the class of T thanks to
196 -- the first field and has the same size as E thanks to the second.
198 function Make_Literal_Range
200 Literal_Typ : Entity_Id) return Node_Id;
201 -- Produce a Range node whose bounds are:
202 -- Low_Bound (Literal_Type) ..
203 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
204 -- this is used for expanding declarations like X : String := "sdfgdfg";
206 -- If the index type of the target array is not integer, we generate:
207 -- Low_Bound (Literal_Type) ..
209 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
210 -- + (Length (Literal_Typ) -1))
212 function Make_Non_Empty_Check
214 N : Node_Id) return Node_Id;
215 -- Produce a boolean expression checking that the unidimensional array
216 -- node N is not empty.
218 function New_Class_Wide_Subtype
220 N : Node_Id) return Entity_Id;
221 -- Create an implicit subtype of CW_Typ attached to node N
223 function Requires_Cleanup_Actions
226 Nested_Constructs : Boolean) return Boolean;
227 -- Given a list L, determine whether it contains one of the following:
229 -- 1) controlled objects
230 -- 2) library-level tagged types
232 -- Lib_Level is True when the list comes from a construct at the library
233 -- level, and False otherwise. Nested_Constructs is True when any nested
234 -- packages declared in L must be processed, and False otherwise.
236 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean;
237 -- Return True if the evaluation of the given attribute is considered
238 -- side-effect free, independently of its prefix and expressions.
240 -------------------------------------
241 -- Activate_Atomic_Synchronization --
242 -------------------------------------
244 procedure Activate_Atomic_Synchronization (N : Node_Id) is
248 case Nkind (Parent (N)) is
250 -- Check for cases of appearing in the prefix of a construct where we
251 -- don't need atomic synchronization for this kind of usage.
254 -- Nothing to do if we are the prefix of an attribute, since we
255 -- do not want an atomic sync operation for things like 'Size.
257 N_Attribute_Reference
259 -- The N_Reference node is like an attribute
263 -- Nothing to do for a reference to a component (or components)
264 -- of a composite object. Only reads and updates of the object
265 -- as a whole require atomic synchronization (RM C.6 (15)).
267 | N_Indexed_Component
268 | N_Selected_Component
271 -- For all the above cases, nothing to do if we are the prefix
273 if Prefix (Parent (N)) = N then
281 -- Nothing to do for the identifier in an object renaming declaration,
282 -- the renaming itself does not need atomic synchronization.
284 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
288 -- Go ahead and set the flag
290 Set_Atomic_Sync_Required (N);
292 -- Generate info message if requested
294 if Warn_On_Atomic_Synchronization then
300 | N_Selected_Component
302 Msg_Node := Selector_Name (N);
304 when N_Explicit_Dereference
305 | N_Indexed_Component
310 pragma Assert (False);
314 if Present (Msg_Node) then
316 ("info: atomic synchronization set for &?N?", Msg_Node);
319 ("info: atomic synchronization set?N?", N);
322 end Activate_Atomic_Synchronization;
324 ----------------------
325 -- Adjust_Condition --
326 ----------------------
328 procedure Adjust_Condition (N : Node_Id) is
335 Loc : constant Source_Ptr := Sloc (N);
336 T : constant Entity_Id := Etype (N);
339 -- Defend against a call where the argument has no type, or has a
340 -- type that is not Boolean. This can occur because of prior errors.
342 if No (T) or else not Is_Boolean_Type (T) then
346 -- Apply validity checking if needed
348 if Validity_Checks_On and Validity_Check_Tests then
352 -- Immediate return if standard boolean, the most common case,
353 -- where nothing needs to be done.
355 if Base_Type (T) = Standard_Boolean then
359 -- Case of zero/nonzero semantics or nonstandard enumeration
360 -- representation. In each case, we rewrite the node as:
362 -- ityp!(N) /= False'Enum_Rep
364 -- where ityp is an integer type with large enough size to hold any
367 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
372 (Integer_Type_For (Esize (T), Uns => False), N),
374 Make_Attribute_Reference (Loc,
375 Attribute_Name => Name_Enum_Rep,
377 New_Occurrence_Of (First_Literal (T), Loc))));
378 Analyze_And_Resolve (N, Standard_Boolean);
381 Rewrite (N, Convert_To (Standard_Boolean, N));
382 Analyze_And_Resolve (N, Standard_Boolean);
385 end Adjust_Condition;
387 ------------------------
388 -- Adjust_Result_Type --
389 ------------------------
391 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
393 -- Ignore call if current type is not Standard.Boolean
395 if Etype (N) /= Standard_Boolean then
399 -- If result is already of correct type, nothing to do. Note that
400 -- this will get the most common case where everything has a type
401 -- of Standard.Boolean.
403 if Base_Type (T) = Standard_Boolean then
408 KP : constant Node_Kind := Nkind (Parent (N));
411 -- If result is to be used as a Condition in the syntax, no need
412 -- to convert it back, since if it was changed to Standard.Boolean
413 -- using Adjust_Condition, that is just fine for this usage.
415 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
418 -- If result is an operand of another logical operation, no need
419 -- to reset its type, since Standard.Boolean is just fine, and
420 -- such operations always do Adjust_Condition on their operands.
422 elsif KP in N_Op_Boolean
423 or else KP in N_Short_Circuit
424 or else KP = N_Op_Not
428 -- Otherwise we perform a conversion from the current type, which
429 -- must be Standard.Boolean, to the desired type. Use the base
430 -- type to prevent spurious constraint checks that are extraneous
431 -- to the transformation. The type and its base have the same
432 -- representation, standard or otherwise.
436 Rewrite (N, Convert_To (Base_Type (T), N));
437 Analyze_And_Resolve (N, Base_Type (T));
441 end Adjust_Result_Type;
443 --------------------------
444 -- Append_Freeze_Action --
445 --------------------------
447 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
451 Ensure_Freeze_Node (T);
452 Fnode := Freeze_Node (T);
454 if No (Actions (Fnode)) then
455 Set_Actions (Fnode, New_List (N));
457 Append (N, Actions (Fnode));
460 end Append_Freeze_Action;
462 ---------------------------
463 -- Append_Freeze_Actions --
464 ---------------------------
466 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
474 Ensure_Freeze_Node (T);
475 Fnode := Freeze_Node (T);
477 if No (Actions (Fnode)) then
478 Set_Actions (Fnode, L);
480 Append_List (L, Actions (Fnode));
482 end Append_Freeze_Actions;
484 ----------------------------------------
485 -- Attribute_Constrained_Static_Value --
486 ----------------------------------------
488 function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
490 Ptyp : constant Entity_Id := Etype (Pref);
491 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
493 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
494 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
495 -- view of an aliased object whose subtype is constrained.
497 ---------------------------------
498 -- Is_Constrained_Aliased_View --
499 ---------------------------------
501 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
505 if Is_Entity_Name (Obj) then
508 if Present (Renamed_Object (E)) then
509 return Is_Constrained_Aliased_View (Renamed_Object (E));
511 return Is_Aliased (E) and then Is_Constrained (Etype (E));
515 return Is_Aliased_View (Obj)
517 (Is_Constrained (Etype (Obj))
519 (Nkind (Obj) = N_Explicit_Dereference
521 not Object_Type_Has_Constrained_Partial_View
522 (Typ => Base_Type (Etype (Obj)),
523 Scop => Current_Scope)));
525 end Is_Constrained_Aliased_View;
527 -- Start of processing for Attribute_Constrained_Static_Value
530 -- We are in a case where the attribute is known statically, and
531 -- implicit dereferences have been rewritten.
534 (not (Present (Formal_Ent)
535 and then Ekind (Formal_Ent) /= E_Constant
536 and then Present (Extra_Constrained (Formal_Ent)))
538 not (Is_Access_Type (Etype (Pref))
539 and then (not Is_Entity_Name (Pref)
540 or else Is_Object (Entity (Pref))))
542 not (Nkind (Pref) = N_Identifier
543 and then Ekind (Entity (Pref)) = E_Variable
544 and then Present (Extra_Constrained (Entity (Pref)))));
546 if Is_Entity_Name (Pref) then
548 Ent : constant Entity_Id := Entity (Pref);
552 -- (RM J.4) obsolescent cases
554 if Is_Type (Ent) then
558 if Is_Private_Type (Ent) then
559 Res := not Has_Discriminants (Ent)
560 or else Is_Constrained (Ent);
562 -- It not a private type, must be a generic actual type
563 -- that corresponded to a private type. We know that this
564 -- correspondence holds, since otherwise the reference
565 -- within the generic template would have been illegal.
568 if Is_Composite_Type (Underlying_Type (Ent)) then
569 Res := Is_Constrained (Ent);
577 -- If the prefix is not a variable or is aliased, then
578 -- definitely true; if it's a formal parameter without an
579 -- associated extra formal, then treat it as constrained.
581 -- Ada 2005 (AI-363): An aliased prefix must be known to be
582 -- constrained in order to set the attribute to True.
584 if not Is_Variable (Pref)
585 or else Present (Formal_Ent)
586 or else (Ada_Version < Ada_2005
587 and then Is_Aliased_View (Pref))
588 or else (Ada_Version >= Ada_2005
589 and then Is_Constrained_Aliased_View (Pref))
593 -- Variable case, look at type to see if it is constrained.
594 -- Note that the one case where this is not accurate (the
595 -- procedure formal case), has been handled above.
597 -- We use the Underlying_Type here (and below) in case the
598 -- type is private without discriminants, but the full type
599 -- has discriminants. This case is illegal, but we generate
600 -- it internally for passing to the Extra_Constrained
604 -- In Ada 2012, test for case of a limited tagged type,
605 -- in which case the attribute is always required to
606 -- return True. The underlying type is tested, to make
607 -- sure we also return True for cases where there is an
608 -- unconstrained object with an untagged limited partial
609 -- view which has defaulted discriminants (such objects
610 -- always produce a False in earlier versions of
611 -- Ada). (Ada 2012: AI05-0214)
614 Is_Constrained (Underlying_Type (Etype (Ent)))
616 (Ada_Version >= Ada_2012
617 and then Is_Tagged_Type (Underlying_Type (Ptyp))
618 and then Is_Limited_Type (Ptyp));
625 -- Prefix is not an entity name. These are also cases where we can
626 -- always tell at compile time by looking at the form and type of the
627 -- prefix. If an explicit dereference of an object with constrained
628 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
629 -- underlying type is a limited tagged type, then Constrained is
630 -- required to always return True (Ada 2012: AI05-0214).
633 return not Is_Variable (Pref)
635 (Nkind (Pref) = N_Explicit_Dereference
637 not Object_Type_Has_Constrained_Partial_View
638 (Typ => Base_Type (Ptyp),
639 Scop => Current_Scope))
640 or else Is_Constrained (Underlying_Type (Ptyp))
641 or else (Ada_Version >= Ada_2012
642 and then Is_Tagged_Type (Underlying_Type (Ptyp))
643 and then Is_Limited_Type (Ptyp));
645 end Attribute_Constrained_Static_Value;
647 ------------------------------------
648 -- Build_Allocate_Deallocate_Proc --
649 ------------------------------------
651 procedure Build_Allocate_Deallocate_Proc
653 Is_Allocate : Boolean)
655 function Find_Object (E : Node_Id) return Node_Id;
656 -- Given an arbitrary expression of an allocator, try to find an object
657 -- reference in it, otherwise return the original expression.
659 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
660 -- Determine whether subprogram Subp denotes a custom allocate or
667 function Find_Object (E : Node_Id) return Node_Id is
671 pragma Assert (Is_Allocate);
675 if Nkind (Expr) = N_Explicit_Dereference then
676 Expr := Prefix (Expr);
678 elsif Nkind (Expr) = N_Qualified_Expression then
679 Expr := Expression (Expr);
681 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
683 -- When interface class-wide types are involved in allocation,
684 -- the expander introduces several levels of address arithmetic
685 -- to perform dispatch table displacement. In this scenario the
686 -- object appears as:
688 -- Tag_Ptr (Base_Address (<object>'Address))
690 -- Detect this case and utilize the whole expression as the
691 -- "object" since it now points to the proper dispatch table.
693 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
696 -- Continue to strip the object
699 Expr := Expression (Expr);
710 ---------------------------------
711 -- Is_Allocate_Deallocate_Proc --
712 ---------------------------------
714 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
716 -- Look for a subprogram body with only one statement which is a
717 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
719 if Ekind (Subp) = E_Procedure
720 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
723 HSS : constant Node_Id :=
724 Handled_Statement_Sequence (Parent (Parent (Subp)));
728 if Present (Statements (HSS))
729 and then Nkind (First (Statements (HSS))) =
730 N_Procedure_Call_Statement
732 Proc := Entity (Name (First (Statements (HSS))));
735 Is_RTE (Proc, RE_Allocate_Any_Controlled)
736 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
742 end Is_Allocate_Deallocate_Proc;
746 Desig_Typ : Entity_Id;
750 Proc_To_Call : Node_Id := Empty;
752 Use_Secondary_Stack_Pool : Boolean;
754 -- Start of processing for Build_Allocate_Deallocate_Proc
757 -- Obtain the attributes of the allocation / deallocation
759 if Nkind (N) = N_Free_Statement then
760 Expr := Expression (N);
761 Ptr_Typ := Base_Type (Etype (Expr));
762 Proc_To_Call := Procedure_To_Call (N);
765 if Nkind (N) = N_Object_Declaration then
766 Expr := Expression (N);
771 -- In certain cases an allocator with a qualified expression may
772 -- be relocated and used as the initialization expression of a
776 -- Obj : Ptr_Typ := new Desig_Typ'(...);
779 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
780 -- Obj : Ptr_Typ := Tmp;
782 -- Since the allocator is always marked as analyzed to avoid infinite
783 -- expansion, it will never be processed by this routine given that
784 -- the designated type needs finalization actions. Detect this case
785 -- and complete the expansion of the allocator.
787 if Nkind (Expr) = N_Identifier
788 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
789 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
791 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
795 -- The allocator may have been rewritten into something else in which
796 -- case the expansion performed by this routine does not apply.
798 if Nkind (Expr) /= N_Allocator then
802 Ptr_Typ := Base_Type (Etype (Expr));
803 Proc_To_Call := Procedure_To_Call (Expr);
806 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
807 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
809 -- Handle concurrent types
811 if Is_Concurrent_Type (Desig_Typ)
812 and then Present (Corresponding_Record_Type (Desig_Typ))
814 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
817 Use_Secondary_Stack_Pool :=
818 Is_RTE (Pool_Id, RE_SS_Pool)
819 or else (Nkind (Expr) = N_Allocator
820 and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool));
822 -- Do not process allocations / deallocations without a pool
827 -- Do not process allocations on / deallocations from the secondary
828 -- stack, except for access types used to implement indirect temps.
830 elsif Use_Secondary_Stack_Pool
831 and then not Old_Attr_Util.Indirect_Temps
832 .Is_Access_Type_For_Indirect_Temp (Ptr_Typ)
836 -- Optimize the case where we are using the default Global_Pool_Object,
837 -- and we don't need the heavy finalization machinery.
839 elsif Pool_Id = RTE (RE_Global_Pool_Object)
840 and then not Needs_Finalization (Desig_Typ)
844 -- Do not replicate the machinery if the allocator / free has already
845 -- been expanded and has a custom Allocate / Deallocate.
847 elsif Present (Proc_To_Call)
848 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
853 -- Finalization actions are required when the object to be allocated or
854 -- deallocated needs these actions and the associated access type is not
855 -- subject to pragma No_Heap_Finalization.
858 Needs_Finalization (Desig_Typ)
859 and then not No_Heap_Finalization (Ptr_Typ);
863 -- Do nothing if the access type may never allocate / deallocate
866 if No_Pool_Assigned (Ptr_Typ) then
870 -- The allocation / deallocation of a controlled object must be
871 -- chained on / detached from a finalization master.
873 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
875 -- The only other kind of allocation / deallocation supported by this
876 -- routine is on / from a subpool.
878 elsif Nkind (Expr) = N_Allocator
879 and then No (Subpool_Handle_Name (Expr))
885 Loc : constant Source_Ptr := Sloc (N);
886 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
887 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
888 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
889 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
892 Fin_Addr_Id : Entity_Id;
893 Fin_Mas_Act : Node_Id;
894 Fin_Mas_Id : Entity_Id;
895 Proc_To_Call : Entity_Id;
896 Subpool : Node_Id := Empty;
899 -- Step 1: Construct all the actuals for the call to library routine
900 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
904 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
910 if Nkind (Expr) = N_Allocator then
911 Subpool := Subpool_Handle_Name (Expr);
914 -- If a subpool is present it can be an arbitrary name, so make
915 -- the actual by copying the tree.
917 if Present (Subpool) then
918 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
920 Append_To (Actuals, Make_Null (Loc));
923 -- c) Finalization master
926 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
927 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
929 -- Handle the case where the master is actually a pointer to a
930 -- master. This case arises in build-in-place functions.
932 if Is_Access_Type (Etype (Fin_Mas_Id)) then
933 Append_To (Actuals, Fin_Mas_Act);
936 Make_Attribute_Reference (Loc,
937 Prefix => Fin_Mas_Act,
938 Attribute_Name => Name_Unrestricted_Access));
941 Append_To (Actuals, Make_Null (Loc));
944 -- d) Finalize_Address
946 -- Primitive Finalize_Address is never generated in CodePeer mode
947 -- since it contains an Unchecked_Conversion.
949 if Needs_Fin and then not CodePeer_Mode then
950 Fin_Addr_Id := Finalize_Address (Desig_Typ);
951 pragma Assert (Present (Fin_Addr_Id));
954 Make_Attribute_Reference (Loc,
955 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
956 Attribute_Name => Name_Unrestricted_Access));
958 Append_To (Actuals, Make_Null (Loc));
966 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
967 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
969 if (Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ))
970 and then not Use_Secondary_Stack_Pool
972 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
974 -- For deallocation of class-wide types we obtain the value of
975 -- alignment from the Type Specific Record of the deallocated object.
976 -- This is needed because the frontend expansion of class-wide types
977 -- into equivalent types confuses the back end.
983 -- ... because 'Alignment applied to class-wide types is expanded
984 -- into the code that reads the value of alignment from the TSD
985 -- (see Expand_N_Attribute_Reference)
987 -- In the Use_Secondary_Stack_Pool case, Alig_Id is not
988 -- passed in and therefore must not be referenced.
991 Unchecked_Convert_To (RTE (RE_Storage_Offset),
992 Make_Attribute_Reference (Loc,
994 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
995 Attribute_Name => Name_Alignment)));
1001 Is_Controlled : declare
1002 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
1003 Flag_Expr : Node_Id;
1010 Temp := Find_Object (Expression (Expr));
1015 -- Processing for allocations where the expression is a subtype
1019 and then Is_Entity_Name (Temp)
1020 and then Is_Type (Entity (Temp))
1025 (Needs_Finalization (Entity (Temp))), Loc);
1027 -- The allocation / deallocation of a class-wide object relies
1028 -- on a runtime check to determine whether the object is truly
1029 -- controlled or not. Depending on this check, the finalization
1030 -- machinery will request or reclaim extra storage reserved for
1033 elsif Is_Class_Wide_Type (Desig_Typ) then
1035 -- Detect a special case where interface class-wide types
1036 -- are involved as the object appears as:
1038 -- Tag_Ptr (Base_Address (<object>'Address))
1040 -- The expression already yields the proper tag, generate:
1044 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
1046 Make_Explicit_Dereference (Loc,
1047 Prefix => Relocate_Node (Temp));
1049 -- In the default case, obtain the tag of the object about
1050 -- to be allocated / deallocated. Generate:
1054 -- If the object is an unchecked conversion (typically to
1055 -- an access to class-wide type), we must preserve the
1056 -- conversion to ensure that the object is seen as tagged
1057 -- in the code that follows.
1062 if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion
1064 Pref := Parent (Pref);
1068 Make_Attribute_Reference (Loc,
1069 Prefix => Relocate_Node (Pref),
1070 Attribute_Name => Name_Tag);
1074 -- Needs_Finalization (<Param>)
1077 Make_Function_Call (Loc,
1079 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
1080 Parameter_Associations => New_List (Param));
1082 -- Processing for generic actuals
1084 elsif Is_Generic_Actual_Type (Desig_Typ) then
1086 New_Occurrence_Of (Boolean_Literals
1087 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
1089 -- The object does not require any specialized checks, it is
1090 -- known to be controlled.
1093 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
1096 -- Create the temporary which represents the finalization state
1097 -- of the expression. Generate:
1099 -- F : constant Boolean := <Flag_Expr>;
1102 Make_Object_Declaration (Loc,
1103 Defining_Identifier => Flag_Id,
1104 Constant_Present => True,
1105 Object_Definition =>
1106 New_Occurrence_Of (Standard_Boolean, Loc),
1107 Expression => Flag_Expr));
1109 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
1112 -- The object is not controlled
1115 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
1122 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
1125 -- Step 2: Build a wrapper Allocate / Deallocate which internally
1126 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
1128 -- Select the proper routine to call
1131 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
1133 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
1136 -- Create a custom Allocate / Deallocate routine which has identical
1137 -- profile to that of System.Storage_Pools.
1140 -- P : Root_Storage_Pool
1141 function Pool_Param return Node_Id is (
1142 Make_Parameter_Specification (Loc,
1143 Defining_Identifier => Make_Temporary (Loc, 'P'),
1145 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)));
1147 -- A : [out] Address
1148 function Address_Param return Node_Id is (
1149 Make_Parameter_Specification (Loc,
1150 Defining_Identifier => Addr_Id,
1151 Out_Present => Is_Allocate,
1153 New_Occurrence_Of (RTE (RE_Address), Loc)));
1155 -- S : Storage_Count
1156 function Size_Param return Node_Id is (
1157 Make_Parameter_Specification (Loc,
1158 Defining_Identifier => Size_Id,
1160 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
1162 -- L : Storage_Count
1163 function Alignment_Param return Node_Id is (
1164 Make_Parameter_Specification (Loc,
1165 Defining_Identifier => Alig_Id,
1167 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)));
1169 Formal_Params : List_Id;
1171 if Use_Secondary_Stack_Pool then
1172 -- Gigi expects a different profile in the Secondary_Stack_Pool
1173 -- case. There must be no uses of the two missing formals
1174 -- (i.e., Pool_Param and Alignment_Param) in this case.
1175 Formal_Params := New_List (Address_Param, Size_Param);
1177 Formal_Params := New_List (
1178 Pool_Param, Address_Param, Size_Param, Alignment_Param);
1182 Make_Subprogram_Body (Loc,
1185 Make_Procedure_Specification (Loc,
1186 Defining_Unit_Name => Proc_Id,
1187 Parameter_Specifications => Formal_Params),
1189 Declarations => No_List,
1191 Handled_Statement_Sequence =>
1192 Make_Handled_Sequence_Of_Statements (Loc,
1193 Statements => New_List (
1194 Make_Procedure_Call_Statement (Loc,
1196 New_Occurrence_Of (Proc_To_Call, Loc),
1197 Parameter_Associations => Actuals)))),
1198 Suppress => All_Checks);
1201 -- The newly generated Allocate / Deallocate becomes the default
1202 -- procedure to call when the back end processes the allocation /
1206 Set_Procedure_To_Call (Expr, Proc_Id);
1208 Set_Procedure_To_Call (N, Proc_Id);
1211 end Build_Allocate_Deallocate_Proc;
1213 -------------------------------
1214 -- Build_Abort_Undefer_Block --
1215 -------------------------------
1217 function Build_Abort_Undefer_Block
1220 Context : Node_Id) return Node_Id
1222 Exceptions_OK : constant Boolean :=
1223 not Restriction_Active (No_Exception_Propagation);
1231 -- The block should be generated only when undeferring abort in the
1232 -- context of a potential exception.
1234 pragma Assert (Abort_Allowed and Exceptions_OK);
1240 -- Abort_Undefer_Direct;
1243 AUD := RTE (RE_Abort_Undefer_Direct);
1246 Make_Handled_Sequence_Of_Statements (Loc,
1247 Statements => Stmts,
1248 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1251 Make_Block_Statement (Loc,
1252 Handled_Statement_Sequence => HSS);
1253 Set_Is_Abort_Block (Blk);
1255 Add_Block_Identifier (Blk, Blk_Id);
1256 Expand_At_End_Handler (HSS, Blk_Id);
1258 -- Present the Abort_Undefer_Direct function to the back end to inline
1259 -- the call to the routine.
1261 Add_Inlined_Body (AUD, Context);
1264 end Build_Abort_Undefer_Block;
1266 ---------------------------------
1267 -- Build_Class_Wide_Expression --
1268 ---------------------------------
1270 procedure Build_Class_Wide_Expression
1273 Par_Subp : Entity_Id;
1274 Adjust_Sloc : Boolean;
1275 Needs_Wrapper : out Boolean)
1277 function Replace_Entity (N : Node_Id) return Traverse_Result;
1278 -- Replace reference to formal of inherited operation or to primitive
1279 -- operation of root type, with corresponding entity for derived type,
1280 -- when constructing the class-wide condition of an overriding
1283 --------------------
1284 -- Replace_Entity --
1285 --------------------
1287 function Replace_Entity (N : Node_Id) return Traverse_Result is
1292 Adjust_Inherited_Pragma_Sloc (N);
1295 if Nkind (N) = N_Identifier
1296 and then Present (Entity (N))
1298 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
1300 (Nkind (Parent (N)) /= N_Attribute_Reference
1301 or else Attribute_Name (Parent (N)) /= Name_Class)
1303 -- The replacement does not apply to dispatching calls within the
1304 -- condition, but only to calls whose static tag is that of the
1307 if Is_Subprogram (Entity (N))
1308 and then Nkind (Parent (N)) = N_Function_Call
1309 and then Present (Controlling_Argument (Parent (N)))
1314 -- Determine whether entity has a renaming
1316 New_E := Type_Map.Get (Entity (N));
1318 if Present (New_E) then
1319 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
1321 -- AI12-0166: a precondition for a protected operation
1322 -- cannot include an internal call to a protected function
1323 -- of the type. In the case of an inherited condition for an
1324 -- overriding operation, both the operation and the function
1325 -- are given by primitive wrappers.
1326 -- Move this check to sem???
1328 if Ekind (New_E) = E_Function
1329 and then Is_Primitive_Wrapper (New_E)
1330 and then Is_Primitive_Wrapper (Subp)
1331 and then Scope (Subp) = Scope (New_E)
1333 Error_Msg_Node_2 := Wrapped_Entity (Subp);
1335 ("internal call to& cannot appear in inherited "
1336 & "precondition of protected operation&",
1337 N, Wrapped_Entity (New_E));
1340 -- If the entity is an overridden primitive and we are not
1341 -- in GNATprove mode, we must build a wrapper for the current
1342 -- inherited operation. If the reference is the prefix of an
1343 -- attribute such as 'Result (or others ???) there is no need
1344 -- for a wrapper: the condition is just rewritten in terms of
1345 -- the inherited subprogram.
1347 if Is_Subprogram (New_E)
1348 and then Nkind (Parent (N)) /= N_Attribute_Reference
1349 and then not GNATprove_Mode
1351 Needs_Wrapper := True;
1355 -- Check that there are no calls left to abstract operations if
1356 -- the current subprogram is not abstract.
1357 -- Move this check to sem???
1359 if Nkind (Parent (N)) = N_Function_Call
1360 and then N = Name (Parent (N))
1362 if not Is_Abstract_Subprogram (Subp)
1363 and then Is_Abstract_Subprogram (Entity (N))
1365 Error_Msg_Sloc := Sloc (Current_Scope);
1366 Error_Msg_Node_2 := Subp;
1367 if Comes_From_Source (Subp) then
1369 ("cannot call abstract subprogram & in inherited "
1370 & "condition for&#", Subp, Entity (N));
1373 ("cannot call abstract subprogram & in inherited "
1374 & "condition for inherited&#", Subp, Entity (N));
1377 -- In SPARK mode, reject an inherited condition for an
1378 -- inherited operation if it contains a call to an overriding
1379 -- operation, because this implies that the pre/postconditions
1380 -- of the inherited operation have changed silently.
1382 elsif SPARK_Mode = On
1383 and then Warn_On_Suspicious_Contract
1384 and then Present (Alias (Subp))
1385 and then Present (New_E)
1386 and then Comes_From_Source (New_E)
1389 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
1391 Error_Msg_Sloc := Sloc (New_E);
1392 Error_Msg_Node_2 := Subp;
1394 ("\overriding of&# forces overriding of&",
1395 Parent (Subp), New_E);
1399 -- Update type of function call node, which should be the same as
1400 -- the function's return type.
1402 if Is_Subprogram (Entity (N))
1403 and then Nkind (Parent (N)) = N_Function_Call
1405 Set_Etype (Parent (N), Etype (Entity (N)));
1408 -- The whole expression will be reanalyzed
1410 elsif Nkind (N) in N_Has_Etype then
1411 Set_Analyzed (N, False);
1417 procedure Replace_Condition_Entities is
1418 new Traverse_Proc (Replace_Entity);
1422 Par_Formal : Entity_Id;
1423 Subp_Formal : Entity_Id;
1425 -- Start of processing for Build_Class_Wide_Expression
1428 Needs_Wrapper := False;
1430 -- Add mapping from old formals to new formals
1432 Par_Formal := First_Formal (Par_Subp);
1433 Subp_Formal := First_Formal (Subp);
1435 while Present (Par_Formal) and then Present (Subp_Formal) loop
1436 Type_Map.Set (Par_Formal, Subp_Formal);
1437 Next_Formal (Par_Formal);
1438 Next_Formal (Subp_Formal);
1441 Replace_Condition_Entities (Prag);
1442 end Build_Class_Wide_Expression;
1444 --------------------
1445 -- Build_DIC_Call --
1446 --------------------
1448 function Build_DIC_Call
1451 Typ : Entity_Id) return Node_Id
1453 Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
1454 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1458 Make_Procedure_Call_Statement (Loc,
1459 Name => New_Occurrence_Of (Proc_Id, Loc),
1460 Parameter_Associations => New_List (
1461 Make_Unchecked_Type_Conversion (Loc,
1462 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1463 Expression => New_Occurrence_Of (Obj_Id, Loc))));
1466 ------------------------------
1467 -- Build_DIC_Procedure_Body --
1468 ------------------------------
1470 -- WARNING: This routine manages Ghost regions. Return statements must be
1471 -- replaced by gotos which jump to the end of the routine and restore the
1474 procedure Build_DIC_Procedure_Body
1476 For_Freeze : Boolean := False)
1478 procedure Add_DIC_Check
1479 (DIC_Prag : Node_Id;
1481 Stmts : in out List_Id);
1482 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1483 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1484 -- is added to list Stmts.
1486 procedure Add_Inherited_DIC
1487 (DIC_Prag : Node_Id;
1488 Par_Typ : Entity_Id;
1489 Deriv_Typ : Entity_Id;
1490 Stmts : in out List_Id);
1491 -- Add a runtime check to verify the assertion expression of inherited
1492 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1493 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1494 -- pragma. All generated code is added to list Stmts.
1496 procedure Add_Inherited_Tagged_DIC
1497 (DIC_Prag : Node_Id;
1498 Par_Typ : Entity_Id;
1499 Deriv_Typ : Entity_Id;
1500 Stmts : in out List_Id);
1501 -- Add a runtime check to verify assertion expression DIC_Expr of
1502 -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
1503 -- postcondition-like runtime semantics to the check. Par_Typ is the
1504 -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
1505 -- derived type inheriting the DIC pragma. All generated code is added
1508 procedure Add_Own_DIC
1509 (DIC_Prag : Node_Id;
1510 DIC_Typ : Entity_Id;
1511 Stmts : in out List_Id);
1512 -- Add a runtime check to verify the assertion expression of pragma
1513 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
1514 -- is added to list Stmts.
1520 procedure Add_DIC_Check
1521 (DIC_Prag : Node_Id;
1523 Stmts : in out List_Id)
1525 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1526 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1529 -- The DIC pragma is ignored, nothing left to do
1531 if Is_Ignored (DIC_Prag) then
1534 -- Otherwise the DIC expression must be checked at run time.
1537 -- pragma Check (<Nam>, <DIC_Expr>);
1540 Append_New_To (Stmts,
1542 Pragma_Identifier =>
1543 Make_Identifier (Loc, Name_Check),
1545 Pragma_Argument_Associations => New_List (
1546 Make_Pragma_Argument_Association (Loc,
1547 Expression => Make_Identifier (Loc, Nam)),
1549 Make_Pragma_Argument_Association (Loc,
1550 Expression => DIC_Expr))));
1554 -----------------------
1555 -- Add_Inherited_DIC --
1556 -----------------------
1558 procedure Add_Inherited_DIC
1559 (DIC_Prag : Node_Id;
1560 Par_Typ : Entity_Id;
1561 Deriv_Typ : Entity_Id;
1562 Stmts : in out List_Id)
1564 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1565 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1566 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1567 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1568 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1571 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1573 -- Verify the inherited DIC assertion expression by calling the DIC
1574 -- procedure of the parent type.
1577 -- <Par_Typ>DIC (Par_Typ (_object));
1579 Append_New_To (Stmts,
1580 Make_Procedure_Call_Statement (Loc,
1581 Name => New_Occurrence_Of (Par_Proc, Loc),
1582 Parameter_Associations => New_List (
1584 (Typ => Etype (Par_Obj),
1585 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1586 end Add_Inherited_DIC;
1588 ------------------------------
1589 -- Add_Inherited_Tagged_DIC --
1590 ------------------------------
1592 procedure Add_Inherited_Tagged_DIC
1593 (DIC_Prag : Node_Id;
1594 Par_Typ : Entity_Id;
1595 Deriv_Typ : Entity_Id;
1596 Stmts : in out List_Id)
1598 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1599 DIC_Args : constant List_Id :=
1600 Pragma_Argument_Associations (DIC_Prag);
1601 DIC_Arg : constant Node_Id := First (DIC_Args);
1602 DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
1603 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1608 -- The processing of an inherited DIC assertion expression starts off
1609 -- with a copy of the original parent expression where all references
1610 -- to the parent type have already been replaced with references to
1611 -- the _object formal parameter of the parent type's DIC procedure.
1613 pragma Assert (Present (DIC_Expr));
1614 Expr := New_Copy_Tree (DIC_Expr);
1616 -- Perform the following substitutions:
1618 -- * Replace a reference to the _object parameter of the parent
1619 -- type's DIC procedure with a reference to the _object parameter
1620 -- of the derived types' DIC procedure.
1622 -- * Replace a reference to a discriminant of the parent type with
1623 -- a suitable value from the point of view of the derived type.
1625 -- * Replace a call to an overridden parent primitive with a call
1626 -- to the overriding derived type primitive.
1628 -- * Replace a call to an inherited parent primitive with a call to
1629 -- the internally-generated inherited derived type primitive.
1631 -- Note that primitives defined in the private part are automatically
1632 -- handled by the overriding/inheritance mechanism and do not require
1633 -- an extra replacement pass.
1635 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1640 Deriv_Typ => Deriv_Typ,
1641 Par_Obj => First_Formal (Par_Proc),
1642 Deriv_Obj => First_Formal (Deriv_Proc));
1644 -- Once the DIC assertion expression is fully processed, add a check
1645 -- to the statements of the DIC procedure.
1648 (DIC_Prag => DIC_Prag,
1651 end Add_Inherited_Tagged_DIC;
1657 procedure Add_Own_DIC
1658 (DIC_Prag : Node_Id;
1659 DIC_Typ : Entity_Id;
1660 Stmts : in out List_Id)
1662 DIC_Args : constant List_Id :=
1663 Pragma_Argument_Associations (DIC_Prag);
1664 DIC_Arg : constant Node_Id := First (DIC_Args);
1665 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1666 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1667 DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
1668 Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
1672 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1676 -- Start of processing for Add_Own_DIC
1679 pragma Assert (Present (DIC_Expr));
1680 Expr := New_Copy_Tree (DIC_Expr);
1682 -- Perform the following substitution:
1684 -- * Replace the current instance of DIC_Typ with a reference to
1685 -- the _object formal parameter of the DIC procedure.
1687 Replace_Type_References
1692 -- Preanalyze the DIC expression to detect errors and at the same
1693 -- time capture the visibility of the proper package part.
1695 Set_Parent (Expr, Typ_Decl);
1696 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1698 -- Save a copy of the expression with all replacements and analysis
1699 -- already taken place in case a derived type inherits the pragma.
1700 -- The copy will be used as the foundation of the derived type's own
1701 -- version of the DIC assertion expression.
1703 if Is_Tagged_Type (DIC_Typ) then
1704 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1707 -- If the pragma comes from an aspect specification, replace the
1708 -- saved expression because all type references must be substituted
1709 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1712 if Present (DIC_Asp) then
1713 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1716 -- Once the DIC assertion expression is fully processed, add a check
1717 -- to the statements of the DIC procedure.
1720 (DIC_Prag => DIC_Prag,
1727 Loc : constant Source_Ptr := Sloc (Typ);
1729 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1730 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1731 -- Save the Ghost-related attributes to restore on exit
1734 DIC_Typ : Entity_Id;
1735 Dummy_1 : Entity_Id;
1736 Dummy_2 : Entity_Id;
1737 Proc_Body : Node_Id;
1738 Proc_Body_Id : Entity_Id;
1739 Proc_Decl : Node_Id;
1740 Proc_Id : Entity_Id;
1741 Stmts : List_Id := No_List;
1743 Build_Body : Boolean := False;
1744 -- Flag set when the type requires a DIC procedure body to be built
1746 Work_Typ : Entity_Id;
1749 -- Start of processing for Build_DIC_Procedure_Body
1752 Work_Typ := Base_Type (Typ);
1754 -- Do not process class-wide types as these are Itypes, but lack a first
1755 -- subtype (see below).
1757 if Is_Class_Wide_Type (Work_Typ) then
1760 -- Do not process the underlying full view of a private type. There is
1761 -- no way to get back to the partial view, plus the body will be built
1762 -- by the full view or the base type.
1764 elsif Is_Underlying_Full_View (Work_Typ) then
1767 -- Use the first subtype when dealing with various base types
1769 elsif Is_Itype (Work_Typ) then
1770 Work_Typ := First_Subtype (Work_Typ);
1772 -- The input denotes the corresponding record type of a protected or a
1773 -- task type. Work with the concurrent type because the corresponding
1774 -- record type may not be visible to clients of the type.
1776 elsif Ekind (Work_Typ) = E_Record_Type
1777 and then Is_Concurrent_Record_Type (Work_Typ)
1779 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
1782 -- The working type may be subject to pragma Ghost. Set the mode now to
1783 -- ensure that the DIC procedure is properly marked as Ghost.
1785 Set_Ghost_Mode (Work_Typ);
1787 -- The working type must be either define a DIC pragma of its own or
1788 -- inherit one from a parent type.
1790 pragma Assert (Has_DIC (Work_Typ));
1792 -- Recover the type which defines the DIC pragma. This is either the
1793 -- working type itself or a parent type when the pragma is inherited.
1795 DIC_Typ := Find_DIC_Type (Work_Typ);
1796 pragma Assert (Present (DIC_Typ));
1798 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
1799 pragma Assert (Present (DIC_Prag));
1801 -- Nothing to do if pragma DIC appears without an argument or its sole
1802 -- argument is "null".
1804 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
1808 -- The working type may lack a DIC procedure declaration. This may be
1809 -- due to several reasons:
1811 -- * The working type's own DIC pragma does not contain a verifiable
1812 -- assertion expression. In this case there is no need to build a
1813 -- DIC procedure because there is nothing to check.
1815 -- * The working type derives from a parent type. In this case a DIC
1816 -- procedure should be built only when the inherited DIC pragma has
1817 -- a verifiable assertion expression.
1819 Proc_Id := DIC_Procedure (Work_Typ);
1821 -- Build a DIC procedure declaration when the working type derives from
1824 if No (Proc_Id) then
1825 Build_DIC_Procedure_Declaration (Work_Typ);
1826 Proc_Id := DIC_Procedure (Work_Typ);
1829 -- At this point there should be a DIC procedure declaration
1831 pragma Assert (Present (Proc_Id));
1832 Proc_Decl := Unit_Declaration_Node (Proc_Id);
1834 -- Nothing to do if the DIC procedure already has a body
1836 if Present (Corresponding_Body (Proc_Decl)) then
1840 -- Emulate the environment of the DIC procedure by installing its scope
1841 -- and formal parameters.
1843 Push_Scope (Proc_Id);
1844 Install_Formals (Proc_Id);
1846 -- The working type defines its own DIC pragma. Replace the current
1847 -- instance of the working type with the formal of the DIC procedure.
1848 -- Note that there is no need to consider inherited DIC pragmas from
1849 -- parent types because the working type's DIC pragma "hides" all
1850 -- inherited DIC pragmas.
1852 if Has_Own_DIC (Work_Typ) then
1853 pragma Assert (DIC_Typ = Work_Typ);
1856 (DIC_Prag => DIC_Prag,
1862 -- Otherwise the working type inherits a DIC pragma from a parent type.
1863 -- This processing is carried out when the type is frozen because the
1864 -- state of all parent discriminants is known at that point. Note that
1865 -- it is semantically sound to delay the creation of the DIC procedure
1866 -- body till the freeze point. If the type has a DIC pragma of its own,
1867 -- then the DIC procedure body would have already been constructed at
1868 -- the end of the visible declarations and all parent DIC pragmas are
1869 -- effectively "hidden" and irrelevant.
1871 elsif For_Freeze then
1872 pragma Assert (Has_Inherited_DIC (Work_Typ));
1873 pragma Assert (DIC_Typ /= Work_Typ);
1875 -- The working type is tagged. The verification of the assertion
1876 -- expression is subject to the same semantics as class-wide pre-
1877 -- and postconditions.
1879 if Is_Tagged_Type (Work_Typ) then
1880 Add_Inherited_Tagged_DIC
1881 (DIC_Prag => DIC_Prag,
1883 Deriv_Typ => Work_Typ,
1886 -- Otherwise the working type is not tagged. Verify the assertion
1887 -- expression of the inherited DIC pragma by directly calling the
1888 -- DIC procedure of the parent type.
1892 (DIC_Prag => DIC_Prag,
1894 Deriv_Typ => Work_Typ,
1905 -- Produce an empty completing body in the following cases:
1906 -- * Assertions are disabled
1907 -- * The DIC Assertion_Policy is Ignore
1910 Stmts := New_List (Make_Null_Statement (Loc));
1914 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
1917 -- end <Work_Typ>DIC;
1920 Make_Subprogram_Body (Loc,
1922 Copy_Subprogram_Spec (Parent (Proc_Id)),
1923 Declarations => Empty_List,
1924 Handled_Statement_Sequence =>
1925 Make_Handled_Sequence_Of_Statements (Loc,
1926 Statements => Stmts));
1927 Proc_Body_Id := Defining_Entity (Proc_Body);
1929 -- Perform minor decoration in case the body is not analyzed
1931 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
1932 Set_Etype (Proc_Body_Id, Standard_Void_Type);
1933 Set_Scope (Proc_Body_Id, Current_Scope);
1934 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
1935 Set_SPARK_Pragma_Inherited
1936 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
1938 -- Link both spec and body to avoid generating duplicates
1940 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
1941 Set_Corresponding_Spec (Proc_Body, Proc_Id);
1943 -- The body should not be inserted into the tree when the context
1944 -- is a generic unit because it is not part of the template.
1945 -- Note that the body must still be generated in order to resolve the
1946 -- DIC assertion expression.
1948 if Inside_A_Generic then
1951 -- Semi-insert the body into the tree for GNATprove by setting its
1952 -- Parent field. This allows for proper upstream tree traversals.
1954 elsif GNATprove_Mode then
1955 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
1957 -- Otherwise the body is part of the freezing actions of the working
1961 Append_Freeze_Action (Work_Typ, Proc_Body);
1966 Restore_Ghost_Region (Saved_GM, Saved_IGR);
1967 end Build_DIC_Procedure_Body;
1969 -------------------------------------
1970 -- Build_DIC_Procedure_Declaration --
1971 -------------------------------------
1973 -- WARNING: This routine manages Ghost regions. Return statements must be
1974 -- replaced by gotos which jump to the end of the routine and restore the
1977 procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is
1978 Loc : constant Source_Ptr := Sloc (Typ);
1980 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1981 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1982 -- Save the Ghost-related attributes to restore on exit
1985 DIC_Typ : Entity_Id;
1986 Proc_Decl : Node_Id;
1987 Proc_Id : Entity_Id;
1990 CRec_Typ : Entity_Id;
1991 -- The corresponding record type of Full_Typ
1993 Full_Typ : Entity_Id;
1994 -- The full view of working type
1997 -- The _object formal parameter of the DIC procedure
1999 Priv_Typ : Entity_Id;
2000 -- The partial view of working type
2002 UFull_Typ : Entity_Id;
2003 -- The underlying full view of Full_Typ
2005 Work_Typ : Entity_Id;
2009 Work_Typ := Base_Type (Typ);
2011 -- Do not process class-wide types as these are Itypes, but lack a first
2012 -- subtype (see below).
2014 if Is_Class_Wide_Type (Work_Typ) then
2017 -- Do not process the underlying full view of a private type. There is
2018 -- no way to get back to the partial view, plus the body will be built
2019 -- by the full view or the base type.
2021 elsif Is_Underlying_Full_View (Work_Typ) then
2024 -- Use the first subtype when dealing with various base types
2026 elsif Is_Itype (Work_Typ) then
2027 Work_Typ := First_Subtype (Work_Typ);
2029 -- The input denotes the corresponding record type of a protected or a
2030 -- task type. Work with the concurrent type because the corresponding
2031 -- record type may not be visible to clients of the type.
2033 elsif Ekind (Work_Typ) = E_Record_Type
2034 and then Is_Concurrent_Record_Type (Work_Typ)
2036 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2039 -- The working type may be subject to pragma Ghost. Set the mode now to
2040 -- ensure that the DIC procedure is properly marked as Ghost.
2042 Set_Ghost_Mode (Work_Typ);
2044 -- The type must be either subject to a DIC pragma or inherit one from a
2047 pragma Assert (Has_DIC (Work_Typ));
2049 -- Recover the type which defines the DIC pragma. This is either the
2050 -- working type itself or a parent type when the pragma is inherited.
2052 DIC_Typ := Find_DIC_Type (Work_Typ);
2053 pragma Assert (Present (DIC_Typ));
2055 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2056 pragma Assert (Present (DIC_Prag));
2058 -- Nothing to do if pragma DIC appears without an argument or its sole
2059 -- argument is "null".
2061 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2064 -- Nothing to do if the type already has a DIC procedure
2066 elsif Present (DIC_Procedure (Work_Typ)) then
2071 Make_Defining_Identifier (Loc,
2073 New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
2075 -- Perform minor decoration in case the declaration is not analyzed
2077 Set_Ekind (Proc_Id, E_Procedure);
2078 Set_Etype (Proc_Id, Standard_Void_Type);
2079 Set_Is_DIC_Procedure (Proc_Id);
2080 Set_Scope (Proc_Id, Current_Scope);
2081 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
2082 Set_SPARK_Pragma_Inherited (Proc_Id);
2084 Set_DIC_Procedure (Work_Typ, Proc_Id);
2086 -- The DIC procedure requires debug info when the assertion expression
2087 -- is subject to Source Coverage Obligations.
2089 if Generate_SCO then
2090 Set_Debug_Info_Needed (Proc_Id);
2093 -- Obtain all views of the input type
2095 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
2097 -- Associate the DIC procedure and various flags with all views
2099 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
2100 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
2101 Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ);
2102 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
2104 -- The declaration of the DIC procedure must be inserted after the
2105 -- declaration of the partial view as this allows for proper external
2108 if Present (Priv_Typ) then
2109 Typ_Decl := Declaration_Node (Priv_Typ);
2111 -- Derived types with the full view as parent do not have a partial
2112 -- view. Insert the DIC procedure after the derived type.
2115 Typ_Decl := Declaration_Node (Full_Typ);
2118 -- The type should have a declarative node
2120 pragma Assert (Present (Typ_Decl));
2122 -- Create the formal parameter which emulates the variable-like behavior
2123 -- of the type's current instance.
2125 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
2127 -- Perform minor decoration in case the declaration is not analyzed
2129 Set_Ekind (Obj_Id, E_In_Parameter);
2130 Set_Etype (Obj_Id, Work_Typ);
2131 Set_Scope (Obj_Id, Proc_Id);
2133 Set_First_Entity (Proc_Id, Obj_Id);
2134 Set_Last_Entity (Proc_Id, Obj_Id);
2137 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2140 Make_Subprogram_Declaration (Loc,
2142 Make_Procedure_Specification (Loc,
2143 Defining_Unit_Name => Proc_Id,
2144 Parameter_Specifications => New_List (
2145 Make_Parameter_Specification (Loc,
2146 Defining_Identifier => Obj_Id,
2148 New_Occurrence_Of (Work_Typ, Loc)))));
2150 -- The declaration should not be inserted into the tree when the context
2151 -- is a generic unit because it is not part of the template.
2153 if Inside_A_Generic then
2156 -- Semi-insert the declaration into the tree for GNATprove by setting
2157 -- its Parent field. This allows for proper upstream tree traversals.
2159 elsif GNATprove_Mode then
2160 Set_Parent (Proc_Decl, Parent (Typ_Decl));
2162 -- Otherwise insert the declaration
2165 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
2169 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2170 end Build_DIC_Procedure_Declaration;
2172 ------------------------------------
2173 -- Build_Invariant_Procedure_Body --
2174 ------------------------------------
2176 -- WARNING: This routine manages Ghost regions. Return statements must be
2177 -- replaced by gotos which jump to the end of the routine and restore the
2180 procedure Build_Invariant_Procedure_Body
2182 Partial_Invariant : Boolean := False)
2184 Loc : constant Source_Ptr := Sloc (Typ);
2186 Pragmas_Seen : Elist_Id := No_Elist;
2187 -- This list contains all invariant pragmas processed so far. The list
2188 -- is used to avoid generating redundant invariant checks.
2190 Produced_Check : Boolean := False;
2191 -- This flag tracks whether the type has produced at least one invariant
2192 -- check. The flag is used as a sanity check at the end of the routine.
2194 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2195 -- intentionally unnested to avoid deep indentation of code.
2197 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2198 -- they emit checks, loops (for arrays) and case statements (for record
2199 -- variant parts) only when there are invariants to verify. This keeps
2200 -- the body of the invariant procedure free of useless code.
2202 procedure Add_Array_Component_Invariants
2205 Checks : in out List_Id);
2206 -- Generate an invariant check for each component of array type T.
2207 -- Obj_Id denotes the entity of the _object formal parameter of the
2208 -- invariant procedure. All created checks are added to list Checks.
2210 procedure Add_Inherited_Invariants
2212 Priv_Typ : Entity_Id;
2213 Full_Typ : Entity_Id;
2215 Checks : in out List_Id);
2216 -- Generate an invariant check for each inherited class-wide invariant
2217 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2218 -- the partial and full view of the parent type. Obj_Id denotes the
2219 -- entity of the _object formal parameter of the invariant procedure.
2220 -- All created checks are added to list Checks.
2222 procedure Add_Interface_Invariants
2225 Checks : in out List_Id);
2226 -- Generate an invariant check for each inherited class-wide invariant
2227 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2228 -- entity of the _object formal parameter of the invariant procedure.
2229 -- All created checks are added to list Checks.
2231 procedure Add_Invariant_Check
2234 Checks : in out List_Id;
2235 Inherited : Boolean := False);
2236 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2237 -- verify assertion expression Expr of pragma Prag. All generated code
2238 -- is added to list Checks. Flag Inherited should be set when the pragma
2239 -- is inherited from a parent or interface type.
2241 procedure Add_Own_Invariants
2244 Checks : in out List_Id;
2245 Priv_Item : Node_Id := Empty);
2246 -- Generate an invariant check for each invariant found for type T.
2247 -- Obj_Id denotes the entity of the _object formal parameter of the
2248 -- invariant procedure. All created checks are added to list Checks.
2249 -- Priv_Item denotes the first rep item of the private type.
2251 procedure Add_Parent_Invariants
2254 Checks : in out List_Id);
2255 -- Generate an invariant check for each inherited class-wide invariant
2256 -- coming from all parent types of type T. Obj_Id denotes the entity of
2257 -- the _object formal parameter of the invariant procedure. All created
2258 -- checks are added to list Checks.
2260 procedure Add_Record_Component_Invariants
2263 Checks : in out List_Id);
2264 -- Generate an invariant check for each component of record type T.
2265 -- Obj_Id denotes the entity of the _object formal parameter of the
2266 -- invariant procedure. All created checks are added to list Checks.
2268 ------------------------------------
2269 -- Add_Array_Component_Invariants --
2270 ------------------------------------
2272 procedure Add_Array_Component_Invariants
2275 Checks : in out List_Id)
2277 Comp_Typ : constant Entity_Id := Component_Type (T);
2278 Dims : constant Pos := Number_Dimensions (T);
2280 procedure Process_Array_Component
2282 Comp_Checks : in out List_Id);
2283 -- Generate an invariant check for an array component identified by
2284 -- the indices in list Indices. All created checks are added to list
2287 procedure Process_One_Dimension
2290 Dim_Checks : in out List_Id);
2291 -- Generate a loop over the Nth dimension Dim of an array type. List
2292 -- Indices contains all array indices for the dimension. All created
2293 -- checks are added to list Dim_Checks.
2295 -----------------------------
2296 -- Process_Array_Component --
2297 -----------------------------
2299 procedure Process_Array_Component
2301 Comp_Checks : in out List_Id)
2303 Proc_Id : Entity_Id;
2306 if Has_Invariants (Comp_Typ) then
2308 -- In GNATprove mode, the component invariants are checked by
2309 -- other means. They should not be added to the array type
2310 -- invariant procedure, so that the procedure can be used to
2311 -- check the array type invariants if any.
2313 if GNATprove_Mode then
2317 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2319 -- The component type should have an invariant procedure
2320 -- if it has invariants of its own or inherits class-wide
2321 -- invariants from parent or interface types.
2323 pragma Assert (Present (Proc_Id));
2326 -- <Comp_Typ>Invariant (_object (<Indices>));
2328 -- The invariant procedure has a null body if assertions are
2329 -- disabled or Assertion_Policy Ignore is in effect.
2331 if not Has_Null_Body (Proc_Id) then
2332 Append_New_To (Comp_Checks,
2333 Make_Procedure_Call_Statement (Loc,
2335 New_Occurrence_Of (Proc_Id, Loc),
2336 Parameter_Associations => New_List (
2337 Make_Indexed_Component (Loc,
2338 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2339 Expressions => New_Copy_List (Indices)))));
2343 Produced_Check := True;
2345 end Process_Array_Component;
2347 ---------------------------
2348 -- Process_One_Dimension --
2349 ---------------------------
2351 procedure Process_One_Dimension
2354 Dim_Checks : in out List_Id)
2356 Comp_Checks : List_Id := No_List;
2360 -- Generate the invariant checks for the array component after all
2361 -- dimensions have produced their respective loops.
2364 Process_Array_Component
2365 (Indices => Indices,
2366 Comp_Checks => Dim_Checks);
2368 -- Otherwise create a loop for the current dimension
2371 -- Create a new loop variable for each dimension
2374 Make_Defining_Identifier (Loc,
2375 Chars => New_External_Name ('I', Dim));
2376 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2378 Process_One_Dimension
2381 Dim_Checks => Comp_Checks);
2384 -- for I<Dim> in _object'Range (<Dim>) loop
2388 -- Note that the invariant procedure may have a null body if
2389 -- assertions are disabled or Assertion_Policy Ignore is in
2392 if Present (Comp_Checks) then
2393 Append_New_To (Dim_Checks,
2394 Make_Implicit_Loop_Statement (T,
2395 Identifier => Empty,
2397 Make_Iteration_Scheme (Loc,
2398 Loop_Parameter_Specification =>
2399 Make_Loop_Parameter_Specification (Loc,
2400 Defining_Identifier => Index,
2401 Discrete_Subtype_Definition =>
2402 Make_Attribute_Reference (Loc,
2404 New_Occurrence_Of (Obj_Id, Loc),
2405 Attribute_Name => Name_Range,
2406 Expressions => New_List (
2407 Make_Integer_Literal (Loc, Dim))))),
2408 Statements => Comp_Checks));
2411 end Process_One_Dimension;
2413 -- Start of processing for Add_Array_Component_Invariants
2416 Process_One_Dimension
2418 Indices => New_List,
2419 Dim_Checks => Checks);
2420 end Add_Array_Component_Invariants;
2422 ------------------------------
2423 -- Add_Inherited_Invariants --
2424 ------------------------------
2426 procedure Add_Inherited_Invariants
2428 Priv_Typ : Entity_Id;
2429 Full_Typ : Entity_Id;
2431 Checks : in out List_Id)
2433 Deriv_Typ : Entity_Id;
2436 Prag_Expr : Node_Id;
2437 Prag_Expr_Arg : Node_Id;
2439 Prag_Typ_Arg : Node_Id;
2441 Par_Proc : Entity_Id;
2442 -- The "partial" invariant procedure of Par_Typ
2444 Par_Typ : Entity_Id;
2445 -- The suitable view of the parent type used in the substitution of
2449 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2453 -- When the type inheriting the class-wide invariant is a concurrent
2454 -- type, use the corresponding record type because it contains all
2455 -- primitive operations of the concurrent type and allows for proper
2458 if Is_Concurrent_Type (T) then
2459 Deriv_Typ := Corresponding_Record_Type (T);
2464 pragma Assert (Present (Deriv_Typ));
2466 -- Determine which rep item chain to use. Precedence is given to that
2467 -- of the parent type's partial view since it usually carries all the
2468 -- class-wide invariants.
2470 if Present (Priv_Typ) then
2471 Prag := First_Rep_Item (Priv_Typ);
2473 Prag := First_Rep_Item (Full_Typ);
2476 while Present (Prag) loop
2477 if Nkind (Prag) = N_Pragma
2478 and then Pragma_Name (Prag) = Name_Invariant
2480 -- Nothing to do if the pragma was already processed
2482 if Contains (Pragmas_Seen, Prag) then
2485 -- Nothing to do when the caller requests the processing of all
2486 -- inherited class-wide invariants, but the pragma does not
2487 -- fall in this category.
2489 elsif not Class_Present (Prag) then
2493 -- Extract the arguments of the invariant pragma
2495 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2496 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2497 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2498 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2500 -- The pragma applies to the partial view of the parent type
2502 if Present (Priv_Typ)
2503 and then Entity (Prag_Typ) = Priv_Typ
2505 Par_Typ := Priv_Typ;
2507 -- The pragma applies to the full view of the parent type
2509 elsif Present (Full_Typ)
2510 and then Entity (Prag_Typ) = Full_Typ
2512 Par_Typ := Full_Typ;
2514 -- Otherwise the pragma does not belong to the parent type and
2515 -- should not be considered.
2521 -- Perform the following substitutions:
2523 -- * Replace a reference to the _object parameter of the
2524 -- parent type's partial invariant procedure with a
2525 -- reference to the _object parameter of the derived
2526 -- type's full invariant procedure.
2528 -- * Replace a reference to a discriminant of the parent type
2529 -- with a suitable value from the point of view of the
2532 -- * Replace a call to an overridden parent primitive with a
2533 -- call to the overriding derived type primitive.
2535 -- * Replace a call to an inherited parent primitive with a
2536 -- call to the internally-generated inherited derived type
2539 Expr := New_Copy_Tree (Prag_Expr);
2541 -- The parent type must have a "partial" invariant procedure
2542 -- because class-wide invariants are captured exclusively by
2545 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2546 pragma Assert (Present (Par_Proc));
2551 Deriv_Typ => Deriv_Typ,
2552 Par_Obj => First_Formal (Par_Proc),
2553 Deriv_Obj => Obj_Id);
2555 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2558 Next_Rep_Item (Prag);
2560 end Add_Inherited_Invariants;
2562 ------------------------------
2563 -- Add_Interface_Invariants --
2564 ------------------------------
2566 procedure Add_Interface_Invariants
2569 Checks : in out List_Id)
2571 Iface_Elmt : Elmt_Id;
2575 -- Generate an invariant check for each class-wide invariant coming
2576 -- from all interfaces implemented by type T.
2578 if Is_Tagged_Type (T) then
2579 Collect_Interfaces (T, Ifaces);
2581 -- Process the class-wide invariants of all implemented interfaces
2583 Iface_Elmt := First_Elmt (Ifaces);
2584 while Present (Iface_Elmt) loop
2586 -- The Full_Typ parameter is intentionally left Empty because
2587 -- interfaces are treated as the partial view of a private type
2588 -- in order to achieve uniformity with the general case.
2590 Add_Inherited_Invariants
2592 Priv_Typ => Node (Iface_Elmt),
2597 Next_Elmt (Iface_Elmt);
2600 end Add_Interface_Invariants;
2602 -------------------------
2603 -- Add_Invariant_Check --
2604 -------------------------
2606 procedure Add_Invariant_Check
2609 Checks : in out List_Id;
2610 Inherited : Boolean := False)
2612 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2613 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2614 Ploc : constant Source_Ptr := Sloc (Prag);
2615 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2621 -- The invariant is ignored, nothing left to do
2623 if Is_Ignored (Prag) then
2626 -- Otherwise the invariant is checked. Build a pragma Check to verify
2627 -- the expression at run time.
2631 Make_Pragma_Argument_Association (Ploc,
2632 Expression => Make_Identifier (Ploc, Nam)),
2633 Make_Pragma_Argument_Association (Ploc,
2634 Expression => Expr));
2636 -- Handle the String argument (if any)
2638 if Present (Str_Arg) then
2639 Str := Strval (Get_Pragma_Arg (Str_Arg));
2641 -- When inheriting an invariant, modify the message from
2642 -- "failed invariant" to "failed inherited invariant".
2645 String_To_Name_Buffer (Str);
2647 if Name_Buffer (1 .. 16) = "failed invariant" then
2648 Insert_Str_In_Name_Buffer ("inherited ", 8);
2649 Str := String_From_Name_Buffer;
2654 Make_Pragma_Argument_Association (Ploc,
2655 Expression => Make_String_Literal (Ploc, Str)));
2659 -- pragma Check (<Nam>, <Expr>, <Str>);
2661 Append_New_To (Checks,
2663 Chars => Name_Check,
2664 Pragma_Argument_Associations => Assoc));
2667 -- Output an info message when inheriting an invariant and the
2668 -- listing option is enabled.
2670 if Inherited and Opt.List_Inherited_Aspects then
2671 Error_Msg_Sloc := Sloc (Prag);
2673 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
2676 -- Add the pragma to the list of processed pragmas
2678 Append_New_Elmt (Prag, Pragmas_Seen);
2679 Produced_Check := True;
2680 end Add_Invariant_Check;
2682 ---------------------------
2683 -- Add_Parent_Invariants --
2684 ---------------------------
2686 procedure Add_Parent_Invariants
2689 Checks : in out List_Id)
2691 Dummy_1 : Entity_Id;
2692 Dummy_2 : Entity_Id;
2694 Curr_Typ : Entity_Id;
2695 -- The entity of the current type being examined
2697 Full_Typ : Entity_Id;
2698 -- The full view of Par_Typ
2700 Par_Typ : Entity_Id;
2701 -- The entity of the parent type
2703 Priv_Typ : Entity_Id;
2704 -- The partial view of Par_Typ
2707 -- Do not process array types because they cannot have true parent
2708 -- types. This also prevents the generation of a duplicate invariant
2709 -- check when the input type is an array base type because its Etype
2710 -- denotes the first subtype, both of which share the same component
2713 if Is_Array_Type (T) then
2717 -- Climb the parent type chain
2721 -- Do not consider subtypes as they inherit the invariants
2722 -- from their base types.
2724 Par_Typ := Base_Type (Etype (Curr_Typ));
2726 -- Stop the climb once the root of the parent chain is
2729 exit when Curr_Typ = Par_Typ;
2731 -- Process the class-wide invariants of the parent type
2733 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
2735 -- Process the elements of an array type
2737 if Is_Array_Type (Full_Typ) then
2738 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
2740 -- Process the components of a record type
2742 elsif Ekind (Full_Typ) = E_Record_Type then
2743 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
2746 Add_Inherited_Invariants
2748 Priv_Typ => Priv_Typ,
2749 Full_Typ => Full_Typ,
2753 Curr_Typ := Par_Typ;
2755 end Add_Parent_Invariants;
2757 ------------------------
2758 -- Add_Own_Invariants --
2759 ------------------------
2761 procedure Add_Own_Invariants
2764 Checks : in out List_Id;
2765 Priv_Item : Node_Id := Empty)
2770 Prag_Expr : Node_Id;
2771 Prag_Expr_Arg : Node_Id;
2773 Prag_Typ_Arg : Node_Id;
2776 if not Present (T) then
2780 Prag := First_Rep_Item (T);
2781 while Present (Prag) loop
2782 if Nkind (Prag) = N_Pragma
2783 and then Pragma_Name (Prag) = Name_Invariant
2785 -- Stop the traversal of the rep item chain once a specific
2786 -- item is encountered.
2788 if Present (Priv_Item) and then Prag = Priv_Item then
2792 -- Nothing to do if the pragma was already processed
2794 if Contains (Pragmas_Seen, Prag) then
2798 -- Extract the arguments of the invariant pragma
2800 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2801 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2802 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
2803 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2804 Prag_Asp := Corresponding_Aspect (Prag);
2806 -- Verify the pragma belongs to T, otherwise the pragma applies
2807 -- to a parent type in which case it will be processed later by
2808 -- Add_Parent_Invariants or Add_Interface_Invariants.
2810 if Entity (Prag_Typ) /= T then
2814 Expr := New_Copy_Tree (Prag_Expr);
2816 -- Substitute all references to type T with references to the
2817 -- _object formal parameter.
2819 Replace_Type_References (Expr, T, Obj_Id);
2821 -- Preanalyze the invariant expression to detect errors and at
2822 -- the same time capture the visibility of the proper package
2825 Set_Parent (Expr, Parent (Prag_Expr));
2826 Preanalyze_Assert_Expression (Expr, Any_Boolean);
2828 -- Save a copy of the expression when T is tagged to detect
2829 -- errors and capture the visibility of the proper package part
2830 -- for the generation of inherited type invariants.
2832 if Is_Tagged_Type (T) then
2833 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
2836 -- If the pragma comes from an aspect specification, replace
2837 -- the saved expression because all type references must be
2838 -- substituted for the call to Preanalyze_Spec_Expression in
2839 -- Check_Aspect_At_xxx routines.
2841 if Present (Prag_Asp) then
2842 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
2845 Add_Invariant_Check (Prag, Expr, Checks);
2848 Next_Rep_Item (Prag);
2850 end Add_Own_Invariants;
2852 -------------------------------------
2853 -- Add_Record_Component_Invariants --
2854 -------------------------------------
2856 procedure Add_Record_Component_Invariants
2859 Checks : in out List_Id)
2861 procedure Process_Component_List
2862 (Comp_List : Node_Id;
2863 CL_Checks : in out List_Id);
2864 -- Generate invariant checks for all record components found in
2865 -- component list Comp_List, including variant parts. All created
2866 -- checks are added to list CL_Checks.
2868 procedure Process_Record_Component
2869 (Comp_Id : Entity_Id;
2870 Comp_Checks : in out List_Id);
2871 -- Generate an invariant check for a record component identified by
2872 -- Comp_Id. All created checks are added to list Comp_Checks.
2874 ----------------------------
2875 -- Process_Component_List --
2876 ----------------------------
2878 procedure Process_Component_List
2879 (Comp_List : Node_Id;
2880 CL_Checks : in out List_Id)
2884 Var_Alts : List_Id := No_List;
2885 Var_Checks : List_Id := No_List;
2886 Var_Stmts : List_Id;
2888 Produced_Variant_Check : Boolean := False;
2889 -- This flag tracks whether the component has produced at least
2890 -- one invariant check.
2893 -- Traverse the component items
2895 Comp := First (Component_Items (Comp_List));
2896 while Present (Comp) loop
2897 if Nkind (Comp) = N_Component_Declaration then
2899 -- Generate the component invariant check
2901 Process_Record_Component
2902 (Comp_Id => Defining_Entity (Comp),
2903 Comp_Checks => CL_Checks);
2909 -- Traverse the variant part
2911 if Present (Variant_Part (Comp_List)) then
2912 Var := First (Variants (Variant_Part (Comp_List)));
2913 while Present (Var) loop
2914 Var_Checks := No_List;
2916 -- Generate invariant checks for all components and variant
2917 -- parts that qualify.
2919 Process_Component_List
2920 (Comp_List => Component_List (Var),
2921 CL_Checks => Var_Checks);
2923 -- The components of the current variant produced at least
2924 -- one invariant check.
2926 if Present (Var_Checks) then
2927 Var_Stmts := Var_Checks;
2928 Produced_Variant_Check := True;
2930 -- Otherwise there are either no components with invariants,
2931 -- assertions are disabled, or Assertion_Policy Ignore is in
2935 Var_Stmts := New_List (Make_Null_Statement (Loc));
2938 Append_New_To (Var_Alts,
2939 Make_Case_Statement_Alternative (Loc,
2941 New_Copy_List (Discrete_Choices (Var)),
2942 Statements => Var_Stmts));
2947 -- Create a case statement which verifies the invariant checks
2948 -- of a particular component list depending on the discriminant
2949 -- values only when there is at least one real invariant check.
2951 if Produced_Variant_Check then
2952 Append_New_To (CL_Checks,
2953 Make_Case_Statement (Loc,
2955 Make_Selected_Component (Loc,
2956 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2959 (Entity (Name (Variant_Part (Comp_List))), Loc)),
2960 Alternatives => Var_Alts));
2963 end Process_Component_List;
2965 ------------------------------
2966 -- Process_Record_Component --
2967 ------------------------------
2969 procedure Process_Record_Component
2970 (Comp_Id : Entity_Id;
2971 Comp_Checks : in out List_Id)
2973 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
2974 Proc_Id : Entity_Id;
2976 Produced_Component_Check : Boolean := False;
2977 -- This flag tracks whether the component has produced at least
2978 -- one invariant check.
2981 -- Nothing to do for internal component _parent. Note that it is
2982 -- not desirable to check whether the component comes from source
2983 -- because protected type components are relocated to an internal
2984 -- corresponding record, but still need processing.
2986 if Chars (Comp_Id) = Name_uParent then
2990 -- Verify the invariant of the component. Note that an access
2991 -- type may have an invariant when it acts as the full view of a
2992 -- private type and the invariant appears on the partial view. In
2993 -- this case verify the access value itself.
2995 if Has_Invariants (Comp_Typ) then
2997 -- In GNATprove mode, the component invariants are checked by
2998 -- other means. They should not be added to the record type
2999 -- invariant procedure, so that the procedure can be used to
3000 -- check the record type invariants if any.
3002 if GNATprove_Mode then
3006 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3008 -- The component type should have an invariant procedure
3009 -- if it has invariants of its own or inherits class-wide
3010 -- invariants from parent or interface types.
3012 pragma Assert (Present (Proc_Id));
3015 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
3017 -- Note that the invariant procedure may have a null body if
3018 -- assertions are disabled or Assertion_Policy Ignore is in
3021 if not Has_Null_Body (Proc_Id) then
3022 Append_New_To (Comp_Checks,
3023 Make_Procedure_Call_Statement (Loc,
3025 New_Occurrence_Of (Proc_Id, Loc),
3026 Parameter_Associations => New_List (
3027 Make_Selected_Component (Loc,
3029 Unchecked_Convert_To
3030 (T, New_Occurrence_Of (Obj_Id, Loc)),
3032 New_Occurrence_Of (Comp_Id, Loc)))));
3036 Produced_Check := True;
3037 Produced_Component_Check := True;
3040 if Produced_Component_Check and then Has_Unchecked_Union (T) then
3042 ("invariants cannot be checked on components of "
3043 & "unchecked_union type &??", Comp_Id, T);
3045 end Process_Record_Component;
3052 -- Start of processing for Add_Record_Component_Invariants
3055 -- An untagged derived type inherits the components of its parent
3056 -- type. In order to avoid creating redundant invariant checks, do
3057 -- not process the components now. Instead wait until the ultimate
3058 -- parent of the untagged derivation chain is reached.
3060 if not Is_Untagged_Derivation (T) then
3061 Def := Type_Definition (Parent (T));
3063 if Nkind (Def) = N_Derived_Type_Definition then
3064 Def := Record_Extension_Part (Def);
3067 pragma Assert (Nkind (Def) = N_Record_Definition);
3068 Comps := Component_List (Def);
3070 if Present (Comps) then
3071 Process_Component_List
3072 (Comp_List => Comps,
3073 CL_Checks => Checks);
3076 end Add_Record_Component_Invariants;
3080 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3081 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3082 -- Save the Ghost-related attributes to restore on exit
3085 Priv_Item : Node_Id;
3086 Proc_Body : Node_Id;
3087 Proc_Body_Id : Entity_Id;
3088 Proc_Decl : Node_Id;
3089 Proc_Id : Entity_Id;
3090 Stmts : List_Id := No_List;
3092 CRec_Typ : Entity_Id := Empty;
3093 -- The corresponding record type of Full_Typ
3095 Full_Proc : Entity_Id := Empty;
3096 -- The entity of the "full" invariant procedure
3098 Full_Typ : Entity_Id := Empty;
3099 -- The full view of the working type
3101 Obj_Id : Entity_Id := Empty;
3102 -- The _object formal parameter of the invariant procedure
3104 Part_Proc : Entity_Id := Empty;
3105 -- The entity of the "partial" invariant procedure
3107 Priv_Typ : Entity_Id := Empty;
3108 -- The partial view of the working type
3110 Work_Typ : Entity_Id := Empty;
3113 -- Start of processing for Build_Invariant_Procedure_Body
3118 -- Do not process the underlying full view of a private type. There is
3119 -- no way to get back to the partial view, plus the body will be built
3120 -- by the full view or the base type.
3122 if Is_Underlying_Full_View (Work_Typ) then
3125 -- The input type denotes the implementation base type of a constrained
3126 -- array type. Work with the first subtype as all invariant pragmas are
3127 -- on its rep item chain.
3129 elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3130 Work_Typ := First_Subtype (Work_Typ);
3132 -- The input type denotes the corresponding record type of a protected
3133 -- or task type. Work with the concurrent type because the corresponding
3134 -- record type may not be visible to clients of the type.
3136 elsif Ekind (Work_Typ) = E_Record_Type
3137 and then Is_Concurrent_Record_Type (Work_Typ)
3139 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3142 -- The working type may be subject to pragma Ghost. Set the mode now to
3143 -- ensure that the invariant procedure is properly marked as Ghost.
3145 Set_Ghost_Mode (Work_Typ);
3147 -- The type must either have invariants of its own, inherit class-wide
3148 -- invariants from parent types or interfaces, or be an array or record
3149 -- type whose components have invariants.
3151 pragma Assert (Has_Invariants (Work_Typ));
3153 -- Interfaces are treated as the partial view of a private type in order
3154 -- to achieve uniformity with the general case.
3156 if Is_Interface (Work_Typ) then
3157 Priv_Typ := Work_Typ;
3159 -- Otherwise obtain both views of the type
3162 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
3165 -- The caller requests a body for the partial invariant procedure
3167 if Partial_Invariant then
3168 Full_Proc := Invariant_Procedure (Work_Typ);
3169 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3171 -- The "full" invariant procedure body was already created
3173 if Present (Full_Proc)
3175 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
3177 -- This scenario happens only when the type is an untagged
3178 -- derivation from a private parent and the underlying full
3179 -- view was processed before the partial view.
3182 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3184 -- Nothing to do because the processing of the underlying full
3185 -- view already checked the invariants of the partial view.
3190 -- Create a declaration for the "partial" invariant procedure if it
3191 -- is not available.
3193 if No (Proc_Id) then
3194 Build_Invariant_Procedure_Declaration
3196 Partial_Invariant => True);
3198 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3201 -- The caller requests a body for the "full" invariant procedure
3204 Proc_Id := Invariant_Procedure (Work_Typ);
3205 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3207 -- Create a declaration for the "full" invariant procedure if it is
3210 if No (Proc_Id) then
3211 Build_Invariant_Procedure_Declaration (Work_Typ);
3212 Proc_Id := Invariant_Procedure (Work_Typ);
3216 -- At this point there should be an invariant procedure declaration
3218 pragma Assert (Present (Proc_Id));
3219 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3221 -- Nothing to do if the invariant procedure already has a body
3223 if Present (Corresponding_Body (Proc_Decl)) then
3227 -- Emulate the environment of the invariant procedure by installing its
3228 -- scope and formal parameters. Note that this is not needed, but having
3229 -- the scope installed helps with the detection of invariant-related
3232 Push_Scope (Proc_Id);
3233 Install_Formals (Proc_Id);
3235 Obj_Id := First_Formal (Proc_Id);
3236 pragma Assert (Present (Obj_Id));
3238 -- The "partial" invariant procedure verifies the invariants of the
3239 -- partial view only.
3241 if Partial_Invariant then
3242 pragma Assert (Present (Priv_Typ));
3249 -- Otherwise the "full" invariant procedure verifies the invariants of
3250 -- the full view, all array or record components, as well as class-wide
3251 -- invariants inherited from parent types or interfaces. In addition, it
3252 -- indirectly verifies the invariants of the partial view by calling the
3253 -- "partial" invariant procedure.
3256 pragma Assert (Present (Full_Typ));
3258 -- Check the invariants of the partial view by calling the "partial"
3259 -- invariant procedure. Generate:
3261 -- <Work_Typ>Partial_Invariant (_object);
3263 if Present (Part_Proc) then
3264 Append_New_To (Stmts,
3265 Make_Procedure_Call_Statement (Loc,
3266 Name => New_Occurrence_Of (Part_Proc, Loc),
3267 Parameter_Associations => New_List (
3268 New_Occurrence_Of (Obj_Id, Loc))));
3270 Produced_Check := True;
3275 -- Derived subtypes do not have a partial view
3277 if Present (Priv_Typ) then
3279 -- The processing of the "full" invariant procedure intentionally
3280 -- skips the partial view because a) this may result in changes of
3281 -- visibility and b) lead to duplicate checks. However, when the
3282 -- full view is the underlying full view of an untagged derived
3283 -- type whose parent type is private, partial invariants appear on
3284 -- the rep item chain of the partial view only.
3286 -- package Pack_1 is
3287 -- type Root ... is private;
3289 -- <full view of Root>
3293 -- package Pack_2 is
3294 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3295 -- <underlying full view of Child>
3298 -- As a result, the processing of the full view must also consider
3299 -- all invariants of the partial view.
3301 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3304 -- Otherwise the invariants of the partial view are ignored
3307 -- Note that the rep item chain is shared between the partial
3308 -- and full views of a type. To avoid processing the invariants
3309 -- of the partial view, signal the logic to stop when the first
3310 -- rep item of the partial view has been reached.
3312 Priv_Item := First_Rep_Item (Priv_Typ);
3314 -- Ignore the invariants of the partial view by eliminating the
3321 -- Process the invariants of the full view and in certain cases those
3322 -- of the partial view. This also handles any invariants on array or
3323 -- record components.
3329 Priv_Item => Priv_Item);
3335 Priv_Item => Priv_Item);
3337 -- Process the elements of an array type
3339 if Is_Array_Type (Full_Typ) then
3340 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3342 -- Process the components of a record type
3344 elsif Ekind (Full_Typ) = E_Record_Type then
3345 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3347 -- Process the components of a corresponding record
3349 elsif Present (CRec_Typ) then
3350 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3353 -- Process the inherited class-wide invariants of all parent types.
3354 -- This also handles any invariants on record components.
3356 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3358 -- Process the inherited class-wide invariants of all implemented
3361 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3366 -- At this point there should be at least one invariant check. If this
3367 -- is not the case, then the invariant-related flags were not properly
3368 -- set, or there is a missing invariant procedure on one of the array
3369 -- or record components.
3371 pragma Assert (Produced_Check);
3373 -- Account for the case where assertions are disabled or all invariant
3374 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3378 Stmts := New_List (Make_Null_Statement (Loc));
3382 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3385 -- end <Work_Typ>[Partial_]Invariant;
3388 Make_Subprogram_Body (Loc,
3390 Copy_Subprogram_Spec (Parent (Proc_Id)),
3391 Declarations => Empty_List,
3392 Handled_Statement_Sequence =>
3393 Make_Handled_Sequence_Of_Statements (Loc,
3394 Statements => Stmts));
3395 Proc_Body_Id := Defining_Entity (Proc_Body);
3397 -- Perform minor decoration in case the body is not analyzed
3399 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
3400 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3401 Set_Scope (Proc_Body_Id, Current_Scope);
3403 -- Link both spec and body to avoid generating duplicates
3405 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3406 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3408 -- The body should not be inserted into the tree when the context is
3409 -- a generic unit because it is not part of the template. Note
3410 -- that the body must still be generated in order to resolve the
3413 if Inside_A_Generic then
3416 -- Semi-insert the body into the tree for GNATprove by setting its
3417 -- Parent field. This allows for proper upstream tree traversals.
3419 elsif GNATprove_Mode then
3420 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3422 -- Otherwise the body is part of the freezing actions of the type
3425 Append_Freeze_Action (Work_Typ, Proc_Body);
3429 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3430 end Build_Invariant_Procedure_Body;
3432 -------------------------------------------
3433 -- Build_Invariant_Procedure_Declaration --
3434 -------------------------------------------
3436 -- WARNING: This routine manages Ghost regions. Return statements must be
3437 -- replaced by gotos which jump to the end of the routine and restore the
3440 procedure Build_Invariant_Procedure_Declaration
3442 Partial_Invariant : Boolean := False)
3444 Loc : constant Source_Ptr := Sloc (Typ);
3446 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3447 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3448 -- Save the Ghost-related attributes to restore on exit
3450 Proc_Decl : Node_Id;
3451 Proc_Id : Entity_Id;
3455 CRec_Typ : Entity_Id;
3456 -- The corresponding record type of Full_Typ
3458 Full_Typ : Entity_Id;
3459 -- The full view of working type
3462 -- The _object formal parameter of the invariant procedure
3464 Obj_Typ : Entity_Id;
3465 -- The type of the _object formal parameter
3467 Priv_Typ : Entity_Id;
3468 -- The partial view of working type
3470 UFull_Typ : Entity_Id;
3471 -- The underlying full view of Full_Typ
3473 Work_Typ : Entity_Id;
3479 -- The input type denotes the implementation base type of a constrained
3480 -- array type. Work with the first subtype as all invariant pragmas are
3481 -- on its rep item chain.
3483 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3484 Work_Typ := First_Subtype (Work_Typ);
3486 -- The input denotes the corresponding record type of a protected or a
3487 -- task type. Work with the concurrent type because the corresponding
3488 -- record type may not be visible to clients of the type.
3490 elsif Ekind (Work_Typ) = E_Record_Type
3491 and then Is_Concurrent_Record_Type (Work_Typ)
3493 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3496 -- The working type may be subject to pragma Ghost. Set the mode now to
3497 -- ensure that the invariant procedure is properly marked as Ghost.
3499 Set_Ghost_Mode (Work_Typ);
3501 -- The type must either have invariants of its own, inherit class-wide
3502 -- invariants from parent or interface types, or be an array or record
3503 -- type whose components have invariants.
3505 pragma Assert (Has_Invariants (Work_Typ));
3507 -- Nothing to do if the type already has a "partial" invariant procedure
3509 if Partial_Invariant then
3510 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3514 -- Nothing to do if the type already has a "full" invariant procedure
3516 elsif Present (Invariant_Procedure (Work_Typ)) then
3520 -- The caller requests the declaration of the "partial" invariant
3523 if Partial_Invariant then
3524 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3526 -- Otherwise the caller requests the declaration of the "full" invariant
3530 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3533 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3535 -- Perform minor decoration in case the declaration is not analyzed
3537 Set_Ekind (Proc_Id, E_Procedure);
3538 Set_Etype (Proc_Id, Standard_Void_Type);
3539 Set_Scope (Proc_Id, Current_Scope);
3541 if Partial_Invariant then
3542 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3543 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3545 Set_Is_Invariant_Procedure (Proc_Id);
3546 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3549 -- The invariant procedure requires debug info when the invariants are
3550 -- subject to Source Coverage Obligations.
3552 if Generate_SCO then
3553 Set_Debug_Info_Needed (Proc_Id);
3556 -- Obtain all views of the input type
3558 Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ);
3560 -- Associate the invariant procedure and various flags with all views
3562 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3563 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3564 Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ);
3565 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3567 -- The declaration of the invariant procedure is inserted after the
3568 -- declaration of the partial view as this allows for proper external
3571 if Present (Priv_Typ) then
3572 Typ_Decl := Declaration_Node (Priv_Typ);
3574 -- Anonymous arrays in object declarations have no explicit declaration
3575 -- so use the related object declaration as the insertion point.
3577 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
3578 Typ_Decl := Associated_Node_For_Itype (Work_Typ);
3580 -- Derived types with the full view as parent do not have a partial
3581 -- view. Insert the invariant procedure after the derived type.
3584 Typ_Decl := Declaration_Node (Full_Typ);
3587 -- The type should have a declarative node
3589 pragma Assert (Present (Typ_Decl));
3591 -- Create the formal parameter which emulates the variable-like behavior
3592 -- of the current type instance.
3594 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3596 -- When generating an invariant procedure declaration for an abstract
3597 -- type (including interfaces), use the class-wide type as the _object
3598 -- type. This has several desirable effects:
3600 -- * The invariant procedure does not become a primitive of the type.
3601 -- This eliminates the need to either special case the treatment of
3602 -- invariant procedures, or to make it a predefined primitive and
3603 -- force every derived type to potentially provide an empty body.
3605 -- * The invariant procedure does not need to be declared as abstract.
3606 -- This allows for a proper body, which in turn avoids redundant
3607 -- processing of the same invariants for types with multiple views.
3609 -- * The class-wide type allows for calls to abstract primitives
3610 -- within a nonabstract subprogram. The calls are treated as
3611 -- dispatching and require additional processing when they are
3612 -- remapped to call primitives of derived types. See routine
3613 -- Replace_References for details.
3615 if Is_Abstract_Type (Work_Typ) then
3616 Obj_Typ := Class_Wide_Type (Work_Typ);
3618 Obj_Typ := Work_Typ;
3621 -- Perform minor decoration in case the declaration is not analyzed
3623 Set_Ekind (Obj_Id, E_In_Parameter);
3624 Set_Etype (Obj_Id, Obj_Typ);
3625 Set_Scope (Obj_Id, Proc_Id);
3627 Set_First_Entity (Proc_Id, Obj_Id);
3628 Set_Last_Entity (Proc_Id, Obj_Id);
3631 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3634 Make_Subprogram_Declaration (Loc,
3636 Make_Procedure_Specification (Loc,
3637 Defining_Unit_Name => Proc_Id,
3638 Parameter_Specifications => New_List (
3639 Make_Parameter_Specification (Loc,
3640 Defining_Identifier => Obj_Id,
3641 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3643 -- The declaration should not be inserted into the tree when the context
3644 -- is a generic unit because it is not part of the template.
3646 if Inside_A_Generic then
3649 -- Semi-insert the declaration into the tree for GNATprove by setting
3650 -- its Parent field. This allows for proper upstream tree traversals.
3652 elsif GNATprove_Mode then
3653 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3655 -- Otherwise insert the declaration
3658 pragma Assert (Present (Typ_Decl));
3659 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3663 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3664 end Build_Invariant_Procedure_Declaration;
3666 --------------------------
3667 -- Build_Procedure_Form --
3668 --------------------------
3670 procedure Build_Procedure_Form (N : Node_Id) is
3671 Loc : constant Source_Ptr := Sloc (N);
3672 Subp : constant Entity_Id := Defining_Entity (N);
3674 Func_Formal : Entity_Id;
3675 Proc_Formals : List_Id;
3676 Proc_Decl : Node_Id;
3679 -- No action needed if this transformation was already done, or in case
3680 -- of subprogram renaming declarations.
3682 if Nkind (Specification (N)) = N_Procedure_Specification
3683 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3688 -- Ditto when dealing with an expression function, where both the
3689 -- original expression and the generated declaration end up being
3692 if Rewritten_For_C (Subp) then
3696 Proc_Formals := New_List;
3698 -- Create a list of formal parameters with the same types as the
3701 Func_Formal := First_Formal (Subp);
3702 while Present (Func_Formal) loop
3703 Append_To (Proc_Formals,
3704 Make_Parameter_Specification (Loc,
3705 Defining_Identifier =>
3706 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
3708 New_Occurrence_Of (Etype (Func_Formal), Loc)));
3710 Next_Formal (Func_Formal);
3713 -- Add an extra out parameter to carry the function result
3715 Append_To (Proc_Formals,
3716 Make_Parameter_Specification (Loc,
3717 Defining_Identifier =>
3718 Make_Defining_Identifier (Loc, Name_UP_RESULT),
3719 Out_Present => True,
3720 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
3722 -- The new procedure declaration is inserted immediately after the
3723 -- function declaration. The processing in Build_Procedure_Body_Form
3724 -- relies on this order.
3727 Make_Subprogram_Declaration (Loc,
3729 Make_Procedure_Specification (Loc,
3730 Defining_Unit_Name =>
3731 Make_Defining_Identifier (Loc, Chars (Subp)),
3732 Parameter_Specifications => Proc_Formals));
3734 Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
3736 -- Entity of procedure must remain invisible so that it does not
3737 -- overload subsequent references to the original function.
3739 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
3741 -- Mark the function as having a procedure form and link the function
3742 -- and its internally built procedure.
3744 Set_Rewritten_For_C (Subp);
3745 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
3746 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
3747 end Build_Procedure_Form;
3749 ------------------------
3750 -- Build_Runtime_Call --
3751 ------------------------
3753 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
3755 -- If entity is not available, we can skip making the call (this avoids
3756 -- junk duplicated error messages in a number of cases).
3758 if not RTE_Available (RE) then
3759 return Make_Null_Statement (Loc);
3762 Make_Procedure_Call_Statement (Loc,
3763 Name => New_Occurrence_Of (RTE (RE), Loc));
3765 end Build_Runtime_Call;
3767 ------------------------
3768 -- Build_SS_Mark_Call --
3769 ------------------------
3771 function Build_SS_Mark_Call
3773 Mark : Entity_Id) return Node_Id
3777 -- Mark : constant Mark_Id := SS_Mark;
3780 Make_Object_Declaration (Loc,
3781 Defining_Identifier => Mark,
3782 Constant_Present => True,
3783 Object_Definition =>
3784 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
3786 Make_Function_Call (Loc,
3787 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
3788 end Build_SS_Mark_Call;
3790 ---------------------------
3791 -- Build_SS_Release_Call --
3792 ---------------------------
3794 function Build_SS_Release_Call
3796 Mark : Entity_Id) return Node_Id
3800 -- SS_Release (Mark);
3803 Make_Procedure_Call_Statement (Loc,
3805 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
3806 Parameter_Associations => New_List (
3807 New_Occurrence_Of (Mark, Loc)));
3808 end Build_SS_Release_Call;
3810 ----------------------------
3811 -- Build_Task_Array_Image --
3812 ----------------------------
3814 -- This function generates the body for a function that constructs the
3815 -- image string for a task that is an array component. The function is
3816 -- local to the init proc for the array type, and is called for each one
3817 -- of the components. The constructed image has the form of an indexed
3818 -- component, whose prefix is the outer variable of the array type.
3819 -- The n-dimensional array type has known indexes Index, Index2...
3821 -- Id_Ref is an indexed component form created by the enclosing init proc.
3822 -- Its successive indexes are Val1, Val2, ... which are the loop variables
3823 -- in the loops that call the individual task init proc on each component.
3825 -- The generated function has the following structure:
3827 -- function F return String is
3828 -- Pref : string renames Task_Name;
3829 -- T1 : String := Index1'Image (Val1);
3831 -- Tn : String := indexn'image (Valn);
3832 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
3833 -- -- Len includes commas and the end parentheses.
3834 -- Res : String (1..Len);
3835 -- Pos : Integer := Pref'Length;
3838 -- Res (1 .. Pos) := Pref;
3840 -- Res (Pos) := '(';
3842 -- Res (Pos .. Pos + T1'Length - 1) := T1;
3843 -- Pos := Pos + T1'Length;
3844 -- Res (Pos) := '.';
3847 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
3848 -- Res (Len) := ')';
3853 -- Needless to say, multidimensional arrays of tasks are rare enough that
3854 -- the bulkiness of this code is not really a concern.
3856 function Build_Task_Array_Image
3860 Dyn : Boolean := False) return Node_Id
3862 Dims : constant Nat := Number_Dimensions (A_Type);
3863 -- Number of dimensions for array of tasks
3865 Temps : array (1 .. Dims) of Entity_Id;
3866 -- Array of temporaries to hold string for each index
3872 -- Total length of generated name
3875 -- Running index for substring assignments
3877 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
3878 -- Name of enclosing variable, prefix of resulting name
3881 -- String to hold result
3884 -- Value of successive indexes
3887 -- Expression to compute total size of string
3890 -- Entity for name at one index position
3892 Decls : constant List_Id := New_List;
3893 Stats : constant List_Id := New_List;
3896 -- For a dynamic task, the name comes from the target variable. For a
3897 -- static one it is a formal of the enclosing init proc.
3900 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
3902 Make_Object_Declaration (Loc,
3903 Defining_Identifier => Pref,
3904 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3906 Make_String_Literal (Loc,
3907 Strval => String_From_Name_Buffer)));
3911 Make_Object_Renaming_Declaration (Loc,
3912 Defining_Identifier => Pref,
3913 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
3914 Name => Make_Identifier (Loc, Name_uTask_Name)));
3917 Indx := First_Index (A_Type);
3918 Val := First (Expressions (Id_Ref));
3920 for J in 1 .. Dims loop
3921 T := Make_Temporary (Loc, 'T');
3925 Make_Object_Declaration (Loc,
3926 Defining_Identifier => T,
3927 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3929 Make_Attribute_Reference (Loc,
3930 Attribute_Name => Name_Image,
3931 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
3932 Expressions => New_List (New_Copy_Tree (Val)))));
3938 Sum := Make_Integer_Literal (Loc, Dims + 1);
3944 Make_Attribute_Reference (Loc,
3945 Attribute_Name => Name_Length,
3946 Prefix => New_Occurrence_Of (Pref, Loc),
3947 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3949 for J in 1 .. Dims loop
3954 Make_Attribute_Reference (Loc,
3955 Attribute_Name => Name_Length,
3957 New_Occurrence_Of (Temps (J), Loc),
3958 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3961 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
3963 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
3966 Make_Assignment_Statement (Loc,
3968 Make_Indexed_Component (Loc,
3969 Prefix => New_Occurrence_Of (Res, Loc),
3970 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
3972 Make_Character_Literal (Loc,
3974 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
3977 Make_Assignment_Statement (Loc,
3978 Name => New_Occurrence_Of (Pos, Loc),
3981 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3982 Right_Opnd => Make_Integer_Literal (Loc, 1))));
3984 for J in 1 .. Dims loop
3987 Make_Assignment_Statement (Loc,
3990 Prefix => New_Occurrence_Of (Res, Loc),
3993 Low_Bound => New_Occurrence_Of (Pos, Loc),
3995 Make_Op_Subtract (Loc,
3998 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4000 Make_Attribute_Reference (Loc,
4001 Attribute_Name => Name_Length,
4003 New_Occurrence_Of (Temps (J), Loc),
4005 New_List (Make_Integer_Literal (Loc, 1)))),
4006 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
4008 Expression => New_Occurrence_Of (Temps (J), Loc)));
4012 Make_Assignment_Statement (Loc,
4013 Name => New_Occurrence_Of (Pos, Loc),
4016 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4018 Make_Attribute_Reference (Loc,
4019 Attribute_Name => Name_Length,
4020 Prefix => New_Occurrence_Of (Temps (J), Loc),
4022 New_List (Make_Integer_Literal (Loc, 1))))));
4024 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
4027 Make_Assignment_Statement (Loc,
4028 Name => Make_Indexed_Component (Loc,
4029 Prefix => New_Occurrence_Of (Res, Loc),
4030 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4032 Make_Character_Literal (Loc,
4034 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
4037 Make_Assignment_Statement (Loc,
4038 Name => New_Occurrence_Of (Pos, Loc),
4041 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4042 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4046 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
4049 Make_Assignment_Statement (Loc,
4051 Make_Indexed_Component (Loc,
4052 Prefix => New_Occurrence_Of (Res, Loc),
4053 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
4055 Make_Character_Literal (Loc,
4057 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
4058 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4059 end Build_Task_Array_Image;
4061 ----------------------------
4062 -- Build_Task_Image_Decls --
4063 ----------------------------
4065 function Build_Task_Image_Decls
4069 In_Init_Proc : Boolean := False) return List_Id
4071 Decls : constant List_Id := New_List;
4072 T_Id : Entity_Id := Empty;
4074 Expr : Node_Id := Empty;
4075 Fun : Node_Id := Empty;
4076 Is_Dyn : constant Boolean :=
4077 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
4079 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
4082 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
4083 -- generate a dummy declaration only.
4085 if Restriction_Active (No_Implicit_Heap_Allocations)
4086 or else Global_Discard_Names
4088 T_Id := Make_Temporary (Loc, 'J');
4093 Make_Object_Declaration (Loc,
4094 Defining_Identifier => T_Id,
4095 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4097 Make_String_Literal (Loc,
4098 Strval => String_From_Name_Buffer)));
4101 if Nkind (Id_Ref) = N_Identifier
4102 or else Nkind (Id_Ref) = N_Defining_Identifier
4104 -- For a simple variable, the image of the task is built from
4105 -- the name of the variable. To avoid possible conflict with the
4106 -- anonymous type created for a single protected object, add a
4110 Make_Defining_Identifier (Loc,
4111 New_External_Name (Chars (Id_Ref), 'T', 1));
4113 Get_Name_String (Chars (Id_Ref));
4116 Make_String_Literal (Loc,
4117 Strval => String_From_Name_Buffer);
4119 elsif Nkind (Id_Ref) = N_Selected_Component then
4121 Make_Defining_Identifier (Loc,
4122 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
4123 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
4125 elsif Nkind (Id_Ref) = N_Indexed_Component then
4127 Make_Defining_Identifier (Loc,
4128 New_External_Name (Chars (A_Type), 'N'));
4130 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
4134 if Present (Fun) then
4135 Append (Fun, Decls);
4136 Expr := Make_Function_Call (Loc,
4137 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
4139 if not In_Init_Proc then
4140 Set_Uses_Sec_Stack (Defining_Entity (Fun));
4144 Decl := Make_Object_Declaration (Loc,
4145 Defining_Identifier => T_Id,
4146 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4147 Constant_Present => True,
4148 Expression => Expr);
4150 Append (Decl, Decls);
4152 end Build_Task_Image_Decls;
4154 -------------------------------
4155 -- Build_Task_Image_Function --
4156 -------------------------------
4158 function Build_Task_Image_Function
4162 Res : Entity_Id) return Node_Id
4168 Make_Simple_Return_Statement (Loc,
4169 Expression => New_Occurrence_Of (Res, Loc)));
4171 Spec := Make_Function_Specification (Loc,
4172 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
4173 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
4175 -- Calls to 'Image use the secondary stack, which must be cleaned up
4176 -- after the task name is built.
4178 return Make_Subprogram_Body (Loc,
4179 Specification => Spec,
4180 Declarations => Decls,
4181 Handled_Statement_Sequence =>
4182 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
4183 end Build_Task_Image_Function;
4185 -----------------------------
4186 -- Build_Task_Image_Prefix --
4187 -----------------------------
4189 procedure Build_Task_Image_Prefix
4191 Len : out Entity_Id;
4192 Res : out Entity_Id;
4193 Pos : out Entity_Id;
4200 Len := Make_Temporary (Loc, 'L', Sum);
4203 Make_Object_Declaration (Loc,
4204 Defining_Identifier => Len,
4205 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4206 Expression => Sum));
4208 Res := Make_Temporary (Loc, 'R');
4211 Make_Object_Declaration (Loc,
4212 Defining_Identifier => Res,
4213 Object_Definition =>
4214 Make_Subtype_Indication (Loc,
4215 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4217 Make_Index_Or_Discriminant_Constraint (Loc,
4221 Low_Bound => Make_Integer_Literal (Loc, 1),
4222 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4224 -- Indicate that the result is an internal temporary, so it does not
4225 -- receive a bogus initialization when declaration is expanded. This
4226 -- is both efficient, and prevents anomalies in the handling of
4227 -- dynamic objects on the secondary stack.
4229 Set_Is_Internal (Res);
4230 Pos := Make_Temporary (Loc, 'P');
4233 Make_Object_Declaration (Loc,
4234 Defining_Identifier => Pos,
4235 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4237 -- Pos := Prefix'Length;
4240 Make_Assignment_Statement (Loc,
4241 Name => New_Occurrence_Of (Pos, Loc),
4243 Make_Attribute_Reference (Loc,
4244 Attribute_Name => Name_Length,
4245 Prefix => New_Occurrence_Of (Prefix, Loc),
4246 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4248 -- Res (1 .. Pos) := Prefix;
4251 Make_Assignment_Statement (Loc,
4254 Prefix => New_Occurrence_Of (Res, Loc),
4257 Low_Bound => Make_Integer_Literal (Loc, 1),
4258 High_Bound => New_Occurrence_Of (Pos, Loc))),
4260 Expression => New_Occurrence_Of (Prefix, Loc)));
4263 Make_Assignment_Statement (Loc,
4264 Name => New_Occurrence_Of (Pos, Loc),
4267 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4268 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4269 end Build_Task_Image_Prefix;
4271 -----------------------------
4272 -- Build_Task_Record_Image --
4273 -----------------------------
4275 function Build_Task_Record_Image
4278 Dyn : Boolean := False) return Node_Id
4281 -- Total length of generated name
4284 -- Index into result
4287 -- String to hold result
4289 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4290 -- Name of enclosing variable, prefix of resulting name
4293 -- Expression to compute total size of string
4296 -- Entity for selector name
4298 Decls : constant List_Id := New_List;
4299 Stats : constant List_Id := New_List;
4302 -- For a dynamic task, the name comes from the target variable. For a
4303 -- static one it is a formal of the enclosing init proc.
4306 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4308 Make_Object_Declaration (Loc,
4309 Defining_Identifier => Pref,
4310 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4312 Make_String_Literal (Loc,
4313 Strval => String_From_Name_Buffer)));
4317 Make_Object_Renaming_Declaration (Loc,
4318 Defining_Identifier => Pref,
4319 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4320 Name => Make_Identifier (Loc, Name_uTask_Name)));
4323 Sel := Make_Temporary (Loc, 'S');
4325 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4328 Make_Object_Declaration (Loc,
4329 Defining_Identifier => Sel,
4330 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4332 Make_String_Literal (Loc,
4333 Strval => String_From_Name_Buffer)));
4335 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4341 Make_Attribute_Reference (Loc,
4342 Attribute_Name => Name_Length,
4344 New_Occurrence_Of (Pref, Loc),
4345 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4347 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4349 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
4351 -- Res (Pos) := '.';
4354 Make_Assignment_Statement (Loc,
4355 Name => Make_Indexed_Component (Loc,
4356 Prefix => New_Occurrence_Of (Res, Loc),
4357 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4359 Make_Character_Literal (Loc,
4361 Char_Literal_Value =>
4362 UI_From_Int (Character'Pos ('.')))));
4365 Make_Assignment_Statement (Loc,
4366 Name => New_Occurrence_Of (Pos, Loc),
4369 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4370 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4372 -- Res (Pos .. Len) := Selector;
4375 Make_Assignment_Statement (Loc,
4376 Name => Make_Slice (Loc,
4377 Prefix => New_Occurrence_Of (Res, Loc),
4380 Low_Bound => New_Occurrence_Of (Pos, Loc),
4381 High_Bound => New_Occurrence_Of (Len, Loc))),
4382 Expression => New_Occurrence_Of (Sel, Loc)));
4384 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4385 end Build_Task_Record_Image;
4387 ---------------------------------------
4388 -- Build_Transient_Object_Statements --
4389 ---------------------------------------
4391 procedure Build_Transient_Object_Statements
4392 (Obj_Decl : Node_Id;
4393 Fin_Call : out Node_Id;
4394 Hook_Assign : out Node_Id;
4395 Hook_Clear : out Node_Id;
4396 Hook_Decl : out Node_Id;
4397 Ptr_Decl : out Node_Id;
4398 Finalize_Obj : Boolean := True)
4400 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4401 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4402 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4404 Desig_Typ : Entity_Id;
4405 Hook_Expr : Node_Id;
4406 Hook_Id : Entity_Id;
4408 Ptr_Typ : Entity_Id;
4411 -- Recover the type of the object
4413 Desig_Typ := Obj_Typ;
4415 if Is_Access_Type (Desig_Typ) then
4416 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4419 -- Create an access type which provides a reference to the transient
4420 -- object. Generate:
4422 -- type Ptr_Typ is access all Desig_Typ;
4424 Ptr_Typ := Make_Temporary (Loc, 'A');
4425 Set_Ekind (Ptr_Typ, E_General_Access_Type);
4426 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4429 Make_Full_Type_Declaration (Loc,
4430 Defining_Identifier => Ptr_Typ,
4432 Make_Access_To_Object_Definition (Loc,
4433 All_Present => True,
4434 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4436 -- Create a temporary check which acts as a hook to the transient
4437 -- object. Generate:
4439 -- Hook : Ptr_Typ := null;
4441 Hook_Id := Make_Temporary (Loc, 'T');
4442 Set_Ekind (Hook_Id, E_Variable);
4443 Set_Etype (Hook_Id, Ptr_Typ);
4446 Make_Object_Declaration (Loc,
4447 Defining_Identifier => Hook_Id,
4448 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4449 Expression => Make_Null (Loc));
4451 -- Mark the temporary as a hook. This signals the machinery in
4452 -- Build_Finalizer to recognize this special case.
4454 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4456 -- Hook the transient object to the temporary. Generate:
4458 -- Hook := Ptr_Typ (Obj_Id);
4460 -- Hool := Obj_Id'Unrestricted_Access;
4462 if Is_Access_Type (Obj_Typ) then
4464 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4467 Make_Attribute_Reference (Loc,
4468 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4469 Attribute_Name => Name_Unrestricted_Access);
4473 Make_Assignment_Statement (Loc,
4474 Name => New_Occurrence_Of (Hook_Id, Loc),
4475 Expression => Hook_Expr);
4477 -- Crear the hook prior to finalizing the object. Generate:
4482 Make_Assignment_Statement (Loc,
4483 Name => New_Occurrence_Of (Hook_Id, Loc),
4484 Expression => Make_Null (Loc));
4486 -- Finalize the object. Generate:
4488 -- [Deep_]Finalize (Obj_Ref[.all]);
4490 if Finalize_Obj then
4491 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4493 if Is_Access_Type (Obj_Typ) then
4494 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4495 Set_Etype (Obj_Ref, Desig_Typ);
4500 (Obj_Ref => Obj_Ref,
4503 -- Otherwise finalize the hook. Generate:
4505 -- [Deep_]Finalize (Hook.all);
4511 Make_Explicit_Dereference (Loc,
4512 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4515 end Build_Transient_Object_Statements;
4517 -----------------------------
4518 -- Check_Float_Op_Overflow --
4519 -----------------------------
4521 procedure Check_Float_Op_Overflow (N : Node_Id) is
4523 -- Return if no check needed
4525 if not Is_Floating_Point_Type (Etype (N))
4526 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4528 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4529 -- and do not expand the code for float overflow checking.
4531 or else CodePeer_Mode
4536 -- Otherwise we replace the expression by
4538 -- do Tnn : constant ftype := expression;
4539 -- constraint_error when not Tnn'Valid;
4543 Loc : constant Source_Ptr := Sloc (N);
4544 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4545 Typ : constant Entity_Id := Etype (N);
4548 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4549 -- right here. We also set the node as analyzed to prevent infinite
4550 -- recursion from repeating the operation in the expansion.
4552 Set_Do_Overflow_Check (N, False);
4553 Set_Analyzed (N, True);
4555 -- Do the rewrite to include the check
4558 Make_Expression_With_Actions (Loc,
4559 Actions => New_List (
4560 Make_Object_Declaration (Loc,
4561 Defining_Identifier => Tnn,
4562 Object_Definition => New_Occurrence_Of (Typ, Loc),
4563 Constant_Present => True,
4564 Expression => Relocate_Node (N)),
4565 Make_Raise_Constraint_Error (Loc,
4569 Make_Attribute_Reference (Loc,
4570 Prefix => New_Occurrence_Of (Tnn, Loc),
4571 Attribute_Name => Name_Valid)),
4572 Reason => CE_Overflow_Check_Failed)),
4573 Expression => New_Occurrence_Of (Tnn, Loc)));
4575 Analyze_And_Resolve (N, Typ);
4577 end Check_Float_Op_Overflow;
4579 ----------------------------------
4580 -- Component_May_Be_Bit_Aligned --
4581 ----------------------------------
4583 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4587 -- If no component clause, then everything is fine, since the back end
4588 -- never misaligns from byte boundaries by default, even if there is a
4589 -- pragma Pack for the record.
4591 if No (Comp) or else No (Component_Clause (Comp)) then
4595 UT := Underlying_Type (Etype (Comp));
4597 -- It is only array and record types that cause trouble
4599 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4602 -- If we know that we have a small (at most the maximum integer size)
4603 -- record or bit-packed array, then everything is fine, since the back
4604 -- end can handle these cases correctly.
4606 elsif Esize (Comp) <= System_Max_Integer_Size
4607 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4611 -- Otherwise if the component is not byte aligned, we know we have the
4612 -- nasty unaligned case.
4614 elsif Normalized_First_Bit (Comp) /= Uint_0
4615 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4619 -- If we are large and byte aligned, then OK at this level
4624 end Component_May_Be_Bit_Aligned;
4626 -------------------------------
4627 -- Convert_To_Actual_Subtype --
4628 -------------------------------
4630 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
4634 Act_ST := Get_Actual_Subtype (Exp);
4636 if Act_ST = Etype (Exp) then
4639 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4640 Analyze_And_Resolve (Exp, Act_ST);
4642 end Convert_To_Actual_Subtype;
4644 -----------------------------------
4645 -- Corresponding_Runtime_Package --
4646 -----------------------------------
4648 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4649 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4650 -- Return True if protected type T has one entry and the maximum queue
4653 --------------------------------
4654 -- Has_One_Entry_And_No_Queue --
4655 --------------------------------
4657 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4659 Is_First : Boolean := True;
4662 Item := First_Entity (T);
4663 while Present (Item) loop
4664 if Is_Entry (Item) then
4666 -- The protected type has more than one entry
4668 if not Is_First then
4672 -- The queue length is not one
4674 if not Restriction_Active (No_Entry_Queue)
4675 and then Get_Max_Queue_Length (Item) /= Uint_1
4687 end Has_One_Entry_And_No_Queue;
4691 Pkg_Id : RTU_Id := RTU_Null;
4693 -- Start of processing for Corresponding_Runtime_Package
4696 pragma Assert (Is_Concurrent_Type (Typ));
4698 if Is_Protected_Type (Typ) then
4699 if Has_Entries (Typ)
4701 -- A protected type without entries that covers an interface and
4702 -- overrides the abstract routines with protected procedures is
4703 -- considered equivalent to a protected type with entries in the
4704 -- context of dispatching select statements. It is sufficient to
4705 -- check for the presence of an interface list in the declaration
4706 -- node to recognize this case.
4708 or else Present (Interface_List (Parent (Typ)))
4710 -- Protected types with interrupt handlers (when not using a
4711 -- restricted profile) are also considered equivalent to
4712 -- protected types with entries. The types which are used
4713 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
4714 -- are derived from Protection_Entries.
4716 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
4717 or else Has_Interrupt_Handler (Typ)
4720 or else Restriction_Active (No_Select_Statements) = False
4721 or else not Has_One_Entry_And_No_Queue (Typ)
4722 or else (Has_Attach_Handler (Typ)
4723 and then not Restricted_Profile)
4725 Pkg_Id := System_Tasking_Protected_Objects_Entries;
4727 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
4731 Pkg_Id := System_Tasking_Protected_Objects;
4736 end Corresponding_Runtime_Package;
4738 -----------------------------------
4739 -- Current_Sem_Unit_Declarations --
4740 -----------------------------------
4742 function Current_Sem_Unit_Declarations return List_Id is
4743 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
4747 -- If the current unit is a package body, locate the visible
4748 -- declarations of the package spec.
4750 if Nkind (U) = N_Package_Body then
4751 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
4754 if Nkind (U) = N_Package_Declaration then
4755 U := Specification (U);
4756 Decls := Visible_Declarations (U);
4760 Set_Visible_Declarations (U, Decls);
4764 Decls := Declarations (U);
4768 Set_Declarations (U, Decls);
4773 end Current_Sem_Unit_Declarations;
4775 -----------------------
4776 -- Duplicate_Subexpr --
4777 -----------------------
4779 function Duplicate_Subexpr
4781 Name_Req : Boolean := False;
4782 Renaming_Req : Boolean := False) return Node_Id
4785 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4786 return New_Copy_Tree (Exp);
4787 end Duplicate_Subexpr;
4789 ---------------------------------
4790 -- Duplicate_Subexpr_No_Checks --
4791 ---------------------------------
4793 function Duplicate_Subexpr_No_Checks
4795 Name_Req : Boolean := False;
4796 Renaming_Req : Boolean := False;
4797 Related_Id : Entity_Id := Empty;
4798 Is_Low_Bound : Boolean := False;
4799 Is_High_Bound : Boolean := False) return Node_Id
4806 Name_Req => Name_Req,
4807 Renaming_Req => Renaming_Req,
4808 Related_Id => Related_Id,
4809 Is_Low_Bound => Is_Low_Bound,
4810 Is_High_Bound => Is_High_Bound);
4812 New_Exp := New_Copy_Tree (Exp);
4813 Remove_Checks (New_Exp);
4815 end Duplicate_Subexpr_No_Checks;
4817 -----------------------------------
4818 -- Duplicate_Subexpr_Move_Checks --
4819 -----------------------------------
4821 function Duplicate_Subexpr_Move_Checks
4823 Name_Req : Boolean := False;
4824 Renaming_Req : Boolean := False) return Node_Id
4829 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4830 New_Exp := New_Copy_Tree (Exp);
4831 Remove_Checks (Exp);
4833 end Duplicate_Subexpr_Move_Checks;
4835 -------------------------
4836 -- Enclosing_Init_Proc --
4837 -------------------------
4839 function Enclosing_Init_Proc return Entity_Id is
4844 while Present (S) and then S /= Standard_Standard loop
4845 if Is_Init_Proc (S) then
4853 end Enclosing_Init_Proc;
4855 --------------------
4856 -- Ensure_Defined --
4857 --------------------
4859 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
4863 -- An itype reference must only be created if this is a local itype, so
4864 -- that gigi can elaborate it on the proper objstack.
4866 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
4867 IR := Make_Itype_Reference (Sloc (N));
4868 Set_Itype (IR, Typ);
4869 Insert_Action (N, IR);
4873 --------------------
4874 -- Entry_Names_OK --
4875 --------------------
4877 function Entry_Names_OK return Boolean is
4880 not Restricted_Profile
4881 and then not Global_Discard_Names
4882 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4883 and then not Restriction_Active (No_Local_Allocators);
4890 procedure Evaluate_Name (Nam : Node_Id) is
4893 -- For an aggregate, force its evaluation
4896 Force_Evaluation (Nam);
4898 -- For an attribute reference or an indexed component, evaluate the
4899 -- prefix, which is itself a name, recursively, and then force the
4900 -- evaluation of all the subscripts (or attribute expressions).
4902 when N_Attribute_Reference
4903 | N_Indexed_Component
4905 Evaluate_Name (Prefix (Nam));
4911 E := First (Expressions (Nam));
4912 while Present (E) loop
4913 Force_Evaluation (E);
4915 if Is_Rewrite_Substitution (E) then
4917 (E, Do_Range_Check (Original_Node (E)));
4924 -- For an explicit dereference, we simply force the evaluation of
4925 -- the name expression. The dereference provides a value that is the
4926 -- address for the renamed object, and it is precisely this value
4927 -- that we want to preserve.
4929 when N_Explicit_Dereference =>
4930 Force_Evaluation (Prefix (Nam));
4932 -- For a function call, we evaluate the call; same for an operator
4934 when N_Function_Call
4937 Force_Evaluation (Nam);
4939 -- For a qualified expression, we evaluate the expression
4941 when N_Qualified_Expression =>
4942 Evaluate_Name (Expression (Nam));
4944 -- For a selected component, we simply evaluate the prefix
4946 when N_Selected_Component =>
4947 Evaluate_Name (Prefix (Nam));
4949 -- For a slice, we evaluate the prefix, as for the indexed component
4950 -- case and then, if there is a range present, either directly or as
4951 -- the constraint of a discrete subtype indication, we evaluate the
4952 -- two bounds of this range.
4955 Evaluate_Name (Prefix (Nam));
4956 Evaluate_Slice_Bounds (Nam);
4958 -- For a type conversion, the expression of the conversion must be
4959 -- the name of an object, and we simply need to evaluate this name.
4961 when N_Type_Conversion =>
4962 Evaluate_Name (Expression (Nam));
4964 -- The remaining cases are direct name and character literal. In all
4965 -- these cases, we do nothing, since we want to reevaluate each time
4966 -- the renamed object is used. ??? There are more remaining cases, at
4967 -- least in the GNATprove_Mode, where this routine is called in more
4968 -- contexts than in GNAT.
4975 ---------------------------
4976 -- Evaluate_Slice_Bounds --
4977 ---------------------------
4979 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
4980 DR : constant Node_Id := Discrete_Range (Slice);
4985 if Nkind (DR) = N_Range then
4986 Force_Evaluation (Low_Bound (DR));
4987 Force_Evaluation (High_Bound (DR));
4989 elsif Nkind (DR) = N_Subtype_Indication then
4990 Constr := Constraint (DR);
4992 if Nkind (Constr) = N_Range_Constraint then
4993 Rexpr := Range_Expression (Constr);
4995 Force_Evaluation (Low_Bound (Rexpr));
4996 Force_Evaluation (High_Bound (Rexpr));
4999 end Evaluate_Slice_Bounds;
5001 ---------------------
5002 -- Evolve_And_Then --
5003 ---------------------
5005 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
5011 Make_And_Then (Sloc (Cond1),
5013 Right_Opnd => Cond1);
5015 end Evolve_And_Then;
5017 --------------------
5018 -- Evolve_Or_Else --
5019 --------------------
5021 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
5027 Make_Or_Else (Sloc (Cond1),
5029 Right_Opnd => Cond1);
5033 -----------------------------------------
5034 -- Expand_Static_Predicates_In_Choices --
5035 -----------------------------------------
5037 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
5038 pragma Assert (Nkind (N) in N_Case_Statement_Alternative | N_Variant);
5040 Choices : constant List_Id := Discrete_Choices (N);
5048 Choice := First (Choices);
5049 while Present (Choice) loop
5050 Next_C := Next (Choice);
5052 -- Check for name of subtype with static predicate
5054 if Is_Entity_Name (Choice)
5055 and then Is_Type (Entity (Choice))
5056 and then Has_Predicates (Entity (Choice))
5058 -- Loop through entries in predicate list, converting to choices
5059 -- and inserting in the list before the current choice. Note that
5060 -- if the list is empty, corresponding to a False predicate, then
5061 -- no choices are inserted.
5063 P := First (Static_Discrete_Predicate (Entity (Choice)));
5064 while Present (P) loop
5066 -- If low bound and high bounds are equal, copy simple choice
5068 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
5069 C := New_Copy (Low_Bound (P));
5071 -- Otherwise copy a range
5077 -- Change Sloc to referencing choice (rather than the Sloc of
5078 -- the predicate declaration element itself).
5080 Set_Sloc (C, Sloc (Choice));
5081 Insert_Before (Choice, C);
5085 -- Delete the predicated entry
5090 -- Move to next choice to check
5095 Set_Has_SP_Choice (N, False);
5096 end Expand_Static_Predicates_In_Choices;
5098 ------------------------------
5099 -- Expand_Subtype_From_Expr --
5100 ------------------------------
5102 -- This function is applicable for both static and dynamic allocation of
5103 -- objects which are constrained by an initial expression. Basically it
5104 -- transforms an unconstrained subtype indication into a constrained one.
5106 -- The expression may also be transformed in certain cases in order to
5107 -- avoid multiple evaluation. In the static allocation case, the general
5112 -- is transformed into
5114 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
5116 -- Here are the main cases :
5118 -- <if Expr is a Slice>
5119 -- Val : T ([Index_Subtype (Expr)]) := Expr;
5121 -- <elsif Expr is a String Literal>
5122 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
5124 -- <elsif Expr is Constrained>
5125 -- subtype T is Type_Of_Expr
5128 -- <elsif Expr is an entity_name>
5129 -- Val : T (constraints taken from Expr) := Expr;
5132 -- type Axxx is access all T;
5133 -- Rval : Axxx := Expr'ref;
5134 -- Val : T (constraints taken from Rval) := Rval.all;
5136 -- ??? note: when the Expression is allocated in the secondary stack
5137 -- we could use it directly instead of copying it by declaring
5138 -- Val : T (...) renames Rval.all
5140 procedure Expand_Subtype_From_Expr
5142 Unc_Type : Entity_Id;
5143 Subtype_Indic : Node_Id;
5145 Related_Id : Entity_Id := Empty)
5147 Loc : constant Source_Ptr := Sloc (N);
5148 Exp_Typ : constant Entity_Id := Etype (Exp);
5152 -- In general we cannot build the subtype if expansion is disabled,
5153 -- because internal entities may not have been defined. However, to
5154 -- avoid some cascaded errors, we try to continue when the expression is
5155 -- an array (or string), because it is safe to compute the bounds. It is
5156 -- in fact required to do so even in a generic context, because there
5157 -- may be constants that depend on the bounds of a string literal, both
5158 -- standard string types and more generally arrays of characters.
5160 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is
5161 -- a static expression. In that case, the subtype will be constrained
5162 -- while the original type might be unconstrained, so expanding the type
5163 -- is necessary both for passing legality checks in GNAT and for precise
5164 -- analysis in GNATprove.
5166 if GNATprove_Mode and then not Is_Static_Expression (Exp) then
5170 if not Expander_Active
5171 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5176 if Nkind (Exp) = N_Slice then
5178 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5181 Rewrite (Subtype_Indic,
5182 Make_Subtype_Indication (Loc,
5183 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5185 Make_Index_Or_Discriminant_Constraint (Loc,
5186 Constraints => New_List
5187 (New_Occurrence_Of (Slice_Type, Loc)))));
5189 -- This subtype indication may be used later for constraint checks
5190 -- we better make sure that if a variable was used as a bound of
5191 -- the original slice, its value is frozen.
5193 Evaluate_Slice_Bounds (Exp);
5196 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5197 Rewrite (Subtype_Indic,
5198 Make_Subtype_Indication (Loc,
5199 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5201 Make_Index_Or_Discriminant_Constraint (Loc,
5202 Constraints => New_List (
5203 Make_Literal_Range (Loc,
5204 Literal_Typ => Exp_Typ)))));
5206 -- If the type of the expression is an internally generated type it
5207 -- may not be necessary to create a new subtype. However there are two
5208 -- exceptions: references to the current instances, and aliased array
5209 -- object declarations for which the back end has to create a template.
5211 elsif Is_Constrained (Exp_Typ)
5212 and then not Is_Class_Wide_Type (Unc_Type)
5214 (Nkind (N) /= N_Object_Declaration
5215 or else not Is_Entity_Name (Expression (N))
5216 or else not Comes_From_Source (Entity (Expression (N)))
5217 or else not Is_Array_Type (Exp_Typ)
5218 or else not Aliased_Present (N))
5220 if Is_Itype (Exp_Typ) then
5222 -- Within an initialization procedure, a selected component
5223 -- denotes a component of the enclosing record, and it appears as
5224 -- an actual in a call to its own initialization procedure. If
5225 -- this component depends on the outer discriminant, we must
5226 -- generate the proper actual subtype for it.
5228 if Nkind (Exp) = N_Selected_Component
5229 and then Within_Init_Proc
5232 Decl : constant Node_Id :=
5233 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5235 if Present (Decl) then
5236 Insert_Action (N, Decl);
5237 T := Defining_Identifier (Decl);
5243 -- No need to generate a new subtype
5250 T := Make_Temporary (Loc, 'T');
5253 Make_Subtype_Declaration (Loc,
5254 Defining_Identifier => T,
5255 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5257 -- This type is marked as an itype even though it has an explicit
5258 -- declaration since otherwise Is_Generic_Actual_Type can get
5259 -- set, resulting in the generation of spurious errors. (See
5260 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5263 Set_Associated_Node_For_Itype (T, Exp);
5266 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5268 -- Nothing needs to be done for private types with unknown discriminants
5269 -- if the underlying type is not an unconstrained composite type or it
5270 -- is an unchecked union.
5272 elsif Is_Private_Type (Unc_Type)
5273 and then Has_Unknown_Discriminants (Unc_Type)
5274 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5275 or else Is_Constrained (Underlying_Type (Unc_Type))
5276 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5280 -- Case of derived type with unknown discriminants where the parent type
5281 -- also has unknown discriminants.
5283 elsif Is_Record_Type (Unc_Type)
5284 and then not Is_Class_Wide_Type (Unc_Type)
5285 and then Has_Unknown_Discriminants (Unc_Type)
5286 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5288 -- Nothing to be done if no underlying record view available
5290 -- If this is a limited type derived from a type with unknown
5291 -- discriminants, do not expand either, so that subsequent expansion
5292 -- of the call can add build-in-place parameters to call.
5294 if No (Underlying_Record_View (Unc_Type))
5295 or else Is_Limited_Type (Unc_Type)
5299 -- Otherwise use the Underlying_Record_View to create the proper
5300 -- constrained subtype for an object of a derived type with unknown
5304 Remove_Side_Effects (Exp);
5305 Rewrite (Subtype_Indic,
5306 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5309 -- Renamings of class-wide interface types require no equivalent
5310 -- constrained type declarations because we only need to reference
5311 -- the tag component associated with the interface. The same is
5312 -- presumably true for class-wide types in general, so this test
5313 -- is broadened to include all class-wide renamings, which also
5314 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5315 -- (Is this really correct, or are there some cases of class-wide
5316 -- renamings that require action in this procedure???)
5319 and then Nkind (N) = N_Object_Renaming_Declaration
5320 and then Is_Class_Wide_Type (Unc_Type)
5324 -- In Ada 95 nothing to be done if the type of the expression is limited
5325 -- because in this case the expression cannot be copied, and its use can
5326 -- only be by reference.
5328 -- In Ada 2005 the context can be an object declaration whose expression
5329 -- is a function that returns in place. If the nominal subtype has
5330 -- unknown discriminants, the call still provides constraints on the
5331 -- object, and we have to create an actual subtype from it.
5333 -- If the type is class-wide, the expression is dynamically tagged and
5334 -- we do not create an actual subtype either. Ditto for an interface.
5335 -- For now this applies only if the type is immutably limited, and the
5336 -- function being called is build-in-place. This will have to be revised
5337 -- when build-in-place functions are generalized to other types.
5339 elsif Is_Limited_View (Exp_Typ)
5341 (Is_Class_Wide_Type (Exp_Typ)
5342 or else Is_Interface (Exp_Typ)
5343 or else not Has_Unknown_Discriminants (Exp_Typ)
5344 or else not Is_Composite_Type (Unc_Type))
5348 -- For limited objects initialized with build-in-place function calls,
5349 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5350 -- node in the expression initializing the object, which breaks the
5351 -- circuitry that detects and adds the additional arguments to the
5354 elsif Is_Build_In_Place_Function_Call (Exp) then
5357 -- If the expression is an uninitialized aggregate, no need to build
5358 -- a subtype from the expression, because this may require the use of
5359 -- dynamic memory to create the object.
5361 elsif Is_Uninitialized_Aggregate (Exp, Exp_Typ) then
5362 Rewrite (Subtype_Indic, New_Occurrence_Of (Etype (Exp), Sloc (N)));
5363 if Nkind (N) = N_Object_Declaration then
5364 Set_Expression (N, Empty);
5365 Set_No_Initialization (N);
5369 Remove_Side_Effects (Exp);
5370 Rewrite (Subtype_Indic,
5371 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5373 end Expand_Subtype_From_Expr;
5375 ---------------------------------------------
5376 -- Expression_Contains_Primitives_Calls_Of --
5377 ---------------------------------------------
5379 function Expression_Contains_Primitives_Calls_Of
5381 Typ : Entity_Id) return Boolean
5383 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5385 Calls_OK : Boolean := False;
5386 -- This flag is set to True when expression Expr contains at least one
5387 -- call to a nondispatching primitive function of Typ.
5389 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5390 -- Search for nondispatching calls to primitive functions of type Typ
5392 ----------------------------
5393 -- Search_Primitive_Calls --
5394 ----------------------------
5396 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5397 Disp_Typ : Entity_Id;
5401 -- Detect a function call that could denote a nondispatching
5402 -- primitive of the input type.
5404 if Nkind (N) = N_Function_Call
5405 and then Is_Entity_Name (Name (N))
5407 Subp := Entity (Name (N));
5409 -- Do not consider function calls with a controlling argument, as
5410 -- those are always dispatching calls.
5412 if Is_Dispatching_Operation (Subp)
5413 and then No (Controlling_Argument (N))
5415 Disp_Typ := Find_Dispatching_Type (Subp);
5417 -- To qualify as a suitable primitive, the dispatching type of
5418 -- the function must be the input type.
5420 if Present (Disp_Typ)
5421 and then Unique_Entity (Disp_Typ) = U_Typ
5425 -- There is no need to continue the traversal, as one such
5434 end Search_Primitive_Calls;
5436 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5438 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5441 Search_Calls (Expr);
5443 end Expression_Contains_Primitives_Calls_Of;
5445 ----------------------
5446 -- Finalize_Address --
5447 ----------------------
5449 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5450 Btyp : constant Entity_Id := Base_Type (Typ);
5451 Utyp : Entity_Id := Typ;
5454 -- Handle protected class-wide or task class-wide types
5456 if Is_Class_Wide_Type (Utyp) then
5457 if Is_Concurrent_Type (Root_Type (Utyp)) then
5458 Utyp := Root_Type (Utyp);
5460 elsif Is_Private_Type (Root_Type (Utyp))
5461 and then Present (Full_View (Root_Type (Utyp)))
5462 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5464 Utyp := Full_View (Root_Type (Utyp));
5468 -- Handle private types
5470 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5471 Utyp := Full_View (Utyp);
5474 -- Handle protected and task types
5476 if Is_Concurrent_Type (Utyp)
5477 and then Present (Corresponding_Record_Type (Utyp))
5479 Utyp := Corresponding_Record_Type (Utyp);
5482 Utyp := Underlying_Type (Base_Type (Utyp));
5484 -- Deal with untagged derivation of private views. If the parent is
5485 -- now known to be protected, the finalization routine is the one
5486 -- defined on the corresponding record of the ancestor (corresponding
5487 -- records do not automatically inherit operations, but maybe they
5490 if Is_Untagged_Derivation (Btyp) then
5491 if Is_Protected_Type (Btyp) then
5492 Utyp := Corresponding_Record_Type (Root_Type (Btyp));
5495 Utyp := Underlying_Type (Root_Type (Btyp));
5497 if Is_Protected_Type (Utyp) then
5498 Utyp := Corresponding_Record_Type (Utyp);
5503 -- If the underlying_type is a subtype, we are dealing with the
5504 -- completion of a private type. We need to access the base type and
5505 -- generate a conversion to it.
5507 if Utyp /= Base_Type (Utyp) then
5508 pragma Assert (Is_Private_Type (Typ));
5510 Utyp := Base_Type (Utyp);
5513 -- When dealing with an internally built full view for a type with
5514 -- unknown discriminants, use the original record type.
5516 if Is_Underlying_Record_View (Utyp) then
5517 Utyp := Etype (Utyp);
5520 return TSS (Utyp, TSS_Finalize_Address);
5521 end Finalize_Address;
5523 ------------------------
5524 -- Find_Interface_ADT --
5525 ------------------------
5527 function Find_Interface_ADT
5529 Iface : Entity_Id) return Elmt_Id
5532 Typ : Entity_Id := T;
5535 pragma Assert (Is_Interface (Iface));
5537 -- Handle private types
5539 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5540 Typ := Full_View (Typ);
5543 -- Handle access types
5545 if Is_Access_Type (Typ) then
5546 Typ := Designated_Type (Typ);
5549 -- Handle task and protected types implementing interfaces
5551 if Is_Concurrent_Type (Typ) then
5552 Typ := Corresponding_Record_Type (Typ);
5556 (not Is_Class_Wide_Type (Typ)
5557 and then Ekind (Typ) /= E_Incomplete_Type);
5559 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5560 return First_Elmt (Access_Disp_Table (Typ));
5563 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5565 and then Present (Related_Type (Node (ADT)))
5566 and then Related_Type (Node (ADT)) /= Iface
5567 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
5568 Use_Full_View => True)
5573 pragma Assert (Present (Related_Type (Node (ADT))));
5576 end Find_Interface_ADT;
5578 ------------------------
5579 -- Find_Interface_Tag --
5580 ------------------------
5582 function Find_Interface_Tag
5584 Iface : Entity_Id) return Entity_Id
5586 AI_Tag : Entity_Id := Empty;
5587 Found : Boolean := False;
5588 Typ : Entity_Id := T;
5590 procedure Find_Tag (Typ : Entity_Id);
5591 -- Internal subprogram used to recursively climb to the ancestors
5597 procedure Find_Tag (Typ : Entity_Id) is
5602 -- This routine does not handle the case in which the interface is an
5603 -- ancestor of Typ. That case is handled by the enclosing subprogram.
5605 pragma Assert (Typ /= Iface);
5607 -- Climb to the root type handling private types
5609 if Present (Full_View (Etype (Typ))) then
5610 if Full_View (Etype (Typ)) /= Typ then
5611 Find_Tag (Full_View (Etype (Typ)));
5614 elsif Etype (Typ) /= Typ then
5615 Find_Tag (Etype (Typ));
5618 -- Traverse the list of interfaces implemented by the type
5621 and then Present (Interfaces (Typ))
5622 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
5624 -- Skip the tag associated with the primary table
5626 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
5627 pragma Assert (Present (AI_Tag));
5629 AI_Elmt := First_Elmt (Interfaces (Typ));
5630 while Present (AI_Elmt) loop
5631 AI := Node (AI_Elmt);
5634 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
5640 AI_Tag := Next_Tag_Component (AI_Tag);
5641 Next_Elmt (AI_Elmt);
5646 -- Start of processing for Find_Interface_Tag
5649 pragma Assert (Is_Interface (Iface));
5651 -- Handle access types
5653 if Is_Access_Type (Typ) then
5654 Typ := Designated_Type (Typ);
5657 -- Handle class-wide types
5659 if Is_Class_Wide_Type (Typ) then
5660 Typ := Root_Type (Typ);
5663 -- Handle private types
5665 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5666 Typ := Full_View (Typ);
5669 -- Handle entities from the limited view
5671 if Ekind (Typ) = E_Incomplete_Type then
5672 pragma Assert (Present (Non_Limited_View (Typ)));
5673 Typ := Non_Limited_View (Typ);
5676 -- Handle task and protected types implementing interfaces
5678 if Is_Concurrent_Type (Typ) then
5679 Typ := Corresponding_Record_Type (Typ);
5682 -- If the interface is an ancestor of the type, then it shared the
5683 -- primary dispatch table.
5685 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5686 return First_Tag_Component (Typ);
5688 -- Otherwise we need to search for its associated tag component
5694 end Find_Interface_Tag;
5696 ---------------------------
5697 -- Find_Optional_Prim_Op --
5698 ---------------------------
5700 function Find_Optional_Prim_Op
5701 (T : Entity_Id; Name : Name_Id) return Entity_Id
5704 Typ : Entity_Id := T;
5708 if Is_Class_Wide_Type (Typ) then
5709 Typ := Root_Type (Typ);
5712 Typ := Underlying_Type (Typ);
5714 -- Loop through primitive operations
5716 Prim := First_Elmt (Primitive_Operations (Typ));
5717 while Present (Prim) loop
5720 -- We can retrieve primitive operations by name if it is an internal
5721 -- name. For equality we must check that both of its operands have
5722 -- the same type, to avoid confusion with user-defined equalities
5723 -- than may have a asymmetric signature.
5725 exit when Chars (Op) = Name
5728 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
5733 return Node (Prim); -- Empty if not found
5734 end Find_Optional_Prim_Op;
5736 ---------------------------
5737 -- Find_Optional_Prim_Op --
5738 ---------------------------
5740 function Find_Optional_Prim_Op
5742 Name : TSS_Name_Type) return Entity_Id
5744 Inher_Op : Entity_Id := Empty;
5745 Own_Op : Entity_Id := Empty;
5746 Prim_Elmt : Elmt_Id;
5747 Prim_Id : Entity_Id;
5748 Typ : Entity_Id := T;
5751 if Is_Class_Wide_Type (Typ) then
5752 Typ := Root_Type (Typ);
5755 Typ := Underlying_Type (Typ);
5757 -- This search is based on the assertion that the dispatching version
5758 -- of the TSS routine always precedes the real primitive.
5760 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5761 while Present (Prim_Elmt) loop
5762 Prim_Id := Node (Prim_Elmt);
5764 if Is_TSS (Prim_Id, Name) then
5765 if Present (Alias (Prim_Id)) then
5766 Inher_Op := Prim_Id;
5772 Next_Elmt (Prim_Elmt);
5775 if Present (Own_Op) then
5777 elsif Present (Inher_Op) then
5782 end Find_Optional_Prim_Op;
5788 function Find_Prim_Op
5789 (T : Entity_Id; Name : Name_Id) return Entity_Id
5791 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5794 raise Program_Error;
5804 function Find_Prim_Op
5806 Name : TSS_Name_Type) return Entity_Id
5808 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5811 raise Program_Error;
5817 ----------------------------
5818 -- Find_Protection_Object --
5819 ----------------------------
5821 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
5826 while Present (S) loop
5827 if Ekind (S) in E_Entry | E_Entry_Family | E_Function | E_Procedure
5828 and then Present (Protection_Object (S))
5830 return Protection_Object (S);
5836 -- If we do not find a Protection object in the scope chain, then
5837 -- something has gone wrong, most likely the object was never created.
5839 raise Program_Error;
5840 end Find_Protection_Object;
5842 --------------------------
5843 -- Find_Protection_Type --
5844 --------------------------
5846 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
5848 Typ : Entity_Id := Conc_Typ;
5851 if Is_Concurrent_Type (Typ) then
5852 Typ := Corresponding_Record_Type (Typ);
5855 -- Since restriction violations are not considered serious errors, the
5856 -- expander remains active, but may leave the corresponding record type
5857 -- malformed. In such cases, component _object is not available so do
5860 if not Analyzed (Typ) then
5864 Comp := First_Component (Typ);
5865 while Present (Comp) loop
5866 if Chars (Comp) = Name_uObject then
5867 return Base_Type (Etype (Comp));
5870 Next_Component (Comp);
5873 -- The corresponding record of a protected type should always have an
5876 raise Program_Error;
5877 end Find_Protection_Type;
5879 -----------------------
5880 -- Find_Hook_Context --
5881 -----------------------
5883 function Find_Hook_Context (N : Node_Id) return Node_Id is
5887 Wrapped_Node : Node_Id;
5888 -- Note: if we are in a transient scope, we want to reuse it as
5889 -- the context for actions insertion, if possible. But if N is itself
5890 -- part of the stored actions for the current transient scope,
5891 -- then we need to insert at the appropriate (inner) location in
5892 -- the not as an action on Node_To_Be_Wrapped.
5894 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
5897 -- When the node is inside a case/if expression, the lifetime of any
5898 -- temporary controlled object is extended. Find a suitable insertion
5899 -- node by locating the topmost case or if expressions.
5901 if In_Cond_Expr then
5904 while Present (Par) loop
5905 if Nkind (Original_Node (Par)) in
5906 N_Case_Expression | N_If_Expression
5910 -- Prevent the search from going too far
5912 elsif Is_Body_Or_Package_Declaration (Par) then
5916 Par := Parent (Par);
5919 -- The topmost case or if expression is now recovered, but it may
5920 -- still not be the correct place to add generated code. Climb to
5921 -- find a parent that is part of a declarative or statement list,
5922 -- and is not a list of actuals in a call.
5925 while Present (Par) loop
5926 if Is_List_Member (Par)
5927 and then Nkind (Par) not in N_Component_Association
5928 | N_Discriminant_Association
5929 | N_Parameter_Association
5930 | N_Pragma_Argument_Association
5931 and then Nkind (Parent (Par)) not in N_Function_Call
5932 | N_Procedure_Call_Statement
5933 | N_Entry_Call_Statement
5938 -- Prevent the search from going too far
5940 elsif Is_Body_Or_Package_Declaration (Par) then
5944 Par := Parent (Par);
5951 while Present (Par) loop
5953 -- Keep climbing past various operators
5955 if Nkind (Parent (Par)) in N_Op
5956 or else Nkind (Parent (Par)) in N_And_Then | N_Or_Else
5958 Par := Parent (Par);
5966 -- The node may be located in a pragma in which case return the
5969 -- pragma Precondition (... and then Ctrl_Func_Call ...);
5971 -- Similar case occurs when the node is related to an object
5972 -- declaration or assignment:
5974 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
5976 -- Another case to consider is when the node is part of a return
5979 -- return ... and then Ctrl_Func_Call ...;
5981 -- Another case is when the node acts as a formal in a procedure
5984 -- Proc (... and then Ctrl_Func_Call ...);
5986 if Scope_Is_Transient then
5987 Wrapped_Node := Node_To_Be_Wrapped;
5989 Wrapped_Node := Empty;
5992 while Present (Par) loop
5993 if Par = Wrapped_Node
5994 or else Nkind (Par) in N_Assignment_Statement
5995 | N_Object_Declaration
5997 | N_Procedure_Call_Statement
5998 | N_Simple_Return_Statement
6002 -- Prevent the search from going too far
6004 elsif Is_Body_Or_Package_Declaration (Par) then
6008 Par := Parent (Par);
6011 -- Return the topmost short circuit operator
6015 end Find_Hook_Context;
6017 ------------------------------
6018 -- Following_Address_Clause --
6019 ------------------------------
6021 function Following_Address_Clause (D : Node_Id) return Node_Id is
6022 Id : constant Entity_Id := Defining_Identifier (D);
6026 function Check_Decls (D : Node_Id) return Node_Id;
6027 -- This internal function differs from the main function in that it
6028 -- gets called to deal with a following package private part, and
6029 -- it checks declarations starting with D (the main function checks
6030 -- declarations following D). If D is Empty, then Empty is returned.
6036 function Check_Decls (D : Node_Id) return Node_Id is
6041 while Present (Decl) loop
6042 if Nkind (Decl) = N_At_Clause
6043 and then Chars (Identifier (Decl)) = Chars (Id)
6047 elsif Nkind (Decl) = N_Attribute_Definition_Clause
6048 and then Chars (Decl) = Name_Address
6049 and then Chars (Name (Decl)) = Chars (Id)
6057 -- Otherwise not found, return Empty
6062 -- Start of processing for Following_Address_Clause
6065 -- If parser detected no address clause for the identifier in question,
6066 -- then the answer is a quick NO, without the need for a search.
6068 if not Get_Name_Table_Boolean1 (Chars (Id)) then
6072 -- Otherwise search current declarative unit
6074 Result := Check_Decls (Next (D));
6076 if Present (Result) then
6080 -- Check for possible package private part following
6084 if Nkind (Par) = N_Package_Specification
6085 and then Visible_Declarations (Par) = List_Containing (D)
6086 and then Present (Private_Declarations (Par))
6088 -- Private part present, check declarations there
6090 return Check_Decls (First (Private_Declarations (Par)));
6093 -- No private part, clause not found, return Empty
6097 end Following_Address_Clause;
6099 ----------------------
6100 -- Force_Evaluation --
6101 ----------------------
6103 procedure Force_Evaluation
6105 Name_Req : Boolean := False;
6106 Related_Id : Entity_Id := Empty;
6107 Is_Low_Bound : Boolean := False;
6108 Is_High_Bound : Boolean := False;
6109 Mode : Force_Evaluation_Mode := Relaxed)
6114 Name_Req => Name_Req,
6115 Variable_Ref => True,
6116 Renaming_Req => False,
6117 Related_Id => Related_Id,
6118 Is_Low_Bound => Is_Low_Bound,
6119 Is_High_Bound => Is_High_Bound,
6120 Check_Side_Effects =>
6121 Is_Static_Expression (Exp)
6122 or else Mode = Relaxed);
6123 end Force_Evaluation;
6125 ---------------------------------
6126 -- Fully_Qualified_Name_String --
6127 ---------------------------------
6129 function Fully_Qualified_Name_String
6131 Append_NUL : Boolean := True) return String_Id
6133 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6134 -- Compute recursively the qualified name without NUL at the end, adding
6135 -- it to the currently started string being generated
6137 ----------------------------------
6138 -- Internal_Full_Qualified_Name --
6139 ----------------------------------
6141 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6145 -- Deal properly with child units
6147 if Nkind (E) = N_Defining_Program_Unit_Name then
6148 Ent := Defining_Identifier (E);
6153 -- Compute qualification recursively (only "Standard" has no scope)
6155 if Present (Scope (Scope (Ent))) then
6156 Internal_Full_Qualified_Name (Scope (Ent));
6157 Store_String_Char (Get_Char_Code ('.'));
6160 -- Every entity should have a name except some expanded blocks
6161 -- don't bother about those.
6163 if Chars (Ent) = No_Name then
6167 -- Generates the entity name in upper case
6169 Get_Decoded_Name_String (Chars (Ent));
6171 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6173 end Internal_Full_Qualified_Name;
6175 -- Start of processing for Full_Qualified_Name
6179 Internal_Full_Qualified_Name (E);
6182 Store_String_Char (Get_Char_Code (ASCII.NUL));
6186 end Fully_Qualified_Name_String;
6188 ---------------------------------
6189 -- Get_Current_Value_Condition --
6190 ---------------------------------
6192 -- Note: the implementation of this procedure is very closely tied to the
6193 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6194 -- interpret Current_Value fields set by the Set procedure, so the two
6195 -- procedures need to be closely coordinated.
6197 procedure Get_Current_Value_Condition
6202 Loc : constant Source_Ptr := Sloc (Var);
6203 Ent : constant Entity_Id := Entity (Var);
6205 procedure Process_Current_Value_Condition
6208 -- N is an expression which holds either True (S = True) or False (S =
6209 -- False) in the condition. This procedure digs out the expression and
6210 -- if it refers to Ent, sets Op and Val appropriately.
6212 -------------------------------------
6213 -- Process_Current_Value_Condition --
6214 -------------------------------------
6216 procedure Process_Current_Value_Condition
6221 Prev_Cond : Node_Id;
6231 -- Deal with NOT operators, inverting sense
6233 while Nkind (Cond) = N_Op_Not loop
6234 Cond := Right_Opnd (Cond);
6238 -- Deal with conversions, qualifications, and expressions with
6241 while Nkind (Cond) in N_Type_Conversion
6242 | N_Qualified_Expression
6243 | N_Expression_With_Actions
6245 Cond := Expression (Cond);
6248 exit when Cond = Prev_Cond;
6251 -- Deal with AND THEN and AND cases
6253 if Nkind (Cond) in N_And_Then | N_Op_And then
6255 -- Don't ever try to invert a condition that is of the form of an
6256 -- AND or AND THEN (since we are not doing sufficiently general
6257 -- processing to allow this).
6259 if Sens = False then
6265 -- Recursively process AND and AND THEN branches
6267 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6269 if Op /= N_Empty then
6273 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6276 -- Case of relational operator
6278 elsif Nkind (Cond) in N_Op_Compare then
6281 -- Invert sense of test if inverted test
6283 if Sens = False then
6285 when N_Op_Eq => Op := N_Op_Ne;
6286 when N_Op_Ne => Op := N_Op_Eq;
6287 when N_Op_Lt => Op := N_Op_Ge;
6288 when N_Op_Gt => Op := N_Op_Le;
6289 when N_Op_Le => Op := N_Op_Gt;
6290 when N_Op_Ge => Op := N_Op_Lt;
6291 when others => raise Program_Error;
6295 -- Case of entity op value
6297 if Is_Entity_Name (Left_Opnd (Cond))
6298 and then Ent = Entity (Left_Opnd (Cond))
6299 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6301 Val := Right_Opnd (Cond);
6303 -- Case of value op entity
6305 elsif Is_Entity_Name (Right_Opnd (Cond))
6306 and then Ent = Entity (Right_Opnd (Cond))
6307 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6309 Val := Left_Opnd (Cond);
6311 -- We are effectively swapping operands
6314 when N_Op_Eq => null;
6315 when N_Op_Ne => null;
6316 when N_Op_Lt => Op := N_Op_Gt;
6317 when N_Op_Gt => Op := N_Op_Lt;
6318 when N_Op_Le => Op := N_Op_Ge;
6319 when N_Op_Ge => Op := N_Op_Le;
6320 when others => raise Program_Error;
6329 elsif Nkind (Cond) in N_Type_Conversion
6330 | N_Qualified_Expression
6331 | N_Expression_With_Actions
6333 Cond := Expression (Cond);
6335 -- Case of Boolean variable reference, return as though the
6336 -- reference had said var = True.
6339 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6340 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6342 if Sens = False then
6349 end Process_Current_Value_Condition;
6351 -- Start of processing for Get_Current_Value_Condition
6357 -- Immediate return, nothing doing, if this is not an object
6359 if not Is_Object (Ent) then
6363 -- In GNATprove mode we don't want to use current value optimizer, in
6364 -- particular for loop invariant expressions and other assertions that
6365 -- act as cut points for proof. The optimizer often folds expressions
6366 -- into True/False where they trivially follow from the previous
6367 -- assignments, but this deprives proof from the information needed to
6368 -- discharge checks that are beyond the scope of the value optimizer.
6370 if GNATprove_Mode then
6374 -- Otherwise examine current value
6377 CV : constant Node_Id := Current_Value (Ent);
6382 -- If statement. Condition is known true in THEN section, known False
6383 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6385 if Nkind (CV) = N_If_Statement then
6387 -- Before start of IF statement
6389 if Loc < Sloc (CV) then
6392 -- After end of IF statement
6394 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6398 -- At this stage we know that we are within the IF statement, but
6399 -- unfortunately, the tree does not record the SLOC of the ELSE so
6400 -- we cannot use a simple SLOC comparison to distinguish between
6401 -- the then/else statements, so we have to climb the tree.
6408 while Parent (N) /= CV loop
6411 -- If we fall off the top of the tree, then that's odd, but
6412 -- perhaps it could occur in some error situation, and the
6413 -- safest response is simply to assume that the outcome of
6414 -- the condition is unknown. No point in bombing during an
6415 -- attempt to optimize things.
6422 -- Now we have N pointing to a node whose parent is the IF
6423 -- statement in question, so now we can tell if we are within
6424 -- the THEN statements.
6426 if Is_List_Member (N)
6427 and then List_Containing (N) = Then_Statements (CV)
6431 -- If the variable reference does not come from source, we
6432 -- cannot reliably tell whether it appears in the else part.
6433 -- In particular, if it appears in generated code for a node
6434 -- that requires finalization, it may be attached to a list
6435 -- that has not been yet inserted into the code. For now,
6436 -- treat it as unknown.
6438 elsif not Comes_From_Source (N) then
6441 -- Otherwise we must be in ELSIF or ELSE part
6448 -- ELSIF part. Condition is known true within the referenced
6449 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6450 -- and unknown before the ELSE part or after the IF statement.
6452 elsif Nkind (CV) = N_Elsif_Part then
6454 -- if the Elsif_Part had condition_actions, the elsif has been
6455 -- rewritten as a nested if, and the original elsif_part is
6456 -- detached from the tree, so there is no way to obtain useful
6457 -- information on the current value of the variable.
6458 -- Can this be improved ???
6460 if No (Parent (CV)) then
6466 -- If the tree has been otherwise rewritten there is nothing
6467 -- else to be done either.
6469 if Nkind (Stm) /= N_If_Statement then
6473 -- Before start of ELSIF part
6475 if Loc < Sloc (CV) then
6478 -- After end of IF statement
6480 elsif Loc >= Sloc (Stm) +
6481 Text_Ptr (UI_To_Int (End_Span (Stm)))
6486 -- Again we lack the SLOC of the ELSE, so we need to climb the
6487 -- tree to see if we are within the ELSIF part in question.
6494 while Parent (N) /= Stm loop
6497 -- If we fall off the top of the tree, then that's odd, but
6498 -- perhaps it could occur in some error situation, and the
6499 -- safest response is simply to assume that the outcome of
6500 -- the condition is unknown. No point in bombing during an
6501 -- attempt to optimize things.
6508 -- Now we have N pointing to a node whose parent is the IF
6509 -- statement in question, so see if is the ELSIF part we want.
6510 -- the THEN statements.
6515 -- Otherwise we must be in subsequent ELSIF or ELSE part
6522 -- Iteration scheme of while loop. The condition is known to be
6523 -- true within the body of the loop.
6525 elsif Nkind (CV) = N_Iteration_Scheme then
6527 Loop_Stmt : constant Node_Id := Parent (CV);
6530 -- Before start of body of loop
6532 if Loc < Sloc (Loop_Stmt) then
6535 -- After end of LOOP statement
6537 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
6540 -- We are within the body of the loop
6547 -- All other cases of Current_Value settings
6553 -- If we fall through here, then we have a reportable condition, Sens
6554 -- is True if the condition is true and False if it needs inverting.
6556 Process_Current_Value_Condition (Condition (CV), Sens);
6558 end Get_Current_Value_Condition;
6560 -----------------------
6561 -- Get_Index_Subtype --
6562 -----------------------
6564 function Get_Index_Subtype (N : Node_Id) return Node_Id is
6565 P_Type : Entity_Id := Etype (Prefix (N));
6570 if Is_Access_Type (P_Type) then
6571 P_Type := Designated_Type (P_Type);
6574 if No (Expressions (N)) then
6577 J := UI_To_Int (Expr_Value (First (Expressions (N))));
6580 Indx := First_Index (P_Type);
6586 return Etype (Indx);
6587 end Get_Index_Subtype;
6589 ---------------------
6590 -- Get_Stream_Size --
6591 ---------------------
6593 function Get_Stream_Size (E : Entity_Id) return Uint is
6595 -- If we have a Stream_Size clause for this type use it
6597 if Has_Stream_Size_Clause (E) then
6598 return Static_Integer (Expression (Stream_Size_Clause (E)));
6600 -- Otherwise the Stream_Size is the size of the type
6605 end Get_Stream_Size;
6607 ---------------------------
6608 -- Has_Access_Constraint --
6609 ---------------------------
6611 function Has_Access_Constraint (E : Entity_Id) return Boolean is
6613 T : constant Entity_Id := Etype (E);
6616 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
6617 Disc := First_Discriminant (T);
6618 while Present (Disc) loop
6619 if Is_Access_Type (Etype (Disc)) then
6623 Next_Discriminant (Disc);
6630 end Has_Access_Constraint;
6632 --------------------
6633 -- Homonym_Number --
6634 --------------------
6636 function Homonym_Number (Subp : Entity_Id) return Pos is
6637 Hom : Entity_Id := Homonym (Subp);
6641 while Present (Hom) loop
6642 if Scope (Hom) = Scope (Subp) then
6646 Hom := Homonym (Hom);
6652 -----------------------------------
6653 -- In_Library_Level_Package_Body --
6654 -----------------------------------
6656 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
6658 -- First determine whether the entity appears at the library level, then
6659 -- look at the containing unit.
6661 if Is_Library_Level_Entity (Id) then
6663 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
6666 return Nkind (Unit (Container)) = N_Package_Body;
6671 end In_Library_Level_Package_Body;
6673 ------------------------------
6674 -- In_Unconditional_Context --
6675 ------------------------------
6677 function In_Unconditional_Context (Node : Node_Id) return Boolean is
6682 while Present (P) loop
6684 when N_Subprogram_Body => return True;
6685 when N_If_Statement => return False;
6686 when N_Loop_Statement => return False;
6687 when N_Case_Statement => return False;
6688 when others => P := Parent (P);
6693 end In_Unconditional_Context;
6699 procedure Insert_Action
6700 (Assoc_Node : Node_Id;
6701 Ins_Action : Node_Id;
6702 Spec_Expr_OK : Boolean := False)
6705 if Present (Ins_Action) then
6707 (Assoc_Node => Assoc_Node,
6708 Ins_Actions => New_List (Ins_Action),
6709 Spec_Expr_OK => Spec_Expr_OK);
6713 -- Version with check(s) suppressed
6715 procedure Insert_Action
6716 (Assoc_Node : Node_Id;
6717 Ins_Action : Node_Id;
6718 Suppress : Check_Id;
6719 Spec_Expr_OK : Boolean := False)
6723 (Assoc_Node => Assoc_Node,
6724 Ins_Actions => New_List (Ins_Action),
6725 Suppress => Suppress,
6726 Spec_Expr_OK => Spec_Expr_OK);
6729 -------------------------
6730 -- Insert_Action_After --
6731 -------------------------
6733 procedure Insert_Action_After
6734 (Assoc_Node : Node_Id;
6735 Ins_Action : Node_Id)
6738 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
6739 end Insert_Action_After;
6741 --------------------
6742 -- Insert_Actions --
6743 --------------------
6745 procedure Insert_Actions
6746 (Assoc_Node : Node_Id;
6747 Ins_Actions : List_Id;
6748 Spec_Expr_OK : Boolean := False)
6753 Wrapped_Node : Node_Id := Empty;
6756 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
6760 -- Insert the action when the context is "Handling of Default and Per-
6761 -- Object Expressions" only when requested by the caller.
6763 if Spec_Expr_OK then
6766 -- Ignore insert of actions from inside default expression (or other
6767 -- similar "spec expression") in the special spec-expression analyze
6768 -- mode. Any insertions at this point have no relevance, since we are
6769 -- only doing the analyze to freeze the types of any static expressions.
6770 -- See section "Handling of Default and Per-Object Expressions" in the
6771 -- spec of package Sem for further details.
6773 elsif In_Spec_Expression then
6777 -- If the action derives from stuff inside a record, then the actions
6778 -- are attached to the current scope, to be inserted and analyzed on
6779 -- exit from the scope. The reason for this is that we may also be
6780 -- generating freeze actions at the same time, and they must eventually
6781 -- be elaborated in the correct order.
6783 if Is_Record_Type (Current_Scope)
6784 and then not Is_Frozen (Current_Scope)
6786 if No (Scope_Stack.Table
6787 (Scope_Stack.Last).Pending_Freeze_Actions)
6789 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
6794 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
6800 -- We now intend to climb up the tree to find the right point to
6801 -- insert the actions. We start at Assoc_Node, unless this node is a
6802 -- subexpression in which case we start with its parent. We do this for
6803 -- two reasons. First it speeds things up. Second, if Assoc_Node is
6804 -- itself one of the special nodes like N_And_Then, then we assume that
6805 -- an initial request to insert actions for such a node does not expect
6806 -- the actions to get deposited in the node for later handling when the
6807 -- node is expanded, since clearly the node is being dealt with by the
6808 -- caller. Note that in the subexpression case, N is always the child we
6811 -- N_Raise_xxx_Error is an annoying special case, it is a statement
6812 -- if it has type Standard_Void_Type, and a subexpression otherwise.
6813 -- Procedure calls, and similarly procedure attribute references, are
6816 if Nkind (Assoc_Node) in N_Subexpr
6817 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
6818 or else Etype (Assoc_Node) /= Standard_Void_Type)
6819 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
6820 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
6821 or else not Is_Procedure_Attribute_Name
6822 (Attribute_Name (Assoc_Node)))
6825 P := Parent (Assoc_Node);
6827 -- Nonsubexpression case. Note that N is initially Empty in this case
6828 -- (N is only guaranteed non-Empty in the subexpr case).
6835 -- Capture root of the transient scope
6837 if Scope_Is_Transient then
6838 Wrapped_Node := Node_To_Be_Wrapped;
6842 pragma Assert (Present (P));
6844 -- Make sure that inserted actions stay in the transient scope
6846 if Present (Wrapped_Node) and then N = Wrapped_Node then
6847 Store_Before_Actions_In_Scope (Ins_Actions);
6853 -- Case of right operand of AND THEN or OR ELSE. Put the actions
6854 -- in the Actions field of the right operand. They will be moved
6855 -- out further when the AND THEN or OR ELSE operator is expanded.
6856 -- Nothing special needs to be done for the left operand since
6857 -- in that case the actions are executed unconditionally.
6859 when N_Short_Circuit =>
6860 if N = Right_Opnd (P) then
6862 -- We are now going to either append the actions to the
6863 -- actions field of the short-circuit operation. We will
6864 -- also analyze the actions now.
6866 -- This analysis is really too early, the proper thing would
6867 -- be to just park them there now, and only analyze them if
6868 -- we find we really need them, and to it at the proper
6869 -- final insertion point. However attempting to this proved
6870 -- tricky, so for now we just kill current values before and
6871 -- after the analyze call to make sure we avoid peculiar
6872 -- optimizations from this out of order insertion.
6874 Kill_Current_Values;
6876 -- If P has already been expanded, we can't park new actions
6877 -- on it, so we need to expand them immediately, introducing
6878 -- an Expression_With_Actions. N can't be an expression
6879 -- with actions, or else then the actions would have been
6880 -- inserted at an inner level.
6882 if Analyzed (P) then
6883 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
6885 Make_Expression_With_Actions (Sloc (N),
6886 Actions => Ins_Actions,
6887 Expression => Relocate_Node (N)));
6888 Analyze_And_Resolve (N);
6890 elsif Present (Actions (P)) then
6891 Insert_List_After_And_Analyze
6892 (Last (Actions (P)), Ins_Actions);
6894 Set_Actions (P, Ins_Actions);
6895 Analyze_List (Actions (P));
6898 Kill_Current_Values;
6903 -- Then or Else dependent expression of an if expression. Add
6904 -- actions to Then_Actions or Else_Actions field as appropriate.
6905 -- The actions will be moved further out when the if is expanded.
6907 when N_If_Expression =>
6909 ThenX : constant Node_Id := Next (First (Expressions (P)));
6910 ElseX : constant Node_Id := Next (ThenX);
6913 -- If the enclosing expression is already analyzed, as
6914 -- is the case for nested elaboration checks, insert the
6915 -- conditional further out.
6917 if Analyzed (P) then
6920 -- Actions belong to the then expression, temporarily place
6921 -- them as Then_Actions of the if expression. They will be
6922 -- moved to the proper place later when the if expression
6925 elsif N = ThenX then
6926 if Present (Then_Actions (P)) then
6927 Insert_List_After_And_Analyze
6928 (Last (Then_Actions (P)), Ins_Actions);
6930 Set_Then_Actions (P, Ins_Actions);
6931 Analyze_List (Then_Actions (P));
6936 -- Actions belong to the else expression, temporarily place
6937 -- them as Else_Actions of the if expression. They will be
6938 -- moved to the proper place later when the if expression
6941 elsif N = ElseX then
6942 if Present (Else_Actions (P)) then
6943 Insert_List_After_And_Analyze
6944 (Last (Else_Actions (P)), Ins_Actions);
6946 Set_Else_Actions (P, Ins_Actions);
6947 Analyze_List (Else_Actions (P));
6952 -- Actions belong to the condition. In this case they are
6953 -- unconditionally executed, and so we can continue the
6954 -- search for the proper insert point.
6961 -- Alternative of case expression, we place the action in the
6962 -- Actions field of the case expression alternative, this will
6963 -- be handled when the case expression is expanded.
6965 when N_Case_Expression_Alternative =>
6966 if Present (Actions (P)) then
6967 Insert_List_After_And_Analyze
6968 (Last (Actions (P)), Ins_Actions);
6970 Set_Actions (P, Ins_Actions);
6971 Analyze_List (Actions (P));
6976 -- Case of appearing within an Expressions_With_Actions node. When
6977 -- the new actions come from the expression of the expression with
6978 -- actions, they must be added to the existing actions. The other
6979 -- alternative is when the new actions are related to one of the
6980 -- existing actions of the expression with actions, and should
6981 -- never reach here: if actions are inserted on a statement
6982 -- within the Actions of an expression with actions, or on some
6983 -- subexpression of such a statement, then the outermost proper
6984 -- insertion point is right before the statement, and we should
6985 -- never climb up as far as the N_Expression_With_Actions itself.
6987 when N_Expression_With_Actions =>
6988 if N = Expression (P) then
6989 if Is_Empty_List (Actions (P)) then
6990 Append_List_To (Actions (P), Ins_Actions);
6991 Analyze_List (Actions (P));
6993 Insert_List_After_And_Analyze
6994 (Last (Actions (P)), Ins_Actions);
7000 raise Program_Error;
7003 -- Case of appearing in the condition of a while expression or
7004 -- elsif. We insert the actions into the Condition_Actions field.
7005 -- They will be moved further out when the while loop or elsif
7009 | N_Iteration_Scheme
7011 if N = Condition (P) then
7012 if Present (Condition_Actions (P)) then
7013 Insert_List_After_And_Analyze
7014 (Last (Condition_Actions (P)), Ins_Actions);
7016 Set_Condition_Actions (P, Ins_Actions);
7018 -- Set the parent of the insert actions explicitly. This
7019 -- is not a syntactic field, but we need the parent field
7020 -- set, in particular so that freeze can understand that
7021 -- it is dealing with condition actions, and properly
7022 -- insert the freezing actions.
7024 Set_Parent (Ins_Actions, P);
7025 Analyze_List (Condition_Actions (P));
7031 -- Statements, declarations, pragmas, representation clauses
7036 N_Procedure_Call_Statement
7037 | N_Statement_Other_Than_Procedure_Call
7043 -- Representation_Clause
7046 | N_Attribute_Definition_Clause
7047 | N_Enumeration_Representation_Clause
7048 | N_Record_Representation_Clause
7052 | N_Abstract_Subprogram_Declaration
7054 | N_Exception_Declaration
7055 | N_Exception_Renaming_Declaration
7056 | N_Expression_Function
7057 | N_Formal_Abstract_Subprogram_Declaration
7058 | N_Formal_Concrete_Subprogram_Declaration
7059 | N_Formal_Object_Declaration
7060 | N_Formal_Type_Declaration
7061 | N_Full_Type_Declaration
7062 | N_Function_Instantiation
7063 | N_Generic_Function_Renaming_Declaration
7064 | N_Generic_Package_Declaration
7065 | N_Generic_Package_Renaming_Declaration
7066 | N_Generic_Procedure_Renaming_Declaration
7067 | N_Generic_Subprogram_Declaration
7068 | N_Implicit_Label_Declaration
7069 | N_Incomplete_Type_Declaration
7070 | N_Number_Declaration
7071 | N_Object_Declaration
7072 | N_Object_Renaming_Declaration
7074 | N_Package_Body_Stub
7075 | N_Package_Declaration
7076 | N_Package_Instantiation
7077 | N_Package_Renaming_Declaration
7078 | N_Private_Extension_Declaration
7079 | N_Private_Type_Declaration
7080 | N_Procedure_Instantiation
7082 | N_Protected_Body_Stub
7083 | N_Single_Task_Declaration
7085 | N_Subprogram_Body_Stub
7086 | N_Subprogram_Declaration
7087 | N_Subprogram_Renaming_Declaration
7088 | N_Subtype_Declaration
7092 -- Use clauses can appear in lists of declarations
7094 | N_Use_Package_Clause
7097 -- Freeze entity behaves like a declaration or statement
7100 | N_Freeze_Generic_Entity
7102 -- Do not insert here if the item is not a list member (this
7103 -- happens for example with a triggering statement, and the
7104 -- proper approach is to insert before the entire select).
7106 if not Is_List_Member (P) then
7109 -- Do not insert if parent of P is an N_Component_Association
7110 -- node (i.e. we are in the context of an N_Aggregate or
7111 -- N_Extension_Aggregate node. In this case we want to insert
7112 -- before the entire aggregate.
7114 elsif Nkind (Parent (P)) = N_Component_Association then
7117 -- Do not insert if the parent of P is either an N_Variant node
7118 -- or an N_Record_Definition node, meaning in either case that
7119 -- P is a member of a component list, and that therefore the
7120 -- actions should be inserted outside the complete record
7123 elsif Nkind (Parent (P)) in N_Variant | N_Record_Definition then
7126 -- Do not insert freeze nodes within the loop generated for
7127 -- an aggregate, because they may be elaborated too late for
7128 -- subsequent use in the back end: within a package spec the
7129 -- loop is part of the elaboration procedure and is only
7130 -- elaborated during the second pass.
7132 -- If the loop comes from source, or the entity is local to the
7133 -- loop itself it must remain within.
7135 elsif Nkind (Parent (P)) = N_Loop_Statement
7136 and then not Comes_From_Source (Parent (P))
7137 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7139 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7143 -- Otherwise we can go ahead and do the insertion
7145 elsif P = Wrapped_Node then
7146 Store_Before_Actions_In_Scope (Ins_Actions);
7150 Insert_List_Before_And_Analyze (P, Ins_Actions);
7154 -- the expansion of Task and protected type declarations can
7155 -- create declarations for temporaries which, like other actions
7156 -- are inserted and analyzed before the current declaraation.
7157 -- However, the current scope is the synchronized type, and
7158 -- for unnesting it is critical that the proper scope for these
7159 -- generated entities be the enclosing one.
7161 when N_Task_Type_Declaration
7162 | N_Protected_Type_Declaration =>
7164 Push_Scope (Scope (Current_Scope));
7165 Insert_List_Before_And_Analyze (P, Ins_Actions);
7169 -- A special case, N_Raise_xxx_Error can act either as a statement
7170 -- or a subexpression. We tell the difference by looking at the
7171 -- Etype. It is set to Standard_Void_Type in the statement case.
7173 when N_Raise_xxx_Error =>
7174 if Etype (P) = Standard_Void_Type then
7175 if P = Wrapped_Node then
7176 Store_Before_Actions_In_Scope (Ins_Actions);
7178 Insert_List_Before_And_Analyze (P, Ins_Actions);
7183 -- In the subexpression case, keep climbing
7189 -- If a component association appears within a loop created for
7190 -- an array aggregate, attach the actions to the association so
7191 -- they can be subsequently inserted within the loop. For other
7192 -- component associations insert outside of the aggregate. For
7193 -- an association that will generate a loop, its Loop_Actions
7194 -- attribute is already initialized (see exp_aggr.adb).
7196 -- The list of Loop_Actions can in turn generate additional ones,
7197 -- that are inserted before the associated node. If the associated
7198 -- node is outside the aggregate, the new actions are collected
7199 -- at the end of the Loop_Actions, to respect the order in which
7200 -- they are to be elaborated.
7202 when N_Component_Association
7203 | N_Iterated_Component_Association
7204 | N_Iterated_Element_Association
7206 if Nkind (Parent (P)) = N_Aggregate
7207 and then Present (Loop_Actions (P))
7209 if Is_Empty_List (Loop_Actions (P)) then
7210 Set_Loop_Actions (P, Ins_Actions);
7211 Analyze_List (Ins_Actions);
7217 -- Check whether these actions were generated by a
7218 -- declaration that is part of the Loop_Actions for
7219 -- the component_association.
7222 while Present (Decl) loop
7223 exit when Parent (Decl) = P
7224 and then Is_List_Member (Decl)
7226 List_Containing (Decl) = Loop_Actions (P);
7227 Decl := Parent (Decl);
7230 if Present (Decl) then
7231 Insert_List_Before_And_Analyze
7232 (Decl, Ins_Actions);
7234 Insert_List_After_And_Analyze
7235 (Last (Loop_Actions (P)), Ins_Actions);
7246 -- Special case: an attribute denoting a procedure call
7248 when N_Attribute_Reference =>
7249 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7250 if P = Wrapped_Node then
7251 Store_Before_Actions_In_Scope (Ins_Actions);
7253 Insert_List_Before_And_Analyze (P, Ins_Actions);
7258 -- In the subexpression case, keep climbing
7264 -- Special case: a marker
7267 | N_Variable_Reference_Marker
7269 if Is_List_Member (P) then
7270 Insert_List_Before_And_Analyze (P, Ins_Actions);
7274 -- A contract node should not belong to the tree
7277 raise Program_Error;
7279 -- For all other node types, keep climbing tree
7281 when N_Abortable_Part
7282 | N_Accept_Alternative
7283 | N_Access_Definition
7284 | N_Access_Function_Definition
7285 | N_Access_Procedure_Definition
7286 | N_Access_To_Object_Definition
7289 | N_Aspect_Specification
7291 | N_Case_Statement_Alternative
7292 | N_Character_Literal
7293 | N_Compilation_Unit
7294 | N_Compilation_Unit_Aux
7295 | N_Component_Clause
7296 | N_Component_Declaration
7297 | N_Component_Definition
7299 | N_Constrained_Array_Definition
7300 | N_Decimal_Fixed_Point_Definition
7301 | N_Defining_Character_Literal
7302 | N_Defining_Identifier
7303 | N_Defining_Operator_Symbol
7304 | N_Defining_Program_Unit_Name
7305 | N_Delay_Alternative
7307 | N_Delta_Constraint
7308 | N_Derived_Type_Definition
7310 | N_Digits_Constraint
7311 | N_Discriminant_Association
7312 | N_Discriminant_Specification
7314 | N_Entry_Body_Formal_Part
7315 | N_Entry_Call_Alternative
7316 | N_Entry_Declaration
7317 | N_Entry_Index_Specification
7318 | N_Enumeration_Type_Definition
7320 | N_Exception_Handler
7322 | N_Explicit_Dereference
7323 | N_Extension_Aggregate
7324 | N_Floating_Point_Definition
7325 | N_Formal_Decimal_Fixed_Point_Definition
7326 | N_Formal_Derived_Type_Definition
7327 | N_Formal_Discrete_Type_Definition
7328 | N_Formal_Floating_Point_Definition
7329 | N_Formal_Modular_Type_Definition
7330 | N_Formal_Ordinary_Fixed_Point_Definition
7331 | N_Formal_Package_Declaration
7332 | N_Formal_Private_Type_Definition
7333 | N_Formal_Incomplete_Type_Definition
7334 | N_Formal_Signed_Integer_Type_Definition
7336 | N_Function_Specification
7337 | N_Generic_Association
7338 | N_Handled_Sequence_Of_Statements
7341 | N_Index_Or_Discriminant_Constraint
7342 | N_Indexed_Component
7344 | N_Iterator_Specification
7347 | N_Loop_Parameter_Specification
7349 | N_Modular_Type_Definition
7375 | N_Op_Shift_Right_Arithmetic
7379 | N_Ordinary_Fixed_Point_Definition
7381 | N_Package_Specification
7382 | N_Parameter_Association
7383 | N_Parameter_Specification
7384 | N_Pop_Constraint_Error_Label
7385 | N_Pop_Program_Error_Label
7386 | N_Pop_Storage_Error_Label
7387 | N_Pragma_Argument_Association
7388 | N_Procedure_Specification
7389 | N_Protected_Definition
7390 | N_Push_Constraint_Error_Label
7391 | N_Push_Program_Error_Label
7392 | N_Push_Storage_Error_Label
7393 | N_Qualified_Expression
7394 | N_Quantified_Expression
7395 | N_Raise_Expression
7397 | N_Range_Constraint
7399 | N_Real_Range_Specification
7400 | N_Record_Definition
7402 | N_SCIL_Dispatch_Table_Tag_Init
7403 | N_SCIL_Dispatching_Call
7404 | N_SCIL_Membership_Test
7405 | N_Selected_Component
7406 | N_Signed_Integer_Type_Definition
7407 | N_Single_Protected_Declaration
7410 | N_Subtype_Indication
7414 | N_Terminate_Alternative
7415 | N_Triggering_Alternative
7417 | N_Unchecked_Expression
7418 | N_Unchecked_Type_Conversion
7419 | N_Unconstrained_Array_Definition
7424 | N_Validate_Unchecked_Conversion
7430 -- If we fall through above tests, keep climbing tree
7434 if Nkind (Parent (N)) = N_Subunit then
7436 -- This is the proper body corresponding to a stub. Insertion must
7437 -- be done at the point of the stub, which is in the declarative
7438 -- part of the parent unit.
7440 P := Corresponding_Stub (Parent (N));
7448 -- Version with check(s) suppressed
7450 procedure Insert_Actions
7451 (Assoc_Node : Node_Id;
7452 Ins_Actions : List_Id;
7453 Suppress : Check_Id;
7454 Spec_Expr_OK : Boolean := False)
7457 if Suppress = All_Checks then
7459 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
7461 Scope_Suppress.Suppress := (others => True);
7462 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7463 Scope_Suppress.Suppress := Sva;
7468 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
7470 Scope_Suppress.Suppress (Suppress) := True;
7471 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7472 Scope_Suppress.Suppress (Suppress) := Svg;
7477 --------------------------
7478 -- Insert_Actions_After --
7479 --------------------------
7481 procedure Insert_Actions_After
7482 (Assoc_Node : Node_Id;
7483 Ins_Actions : List_Id)
7486 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
7487 Store_After_Actions_In_Scope (Ins_Actions);
7489 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
7491 end Insert_Actions_After;
7493 ------------------------
7494 -- Insert_Declaration --
7495 ------------------------
7497 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
7501 pragma Assert (Nkind (N) in N_Subexpr);
7503 -- Climb until we find a procedure or a package
7507 pragma Assert (Present (Parent (P)));
7510 if Is_List_Member (P) then
7511 exit when Nkind (Parent (P)) in
7512 N_Package_Specification | N_Subprogram_Body;
7514 -- Special handling for handled sequence of statements, we must
7515 -- insert in the statements not the exception handlers!
7517 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
7518 P := First (Statements (Parent (P)));
7524 -- Now do the insertion
7526 Insert_Before (P, Decl);
7528 end Insert_Declaration;
7530 ---------------------------------
7531 -- Insert_Library_Level_Action --
7532 ---------------------------------
7534 procedure Insert_Library_Level_Action (N : Node_Id) is
7535 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7538 Push_Scope (Cunit_Entity (Current_Sem_Unit));
7539 -- And not Main_Unit as previously. If the main unit is a body,
7540 -- the scope needed to analyze the actions is the entity of the
7541 -- corresponding declaration.
7543 if No (Actions (Aux)) then
7544 Set_Actions (Aux, New_List (N));
7546 Append (N, Actions (Aux));
7551 end Insert_Library_Level_Action;
7553 ----------------------------------
7554 -- Insert_Library_Level_Actions --
7555 ----------------------------------
7557 procedure Insert_Library_Level_Actions (L : List_Id) is
7558 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7561 if Is_Non_Empty_List (L) then
7562 Push_Scope (Cunit_Entity (Main_Unit));
7563 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
7565 if No (Actions (Aux)) then
7566 Set_Actions (Aux, L);
7569 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
7574 end Insert_Library_Level_Actions;
7576 ----------------------
7577 -- Inside_Init_Proc --
7578 ----------------------
7580 function Inside_Init_Proc return Boolean is
7581 Proc : constant Entity_Id := Enclosing_Init_Proc;
7584 return Proc /= Empty;
7585 end Inside_Init_Proc;
7587 ----------------------
7588 -- Integer_Type_For --
7589 ----------------------
7591 function Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id is
7593 pragma Assert (S <= System_Max_Integer_Size);
7595 -- This is the canonical 32-bit type
7597 if S <= Standard_Integer_Size then
7599 return Standard_Unsigned;
7601 return Standard_Integer;
7604 -- This is the canonical 64-bit type
7606 elsif S <= Standard_Long_Long_Integer_Size then
7608 return Standard_Long_Long_Unsigned;
7610 return Standard_Long_Long_Integer;
7613 -- This is the canonical 128-bit type
7615 elsif S <= Standard_Long_Long_Long_Integer_Size then
7617 return Standard_Long_Long_Long_Unsigned;
7619 return Standard_Long_Long_Long_Integer;
7623 raise Program_Error;
7625 end Integer_Type_For;
7627 ----------------------------
7628 -- Is_All_Null_Statements --
7629 ----------------------------
7631 function Is_All_Null_Statements (L : List_Id) return Boolean is
7636 while Present (Stm) loop
7637 if Nkind (Stm) /= N_Null_Statement then
7645 end Is_All_Null_Statements;
7647 --------------------------------------------------
7648 -- Is_Displacement_Of_Object_Or_Function_Result --
7649 --------------------------------------------------
7651 function Is_Displacement_Of_Object_Or_Function_Result
7652 (Obj_Id : Entity_Id) return Boolean
7654 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
7655 -- Determine whether node N denotes a controlled function call
7657 function Is_Controlled_Indexing (N : Node_Id) return Boolean;
7658 -- Determine whether node N denotes a generalized indexing form which
7659 -- involves a controlled result.
7661 function Is_Displace_Call (N : Node_Id) return Boolean;
7662 -- Determine whether node N denotes a call to Ada.Tags.Displace
7664 function Is_Source_Object (N : Node_Id) return Boolean;
7665 -- Determine whether a particular node denotes a source object
7667 function Strip (N : Node_Id) return Node_Id;
7668 -- Examine arbitrary node N by stripping various indirections and return
7671 ---------------------------------
7672 -- Is_Controlled_Function_Call --
7673 ---------------------------------
7675 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
7679 -- When a function call appears in Object.Operation format, the
7680 -- original representation has several possible forms depending on
7681 -- the availability and form of actual parameters:
7683 -- Obj.Func N_Selected_Component
7684 -- Obj.Func (Actual) N_Indexed_Component
7685 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
7686 -- N_Selected_Component
7688 Expr := Original_Node (N);
7690 if Nkind (Expr) = N_Function_Call then
7691 Expr := Name (Expr);
7693 -- "Obj.Func (Actual)" case
7695 elsif Nkind (Expr) = N_Indexed_Component then
7696 Expr := Prefix (Expr);
7698 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
7700 elsif Nkind (Expr) = N_Selected_Component then
7701 Expr := Selector_Name (Expr);
7709 Nkind (Expr) in N_Has_Entity
7710 and then Present (Entity (Expr))
7711 and then Ekind (Entity (Expr)) = E_Function
7712 and then Needs_Finalization (Etype (Entity (Expr)));
7713 end Is_Controlled_Function_Call;
7715 ----------------------------
7716 -- Is_Controlled_Indexing --
7717 ----------------------------
7719 function Is_Controlled_Indexing (N : Node_Id) return Boolean is
7720 Expr : constant Node_Id := Original_Node (N);
7724 Nkind (Expr) = N_Indexed_Component
7725 and then Present (Generalized_Indexing (Expr))
7726 and then Needs_Finalization (Etype (Expr));
7727 end Is_Controlled_Indexing;
7729 ----------------------
7730 -- Is_Displace_Call --
7731 ----------------------
7733 function Is_Displace_Call (N : Node_Id) return Boolean is
7734 Call : constant Node_Id := Strip (N);
7739 and then Nkind (Call) = N_Function_Call
7740 and then Nkind (Name (Call)) in N_Has_Entity
7741 and then Is_RTE (Entity (Name (Call)), RE_Displace);
7742 end Is_Displace_Call;
7744 ----------------------
7745 -- Is_Source_Object --
7746 ----------------------
7748 function Is_Source_Object (N : Node_Id) return Boolean is
7749 Obj : constant Node_Id := Strip (N);
7754 and then Comes_From_Source (Obj)
7755 and then Nkind (Obj) in N_Has_Entity
7756 and then Is_Object (Entity (Obj));
7757 end Is_Source_Object;
7763 function Strip (N : Node_Id) return Node_Id is
7769 if Nkind (Result) = N_Explicit_Dereference then
7770 Result := Prefix (Result);
7772 elsif Nkind (Result) in
7773 N_Type_Conversion | N_Unchecked_Type_Conversion
7775 Result := Expression (Result);
7787 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
7788 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7789 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
7790 Orig_Expr : Node_Id;
7792 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
7797 -- Obj : CW_Type := Function_Call (...);
7799 -- is rewritten into:
7801 -- Temp : ... := Function_Call (...)'reference;
7802 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
7804 -- where the return type of the function and the class-wide type require
7805 -- dispatch table pointer displacement.
7809 -- Obj : CW_Type := Container (...);
7811 -- is rewritten into:
7813 -- Temp : ... := Function_Call (Container, ...)'reference;
7814 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
7816 -- where the container element type and the class-wide type require
7817 -- dispatch table pointer dispacement.
7821 -- Obj : CW_Type := Src_Obj;
7823 -- is rewritten into:
7825 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7827 -- where the type of the source object and the class-wide type require
7828 -- dispatch table pointer displacement.
7830 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
7831 and then Is_Class_Wide_Type (Obj_Typ)
7832 and then Is_Displace_Call (Renamed_Object (Obj_Id))
7833 and then Nkind (Orig_Decl) = N_Object_Declaration
7834 and then Comes_From_Source (Orig_Decl)
7836 Orig_Expr := Expression (Orig_Decl);
7839 Is_Controlled_Function_Call (Orig_Expr)
7840 or else Is_Controlled_Indexing (Orig_Expr)
7841 or else Is_Source_Object (Orig_Expr);
7845 end Is_Displacement_Of_Object_Or_Function_Result;
7847 ------------------------------
7848 -- Is_Finalizable_Transient --
7849 ------------------------------
7851 function Is_Finalizable_Transient
7853 Rel_Node : Node_Id) return Boolean
7855 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
7856 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7858 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
7859 -- Determine whether transient object Trans_Id is initialized either
7860 -- by a function call which returns an access type or simply renames
7863 function Initialized_By_Aliased_BIP_Func_Call
7864 (Trans_Id : Entity_Id) return Boolean;
7865 -- Determine whether transient object Trans_Id is initialized by a
7866 -- build-in-place function call where the BIPalloc parameter is of
7867 -- value 1 and BIPaccess is not null. This case creates an aliasing
7868 -- between the returned value and the value denoted by BIPaccess.
7871 (Trans_Id : Entity_Id;
7872 First_Stmt : Node_Id) return Boolean;
7873 -- Determine whether transient object Trans_Id has been renamed or
7874 -- aliased through 'reference in the statement list starting from
7877 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
7878 -- Determine whether transient object Trans_Id is allocated on the heap
7880 function Is_Iterated_Container
7881 (Trans_Id : Entity_Id;
7882 First_Stmt : Node_Id) return Boolean;
7883 -- Determine whether transient object Trans_Id denotes a container which
7884 -- is in the process of being iterated in the statement list starting
7887 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean;
7888 -- Return True if N is directly part of a build-in-place return
7891 ---------------------------
7892 -- Initialized_By_Access --
7893 ---------------------------
7895 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
7896 Expr : constant Node_Id := Expression (Parent (Trans_Id));
7901 and then Nkind (Expr) /= N_Reference
7902 and then Is_Access_Type (Etype (Expr));
7903 end Initialized_By_Access;
7905 ------------------------------------------
7906 -- Initialized_By_Aliased_BIP_Func_Call --
7907 ------------------------------------------
7909 function Initialized_By_Aliased_BIP_Func_Call
7910 (Trans_Id : Entity_Id) return Boolean
7912 Call : Node_Id := Expression (Parent (Trans_Id));
7915 -- Build-in-place calls usually appear in 'reference format
7917 if Nkind (Call) = N_Reference then
7918 Call := Prefix (Call);
7921 Call := Unqual_Conv (Call);
7923 if Is_Build_In_Place_Function_Call (Call) then
7925 Access_Nam : Name_Id := No_Name;
7926 Access_OK : Boolean := False;
7928 Alloc_Nam : Name_Id := No_Name;
7929 Alloc_OK : Boolean := False;
7931 Func_Id : Entity_Id;
7935 -- Examine all parameter associations of the function call
7937 Param := First (Parameter_Associations (Call));
7938 while Present (Param) loop
7939 if Nkind (Param) = N_Parameter_Association
7940 and then Nkind (Selector_Name (Param)) = N_Identifier
7942 Actual := Explicit_Actual_Parameter (Param);
7943 Formal := Selector_Name (Param);
7945 -- Construct the names of formals BIPaccess and BIPalloc
7946 -- using the function name retrieved from an arbitrary
7949 if Access_Nam = No_Name
7950 and then Alloc_Nam = No_Name
7951 and then Present (Entity (Formal))
7953 Func_Id := Scope (Entity (Formal));
7956 New_External_Name (Chars (Func_Id),
7957 BIP_Formal_Suffix (BIP_Object_Access));
7960 New_External_Name (Chars (Func_Id),
7961 BIP_Formal_Suffix (BIP_Alloc_Form));
7964 -- A match for BIPaccess => Temp has been found
7966 if Chars (Formal) = Access_Nam
7967 and then Nkind (Actual) /= N_Null
7972 -- A match for BIPalloc => 1 has been found
7974 if Chars (Formal) = Alloc_Nam
7975 and then Nkind (Actual) = N_Integer_Literal
7976 and then Intval (Actual) = Uint_1
7985 return Access_OK and Alloc_OK;
7990 end Initialized_By_Aliased_BIP_Func_Call;
7997 (Trans_Id : Entity_Id;
7998 First_Stmt : Node_Id) return Boolean
8000 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
8001 -- Given an object renaming declaration, retrieve the entity of the
8002 -- renamed name. Return Empty if the renamed name is anything other
8003 -- than a variable or a constant.
8005 -------------------------
8006 -- Find_Renamed_Object --
8007 -------------------------
8009 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
8010 Ren_Obj : Node_Id := Empty;
8012 function Find_Object (N : Node_Id) return Traverse_Result;
8013 -- Try to detect an object which is either a constant or a
8020 function Find_Object (N : Node_Id) return Traverse_Result is
8022 -- Stop the search once a constant or a variable has been
8025 if Nkind (N) = N_Identifier
8026 and then Present (Entity (N))
8027 and then Ekind (Entity (N)) in E_Constant | E_Variable
8029 Ren_Obj := Entity (N);
8036 procedure Search is new Traverse_Proc (Find_Object);
8040 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
8042 -- Start of processing for Find_Renamed_Object
8045 -- Actions related to dispatching calls may appear as renamings of
8046 -- tags. Do not process this type of renaming because it does not
8047 -- use the actual value of the object.
8049 if not Is_RTE (Typ, RE_Tag_Ptr) then
8050 Search (Name (Ren_Decl));
8054 end Find_Renamed_Object;
8059 Ren_Obj : Entity_Id;
8062 -- Start of processing for Is_Aliased
8065 -- A controlled transient object is not considered aliased when it
8066 -- appears inside an expression_with_actions node even when there are
8067 -- explicit aliases of it:
8070 -- Trans_Id : Ctrl_Typ ...; -- transient object
8071 -- Alias : ... := Trans_Id; -- object is aliased
8072 -- Val : constant Boolean :=
8073 -- ... Alias ...; -- aliasing ends
8074 -- <finalize Trans_Id> -- object safe to finalize
8077 -- Expansion ensures that all aliases are encapsulated in the actions
8078 -- list and do not leak to the expression by forcing the evaluation
8079 -- of the expression.
8081 if Nkind (Rel_Node) = N_Expression_With_Actions then
8084 -- Otherwise examine the statements after the controlled transient
8085 -- object and look for various forms of aliasing.
8089 while Present (Stmt) loop
8090 if Nkind (Stmt) = N_Object_Declaration then
8091 Expr := Expression (Stmt);
8093 -- Aliasing of the form:
8094 -- Obj : ... := Trans_Id'reference;
8097 and then Nkind (Expr) = N_Reference
8098 and then Nkind (Prefix (Expr)) = N_Identifier
8099 and then Entity (Prefix (Expr)) = Trans_Id
8104 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
8105 Ren_Obj := Find_Renamed_Object (Stmt);
8107 -- Aliasing of the form:
8108 -- Obj : ... renames ... Trans_Id ...;
8110 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
8126 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
8127 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8130 Is_Access_Type (Etype (Trans_Id))
8131 and then Present (Expr)
8132 and then Nkind (Expr) = N_Allocator;
8135 ---------------------------
8136 -- Is_Iterated_Container --
8137 ---------------------------
8139 function Is_Iterated_Container
8140 (Trans_Id : Entity_Id;
8141 First_Stmt : Node_Id) return Boolean
8151 -- It is not possible to iterate over containers in non-Ada 2012 code
8153 if Ada_Version < Ada_2012 then
8157 Typ := Etype (Trans_Id);
8159 -- Handle access type created for secondary stack use
8161 if Is_Access_Type (Typ) then
8162 Typ := Designated_Type (Typ);
8165 -- Look for aspect Default_Iterator. It may be part of a type
8166 -- declaration for a container, or inherited from a base type
8169 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8171 if Present (Aspect) then
8172 Iter := Entity (Aspect);
8174 -- Examine the statements following the container object and
8175 -- look for a call to the default iterate routine where the
8176 -- first parameter is the transient. Such a call appears as:
8178 -- It : Access_To_CW_Iterator :=
8179 -- Iterate (Tran_Id.all, ...)'reference;
8182 while Present (Stmt) loop
8184 -- Detect an object declaration which is initialized by a
8185 -- secondary stack function call.
8187 if Nkind (Stmt) = N_Object_Declaration
8188 and then Present (Expression (Stmt))
8189 and then Nkind (Expression (Stmt)) = N_Reference
8190 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8192 Call := Prefix (Expression (Stmt));
8194 -- The call must invoke the default iterate routine of
8195 -- the container and the transient object must appear as
8196 -- the first actual parameter. Skip any calls whose names
8197 -- are not entities.
8199 if Is_Entity_Name (Name (Call))
8200 and then Entity (Name (Call)) = Iter
8201 and then Present (Parameter_Associations (Call))
8203 Param := First (Parameter_Associations (Call));
8205 if Nkind (Param) = N_Explicit_Dereference
8206 and then Entity (Prefix (Param)) = Trans_Id
8218 end Is_Iterated_Container;
8220 -------------------------------------
8221 -- Is_Part_Of_BIP_Return_Statement --
8222 -------------------------------------
8224 function Is_Part_Of_BIP_Return_Statement (N : Node_Id) return Boolean is
8225 Subp : constant Entity_Id := Current_Subprogram;
8228 -- First check if N is part of a BIP function
8231 or else not Is_Build_In_Place_Function (Subp)
8236 -- Then check whether N is a complete part of a return statement
8237 -- Should we consider other node kinds to go up the tree???
8241 case Nkind (Context) is
8242 when N_Expression_With_Actions => Context := Parent (Context);
8243 when N_Simple_Return_Statement => return True;
8244 when others => return False;
8247 end Is_Part_Of_BIP_Return_Statement;
8251 Desig : Entity_Id := Obj_Typ;
8253 -- Start of processing for Is_Finalizable_Transient
8256 -- Handle access types
8258 if Is_Access_Type (Desig) then
8259 Desig := Available_View (Designated_Type (Desig));
8263 Ekind (Obj_Id) in E_Constant | E_Variable
8264 and then Needs_Finalization (Desig)
8265 and then Requires_Transient_Scope (Desig)
8266 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8267 and then not Is_Part_Of_BIP_Return_Statement (Rel_Node)
8269 -- Do not consider a transient object that was already processed
8271 and then not Is_Finalized_Transient (Obj_Id)
8273 -- Do not consider renamed or 'reference-d transient objects because
8274 -- the act of renaming extends the object's lifetime.
8276 and then not Is_Aliased (Obj_Id, Decl)
8278 -- Do not consider transient objects allocated on the heap since
8279 -- they are attached to a finalization master.
8281 and then not Is_Allocated (Obj_Id)
8283 -- If the transient object is a pointer, check that it is not
8284 -- initialized by a function that returns a pointer or acts as a
8285 -- renaming of another pointer.
8288 (Is_Access_Type (Obj_Typ) and then Initialized_By_Access (Obj_Id))
8290 -- Do not consider transient objects which act as indirect aliases
8291 -- of build-in-place function results.
8293 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8295 -- Do not consider conversions of tags to class-wide types
8297 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8299 -- Do not consider iterators because those are treated as normal
8300 -- controlled objects and are processed by the usual finalization
8301 -- machinery. This avoids the double finalization of an iterator.
8303 and then not Is_Iterator (Desig)
8305 -- Do not consider containers in the context of iterator loops. Such
8306 -- transient objects must exist for as long as the loop is around,
8307 -- otherwise any operation carried out by the iterator will fail.
8309 and then not Is_Iterated_Container (Obj_Id, Decl);
8310 end Is_Finalizable_Transient;
8312 ---------------------------------
8313 -- Is_Fully_Repped_Tagged_Type --
8314 ---------------------------------
8316 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8317 U : constant Entity_Id := Underlying_Type (T);
8321 if No (U) or else not Is_Tagged_Type (U) then
8323 elsif Has_Discriminants (U) then
8325 elsif not Has_Specified_Layout (U) then
8329 -- Here we have a tagged type, see if it has any component (other than
8330 -- tag and parent) with no component_clause. If so, we return False.
8332 Comp := First_Component (U);
8333 while Present (Comp) loop
8334 if not Is_Tag (Comp)
8335 and then Chars (Comp) /= Name_uParent
8336 and then No (Component_Clause (Comp))
8340 Next_Component (Comp);
8344 -- All components have clauses
8347 end Is_Fully_Repped_Tagged_Type;
8349 ----------------------------------
8350 -- Is_Library_Level_Tagged_Type --
8351 ----------------------------------
8353 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8355 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8356 end Is_Library_Level_Tagged_Type;
8358 --------------------------
8359 -- Is_Non_BIP_Func_Call --
8360 --------------------------
8362 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8364 -- The expected call is of the format
8366 -- Func_Call'reference
8369 Nkind (Expr) = N_Reference
8370 and then Nkind (Prefix (Expr)) = N_Function_Call
8371 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8372 end Is_Non_BIP_Func_Call;
8374 ----------------------------------
8375 -- Is_Possibly_Unaligned_Object --
8376 ----------------------------------
8378 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8379 T : constant Entity_Id := Etype (N);
8382 -- If renamed object, apply test to underlying object
8384 if Is_Entity_Name (N)
8385 and then Is_Object (Entity (N))
8386 and then Present (Renamed_Object (Entity (N)))
8388 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8391 -- Tagged and controlled types and aliased types are always aligned, as
8392 -- are concurrent types.
8395 or else Has_Controlled_Component (T)
8396 or else Is_Concurrent_Type (T)
8397 or else Is_Tagged_Type (T)
8398 or else Is_Controlled (T)
8403 -- If this is an element of a packed array, may be unaligned
8405 if Is_Ref_To_Bit_Packed_Array (N) then
8409 -- Case of indexed component reference: test whether prefix is unaligned
8411 if Nkind (N) = N_Indexed_Component then
8412 return Is_Possibly_Unaligned_Object (Prefix (N));
8414 -- Case of selected component reference
8416 elsif Nkind (N) = N_Selected_Component then
8418 P : constant Node_Id := Prefix (N);
8419 C : constant Entity_Id := Entity (Selector_Name (N));
8424 -- If component reference is for an array with nonstatic bounds,
8425 -- then it is always aligned: we can only process unaligned arrays
8426 -- with static bounds (more precisely compile time known bounds).
8428 if Is_Array_Type (T)
8429 and then not Compile_Time_Known_Bounds (T)
8434 -- If component is aliased, it is definitely properly aligned
8436 if Is_Aliased (C) then
8440 -- If component is for a type implemented as a scalar, and the
8441 -- record is packed, and the component is other than the first
8442 -- component of the record, then the component may be unaligned.
8444 if Is_Packed (Etype (P))
8445 and then Represented_As_Scalar (Etype (C))
8446 and then First_Entity (Scope (C)) /= C
8451 -- Compute maximum possible alignment for T
8453 -- If alignment is known, then that settles things
8455 if Known_Alignment (T) then
8456 M := UI_To_Int (Alignment (T));
8458 -- If alignment is not known, tentatively set max alignment
8461 M := Ttypes.Maximum_Alignment;
8463 -- We can reduce this if the Esize is known since the default
8464 -- alignment will never be more than the smallest power of 2
8465 -- that does not exceed this Esize value.
8467 if Known_Esize (T) then
8468 S := UI_To_Int (Esize (T));
8470 while (M / 2) >= S loop
8476 -- The following code is historical, it used to be present but it
8477 -- is too cautious, because the front-end does not know the proper
8478 -- default alignments for the target. Also, if the alignment is
8479 -- not known, the front end can't know in any case. If a copy is
8480 -- needed, the back-end will take care of it. This whole section
8481 -- including this comment can be removed later ???
8483 -- If the component reference is for a record that has a specified
8484 -- alignment, and we either know it is too small, or cannot tell,
8485 -- then the component may be unaligned.
8487 -- What is the following commented out code ???
8489 -- if Known_Alignment (Etype (P))
8490 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
8491 -- and then M > Alignment (Etype (P))
8496 -- Case of component clause present which may specify an
8497 -- unaligned position.
8499 if Present (Component_Clause (C)) then
8501 -- Otherwise we can do a test to make sure that the actual
8502 -- start position in the record, and the length, are both
8503 -- consistent with the required alignment. If not, we know
8504 -- that we are unaligned.
8507 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8513 -- For a component inherited in a record extension, the
8514 -- clause is inherited but position and size are not set.
8516 if Is_Base_Type (Etype (P))
8517 and then Is_Tagged_Type (Etype (P))
8518 and then Present (Original_Record_Component (Comp))
8520 Comp := Original_Record_Component (Comp);
8523 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
8524 or else Esize (Comp) mod Align_In_Bits /= 0
8531 -- Otherwise, for a component reference, test prefix
8533 return Is_Possibly_Unaligned_Object (P);
8536 -- If not a component reference, must be aligned
8541 end Is_Possibly_Unaligned_Object;
8543 ---------------------------------
8544 -- Is_Possibly_Unaligned_Slice --
8545 ---------------------------------
8547 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
8549 -- Go to renamed object
8551 if Is_Entity_Name (N)
8552 and then Is_Object (Entity (N))
8553 and then Present (Renamed_Object (Entity (N)))
8555 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
8558 -- The reference must be a slice
8560 if Nkind (N) /= N_Slice then
8564 -- If it is a slice, then look at the array type being sliced
8567 Sarr : constant Node_Id := Prefix (N);
8568 -- Prefix of the slice, i.e. the array being sliced
8570 Styp : constant Entity_Id := Etype (Prefix (N));
8571 -- Type of the array being sliced
8577 -- The problems arise if the array object that is being sliced
8578 -- is a component of a record or array, and we cannot guarantee
8579 -- the alignment of the array within its containing object.
8581 -- To investigate this, we look at successive prefixes to see
8582 -- if we have a worrisome indexed or selected component.
8586 -- Case of array is part of an indexed component reference
8588 if Nkind (Pref) = N_Indexed_Component then
8589 Ptyp := Etype (Prefix (Pref));
8591 -- The only problematic case is when the array is packed, in
8592 -- which case we really know nothing about the alignment of
8593 -- individual components.
8595 if Is_Bit_Packed_Array (Ptyp) then
8599 -- Case of array is part of a selected component reference
8601 elsif Nkind (Pref) = N_Selected_Component then
8602 Ptyp := Etype (Prefix (Pref));
8604 -- We are definitely in trouble if the record in question
8605 -- has an alignment, and either we know this alignment is
8606 -- inconsistent with the alignment of the slice, or we don't
8607 -- know what the alignment of the slice should be. But this
8608 -- really matters only if the target has strict alignment.
8610 if Target_Strict_Alignment
8611 and then Known_Alignment (Ptyp)
8612 and then (Unknown_Alignment (Styp)
8613 or else Alignment (Styp) > Alignment (Ptyp))
8618 -- We are in potential trouble if the record type is packed.
8619 -- We could special case when we know that the array is the
8620 -- first component, but that's not such a simple case ???
8622 if Is_Packed (Ptyp) then
8626 -- We are in trouble if there is a component clause, and
8627 -- either we do not know the alignment of the slice, or
8628 -- the alignment of the slice is inconsistent with the
8629 -- bit position specified by the component clause.
8632 Field : constant Entity_Id := Entity (Selector_Name (Pref));
8634 if Present (Component_Clause (Field))
8636 (Unknown_Alignment (Styp)
8638 (Component_Bit_Offset (Field) mod
8639 (System_Storage_Unit * Alignment (Styp))) /= 0)
8645 -- For cases other than selected or indexed components we know we
8646 -- are OK, since no issues arise over alignment.
8652 -- We processed an indexed component or selected component
8653 -- reference that looked safe, so keep checking prefixes.
8655 Pref := Prefix (Pref);
8658 end Is_Possibly_Unaligned_Slice;
8660 -------------------------------
8661 -- Is_Related_To_Func_Return --
8662 -------------------------------
8664 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
8665 Expr : constant Node_Id := Related_Expression (Id);
8667 -- In the case of a function with a class-wide result that returns
8668 -- a call to a function with a specific result, we introduce a
8669 -- type conversion for the return expression. We do not want that
8670 -- type conversion to influence the result of this function.
8674 and then Nkind (Unqual_Conv (Expr)) = N_Explicit_Dereference
8675 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
8676 end Is_Related_To_Func_Return;
8678 --------------------------------
8679 -- Is_Ref_To_Bit_Packed_Array --
8680 --------------------------------
8682 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
8687 if Is_Entity_Name (N)
8688 and then Is_Object (Entity (N))
8689 and then Present (Renamed_Object (Entity (N)))
8691 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
8694 if Nkind (N) in N_Indexed_Component | N_Selected_Component then
8695 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
8698 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
8701 if Result and then Nkind (N) = N_Indexed_Component then
8702 Expr := First (Expressions (N));
8703 while Present (Expr) loop
8704 Force_Evaluation (Expr);
8714 end Is_Ref_To_Bit_Packed_Array;
8716 --------------------------------
8717 -- Is_Ref_To_Bit_Packed_Slice --
8718 --------------------------------
8720 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
8722 if Nkind (N) = N_Type_Conversion then
8723 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
8725 elsif Is_Entity_Name (N)
8726 and then Is_Object (Entity (N))
8727 and then Present (Renamed_Object (Entity (N)))
8729 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
8731 elsif Nkind (N) = N_Slice
8732 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
8736 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
8737 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
8742 end Is_Ref_To_Bit_Packed_Slice;
8744 -----------------------
8745 -- Is_Renamed_Object --
8746 -----------------------
8748 function Is_Renamed_Object (N : Node_Id) return Boolean is
8749 Pnod : constant Node_Id := Parent (N);
8750 Kind : constant Node_Kind := Nkind (Pnod);
8752 if Kind = N_Object_Renaming_Declaration then
8754 elsif Kind in N_Indexed_Component | N_Selected_Component then
8755 return Is_Renamed_Object (Pnod);
8759 end Is_Renamed_Object;
8761 --------------------------------------
8762 -- Is_Secondary_Stack_BIP_Func_Call --
8763 --------------------------------------
8765 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
8767 Call : Node_Id := Expr;
8772 -- Build-in-place calls usually appear in 'reference format. Note that
8773 -- the accessibility check machinery may add an extra 'reference due to
8774 -- side effect removal.
8776 while Nkind (Call) = N_Reference loop
8777 Call := Prefix (Call);
8780 Call := Unqual_Conv (Call);
8782 if Is_Build_In_Place_Function_Call (Call) then
8784 -- Examine all parameter associations of the function call
8786 Param := First (Parameter_Associations (Call));
8787 while Present (Param) loop
8788 if Nkind (Param) = N_Parameter_Association then
8789 Formal := Selector_Name (Param);
8790 Actual := Explicit_Actual_Parameter (Param);
8792 -- A match for BIPalloc => 2 has been found
8794 if Is_Build_In_Place_Entity (Formal)
8795 and then BIP_Suffix_Kind (Formal) = BIP_Alloc_Form
8796 and then Nkind (Actual) = N_Integer_Literal
8797 and then Intval (Actual) = Uint_2
8808 end Is_Secondary_Stack_BIP_Func_Call;
8810 -------------------------------------
8811 -- Is_Tag_To_Class_Wide_Conversion --
8812 -------------------------------------
8814 function Is_Tag_To_Class_Wide_Conversion
8815 (Obj_Id : Entity_Id) return Boolean
8817 Expr : constant Node_Id := Expression (Parent (Obj_Id));
8821 Is_Class_Wide_Type (Etype (Obj_Id))
8822 and then Present (Expr)
8823 and then Nkind (Expr) = N_Unchecked_Type_Conversion
8824 and then Etype (Expression (Expr)) = RTE (RE_Tag);
8825 end Is_Tag_To_Class_Wide_Conversion;
8827 --------------------------------
8828 -- Is_Uninitialized_Aggregate --
8829 --------------------------------
8831 function Is_Uninitialized_Aggregate
8833 T : Entity_Id) return Boolean
8836 Comp_Type : Entity_Id;
8840 if Nkind (Exp) /= N_Aggregate then
8844 Preanalyze_And_Resolve (Exp, T);
8848 or else Ekind (Typ) /= E_Array_Subtype
8849 or else Present (Expressions (Exp))
8850 or else No (Component_Associations (Exp))
8854 Comp_Type := Component_Type (Typ);
8855 Comp := First (Component_Associations (Exp));
8857 if not Box_Present (Comp)
8858 or else Present (Next (Comp))
8863 return Is_Scalar_Type (Comp_Type)
8864 and then No (Default_Aspect_Component_Value (Typ));
8866 end Is_Uninitialized_Aggregate;
8868 ----------------------------
8869 -- Is_Untagged_Derivation --
8870 ----------------------------
8872 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
8874 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
8876 (Is_Private_Type (T) and then Present (Full_View (T))
8877 and then not Is_Tagged_Type (Full_View (T))
8878 and then Is_Derived_Type (Full_View (T))
8879 and then Etype (Full_View (T)) /= T);
8880 end Is_Untagged_Derivation;
8882 ------------------------------------
8883 -- Is_Untagged_Private_Derivation --
8884 ------------------------------------
8886 function Is_Untagged_Private_Derivation
8887 (Priv_Typ : Entity_Id;
8888 Full_Typ : Entity_Id) return Boolean
8893 and then Is_Untagged_Derivation (Priv_Typ)
8894 and then Is_Private_Type (Etype (Priv_Typ))
8895 and then Present (Full_Typ)
8896 and then Is_Itype (Full_Typ);
8897 end Is_Untagged_Private_Derivation;
8899 ------------------------------
8900 -- Is_Verifiable_DIC_Pragma --
8901 ------------------------------
8903 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
8904 Args : constant List_Id := Pragma_Argument_Associations (Prag);
8907 -- To qualify as verifiable, a DIC pragma must have a non-null argument
8911 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
8912 end Is_Verifiable_DIC_Pragma;
8914 ---------------------------
8915 -- Is_Volatile_Reference --
8916 ---------------------------
8918 function Is_Volatile_Reference (N : Node_Id) return Boolean is
8920 -- Only source references are to be treated as volatile, internally
8921 -- generated stuff cannot have volatile external effects.
8923 if not Comes_From_Source (N) then
8926 -- Never true for reference to a type
8928 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
8931 -- Never true for a compile time known constant
8933 elsif Compile_Time_Known_Value (N) then
8936 -- True if object reference with volatile type
8938 elsif Is_Volatile_Object (N) then
8941 -- True if reference to volatile entity
8943 elsif Is_Entity_Name (N) then
8944 return Treat_As_Volatile (Entity (N));
8946 -- True for slice of volatile array
8948 elsif Nkind (N) = N_Slice then
8949 return Is_Volatile_Reference (Prefix (N));
8951 -- True if volatile component
8953 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
8954 if (Is_Entity_Name (Prefix (N))
8955 and then Has_Volatile_Components (Entity (Prefix (N))))
8956 or else (Present (Etype (Prefix (N)))
8957 and then Has_Volatile_Components (Etype (Prefix (N))))
8961 return Is_Volatile_Reference (Prefix (N));
8969 end Is_Volatile_Reference;
8971 --------------------
8972 -- Kill_Dead_Code --
8973 --------------------
8975 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
8976 W : Boolean := Warn;
8977 -- Set False if warnings suppressed
8981 Remove_Warning_Messages (N);
8983 -- Update the internal structures of the ABE mechanism in case the
8984 -- dead node is an elaboration scenario.
8986 Kill_Elaboration_Scenario (N);
8988 -- Generate warning if appropriate
8992 -- We suppress the warning if this code is under control of an
8993 -- if statement, whose condition is a simple identifier, and
8994 -- either we are in an instance, or warnings off is set for this
8995 -- identifier. The reason for killing it in the instance case is
8996 -- that it is common and reasonable for code to be deleted in
8997 -- instances for various reasons.
8999 -- Could we use Is_Statically_Unevaluated here???
9001 if Nkind (Parent (N)) = N_If_Statement then
9003 C : constant Node_Id := Condition (Parent (N));
9005 if Nkind (C) = N_Identifier
9008 or else (Present (Entity (C))
9009 and then Has_Warnings_Off (Entity (C))))
9016 -- Generate warning if not suppressed
9020 ("?t?this code can never be executed and has been deleted!",
9025 -- Recurse into block statements and bodies to process declarations
9028 if Nkind (N) = N_Block_Statement
9029 or else Nkind (N) = N_Subprogram_Body
9030 or else Nkind (N) = N_Package_Body
9032 Kill_Dead_Code (Declarations (N), False);
9033 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
9035 if Nkind (N) = N_Subprogram_Body then
9036 Set_Is_Eliminated (Defining_Entity (N));
9039 elsif Nkind (N) = N_Package_Declaration then
9040 Kill_Dead_Code (Visible_Declarations (Specification (N)));
9041 Kill_Dead_Code (Private_Declarations (Specification (N)));
9043 -- ??? After this point, Delete_Tree has been called on all
9044 -- declarations in Specification (N), so references to entities
9045 -- therein look suspicious.
9048 E : Entity_Id := First_Entity (Defining_Entity (N));
9051 while Present (E) loop
9052 if Ekind (E) = E_Operator then
9053 Set_Is_Eliminated (E);
9060 -- Recurse into composite statement to kill individual statements in
9061 -- particular instantiations.
9063 elsif Nkind (N) = N_If_Statement then
9064 Kill_Dead_Code (Then_Statements (N));
9065 Kill_Dead_Code (Elsif_Parts (N));
9066 Kill_Dead_Code (Else_Statements (N));
9068 elsif Nkind (N) = N_Loop_Statement then
9069 Kill_Dead_Code (Statements (N));
9071 elsif Nkind (N) = N_Case_Statement then
9075 Alt := First (Alternatives (N));
9076 while Present (Alt) loop
9077 Kill_Dead_Code (Statements (Alt));
9082 elsif Nkind (N) = N_Case_Statement_Alternative then
9083 Kill_Dead_Code (Statements (N));
9085 -- Deal with dead instances caused by deleting instantiations
9087 elsif Nkind (N) in N_Generic_Instantiation then
9088 Remove_Dead_Instance (N);
9093 -- Case where argument is a list of nodes to be killed
9095 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
9102 if Is_Non_Empty_List (L) then
9104 while Present (N) loop
9105 Kill_Dead_Code (N, W);
9112 ------------------------
9113 -- Known_Non_Negative --
9114 ------------------------
9116 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
9118 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
9123 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
9126 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
9129 end Known_Non_Negative;
9131 -----------------------------
9132 -- Make_CW_Equivalent_Type --
9133 -----------------------------
9135 -- Create a record type used as an equivalent of any member of the class
9136 -- which takes its size from exp.
9138 -- Generate the following code:
9140 -- type Equiv_T is record
9141 -- _parent : T (List of discriminant constraints taken from Exp);
9142 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
9145 -- ??? Note that this type does not guarantee same alignment as all
9148 -- Note: for the freezing circuitry, this looks like a record extension,
9149 -- and so we need to make sure that the scalar storage order is the same
9150 -- as that of the parent type. (This does not change anything for the
9151 -- representation of the extension part.)
9153 function Make_CW_Equivalent_Type
9155 E : Node_Id) return Entity_Id
9157 Loc : constant Source_Ptr := Sloc (E);
9158 Root_Typ : constant Entity_Id := Root_Type (T);
9159 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
9160 List_Def : constant List_Id := Empty_List;
9161 Comp_List : constant List_Id := New_List;
9162 Equiv_Type : Entity_Id;
9163 Range_Type : Entity_Id;
9164 Str_Type : Entity_Id;
9165 Constr_Root : Entity_Id;
9169 -- If the root type is already constrained, there are no discriminants
9170 -- in the expression.
9172 if not Has_Discriminants (Root_Typ)
9173 or else Is_Constrained (Root_Typ)
9175 Constr_Root := Root_Typ;
9177 -- At this point in the expansion, nonlimited view of the type
9178 -- must be available, otherwise the error will be reported later.
9180 if From_Limited_With (Constr_Root)
9181 and then Present (Non_Limited_View (Constr_Root))
9183 Constr_Root := Non_Limited_View (Constr_Root);
9187 Constr_Root := Make_Temporary (Loc, 'R');
9189 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9191 Append_To (List_Def,
9192 Make_Subtype_Declaration (Loc,
9193 Defining_Identifier => Constr_Root,
9194 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9197 -- Generate the range subtype declaration
9199 Range_Type := Make_Temporary (Loc, 'G');
9201 if not Is_Interface (Root_Typ) then
9203 -- subtype rg__xx is
9204 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
9207 Make_Op_Subtract (Loc,
9209 Make_Attribute_Reference (Loc,
9211 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9212 Attribute_Name => Name_Size),
9214 Make_Attribute_Reference (Loc,
9215 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9216 Attribute_Name => Name_Object_Size));
9218 -- subtype rg__xx is
9219 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
9222 Make_Attribute_Reference (Loc,
9224 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9225 Attribute_Name => Name_Size);
9228 Set_Paren_Count (Sizexpr, 1);
9230 Append_To (List_Def,
9231 Make_Subtype_Declaration (Loc,
9232 Defining_Identifier => Range_Type,
9233 Subtype_Indication =>
9234 Make_Subtype_Indication (Loc,
9235 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9236 Constraint => Make_Range_Constraint (Loc,
9239 Low_Bound => Make_Integer_Literal (Loc, 1),
9241 Make_Op_Divide (Loc,
9242 Left_Opnd => Sizexpr,
9243 Right_Opnd => Make_Integer_Literal (Loc,
9244 Intval => System_Storage_Unit)))))));
9246 -- subtype str__nn is Storage_Array (rg__x);
9248 Str_Type := Make_Temporary (Loc, 'S');
9249 Append_To (List_Def,
9250 Make_Subtype_Declaration (Loc,
9251 Defining_Identifier => Str_Type,
9252 Subtype_Indication =>
9253 Make_Subtype_Indication (Loc,
9254 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9256 Make_Index_Or_Discriminant_Constraint (Loc,
9258 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9260 -- type Equiv_T is record
9261 -- [ _parent : Tnn; ]
9265 Equiv_Type := Make_Temporary (Loc, 'T');
9266 Set_Ekind (Equiv_Type, E_Record_Type);
9267 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9269 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9270 -- treatment for this type. In particular, even though _parent's type
9271 -- is a controlled type or contains controlled components, we do not
9272 -- want to set Has_Controlled_Component on it to avoid making it gain
9273 -- an unwanted _controller component.
9275 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9277 -- A class-wide equivalent type does not require initialization
9279 Set_Suppress_Initialization (Equiv_Type);
9281 if not Is_Interface (Root_Typ) then
9282 Append_To (Comp_List,
9283 Make_Component_Declaration (Loc,
9284 Defining_Identifier =>
9285 Make_Defining_Identifier (Loc, Name_uParent),
9286 Component_Definition =>
9287 Make_Component_Definition (Loc,
9288 Aliased_Present => False,
9289 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9291 Set_Reverse_Storage_Order
9292 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
9293 Set_Reverse_Bit_Order
9294 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
9297 Append_To (Comp_List,
9298 Make_Component_Declaration (Loc,
9299 Defining_Identifier => Make_Temporary (Loc, 'C'),
9300 Component_Definition =>
9301 Make_Component_Definition (Loc,
9302 Aliased_Present => False,
9303 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9305 Append_To (List_Def,
9306 Make_Full_Type_Declaration (Loc,
9307 Defining_Identifier => Equiv_Type,
9309 Make_Record_Definition (Loc,
9311 Make_Component_List (Loc,
9312 Component_Items => Comp_List,
9313 Variant_Part => Empty))));
9315 -- Suppress all checks during the analysis of the expanded code to avoid
9316 -- the generation of spurious warnings under ZFP run-time.
9318 Insert_Actions (E, List_Def, Suppress => All_Checks);
9320 end Make_CW_Equivalent_Type;
9322 -------------------------
9323 -- Make_Invariant_Call --
9324 -------------------------
9326 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9327 Loc : constant Source_Ptr := Sloc (Expr);
9328 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9329 pragma Assert (Has_Invariants (Typ));
9330 Proc_Id : constant Entity_Id := Invariant_Procedure (Typ);
9331 pragma Assert (Present (Proc_Id));
9333 -- The invariant procedure has a null body if assertions are disabled or
9334 -- Assertion_Policy Ignore is in effect. In that case, generate a null
9335 -- statement instead of a call to the invariant procedure.
9337 if Has_Null_Body (Proc_Id) then
9338 return Make_Null_Statement (Loc);
9341 Make_Procedure_Call_Statement (Loc,
9342 Name => New_Occurrence_Of (Proc_Id, Loc),
9343 Parameter_Associations => New_List (Relocate_Node (Expr)));
9345 end Make_Invariant_Call;
9347 ------------------------
9348 -- Make_Literal_Range --
9349 ------------------------
9351 function Make_Literal_Range
9353 Literal_Typ : Entity_Id) return Node_Id
9355 Lo : constant Node_Id :=
9356 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9357 Index : constant Entity_Id := Etype (Lo);
9358 Length_Expr : constant Node_Id :=
9359 Make_Op_Subtract (Loc,
9361 Make_Integer_Literal (Loc,
9362 Intval => String_Literal_Length (Literal_Typ)),
9363 Right_Opnd => Make_Integer_Literal (Loc, 1));
9368 Set_Analyzed (Lo, False);
9370 if Is_Integer_Type (Index) then
9373 Left_Opnd => New_Copy_Tree (Lo),
9374 Right_Opnd => Length_Expr);
9377 Make_Attribute_Reference (Loc,
9378 Attribute_Name => Name_Val,
9379 Prefix => New_Occurrence_Of (Index, Loc),
9380 Expressions => New_List (
9383 Make_Attribute_Reference (Loc,
9384 Attribute_Name => Name_Pos,
9385 Prefix => New_Occurrence_Of (Index, Loc),
9386 Expressions => New_List (New_Copy_Tree (Lo))),
9387 Right_Opnd => Length_Expr)));
9394 end Make_Literal_Range;
9396 --------------------------
9397 -- Make_Non_Empty_Check --
9398 --------------------------
9400 function Make_Non_Empty_Check
9402 N : Node_Id) return Node_Id
9408 Make_Attribute_Reference (Loc,
9409 Attribute_Name => Name_Length,
9410 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9412 Make_Integer_Literal (Loc, 0));
9413 end Make_Non_Empty_Check;
9415 -------------------------
9416 -- Make_Predicate_Call --
9417 -------------------------
9419 -- WARNING: This routine manages Ghost regions. Return statements must be
9420 -- replaced by gotos which jump to the end of the routine and restore the
9423 function Make_Predicate_Call
9426 Mem : Boolean := False) return Node_Id
9428 Loc : constant Source_Ptr := Sloc (Expr);
9430 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9431 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9432 -- Save the Ghost-related attributes to restore on exit
9435 Func_Id : Entity_Id;
9438 Func_Id := Predicate_Function (Typ);
9439 pragma Assert (Present (Func_Id));
9441 -- The related type may be subject to pragma Ghost. Set the mode now to
9442 -- ensure that the call is properly marked as Ghost.
9444 Set_Ghost_Mode (Typ);
9446 -- Call special membership version if requested and available
9448 if Mem and then Present (Predicate_Function_M (Typ)) then
9449 Func_Id := Predicate_Function_M (Typ);
9452 -- Case of calling normal predicate function
9454 -- If the type is tagged, the expression may be class-wide, in which
9455 -- case it has to be converted to its root type, given that the
9456 -- generated predicate function is not dispatching. The conversion is
9457 -- type-safe and does not need validation, which matters when private
9458 -- extensions are involved.
9460 if Is_Tagged_Type (Typ) then
9462 Make_Function_Call (Loc,
9463 Name => New_Occurrence_Of (Func_Id, Loc),
9464 Parameter_Associations =>
9465 New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
9468 Make_Function_Call (Loc,
9469 Name => New_Occurrence_Of (Func_Id, Loc),
9470 Parameter_Associations => New_List (Relocate_Node (Expr)));
9473 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9476 end Make_Predicate_Call;
9478 --------------------------
9479 -- Make_Predicate_Check --
9480 --------------------------
9482 function Make_Predicate_Check
9484 Expr : Node_Id) return Node_Id
9486 Loc : constant Source_Ptr := Sloc (Expr);
9488 procedure Add_Failure_Expression (Args : List_Id);
9489 -- Add the failure expression of pragma Predicate_Failure (if any) to
9492 ----------------------------
9493 -- Add_Failure_Expression --
9494 ----------------------------
9496 procedure Add_Failure_Expression (Args : List_Id) is
9497 function Failure_Expression return Node_Id;
9498 pragma Inline (Failure_Expression);
9499 -- Find aspect or pragma Predicate_Failure that applies to type Typ
9500 -- and return its expression. Return Empty if no such annotation is
9503 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
9504 pragma Inline (Is_OK_PF_Aspect);
9505 -- Determine whether aspect Asp is a suitable Predicate_Failure
9506 -- aspect that applies to type Typ.
9508 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
9509 pragma Inline (Is_OK_PF_Pragma);
9510 -- Determine whether pragma Prag is a suitable Predicate_Failure
9511 -- pragma that applies to type Typ.
9513 procedure Replace_Subtype_Reference (N : Node_Id);
9514 -- Replace the current instance of type Typ denoted by N with
9517 ------------------------
9518 -- Failure_Expression --
9519 ------------------------
9521 function Failure_Expression return Node_Id is
9525 -- The management of the rep item chain involves "inheritance" of
9526 -- parent type chains. If a parent [sub]type is already subject to
9527 -- pragma Predicate_Failure, then the pragma will also appear in
9528 -- the chain of the child [sub]type, which in turn may possess a
9529 -- pragma of its own. Avoid order-dependent issues by inspecting
9530 -- the rep item chain directly. Note that routine Get_Pragma may
9531 -- return a parent pragma.
9533 Item := First_Rep_Item (Typ);
9534 while Present (Item) loop
9536 -- Predicate_Failure appears as an aspect
9538 if Nkind (Item) = N_Aspect_Specification
9539 and then Is_OK_PF_Aspect (Item)
9541 return Expression (Item);
9543 -- Predicate_Failure appears as a pragma
9545 elsif Nkind (Item) = N_Pragma
9546 and then Is_OK_PF_Pragma (Item)
9550 (Next (First (Pragma_Argument_Associations (Item))));
9553 Next_Rep_Item (Item);
9557 end Failure_Expression;
9559 ---------------------
9560 -- Is_OK_PF_Aspect --
9561 ---------------------
9563 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
9565 -- To qualify, the aspect must apply to the type subjected to the
9569 Chars (Identifier (Asp)) = Name_Predicate_Failure
9570 and then Present (Entity (Asp))
9571 and then Entity (Asp) = Typ;
9572 end Is_OK_PF_Aspect;
9574 ---------------------
9575 -- Is_OK_PF_Pragma --
9576 ---------------------
9578 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
9579 Args : constant List_Id := Pragma_Argument_Associations (Prag);
9583 -- Nothing to do when the pragma does not denote Predicate_Failure
9585 if Pragma_Name (Prag) /= Name_Predicate_Failure then
9588 -- Nothing to do when the pragma lacks arguments, in which case it
9591 elsif No (Args) or else Is_Empty_List (Args) then
9595 Typ_Arg := Get_Pragma_Arg (First (Args));
9597 -- To qualify, the local name argument of the pragma must denote
9598 -- the type subjected to the predicate check.
9601 Is_Entity_Name (Typ_Arg)
9602 and then Present (Entity (Typ_Arg))
9603 and then Entity (Typ_Arg) = Typ;
9604 end Is_OK_PF_Pragma;
9606 --------------------------------
9607 -- Replace_Subtype_Reference --
9608 --------------------------------
9610 procedure Replace_Subtype_Reference (N : Node_Id) is
9612 Rewrite (N, New_Copy_Tree (Expr));
9613 end Replace_Subtype_Reference;
9615 procedure Replace_Subtype_References is
9616 new Replace_Type_References_Generic (Replace_Subtype_Reference);
9620 PF_Expr : constant Node_Id := Failure_Expression;
9623 -- Start of processing for Add_Failure_Expression
9626 if Present (PF_Expr) then
9628 -- Replace any occurrences of the current instance of the type
9629 -- with the object subjected to the predicate check.
9631 Expr := New_Copy_Tree (PF_Expr);
9632 Replace_Subtype_References (Expr, Typ);
9634 -- The failure expression appears as the third argument of the
9638 Make_Pragma_Argument_Association (Loc,
9639 Expression => Expr));
9641 end Add_Failure_Expression;
9648 -- Start of processing for Make_Predicate_Check
9651 -- If predicate checks are suppressed, then return a null statement. For
9652 -- this call, we check only the scope setting. If the caller wants to
9653 -- check a specific entity's setting, they must do it manually.
9655 if Predicate_Checks_Suppressed (Empty) then
9656 return Make_Null_Statement (Loc);
9659 -- Do not generate a check within stream functions and the like.
9661 if not Predicate_Check_In_Scope (Expr) 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;
9898 -----------------------------
9899 -- Make_Variant_Comparison --
9900 -----------------------------
9902 function Make_Variant_Comparison
9906 Old_Val : Node_Id) return Node_Id
9909 if Mode = Name_Increases then
9910 return Make_Op_Gt (Loc, Curr_Val, Old_Val);
9911 else pragma Assert (Mode = Name_Decreases);
9912 return Make_Op_Lt (Loc, Curr_Val, Old_Val);
9914 end Make_Variant_Comparison;
9920 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
9922 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
9923 -- avoid deep indentation of code.
9925 -- NOTE: Routines which deal with discriminant mapping operate on the
9926 -- [underlying/record] full view of various types because those views
9927 -- contain all discriminants and stored constraints.
9929 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
9930 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
9931 -- overriding chain starting from Prim whose dispatching type is parent
9932 -- type Par_Typ and add a mapping between the result and primitive Prim.
9934 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
9935 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
9936 -- the inheritance or overriding chain of subprogram Subp. Return Empty
9937 -- if no such primitive is available.
9939 function Build_Chain
9940 (Par_Typ : Entity_Id;
9941 Deriv_Typ : Entity_Id) return Elist_Id;
9942 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
9943 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
9944 -- list has the form:
9948 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
9950 -- Note that Par_Typ is not part of the resulting derivation chain
9952 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
9953 -- Return the view of type Typ which could potentially contains either
9954 -- the discriminants or stored constraints of the type.
9956 function Find_Discriminant_Value
9958 Par_Typ : Entity_Id;
9959 Deriv_Typ : Entity_Id;
9960 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
9961 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
9962 -- in the derivation chain starting from parent type Par_Typ leading to
9963 -- derived type Deriv_Typ. The returned value is one of the following:
9965 -- * An entity which is either a discriminant or a nondiscriminant
9966 -- name, and renames/constraints Discr.
9968 -- * An expression which constraints Discr
9970 -- Typ_Elmt is an element of the derivation chain created by routine
9971 -- Build_Chain and denotes the current ancestor being examined.
9973 procedure Map_Discriminants
9974 (Par_Typ : Entity_Id;
9975 Deriv_Typ : Entity_Id);
9976 -- Map each discriminant of type Par_Typ to a meaningful constraint
9977 -- from the point of view of type Deriv_Typ.
9979 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
9980 -- Map each primitive of type Par_Typ to a corresponding primitive of
9987 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
9988 Par_Prim : Entity_Id;
9991 -- Inspect the inheritance chain through the Alias attribute and the
9992 -- overriding chain through the Overridden_Operation looking for an
9993 -- ancestor primitive with the appropriate dispatching type.
9996 while Present (Par_Prim) loop
9997 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
9998 Par_Prim := Ancestor_Primitive (Par_Prim);
10001 -- Create a mapping of the form:
10003 -- parent type primitive -> derived type primitive
10005 if Present (Par_Prim) then
10006 Type_Map.Set (Par_Prim, Prim);
10010 ------------------------
10011 -- Ancestor_Primitive --
10012 ------------------------
10014 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
10015 Inher_Prim : constant Entity_Id := Alias (Subp);
10016 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
10019 -- The current subprogram overrides an ancestor primitive
10021 if Present (Over_Prim) then
10024 -- The current subprogram is an internally generated alias of an
10025 -- inherited ancestor primitive.
10027 elsif Present (Inher_Prim) then
10030 -- Otherwise the current subprogram is the root of the inheritance or
10031 -- overriding chain.
10036 end Ancestor_Primitive;
10042 function Build_Chain
10043 (Par_Typ : Entity_Id;
10044 Deriv_Typ : Entity_Id) return Elist_Id
10046 Anc_Typ : Entity_Id;
10048 Curr_Typ : Entity_Id;
10051 Chain := New_Elmt_List;
10053 -- Add the derived type to the derivation chain
10055 Prepend_Elmt (Deriv_Typ, Chain);
10057 -- Examine all ancestors starting from the derived type climbing
10058 -- towards parent type Par_Typ.
10060 Curr_Typ := Deriv_Typ;
10062 -- Handle the case where the current type is a record which
10063 -- derives from a subtype.
10065 -- subtype Sub_Typ is Par_Typ ...
10066 -- type Deriv_Typ is Sub_Typ ...
10068 if Ekind (Curr_Typ) = E_Record_Type
10069 and then Present (Parent_Subtype (Curr_Typ))
10071 Anc_Typ := Parent_Subtype (Curr_Typ);
10073 -- Handle the case where the current type is a record subtype of
10074 -- another subtype.
10076 -- subtype Sub_Typ1 is Par_Typ ...
10077 -- subtype Sub_Typ2 is Sub_Typ1 ...
10079 elsif Ekind (Curr_Typ) = E_Record_Subtype
10080 and then Present (Cloned_Subtype (Curr_Typ))
10082 Anc_Typ := Cloned_Subtype (Curr_Typ);
10084 -- Otherwise use the direct parent type
10087 Anc_Typ := Etype (Curr_Typ);
10090 -- Use the first subtype when dealing with itypes
10092 if Is_Itype (Anc_Typ) then
10093 Anc_Typ := First_Subtype (Anc_Typ);
10096 -- Work with the view which contains the discriminants and stored
10099 Anc_Typ := Discriminated_View (Anc_Typ);
10101 -- Stop the climb when either the parent type has been reached or
10102 -- there are no more ancestors left to examine.
10104 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
10106 Prepend_Unique_Elmt (Anc_Typ, Chain);
10107 Curr_Typ := Anc_Typ;
10113 ------------------------
10114 -- Discriminated_View --
10115 ------------------------
10117 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
10123 -- Use the [underlying] full view when dealing with private types
10124 -- because the view contains all inherited discriminants or stored
10127 if Is_Private_Type (T) then
10128 if Present (Underlying_Full_View (T)) then
10129 T := Underlying_Full_View (T);
10131 elsif Present (Full_View (T)) then
10132 T := Full_View (T);
10136 -- Use the underlying record view when the type is an extenstion of
10137 -- a parent type with unknown discriminants because the view contains
10138 -- all inherited discriminants or stored constraints.
10140 if Ekind (T) = E_Record_Type
10141 and then Present (Underlying_Record_View (T))
10143 T := Underlying_Record_View (T);
10147 end Discriminated_View;
10149 -----------------------------
10150 -- Find_Discriminant_Value --
10151 -----------------------------
10153 function Find_Discriminant_Value
10154 (Discr : Entity_Id;
10155 Par_Typ : Entity_Id;
10156 Deriv_Typ : Entity_Id;
10157 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
10159 Discr_Pos : constant Uint := Discriminant_Number (Discr);
10160 Typ : constant Entity_Id := Node (Typ_Elmt);
10162 function Find_Constraint_Value
10163 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
10164 -- Given constraint Constr, find what it denotes. This is either:
10166 -- * An entity which is either a discriminant or a name
10170 ---------------------------
10171 -- Find_Constraint_Value --
10172 ---------------------------
10174 function Find_Constraint_Value
10175 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
10178 if Nkind (Constr) in N_Entity then
10180 -- The constraint denotes a discriminant of the curren type
10181 -- which renames the ancestor discriminant:
10184 -- type Typ (D1 : ...; DN : ...) is
10185 -- new Anc (Discr => D1) with ...
10188 if Ekind (Constr) = E_Discriminant then
10190 -- The discriminant belongs to derived type Deriv_Typ. This
10191 -- is the final value for the ancestor discriminant as the
10192 -- derivations chain has been fully exhausted.
10194 if Typ = Deriv_Typ then
10197 -- Otherwise the discriminant may be renamed or constrained
10198 -- at a lower level. Continue looking down the derivation
10203 Find_Discriminant_Value
10205 Par_Typ => Par_Typ,
10206 Deriv_Typ => Deriv_Typ,
10207 Typ_Elmt => Next_Elmt (Typ_Elmt));
10210 -- Otherwise the constraint denotes a reference to some name
10211 -- which results in a Girder discriminant:
10215 -- type Typ (D1 : ...; DN : ...) is
10216 -- new Anc (Discr => Name) with ...
10219 -- Return the name as this is the proper constraint of the
10226 -- The constraint denotes a reference to a name
10228 elsif Is_Entity_Name (Constr) then
10229 return Find_Constraint_Value (Entity (Constr));
10231 -- Otherwise the current constraint is an expression which yields
10232 -- a Girder discriminant:
10234 -- type Typ (D1 : ...; DN : ...) is
10235 -- new Anc (Discr => <expression>) with ...
10238 -- Return the expression as this is the proper constraint of the
10244 end Find_Constraint_Value;
10248 Constrs : constant Elist_Id := Stored_Constraint (Typ);
10250 Constr_Elmt : Elmt_Id;
10252 Typ_Discr : Entity_Id;
10254 -- Start of processing for Find_Discriminant_Value
10257 -- The algorithm for finding the value of a discriminant works as
10258 -- follows. First, it recreates the derivation chain from Par_Typ
10259 -- to Deriv_Typ as a list:
10261 -- Par_Typ (shown for completeness)
10263 -- Ancestor_N <-- head of chain
10267 -- Deriv_Typ <-- tail of chain
10269 -- The algorithm then traces the fate of a parent discriminant down
10270 -- the derivation chain. At each derivation level, the discriminant
10271 -- may be either inherited or constrained.
10273 -- 1) Discriminant is inherited: there are two cases, depending on
10274 -- which type is inheriting.
10276 -- 1.1) Deriv_Typ is inheriting:
10278 -- type Ancestor (D_1 : ...) is tagged ...
10279 -- type Deriv_Typ is new Ancestor ...
10281 -- In this case the inherited discriminant is the final value of
10282 -- the parent discriminant because the end of the derivation chain
10283 -- has been reached.
10285 -- 1.2) Some other type is inheriting:
10287 -- type Ancestor_1 (D_1 : ...) is tagged ...
10288 -- type Ancestor_2 is new Ancestor_1 ...
10290 -- In this case the algorithm continues to trace the fate of the
10291 -- inherited discriminant down the derivation chain because it may
10292 -- be further inherited or constrained.
10294 -- 2) Discriminant is constrained: there are three cases, depending
10295 -- on what the constraint is.
10297 -- 2.1) The constraint is another discriminant (aka renaming):
10299 -- type Ancestor_1 (D_1 : ...) is tagged ...
10300 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
10302 -- In this case the constraining discriminant becomes the one to
10303 -- track down the derivation chain. The algorithm already knows
10304 -- that D_2 constrains D_1, therefore if the algorithm finds the
10305 -- value of D_2, then this would also be the value for D_1.
10307 -- 2.2) The constraint is a name (aka Girder):
10310 -- type Ancestor_1 (D_1 : ...) is tagged ...
10311 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
10313 -- In this case the name is the final value of D_1 because the
10314 -- discriminant cannot be further constrained.
10316 -- 2.3) The constraint is an expression (aka Girder):
10318 -- type Ancestor_1 (D_1 : ...) is tagged ...
10319 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10321 -- Similar to 2.2, the expression is the final value of D_1
10325 -- When a derived type constrains its parent type, all constaints
10326 -- appear in the Stored_Constraint list. Examine the list looking
10327 -- for a positional match.
10329 if Present (Constrs) then
10330 Constr_Elmt := First_Elmt (Constrs);
10331 while Present (Constr_Elmt) loop
10333 -- The position of the current constraint matches that of the
10334 -- ancestor discriminant.
10336 if Pos = Discr_Pos then
10337 return Find_Constraint_Value (Node (Constr_Elmt));
10340 Next_Elmt (Constr_Elmt);
10344 -- Otherwise the derived type does not constraint its parent type in
10345 -- which case it inherits the parent discriminants.
10348 Typ_Discr := First_Discriminant (Typ);
10349 while Present (Typ_Discr) loop
10351 -- The position of the current discriminant matches that of the
10352 -- ancestor discriminant.
10354 if Pos = Discr_Pos then
10355 return Find_Constraint_Value (Typ_Discr);
10358 Next_Discriminant (Typ_Discr);
10363 -- A discriminant must always have a corresponding value. This is
10364 -- either another discriminant, a name, or an expression. If this
10365 -- point is reached, them most likely the derivation chain employs
10366 -- the wrong views of types.
10368 pragma Assert (False);
10371 end Find_Discriminant_Value;
10373 -----------------------
10374 -- Map_Discriminants --
10375 -----------------------
10377 procedure Map_Discriminants
10378 (Par_Typ : Entity_Id;
10379 Deriv_Typ : Entity_Id)
10381 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10384 Discr_Val : Node_Or_Entity_Id;
10387 -- Examine each discriminant of parent type Par_Typ and find a
10388 -- suitable value for it from the point of view of derived type
10391 if Has_Discriminants (Par_Typ) then
10392 Discr := First_Discriminant (Par_Typ);
10393 while Present (Discr) loop
10395 Find_Discriminant_Value
10397 Par_Typ => Par_Typ,
10398 Deriv_Typ => Deriv_Typ,
10399 Typ_Elmt => First_Elmt (Deriv_Chain));
10401 -- Create a mapping of the form:
10403 -- parent type discriminant -> value
10405 Type_Map.Set (Discr, Discr_Val);
10407 Next_Discriminant (Discr);
10410 end Map_Discriminants;
10412 --------------------
10413 -- Map_Primitives --
10414 --------------------
10416 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
10417 Deriv_Prim : Entity_Id;
10418 Par_Prim : Entity_Id;
10419 Par_Prims : Elist_Id;
10420 Prim_Elmt : Elmt_Id;
10423 -- Inspect the primitives of the derived type and determine whether
10424 -- they relate to the primitives of the parent type. If there is a
10425 -- meaningful relation, create a mapping of the form:
10427 -- parent type primitive -> perived type primitive
10429 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
10430 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
10431 while Present (Prim_Elmt) loop
10432 Deriv_Prim := Node (Prim_Elmt);
10434 if Is_Subprogram (Deriv_Prim)
10435 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
10437 Add_Primitive (Deriv_Prim, Par_Typ);
10440 Next_Elmt (Prim_Elmt);
10444 -- If the parent operation is an interface operation, the overriding
10445 -- indicator is not present. Instead, we get from the interface
10446 -- operation the primitive of the current type that implements it.
10448 if Is_Interface (Par_Typ) then
10449 Par_Prims := Collect_Primitive_Operations (Par_Typ);
10451 if Present (Par_Prims) then
10452 Prim_Elmt := First_Elmt (Par_Prims);
10454 while Present (Prim_Elmt) loop
10455 Par_Prim := Node (Prim_Elmt);
10457 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
10459 if Present (Deriv_Prim) then
10460 Type_Map.Set (Par_Prim, Deriv_Prim);
10463 Next_Elmt (Prim_Elmt);
10467 end Map_Primitives;
10469 -- Start of processing for Map_Types
10472 -- Nothing to do if there are no types to work with
10474 if No (Parent_Type) or else No (Derived_Type) then
10477 -- Nothing to do if the mapping already exists
10479 elsif Type_Map.Get (Parent_Type) = Derived_Type then
10482 -- Nothing to do if both types are not tagged. Note that untagged types
10483 -- do not have primitive operations and their discriminants are already
10484 -- handled by gigi.
10486 elsif not Is_Tagged_Type (Parent_Type)
10487 or else not Is_Tagged_Type (Derived_Type)
10492 -- Create a mapping of the form
10494 -- parent type -> derived type
10496 -- to prevent any subsequent attempts to produce the same relations
10498 Type_Map.Set (Parent_Type, Derived_Type);
10500 -- Create mappings of the form
10502 -- parent type discriminant -> derived type discriminant
10504 -- parent type discriminant -> constraint
10506 -- Note that mapping of discriminants breaks privacy because it needs to
10507 -- work with those views which contains the discriminants and any stored
10511 (Par_Typ => Discriminated_View (Parent_Type),
10512 Deriv_Typ => Discriminated_View (Derived_Type));
10514 -- Create mappings of the form
10516 -- parent type primitive -> derived type primitive
10519 (Par_Typ => Parent_Type,
10520 Deriv_Typ => Derived_Type);
10523 ----------------------------
10524 -- Matching_Standard_Type --
10525 ----------------------------
10527 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
10528 pragma Assert (Is_Scalar_Type (Typ));
10529 Siz : constant Uint := Esize (Typ);
10532 -- Floating-point cases
10534 if Is_Floating_Point_Type (Typ) then
10535 if Siz <= Esize (Standard_Short_Float) then
10536 return Standard_Short_Float;
10537 elsif Siz <= Esize (Standard_Float) then
10538 return Standard_Float;
10539 elsif Siz <= Esize (Standard_Long_Float) then
10540 return Standard_Long_Float;
10541 elsif Siz <= Esize (Standard_Long_Long_Float) then
10542 return Standard_Long_Long_Float;
10544 raise Program_Error;
10547 -- Integer cases (includes fixed-point types)
10549 -- Unsigned integer cases (includes normal enumeration types)
10552 return Small_Integer_Type_For (Siz, Is_Unsigned_Type (Typ));
10554 end Matching_Standard_Type;
10556 -----------------------------
10557 -- May_Generate_Large_Temp --
10558 -----------------------------
10560 -- At the current time, the only types that we return False for (i.e. where
10561 -- we decide we know they cannot generate large temps) are ones where we
10562 -- know the size is 256 bits or less at compile time, and we are still not
10563 -- doing a thorough job on arrays and records ???
10565 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
10567 if not Size_Known_At_Compile_Time (Typ) then
10570 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
10573 elsif Is_Array_Type (Typ)
10574 and then Present (Packed_Array_Impl_Type (Typ))
10576 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
10578 -- We could do more here to find other small types ???
10583 end May_Generate_Large_Temp;
10585 --------------------------------------------
10586 -- Needs_Conditional_Null_Excluding_Check --
10587 --------------------------------------------
10589 function Needs_Conditional_Null_Excluding_Check
10590 (Typ : Entity_Id) return Boolean
10594 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
10595 end Needs_Conditional_Null_Excluding_Check;
10597 ----------------------------
10598 -- Needs_Constant_Address --
10599 ----------------------------
10601 function Needs_Constant_Address
10603 Typ : Entity_Id) return Boolean
10606 -- If we have no initialization of any kind, then we don't need to place
10607 -- any restrictions on the address clause, because the object will be
10608 -- elaborated after the address clause is evaluated. This happens if the
10609 -- declaration has no initial expression, or the type has no implicit
10610 -- initialization, or the object is imported.
10612 -- The same holds for all initialized scalar types and all access types.
10613 -- Packed bit array types of size up to the maximum integer size are
10614 -- represented using a modular type with an initialization (to zero) and
10615 -- can be processed like other initialized scalar types.
10617 -- If the type is controlled, code to attach the object to a
10618 -- finalization chain is generated at the point of declaration, and
10619 -- therefore the elaboration of the object cannot be delayed: the
10620 -- address expression must be a constant.
10622 if No (Expression (Decl))
10623 and then not Needs_Finalization (Typ)
10625 (not Has_Non_Null_Base_Init_Proc (Typ)
10626 or else Is_Imported (Defining_Identifier (Decl)))
10630 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
10631 or else Is_Access_Type (Typ)
10633 (Is_Bit_Packed_Array (Typ)
10634 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
10639 -- Otherwise, we require the address clause to be constant because
10640 -- the call to the initialization procedure (or the attach code) has
10641 -- to happen at the point of the declaration.
10643 -- Actually the IP call has been moved to the freeze actions anyway,
10644 -- so maybe we can relax this restriction???
10648 end Needs_Constant_Address;
10650 ----------------------------
10651 -- New_Class_Wide_Subtype --
10652 ----------------------------
10654 function New_Class_Wide_Subtype
10655 (CW_Typ : Entity_Id;
10656 N : Node_Id) return Entity_Id
10658 Res : constant Entity_Id := Create_Itype (E_Void, N);
10660 -- Capture relevant attributes of the class-wide subtype which must be
10661 -- restored after the copy.
10663 Res_Chars : constant Name_Id := Chars (Res);
10664 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
10665 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
10666 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
10667 Res_Scope : constant Entity_Id := Scope (Res);
10670 Copy_Node (CW_Typ, Res);
10672 -- Restore the relevant attributes of the class-wide subtype
10674 Set_Chars (Res, Res_Chars);
10675 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
10676 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
10677 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
10678 Set_Scope (Res, Res_Scope);
10680 -- Decorate the class-wide subtype
10682 Set_Associated_Node_For_Itype (Res, N);
10683 Set_Comes_From_Source (Res, False);
10684 Set_Ekind (Res, E_Class_Wide_Subtype);
10685 Set_Etype (Res, Base_Type (CW_Typ));
10686 Set_Freeze_Node (Res, Empty);
10687 Set_Is_Frozen (Res, False);
10688 Set_Is_Itype (Res);
10689 Set_Is_Public (Res, False);
10690 Set_Next_Entity (Res, Empty);
10691 Set_Prev_Entity (Res, Empty);
10692 Set_Sloc (Res, Sloc (N));
10694 Set_Public_Status (Res);
10697 end New_Class_Wide_Subtype;
10699 --------------------------------
10700 -- Non_Limited_Designated_Type --
10701 ---------------------------------
10703 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
10704 Desig : constant Entity_Id := Designated_Type (T);
10706 if Has_Non_Limited_View (Desig) then
10707 return Non_Limited_View (Desig);
10711 end Non_Limited_Designated_Type;
10713 -----------------------------------
10714 -- OK_To_Do_Constant_Replacement --
10715 -----------------------------------
10717 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
10718 ES : constant Entity_Id := Scope (E);
10722 -- Do not replace statically allocated objects, because they may be
10723 -- modified outside the current scope.
10725 if Is_Statically_Allocated (E) then
10728 -- Do not replace aliased or volatile objects, since we don't know what
10729 -- else might change the value.
10731 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
10734 -- Debug flag -gnatdM disconnects this optimization
10736 elsif Debug_Flag_MM then
10739 -- Otherwise check scopes
10742 CS := Current_Scope;
10745 -- If we are in right scope, replacement is safe
10750 -- Packages do not affect the determination of safety
10752 elsif Ekind (CS) = E_Package then
10753 exit when CS = Standard_Standard;
10756 -- Blocks do not affect the determination of safety
10758 elsif Ekind (CS) = E_Block then
10761 -- Loops do not affect the determination of safety. Note that we
10762 -- kill all current values on entry to a loop, so we are just
10763 -- talking about processing within a loop here.
10765 elsif Ekind (CS) = E_Loop then
10768 -- Otherwise, the reference is dubious, and we cannot be sure that
10769 -- it is safe to do the replacement.
10778 end OK_To_Do_Constant_Replacement;
10780 ------------------------------------
10781 -- Possible_Bit_Aligned_Component --
10782 ------------------------------------
10784 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
10786 -- Do not process an unanalyzed node because it is not yet decorated and
10787 -- most checks performed below will fail.
10789 if not Analyzed (N) then
10793 -- There are never alignment issues in CodePeer mode
10795 if CodePeer_Mode then
10801 -- Case of indexed component
10803 when N_Indexed_Component =>
10805 P : constant Node_Id := Prefix (N);
10806 Ptyp : constant Entity_Id := Etype (P);
10809 -- If we know the component size and it is not larger than the
10810 -- maximum integer size, then we are OK. The back end does the
10811 -- assignment of small misaligned objects correctly.
10813 if Known_Static_Component_Size (Ptyp)
10814 and then Component_Size (Ptyp) <= System_Max_Integer_Size
10818 -- Otherwise, we need to test the prefix, to see if we are
10819 -- indexing from a possibly unaligned component.
10822 return Possible_Bit_Aligned_Component (P);
10826 -- Case of selected component
10828 when N_Selected_Component =>
10830 P : constant Node_Id := Prefix (N);
10831 Comp : constant Entity_Id := Entity (Selector_Name (N));
10834 -- This is the crucial test: if the component itself causes
10835 -- trouble, then we can stop and return True.
10837 if Component_May_Be_Bit_Aligned (Comp) then
10840 -- Otherwise, we need to test the prefix, to see if we are
10841 -- selecting from a possibly unaligned component.
10844 return Possible_Bit_Aligned_Component (P);
10848 -- For a slice, test the prefix, if that is possibly misaligned,
10849 -- then for sure the slice is.
10852 return Possible_Bit_Aligned_Component (Prefix (N));
10854 -- For an unchecked conversion, check whether the expression may
10857 when N_Unchecked_Type_Conversion =>
10858 return Possible_Bit_Aligned_Component (Expression (N));
10860 -- If we have none of the above, it means that we have fallen off the
10861 -- top testing prefixes recursively, and we now have a stand alone
10862 -- object, where we don't have a problem, unless this is a renaming,
10863 -- in which case we need to look into the renamed object.
10866 if Is_Entity_Name (N)
10867 and then Present (Renamed_Object (Entity (N)))
10870 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
10875 end Possible_Bit_Aligned_Component;
10877 -----------------------------------------------
10878 -- Process_Statements_For_Controlled_Objects --
10879 -----------------------------------------------
10881 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
10882 Loc : constant Source_Ptr := Sloc (N);
10884 function Are_Wrapped (L : List_Id) return Boolean;
10885 -- Determine whether list L contains only one statement which is a block
10887 function Wrap_Statements_In_Block
10889 Scop : Entity_Id := Current_Scope) return Node_Id;
10890 -- Given a list of statements L, wrap it in a block statement and return
10891 -- the generated node. Scop is either the current scope or the scope of
10892 -- the context (if applicable).
10898 function Are_Wrapped (L : List_Id) return Boolean is
10899 Stmt : constant Node_Id := First (L);
10903 and then No (Next (Stmt))
10904 and then Nkind (Stmt) = N_Block_Statement;
10907 ------------------------------
10908 -- Wrap_Statements_In_Block --
10909 ------------------------------
10911 function Wrap_Statements_In_Block
10913 Scop : Entity_Id := Current_Scope) return Node_Id
10915 Block_Id : Entity_Id;
10916 Block_Nod : Node_Id;
10917 Iter_Loop : Entity_Id;
10921 Make_Block_Statement (Loc,
10922 Declarations => No_List,
10923 Handled_Statement_Sequence =>
10924 Make_Handled_Sequence_Of_Statements (Loc,
10927 -- Create a label for the block in case the block needs to manage the
10928 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
10930 Add_Block_Identifier (Block_Nod, Block_Id);
10932 -- When wrapping the statements of an iterator loop, check whether
10933 -- the loop requires secondary stack management and if so, propagate
10934 -- the appropriate flags to the block. This ensures that the cursor
10935 -- is properly cleaned up at each iteration of the loop.
10937 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
10939 if Present (Iter_Loop) then
10940 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
10942 -- Secondary stack reclamation is suppressed when the associated
10943 -- iterator loop contains a return statement which uses the stack.
10945 Set_Sec_Stack_Needed_For_Return
10946 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
10950 end Wrap_Statements_In_Block;
10956 -- Start of processing for Process_Statements_For_Controlled_Objects
10959 -- Whenever a non-handled statement list is wrapped in a block, the
10960 -- block must be explicitly analyzed to redecorate all entities in the
10961 -- list and ensure that a finalizer is properly built.
10964 when N_Conditional_Entry_Call
10967 | N_Selective_Accept
10969 -- Check the "then statements" for elsif parts and if statements
10971 if Nkind (N) in N_Elsif_Part | N_If_Statement
10972 and then not Is_Empty_List (Then_Statements (N))
10973 and then not Are_Wrapped (Then_Statements (N))
10974 and then Requires_Cleanup_Actions
10975 (L => Then_Statements (N),
10976 Lib_Level => False,
10977 Nested_Constructs => False)
10979 Block := Wrap_Statements_In_Block (Then_Statements (N));
10980 Set_Then_Statements (N, New_List (Block));
10985 -- Check the "else statements" for conditional entry calls, if
10986 -- statements and selective accepts.
10989 N_Conditional_Entry_Call | N_If_Statement | N_Selective_Accept
10990 and then not Is_Empty_List (Else_Statements (N))
10991 and then not Are_Wrapped (Else_Statements (N))
10992 and then Requires_Cleanup_Actions
10993 (L => Else_Statements (N),
10994 Lib_Level => False,
10995 Nested_Constructs => False)
10997 Block := Wrap_Statements_In_Block (Else_Statements (N));
10998 Set_Else_Statements (N, New_List (Block));
11003 when N_Abortable_Part
11004 | N_Accept_Alternative
11005 | N_Case_Statement_Alternative
11006 | N_Delay_Alternative
11007 | N_Entry_Call_Alternative
11008 | N_Exception_Handler
11010 | N_Triggering_Alternative
11012 if not Is_Empty_List (Statements (N))
11013 and then not Are_Wrapped (Statements (N))
11014 and then Requires_Cleanup_Actions
11015 (L => Statements (N),
11016 Lib_Level => False,
11017 Nested_Constructs => False)
11019 if Nkind (N) = N_Loop_Statement
11020 and then Present (Identifier (N))
11023 Wrap_Statements_In_Block
11024 (L => Statements (N),
11025 Scop => Entity (Identifier (N)));
11027 Block := Wrap_Statements_In_Block (Statements (N));
11030 Set_Statements (N, New_List (Block));
11034 -- Could be e.g. a loop that was transformed into a block or null
11035 -- statement. Do nothing for terminate alternatives.
11037 when N_Block_Statement
11039 | N_Terminate_Alternative
11044 raise Program_Error;
11046 end Process_Statements_For_Controlled_Objects;
11052 function Power_Of_Two (N : Node_Id) return Nat is
11053 Typ : constant Entity_Id := Etype (N);
11054 pragma Assert (Is_Integer_Type (Typ));
11056 Siz : constant Nat := UI_To_Int (Esize (Typ));
11060 if not Compile_Time_Known_Value (N) then
11064 Val := Expr_Value (N);
11065 for J in 1 .. Siz - 1 loop
11066 if Val = Uint_2 ** J then
11075 ----------------------
11076 -- Remove_Init_Call --
11077 ----------------------
11079 function Remove_Init_Call
11081 Rep_Clause : Node_Id) return Node_Id
11083 Par : constant Node_Id := Parent (Var);
11084 Typ : constant Entity_Id := Etype (Var);
11086 Init_Proc : Entity_Id;
11087 -- Initialization procedure for Typ
11089 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
11090 -- Look for init call for Var starting at From and scanning the
11091 -- enclosing list until Rep_Clause or the end of the list is reached.
11093 ----------------------------
11094 -- Find_Init_Call_In_List --
11095 ----------------------------
11097 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
11098 Init_Call : Node_Id;
11102 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
11103 if Nkind (Init_Call) = N_Procedure_Call_Statement
11104 and then Is_Entity_Name (Name (Init_Call))
11105 and then Entity (Name (Init_Call)) = Init_Proc
11114 end Find_Init_Call_In_List;
11116 Init_Call : Node_Id;
11118 -- Start of processing for Find_Init_Call
11121 if Present (Initialization_Statements (Var)) then
11122 Init_Call := Initialization_Statements (Var);
11123 Set_Initialization_Statements (Var, Empty);
11125 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
11127 -- No init proc for the type, so obviously no call to be found
11132 -- We might be able to handle other cases below by just properly
11133 -- setting Initialization_Statements at the point where the init proc
11134 -- call is generated???
11136 Init_Proc := Base_Init_Proc (Typ);
11138 -- First scan the list containing the declaration of Var
11140 Init_Call := Find_Init_Call_In_List (From => Next (Par));
11142 -- If not found, also look on Var's freeze actions list, if any,
11143 -- since the init call may have been moved there (case of an address
11144 -- clause applying to Var).
11146 if No (Init_Call) and then Present (Freeze_Node (Var)) then
11148 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
11151 -- If the initialization call has actuals that use the secondary
11152 -- stack, the call may have been wrapped into a temporary block, in
11153 -- which case the block itself has to be removed.
11155 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
11157 Blk : constant Node_Id := Next (Par);
11160 (Find_Init_Call_In_List
11161 (First (Statements (Handled_Statement_Sequence (Blk)))))
11169 if Present (Init_Call) then
11170 Remove (Init_Call);
11173 end Remove_Init_Call;
11175 -------------------------
11176 -- Remove_Side_Effects --
11177 -------------------------
11179 procedure Remove_Side_Effects
11181 Name_Req : Boolean := False;
11182 Renaming_Req : Boolean := False;
11183 Variable_Ref : Boolean := False;
11184 Related_Id : Entity_Id := Empty;
11185 Is_Low_Bound : Boolean := False;
11186 Is_High_Bound : Boolean := False;
11187 Check_Side_Effects : Boolean := True)
11189 function Build_Temporary
11192 Related_Nod : Node_Id := Empty) return Entity_Id;
11193 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
11194 -- is present (xxx is taken from the Chars field of Related_Nod),
11195 -- otherwise it generates an internal temporary. The created temporary
11196 -- entity is marked as internal.
11198 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean;
11199 -- Computes whether a side effect is possible in SPARK, which should
11200 -- be handled by removing it from the expression for GNATprove. Note
11201 -- that other side effects related to volatile variables are handled
11204 ---------------------
11205 -- Build_Temporary --
11206 ---------------------
11208 function Build_Temporary
11211 Related_Nod : Node_Id := Empty) return Entity_Id
11213 Temp_Id : Entity_Id;
11214 Temp_Nam : Name_Id;
11217 -- The context requires an external symbol
11219 if Present (Related_Id) then
11220 if Is_Low_Bound then
11221 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
11222 else pragma Assert (Is_High_Bound);
11223 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
11226 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
11228 -- Otherwise generate an internal temporary
11231 Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
11234 Set_Is_Internal (Temp_Id);
11237 end Build_Temporary;
11239 -----------------------------------
11240 -- Possible_Side_Effect_In_SPARK --
11241 -----------------------------------
11243 function Possible_Side_Effect_In_SPARK (Exp : Node_Id) return Boolean is
11245 -- Side-effect removal in SPARK should only occur when not inside a
11246 -- generic and not doing a preanalysis, inside an object renaming or
11247 -- a type declaration or a for-loop iteration scheme.
11249 return not Inside_A_Generic
11250 and then Full_Analysis
11251 and then Nkind (Enclosing_Declaration (Exp)) in
11252 N_Full_Type_Declaration
11253 | N_Iterator_Specification
11254 | N_Loop_Parameter_Specification
11255 | N_Object_Renaming_Declaration
11256 | N_Subtype_Declaration;
11257 end Possible_Side_Effect_In_SPARK;
11261 Loc : constant Source_Ptr := Sloc (Exp);
11262 Exp_Type : constant Entity_Id := Etype (Exp);
11263 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
11264 Def_Id : Entity_Id;
11267 Ptr_Typ_Decl : Node_Id;
11268 Ref_Type : Entity_Id;
11271 -- Start of processing for Remove_Side_Effects
11274 -- Handle cases in which there is nothing to do. In GNATprove mode,
11275 -- removal of side effects is useful for the light expansion of
11278 if not Expander_Active
11280 (GNATprove_Mode and then Possible_Side_Effect_In_SPARK (Exp))
11284 -- Cannot generate temporaries if the invocation to remove side effects
11285 -- was issued too early and the type of the expression is not resolved
11286 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
11287 -- Remove_Side_Effects).
11289 elsif No (Exp_Type)
11290 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11294 -- Nothing to do if prior expansion determined that a function call does
11295 -- not require side effect removal.
11297 elsif Nkind (Exp) = N_Function_Call
11298 and then No_Side_Effect_Removal (Exp)
11302 -- No action needed for side-effect free expressions
11304 elsif Check_Side_Effects
11305 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11309 -- Generating C code we cannot remove side effect of function returning
11310 -- class-wide types since there is no secondary stack (required to use
11313 elsif Modify_Tree_For_C
11314 and then Nkind (Exp) = N_Function_Call
11315 and then Is_Class_Wide_Type (Etype (Exp))
11320 -- The remaining processing is done with all checks suppressed
11322 -- Note: from now on, don't use return statements, instead do a goto
11323 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11325 Scope_Suppress.Suppress := (others => True);
11327 -- If this is a side-effect free attribute reference whose expressions
11328 -- are also side-effect free and whose prefix is not a name, remove the
11329 -- side effects of the prefix. A copy of the prefix is required in this
11330 -- case and it is better not to make an additional one for the attribute
11331 -- itself, because the return type of many of them is universal integer,
11332 -- which is a very large type for a temporary.
11334 if Nkind (Exp) = N_Attribute_Reference
11335 and then Side_Effect_Free_Attribute (Attribute_Name (Exp))
11336 and then Side_Effect_Free (Expressions (Exp), Name_Req, Variable_Ref)
11337 and then not Is_Name_Reference (Prefix (Exp))
11339 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11342 -- If this is an elementary or a small not-by-reference record type, and
11343 -- we need to capture the value, just make a constant; this is cheap and
11344 -- objects of both kinds of types can be bit aligned, so it might not be
11345 -- possible to generate a reference to them. Likewise if this is not a
11346 -- name reference, except for a type conversion, because we would enter
11347 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11348 -- type has predicates (and type conversions need a specific treatment
11349 -- anyway, see below). Also do it if we have a volatile reference and
11350 -- Name_Req is not set (see comments for Side_Effect_Free).
11352 elsif (Is_Elementary_Type (Exp_Type)
11353 or else (Is_Record_Type (Exp_Type)
11354 and then Known_Static_RM_Size (Exp_Type)
11355 and then RM_Size (Exp_Type) <= System_Max_Integer_Size
11356 and then not Has_Discriminants (Exp_Type)
11357 and then not Is_By_Reference_Type (Exp_Type)))
11358 and then (Variable_Ref
11359 or else (not Is_Name_Reference (Exp)
11360 and then Nkind (Exp) /= N_Type_Conversion)
11361 or else (not Name_Req
11362 and then Is_Volatile_Reference (Exp)))
11364 Def_Id := Build_Temporary (Loc, 'R', Exp);
11365 Set_Etype (Def_Id, Exp_Type);
11366 Res := New_Occurrence_Of (Def_Id, Loc);
11368 -- If the expression is a packed reference, it must be reanalyzed and
11369 -- expanded, depending on context. This is the case for actuals where
11370 -- a constraint check may capture the actual before expansion of the
11371 -- call is complete.
11373 if Nkind (Exp) = N_Indexed_Component
11374 and then Is_Packed (Etype (Prefix (Exp)))
11376 Set_Analyzed (Exp, False);
11377 Set_Analyzed (Prefix (Exp), False);
11381 -- Rnn : Exp_Type renames Expr;
11383 -- In GNATprove mode, we prefer to use renamings for intermediate
11384 -- variables to definition of constants, due to the implicit move
11385 -- operation that such a constant definition causes as part of the
11386 -- support in GNATprove for ownership pointers. Hence, we generate
11387 -- a renaming for a reference to an object of a nonscalar type.
11390 or else (GNATprove_Mode
11391 and then Is_Object_Reference (Exp)
11392 and then not Is_Scalar_Type (Exp_Type))
11395 Make_Object_Renaming_Declaration (Loc,
11396 Defining_Identifier => Def_Id,
11397 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11398 Name => Relocate_Node (Exp));
11401 -- Rnn : constant Exp_Type := Expr;
11405 Make_Object_Declaration (Loc,
11406 Defining_Identifier => Def_Id,
11407 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11408 Constant_Present => True,
11409 Expression => Relocate_Node (Exp));
11411 Set_Assignment_OK (E);
11414 Insert_Action (Exp, E);
11416 -- If the expression has the form v.all then we can just capture the
11417 -- pointer, and then do an explicit dereference on the result, but
11418 -- this is not right if this is a volatile reference.
11420 elsif Nkind (Exp) = N_Explicit_Dereference
11421 and then not Is_Volatile_Reference (Exp)
11423 Def_Id := Build_Temporary (Loc, 'R', Exp);
11425 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
11427 Insert_Action (Exp,
11428 Make_Object_Declaration (Loc,
11429 Defining_Identifier => Def_Id,
11430 Object_Definition =>
11431 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
11432 Constant_Present => True,
11433 Expression => Relocate_Node (Prefix (Exp))));
11435 -- Similar processing for an unchecked conversion of an expression of
11436 -- the form v.all, where we want the same kind of treatment.
11438 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11439 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
11441 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11444 -- If this is a type conversion, leave the type conversion and remove
11445 -- side effects in the expression, unless it is of universal integer,
11446 -- which is a very large type for a temporary. This is important in
11447 -- several circumstances: for change of representations and also when
11448 -- this is a view conversion to a smaller object, where gigi can end
11449 -- up creating its own temporary of the wrong size.
11451 elsif Nkind (Exp) = N_Type_Conversion
11452 and then Etype (Expression (Exp)) /= Universal_Integer
11454 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11456 -- Generating C code the type conversion of an access to constrained
11457 -- array type into an access to unconstrained array type involves
11458 -- initializing a fat pointer and the expression must be free of
11459 -- side effects to safely compute its bounds.
11461 if Modify_Tree_For_C
11462 and then Is_Access_Type (Etype (Exp))
11463 and then Is_Array_Type (Designated_Type (Etype (Exp)))
11464 and then not Is_Constrained (Designated_Type (Etype (Exp)))
11466 Def_Id := Build_Temporary (Loc, 'R', Exp);
11467 Set_Etype (Def_Id, Exp_Type);
11468 Res := New_Occurrence_Of (Def_Id, Loc);
11470 Insert_Action (Exp,
11471 Make_Object_Declaration (Loc,
11472 Defining_Identifier => Def_Id,
11473 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11474 Constant_Present => True,
11475 Expression => Relocate_Node (Exp)));
11480 -- If this is an unchecked conversion that Gigi can't handle, make
11481 -- a copy or a use a renaming to capture the value.
11483 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11484 and then not Safe_Unchecked_Type_Conversion (Exp)
11486 if CW_Or_Has_Controlled_Part (Exp_Type) then
11488 -- Use a renaming to capture the expression, rather than create
11489 -- a controlled temporary.
11491 Def_Id := Build_Temporary (Loc, 'R', Exp);
11492 Res := New_Occurrence_Of (Def_Id, Loc);
11494 Insert_Action (Exp,
11495 Make_Object_Renaming_Declaration (Loc,
11496 Defining_Identifier => Def_Id,
11497 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11498 Name => Relocate_Node (Exp)));
11501 Def_Id := Build_Temporary (Loc, 'R', Exp);
11502 Set_Etype (Def_Id, Exp_Type);
11503 Res := New_Occurrence_Of (Def_Id, Loc);
11506 Make_Object_Declaration (Loc,
11507 Defining_Identifier => Def_Id,
11508 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11509 Constant_Present => not Is_Variable (Exp),
11510 Expression => Relocate_Node (Exp));
11512 Set_Assignment_OK (E);
11513 Insert_Action (Exp, E);
11516 -- If this is a packed array component or a selected component with a
11517 -- nonstandard representation, we cannot generate a reference because
11518 -- the component may be unaligned, so we must use a renaming and this
11519 -- renaming must be handled by the front end, as the back end may balk
11520 -- at the nonstandard representation (see Exp_Ch2.Expand_Renaming).
11522 elsif Nkind (Exp) in N_Indexed_Component | N_Selected_Component
11523 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
11525 Def_Id := Build_Temporary (Loc, 'R', Exp);
11526 Res := New_Occurrence_Of (Def_Id, Loc);
11528 Insert_Action (Exp,
11529 Make_Object_Renaming_Declaration (Loc,
11530 Defining_Identifier => Def_Id,
11531 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11532 Name => Relocate_Node (Exp)));
11534 -- For an expression that denotes a name, we can use a renaming scheme
11535 -- that is handled by the back end, instead of the front end as above.
11536 -- This is needed for correctness in the case of a volatile object of
11537 -- a nonvolatile type because the Make_Reference call of the "default"
11538 -- approach would generate an illegal access value (an access value
11539 -- cannot designate such an object - see Analyze_Reference).
11541 elsif Is_Name_Reference (Exp)
11543 -- We skip using this scheme if we have an object of a volatile
11544 -- type and we do not have Name_Req set true (see comments for
11545 -- Side_Effect_Free).
11547 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
11549 Def_Id := Build_Temporary (Loc, 'R', Exp);
11550 Res := New_Occurrence_Of (Def_Id, Loc);
11552 Insert_Action (Exp,
11553 Make_Object_Renaming_Declaration (Loc,
11554 Defining_Identifier => Def_Id,
11555 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11556 Name => Relocate_Node (Exp)));
11558 Set_Is_Renaming_Of_Object (Def_Id, False);
11560 -- Avoid generating a variable-sized temporary, by generating the
11561 -- reference just for the function call. The transformation could be
11562 -- refined to apply only when the array component is constrained by a
11565 elsif Nkind (Exp) = N_Selected_Component
11566 and then Nkind (Prefix (Exp)) = N_Function_Call
11567 and then Is_Array_Type (Exp_Type)
11569 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11572 -- Otherwise we generate a reference to the expression
11575 -- When generating C code we cannot consider side effect free object
11576 -- declarations that have discriminants and are initialized by means
11577 -- of a function call since on this target there is no secondary
11578 -- stack to store the return value and the expander may generate an
11579 -- extra call to the function to compute the discriminant value. In
11580 -- addition, for targets that have secondary stack, the expansion of
11581 -- functions with side effects involves the generation of an access
11582 -- type to capture the return value stored in the secondary stack;
11583 -- by contrast when generating C code such expansion generates an
11584 -- internal object declaration (no access type involved) which must
11585 -- be identified here to avoid entering into a never-ending loop
11586 -- generating internal object declarations.
11588 if Modify_Tree_For_C
11589 and then Nkind (Parent (Exp)) = N_Object_Declaration
11591 (Nkind (Exp) /= N_Function_Call
11592 or else not Has_Discriminants (Exp_Type)
11593 or else Is_Internal_Name
11594 (Chars (Defining_Identifier (Parent (Exp)))))
11599 -- Special processing for function calls that return a limited type.
11600 -- We need to build a declaration that will enable build-in-place
11601 -- expansion of the call. This is not done if the context is already
11602 -- an object declaration, to prevent infinite recursion.
11604 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
11605 -- to accommodate functions returning limited objects by reference.
11607 if Ada_Version >= Ada_2005
11608 and then Nkind (Exp) = N_Function_Call
11609 and then Is_Limited_View (Etype (Exp))
11610 and then Nkind (Parent (Exp)) /= N_Object_Declaration
11613 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
11618 Make_Object_Declaration (Loc,
11619 Defining_Identifier => Obj,
11620 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11621 Expression => Relocate_Node (Exp));
11623 Insert_Action (Exp, Decl);
11624 Set_Etype (Obj, Exp_Type);
11625 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
11630 Def_Id := Build_Temporary (Loc, 'R', Exp);
11632 -- The regular expansion of functions with side effects involves the
11633 -- generation of an access type to capture the return value found on
11634 -- the secondary stack. Since SPARK (and why) cannot process access
11635 -- types, use a different approach which ignores the secondary stack
11636 -- and "copies" the returned object.
11637 -- When generating C code, no need for a 'reference since the
11638 -- secondary stack is not supported.
11640 if GNATprove_Mode or Modify_Tree_For_C then
11641 Res := New_Occurrence_Of (Def_Id, Loc);
11642 Ref_Type := Exp_Type;
11644 -- Regular expansion utilizing an access type and 'reference
11648 Make_Explicit_Dereference (Loc,
11649 Prefix => New_Occurrence_Of (Def_Id, Loc));
11652 -- type Ann is access all <Exp_Type>;
11654 Ref_Type := Make_Temporary (Loc, 'A');
11657 Make_Full_Type_Declaration (Loc,
11658 Defining_Identifier => Ref_Type,
11660 Make_Access_To_Object_Definition (Loc,
11661 All_Present => True,
11662 Subtype_Indication =>
11663 New_Occurrence_Of (Exp_Type, Loc)));
11665 Insert_Action (Exp, Ptr_Typ_Decl);
11669 if Nkind (E) = N_Explicit_Dereference then
11670 New_Exp := Relocate_Node (Prefix (E));
11673 E := Relocate_Node (E);
11675 -- Do not generate a 'reference in SPARK mode or C generation
11676 -- since the access type is not created in the first place.
11678 if GNATprove_Mode or Modify_Tree_For_C then
11681 -- Otherwise generate reference, marking the value as non-null
11682 -- since we know it cannot be null and we don't want a check.
11685 New_Exp := Make_Reference (Loc, E);
11686 Set_Is_Known_Non_Null (Def_Id);
11690 if Is_Delayed_Aggregate (E) then
11692 -- The expansion of nested aggregates is delayed until the
11693 -- enclosing aggregate is expanded. As aggregates are often
11694 -- qualified, the predicate applies to qualified expressions as
11695 -- well, indicating that the enclosing aggregate has not been
11696 -- expanded yet. At this point the aggregate is part of a
11697 -- stand-alone declaration, and must be fully expanded.
11699 if Nkind (E) = N_Qualified_Expression then
11700 Set_Expansion_Delayed (Expression (E), False);
11701 Set_Analyzed (Expression (E), False);
11703 Set_Expansion_Delayed (E, False);
11706 Set_Analyzed (E, False);
11709 -- Generating C code of object declarations that have discriminants
11710 -- and are initialized by means of a function call we propagate the
11711 -- discriminants of the parent type to the internally built object.
11712 -- This is needed to avoid generating an extra call to the called
11715 -- For example, if we generate here the following declaration, it
11716 -- will be expanded later adding an extra call to evaluate the value
11717 -- of the discriminant (needed to compute the size of the object).
11719 -- type Rec (D : Integer) is ...
11720 -- Obj : constant Rec := SomeFunc;
11722 if Modify_Tree_For_C
11723 and then Nkind (Parent (Exp)) = N_Object_Declaration
11724 and then Has_Discriminants (Exp_Type)
11725 and then Nkind (Exp) = N_Function_Call
11727 Insert_Action (Exp,
11728 Make_Object_Declaration (Loc,
11729 Defining_Identifier => Def_Id,
11730 Object_Definition => New_Copy_Tree
11731 (Object_Definition (Parent (Exp))),
11732 Constant_Present => True,
11733 Expression => New_Exp));
11735 Insert_Action (Exp,
11736 Make_Object_Declaration (Loc,
11737 Defining_Identifier => Def_Id,
11738 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
11739 Constant_Present => True,
11740 Expression => New_Exp));
11744 -- Preserve the Assignment_OK flag in all copies, since at least one
11745 -- copy may be used in a context where this flag must be set (otherwise
11746 -- why would the flag be set in the first place).
11748 Set_Assignment_OK (Res, Assignment_OK (Exp));
11750 -- Preserve the Do_Range_Check flag in all copies
11752 Set_Do_Range_Check (Res, Do_Range_Check (Exp));
11754 -- Finally rewrite the original expression and we are done
11756 Rewrite (Exp, Res);
11757 Analyze_And_Resolve (Exp, Exp_Type);
11760 Scope_Suppress := Svg_Suppress;
11761 end Remove_Side_Effects;
11763 ------------------------
11764 -- Replace_References --
11765 ------------------------
11767 procedure Replace_References
11769 Par_Typ : Entity_Id;
11770 Deriv_Typ : Entity_Id;
11771 Par_Obj : Entity_Id := Empty;
11772 Deriv_Obj : Entity_Id := Empty)
11774 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
11775 -- Determine whether node Ref denotes some component of Deriv_Obj
11777 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
11778 -- Substitute a reference to an entity with the corresponding value
11779 -- stored in table Type_Map.
11781 function Type_Of_Formal
11783 Actual : Node_Id) return Entity_Id;
11784 -- Find the type of the formal parameter which corresponds to actual
11785 -- parameter Actual in subprogram call Call.
11787 ----------------------
11788 -- Is_Deriv_Obj_Ref --
11789 ----------------------
11791 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
11792 Par : constant Node_Id := Parent (Ref);
11795 -- Detect the folowing selected component form:
11797 -- Deriv_Obj.(something)
11800 Nkind (Par) = N_Selected_Component
11801 and then Is_Entity_Name (Prefix (Par))
11802 and then Entity (Prefix (Par)) = Deriv_Obj;
11803 end Is_Deriv_Obj_Ref;
11809 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
11810 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
11811 -- Reset the Controlling_Argument of all function calls that
11812 -- encapsulate node From_Arg.
11814 ----------------------------------
11815 -- Remove_Controlling_Arguments --
11816 ----------------------------------
11818 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
11823 while Present (Par) loop
11824 if Nkind (Par) = N_Function_Call
11825 and then Present (Controlling_Argument (Par))
11827 Set_Controlling_Argument (Par, Empty);
11829 -- Prevent the search from going too far
11831 elsif Is_Body_Or_Package_Declaration (Par) then
11835 Par := Parent (Par);
11837 end Remove_Controlling_Arguments;
11841 Context : constant Node_Id := Parent (Ref);
11842 Loc : constant Source_Ptr := Sloc (Ref);
11843 Ref_Id : Entity_Id;
11844 Result : Traverse_Result;
11847 -- The new reference which is intended to substitute the old one
11850 -- The reference designated for replacement. In certain cases this
11851 -- may be a node other than Ref.
11853 Val : Node_Or_Entity_Id;
11854 -- The corresponding value of Ref from the type map
11856 -- Start of processing for Replace_Ref
11859 -- Assume that the input reference is to be replaced and that the
11860 -- traversal should examine the children of the reference.
11865 -- The input denotes a meaningful reference
11867 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
11868 Ref_Id := Entity (Ref);
11869 Val := Type_Map.Get (Ref_Id);
11871 -- The reference has a corresponding value in the type map, a
11872 -- substitution is possible.
11874 if Present (Val) then
11876 -- The reference denotes a discriminant
11878 if Ekind (Ref_Id) = E_Discriminant then
11879 if Nkind (Val) in N_Entity then
11881 -- The value denotes another discriminant. Replace as
11884 -- _object.Discr -> _object.Val
11886 if Ekind (Val) = E_Discriminant then
11887 New_Ref := New_Occurrence_Of (Val, Loc);
11889 -- Otherwise the value denotes the entity of a name which
11890 -- constraints the discriminant. Replace as follows:
11892 -- _object.Discr -> Val
11895 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11897 New_Ref := New_Occurrence_Of (Val, Loc);
11898 Old_Ref := Parent (Old_Ref);
11901 -- Otherwise the value denotes an arbitrary expression which
11902 -- constraints the discriminant. Replace as follows:
11904 -- _object.Discr -> Val
11907 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11909 New_Ref := New_Copy_Tree (Val);
11910 Old_Ref := Parent (Old_Ref);
11913 -- Otherwise the reference denotes a primitive. Replace as
11916 -- Primitive -> Val
11919 pragma Assert (Nkind (Val) in N_Entity);
11920 New_Ref := New_Occurrence_Of (Val, Loc);
11923 -- The reference mentions the _object parameter of the parent
11924 -- type's DIC or type invariant procedure. Replace as follows:
11926 -- _object -> _object
11928 elsif Present (Par_Obj)
11929 and then Present (Deriv_Obj)
11930 and then Ref_Id = Par_Obj
11932 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
11934 -- The type of the _object parameter is class-wide when the
11935 -- expression comes from an assertion pragma that applies to
11936 -- an abstract parent type or an interface. The class-wide type
11937 -- facilitates the preanalysis of the expression by treating
11938 -- calls to abstract primitives that mention the current
11939 -- instance of the type as dispatching. Once the calls are
11940 -- remapped to invoke overriding or inherited primitives, the
11941 -- calls no longer need to be dispatching. Examine all function
11942 -- calls that encapsulate the _object parameter and reset their
11943 -- Controlling_Argument attribute.
11945 if Is_Class_Wide_Type (Etype (Par_Obj))
11946 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
11948 Remove_Controlling_Arguments (Old_Ref);
11951 -- The reference to _object acts as an actual parameter in a
11952 -- subprogram call which may be invoking a primitive of the
11955 -- Primitive (... _object ...);
11957 -- The parent type primitive may not be overridden nor
11958 -- inherited when it is declared after the derived type
11961 -- type Parent is tagged private;
11962 -- type Child is new Parent with private;
11963 -- procedure Primitive (Obj : Parent);
11965 -- In this scenario the _object parameter is converted to the
11966 -- parent type. Due to complications with partial/full views
11967 -- and view swaps, the parent type is taken from the formal
11968 -- parameter of the subprogram being called.
11970 if Nkind (Context) in
11971 N_Function_Call | N_Procedure_Call_Statement
11972 and then No (Type_Map.Get (Entity (Name (Context))))
11975 Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
11977 -- Do not process the generated type conversion because
11978 -- both the parent type and the derived type are in the
11979 -- Type_Map table. This will clobber the type conversion
11980 -- by resetting its subtype mark.
11985 -- Otherwise there is nothing to replace
11991 if Present (New_Ref) then
11992 Rewrite (Old_Ref, New_Ref);
11994 -- Update the return type when the context of the reference
11995 -- acts as the name of a function call. Note that the update
11996 -- should not be performed when the reference appears as an
11997 -- actual in the call.
11999 if Nkind (Context) = N_Function_Call
12000 and then Name (Context) = Old_Ref
12002 Set_Etype (Context, Etype (Val));
12007 -- Reanalyze the reference due to potential replacements
12009 if Nkind (Old_Ref) in N_Has_Etype then
12010 Set_Analyzed (Old_Ref, False);
12016 procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
12018 --------------------
12019 -- Type_Of_Formal --
12020 --------------------
12022 function Type_Of_Formal
12024 Actual : Node_Id) return Entity_Id
12030 -- Examine the list of actual and formal parameters in parallel
12032 A := First (Parameter_Associations (Call));
12033 F := First_Formal (Entity (Name (Call)));
12034 while Present (A) and then Present (F) loop
12043 -- The actual parameter must always have a corresponding formal
12045 pragma Assert (False);
12048 end Type_Of_Formal;
12050 -- Start of processing for Replace_References
12053 -- Map the attributes of the parent type to the proper corresponding
12054 -- attributes of the derived type.
12057 (Parent_Type => Par_Typ,
12058 Derived_Type => Deriv_Typ);
12060 -- Inspect the input expression and perform substitutions where
12063 Replace_Refs (Expr);
12064 end Replace_References;
12066 -----------------------------
12067 -- Replace_Type_References --
12068 -----------------------------
12070 procedure Replace_Type_References
12073 Obj_Id : Entity_Id)
12075 procedure Replace_Type_Ref (N : Node_Id);
12076 -- Substitute a single reference of the current instance of type Typ
12077 -- with a reference to Obj_Id.
12079 ----------------------
12080 -- Replace_Type_Ref --
12081 ----------------------
12083 procedure Replace_Type_Ref (N : Node_Id) is
12085 -- Decorate the reference to Typ even though it may be rewritten
12086 -- further down. This is done so that routines which examine
12087 -- properties of the Original_Node have some semantic information.
12089 if Nkind (N) = N_Identifier then
12090 Set_Entity (N, Typ);
12091 Set_Etype (N, Typ);
12093 elsif Nkind (N) = N_Selected_Component then
12094 Analyze (Prefix (N));
12095 Set_Entity (Selector_Name (N), Typ);
12096 Set_Etype (Selector_Name (N), Typ);
12099 -- Perform the following substitution:
12103 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
12104 Set_Comes_From_Source (N, True);
12105 end Replace_Type_Ref;
12107 procedure Replace_Type_Refs is
12108 new Replace_Type_References_Generic (Replace_Type_Ref);
12110 -- Start of processing for Replace_Type_References
12113 Replace_Type_Refs (Expr, Typ);
12114 end Replace_Type_References;
12116 ---------------------------
12117 -- Represented_As_Scalar --
12118 ---------------------------
12120 function Represented_As_Scalar (T : Entity_Id) return Boolean is
12121 UT : constant Entity_Id := Underlying_Type (T);
12123 return Is_Scalar_Type (UT)
12124 or else (Is_Bit_Packed_Array (UT)
12125 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
12126 end Represented_As_Scalar;
12128 ------------------------------
12129 -- Requires_Cleanup_Actions --
12130 ------------------------------
12132 function Requires_Cleanup_Actions
12134 Lib_Level : Boolean) return Boolean
12136 At_Lib_Level : constant Boolean :=
12138 and then Nkind (N) in N_Package_Body | N_Package_Specification;
12139 -- N is at the library level if the top-most context is a package and
12140 -- the path taken to reach N does not include nonpackage constructs.
12144 when N_Accept_Statement
12145 | N_Block_Statement
12149 | N_Subprogram_Body
12153 Requires_Cleanup_Actions
12154 (L => Declarations (N),
12155 Lib_Level => At_Lib_Level,
12156 Nested_Constructs => True)
12158 (Present (Handled_Statement_Sequence (N))
12160 Requires_Cleanup_Actions
12162 Statements (Handled_Statement_Sequence (N)),
12163 Lib_Level => At_Lib_Level,
12164 Nested_Constructs => True));
12166 -- Extended return statements are the same as the above, except that
12167 -- there is no Declarations field. We do not want to clean up the
12168 -- Return_Object_Declarations.
12170 when N_Extended_Return_Statement =>
12172 Present (Handled_Statement_Sequence (N))
12173 and then Requires_Cleanup_Actions
12175 Statements (Handled_Statement_Sequence (N)),
12176 Lib_Level => At_Lib_Level,
12177 Nested_Constructs => True);
12179 when N_Package_Specification =>
12181 Requires_Cleanup_Actions
12182 (L => Visible_Declarations (N),
12183 Lib_Level => At_Lib_Level,
12184 Nested_Constructs => True)
12186 Requires_Cleanup_Actions
12187 (L => Private_Declarations (N),
12188 Lib_Level => At_Lib_Level,
12189 Nested_Constructs => True);
12192 raise Program_Error;
12194 end Requires_Cleanup_Actions;
12196 ------------------------------
12197 -- Requires_Cleanup_Actions --
12198 ------------------------------
12200 function Requires_Cleanup_Actions
12202 Lib_Level : Boolean;
12203 Nested_Constructs : Boolean) return Boolean
12207 Obj_Id : Entity_Id;
12208 Obj_Typ : Entity_Id;
12209 Pack_Id : Entity_Id;
12213 if No (L) or else Is_Empty_List (L) then
12218 while Present (Decl) loop
12220 -- Library-level tagged types
12222 if Nkind (Decl) = N_Full_Type_Declaration then
12223 Typ := Defining_Identifier (Decl);
12225 -- Ignored Ghost types do not need any cleanup actions because
12226 -- they will not appear in the final tree.
12228 if Is_Ignored_Ghost_Entity (Typ) then
12231 elsif Is_Tagged_Type (Typ)
12232 and then Is_Library_Level_Entity (Typ)
12233 and then Convention (Typ) = Convention_Ada
12234 and then Present (Access_Disp_Table (Typ))
12235 and then RTE_Available (RE_Unregister_Tag)
12236 and then not Is_Abstract_Type (Typ)
12237 and then not No_Run_Time_Mode
12242 -- Regular object declarations
12244 elsif Nkind (Decl) = N_Object_Declaration then
12245 Obj_Id := Defining_Identifier (Decl);
12246 Obj_Typ := Base_Type (Etype (Obj_Id));
12247 Expr := Expression (Decl);
12249 -- Bypass any form of processing for objects which have their
12250 -- finalization disabled. This applies only to objects at the
12253 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12256 -- Finalization of transient objects are treated separately in
12257 -- order to handle sensitive cases. These include:
12259 -- * Aggregate expansion
12260 -- * If, case, and expression with actions expansion
12261 -- * Transient scopes
12263 -- If one of those contexts has marked the transient object as
12264 -- ignored, do not generate finalization actions for it.
12266 elsif Is_Finalized_Transient (Obj_Id)
12267 or else Is_Ignored_Transient (Obj_Id)
12271 -- Ignored Ghost objects do not need any cleanup actions because
12272 -- they will not appear in the final tree.
12274 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12277 -- The object is of the form:
12278 -- Obj : [constant] Typ [:= Expr];
12280 -- Do not process tag-to-class-wide conversions because they do
12281 -- not yield an object. Do not process the incomplete view of a
12282 -- deferred constant. Note that an object initialized by means
12283 -- of a build-in-place function call may appear as a deferred
12284 -- constant after expansion activities. These kinds of objects
12285 -- must be finalized.
12287 elsif not Is_Imported (Obj_Id)
12288 and then Needs_Finalization (Obj_Typ)
12289 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
12290 and then not (Ekind (Obj_Id) = E_Constant
12291 and then not Has_Completion (Obj_Id)
12292 and then No (BIP_Initialization_Call (Obj_Id)))
12296 -- The object is of the form:
12297 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
12299 -- Obj : Access_Typ :=
12300 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
12302 elsif Is_Access_Type (Obj_Typ)
12303 and then Needs_Finalization
12304 (Available_View (Designated_Type (Obj_Typ)))
12305 and then Present (Expr)
12307 (Is_Secondary_Stack_BIP_Func_Call (Expr)
12309 (Is_Non_BIP_Func_Call (Expr)
12310 and then not Is_Related_To_Func_Return (Obj_Id)))
12314 -- Processing for "hook" objects generated for transient objects
12315 -- declared inside an Expression_With_Actions.
12317 elsif Is_Access_Type (Obj_Typ)
12318 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12319 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12320 N_Object_Declaration
12324 -- Processing for intermediate results of if expressions where
12325 -- one of the alternatives uses a controlled function call.
12327 elsif Is_Access_Type (Obj_Typ)
12328 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12329 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12330 N_Defining_Identifier
12331 and then Present (Expr)
12332 and then Nkind (Expr) = N_Null
12336 -- Simple protected objects which use type System.Tasking.
12337 -- Protected_Objects.Protection to manage their locks should be
12338 -- treated as controlled since they require manual cleanup.
12340 elsif Ekind (Obj_Id) = E_Variable
12341 and then (Is_Simple_Protected_Type (Obj_Typ)
12342 or else Has_Simple_Protected_Object (Obj_Typ))
12347 -- Specific cases of object renamings
12349 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
12350 Obj_Id := Defining_Identifier (Decl);
12351 Obj_Typ := Base_Type (Etype (Obj_Id));
12353 -- Bypass any form of processing for objects which have their
12354 -- finalization disabled. This applies only to objects at the
12357 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12360 -- Ignored Ghost object renamings do not need any cleanup actions
12361 -- because they will not appear in the final tree.
12363 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12366 -- Return object of a build-in-place function. This case is
12367 -- recognized and marked by the expansion of an extended return
12368 -- statement (see Expand_N_Extended_Return_Statement).
12370 elsif Needs_Finalization (Obj_Typ)
12371 and then Is_Return_Object (Obj_Id)
12372 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12376 -- Detect a case where a source object has been initialized by
12377 -- a controlled function call or another object which was later
12378 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
12380 -- Obj1 : CW_Type := Src_Obj;
12381 -- Obj2 : CW_Type := Function_Call (...);
12383 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
12384 -- Tmp : ... := Function_Call (...)'reference;
12385 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
12387 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
12391 -- Inspect the freeze node of an access-to-controlled type and look
12392 -- for a delayed finalization master. This case arises when the
12393 -- freeze actions are inserted at a later time than the expansion of
12394 -- the context. Since Build_Finalizer is never called on a single
12395 -- construct twice, the master will be ultimately left out and never
12396 -- finalized. This is also needed for freeze actions of designated
12397 -- types themselves, since in some cases the finalization master is
12398 -- associated with a designated type's freeze node rather than that
12399 -- of the access type (see handling for freeze actions in
12400 -- Build_Finalization_Master).
12402 elsif Nkind (Decl) = N_Freeze_Entity
12403 and then Present (Actions (Decl))
12405 Typ := Entity (Decl);
12407 -- Freeze nodes for ignored Ghost types do not need cleanup
12408 -- actions because they will never appear in the final tree.
12410 if Is_Ignored_Ghost_Entity (Typ) then
12413 elsif ((Is_Access_Object_Type (Typ)
12414 and then Needs_Finalization
12415 (Available_View (Designated_Type (Typ))))
12416 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
12417 and then Requires_Cleanup_Actions
12418 (Actions (Decl), Lib_Level, Nested_Constructs)
12423 -- Nested package declarations
12425 elsif Nested_Constructs
12426 and then Nkind (Decl) = N_Package_Declaration
12428 Pack_Id := Defining_Entity (Decl);
12430 -- Do not inspect an ignored Ghost package because all code found
12431 -- within will not appear in the final tree.
12433 if Is_Ignored_Ghost_Entity (Pack_Id) then
12436 elsif Ekind (Pack_Id) /= E_Generic_Package
12437 and then Requires_Cleanup_Actions
12438 (Specification (Decl), Lib_Level)
12443 -- Nested package bodies
12445 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
12447 -- Do not inspect an ignored Ghost package body because all code
12448 -- found within will not appear in the final tree.
12450 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
12453 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
12454 and then Requires_Cleanup_Actions (Decl, Lib_Level)
12459 elsif Nkind (Decl) = N_Block_Statement
12462 -- Handle a rare case caused by a controlled transient object
12463 -- created as part of a record init proc. The variable is wrapped
12464 -- in a block, but the block is not associated with a transient
12469 -- Handle the case where the original context has been wrapped in
12470 -- a block to avoid interference between exception handlers and
12471 -- At_End handlers. Treat the block as transparent and process its
12474 or else Is_Finalization_Wrapper (Decl))
12476 if Requires_Cleanup_Actions (Decl, Lib_Level) then
12485 end Requires_Cleanup_Actions;
12487 ------------------------------------
12488 -- Safe_Unchecked_Type_Conversion --
12489 ------------------------------------
12491 -- Note: this function knows quite a bit about the exact requirements of
12492 -- Gigi with respect to unchecked type conversions, and its code must be
12493 -- coordinated with any changes in Gigi in this area.
12495 -- The above requirements should be documented in Sinfo ???
12497 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
12502 Pexp : constant Node_Id := Parent (Exp);
12505 -- If the expression is the RHS of an assignment or object declaration
12506 -- we are always OK because there will always be a target.
12508 -- Object renaming declarations, (generated for view conversions of
12509 -- actuals in inlined calls), like object declarations, provide an
12510 -- explicit type, and are safe as well.
12512 if (Nkind (Pexp) = N_Assignment_Statement
12513 and then Expression (Pexp) = Exp)
12514 or else Nkind (Pexp)
12515 in N_Object_Declaration | N_Object_Renaming_Declaration
12519 -- If the expression is the prefix of an N_Selected_Component we should
12520 -- also be OK because GCC knows to look inside the conversion except if
12521 -- the type is discriminated. We assume that we are OK anyway if the
12522 -- type is not set yet or if it is controlled since we can't afford to
12523 -- introduce a temporary in this case.
12525 elsif Nkind (Pexp) = N_Selected_Component
12526 and then Prefix (Pexp) = Exp
12528 return No (Etype (Pexp))
12529 or else not Is_Type (Etype (Pexp))
12530 or else not Has_Discriminants (Etype (Pexp))
12531 or else Is_Constrained (Etype (Pexp));
12534 -- Set the output type, this comes from Etype if it is set, otherwise we
12535 -- take it from the subtype mark, which we assume was already fully
12538 if Present (Etype (Exp)) then
12539 Otyp := Etype (Exp);
12541 Otyp := Entity (Subtype_Mark (Exp));
12544 -- The input type always comes from the expression, and we assume this
12545 -- is indeed always analyzed, so we can simply get the Etype.
12547 Ityp := Etype (Expression (Exp));
12549 -- Initialize alignments to unknown so far
12554 -- Replace a concurrent type by its corresponding record type and each
12555 -- type by its underlying type and do the tests on those. The original
12556 -- type may be a private type whose completion is a concurrent type, so
12557 -- find the underlying type first.
12559 if Present (Underlying_Type (Otyp)) then
12560 Otyp := Underlying_Type (Otyp);
12563 if Present (Underlying_Type (Ityp)) then
12564 Ityp := Underlying_Type (Ityp);
12567 if Is_Concurrent_Type (Otyp) then
12568 Otyp := Corresponding_Record_Type (Otyp);
12571 if Is_Concurrent_Type (Ityp) then
12572 Ityp := Corresponding_Record_Type (Ityp);
12575 -- If the base types are the same, we know there is no problem since
12576 -- this conversion will be a noop.
12578 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
12581 -- Same if this is an upwards conversion of an untagged type, and there
12582 -- are no constraints involved (could be more general???)
12584 elsif Etype (Ityp) = Otyp
12585 and then not Is_Tagged_Type (Ityp)
12586 and then not Has_Discriminants (Ityp)
12587 and then No (First_Rep_Item (Base_Type (Ityp)))
12591 -- If the expression has an access type (object or subprogram) we assume
12592 -- that the conversion is safe, because the size of the target is safe,
12593 -- even if it is a record (which might be treated as having unknown size
12596 elsif Is_Access_Type (Ityp) then
12599 -- If the size of output type is known at compile time, there is never
12600 -- a problem. Note that unconstrained records are considered to be of
12601 -- known size, but we can't consider them that way here, because we are
12602 -- talking about the actual size of the object.
12604 -- We also make sure that in addition to the size being known, we do not
12605 -- have a case which might generate an embarrassingly large temp in
12606 -- stack checking mode.
12608 elsif Size_Known_At_Compile_Time (Otyp)
12610 (not Stack_Checking_Enabled
12611 or else not May_Generate_Large_Temp (Otyp))
12612 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
12616 -- If either type is tagged, then we know the alignment is OK so Gigi
12617 -- will be able to use pointer punning.
12619 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
12622 -- If either type is a limited record type, we cannot do a copy, so say
12623 -- safe since there's nothing else we can do.
12625 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
12628 -- Conversions to and from packed array types are always ignored and
12631 elsif Is_Packed_Array_Impl_Type (Otyp)
12632 or else Is_Packed_Array_Impl_Type (Ityp)
12637 -- The only other cases known to be safe is if the input type's
12638 -- alignment is known to be at least the maximum alignment for the
12639 -- target or if both alignments are known and the output type's
12640 -- alignment is no stricter than the input's. We can use the component
12641 -- type alignment for an array if a type is an unpacked array type.
12643 if Present (Alignment_Clause (Otyp)) then
12644 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
12646 elsif Is_Array_Type (Otyp)
12647 and then Present (Alignment_Clause (Component_Type (Otyp)))
12649 Oalign := Expr_Value (Expression (Alignment_Clause
12650 (Component_Type (Otyp))));
12653 if Present (Alignment_Clause (Ityp)) then
12654 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
12656 elsif Is_Array_Type (Ityp)
12657 and then Present (Alignment_Clause (Component_Type (Ityp)))
12659 Ialign := Expr_Value (Expression (Alignment_Clause
12660 (Component_Type (Ityp))));
12663 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
12666 elsif Ialign /= No_Uint
12667 and then Oalign /= No_Uint
12668 and then Ialign <= Oalign
12672 -- Otherwise, Gigi cannot handle this and we must make a temporary
12677 end Safe_Unchecked_Type_Conversion;
12679 ---------------------------------
12680 -- Set_Current_Value_Condition --
12681 ---------------------------------
12683 -- Note: the implementation of this procedure is very closely tied to the
12684 -- implementation of Get_Current_Value_Condition. Here we set required
12685 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
12686 -- them, so they must have a consistent view.
12688 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
12690 procedure Set_Entity_Current_Value (N : Node_Id);
12691 -- If N is an entity reference, where the entity is of an appropriate
12692 -- kind, then set the current value of this entity to Cnode, unless
12693 -- there is already a definite value set there.
12695 procedure Set_Expression_Current_Value (N : Node_Id);
12696 -- If N is of an appropriate form, sets an appropriate entry in current
12697 -- value fields of relevant entities. Multiple entities can be affected
12698 -- in the case of an AND or AND THEN.
12700 ------------------------------
12701 -- Set_Entity_Current_Value --
12702 ------------------------------
12704 procedure Set_Entity_Current_Value (N : Node_Id) is
12706 if Is_Entity_Name (N) then
12708 Ent : constant Entity_Id := Entity (N);
12711 -- Don't capture if not safe to do so
12713 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
12717 -- Here we have a case where the Current_Value field may need
12718 -- to be set. We set it if it is not already set to a compile
12719 -- time expression value.
12721 -- Note that this represents a decision that one condition
12722 -- blots out another previous one. That's certainly right if
12723 -- they occur at the same level. If the second one is nested,
12724 -- then the decision is neither right nor wrong (it would be
12725 -- equally OK to leave the outer one in place, or take the new
12726 -- inner one). Really we should record both, but our data
12727 -- structures are not that elaborate.
12729 if Nkind (Current_Value (Ent)) not in N_Subexpr then
12730 Set_Current_Value (Ent, Cnode);
12734 end Set_Entity_Current_Value;
12736 ----------------------------------
12737 -- Set_Expression_Current_Value --
12738 ----------------------------------
12740 procedure Set_Expression_Current_Value (N : Node_Id) is
12746 -- Loop to deal with (ignore for now) any NOT operators present. The
12747 -- presence of NOT operators will be handled properly when we call
12748 -- Get_Current_Value_Condition.
12750 while Nkind (Cond) = N_Op_Not loop
12751 Cond := Right_Opnd (Cond);
12754 -- For an AND or AND THEN, recursively process operands
12756 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
12757 Set_Expression_Current_Value (Left_Opnd (Cond));
12758 Set_Expression_Current_Value (Right_Opnd (Cond));
12762 -- Check possible relational operator
12764 if Nkind (Cond) in N_Op_Compare then
12765 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
12766 Set_Entity_Current_Value (Left_Opnd (Cond));
12767 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
12768 Set_Entity_Current_Value (Right_Opnd (Cond));
12771 elsif Nkind (Cond) in N_Type_Conversion
12772 | N_Qualified_Expression
12773 | N_Expression_With_Actions
12775 Set_Expression_Current_Value (Expression (Cond));
12777 -- Check possible boolean variable reference
12780 Set_Entity_Current_Value (Cond);
12782 end Set_Expression_Current_Value;
12784 -- Start of processing for Set_Current_Value_Condition
12787 Set_Expression_Current_Value (Condition (Cnode));
12788 end Set_Current_Value_Condition;
12790 --------------------------
12791 -- Set_Elaboration_Flag --
12792 --------------------------
12794 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
12795 Loc : constant Source_Ptr := Sloc (N);
12796 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
12800 if Present (Ent) then
12802 -- Nothing to do if at the compilation unit level, because in this
12803 -- case the flag is set by the binder generated elaboration routine.
12805 if Nkind (Parent (N)) = N_Compilation_Unit then
12808 -- Here we do need to generate an assignment statement
12811 Check_Restriction (No_Elaboration_Code, N);
12814 Make_Assignment_Statement (Loc,
12815 Name => New_Occurrence_Of (Ent, Loc),
12816 Expression => Make_Integer_Literal (Loc, Uint_1));
12818 -- Mark the assignment statement as elaboration code. This allows
12819 -- the early call region mechanism (see Sem_Elab) to properly
12820 -- ignore such assignments even though they are nonpreelaborable
12823 Set_Is_Elaboration_Code (Asn);
12825 if Nkind (Parent (N)) = N_Subunit then
12826 Insert_After (Corresponding_Stub (Parent (N)), Asn);
12828 Insert_After (N, Asn);
12833 -- Kill current value indication. This is necessary because the
12834 -- tests of this flag are inserted out of sequence and must not
12835 -- pick up bogus indications of the wrong constant value.
12837 Set_Current_Value (Ent, Empty);
12839 -- If the subprogram is in the current declarative part and
12840 -- 'access has been applied to it, generate an elaboration
12841 -- check at the beginning of the declarations of the body.
12843 if Nkind (N) = N_Subprogram_Body
12844 and then Address_Taken (Spec_Id)
12846 Ekind (Scope (Spec_Id)) in E_Block | E_Procedure | E_Function
12849 Loc : constant Source_Ptr := Sloc (N);
12850 Decls : constant List_Id := Declarations (N);
12854 -- No need to generate this check if first entry in the
12855 -- declaration list is a raise of Program_Error now.
12858 and then Nkind (First (Decls)) = N_Raise_Program_Error
12863 -- Otherwise generate the check
12866 Make_Raise_Program_Error (Loc,
12869 Left_Opnd => New_Occurrence_Of (Ent, Loc),
12870 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
12871 Reason => PE_Access_Before_Elaboration);
12874 Set_Declarations (N, New_List (Chk));
12876 Prepend (Chk, Decls);
12884 end Set_Elaboration_Flag;
12886 ----------------------------
12887 -- Set_Renamed_Subprogram --
12888 ----------------------------
12890 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
12892 -- If input node is an identifier, we can just reset it
12894 if Nkind (N) = N_Identifier then
12895 Set_Chars (N, Chars (E));
12898 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
12902 CS : constant Boolean := Comes_From_Source (N);
12904 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
12906 Set_Comes_From_Source (N, CS);
12907 Set_Analyzed (N, True);
12910 end Set_Renamed_Subprogram;
12912 ----------------------
12913 -- Side_Effect_Free --
12914 ----------------------
12916 function Side_Effect_Free
12918 Name_Req : Boolean := False;
12919 Variable_Ref : Boolean := False) return Boolean
12921 Typ : constant Entity_Id := Etype (N);
12922 -- Result type of the expression
12924 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
12925 -- The argument N is a construct where the Prefix is dereferenced if it
12926 -- is an access type and the result is a variable. The call returns True
12927 -- if the construct is side effect free (not considering side effects in
12928 -- other than the prefix which are to be tested by the caller).
12930 function Within_In_Parameter (N : Node_Id) return Boolean;
12931 -- Determines if N is a subcomponent of a composite in-parameter. If so,
12932 -- N is not side-effect free when the actual is global and modifiable
12933 -- indirectly from within a subprogram, because it may be passed by
12934 -- reference. The front-end must be conservative here and assume that
12935 -- this may happen with any array or record type. On the other hand, we
12936 -- cannot create temporaries for all expressions for which this
12937 -- condition is true, for various reasons that might require clearing up
12938 -- ??? For example, discriminant references that appear out of place, or
12939 -- spurious type errors with class-wide expressions. As a result, we
12940 -- limit the transformation to loop bounds, which is so far the only
12941 -- case that requires it.
12943 -----------------------------
12944 -- Safe_Prefixed_Reference --
12945 -----------------------------
12947 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
12949 -- If prefix is not side effect free, definitely not safe
12951 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
12954 -- If the prefix is of an access type that is not access-to-constant,
12955 -- then this construct is a variable reference, which means it is to
12956 -- be considered to have side effects if Variable_Ref is set True.
12958 elsif Is_Access_Type (Etype (Prefix (N)))
12959 and then not Is_Access_Constant (Etype (Prefix (N)))
12960 and then Variable_Ref
12962 -- Exception is a prefix that is the result of a previous removal
12963 -- of side effects.
12965 return Is_Entity_Name (Prefix (N))
12966 and then not Comes_From_Source (Prefix (N))
12967 and then Ekind (Entity (Prefix (N))) = E_Constant
12968 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
12970 -- If the prefix is an explicit dereference then this construct is a
12971 -- variable reference, which means it is to be considered to have
12972 -- side effects if Variable_Ref is True.
12974 -- We do NOT exclude dereferences of access-to-constant types because
12975 -- we handle them as constant view of variables.
12977 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
12978 and then Variable_Ref
12982 -- Note: The following test is the simplest way of solving a complex
12983 -- problem uncovered by the following test (Side effect on loop bound
12984 -- that is a subcomponent of a global variable:
12986 -- with Text_Io; use Text_Io;
12987 -- procedure Tloop is
12990 -- V : Natural := 4;
12991 -- S : String (1..5) := (others => 'a');
12998 -- with procedure Action;
12999 -- procedure Loop_G (Arg : X; Msg : String)
13001 -- procedure Loop_G (Arg : X; Msg : String) is
13003 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
13004 -- & Natural'Image (Arg.V));
13005 -- for Index in 1 .. Arg.V loop
13006 -- Text_Io.Put_Line
13007 -- (Natural'Image (Index) & " " & Arg.S (Index));
13008 -- if Index > 2 then
13012 -- Put_Line ("end loop_g " & Msg);
13015 -- procedure Loop1 is new Loop_G (Modi);
13016 -- procedure Modi is
13019 -- Loop1 (X1, "from modi");
13023 -- Loop1 (X1, "initial");
13026 -- The output of the above program should be:
13028 -- begin loop_g initial will loop till: 4
13032 -- begin loop_g from modi will loop till: 1
13034 -- end loop_g from modi
13036 -- begin loop_g from modi will loop till: 1
13038 -- end loop_g from modi
13039 -- end loop_g initial
13041 -- If a loop bound is a subcomponent of a global variable, a
13042 -- modification of that variable within the loop may incorrectly
13043 -- affect the execution of the loop.
13045 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
13046 and then Within_In_Parameter (Prefix (N))
13047 and then Variable_Ref
13051 -- All other cases are side effect free
13056 end Safe_Prefixed_Reference;
13058 -------------------------
13059 -- Within_In_Parameter --
13060 -------------------------
13062 function Within_In_Parameter (N : Node_Id) return Boolean is
13064 if not Comes_From_Source (N) then
13067 elsif Is_Entity_Name (N) then
13068 return Ekind (Entity (N)) = E_In_Parameter;
13070 elsif Nkind (N) in N_Indexed_Component | N_Selected_Component then
13071 return Within_In_Parameter (Prefix (N));
13076 end Within_In_Parameter;
13078 -- Start of processing for Side_Effect_Free
13081 -- If volatile reference, always consider it to have side effects
13083 if Is_Volatile_Reference (N) then
13087 -- Note on checks that could raise Constraint_Error. Strictly, if we
13088 -- take advantage of 11.6, these checks do not count as side effects.
13089 -- However, we would prefer to consider that they are side effects,
13090 -- since the back end CSE does not work very well on expressions which
13091 -- can raise Constraint_Error. On the other hand if we don't consider
13092 -- them to be side effect free, then we get some awkward expansions
13093 -- in -gnato mode, resulting in code insertions at a point where we
13094 -- do not have a clear model for performing the insertions.
13096 -- Special handling for entity names
13098 if Is_Entity_Name (N) then
13100 -- A type reference is always side effect free
13102 if Is_Type (Entity (N)) then
13105 -- Variables are considered to be a side effect if Variable_Ref
13106 -- is set or if we have a volatile reference and Name_Req is off.
13107 -- If Name_Req is True then we can't help returning a name which
13108 -- effectively allows multiple references in any case.
13110 elsif Is_Variable (N, Use_Original_Node => False) then
13111 return not Variable_Ref
13112 and then (not Is_Volatile_Reference (N) or else Name_Req);
13114 -- Any other entity (e.g. a subtype name) is definitely side
13121 -- A value known at compile time is always side effect free
13123 elsif Compile_Time_Known_Value (N) then
13126 -- A variable renaming is not side-effect free, because the renaming
13127 -- will function like a macro in the front-end in some cases, and an
13128 -- assignment can modify the component designated by N, so we need to
13129 -- create a temporary for it.
13131 -- The guard testing for Entity being present is needed at least in
13132 -- the case of rewritten predicate expressions, and may well also be
13133 -- appropriate elsewhere. Obviously we can't go testing the entity
13134 -- field if it does not exist, so it's reasonable to say that this is
13135 -- not the renaming case if it does not exist.
13137 elsif Is_Entity_Name (Original_Node (N))
13138 and then Present (Entity (Original_Node (N)))
13139 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
13140 and then Ekind (Entity (Original_Node (N))) /= E_Constant
13143 RO : constant Node_Id :=
13144 Renamed_Object (Entity (Original_Node (N)));
13147 -- If the renamed object is an indexed component, or an
13148 -- explicit dereference, then the designated object could
13149 -- be modified by an assignment.
13151 if Nkind (RO) in N_Indexed_Component | N_Explicit_Dereference then
13154 -- A selected component must have a safe prefix
13156 elsif Nkind (RO) = N_Selected_Component then
13157 return Safe_Prefixed_Reference (RO);
13159 -- In all other cases, designated object cannot be changed so
13160 -- we are side effect free.
13167 -- Remove_Side_Effects generates an object renaming declaration to
13168 -- capture the expression of a class-wide expression. In VM targets
13169 -- the frontend performs no expansion for dispatching calls to
13170 -- class- wide types since they are handled by the VM. Hence, we must
13171 -- locate here if this node corresponds to a previous invocation of
13172 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
13174 elsif not Tagged_Type_Expansion
13175 and then not Comes_From_Source (N)
13176 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
13177 and then Is_Class_Wide_Type (Typ)
13181 -- Generating C the type conversion of an access to constrained array
13182 -- type into an access to unconstrained array type involves initializing
13183 -- a fat pointer and the expression cannot be assumed to be free of side
13184 -- effects since it must referenced several times to compute its bounds.
13186 elsif Modify_Tree_For_C
13187 and then Nkind (N) = N_Type_Conversion
13188 and then Is_Access_Type (Typ)
13189 and then Is_Array_Type (Designated_Type (Typ))
13190 and then not Is_Constrained (Designated_Type (Typ))
13195 -- For other than entity names and compile time known values,
13196 -- check the node kind for special processing.
13200 -- An attribute reference is side-effect free if its expressions
13201 -- are side-effect free and its prefix is side-effect free or is
13202 -- an entity reference.
13204 when N_Attribute_Reference =>
13205 return Side_Effect_Free_Attribute (Attribute_Name (N))
13207 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13209 (Is_Entity_Name (Prefix (N))
13211 Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref));
13213 -- A binary operator is side effect free if and both operands are
13214 -- side effect free. For this purpose binary operators include
13215 -- membership tests and short circuit forms.
13218 | N_Membership_Test
13221 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13223 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13225 -- An explicit dereference is side effect free only if it is
13226 -- a side effect free prefixed reference.
13228 when N_Explicit_Dereference =>
13229 return Safe_Prefixed_Reference (N);
13231 -- An expression with action is side effect free if its expression
13232 -- is side effect free and it has no actions.
13234 when N_Expression_With_Actions =>
13236 Is_Empty_List (Actions (N))
13237 and then Side_Effect_Free
13238 (Expression (N), Name_Req, Variable_Ref);
13240 -- A call to _rep_to_pos is side effect free, since we generate
13241 -- this pure function call ourselves. Moreover it is critically
13242 -- important to make this exception, since otherwise we can have
13243 -- discriminants in array components which don't look side effect
13244 -- free in the case of an array whose index type is an enumeration
13245 -- type with an enumeration rep clause.
13247 -- All other function calls are not side effect free
13249 when N_Function_Call =>
13251 Nkind (Name (N)) = N_Identifier
13252 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
13253 and then Side_Effect_Free
13254 (First (Parameter_Associations (N)),
13255 Name_Req, Variable_Ref);
13257 -- An IF expression is side effect free if it's of a scalar type, and
13258 -- all its components are all side effect free (conditions and then
13259 -- actions and else actions). We restrict to scalar types, since it
13260 -- is annoying to deal with things like (if A then B else C)'First
13261 -- where the type involved is a string type.
13263 when N_If_Expression =>
13265 Is_Scalar_Type (Typ)
13266 and then Side_Effect_Free
13267 (Expressions (N), Name_Req, Variable_Ref);
13269 -- An indexed component is side effect free if it is a side
13270 -- effect free prefixed reference and all the indexing
13271 -- expressions are side effect free.
13273 when N_Indexed_Component =>
13275 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13276 and then Safe_Prefixed_Reference (N);
13278 -- A type qualification, type conversion, or unchecked expression is
13279 -- side effect free if the expression is side effect free.
13281 when N_Qualified_Expression
13282 | N_Type_Conversion
13283 | N_Unchecked_Expression
13285 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
13287 -- A selected component is side effect free only if it is a side
13288 -- effect free prefixed reference.
13290 when N_Selected_Component =>
13291 return Safe_Prefixed_Reference (N);
13293 -- A range is side effect free if the bounds are side effect free
13296 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
13298 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
13300 -- A slice is side effect free if it is a side effect free
13301 -- prefixed reference and the bounds are side effect free.
13305 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
13306 and then Safe_Prefixed_Reference (N);
13308 -- A unary operator is side effect free if the operand
13309 -- is side effect free.
13312 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13314 -- An unchecked type conversion is side effect free only if it
13315 -- is safe and its argument is side effect free.
13317 when N_Unchecked_Type_Conversion =>
13319 Safe_Unchecked_Type_Conversion (N)
13320 and then Side_Effect_Free
13321 (Expression (N), Name_Req, Variable_Ref);
13323 -- A literal is side effect free
13325 when N_Character_Literal
13326 | N_Integer_Literal
13332 -- An aggregate is side effect free if all its values are compile
13335 when N_Aggregate =>
13336 return Compile_Time_Known_Aggregate (N);
13338 -- We consider that anything else has side effects. This is a bit
13339 -- crude, but we are pretty close for most common cases, and we
13340 -- are certainly correct (i.e. we never return True when the
13341 -- answer should be False).
13346 end Side_Effect_Free;
13348 -- A list is side effect free if all elements of the list are side
13351 function Side_Effect_Free
13353 Name_Req : Boolean := False;
13354 Variable_Ref : Boolean := False) return Boolean
13359 if L = No_List or else L = Error_List then
13364 while Present (N) loop
13365 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
13374 end Side_Effect_Free;
13376 --------------------------------
13377 -- Side_Effect_Free_Attribute --
13378 --------------------------------
13380 function Side_Effect_Free_Attribute (Name : Name_Id) return Boolean is
13389 | Name_Wide_Wide_Image
13391 -- CodePeer doesn't want to see replicated copies of 'Image calls
13393 return not CodePeer_Mode;
13398 end Side_Effect_Free_Attribute;
13400 ----------------------------------
13401 -- Silly_Boolean_Array_Not_Test --
13402 ----------------------------------
13404 -- This procedure implements an odd and silly test. We explicitly check
13405 -- for the case where the 'First of the component type is equal to the
13406 -- 'Last of this component type, and if this is the case, we make sure
13407 -- that constraint error is raised. The reason is that the NOT is bound
13408 -- to cause CE in this case, and we will not otherwise catch it.
13410 -- No such check is required for AND and OR, since for both these cases
13411 -- False op False = False, and True op True = True. For the XOR case,
13412 -- see Silly_Boolean_Array_Xor_Test.
13414 -- Believe it or not, this was reported as a bug. Note that nearly always,
13415 -- the test will evaluate statically to False, so the code will be
13416 -- statically removed, and no extra overhead caused.
13418 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
13419 Loc : constant Source_Ptr := Sloc (N);
13420 CT : constant Entity_Id := Component_Type (T);
13423 -- The check we install is
13425 -- constraint_error when
13426 -- component_type'first = component_type'last
13427 -- and then array_type'Length /= 0)
13429 -- We need the last guard because we don't want to raise CE for empty
13430 -- arrays since no out of range values result. (Empty arrays with a
13431 -- component type of True .. True -- very useful -- even the ACATS
13432 -- does not test that marginal case).
13435 Make_Raise_Constraint_Error (Loc,
13437 Make_And_Then (Loc,
13441 Make_Attribute_Reference (Loc,
13442 Prefix => New_Occurrence_Of (CT, Loc),
13443 Attribute_Name => Name_First),
13446 Make_Attribute_Reference (Loc,
13447 Prefix => New_Occurrence_Of (CT, Loc),
13448 Attribute_Name => Name_Last)),
13450 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
13451 Reason => CE_Range_Check_Failed));
13452 end Silly_Boolean_Array_Not_Test;
13454 ----------------------------------
13455 -- Silly_Boolean_Array_Xor_Test --
13456 ----------------------------------
13458 -- This procedure implements an odd and silly test. We explicitly check
13459 -- for the XOR case where the component type is True .. True, since this
13460 -- will raise constraint error. A special check is required since CE
13461 -- will not be generated otherwise (cf Expand_Packed_Not).
13463 -- No such check is required for AND and OR, since for both these cases
13464 -- False op False = False, and True op True = True, and no check is
13465 -- required for the case of False .. False, since False xor False = False.
13466 -- See also Silly_Boolean_Array_Not_Test
13468 procedure Silly_Boolean_Array_Xor_Test
13473 Loc : constant Source_Ptr := Sloc (N);
13474 CT : constant Entity_Id := Component_Type (T);
13477 -- The check we install is
13479 -- constraint_error when
13480 -- Boolean (component_type'First)
13481 -- and then Boolean (component_type'Last)
13482 -- and then array_type'Length /= 0)
13484 -- We need the last guard because we don't want to raise CE for empty
13485 -- arrays since no out of range values result (Empty arrays with a
13486 -- component type of True .. True -- very useful -- even the ACATS
13487 -- does not test that marginal case).
13490 Make_Raise_Constraint_Error (Loc,
13492 Make_And_Then (Loc,
13494 Make_And_Then (Loc,
13496 Convert_To (Standard_Boolean,
13497 Make_Attribute_Reference (Loc,
13498 Prefix => New_Occurrence_Of (CT, Loc),
13499 Attribute_Name => Name_First)),
13502 Convert_To (Standard_Boolean,
13503 Make_Attribute_Reference (Loc,
13504 Prefix => New_Occurrence_Of (CT, Loc),
13505 Attribute_Name => Name_Last))),
13507 Right_Opnd => Make_Non_Empty_Check (Loc, R)),
13508 Reason => CE_Range_Check_Failed));
13509 end Silly_Boolean_Array_Xor_Test;
13511 ----------------------------
13512 -- Small_Integer_Type_For --
13513 ----------------------------
13515 function Small_Integer_Type_For (S : Uint; Uns : Boolean) return Entity_Id
13518 pragma Assert (S <= System_Max_Integer_Size);
13520 if S <= Standard_Short_Short_Integer_Size then
13522 return Standard_Short_Short_Unsigned;
13524 return Standard_Short_Short_Integer;
13527 elsif S <= Standard_Short_Integer_Size then
13529 return Standard_Short_Unsigned;
13531 return Standard_Short_Integer;
13534 elsif S <= Standard_Integer_Size then
13536 return Standard_Unsigned;
13538 return Standard_Integer;
13541 elsif S <= Standard_Long_Integer_Size then
13543 return Standard_Long_Unsigned;
13545 return Standard_Long_Integer;
13548 elsif S <= Standard_Long_Long_Integer_Size then
13550 return Standard_Long_Long_Unsigned;
13552 return Standard_Long_Long_Integer;
13555 elsif S <= Standard_Long_Long_Long_Integer_Size then
13557 return Standard_Long_Long_Long_Unsigned;
13559 return Standard_Long_Long_Long_Integer;
13563 raise Program_Error;
13565 end Small_Integer_Type_For;
13567 --------------------------
13568 -- Target_Has_Fixed_Ops --
13569 --------------------------
13571 Integer_Sized_Small : Ureal;
13572 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
13573 -- called (we don't want to compute it more than once).
13575 Long_Integer_Sized_Small : Ureal;
13576 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
13577 -- is called (we don't want to compute it more than once)
13579 First_Time_For_THFO : Boolean := True;
13580 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
13582 function Target_Has_Fixed_Ops
13583 (Left_Typ : Entity_Id;
13584 Right_Typ : Entity_Id;
13585 Result_Typ : Entity_Id) return Boolean
13587 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
13588 -- Return True if the given type is a fixed-point type with a small
13589 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
13590 -- an absolute value less than 1.0. This is currently limited to
13591 -- fixed-point types that map to Integer or Long_Integer.
13593 ------------------------
13594 -- Is_Fractional_Type --
13595 ------------------------
13597 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
13599 if Esize (Typ) = Standard_Integer_Size then
13600 return Small_Value (Typ) = Integer_Sized_Small;
13602 elsif Esize (Typ) = Standard_Long_Integer_Size then
13603 return Small_Value (Typ) = Long_Integer_Sized_Small;
13608 end Is_Fractional_Type;
13610 -- Start of processing for Target_Has_Fixed_Ops
13613 -- Return False if Fractional_Fixed_Ops_On_Target is false
13615 if not Fractional_Fixed_Ops_On_Target then
13619 -- Here the target has Fractional_Fixed_Ops, if first time, compute
13620 -- standard constants used by Is_Fractional_Type.
13622 if First_Time_For_THFO then
13623 First_Time_For_THFO := False;
13625 Integer_Sized_Small :=
13628 Den => UI_From_Int (Standard_Integer_Size - 1),
13631 Long_Integer_Sized_Small :=
13634 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
13638 -- Return True if target supports fixed-by-fixed multiply/divide for
13639 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
13640 -- and result types are equivalent fractional types.
13642 return Is_Fractional_Type (Base_Type (Left_Typ))
13643 and then Is_Fractional_Type (Base_Type (Right_Typ))
13644 and then Is_Fractional_Type (Base_Type (Result_Typ))
13645 and then Esize (Left_Typ) = Esize (Right_Typ)
13646 and then Esize (Left_Typ) = Esize (Result_Typ);
13647 end Target_Has_Fixed_Ops;
13649 -------------------
13650 -- Type_Map_Hash --
13651 -------------------
13653 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
13655 return Type_Map_Header (Id mod Type_Map_Size);
13658 ------------------------------------------
13659 -- Type_May_Have_Bit_Aligned_Components --
13660 ------------------------------------------
13662 function Type_May_Have_Bit_Aligned_Components
13663 (Typ : Entity_Id) return Boolean
13666 -- Array type, check component type
13668 if Is_Array_Type (Typ) then
13670 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
13672 -- Record type, check components
13674 elsif Is_Record_Type (Typ) then
13679 E := First_Component_Or_Discriminant (Typ);
13680 while Present (E) loop
13681 -- This is the crucial test: if the component itself causes
13682 -- trouble, then we can stop and return True.
13684 if Component_May_Be_Bit_Aligned (E) then
13688 -- Otherwise, we need to test its type, to see if it may
13689 -- itself contain a troublesome component.
13691 if Type_May_Have_Bit_Aligned_Components (Etype (E)) then
13695 Next_Component_Or_Discriminant (E);
13701 -- Type other than array or record is always OK
13706 end Type_May_Have_Bit_Aligned_Components;
13708 -------------------------------
13709 -- Update_Primitives_Mapping --
13710 -------------------------------
13712 procedure Update_Primitives_Mapping
13713 (Inher_Id : Entity_Id;
13714 Subp_Id : Entity_Id)
13718 (Parent_Type => Find_Dispatching_Type (Inher_Id),
13719 Derived_Type => Find_Dispatching_Type (Subp_Id));
13720 end Update_Primitives_Mapping;
13722 ----------------------------------
13723 -- Within_Case_Or_If_Expression --
13724 ----------------------------------
13726 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
13730 -- Locate an enclosing case or if expression. Note that these constructs
13731 -- can be expanded into Expression_With_Actions, hence the test of the
13735 while Present (Par) loop
13736 if Nkind (Original_Node (Par)) in N_Case_Expression | N_If_Expression
13740 -- Prevent the search from going too far
13742 elsif Is_Body_Or_Package_Declaration (Par) then
13746 Par := Parent (Par);
13750 end Within_Case_Or_If_Expression;
13752 ------------------------------
13753 -- Predicate_Check_In_Scope --
13754 ------------------------------
13756 function Predicate_Check_In_Scope (N : Node_Id) return Boolean is
13760 S := Current_Scope;
13761 while Present (S) and then not Is_Subprogram (S) loop
13765 if Present (S) then
13767 -- Predicate checks should only be enabled in init procs for
13768 -- expressions coming from source.
13770 if Is_Init_Proc (S) then
13771 return Comes_From_Source (N);
13773 elsif Get_TSS_Name (S) /= TSS_Null
13774 and then not Is_Predicate_Function (S)
13775 and then not Is_Predicate_Function_M (S)
13782 end Predicate_Check_In_Scope;