1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Checks; use Checks;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Elists; use Elists;
33 with Errout; use Errout;
34 with Exp_Aggr; use Exp_Aggr;
35 with Exp_Ch2; use Exp_Ch2;
36 with Exp_Ch6; use Exp_Ch6;
37 with Exp_Ch7; use Exp_Ch7;
38 with Exp_Ch11; use Exp_Ch11;
39 with Ghost; use Ghost;
40 with Inline; use Inline;
41 with Itypes; use Itypes;
43 with Nlists; use Nlists;
44 with Nmake; use Nmake;
46 with Restrict; use Restrict;
47 with Rident; use Rident;
49 with Sem_Aux; use Sem_Aux;
50 with Sem_Ch3; use Sem_Ch3;
51 with Sem_Ch6; use Sem_Ch6;
52 with Sem_Ch8; use Sem_Ch8;
53 with Sem_Ch12; use Sem_Ch12;
54 with Sem_Ch13; use Sem_Ch13;
55 with Sem_Disp; use Sem_Disp;
56 with Sem_Elab; use Sem_Elab;
57 with Sem_Eval; use Sem_Eval;
58 with Sem_Res; use Sem_Res;
59 with Sem_Type; use Sem_Type;
60 with Sem_Util; use Sem_Util;
61 with Snames; use Snames;
62 with Stand; use Stand;
63 with Stringt; use Stringt;
64 with Targparm; use Targparm;
65 with Tbuild; use Tbuild;
66 with Ttypes; use Ttypes;
67 with Urealp; use Urealp;
68 with Validsw; use Validsw;
71 package body Exp_Util is
73 ---------------------------------------------------------
74 -- Handling of inherited class-wide pre/postconditions --
75 ---------------------------------------------------------
77 -- Following AI12-0113, the expression for a class-wide condition is
78 -- transformed for a subprogram that inherits it, by replacing calls
79 -- to primitive operations of the original controlling type into the
80 -- corresponding overriding operations of the derived type. The following
81 -- hash table manages this mapping, and is expanded on demand whenever
82 -- such inherited expression needs to be constructed.
84 -- The mapping is also used to check whether an inherited operation has
85 -- a condition that depends on overridden operations. For such an
86 -- operation we must create a wrapper that is then treated as a normal
87 -- overriding. In SPARK mode such operations are illegal.
89 -- For a given root type there may be several type extensions with their
90 -- own overriding operations, so at various times a given operation of
91 -- the root will be mapped into different overridings. The root type is
92 -- also mapped into the current type extension to indicate that its
93 -- operations are mapped into the overriding operations of that current
96 -- The contents of the map are as follows:
100 -- Discriminant (Entity_Id) Discriminant (Entity_Id)
101 -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
102 -- Discriminant (Entity_Id) Expression (Node_Id)
103 -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
104 -- Type (Entity_Id) Type (Entity_Id)
106 Type_Map_Size : constant := 511;
108 subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
109 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
111 package Type_Map is new GNAT.HTable.Simple_HTable
112 (Header_Num => Type_Map_Header,
114 Element => Node_Or_Entity_Id,
116 Hash => Type_Map_Hash,
119 -----------------------
120 -- Local Subprograms --
121 -----------------------
123 function Build_Task_Array_Image
127 Dyn : Boolean := False) return Node_Id;
128 -- Build function to generate the image string for a task that is an array
129 -- component, concatenating the images of each index. To avoid storage
130 -- leaks, the string is built with successive slice assignments. The flag
131 -- Dyn indicates whether this is called for the initialization procedure of
132 -- an array of tasks, or for the name of a dynamically created task that is
133 -- assigned to an indexed component.
135 function Build_Task_Image_Function
139 Res : Entity_Id) return Node_Id;
140 -- Common processing for Task_Array_Image and Task_Record_Image. Build
141 -- function body that computes image.
143 procedure Build_Task_Image_Prefix
152 -- Common processing for Task_Array_Image and Task_Record_Image. Create
153 -- local variables and assign prefix of name to result string.
155 function Build_Task_Record_Image
158 Dyn : Boolean := False) return Node_Id;
159 -- Build function to generate the image string for a task that is a record
160 -- component. Concatenate name of variable with that of selector. The flag
161 -- Dyn indicates whether this is called for the initialization procedure of
162 -- record with task components, or for a dynamically created task that is
163 -- assigned to a selected component.
165 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
166 -- Force evaluation of bounds of a slice, which may be given by a range
167 -- or by a subtype indication with or without a constraint.
169 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
170 -- Determine whether pragma Default_Initial_Condition denoted by Prag has
171 -- an assertion expression that should be verified at run time.
173 function Make_CW_Equivalent_Type
175 E : Node_Id) return Entity_Id;
176 -- T is a class-wide type entity, E is the initial expression node that
177 -- constrains T in case such as: " X: T := E" or "new T'(E)". This function
178 -- returns the entity of the Equivalent type and inserts on the fly the
179 -- necessary declaration such as:
181 -- type anon is record
182 -- _parent : Root_Type (T); constrained with E discriminants (if any)
183 -- Extension : String (1 .. expr to match size of E);
186 -- This record is compatible with any object of the class of T thanks to
187 -- the first field and has the same size as E thanks to the second.
189 function Make_Literal_Range
191 Literal_Typ : Entity_Id) return Node_Id;
192 -- Produce a Range node whose bounds are:
193 -- Low_Bound (Literal_Type) ..
194 -- Low_Bound (Literal_Type) + (Length (Literal_Typ) - 1)
195 -- this is used for expanding declarations like X : String := "sdfgdfg";
197 -- If the index type of the target array is not integer, we generate:
198 -- Low_Bound (Literal_Type) ..
200 -- (Literal_Type'Pos (Low_Bound (Literal_Type))
201 -- + (Length (Literal_Typ) -1))
203 function Make_Non_Empty_Check
205 N : Node_Id) return Node_Id;
206 -- Produce a boolean expression checking that the unidimensional array
207 -- node N is not empty.
209 function New_Class_Wide_Subtype
211 N : Node_Id) return Entity_Id;
212 -- Create an implicit subtype of CW_Typ attached to node N
214 function Requires_Cleanup_Actions
217 Nested_Constructs : Boolean) return Boolean;
218 -- Given a list L, determine whether it contains one of the following:
220 -- 1) controlled objects
221 -- 2) library-level tagged types
223 -- Lib_Level is True when the list comes from a construct at the library
224 -- level, and False otherwise. Nested_Constructs is True when any nested
225 -- packages declared in L must be processed, and False otherwise.
227 -------------------------------------
228 -- Activate_Atomic_Synchronization --
229 -------------------------------------
231 procedure Activate_Atomic_Synchronization (N : Node_Id) is
235 case Nkind (Parent (N)) is
237 -- Check for cases of appearing in the prefix of a construct where we
238 -- don't need atomic synchronization for this kind of usage.
241 -- Nothing to do if we are the prefix of an attribute, since we
242 -- do not want an atomic sync operation for things like 'Size.
244 N_Attribute_Reference
246 -- The N_Reference node is like an attribute
250 -- Nothing to do for a reference to a component (or components)
251 -- of a composite object. Only reads and updates of the object
252 -- as a whole require atomic synchronization (RM C.6 (15)).
254 | N_Indexed_Component
255 | N_Selected_Component
258 -- For all the above cases, nothing to do if we are the prefix
260 if Prefix (Parent (N)) = N then
268 -- Nothing to do for the identifier in an object renaming declaration,
269 -- the renaming itself does not need atomic synchronization.
271 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
275 -- Go ahead and set the flag
277 Set_Atomic_Sync_Required (N);
279 -- Generate info message if requested
281 if Warn_On_Atomic_Synchronization then
287 | N_Selected_Component
289 Msg_Node := Selector_Name (N);
291 when N_Explicit_Dereference
292 | N_Indexed_Component
297 pragma Assert (False);
301 if Present (Msg_Node) then
303 ("info: atomic synchronization set for &?N?", Msg_Node);
306 ("info: atomic synchronization set?N?", N);
309 end Activate_Atomic_Synchronization;
311 ----------------------
312 -- Adjust_Condition --
313 ----------------------
315 procedure Adjust_Condition (N : Node_Id) is
322 Loc : constant Source_Ptr := Sloc (N);
323 T : constant Entity_Id := Etype (N);
327 -- Defend against a call where the argument has no type, or has a
328 -- type that is not Boolean. This can occur because of prior errors.
330 if No (T) or else not Is_Boolean_Type (T) then
334 -- Apply validity checking if needed
336 if Validity_Checks_On and Validity_Check_Tests then
340 -- Immediate return if standard boolean, the most common case,
341 -- where nothing needs to be done.
343 if Base_Type (T) = Standard_Boolean then
347 -- Case of zero/nonzero semantics or nonstandard enumeration
348 -- representation. In each case, we rewrite the node as:
350 -- ityp!(N) /= False'Enum_Rep
352 -- where ityp is an integer type with large enough size to hold any
355 if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
356 if Esize (T) <= Esize (Standard_Integer) then
357 Ti := Standard_Integer;
359 Ti := Standard_Long_Long_Integer;
364 Left_Opnd => Unchecked_Convert_To (Ti, N),
366 Make_Attribute_Reference (Loc,
367 Attribute_Name => Name_Enum_Rep,
369 New_Occurrence_Of (First_Literal (T), Loc))));
370 Analyze_And_Resolve (N, Standard_Boolean);
373 Rewrite (N, Convert_To (Standard_Boolean, N));
374 Analyze_And_Resolve (N, Standard_Boolean);
377 end Adjust_Condition;
379 ------------------------
380 -- Adjust_Result_Type --
381 ------------------------
383 procedure Adjust_Result_Type (N : Node_Id; T : Entity_Id) is
385 -- Ignore call if current type is not Standard.Boolean
387 if Etype (N) /= Standard_Boolean then
391 -- If result is already of correct type, nothing to do. Note that
392 -- this will get the most common case where everything has a type
393 -- of Standard.Boolean.
395 if Base_Type (T) = Standard_Boolean then
400 KP : constant Node_Kind := Nkind (Parent (N));
403 -- If result is to be used as a Condition in the syntax, no need
404 -- to convert it back, since if it was changed to Standard.Boolean
405 -- using Adjust_Condition, that is just fine for this usage.
407 if KP in N_Raise_xxx_Error or else KP in N_Has_Condition then
410 -- If result is an operand of another logical operation, no need
411 -- to reset its type, since Standard.Boolean is just fine, and
412 -- such operations always do Adjust_Condition on their operands.
414 elsif KP in N_Op_Boolean
415 or else KP in N_Short_Circuit
416 or else KP = N_Op_Not
420 -- Otherwise we perform a conversion from the current type, which
421 -- must be Standard.Boolean, to the desired type. Use the base
422 -- type to prevent spurious constraint checks that are extraneous
423 -- to the transformation. The type and its base have the same
424 -- representation, standard or otherwise.
428 Rewrite (N, Convert_To (Base_Type (T), N));
429 Analyze_And_Resolve (N, Base_Type (T));
433 end Adjust_Result_Type;
435 --------------------------
436 -- Append_Freeze_Action --
437 --------------------------
439 procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
443 Ensure_Freeze_Node (T);
444 Fnode := Freeze_Node (T);
446 if No (Actions (Fnode)) then
447 Set_Actions (Fnode, New_List (N));
449 Append (N, Actions (Fnode));
452 end Append_Freeze_Action;
454 ---------------------------
455 -- Append_Freeze_Actions --
456 ---------------------------
458 procedure Append_Freeze_Actions (T : Entity_Id; L : List_Id) is
466 Ensure_Freeze_Node (T);
467 Fnode := Freeze_Node (T);
469 if No (Actions (Fnode)) then
470 Set_Actions (Fnode, L);
472 Append_List (L, Actions (Fnode));
474 end Append_Freeze_Actions;
476 --------------------------------------
477 -- Attr_Constrained_Statically_True --
478 --------------------------------------
480 function Attribute_Constrained_Static_Value (Pref : Node_Id) return Boolean
482 Ptyp : constant Entity_Id := Etype (Pref);
483 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
485 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
486 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
487 -- view of an aliased object whose subtype is constrained.
489 ---------------------------------
490 -- Is_Constrained_Aliased_View --
491 ---------------------------------
493 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
497 if Is_Entity_Name (Obj) then
500 if Present (Renamed_Object (E)) then
501 return Is_Constrained_Aliased_View (Renamed_Object (E));
503 return Is_Aliased (E) and then Is_Constrained (Etype (E));
507 return Is_Aliased_View (Obj)
509 (Is_Constrained (Etype (Obj))
511 (Nkind (Obj) = N_Explicit_Dereference
513 not Object_Type_Has_Constrained_Partial_View
514 (Typ => Base_Type (Etype (Obj)),
515 Scop => Current_Scope)));
517 end Is_Constrained_Aliased_View;
519 -- Start of processing for Attribute_Constrained_Static_Value
522 -- We are in a case where the attribute is known statically, and
523 -- implicit dereferences have been rewritten.
526 (not (Present (Formal_Ent)
527 and then Ekind (Formal_Ent) /= E_Constant
528 and then Present (Extra_Constrained (Formal_Ent)))
530 not (Is_Access_Type (Etype (Pref))
531 and then (not Is_Entity_Name (Pref)
532 or else Is_Object (Entity (Pref))))
534 not (Nkind (Pref) = N_Identifier
535 and then Ekind (Entity (Pref)) = E_Variable
536 and then Present (Extra_Constrained (Entity (Pref)))));
538 if Is_Entity_Name (Pref) then
540 Ent : constant Entity_Id := Entity (Pref);
544 -- (RM J.4) obsolescent cases
546 if Is_Type (Ent) then
550 if Is_Private_Type (Ent) then
551 Res := not Has_Discriminants (Ent)
552 or else Is_Constrained (Ent);
554 -- It not a private type, must be a generic actual type
555 -- that corresponded to a private type. We know that this
556 -- correspondence holds, since otherwise the reference
557 -- within the generic template would have been illegal.
560 if Is_Composite_Type (Underlying_Type (Ent)) then
561 Res := Is_Constrained (Ent);
569 -- If the prefix is not a variable or is aliased, then
570 -- definitely true; if it's a formal parameter without an
571 -- associated extra formal, then treat it as constrained.
573 -- Ada 2005 (AI-363): An aliased prefix must be known to be
574 -- constrained in order to set the attribute to True.
576 if not Is_Variable (Pref)
577 or else Present (Formal_Ent)
578 or else (Ada_Version < Ada_2005
579 and then Is_Aliased_View (Pref))
580 or else (Ada_Version >= Ada_2005
581 and then Is_Constrained_Aliased_View (Pref))
585 -- Variable case, look at type to see if it is constrained.
586 -- Note that the one case where this is not accurate (the
587 -- procedure formal case), has been handled above.
589 -- We use the Underlying_Type here (and below) in case the
590 -- type is private without discriminants, but the full type
591 -- has discriminants. This case is illegal, but we generate
592 -- it internally for passing to the Extra_Constrained
596 -- In Ada 2012, test for case of a limited tagged type,
597 -- in which case the attribute is always required to
598 -- return True. The underlying type is tested, to make
599 -- sure we also return True for cases where there is an
600 -- unconstrained object with an untagged limited partial
601 -- view which has defaulted discriminants (such objects
602 -- always produce a False in earlier versions of
603 -- Ada). (Ada 2012: AI05-0214)
606 Is_Constrained (Underlying_Type (Etype (Ent)))
608 (Ada_Version >= Ada_2012
609 and then Is_Tagged_Type (Underlying_Type (Ptyp))
610 and then Is_Limited_Type (Ptyp));
617 -- Prefix is not an entity name. These are also cases where we can
618 -- always tell at compile time by looking at the form and type of the
619 -- prefix. If an explicit dereference of an object with constrained
620 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
621 -- underlying type is a limited tagged type, then Constrained is
622 -- required to always return True (Ada 2012: AI05-0214).
625 return not Is_Variable (Pref)
627 (Nkind (Pref) = N_Explicit_Dereference
629 not Object_Type_Has_Constrained_Partial_View
630 (Typ => Base_Type (Ptyp),
631 Scop => Current_Scope))
632 or else Is_Constrained (Underlying_Type (Ptyp))
633 or else (Ada_Version >= Ada_2012
634 and then Is_Tagged_Type (Underlying_Type (Ptyp))
635 and then Is_Limited_Type (Ptyp));
637 end Attribute_Constrained_Static_Value;
639 ------------------------------------
640 -- Build_Allocate_Deallocate_Proc --
641 ------------------------------------
643 procedure Build_Allocate_Deallocate_Proc
645 Is_Allocate : Boolean)
647 function Find_Object (E : Node_Id) return Node_Id;
648 -- Given an arbitrary expression of an allocator, try to find an object
649 -- reference in it, otherwise return the original expression.
651 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
652 -- Determine whether subprogram Subp denotes a custom allocate or
659 function Find_Object (E : Node_Id) return Node_Id is
663 pragma Assert (Is_Allocate);
667 if Nkind (Expr) = N_Explicit_Dereference then
668 Expr := Prefix (Expr);
670 elsif Nkind (Expr) = N_Qualified_Expression then
671 Expr := Expression (Expr);
673 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
675 -- When interface class-wide types are involved in allocation,
676 -- the expander introduces several levels of address arithmetic
677 -- to perform dispatch table displacement. In this scenario the
678 -- object appears as:
680 -- Tag_Ptr (Base_Address (<object>'Address))
682 -- Detect this case and utilize the whole expression as the
683 -- "object" since it now points to the proper dispatch table.
685 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
688 -- Continue to strip the object
691 Expr := Expression (Expr);
702 ---------------------------------
703 -- Is_Allocate_Deallocate_Proc --
704 ---------------------------------
706 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
708 -- Look for a subprogram body with only one statement which is a
709 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
711 if Ekind (Subp) = E_Procedure
712 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
715 HSS : constant Node_Id :=
716 Handled_Statement_Sequence (Parent (Parent (Subp)));
720 if Present (Statements (HSS))
721 and then Nkind (First (Statements (HSS))) =
722 N_Procedure_Call_Statement
724 Proc := Entity (Name (First (Statements (HSS))));
727 Is_RTE (Proc, RE_Allocate_Any_Controlled)
728 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
734 end Is_Allocate_Deallocate_Proc;
738 Desig_Typ : Entity_Id;
742 Proc_To_Call : Node_Id := Empty;
745 -- Start of processing for Build_Allocate_Deallocate_Proc
748 -- Obtain the attributes of the allocation / deallocation
750 if Nkind (N) = N_Free_Statement then
751 Expr := Expression (N);
752 Ptr_Typ := Base_Type (Etype (Expr));
753 Proc_To_Call := Procedure_To_Call (N);
756 if Nkind (N) = N_Object_Declaration then
757 Expr := Expression (N);
762 -- In certain cases an allocator with a qualified expression may
763 -- be relocated and used as the initialization expression of a
767 -- Obj : Ptr_Typ := new Desig_Typ'(...);
770 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
771 -- Obj : Ptr_Typ := Tmp;
773 -- Since the allocator is always marked as analyzed to avoid infinite
774 -- expansion, it will never be processed by this routine given that
775 -- the designated type needs finalization actions. Detect this case
776 -- and complete the expansion of the allocator.
778 if Nkind (Expr) = N_Identifier
779 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
780 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
782 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
786 -- The allocator may have been rewritten into something else in which
787 -- case the expansion performed by this routine does not apply.
789 if Nkind (Expr) /= N_Allocator then
793 Ptr_Typ := Base_Type (Etype (Expr));
794 Proc_To_Call := Procedure_To_Call (Expr);
797 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
798 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
800 -- Handle concurrent types
802 if Is_Concurrent_Type (Desig_Typ)
803 and then Present (Corresponding_Record_Type (Desig_Typ))
805 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
808 -- Do not process allocations / deallocations without a pool
813 -- Do not process allocations on / deallocations from the secondary
816 elsif Is_RTE (Pool_Id, RE_SS_Pool)
817 or else (Nkind (Expr) = N_Allocator
818 and then Is_RTE (Storage_Pool (Expr), RE_SS_Pool))
822 -- Optimize the case where we are using the default Global_Pool_Object,
823 -- and we don't need the heavy finalization machinery.
825 elsif Pool_Id = RTE (RE_Global_Pool_Object)
826 and then not Needs_Finalization (Desig_Typ)
830 -- Do not replicate the machinery if the allocator / free has already
831 -- been expanded and has a custom Allocate / Deallocate.
833 elsif Present (Proc_To_Call)
834 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
839 -- Finalization actions are required when the object to be allocated or
840 -- deallocated needs these actions and the associated access type is not
841 -- subject to pragma No_Heap_Finalization.
844 Needs_Finalization (Desig_Typ)
845 and then not No_Heap_Finalization (Ptr_Typ);
849 -- Do nothing if the access type may never allocate / deallocate
852 if No_Pool_Assigned (Ptr_Typ) then
856 -- The allocation / deallocation of a controlled object must be
857 -- chained on / detached from a finalization master.
859 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
861 -- The only other kind of allocation / deallocation supported by this
862 -- routine is on / from a subpool.
864 elsif Nkind (Expr) = N_Allocator
865 and then No (Subpool_Handle_Name (Expr))
871 Loc : constant Source_Ptr := Sloc (N);
872 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
873 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
874 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
875 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
878 Fin_Addr_Id : Entity_Id;
879 Fin_Mas_Act : Node_Id;
880 Fin_Mas_Id : Entity_Id;
881 Proc_To_Call : Entity_Id;
882 Subpool : Node_Id := Empty;
885 -- Step 1: Construct all the actuals for the call to library routine
886 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
890 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
896 if Nkind (Expr) = N_Allocator then
897 Subpool := Subpool_Handle_Name (Expr);
900 -- If a subpool is present it can be an arbitrary name, so make
901 -- the actual by copying the tree.
903 if Present (Subpool) then
904 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
906 Append_To (Actuals, Make_Null (Loc));
909 -- c) Finalization master
912 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
913 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
915 -- Handle the case where the master is actually a pointer to a
916 -- master. This case arises in build-in-place functions.
918 if Is_Access_Type (Etype (Fin_Mas_Id)) then
919 Append_To (Actuals, Fin_Mas_Act);
922 Make_Attribute_Reference (Loc,
923 Prefix => Fin_Mas_Act,
924 Attribute_Name => Name_Unrestricted_Access));
927 Append_To (Actuals, Make_Null (Loc));
930 -- d) Finalize_Address
932 -- Primitive Finalize_Address is never generated in CodePeer mode
933 -- since it contains an Unchecked_Conversion.
935 if Needs_Fin and then not CodePeer_Mode then
936 Fin_Addr_Id := Finalize_Address (Desig_Typ);
937 pragma Assert (Present (Fin_Addr_Id));
940 Make_Attribute_Reference (Loc,
941 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
942 Attribute_Name => Name_Unrestricted_Access));
944 Append_To (Actuals, Make_Null (Loc));
952 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
953 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
955 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
956 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
958 -- For deallocation of class-wide types we obtain the value of
959 -- alignment from the Type Specific Record of the deallocated object.
960 -- This is needed because the frontend expansion of class-wide types
961 -- into equivalent types confuses the back end.
967 -- ... because 'Alignment applied to class-wide types is expanded
968 -- into the code that reads the value of alignment from the TSD
969 -- (see Expand_N_Attribute_Reference)
972 Unchecked_Convert_To (RTE (RE_Storage_Offset),
973 Make_Attribute_Reference (Loc,
975 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
976 Attribute_Name => Name_Alignment)));
982 Is_Controlled : declare
983 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
991 Temp := Find_Object (Expression (Expr));
996 -- Processing for allocations where the expression is a subtype
1000 and then Is_Entity_Name (Temp)
1001 and then Is_Type (Entity (Temp))
1006 (Needs_Finalization (Entity (Temp))), Loc);
1008 -- The allocation / deallocation of a class-wide object relies
1009 -- on a runtime check to determine whether the object is truly
1010 -- controlled or not. Depending on this check, the finalization
1011 -- machinery will request or reclaim extra storage reserved for
1014 elsif Is_Class_Wide_Type (Desig_Typ) then
1016 -- Detect a special case where interface class-wide types
1017 -- are involved as the object appears as:
1019 -- Tag_Ptr (Base_Address (<object>'Address))
1021 -- The expression already yields the proper tag, generate:
1025 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
1027 Make_Explicit_Dereference (Loc,
1028 Prefix => Relocate_Node (Temp));
1030 -- In the default case, obtain the tag of the object about
1031 -- to be allocated / deallocated. Generate:
1035 -- If the object is an unchecked conversion (typically to
1036 -- an access to class-wide type), we must preserve the
1037 -- conversion to ensure that the object is seen as tagged
1038 -- in the code that follows.
1043 if Nkind (Parent (Pref)) = N_Unchecked_Type_Conversion
1045 Pref := Parent (Pref);
1049 Make_Attribute_Reference (Loc,
1050 Prefix => Relocate_Node (Pref),
1051 Attribute_Name => Name_Tag);
1055 -- Needs_Finalization (<Param>)
1058 Make_Function_Call (Loc,
1060 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
1061 Parameter_Associations => New_List (Param));
1063 -- Processing for generic actuals
1065 elsif Is_Generic_Actual_Type (Desig_Typ) then
1067 New_Occurrence_Of (Boolean_Literals
1068 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
1070 -- The object does not require any specialized checks, it is
1071 -- known to be controlled.
1074 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
1077 -- Create the temporary which represents the finalization state
1078 -- of the expression. Generate:
1080 -- F : constant Boolean := <Flag_Expr>;
1083 Make_Object_Declaration (Loc,
1084 Defining_Identifier => Flag_Id,
1085 Constant_Present => True,
1086 Object_Definition =>
1087 New_Occurrence_Of (Standard_Boolean, Loc),
1088 Expression => Flag_Expr));
1090 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
1093 -- The object is not controlled
1096 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
1103 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
1106 -- Step 2: Build a wrapper Allocate / Deallocate which internally
1107 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
1109 -- Select the proper routine to call
1112 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
1114 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
1117 -- Create a custom Allocate / Deallocate routine which has identical
1118 -- profile to that of System.Storage_Pools.
1121 Make_Subprogram_Body (Loc,
1126 Make_Procedure_Specification (Loc,
1127 Defining_Unit_Name => Proc_Id,
1128 Parameter_Specifications => New_List (
1130 -- P : Root_Storage_Pool
1132 Make_Parameter_Specification (Loc,
1133 Defining_Identifier => Make_Temporary (Loc, 'P'),
1135 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
1137 -- A : [out] Address
1139 Make_Parameter_Specification (Loc,
1140 Defining_Identifier => Addr_Id,
1141 Out_Present => Is_Allocate,
1143 New_Occurrence_Of (RTE (RE_Address), Loc)),
1145 -- S : Storage_Count
1147 Make_Parameter_Specification (Loc,
1148 Defining_Identifier => Size_Id,
1150 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)),
1152 -- L : Storage_Count
1154 Make_Parameter_Specification (Loc,
1155 Defining_Identifier => Alig_Id,
1157 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
1159 Declarations => No_List,
1161 Handled_Statement_Sequence =>
1162 Make_Handled_Sequence_Of_Statements (Loc,
1163 Statements => New_List (
1164 Make_Procedure_Call_Statement (Loc,
1166 New_Occurrence_Of (Proc_To_Call, Loc),
1167 Parameter_Associations => Actuals)))),
1168 Suppress => All_Checks);
1170 -- The newly generated Allocate / Deallocate becomes the default
1171 -- procedure to call when the back end processes the allocation /
1175 Set_Procedure_To_Call (Expr, Proc_Id);
1177 Set_Procedure_To_Call (N, Proc_Id);
1180 end Build_Allocate_Deallocate_Proc;
1182 -------------------------------
1183 -- Build_Abort_Undefer_Block --
1184 -------------------------------
1186 function Build_Abort_Undefer_Block
1189 Context : Node_Id) return Node_Id
1191 Exceptions_OK : constant Boolean :=
1192 not Restriction_Active (No_Exception_Propagation);
1200 -- The block should be generated only when undeferring abort in the
1201 -- context of a potential exception.
1203 pragma Assert (Abort_Allowed and Exceptions_OK);
1209 -- Abort_Undefer_Direct;
1212 AUD := RTE (RE_Abort_Undefer_Direct);
1215 Make_Handled_Sequence_Of_Statements (Loc,
1216 Statements => Stmts,
1217 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1220 Make_Block_Statement (Loc,
1221 Handled_Statement_Sequence => HSS);
1222 Set_Is_Abort_Block (Blk);
1224 Add_Block_Identifier (Blk, Blk_Id);
1225 Expand_At_End_Handler (HSS, Blk_Id);
1227 -- Present the Abort_Undefer_Direct function to the back end to inline
1228 -- the call to the routine.
1230 Add_Inlined_Body (AUD, Context);
1233 end Build_Abort_Undefer_Block;
1235 ---------------------------------
1236 -- Build_Class_Wide_Expression --
1237 ---------------------------------
1239 procedure Build_Class_Wide_Expression
1242 Par_Subp : Entity_Id;
1243 Adjust_Sloc : Boolean;
1244 Needs_Wrapper : out Boolean)
1246 function Replace_Entity (N : Node_Id) return Traverse_Result;
1247 -- Replace reference to formal of inherited operation or to primitive
1248 -- operation of root type, with corresponding entity for derived type,
1249 -- when constructing the class-wide condition of an overriding
1252 --------------------
1253 -- Replace_Entity --
1254 --------------------
1256 function Replace_Entity (N : Node_Id) return Traverse_Result is
1261 Adjust_Inherited_Pragma_Sloc (N);
1264 if Nkind (N) = N_Identifier
1265 and then Present (Entity (N))
1267 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
1269 (Nkind (Parent (N)) /= N_Attribute_Reference
1270 or else Attribute_Name (Parent (N)) /= Name_Class)
1272 -- The replacement does not apply to dispatching calls within the
1273 -- condition, but only to calls whose static tag is that of the
1276 if Is_Subprogram (Entity (N))
1277 and then Nkind (Parent (N)) = N_Function_Call
1278 and then Present (Controlling_Argument (Parent (N)))
1283 -- Determine whether entity has a renaming
1285 New_E := Type_Map.Get (Entity (N));
1287 if Present (New_E) then
1288 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
1290 -- AI12-0166: a precondition for a protected operation
1291 -- cannot include an internal call to a protected function
1292 -- of the type. In the case of an inherited condition for an
1293 -- overriding operation, both the operation and the function
1294 -- are given by primitive wrappers.
1296 if Ekind (New_E) = E_Function
1297 and then Is_Primitive_Wrapper (New_E)
1298 and then Is_Primitive_Wrapper (Subp)
1299 and then Scope (Subp) = Scope (New_E)
1301 Error_Msg_Node_2 := Wrapped_Entity (Subp);
1303 ("internal call to& cannot appear in inherited "
1304 & "precondition of protected operation&",
1305 N, Wrapped_Entity (New_E));
1308 -- If the entity is an overridden primitive and we are not
1309 -- in GNATprove mode, we must build a wrapper for the current
1310 -- inherited operation. If the reference is the prefix of an
1311 -- attribute such as 'Result (or others ???) there is no need
1312 -- for a wrapper: the condition is just rewritten in terms of
1313 -- the inherited subprogram.
1315 if Is_Subprogram (New_E)
1316 and then Nkind (Parent (N)) /= N_Attribute_Reference
1317 and then not GNATprove_Mode
1319 Needs_Wrapper := True;
1323 -- Check that there are no calls left to abstract operations if
1324 -- the current subprogram is not abstract.
1326 if Nkind (Parent (N)) = N_Function_Call
1327 and then N = Name (Parent (N))
1329 if not Is_Abstract_Subprogram (Subp)
1330 and then Is_Abstract_Subprogram (Entity (N))
1332 Error_Msg_Sloc := Sloc (Current_Scope);
1333 Error_Msg_Node_2 := Subp;
1334 if Comes_From_Source (Subp) then
1336 ("cannot call abstract subprogram & in inherited "
1337 & "condition for&#", Subp, Entity (N));
1340 ("cannot call abstract subprogram & in inherited "
1341 & "condition for inherited&#", Subp, Entity (N));
1344 -- In SPARK mode, reject an inherited condition for an
1345 -- inherited operation if it contains a call to an overriding
1346 -- operation, because this implies that the pre/postconditions
1347 -- of the inherited operation have changed silently.
1349 elsif SPARK_Mode = On
1350 and then Warn_On_Suspicious_Contract
1351 and then Present (Alias (Subp))
1352 and then Present (New_E)
1353 and then Comes_From_Source (New_E)
1356 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
1358 Error_Msg_Sloc := Sloc (New_E);
1359 Error_Msg_Node_2 := Subp;
1361 ("\overriding of&# forces overriding of&",
1362 Parent (Subp), New_E);
1366 -- Update type of function call node, which should be the same as
1367 -- the function's return type.
1369 if Is_Subprogram (Entity (N))
1370 and then Nkind (Parent (N)) = N_Function_Call
1372 Set_Etype (Parent (N), Etype (Entity (N)));
1375 -- The whole expression will be reanalyzed
1377 elsif Nkind (N) in N_Has_Etype then
1378 Set_Analyzed (N, False);
1384 procedure Replace_Condition_Entities is
1385 new Traverse_Proc (Replace_Entity);
1389 Par_Formal : Entity_Id;
1390 Subp_Formal : Entity_Id;
1392 -- Start of processing for Build_Class_Wide_Expression
1395 Needs_Wrapper := False;
1397 -- Add mapping from old formals to new formals
1399 Par_Formal := First_Formal (Par_Subp);
1400 Subp_Formal := First_Formal (Subp);
1402 while Present (Par_Formal) and then Present (Subp_Formal) loop
1403 Type_Map.Set (Par_Formal, Subp_Formal);
1404 Next_Formal (Par_Formal);
1405 Next_Formal (Subp_Formal);
1408 Replace_Condition_Entities (Prag);
1409 end Build_Class_Wide_Expression;
1411 --------------------
1412 -- Build_DIC_Call --
1413 --------------------
1415 function Build_DIC_Call
1418 Typ : Entity_Id) return Node_Id
1420 Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
1421 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1425 Make_Procedure_Call_Statement (Loc,
1426 Name => New_Occurrence_Of (Proc_Id, Loc),
1427 Parameter_Associations => New_List (
1428 Make_Unchecked_Type_Conversion (Loc,
1429 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1430 Expression => New_Occurrence_Of (Obj_Id, Loc))));
1433 ------------------------------
1434 -- Build_DIC_Procedure_Body --
1435 ------------------------------
1437 -- WARNING: This routine manages Ghost regions. Return statements must be
1438 -- replaced by gotos which jump to the end of the routine and restore the
1441 procedure Build_DIC_Procedure_Body
1443 For_Freeze : Boolean := False)
1445 procedure Add_DIC_Check
1446 (DIC_Prag : Node_Id;
1448 Stmts : in out List_Id);
1449 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1450 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1451 -- is added to list Stmts.
1453 procedure Add_Inherited_DIC
1454 (DIC_Prag : Node_Id;
1455 Par_Typ : Entity_Id;
1456 Deriv_Typ : Entity_Id;
1457 Stmts : in out List_Id);
1458 -- Add a runtime check to verify the assertion expression of inherited
1459 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1460 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1461 -- pragma. All generated code is added to list Stmts.
1463 procedure Add_Inherited_Tagged_DIC
1464 (DIC_Prag : Node_Id;
1465 Par_Typ : Entity_Id;
1466 Deriv_Typ : Entity_Id;
1467 Stmts : in out List_Id);
1468 -- Add a runtime check to verify assertion expression DIC_Expr of
1469 -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
1470 -- postcondition-like runtime semantics to the check. Par_Typ is the
1471 -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
1472 -- derived type inheriting the DIC pragma. All generated code is added
1475 procedure Add_Own_DIC
1476 (DIC_Prag : Node_Id;
1477 DIC_Typ : Entity_Id;
1478 Stmts : in out List_Id);
1479 -- Add a runtime check to verify the assertion expression of pragma
1480 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
1481 -- is added to list Stmts.
1487 procedure Add_DIC_Check
1488 (DIC_Prag : Node_Id;
1490 Stmts : in out List_Id)
1492 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1493 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1496 -- The DIC pragma is ignored, nothing left to do
1498 if Is_Ignored (DIC_Prag) then
1501 -- Otherwise the DIC expression must be checked at run time.
1504 -- pragma Check (<Nam>, <DIC_Expr>);
1507 Append_New_To (Stmts,
1509 Pragma_Identifier =>
1510 Make_Identifier (Loc, Name_Check),
1512 Pragma_Argument_Associations => New_List (
1513 Make_Pragma_Argument_Association (Loc,
1514 Expression => Make_Identifier (Loc, Nam)),
1516 Make_Pragma_Argument_Association (Loc,
1517 Expression => DIC_Expr))));
1521 -----------------------
1522 -- Add_Inherited_DIC --
1523 -----------------------
1525 procedure Add_Inherited_DIC
1526 (DIC_Prag : Node_Id;
1527 Par_Typ : Entity_Id;
1528 Deriv_Typ : Entity_Id;
1529 Stmts : in out List_Id)
1531 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1532 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1533 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1534 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1535 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1538 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1540 -- Verify the inherited DIC assertion expression by calling the DIC
1541 -- procedure of the parent type.
1544 -- <Par_Typ>DIC (Par_Typ (_object));
1546 Append_New_To (Stmts,
1547 Make_Procedure_Call_Statement (Loc,
1548 Name => New_Occurrence_Of (Par_Proc, Loc),
1549 Parameter_Associations => New_List (
1551 (Typ => Etype (Par_Obj),
1552 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1553 end Add_Inherited_DIC;
1555 ------------------------------
1556 -- Add_Inherited_Tagged_DIC --
1557 ------------------------------
1559 procedure Add_Inherited_Tagged_DIC
1560 (DIC_Prag : Node_Id;
1561 Par_Typ : Entity_Id;
1562 Deriv_Typ : Entity_Id;
1563 Stmts : in out List_Id)
1565 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1566 DIC_Args : constant List_Id :=
1567 Pragma_Argument_Associations (DIC_Prag);
1568 DIC_Arg : constant Node_Id := First (DIC_Args);
1569 DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
1570 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1575 -- The processing of an inherited DIC assertion expression starts off
1576 -- with a copy of the original parent expression where all references
1577 -- to the parent type have already been replaced with references to
1578 -- the _object formal parameter of the parent type's DIC procedure.
1580 pragma Assert (Present (DIC_Expr));
1581 Expr := New_Copy_Tree (DIC_Expr);
1583 -- Perform the following substitutions:
1585 -- * Replace a reference to the _object parameter of the parent
1586 -- type's DIC procedure with a reference to the _object parameter
1587 -- of the derived types' DIC procedure.
1589 -- * Replace a reference to a discriminant of the parent type with
1590 -- a suitable value from the point of view of the derived type.
1592 -- * Replace a call to an overridden parent primitive with a call
1593 -- to the overriding derived type primitive.
1595 -- * Replace a call to an inherited parent primitive with a call to
1596 -- the internally-generated inherited derived type primitive.
1598 -- Note that primitives defined in the private part are automatically
1599 -- handled by the overriding/inheritance mechanism and do not require
1600 -- an extra replacement pass.
1602 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1607 Deriv_Typ => Deriv_Typ,
1608 Par_Obj => First_Formal (Par_Proc),
1609 Deriv_Obj => First_Formal (Deriv_Proc));
1611 -- Once the DIC assertion expression is fully processed, add a check
1612 -- to the statements of the DIC procedure.
1615 (DIC_Prag => DIC_Prag,
1618 end Add_Inherited_Tagged_DIC;
1624 procedure Add_Own_DIC
1625 (DIC_Prag : Node_Id;
1626 DIC_Typ : Entity_Id;
1627 Stmts : in out List_Id)
1629 DIC_Args : constant List_Id :=
1630 Pragma_Argument_Associations (DIC_Prag);
1631 DIC_Arg : constant Node_Id := First (DIC_Args);
1632 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1633 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1634 DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
1635 Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
1637 procedure Preanalyze_Own_DIC_For_ASIS;
1638 -- Preanalyze the original DIC expression of an aspect or a source
1641 ---------------------------------
1642 -- Preanalyze_Own_DIC_For_ASIS --
1643 ---------------------------------
1645 procedure Preanalyze_Own_DIC_For_ASIS is
1646 Expr : Node_Id := Empty;
1649 -- The DIC pragma is a source construct, preanalyze the original
1650 -- expression of the pragma.
1652 if Comes_From_Source (DIC_Prag) then
1655 -- Otherwise preanalyze the expression of the corresponding aspect
1657 elsif Present (DIC_Asp) then
1658 Expr := Expression (DIC_Asp);
1661 -- The expression must be subjected to the same substitutions as
1662 -- the copy used in the generation of the runtime check.
1664 if Present (Expr) then
1665 Replace_Type_References
1670 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1672 end Preanalyze_Own_DIC_For_ASIS;
1676 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1680 -- Start of processing for Add_Own_DIC
1683 pragma Assert (Present (DIC_Expr));
1684 Expr := New_Copy_Tree (DIC_Expr);
1686 -- Perform the following substitution:
1688 -- * Replace the current instance of DIC_Typ with a reference to
1689 -- the _object formal parameter of the DIC procedure.
1691 Replace_Type_References
1696 -- Preanalyze the DIC expression to detect errors and at the same
1697 -- time capture the visibility of the proper package part.
1699 Set_Parent (Expr, Typ_Decl);
1700 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1702 -- Save a copy of the expression with all replacements and analysis
1703 -- already taken place in case a derived type inherits the pragma.
1704 -- The copy will be used as the foundation of the derived type's own
1705 -- version of the DIC assertion expression.
1707 if Is_Tagged_Type (DIC_Typ) then
1708 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1711 -- If the pragma comes from an aspect specification, replace the
1712 -- saved expression because all type references must be substituted
1713 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1716 if Present (DIC_Asp) then
1717 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1720 -- Preanalyze the original DIC expression for ASIS
1723 Preanalyze_Own_DIC_For_ASIS;
1726 -- Once the DIC assertion expression is fully processed, add a check
1727 -- to the statements of the DIC procedure.
1730 (DIC_Prag => DIC_Prag,
1737 Loc : constant Source_Ptr := Sloc (Typ);
1739 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1740 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1741 -- Save the Ghost-related attributes to restore on exit
1744 DIC_Typ : Entity_Id;
1745 Dummy_1 : Entity_Id;
1746 Dummy_2 : Entity_Id;
1747 Proc_Body : Node_Id;
1748 Proc_Body_Id : Entity_Id;
1749 Proc_Decl : Node_Id;
1750 Proc_Id : Entity_Id;
1751 Stmts : List_Id := No_List;
1753 Build_Body : Boolean := False;
1754 -- Flag set when the type requires a DIC procedure body to be built
1756 Work_Typ : Entity_Id;
1759 -- Start of processing for Build_DIC_Procedure_Body
1762 Work_Typ := Base_Type (Typ);
1764 -- Do not process class-wide types as these are Itypes, but lack a first
1765 -- subtype (see below).
1767 if Is_Class_Wide_Type (Work_Typ) then
1770 -- Do not process the underlying full view of a private type. There is
1771 -- no way to get back to the partial view, plus the body will be built
1772 -- by the full view or the base type.
1774 elsif Is_Underlying_Full_View (Work_Typ) then
1777 -- Use the first subtype when dealing with various base types
1779 elsif Is_Itype (Work_Typ) then
1780 Work_Typ := First_Subtype (Work_Typ);
1782 -- The input denotes the corresponding record type of a protected or a
1783 -- task type. Work with the concurrent type because the corresponding
1784 -- record type may not be visible to clients of the type.
1786 elsif Ekind (Work_Typ) = E_Record_Type
1787 and then Is_Concurrent_Record_Type (Work_Typ)
1789 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
1792 -- The working type may be subject to pragma Ghost. Set the mode now to
1793 -- ensure that the DIC procedure is properly marked as Ghost.
1795 Set_Ghost_Mode (Work_Typ);
1797 -- The working type must be either define a DIC pragma of its own or
1798 -- inherit one from a parent type.
1800 pragma Assert (Has_DIC (Work_Typ));
1802 -- Recover the type which defines the DIC pragma. This is either the
1803 -- working type itself or a parent type when the pragma is inherited.
1805 DIC_Typ := Find_DIC_Type (Work_Typ);
1806 pragma Assert (Present (DIC_Typ));
1808 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
1809 pragma Assert (Present (DIC_Prag));
1811 -- Nothing to do if pragma DIC appears without an argument or its sole
1812 -- argument is "null".
1814 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
1818 -- The working type may lack a DIC procedure declaration. This may be
1819 -- due to several reasons:
1821 -- * The working type's own DIC pragma does not contain a verifiable
1822 -- assertion expression. In this case there is no need to build a
1823 -- DIC procedure because there is nothing to check.
1825 -- * The working type derives from a parent type. In this case a DIC
1826 -- procedure should be built only when the inherited DIC pragma has
1827 -- a verifiable assertion expression.
1829 Proc_Id := DIC_Procedure (Work_Typ);
1831 -- Build a DIC procedure declaration when the working type derives from
1834 if No (Proc_Id) then
1835 Build_DIC_Procedure_Declaration (Work_Typ);
1836 Proc_Id := DIC_Procedure (Work_Typ);
1839 -- At this point there should be a DIC procedure declaration
1841 pragma Assert (Present (Proc_Id));
1842 Proc_Decl := Unit_Declaration_Node (Proc_Id);
1844 -- Nothing to do if the DIC procedure already has a body
1846 if Present (Corresponding_Body (Proc_Decl)) then
1850 -- Emulate the environment of the DIC procedure by installing its scope
1851 -- and formal parameters.
1853 Push_Scope (Proc_Id);
1854 Install_Formals (Proc_Id);
1856 -- The working type defines its own DIC pragma. Replace the current
1857 -- instance of the working type with the formal of the DIC procedure.
1858 -- Note that there is no need to consider inherited DIC pragmas from
1859 -- parent types because the working type's DIC pragma "hides" all
1860 -- inherited DIC pragmas.
1862 if Has_Own_DIC (Work_Typ) then
1863 pragma Assert (DIC_Typ = Work_Typ);
1866 (DIC_Prag => DIC_Prag,
1872 -- Otherwise the working type inherits a DIC pragma from a parent type.
1873 -- This processing is carried out when the type is frozen because the
1874 -- state of all parent discriminants is known at that point. Note that
1875 -- it is semantically sound to delay the creation of the DIC procedure
1876 -- body till the freeze point. If the type has a DIC pragma of its own,
1877 -- then the DIC procedure body would have already been constructed at
1878 -- the end of the visible declarations and all parent DIC pragmas are
1879 -- effectively "hidden" and irrelevant.
1881 elsif For_Freeze then
1882 pragma Assert (Has_Inherited_DIC (Work_Typ));
1883 pragma Assert (DIC_Typ /= Work_Typ);
1885 -- The working type is tagged. The verification of the assertion
1886 -- expression is subject to the same semantics as class-wide pre-
1887 -- and postconditions.
1889 if Is_Tagged_Type (Work_Typ) then
1890 Add_Inherited_Tagged_DIC
1891 (DIC_Prag => DIC_Prag,
1893 Deriv_Typ => Work_Typ,
1896 -- Otherwise the working type is not tagged. Verify the assertion
1897 -- expression of the inherited DIC pragma by directly calling the
1898 -- DIC procedure of the parent type.
1902 (DIC_Prag => DIC_Prag,
1904 Deriv_Typ => Work_Typ,
1915 -- Produce an empty completing body in the following cases:
1916 -- * Assertions are disabled
1917 -- * The DIC Assertion_Policy is Ignore
1920 Stmts := New_List (Make_Null_Statement (Loc));
1924 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
1927 -- end <Work_Typ>DIC;
1930 Make_Subprogram_Body (Loc,
1932 Copy_Subprogram_Spec (Parent (Proc_Id)),
1933 Declarations => Empty_List,
1934 Handled_Statement_Sequence =>
1935 Make_Handled_Sequence_Of_Statements (Loc,
1936 Statements => Stmts));
1937 Proc_Body_Id := Defining_Entity (Proc_Body);
1939 -- Perform minor decoration in case the body is not analyzed
1941 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
1942 Set_Etype (Proc_Body_Id, Standard_Void_Type);
1943 Set_Scope (Proc_Body_Id, Current_Scope);
1944 Set_SPARK_Pragma (Proc_Body_Id, SPARK_Pragma (Proc_Id));
1945 Set_SPARK_Pragma_Inherited
1946 (Proc_Body_Id, SPARK_Pragma_Inherited (Proc_Id));
1948 -- Link both spec and body to avoid generating duplicates
1950 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
1951 Set_Corresponding_Spec (Proc_Body, Proc_Id);
1953 -- The body should not be inserted into the tree when the context
1954 -- is ASIS or a generic unit because it is not part of the template.
1955 -- Note that the body must still be generated in order to resolve the
1956 -- DIC assertion expression.
1958 if ASIS_Mode or Inside_A_Generic then
1961 -- Semi-insert the body into the tree for GNATprove by setting its
1962 -- Parent field. This allows for proper upstream tree traversals.
1964 elsif GNATprove_Mode then
1965 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
1967 -- Otherwise the body is part of the freezing actions of the working
1971 Append_Freeze_Action (Work_Typ, Proc_Body);
1976 Restore_Ghost_Region (Saved_GM, Saved_IGR);
1977 end Build_DIC_Procedure_Body;
1979 -------------------------------------
1980 -- Build_DIC_Procedure_Declaration --
1981 -------------------------------------
1983 -- WARNING: This routine manages Ghost regions. Return statements must be
1984 -- replaced by gotos which jump to the end of the routine and restore the
1987 procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is
1988 Loc : constant Source_Ptr := Sloc (Typ);
1990 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1991 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1992 -- Save the Ghost-related attributes to restore on exit
1995 DIC_Typ : Entity_Id;
1996 Proc_Decl : Node_Id;
1997 Proc_Id : Entity_Id;
2000 CRec_Typ : Entity_Id;
2001 -- The corresponding record type of Full_Typ
2003 Full_Base : Entity_Id;
2004 -- The base type of Full_Typ
2006 Full_Typ : Entity_Id;
2007 -- The full view of working type
2010 -- The _object formal parameter of the DIC procedure
2012 Priv_Typ : Entity_Id;
2013 -- The partial view of working type
2015 Work_Typ : Entity_Id;
2019 Work_Typ := Base_Type (Typ);
2021 -- Do not process class-wide types as these are Itypes, but lack a first
2022 -- subtype (see below).
2024 if Is_Class_Wide_Type (Work_Typ) then
2027 -- Do not process the underlying full view of a private type. There is
2028 -- no way to get back to the partial view, plus the body will be built
2029 -- by the full view or the base type.
2031 elsif Is_Underlying_Full_View (Work_Typ) then
2034 -- Use the first subtype when dealing with various base types
2036 elsif Is_Itype (Work_Typ) then
2037 Work_Typ := First_Subtype (Work_Typ);
2039 -- The input denotes the corresponding record type of a protected or a
2040 -- task type. Work with the concurrent type because the corresponding
2041 -- record type may not be visible to clients of the type.
2043 elsif Ekind (Work_Typ) = E_Record_Type
2044 and then Is_Concurrent_Record_Type (Work_Typ)
2046 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2049 -- The working type may be subject to pragma Ghost. Set the mode now to
2050 -- ensure that the DIC procedure is properly marked as Ghost.
2052 Set_Ghost_Mode (Work_Typ);
2054 -- The type must be either subject to a DIC pragma or inherit one from a
2057 pragma Assert (Has_DIC (Work_Typ));
2059 -- Recover the type which defines the DIC pragma. This is either the
2060 -- working type itself or a parent type when the pragma is inherited.
2062 DIC_Typ := Find_DIC_Type (Work_Typ);
2063 pragma Assert (Present (DIC_Typ));
2065 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
2066 pragma Assert (Present (DIC_Prag));
2068 -- Nothing to do if pragma DIC appears without an argument or its sole
2069 -- argument is "null".
2071 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
2074 -- Nothing to do if the type already has a DIC procedure
2076 elsif Present (DIC_Procedure (Work_Typ)) then
2081 Make_Defining_Identifier (Loc,
2083 New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
2085 -- Perform minor decoration in case the declaration is not analyzed
2087 Set_Ekind (Proc_Id, E_Procedure);
2088 Set_Etype (Proc_Id, Standard_Void_Type);
2089 Set_Is_DIC_Procedure (Proc_Id);
2090 Set_Scope (Proc_Id, Current_Scope);
2091 Set_SPARK_Pragma (Proc_Id, SPARK_Mode_Pragma);
2092 Set_SPARK_Pragma_Inherited (Proc_Id);
2094 Set_DIC_Procedure (Work_Typ, Proc_Id);
2096 -- The DIC procedure requires debug info when the assertion expression
2097 -- is subject to Source Coverage Obligations.
2099 if Generate_SCO then
2100 Set_Debug_Info_Needed (Proc_Id);
2103 -- Obtain all views of the input type
2105 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
2107 -- Associate the DIC procedure and various relevant flags with all views
2109 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
2110 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
2111 Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ);
2112 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
2114 -- The declaration of the DIC procedure must be inserted after the
2115 -- declaration of the partial view as this allows for proper external
2118 if Present (Priv_Typ) then
2119 Typ_Decl := Declaration_Node (Priv_Typ);
2121 -- Derived types with the full view as parent do not have a partial
2122 -- view. Insert the DIC procedure after the derived type.
2125 Typ_Decl := Declaration_Node (Full_Typ);
2128 -- The type should have a declarative node
2130 pragma Assert (Present (Typ_Decl));
2132 -- Create the formal parameter which emulates the variable-like behavior
2133 -- of the type's current instance.
2135 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
2137 -- Perform minor decoration in case the declaration is not analyzed
2139 Set_Ekind (Obj_Id, E_In_Parameter);
2140 Set_Etype (Obj_Id, Work_Typ);
2141 Set_Scope (Obj_Id, Proc_Id);
2143 Set_First_Entity (Proc_Id, Obj_Id);
2144 Set_Last_Entity (Proc_Id, Obj_Id);
2147 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
2150 Make_Subprogram_Declaration (Loc,
2152 Make_Procedure_Specification (Loc,
2153 Defining_Unit_Name => Proc_Id,
2154 Parameter_Specifications => New_List (
2155 Make_Parameter_Specification (Loc,
2156 Defining_Identifier => Obj_Id,
2158 New_Occurrence_Of (Work_Typ, Loc)))));
2160 -- The declaration should not be inserted into the tree when the context
2161 -- is ASIS or a generic unit because it is not part of the template.
2163 if ASIS_Mode or Inside_A_Generic then
2166 -- Semi-insert the declaration into the tree for GNATprove by setting
2167 -- its Parent field. This allows for proper upstream tree traversals.
2169 elsif GNATprove_Mode then
2170 Set_Parent (Proc_Decl, Parent (Typ_Decl));
2172 -- Otherwise insert the declaration
2175 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
2179 Restore_Ghost_Region (Saved_GM, Saved_IGR);
2180 end Build_DIC_Procedure_Declaration;
2182 ------------------------------------
2183 -- Build_Invariant_Procedure_Body --
2184 ------------------------------------
2186 -- WARNING: This routine manages Ghost regions. Return statements must be
2187 -- replaced by gotos which jump to the end of the routine and restore the
2190 procedure Build_Invariant_Procedure_Body
2192 Partial_Invariant : Boolean := False)
2194 Loc : constant Source_Ptr := Sloc (Typ);
2196 Pragmas_Seen : Elist_Id := No_Elist;
2197 -- This list contains all invariant pragmas processed so far. The list
2198 -- is used to avoid generating redundant invariant checks.
2200 Produced_Check : Boolean := False;
2201 -- This flag tracks whether the type has produced at least one invariant
2202 -- check. The flag is used as a sanity check at the end of the routine.
2204 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2205 -- intentionally unnested to avoid deep indentation of code.
2207 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2208 -- they emit checks, loops (for arrays) and case statements (for record
2209 -- variant parts) only when there are invariants to verify. This keeps
2210 -- the body of the invariant procedure free of useless code.
2212 procedure Add_Array_Component_Invariants
2215 Checks : in out List_Id);
2216 -- Generate an invariant check for each component of array type T.
2217 -- Obj_Id denotes the entity of the _object formal parameter of the
2218 -- invariant procedure. All created checks are added to list Checks.
2220 procedure Add_Inherited_Invariants
2222 Priv_Typ : Entity_Id;
2223 Full_Typ : Entity_Id;
2225 Checks : in out List_Id);
2226 -- Generate an invariant check for each inherited class-wide invariant
2227 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2228 -- the partial and full view of the parent type. Obj_Id denotes the
2229 -- entity of the _object formal parameter of the invariant procedure.
2230 -- All created checks are added to list Checks.
2232 procedure Add_Interface_Invariants
2235 Checks : in out List_Id);
2236 -- Generate an invariant check for each inherited class-wide invariant
2237 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2238 -- entity of the _object formal parameter of the invariant procedure.
2239 -- All created checks are added to list Checks.
2241 procedure Add_Invariant_Check
2244 Checks : in out List_Id;
2245 Inherited : Boolean := False);
2246 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2247 -- verify assertion expression Expr of pragma Prag. All generated code
2248 -- is added to list Checks. Flag Inherited should be set when the pragma
2249 -- is inherited from a parent or interface type.
2251 procedure Add_Own_Invariants
2254 Checks : in out List_Id;
2255 Priv_Item : Node_Id := Empty);
2256 -- Generate an invariant check for each invariant found for type T.
2257 -- Obj_Id denotes the entity of the _object formal parameter of the
2258 -- invariant procedure. All created checks are added to list Checks.
2259 -- Priv_Item denotes the first rep item of the private type.
2261 procedure Add_Parent_Invariants
2264 Checks : in out List_Id);
2265 -- Generate an invariant check for each inherited class-wide invariant
2266 -- coming from all parent types of type T. Obj_Id denotes the entity of
2267 -- the _object formal parameter of the invariant procedure. All created
2268 -- checks are added to list Checks.
2270 procedure Add_Record_Component_Invariants
2273 Checks : in out List_Id);
2274 -- Generate an invariant check for each component of record type T.
2275 -- Obj_Id denotes the entity of the _object formal parameter of the
2276 -- invariant procedure. All created checks are added to list Checks.
2278 ------------------------------------
2279 -- Add_Array_Component_Invariants --
2280 ------------------------------------
2282 procedure Add_Array_Component_Invariants
2285 Checks : in out List_Id)
2287 Comp_Typ : constant Entity_Id := Component_Type (T);
2288 Dims : constant Pos := Number_Dimensions (T);
2290 procedure Process_Array_Component
2292 Comp_Checks : in out List_Id);
2293 -- Generate an invariant check for an array component identified by
2294 -- the indices in list Indices. All created checks are added to list
2297 procedure Process_One_Dimension
2300 Dim_Checks : in out List_Id);
2301 -- Generate a loop over the Nth dimension Dim of an array type. List
2302 -- Indices contains all array indices for the dimension. All created
2303 -- checks are added to list Dim_Checks.
2305 -----------------------------
2306 -- Process_Array_Component --
2307 -----------------------------
2309 procedure Process_Array_Component
2311 Comp_Checks : in out List_Id)
2313 Proc_Id : Entity_Id;
2316 if Has_Invariants (Comp_Typ) then
2318 -- In GNATprove mode, the component invariants are checked by
2319 -- other means. They should not be added to the array type
2320 -- invariant procedure, so that the procedure can be used to
2321 -- check the array type invariants if any.
2323 if GNATprove_Mode then
2327 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2329 -- The component type should have an invariant procedure
2330 -- if it has invariants of its own or inherits class-wide
2331 -- invariants from parent or interface types.
2333 pragma Assert (Present (Proc_Id));
2336 -- <Comp_Typ>Invariant (_object (<Indices>));
2338 -- Note that the invariant procedure may have a null body if
2339 -- assertions are disabled or Assertion_Policy Ignore is in
2342 if not Has_Null_Body (Proc_Id) then
2343 Append_New_To (Comp_Checks,
2344 Make_Procedure_Call_Statement (Loc,
2346 New_Occurrence_Of (Proc_Id, Loc),
2347 Parameter_Associations => New_List (
2348 Make_Indexed_Component (Loc,
2349 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2350 Expressions => New_Copy_List (Indices)))));
2354 Produced_Check := True;
2356 end Process_Array_Component;
2358 ---------------------------
2359 -- Process_One_Dimension --
2360 ---------------------------
2362 procedure Process_One_Dimension
2365 Dim_Checks : in out List_Id)
2367 Comp_Checks : List_Id := No_List;
2371 -- Generate the invariant checks for the array component after all
2372 -- dimensions have produced their respective loops.
2375 Process_Array_Component
2376 (Indices => Indices,
2377 Comp_Checks => Dim_Checks);
2379 -- Otherwise create a loop for the current dimension
2382 -- Create a new loop variable for each dimension
2385 Make_Defining_Identifier (Loc,
2386 Chars => New_External_Name ('I', Dim));
2387 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2389 Process_One_Dimension
2392 Dim_Checks => Comp_Checks);
2395 -- for I<Dim> in _object'Range (<Dim>) loop
2399 -- Note that the invariant procedure may have a null body if
2400 -- assertions are disabled or Assertion_Policy Ignore is in
2403 if Present (Comp_Checks) then
2404 Append_New_To (Dim_Checks,
2405 Make_Implicit_Loop_Statement (T,
2406 Identifier => Empty,
2408 Make_Iteration_Scheme (Loc,
2409 Loop_Parameter_Specification =>
2410 Make_Loop_Parameter_Specification (Loc,
2411 Defining_Identifier => Index,
2412 Discrete_Subtype_Definition =>
2413 Make_Attribute_Reference (Loc,
2415 New_Occurrence_Of (Obj_Id, Loc),
2416 Attribute_Name => Name_Range,
2417 Expressions => New_List (
2418 Make_Integer_Literal (Loc, Dim))))),
2419 Statements => Comp_Checks));
2422 end Process_One_Dimension;
2424 -- Start of processing for Add_Array_Component_Invariants
2427 Process_One_Dimension
2429 Indices => New_List,
2430 Dim_Checks => Checks);
2431 end Add_Array_Component_Invariants;
2433 ------------------------------
2434 -- Add_Inherited_Invariants --
2435 ------------------------------
2437 procedure Add_Inherited_Invariants
2439 Priv_Typ : Entity_Id;
2440 Full_Typ : Entity_Id;
2442 Checks : in out List_Id)
2444 Deriv_Typ : Entity_Id;
2447 Prag_Expr : Node_Id;
2448 Prag_Expr_Arg : Node_Id;
2450 Prag_Typ_Arg : Node_Id;
2452 Par_Proc : Entity_Id;
2453 -- The "partial" invariant procedure of Par_Typ
2455 Par_Typ : Entity_Id;
2456 -- The suitable view of the parent type used in the substitution of
2460 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2464 -- When the type inheriting the class-wide invariant is a concurrent
2465 -- type, use the corresponding record type because it contains all
2466 -- primitive operations of the concurrent type and allows for proper
2469 if Is_Concurrent_Type (T) then
2470 Deriv_Typ := Corresponding_Record_Type (T);
2475 pragma Assert (Present (Deriv_Typ));
2477 -- Determine which rep item chain to use. Precedence is given to that
2478 -- of the parent type's partial view since it usually carries all the
2479 -- class-wide invariants.
2481 if Present (Priv_Typ) then
2482 Prag := First_Rep_Item (Priv_Typ);
2484 Prag := First_Rep_Item (Full_Typ);
2487 while Present (Prag) loop
2488 if Nkind (Prag) = N_Pragma
2489 and then Pragma_Name (Prag) = Name_Invariant
2491 -- Nothing to do if the pragma was already processed
2493 if Contains (Pragmas_Seen, Prag) then
2496 -- Nothing to do when the caller requests the processing of all
2497 -- inherited class-wide invariants, but the pragma does not
2498 -- fall in this category.
2500 elsif not Class_Present (Prag) then
2504 -- Extract the arguments of the invariant pragma
2506 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2507 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2508 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2509 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2511 -- The pragma applies to the partial view of the parent type
2513 if Present (Priv_Typ)
2514 and then Entity (Prag_Typ) = Priv_Typ
2516 Par_Typ := Priv_Typ;
2518 -- The pragma applies to the full view of the parent type
2520 elsif Present (Full_Typ)
2521 and then Entity (Prag_Typ) = Full_Typ
2523 Par_Typ := Full_Typ;
2525 -- Otherwise the pragma does not belong to the parent type and
2526 -- should not be considered.
2532 -- Perform the following substitutions:
2534 -- * Replace a reference to the _object parameter of the
2535 -- parent type's partial invariant procedure with a
2536 -- reference to the _object parameter of the derived
2537 -- type's full invariant procedure.
2539 -- * Replace a reference to a discriminant of the parent type
2540 -- with a suitable value from the point of view of the
2543 -- * Replace a call to an overridden parent primitive with a
2544 -- call to the overriding derived type primitive.
2546 -- * Replace a call to an inherited parent primitive with a
2547 -- call to the internally-generated inherited derived type
2550 Expr := New_Copy_Tree (Prag_Expr);
2552 -- The parent type must have a "partial" invariant procedure
2553 -- because class-wide invariants are captured exclusively by
2556 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2557 pragma Assert (Present (Par_Proc));
2562 Deriv_Typ => Deriv_Typ,
2563 Par_Obj => First_Formal (Par_Proc),
2564 Deriv_Obj => Obj_Id);
2566 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2569 Next_Rep_Item (Prag);
2571 end Add_Inherited_Invariants;
2573 ------------------------------
2574 -- Add_Interface_Invariants --
2575 ------------------------------
2577 procedure Add_Interface_Invariants
2580 Checks : in out List_Id)
2582 Iface_Elmt : Elmt_Id;
2586 -- Generate an invariant check for each class-wide invariant coming
2587 -- from all interfaces implemented by type T.
2589 if Is_Tagged_Type (T) then
2590 Collect_Interfaces (T, Ifaces);
2592 -- Process the class-wide invariants of all implemented interfaces
2594 Iface_Elmt := First_Elmt (Ifaces);
2595 while Present (Iface_Elmt) loop
2597 -- The Full_Typ parameter is intentionally left Empty because
2598 -- interfaces are treated as the partial view of a private type
2599 -- in order to achieve uniformity with the general case.
2601 Add_Inherited_Invariants
2603 Priv_Typ => Node (Iface_Elmt),
2608 Next_Elmt (Iface_Elmt);
2611 end Add_Interface_Invariants;
2613 -------------------------
2614 -- Add_Invariant_Check --
2615 -------------------------
2617 procedure Add_Invariant_Check
2620 Checks : in out List_Id;
2621 Inherited : Boolean := False)
2623 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2624 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2625 Ploc : constant Source_Ptr := Sloc (Prag);
2626 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2632 -- The invariant is ignored, nothing left to do
2634 if Is_Ignored (Prag) then
2637 -- Otherwise the invariant is checked. Build a pragma Check to verify
2638 -- the expression at run time.
2642 Make_Pragma_Argument_Association (Ploc,
2643 Expression => Make_Identifier (Ploc, Nam)),
2644 Make_Pragma_Argument_Association (Ploc,
2645 Expression => Expr));
2647 -- Handle the String argument (if any)
2649 if Present (Str_Arg) then
2650 Str := Strval (Get_Pragma_Arg (Str_Arg));
2652 -- When inheriting an invariant, modify the message from
2653 -- "failed invariant" to "failed inherited invariant".
2656 String_To_Name_Buffer (Str);
2658 if Name_Buffer (1 .. 16) = "failed invariant" then
2659 Insert_Str_In_Name_Buffer ("inherited ", 8);
2660 Str := String_From_Name_Buffer;
2665 Make_Pragma_Argument_Association (Ploc,
2666 Expression => Make_String_Literal (Ploc, Str)));
2670 -- pragma Check (<Nam>, <Expr>, <Str>);
2672 Append_New_To (Checks,
2674 Chars => Name_Check,
2675 Pragma_Argument_Associations => Assoc));
2678 -- Output an info message when inheriting an invariant and the
2679 -- listing option is enabled.
2681 if Inherited and Opt.List_Inherited_Aspects then
2682 Error_Msg_Sloc := Sloc (Prag);
2684 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
2687 -- Add the pragma to the list of processed pragmas
2689 Append_New_Elmt (Prag, Pragmas_Seen);
2690 Produced_Check := True;
2691 end Add_Invariant_Check;
2693 ---------------------------
2694 -- Add_Parent_Invariants --
2695 ---------------------------
2697 procedure Add_Parent_Invariants
2700 Checks : in out List_Id)
2702 Dummy_1 : Entity_Id;
2703 Dummy_2 : Entity_Id;
2705 Curr_Typ : Entity_Id;
2706 -- The entity of the current type being examined
2708 Full_Typ : Entity_Id;
2709 -- The full view of Par_Typ
2711 Par_Typ : Entity_Id;
2712 -- The entity of the parent type
2714 Priv_Typ : Entity_Id;
2715 -- The partial view of Par_Typ
2718 -- Do not process array types because they cannot have true parent
2719 -- types. This also prevents the generation of a duplicate invariant
2720 -- check when the input type is an array base type because its Etype
2721 -- denotes the first subtype, both of which share the same component
2724 if Is_Array_Type (T) then
2728 -- Climb the parent type chain
2732 -- Do not consider subtypes as they inherit the invariants
2733 -- from their base types.
2735 Par_Typ := Base_Type (Etype (Curr_Typ));
2737 -- Stop the climb once the root of the parent chain is
2740 exit when Curr_Typ = Par_Typ;
2742 -- Process the class-wide invariants of the parent type
2744 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
2746 -- Process the elements of an array type
2748 if Is_Array_Type (Full_Typ) then
2749 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
2751 -- Process the components of a record type
2753 elsif Ekind (Full_Typ) = E_Record_Type then
2754 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
2757 Add_Inherited_Invariants
2759 Priv_Typ => Priv_Typ,
2760 Full_Typ => Full_Typ,
2764 Curr_Typ := Par_Typ;
2766 end Add_Parent_Invariants;
2768 ------------------------
2769 -- Add_Own_Invariants --
2770 ------------------------
2772 procedure Add_Own_Invariants
2775 Checks : in out List_Id;
2776 Priv_Item : Node_Id := Empty)
2778 ASIS_Expr : Node_Id;
2782 Prag_Expr : Node_Id;
2783 Prag_Expr_Arg : Node_Id;
2785 Prag_Typ_Arg : Node_Id;
2788 if not Present (T) then
2792 Prag := First_Rep_Item (T);
2793 while Present (Prag) loop
2794 if Nkind (Prag) = N_Pragma
2795 and then Pragma_Name (Prag) = Name_Invariant
2797 -- Stop the traversal of the rep item chain once a specific
2798 -- item is encountered.
2800 if Present (Priv_Item) and then Prag = Priv_Item then
2804 -- Nothing to do if the pragma was already processed
2806 if Contains (Pragmas_Seen, Prag) then
2810 -- Extract the arguments of the invariant pragma
2812 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2813 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2814 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
2815 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2816 Prag_Asp := Corresponding_Aspect (Prag);
2818 -- Verify the pragma belongs to T, otherwise the pragma applies
2819 -- to a parent type in which case it will be processed later by
2820 -- Add_Parent_Invariants or Add_Interface_Invariants.
2822 if Entity (Prag_Typ) /= T then
2826 Expr := New_Copy_Tree (Prag_Expr);
2828 -- Substitute all references to type T with references to the
2829 -- _object formal parameter.
2831 Replace_Type_References (Expr, T, Obj_Id);
2833 -- Preanalyze the invariant expression to detect errors and at
2834 -- the same time capture the visibility of the proper package
2837 Set_Parent (Expr, Parent (Prag_Expr));
2838 Preanalyze_Assert_Expression (Expr, Any_Boolean);
2840 -- Save a copy of the expression when T is tagged to detect
2841 -- errors and capture the visibility of the proper package part
2842 -- for the generation of inherited type invariants.
2844 if Is_Tagged_Type (T) then
2845 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
2848 -- If the pragma comes from an aspect specification, replace
2849 -- the saved expression because all type references must be
2850 -- substituted for the call to Preanalyze_Spec_Expression in
2851 -- Check_Aspect_At_xxx routines.
2853 if Present (Prag_Asp) then
2854 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
2857 -- Analyze the original invariant expression for ASIS
2862 if Comes_From_Source (Prag) then
2863 ASIS_Expr := Prag_Expr;
2864 elsif Present (Prag_Asp) then
2865 ASIS_Expr := Expression (Prag_Asp);
2868 if Present (ASIS_Expr) then
2869 Replace_Type_References (ASIS_Expr, T, Obj_Id);
2870 Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean);
2874 Add_Invariant_Check (Prag, Expr, Checks);
2877 Next_Rep_Item (Prag);
2879 end Add_Own_Invariants;
2881 -------------------------------------
2882 -- Add_Record_Component_Invariants --
2883 -------------------------------------
2885 procedure Add_Record_Component_Invariants
2888 Checks : in out List_Id)
2890 procedure Process_Component_List
2891 (Comp_List : Node_Id;
2892 CL_Checks : in out List_Id);
2893 -- Generate invariant checks for all record components found in
2894 -- component list Comp_List, including variant parts. All created
2895 -- checks are added to list CL_Checks.
2897 procedure Process_Record_Component
2898 (Comp_Id : Entity_Id;
2899 Comp_Checks : in out List_Id);
2900 -- Generate an invariant check for a record component identified by
2901 -- Comp_Id. All created checks are added to list Comp_Checks.
2903 ----------------------------
2904 -- Process_Component_List --
2905 ----------------------------
2907 procedure Process_Component_List
2908 (Comp_List : Node_Id;
2909 CL_Checks : in out List_Id)
2913 Var_Alts : List_Id := No_List;
2914 Var_Checks : List_Id := No_List;
2915 Var_Stmts : List_Id;
2917 Produced_Variant_Check : Boolean := False;
2918 -- This flag tracks whether the component has produced at least
2919 -- one invariant check.
2922 -- Traverse the component items
2924 Comp := First (Component_Items (Comp_List));
2925 while Present (Comp) loop
2926 if Nkind (Comp) = N_Component_Declaration then
2928 -- Generate the component invariant check
2930 Process_Record_Component
2931 (Comp_Id => Defining_Entity (Comp),
2932 Comp_Checks => CL_Checks);
2938 -- Traverse the variant part
2940 if Present (Variant_Part (Comp_List)) then
2941 Var := First (Variants (Variant_Part (Comp_List)));
2942 while Present (Var) loop
2943 Var_Checks := No_List;
2945 -- Generate invariant checks for all components and variant
2946 -- parts that qualify.
2948 Process_Component_List
2949 (Comp_List => Component_List (Var),
2950 CL_Checks => Var_Checks);
2952 -- The components of the current variant produced at least
2953 -- one invariant check.
2955 if Present (Var_Checks) then
2956 Var_Stmts := Var_Checks;
2957 Produced_Variant_Check := True;
2959 -- Otherwise there are either no components with invariants,
2960 -- assertions are disabled, or Assertion_Policy Ignore is in
2964 Var_Stmts := New_List (Make_Null_Statement (Loc));
2967 Append_New_To (Var_Alts,
2968 Make_Case_Statement_Alternative (Loc,
2970 New_Copy_List (Discrete_Choices (Var)),
2971 Statements => Var_Stmts));
2976 -- Create a case statement which verifies the invariant checks
2977 -- of a particular component list depending on the discriminant
2978 -- values only when there is at least one real invariant check.
2980 if Produced_Variant_Check then
2981 Append_New_To (CL_Checks,
2982 Make_Case_Statement (Loc,
2984 Make_Selected_Component (Loc,
2985 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2988 (Entity (Name (Variant_Part (Comp_List))), Loc)),
2989 Alternatives => Var_Alts));
2992 end Process_Component_List;
2994 ------------------------------
2995 -- Process_Record_Component --
2996 ------------------------------
2998 procedure Process_Record_Component
2999 (Comp_Id : Entity_Id;
3000 Comp_Checks : in out List_Id)
3002 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
3003 Proc_Id : Entity_Id;
3005 Produced_Component_Check : Boolean := False;
3006 -- This flag tracks whether the component has produced at least
3007 -- one invariant check.
3010 -- Nothing to do for internal component _parent. Note that it is
3011 -- not desirable to check whether the component comes from source
3012 -- because protected type components are relocated to an internal
3013 -- corresponding record, but still need processing.
3015 if Chars (Comp_Id) = Name_uParent then
3019 -- Verify the invariant of the component. Note that an access
3020 -- type may have an invariant when it acts as the full view of a
3021 -- private type and the invariant appears on the partial view. In
3022 -- this case verify the access value itself.
3024 if Has_Invariants (Comp_Typ) then
3026 -- In GNATprove mode, the component invariants are checked by
3027 -- other means. They should not be added to the record type
3028 -- invariant procedure, so that the procedure can be used to
3029 -- check the record type invariants if any.
3031 if GNATprove_Mode then
3035 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
3037 -- The component type should have an invariant procedure
3038 -- if it has invariants of its own or inherits class-wide
3039 -- invariants from parent or interface types.
3041 pragma Assert (Present (Proc_Id));
3044 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
3046 -- Note that the invariant procedure may have a null body if
3047 -- assertions are disabled or Assertion_Policy Ignore is in
3050 if not Has_Null_Body (Proc_Id) then
3051 Append_New_To (Comp_Checks,
3052 Make_Procedure_Call_Statement (Loc,
3054 New_Occurrence_Of (Proc_Id, Loc),
3055 Parameter_Associations => New_List (
3056 Make_Selected_Component (Loc,
3058 Unchecked_Convert_To
3059 (T, New_Occurrence_Of (Obj_Id, Loc)),
3061 New_Occurrence_Of (Comp_Id, Loc)))));
3065 Produced_Check := True;
3066 Produced_Component_Check := True;
3069 if Produced_Component_Check and then Has_Unchecked_Union (T) then
3071 ("invariants cannot be checked on components of "
3072 & "unchecked_union type &?", Comp_Id, T);
3074 end Process_Record_Component;
3081 -- Start of processing for Add_Record_Component_Invariants
3084 -- An untagged derived type inherits the components of its parent
3085 -- type. In order to avoid creating redundant invariant checks, do
3086 -- not process the components now. Instead wait until the ultimate
3087 -- parent of the untagged derivation chain is reached.
3089 if not Is_Untagged_Derivation (T) then
3090 Def := Type_Definition (Parent (T));
3092 if Nkind (Def) = N_Derived_Type_Definition then
3093 Def := Record_Extension_Part (Def);
3096 pragma Assert (Nkind (Def) = N_Record_Definition);
3097 Comps := Component_List (Def);
3099 if Present (Comps) then
3100 Process_Component_List
3101 (Comp_List => Comps,
3102 CL_Checks => Checks);
3105 end Add_Record_Component_Invariants;
3109 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3110 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3111 -- Save the Ghost-related attributes to restore on exit
3114 Priv_Item : Node_Id;
3115 Proc_Body : Node_Id;
3116 Proc_Body_Id : Entity_Id;
3117 Proc_Decl : Node_Id;
3118 Proc_Id : Entity_Id;
3119 Stmts : List_Id := No_List;
3121 CRec_Typ : Entity_Id := Empty;
3122 -- The corresponding record type of Full_Typ
3124 Full_Proc : Entity_Id := Empty;
3125 -- The entity of the "full" invariant procedure
3127 Full_Typ : Entity_Id := Empty;
3128 -- The full view of the working type
3130 Obj_Id : Entity_Id := Empty;
3131 -- The _object formal parameter of the invariant procedure
3133 Part_Proc : Entity_Id := Empty;
3134 -- The entity of the "partial" invariant procedure
3136 Priv_Typ : Entity_Id := Empty;
3137 -- The partial view of the working type
3139 Work_Typ : Entity_Id := Empty;
3142 -- Start of processing for Build_Invariant_Procedure_Body
3147 -- The input type denotes the implementation base type of a constrained
3148 -- array type. Work with the first subtype as all invariant pragmas are
3149 -- on its rep item chain.
3151 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3152 Work_Typ := First_Subtype (Work_Typ);
3154 -- The input type denotes the corresponding record type of a protected
3155 -- or task type. Work with the concurrent type because the corresponding
3156 -- record type may not be visible to clients of the type.
3158 elsif Ekind (Work_Typ) = E_Record_Type
3159 and then Is_Concurrent_Record_Type (Work_Typ)
3161 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3164 -- The working type may be subject to pragma Ghost. Set the mode now to
3165 -- ensure that the invariant procedure is properly marked as Ghost.
3167 Set_Ghost_Mode (Work_Typ);
3169 -- The type must either have invariants of its own, inherit class-wide
3170 -- invariants from parent types or interfaces, or be an array or record
3171 -- type whose components have invariants.
3173 pragma Assert (Has_Invariants (Work_Typ));
3175 -- Interfaces are treated as the partial view of a private type in order
3176 -- to achieve uniformity with the general case.
3178 if Is_Interface (Work_Typ) then
3179 Priv_Typ := Work_Typ;
3181 -- Otherwise obtain both views of the type
3184 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
3187 -- The caller requests a body for the partial invariant procedure
3189 if Partial_Invariant then
3190 Full_Proc := Invariant_Procedure (Work_Typ);
3191 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3193 -- The "full" invariant procedure body was already created
3195 if Present (Full_Proc)
3197 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
3199 -- This scenario happens only when the type is an untagged
3200 -- derivation from a private parent and the underlying full
3201 -- view was processed before the partial view.
3204 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3206 -- Nothing to do because the processing of the underlying full
3207 -- view already checked the invariants of the partial view.
3212 -- Create a declaration for the "partial" invariant procedure if it
3213 -- is not available.
3215 if No (Proc_Id) then
3216 Build_Invariant_Procedure_Declaration
3218 Partial_Invariant => True);
3220 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3223 -- The caller requests a body for the "full" invariant procedure
3226 Proc_Id := Invariant_Procedure (Work_Typ);
3227 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3229 -- Create a declaration for the "full" invariant procedure if it is
3232 if No (Proc_Id) then
3233 Build_Invariant_Procedure_Declaration (Work_Typ);
3234 Proc_Id := Invariant_Procedure (Work_Typ);
3238 -- At this point there should be an invariant procedure declaration
3240 pragma Assert (Present (Proc_Id));
3241 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3243 -- Nothing to do if the invariant procedure already has a body
3245 if Present (Corresponding_Body (Proc_Decl)) then
3249 -- Emulate the environment of the invariant procedure by installing its
3250 -- scope and formal parameters. Note that this is not needed, but having
3251 -- the scope installed helps with the detection of invariant-related
3254 Push_Scope (Proc_Id);
3255 Install_Formals (Proc_Id);
3257 Obj_Id := First_Formal (Proc_Id);
3258 pragma Assert (Present (Obj_Id));
3260 -- The "partial" invariant procedure verifies the invariants of the
3261 -- partial view only.
3263 if Partial_Invariant then
3264 pragma Assert (Present (Priv_Typ));
3271 -- Otherwise the "full" invariant procedure verifies the invariants of
3272 -- the full view, all array or record components, as well as class-wide
3273 -- invariants inherited from parent types or interfaces. In addition, it
3274 -- indirectly verifies the invariants of the partial view by calling the
3275 -- "partial" invariant procedure.
3278 pragma Assert (Present (Full_Typ));
3280 -- Check the invariants of the partial view by calling the "partial"
3281 -- invariant procedure. Generate:
3283 -- <Work_Typ>Partial_Invariant (_object);
3285 if Present (Part_Proc) then
3286 Append_New_To (Stmts,
3287 Make_Procedure_Call_Statement (Loc,
3288 Name => New_Occurrence_Of (Part_Proc, Loc),
3289 Parameter_Associations => New_List (
3290 New_Occurrence_Of (Obj_Id, Loc))));
3292 Produced_Check := True;
3297 -- Derived subtypes do not have a partial view
3299 if Present (Priv_Typ) then
3301 -- The processing of the "full" invariant procedure intentionally
3302 -- skips the partial view because a) this may result in changes of
3303 -- visibility and b) lead to duplicate checks. However, when the
3304 -- full view is the underlying full view of an untagged derived
3305 -- type whose parent type is private, partial invariants appear on
3306 -- the rep item chain of the partial view only.
3308 -- package Pack_1 is
3309 -- type Root ... is private;
3311 -- <full view of Root>
3315 -- package Pack_2 is
3316 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3317 -- <underlying full view of Child>
3320 -- As a result, the processing of the full view must also consider
3321 -- all invariants of the partial view.
3323 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3326 -- Otherwise the invariants of the partial view are ignored
3329 -- Note that the rep item chain is shared between the partial
3330 -- and full views of a type. To avoid processing the invariants
3331 -- of the partial view, signal the logic to stop when the first
3332 -- rep item of the partial view has been reached.
3334 Priv_Item := First_Rep_Item (Priv_Typ);
3336 -- Ignore the invariants of the partial view by eliminating the
3343 -- Process the invariants of the full view and in certain cases those
3344 -- of the partial view. This also handles any invariants on array or
3345 -- record components.
3351 Priv_Item => Priv_Item);
3357 Priv_Item => Priv_Item);
3359 -- Process the elements of an array type
3361 if Is_Array_Type (Full_Typ) then
3362 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3364 -- Process the components of a record type
3366 elsif Ekind (Full_Typ) = E_Record_Type then
3367 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3369 -- Process the components of a corresponding record
3371 elsif Present (CRec_Typ) then
3372 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3375 -- Process the inherited class-wide invariants of all parent types.
3376 -- This also handles any invariants on record components.
3378 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3380 -- Process the inherited class-wide invariants of all implemented
3383 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3388 -- At this point there should be at least one invariant check. If this
3389 -- is not the case, then the invariant-related flags were not properly
3390 -- set, or there is a missing invariant procedure on one of the array
3391 -- or record components.
3393 pragma Assert (Produced_Check);
3395 -- Account for the case where assertions are disabled or all invariant
3396 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3400 Stmts := New_List (Make_Null_Statement (Loc));
3404 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3407 -- end <Work_Typ>[Partial_]Invariant;
3410 Make_Subprogram_Body (Loc,
3412 Copy_Subprogram_Spec (Parent (Proc_Id)),
3413 Declarations => Empty_List,
3414 Handled_Statement_Sequence =>
3415 Make_Handled_Sequence_Of_Statements (Loc,
3416 Statements => Stmts));
3417 Proc_Body_Id := Defining_Entity (Proc_Body);
3419 -- Perform minor decoration in case the body is not analyzed
3421 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
3422 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3423 Set_Scope (Proc_Body_Id, Current_Scope);
3425 -- Link both spec and body to avoid generating duplicates
3427 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3428 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3430 -- The body should not be inserted into the tree when the context is
3431 -- ASIS or a generic unit because it is not part of the template. Note
3432 -- that the body must still be generated in order to resolve the
3435 if ASIS_Mode or Inside_A_Generic then
3438 -- Semi-insert the body into the tree for GNATprove by setting its
3439 -- Parent field. This allows for proper upstream tree traversals.
3441 elsif GNATprove_Mode then
3442 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3444 -- Otherwise the body is part of the freezing actions of the type
3447 Append_Freeze_Action (Work_Typ, Proc_Body);
3451 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3452 end Build_Invariant_Procedure_Body;
3454 -------------------------------------------
3455 -- Build_Invariant_Procedure_Declaration --
3456 -------------------------------------------
3458 -- WARNING: This routine manages Ghost regions. Return statements must be
3459 -- replaced by gotos which jump to the end of the routine and restore the
3462 procedure Build_Invariant_Procedure_Declaration
3464 Partial_Invariant : Boolean := False)
3466 Loc : constant Source_Ptr := Sloc (Typ);
3468 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3469 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
3470 -- Save the Ghost-related attributes to restore on exit
3472 Proc_Decl : Node_Id;
3473 Proc_Id : Entity_Id;
3477 CRec_Typ : Entity_Id;
3478 -- The corresponding record type of Full_Typ
3480 Full_Base : Entity_Id;
3481 -- The base type of Full_Typ
3483 Full_Typ : Entity_Id;
3484 -- The full view of working type
3487 -- The _object formal parameter of the invariant procedure
3489 Obj_Typ : Entity_Id;
3490 -- The type of the _object formal parameter
3492 Priv_Typ : Entity_Id;
3493 -- The partial view of working type
3495 Work_Typ : Entity_Id;
3501 -- The input type denotes the implementation base type of a constrained
3502 -- array type. Work with the first subtype as all invariant pragmas are
3503 -- on its rep item chain.
3505 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3506 Work_Typ := First_Subtype (Work_Typ);
3508 -- The input denotes the corresponding record type of a protected or a
3509 -- task type. Work with the concurrent type because the corresponding
3510 -- record type may not be visible to clients of the type.
3512 elsif Ekind (Work_Typ) = E_Record_Type
3513 and then Is_Concurrent_Record_Type (Work_Typ)
3515 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3518 -- The working type may be subject to pragma Ghost. Set the mode now to
3519 -- ensure that the invariant procedure is properly marked as Ghost.
3521 Set_Ghost_Mode (Work_Typ);
3523 -- The type must either have invariants of its own, inherit class-wide
3524 -- invariants from parent or interface types, or be an array or record
3525 -- type whose components have invariants.
3527 pragma Assert (Has_Invariants (Work_Typ));
3529 -- Nothing to do if the type already has a "partial" invariant procedure
3531 if Partial_Invariant then
3532 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3536 -- Nothing to do if the type already has a "full" invariant procedure
3538 elsif Present (Invariant_Procedure (Work_Typ)) then
3542 -- The caller requests the declaration of the "partial" invariant
3545 if Partial_Invariant then
3546 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3548 -- Otherwise the caller requests the declaration of the "full" invariant
3552 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3555 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3557 -- Perform minor decoration in case the declaration is not analyzed
3559 Set_Ekind (Proc_Id, E_Procedure);
3560 Set_Etype (Proc_Id, Standard_Void_Type);
3561 Set_Scope (Proc_Id, Current_Scope);
3563 if Partial_Invariant then
3564 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3565 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3567 Set_Is_Invariant_Procedure (Proc_Id);
3568 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3571 -- The invariant procedure requires debug info when the invariants are
3572 -- subject to Source Coverage Obligations.
3574 if Generate_SCO then
3575 Set_Debug_Info_Needed (Proc_Id);
3578 -- Obtain all views of the input type
3580 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
3582 -- Associate the invariant procedure with all views
3584 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3585 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3586 Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ);
3587 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3589 -- The declaration of the invariant procedure is inserted after the
3590 -- declaration of the partial view as this allows for proper external
3593 if Present (Priv_Typ) then
3594 Typ_Decl := Declaration_Node (Priv_Typ);
3596 -- Anonymous arrays in object declarations have no explicit declaration
3597 -- so use the related object declaration as the insertion point.
3599 elsif Is_Itype (Work_Typ) and then Is_Array_Type (Work_Typ) then
3600 Typ_Decl := Associated_Node_For_Itype (Work_Typ);
3602 -- Derived types with the full view as parent do not have a partial
3603 -- view. Insert the invariant procedure after the derived type.
3606 Typ_Decl := Declaration_Node (Full_Typ);
3609 -- The type should have a declarative node
3611 pragma Assert (Present (Typ_Decl));
3613 -- Create the formal parameter which emulates the variable-like behavior
3614 -- of the current type instance.
3616 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3618 -- When generating an invariant procedure declaration for an abstract
3619 -- type (including interfaces), use the class-wide type as the _object
3620 -- type. This has several desirable effects:
3622 -- * The invariant procedure does not become a primitive of the type.
3623 -- This eliminates the need to either special case the treatment of
3624 -- invariant procedures, or to make it a predefined primitive and
3625 -- force every derived type to potentially provide an empty body.
3627 -- * The invariant procedure does not need to be declared as abstract.
3628 -- This allows for a proper body, which in turn avoids redundant
3629 -- processing of the same invariants for types with multiple views.
3631 -- * The class-wide type allows for calls to abstract primitives
3632 -- within a nonabstract subprogram. The calls are treated as
3633 -- dispatching and require additional processing when they are
3634 -- remapped to call primitives of derived types. See routine
3635 -- Replace_References for details.
3637 if Is_Abstract_Type (Work_Typ) then
3638 Obj_Typ := Class_Wide_Type (Work_Typ);
3640 Obj_Typ := Work_Typ;
3643 -- Perform minor decoration in case the declaration is not analyzed
3645 Set_Ekind (Obj_Id, E_In_Parameter);
3646 Set_Etype (Obj_Id, Obj_Typ);
3647 Set_Scope (Obj_Id, Proc_Id);
3649 Set_First_Entity (Proc_Id, Obj_Id);
3650 Set_Last_Entity (Proc_Id, Obj_Id);
3653 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3656 Make_Subprogram_Declaration (Loc,
3658 Make_Procedure_Specification (Loc,
3659 Defining_Unit_Name => Proc_Id,
3660 Parameter_Specifications => New_List (
3661 Make_Parameter_Specification (Loc,
3662 Defining_Identifier => Obj_Id,
3663 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3665 -- The declaration should not be inserted into the tree when the context
3666 -- is ASIS or a generic unit because it is not part of the template.
3668 if ASIS_Mode or Inside_A_Generic then
3671 -- Semi-insert the declaration into the tree for GNATprove by setting
3672 -- its Parent field. This allows for proper upstream tree traversals.
3674 elsif GNATprove_Mode then
3675 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3677 -- Otherwise insert the declaration
3680 pragma Assert (Present (Typ_Decl));
3681 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3685 Restore_Ghost_Region (Saved_GM, Saved_IGR);
3686 end Build_Invariant_Procedure_Declaration;
3688 --------------------------
3689 -- Build_Procedure_Form --
3690 --------------------------
3692 procedure Build_Procedure_Form (N : Node_Id) is
3693 Loc : constant Source_Ptr := Sloc (N);
3694 Subp : constant Entity_Id := Defining_Entity (N);
3696 Func_Formal : Entity_Id;
3697 Proc_Formals : List_Id;
3698 Proc_Decl : Node_Id;
3701 -- No action needed if this transformation was already done, or in case
3702 -- of subprogram renaming declarations.
3704 if Nkind (Specification (N)) = N_Procedure_Specification
3705 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3710 -- Ditto when dealing with an expression function, where both the
3711 -- original expression and the generated declaration end up being
3714 if Rewritten_For_C (Subp) then
3718 Proc_Formals := New_List;
3720 -- Create a list of formal parameters with the same types as the
3723 Func_Formal := First_Formal (Subp);
3724 while Present (Func_Formal) loop
3725 Append_To (Proc_Formals,
3726 Make_Parameter_Specification (Loc,
3727 Defining_Identifier =>
3728 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
3730 New_Occurrence_Of (Etype (Func_Formal), Loc)));
3732 Next_Formal (Func_Formal);
3735 -- Add an extra out parameter to carry the function result
3738 Name_Buffer (1 .. Name_Len) := "RESULT";
3739 Append_To (Proc_Formals,
3740 Make_Parameter_Specification (Loc,
3741 Defining_Identifier =>
3742 Make_Defining_Identifier (Loc, Chars => Name_Find),
3743 Out_Present => True,
3744 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
3746 -- The new procedure declaration is inserted immediately after the
3747 -- function declaration. The processing in Build_Procedure_Body_Form
3748 -- relies on this order.
3751 Make_Subprogram_Declaration (Loc,
3753 Make_Procedure_Specification (Loc,
3754 Defining_Unit_Name =>
3755 Make_Defining_Identifier (Loc, Chars (Subp)),
3756 Parameter_Specifications => Proc_Formals));
3758 Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
3760 -- Entity of procedure must remain invisible so that it does not
3761 -- overload subsequent references to the original function.
3763 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
3765 -- Mark the function as having a procedure form and link the function
3766 -- and its internally built procedure.
3768 Set_Rewritten_For_C (Subp);
3769 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
3770 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
3771 end Build_Procedure_Form;
3773 ------------------------
3774 -- Build_Runtime_Call --
3775 ------------------------
3777 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
3779 -- If entity is not available, we can skip making the call (this avoids
3780 -- junk duplicated error messages in a number of cases).
3782 if not RTE_Available (RE) then
3783 return Make_Null_Statement (Loc);
3786 Make_Procedure_Call_Statement (Loc,
3787 Name => New_Occurrence_Of (RTE (RE), Loc));
3789 end Build_Runtime_Call;
3791 ------------------------
3792 -- Build_SS_Mark_Call --
3793 ------------------------
3795 function Build_SS_Mark_Call
3797 Mark : Entity_Id) return Node_Id
3801 -- Mark : constant Mark_Id := SS_Mark;
3804 Make_Object_Declaration (Loc,
3805 Defining_Identifier => Mark,
3806 Constant_Present => True,
3807 Object_Definition =>
3808 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
3810 Make_Function_Call (Loc,
3811 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
3812 end Build_SS_Mark_Call;
3814 ---------------------------
3815 -- Build_SS_Release_Call --
3816 ---------------------------
3818 function Build_SS_Release_Call
3820 Mark : Entity_Id) return Node_Id
3824 -- SS_Release (Mark);
3827 Make_Procedure_Call_Statement (Loc,
3829 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
3830 Parameter_Associations => New_List (
3831 New_Occurrence_Of (Mark, Loc)));
3832 end Build_SS_Release_Call;
3834 ----------------------------
3835 -- Build_Task_Array_Image --
3836 ----------------------------
3838 -- This function generates the body for a function that constructs the
3839 -- image string for a task that is an array component. The function is
3840 -- local to the init proc for the array type, and is called for each one
3841 -- of the components. The constructed image has the form of an indexed
3842 -- component, whose prefix is the outer variable of the array type.
3843 -- The n-dimensional array type has known indexes Index, Index2...
3845 -- Id_Ref is an indexed component form created by the enclosing init proc.
3846 -- Its successive indexes are Val1, Val2, ... which are the loop variables
3847 -- in the loops that call the individual task init proc on each component.
3849 -- The generated function has the following structure:
3851 -- function F return String is
3852 -- Pref : string renames Task_Name;
3853 -- T1 : String := Index1'Image (Val1);
3855 -- Tn : String := indexn'image (Valn);
3856 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
3857 -- -- Len includes commas and the end parentheses.
3858 -- Res : String (1..Len);
3859 -- Pos : Integer := Pref'Length;
3862 -- Res (1 .. Pos) := Pref;
3864 -- Res (Pos) := '(';
3866 -- Res (Pos .. Pos + T1'Length - 1) := T1;
3867 -- Pos := Pos + T1'Length;
3868 -- Res (Pos) := '.';
3871 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
3872 -- Res (Len) := ')';
3877 -- Needless to say, multidimensional arrays of tasks are rare enough that
3878 -- the bulkiness of this code is not really a concern.
3880 function Build_Task_Array_Image
3884 Dyn : Boolean := False) return Node_Id
3886 Dims : constant Nat := Number_Dimensions (A_Type);
3887 -- Number of dimensions for array of tasks
3889 Temps : array (1 .. Dims) of Entity_Id;
3890 -- Array of temporaries to hold string for each index
3896 -- Total length of generated name
3899 -- Running index for substring assignments
3901 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
3902 -- Name of enclosing variable, prefix of resulting name
3905 -- String to hold result
3908 -- Value of successive indexes
3911 -- Expression to compute total size of string
3914 -- Entity for name at one index position
3916 Decls : constant List_Id := New_List;
3917 Stats : constant List_Id := New_List;
3920 -- For a dynamic task, the name comes from the target variable. For a
3921 -- static one it is a formal of the enclosing init proc.
3924 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
3926 Make_Object_Declaration (Loc,
3927 Defining_Identifier => Pref,
3928 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3930 Make_String_Literal (Loc,
3931 Strval => String_From_Name_Buffer)));
3935 Make_Object_Renaming_Declaration (Loc,
3936 Defining_Identifier => Pref,
3937 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
3938 Name => Make_Identifier (Loc, Name_uTask_Name)));
3941 Indx := First_Index (A_Type);
3942 Val := First (Expressions (Id_Ref));
3944 for J in 1 .. Dims loop
3945 T := Make_Temporary (Loc, 'T');
3949 Make_Object_Declaration (Loc,
3950 Defining_Identifier => T,
3951 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3953 Make_Attribute_Reference (Loc,
3954 Attribute_Name => Name_Image,
3955 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
3956 Expressions => New_List (New_Copy_Tree (Val)))));
3962 Sum := Make_Integer_Literal (Loc, Dims + 1);
3968 Make_Attribute_Reference (Loc,
3969 Attribute_Name => Name_Length,
3970 Prefix => New_Occurrence_Of (Pref, Loc),
3971 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3973 for J in 1 .. Dims loop
3978 Make_Attribute_Reference (Loc,
3979 Attribute_Name => Name_Length,
3981 New_Occurrence_Of (Temps (J), Loc),
3982 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3985 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
3987 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
3990 Make_Assignment_Statement (Loc,
3992 Make_Indexed_Component (Loc,
3993 Prefix => New_Occurrence_Of (Res, Loc),
3994 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
3996 Make_Character_Literal (Loc,
3998 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
4001 Make_Assignment_Statement (Loc,
4002 Name => New_Occurrence_Of (Pos, Loc),
4005 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4006 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4008 for J in 1 .. Dims loop
4011 Make_Assignment_Statement (Loc,
4014 Prefix => New_Occurrence_Of (Res, Loc),
4017 Low_Bound => New_Occurrence_Of (Pos, Loc),
4019 Make_Op_Subtract (Loc,
4022 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4024 Make_Attribute_Reference (Loc,
4025 Attribute_Name => Name_Length,
4027 New_Occurrence_Of (Temps (J), Loc),
4029 New_List (Make_Integer_Literal (Loc, 1)))),
4030 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
4032 Expression => New_Occurrence_Of (Temps (J), Loc)));
4036 Make_Assignment_Statement (Loc,
4037 Name => New_Occurrence_Of (Pos, Loc),
4040 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4042 Make_Attribute_Reference (Loc,
4043 Attribute_Name => Name_Length,
4044 Prefix => New_Occurrence_Of (Temps (J), Loc),
4046 New_List (Make_Integer_Literal (Loc, 1))))));
4048 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
4051 Make_Assignment_Statement (Loc,
4052 Name => Make_Indexed_Component (Loc,
4053 Prefix => New_Occurrence_Of (Res, Loc),
4054 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4056 Make_Character_Literal (Loc,
4058 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
4061 Make_Assignment_Statement (Loc,
4062 Name => New_Occurrence_Of (Pos, Loc),
4065 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4066 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4070 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
4073 Make_Assignment_Statement (Loc,
4075 Make_Indexed_Component (Loc,
4076 Prefix => New_Occurrence_Of (Res, Loc),
4077 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
4079 Make_Character_Literal (Loc,
4081 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
4082 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4083 end Build_Task_Array_Image;
4085 ----------------------------
4086 -- Build_Task_Image_Decls --
4087 ----------------------------
4089 function Build_Task_Image_Decls
4093 In_Init_Proc : Boolean := False) return List_Id
4095 Decls : constant List_Id := New_List;
4096 T_Id : Entity_Id := Empty;
4098 Expr : Node_Id := Empty;
4099 Fun : Node_Id := Empty;
4100 Is_Dyn : constant Boolean :=
4101 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
4103 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
4106 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
4107 -- generate a dummy declaration only.
4109 if Restriction_Active (No_Implicit_Heap_Allocations)
4110 or else Global_Discard_Names
4112 T_Id := Make_Temporary (Loc, 'J');
4117 Make_Object_Declaration (Loc,
4118 Defining_Identifier => T_Id,
4119 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4121 Make_String_Literal (Loc,
4122 Strval => String_From_Name_Buffer)));
4125 if Nkind (Id_Ref) = N_Identifier
4126 or else Nkind (Id_Ref) = N_Defining_Identifier
4128 -- For a simple variable, the image of the task is built from
4129 -- the name of the variable. To avoid possible conflict with the
4130 -- anonymous type created for a single protected object, add a
4134 Make_Defining_Identifier (Loc,
4135 New_External_Name (Chars (Id_Ref), 'T', 1));
4137 Get_Name_String (Chars (Id_Ref));
4140 Make_String_Literal (Loc,
4141 Strval => String_From_Name_Buffer);
4143 elsif Nkind (Id_Ref) = N_Selected_Component then
4145 Make_Defining_Identifier (Loc,
4146 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
4147 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
4149 elsif Nkind (Id_Ref) = N_Indexed_Component then
4151 Make_Defining_Identifier (Loc,
4152 New_External_Name (Chars (A_Type), 'N'));
4154 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
4158 if Present (Fun) then
4159 Append (Fun, Decls);
4160 Expr := Make_Function_Call (Loc,
4161 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
4163 if not In_Init_Proc then
4164 Set_Uses_Sec_Stack (Defining_Entity (Fun));
4168 Decl := Make_Object_Declaration (Loc,
4169 Defining_Identifier => T_Id,
4170 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4171 Constant_Present => True,
4172 Expression => Expr);
4174 Append (Decl, Decls);
4176 end Build_Task_Image_Decls;
4178 -------------------------------
4179 -- Build_Task_Image_Function --
4180 -------------------------------
4182 function Build_Task_Image_Function
4186 Res : Entity_Id) return Node_Id
4192 Make_Simple_Return_Statement (Loc,
4193 Expression => New_Occurrence_Of (Res, Loc)));
4195 Spec := Make_Function_Specification (Loc,
4196 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
4197 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
4199 -- Calls to 'Image use the secondary stack, which must be cleaned up
4200 -- after the task name is built.
4202 return Make_Subprogram_Body (Loc,
4203 Specification => Spec,
4204 Declarations => Decls,
4205 Handled_Statement_Sequence =>
4206 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
4207 end Build_Task_Image_Function;
4209 -----------------------------
4210 -- Build_Task_Image_Prefix --
4211 -----------------------------
4213 procedure Build_Task_Image_Prefix
4215 Len : out Entity_Id;
4216 Res : out Entity_Id;
4217 Pos : out Entity_Id;
4224 Len := Make_Temporary (Loc, 'L', Sum);
4227 Make_Object_Declaration (Loc,
4228 Defining_Identifier => Len,
4229 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4230 Expression => Sum));
4232 Res := Make_Temporary (Loc, 'R');
4235 Make_Object_Declaration (Loc,
4236 Defining_Identifier => Res,
4237 Object_Definition =>
4238 Make_Subtype_Indication (Loc,
4239 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4241 Make_Index_Or_Discriminant_Constraint (Loc,
4245 Low_Bound => Make_Integer_Literal (Loc, 1),
4246 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4248 -- Indicate that the result is an internal temporary, so it does not
4249 -- receive a bogus initialization when declaration is expanded. This
4250 -- is both efficient, and prevents anomalies in the handling of
4251 -- dynamic objects on the secondary stack.
4253 Set_Is_Internal (Res);
4254 Pos := Make_Temporary (Loc, 'P');
4257 Make_Object_Declaration (Loc,
4258 Defining_Identifier => Pos,
4259 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4261 -- Pos := Prefix'Length;
4264 Make_Assignment_Statement (Loc,
4265 Name => New_Occurrence_Of (Pos, Loc),
4267 Make_Attribute_Reference (Loc,
4268 Attribute_Name => Name_Length,
4269 Prefix => New_Occurrence_Of (Prefix, Loc),
4270 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4272 -- Res (1 .. Pos) := Prefix;
4275 Make_Assignment_Statement (Loc,
4278 Prefix => New_Occurrence_Of (Res, Loc),
4281 Low_Bound => Make_Integer_Literal (Loc, 1),
4282 High_Bound => New_Occurrence_Of (Pos, Loc))),
4284 Expression => New_Occurrence_Of (Prefix, Loc)));
4287 Make_Assignment_Statement (Loc,
4288 Name => New_Occurrence_Of (Pos, Loc),
4291 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4292 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4293 end Build_Task_Image_Prefix;
4295 -----------------------------
4296 -- Build_Task_Record_Image --
4297 -----------------------------
4299 function Build_Task_Record_Image
4302 Dyn : Boolean := False) return Node_Id
4305 -- Total length of generated name
4308 -- Index into result
4311 -- String to hold result
4313 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4314 -- Name of enclosing variable, prefix of resulting name
4317 -- Expression to compute total size of string
4320 -- Entity for selector name
4322 Decls : constant List_Id := New_List;
4323 Stats : constant List_Id := New_List;
4326 -- For a dynamic task, the name comes from the target variable. For a
4327 -- static one it is a formal of the enclosing init proc.
4330 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4332 Make_Object_Declaration (Loc,
4333 Defining_Identifier => Pref,
4334 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4336 Make_String_Literal (Loc,
4337 Strval => String_From_Name_Buffer)));
4341 Make_Object_Renaming_Declaration (Loc,
4342 Defining_Identifier => Pref,
4343 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4344 Name => Make_Identifier (Loc, Name_uTask_Name)));
4347 Sel := Make_Temporary (Loc, 'S');
4349 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4352 Make_Object_Declaration (Loc,
4353 Defining_Identifier => Sel,
4354 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4356 Make_String_Literal (Loc,
4357 Strval => String_From_Name_Buffer)));
4359 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4365 Make_Attribute_Reference (Loc,
4366 Attribute_Name => Name_Length,
4368 New_Occurrence_Of (Pref, Loc),
4369 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4371 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4373 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
4375 -- Res (Pos) := '.';
4378 Make_Assignment_Statement (Loc,
4379 Name => Make_Indexed_Component (Loc,
4380 Prefix => New_Occurrence_Of (Res, Loc),
4381 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4383 Make_Character_Literal (Loc,
4385 Char_Literal_Value =>
4386 UI_From_Int (Character'Pos ('.')))));
4389 Make_Assignment_Statement (Loc,
4390 Name => New_Occurrence_Of (Pos, Loc),
4393 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4394 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4396 -- Res (Pos .. Len) := Selector;
4399 Make_Assignment_Statement (Loc,
4400 Name => Make_Slice (Loc,
4401 Prefix => New_Occurrence_Of (Res, Loc),
4404 Low_Bound => New_Occurrence_Of (Pos, Loc),
4405 High_Bound => New_Occurrence_Of (Len, Loc))),
4406 Expression => New_Occurrence_Of (Sel, Loc)));
4408 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4409 end Build_Task_Record_Image;
4411 ---------------------------------------
4412 -- Build_Transient_Object_Statements --
4413 ---------------------------------------
4415 procedure Build_Transient_Object_Statements
4416 (Obj_Decl : Node_Id;
4417 Fin_Call : out Node_Id;
4418 Hook_Assign : out Node_Id;
4419 Hook_Clear : out Node_Id;
4420 Hook_Decl : out Node_Id;
4421 Ptr_Decl : out Node_Id;
4422 Finalize_Obj : Boolean := True)
4424 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4425 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4426 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4428 Desig_Typ : Entity_Id;
4429 Hook_Expr : Node_Id;
4430 Hook_Id : Entity_Id;
4432 Ptr_Typ : Entity_Id;
4435 -- Recover the type of the object
4437 Desig_Typ := Obj_Typ;
4439 if Is_Access_Type (Desig_Typ) then
4440 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4443 -- Create an access type which provides a reference to the transient
4444 -- object. Generate:
4446 -- type Ptr_Typ is access all Desig_Typ;
4448 Ptr_Typ := Make_Temporary (Loc, 'A');
4449 Set_Ekind (Ptr_Typ, E_General_Access_Type);
4450 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4453 Make_Full_Type_Declaration (Loc,
4454 Defining_Identifier => Ptr_Typ,
4456 Make_Access_To_Object_Definition (Loc,
4457 All_Present => True,
4458 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4460 -- Create a temporary check which acts as a hook to the transient
4461 -- object. Generate:
4463 -- Hook : Ptr_Typ := null;
4465 Hook_Id := Make_Temporary (Loc, 'T');
4466 Set_Ekind (Hook_Id, E_Variable);
4467 Set_Etype (Hook_Id, Ptr_Typ);
4470 Make_Object_Declaration (Loc,
4471 Defining_Identifier => Hook_Id,
4472 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4473 Expression => Make_Null (Loc));
4475 -- Mark the temporary as a hook. This signals the machinery in
4476 -- Build_Finalizer to recognize this special case.
4478 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4480 -- Hook the transient object to the temporary. Generate:
4482 -- Hook := Ptr_Typ (Obj_Id);
4484 -- Hool := Obj_Id'Unrestricted_Access;
4486 if Is_Access_Type (Obj_Typ) then
4488 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4491 Make_Attribute_Reference (Loc,
4492 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4493 Attribute_Name => Name_Unrestricted_Access);
4497 Make_Assignment_Statement (Loc,
4498 Name => New_Occurrence_Of (Hook_Id, Loc),
4499 Expression => Hook_Expr);
4501 -- Crear the hook prior to finalizing the object. Generate:
4506 Make_Assignment_Statement (Loc,
4507 Name => New_Occurrence_Of (Hook_Id, Loc),
4508 Expression => Make_Null (Loc));
4510 -- Finalize the object. Generate:
4512 -- [Deep_]Finalize (Obj_Ref[.all]);
4514 if Finalize_Obj then
4515 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4517 if Is_Access_Type (Obj_Typ) then
4518 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4519 Set_Etype (Obj_Ref, Desig_Typ);
4524 (Obj_Ref => Obj_Ref,
4527 -- Otherwise finalize the hook. Generate:
4529 -- [Deep_]Finalize (Hook.all);
4535 Make_Explicit_Dereference (Loc,
4536 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4539 end Build_Transient_Object_Statements;
4541 -----------------------------
4542 -- Check_Float_Op_Overflow --
4543 -----------------------------
4545 procedure Check_Float_Op_Overflow (N : Node_Id) is
4547 -- Return if no check needed
4549 if not Is_Floating_Point_Type (Etype (N))
4550 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4552 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4553 -- and do not expand the code for float overflow checking.
4555 or else CodePeer_Mode
4560 -- Otherwise we replace the expression by
4562 -- do Tnn : constant ftype := expression;
4563 -- constraint_error when not Tnn'Valid;
4567 Loc : constant Source_Ptr := Sloc (N);
4568 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4569 Typ : constant Entity_Id := Etype (N);
4572 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4573 -- right here. We also set the node as analyzed to prevent infinite
4574 -- recursion from repeating the operation in the expansion.
4576 Set_Do_Overflow_Check (N, False);
4577 Set_Analyzed (N, True);
4579 -- Do the rewrite to include the check
4582 Make_Expression_With_Actions (Loc,
4583 Actions => New_List (
4584 Make_Object_Declaration (Loc,
4585 Defining_Identifier => Tnn,
4586 Object_Definition => New_Occurrence_Of (Typ, Loc),
4587 Constant_Present => True,
4588 Expression => Relocate_Node (N)),
4589 Make_Raise_Constraint_Error (Loc,
4593 Make_Attribute_Reference (Loc,
4594 Prefix => New_Occurrence_Of (Tnn, Loc),
4595 Attribute_Name => Name_Valid)),
4596 Reason => CE_Overflow_Check_Failed)),
4597 Expression => New_Occurrence_Of (Tnn, Loc)));
4599 Analyze_And_Resolve (N, Typ);
4601 end Check_Float_Op_Overflow;
4603 ----------------------------------
4604 -- Component_May_Be_Bit_Aligned --
4605 ----------------------------------
4607 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4611 -- If no component clause, then everything is fine, since the back end
4612 -- never misaligns from byte boundaries by default, even if there is a
4613 -- pragma Pack for the record.
4615 if No (Comp) or else No (Component_Clause (Comp)) then
4619 UT := Underlying_Type (Etype (Comp));
4621 -- It is only array and record types that cause trouble
4623 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4626 -- If we know that we have a small (64 bits or less) record or small
4627 -- bit-packed array, then everything is fine, since the back end can
4628 -- handle these cases correctly.
4630 elsif Esize (Comp) <= 64
4631 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4635 -- Otherwise if the component is not byte aligned, we know we have the
4636 -- nasty unaligned case.
4638 elsif Normalized_First_Bit (Comp) /= Uint_0
4639 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4643 -- If we are large and byte aligned, then OK at this level
4648 end Component_May_Be_Bit_Aligned;
4650 ----------------------------------------
4651 -- Containing_Package_With_Ext_Axioms --
4652 ----------------------------------------
4654 function Containing_Package_With_Ext_Axioms
4655 (E : Entity_Id) return Entity_Id
4658 -- E is the package or generic package which is externally axiomatized
4660 if Is_Package_Or_Generic_Package (E)
4661 and then Has_Annotate_Pragma_For_External_Axiomatization (E)
4666 -- If E's scope is axiomatized, E is axiomatized
4668 if Present (Scope (E)) then
4670 First_Ax_Parent_Scope : constant Entity_Id :=
4671 Containing_Package_With_Ext_Axioms (Scope (E));
4673 if Present (First_Ax_Parent_Scope) then
4674 return First_Ax_Parent_Scope;
4679 -- Otherwise, if E is a package instance, it is axiomatized if the
4680 -- corresponding generic package is axiomatized.
4682 if Ekind (E) = E_Package then
4684 Par : constant Node_Id := Parent (E);
4688 if Nkind (Par) = N_Defining_Program_Unit_Name then
4689 Decl := Parent (Par);
4694 if Present (Generic_Parent (Decl)) then
4696 Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
4702 end Containing_Package_With_Ext_Axioms;
4704 -------------------------------
4705 -- Convert_To_Actual_Subtype --
4706 -------------------------------
4708 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
4712 Act_ST := Get_Actual_Subtype (Exp);
4714 if Act_ST = Etype (Exp) then
4717 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4718 Analyze_And_Resolve (Exp, Act_ST);
4720 end Convert_To_Actual_Subtype;
4722 -----------------------------------
4723 -- Corresponding_Runtime_Package --
4724 -----------------------------------
4726 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4727 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4728 -- Return True if protected type T has one entry and the maximum queue
4731 --------------------------------
4732 -- Has_One_Entry_And_No_Queue --
4733 --------------------------------
4735 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4737 Is_First : Boolean := True;
4740 Item := First_Entity (T);
4741 while Present (Item) loop
4742 if Is_Entry (Item) then
4744 -- The protected type has more than one entry
4746 if not Is_First then
4750 -- The queue length is not one
4752 if not Restriction_Active (No_Entry_Queue)
4753 and then Get_Max_Queue_Length (Item) /= Uint_1
4765 end Has_One_Entry_And_No_Queue;
4769 Pkg_Id : RTU_Id := RTU_Null;
4771 -- Start of processing for Corresponding_Runtime_Package
4774 pragma Assert (Is_Concurrent_Type (Typ));
4776 if Is_Protected_Type (Typ) then
4777 if Has_Entries (Typ)
4779 -- A protected type without entries that covers an interface and
4780 -- overrides the abstract routines with protected procedures is
4781 -- considered equivalent to a protected type with entries in the
4782 -- context of dispatching select statements. It is sufficient to
4783 -- check for the presence of an interface list in the declaration
4784 -- node to recognize this case.
4786 or else Present (Interface_List (Parent (Typ)))
4788 -- Protected types with interrupt handlers (when not using a
4789 -- restricted profile) are also considered equivalent to
4790 -- protected types with entries. The types which are used
4791 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
4792 -- are derived from Protection_Entries.
4794 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
4795 or else Has_Interrupt_Handler (Typ)
4798 or else Restriction_Active (No_Select_Statements) = False
4799 or else not Has_One_Entry_And_No_Queue (Typ)
4800 or else (Has_Attach_Handler (Typ)
4801 and then not Restricted_Profile)
4803 Pkg_Id := System_Tasking_Protected_Objects_Entries;
4805 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
4809 Pkg_Id := System_Tasking_Protected_Objects;
4814 end Corresponding_Runtime_Package;
4816 -----------------------------------
4817 -- Current_Sem_Unit_Declarations --
4818 -----------------------------------
4820 function Current_Sem_Unit_Declarations return List_Id is
4821 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
4825 -- If the current unit is a package body, locate the visible
4826 -- declarations of the package spec.
4828 if Nkind (U) = N_Package_Body then
4829 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
4832 if Nkind (U) = N_Package_Declaration then
4833 U := Specification (U);
4834 Decls := Visible_Declarations (U);
4838 Set_Visible_Declarations (U, Decls);
4842 Decls := Declarations (U);
4846 Set_Declarations (U, Decls);
4851 end Current_Sem_Unit_Declarations;
4853 -----------------------
4854 -- Duplicate_Subexpr --
4855 -----------------------
4857 function Duplicate_Subexpr
4859 Name_Req : Boolean := False;
4860 Renaming_Req : Boolean := False) return Node_Id
4863 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4864 return New_Copy_Tree (Exp);
4865 end Duplicate_Subexpr;
4867 ---------------------------------
4868 -- Duplicate_Subexpr_No_Checks --
4869 ---------------------------------
4871 function Duplicate_Subexpr_No_Checks
4873 Name_Req : Boolean := False;
4874 Renaming_Req : Boolean := False;
4875 Related_Id : Entity_Id := Empty;
4876 Is_Low_Bound : Boolean := False;
4877 Is_High_Bound : Boolean := False) return Node_Id
4884 Name_Req => Name_Req,
4885 Renaming_Req => Renaming_Req,
4886 Related_Id => Related_Id,
4887 Is_Low_Bound => Is_Low_Bound,
4888 Is_High_Bound => Is_High_Bound);
4890 New_Exp := New_Copy_Tree (Exp);
4891 Remove_Checks (New_Exp);
4893 end Duplicate_Subexpr_No_Checks;
4895 -----------------------------------
4896 -- Duplicate_Subexpr_Move_Checks --
4897 -----------------------------------
4899 function Duplicate_Subexpr_Move_Checks
4901 Name_Req : Boolean := False;
4902 Renaming_Req : Boolean := False) return Node_Id
4907 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4908 New_Exp := New_Copy_Tree (Exp);
4909 Remove_Checks (Exp);
4911 end Duplicate_Subexpr_Move_Checks;
4913 -------------------------
4914 -- Enclosing_Init_Proc --
4915 -------------------------
4917 function Enclosing_Init_Proc return Entity_Id is
4922 while Present (S) and then S /= Standard_Standard loop
4923 if Is_Init_Proc (S) then
4931 end Enclosing_Init_Proc;
4933 --------------------
4934 -- Ensure_Defined --
4935 --------------------
4937 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
4941 -- An itype reference must only be created if this is a local itype, so
4942 -- that gigi can elaborate it on the proper objstack.
4944 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
4945 IR := Make_Itype_Reference (Sloc (N));
4946 Set_Itype (IR, Typ);
4947 Insert_Action (N, IR);
4951 --------------------
4952 -- Entry_Names_OK --
4953 --------------------
4955 function Entry_Names_OK return Boolean is
4958 not Restricted_Profile
4959 and then not Global_Discard_Names
4960 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4961 and then not Restriction_Active (No_Local_Allocators);
4968 procedure Evaluate_Name (Nam : Node_Id) is
4970 -- For an attribute reference or an indexed component, evaluate the
4971 -- prefix, which is itself a name, recursively, and then force the
4972 -- evaluation of all the subscripts (or attribute expressions).
4975 when N_Attribute_Reference
4976 | N_Indexed_Component
4978 Evaluate_Name (Prefix (Nam));
4984 E := First (Expressions (Nam));
4985 while Present (E) loop
4986 Force_Evaluation (E);
4988 if Is_Rewrite_Substitution (E) then
4990 (E, Do_Range_Check (Original_Node (E)));
4997 -- For an explicit dereference, we simply force the evaluation of
4998 -- the name expression. The dereference provides a value that is the
4999 -- address for the renamed object, and it is precisely this value
5000 -- that we want to preserve.
5002 when N_Explicit_Dereference =>
5003 Force_Evaluation (Prefix (Nam));
5005 -- For a function call, we evaluate the call
5007 when N_Function_Call =>
5008 Force_Evaluation (Nam);
5010 -- For a qualified expression, we evaluate the underlying object
5011 -- name if any, otherwise we force the evaluation of the underlying
5014 when N_Qualified_Expression =>
5015 if Is_Object_Reference (Expression (Nam)) then
5016 Evaluate_Name (Expression (Nam));
5018 Force_Evaluation (Expression (Nam));
5021 -- For a selected component, we simply evaluate the prefix
5023 when N_Selected_Component =>
5024 Evaluate_Name (Prefix (Nam));
5026 -- For a slice, we evaluate the prefix, as for the indexed component
5027 -- case and then, if there is a range present, either directly or as
5028 -- the constraint of a discrete subtype indication, we evaluate the
5029 -- two bounds of this range.
5032 Evaluate_Name (Prefix (Nam));
5033 Evaluate_Slice_Bounds (Nam);
5035 -- For a type conversion, the expression of the conversion must be
5036 -- the name of an object, and we simply need to evaluate this name.
5038 when N_Type_Conversion =>
5039 Evaluate_Name (Expression (Nam));
5041 -- The remaining cases are direct name, operator symbol and character
5042 -- literal. In all these cases, we do nothing, since we want to
5043 -- reevaluate each time the renamed object is used.
5050 ---------------------------
5051 -- Evaluate_Slice_Bounds --
5052 ---------------------------
5054 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
5055 DR : constant Node_Id := Discrete_Range (Slice);
5060 if Nkind (DR) = N_Range then
5061 Force_Evaluation (Low_Bound (DR));
5062 Force_Evaluation (High_Bound (DR));
5064 elsif Nkind (DR) = N_Subtype_Indication then
5065 Constr := Constraint (DR);
5067 if Nkind (Constr) = N_Range_Constraint then
5068 Rexpr := Range_Expression (Constr);
5070 Force_Evaluation (Low_Bound (Rexpr));
5071 Force_Evaluation (High_Bound (Rexpr));
5074 end Evaluate_Slice_Bounds;
5076 ---------------------
5077 -- Evolve_And_Then --
5078 ---------------------
5080 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
5086 Make_And_Then (Sloc (Cond1),
5088 Right_Opnd => Cond1);
5090 end Evolve_And_Then;
5092 --------------------
5093 -- Evolve_Or_Else --
5094 --------------------
5096 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
5102 Make_Or_Else (Sloc (Cond1),
5104 Right_Opnd => Cond1);
5108 -----------------------------------------
5109 -- Expand_Static_Predicates_In_Choices --
5110 -----------------------------------------
5112 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
5113 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
5115 Choices : constant List_Id := Discrete_Choices (N);
5123 Choice := First (Choices);
5124 while Present (Choice) loop
5125 Next_C := Next (Choice);
5127 -- Check for name of subtype with static predicate
5129 if Is_Entity_Name (Choice)
5130 and then Is_Type (Entity (Choice))
5131 and then Has_Predicates (Entity (Choice))
5133 -- Loop through entries in predicate list, converting to choices
5134 -- and inserting in the list before the current choice. Note that
5135 -- if the list is empty, corresponding to a False predicate, then
5136 -- no choices are inserted.
5138 P := First (Static_Discrete_Predicate (Entity (Choice)));
5139 while Present (P) loop
5141 -- If low bound and high bounds are equal, copy simple choice
5143 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
5144 C := New_Copy (Low_Bound (P));
5146 -- Otherwise copy a range
5152 -- Change Sloc to referencing choice (rather than the Sloc of
5153 -- the predicate declaration element itself).
5155 Set_Sloc (C, Sloc (Choice));
5156 Insert_Before (Choice, C);
5160 -- Delete the predicated entry
5165 -- Move to next choice to check
5170 Set_Has_SP_Choice (N, False);
5171 end Expand_Static_Predicates_In_Choices;
5173 ------------------------------
5174 -- Expand_Subtype_From_Expr --
5175 ------------------------------
5177 -- This function is applicable for both static and dynamic allocation of
5178 -- objects which are constrained by an initial expression. Basically it
5179 -- transforms an unconstrained subtype indication into a constrained one.
5181 -- The expression may also be transformed in certain cases in order to
5182 -- avoid multiple evaluation. In the static allocation case, the general
5187 -- is transformed into
5189 -- Val : Constrained_Subtype_Of_T := Maybe_Modified_Expr;
5191 -- Here are the main cases :
5193 -- <if Expr is a Slice>
5194 -- Val : T ([Index_Subtype (Expr)]) := Expr;
5196 -- <elsif Expr is a String Literal>
5197 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
5199 -- <elsif Expr is Constrained>
5200 -- subtype T is Type_Of_Expr
5203 -- <elsif Expr is an entity_name>
5204 -- Val : T (constraints taken from Expr) := Expr;
5207 -- type Axxx is access all T;
5208 -- Rval : Axxx := Expr'ref;
5209 -- Val : T (constraints taken from Rval) := Rval.all;
5211 -- ??? note: when the Expression is allocated in the secondary stack
5212 -- we could use it directly instead of copying it by declaring
5213 -- Val : T (...) renames Rval.all
5215 procedure Expand_Subtype_From_Expr
5217 Unc_Type : Entity_Id;
5218 Subtype_Indic : Node_Id;
5220 Related_Id : Entity_Id := Empty)
5222 Loc : constant Source_Ptr := Sloc (N);
5223 Exp_Typ : constant Entity_Id := Etype (Exp);
5227 -- In general we cannot build the subtype if expansion is disabled,
5228 -- because internal entities may not have been defined. However, to
5229 -- avoid some cascaded errors, we try to continue when the expression is
5230 -- an array (or string), because it is safe to compute the bounds. It is
5231 -- in fact required to do so even in a generic context, because there
5232 -- may be constants that depend on the bounds of a string literal, both
5233 -- standard string types and more generally arrays of characters.
5235 -- In GNATprove mode, these extra subtypes are not needed, unless Exp is
5236 -- a static expression. In that case, the subtype will be constrained
5237 -- while the original type might be unconstrained, so expanding the type
5238 -- is necessary both for passing legality checks in GNAT and for precise
5239 -- analysis in GNATprove.
5241 if GNATprove_Mode and then not Is_Static_Expression (Exp) then
5245 if not Expander_Active
5246 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5251 if Nkind (Exp) = N_Slice then
5253 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5256 Rewrite (Subtype_Indic,
5257 Make_Subtype_Indication (Loc,
5258 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5260 Make_Index_Or_Discriminant_Constraint (Loc,
5261 Constraints => New_List
5262 (New_Occurrence_Of (Slice_Type, Loc)))));
5264 -- This subtype indication may be used later for constraint checks
5265 -- we better make sure that if a variable was used as a bound of
5266 -- the original slice, its value is frozen.
5268 Evaluate_Slice_Bounds (Exp);
5271 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5272 Rewrite (Subtype_Indic,
5273 Make_Subtype_Indication (Loc,
5274 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5276 Make_Index_Or_Discriminant_Constraint (Loc,
5277 Constraints => New_List (
5278 Make_Literal_Range (Loc,
5279 Literal_Typ => Exp_Typ)))));
5281 -- If the type of the expression is an internally generated type it
5282 -- may not be necessary to create a new subtype. However there are two
5283 -- exceptions: references to the current instances, and aliased array
5284 -- object declarations for which the back end has to create a template.
5286 elsif Is_Constrained (Exp_Typ)
5287 and then not Is_Class_Wide_Type (Unc_Type)
5289 (Nkind (N) /= N_Object_Declaration
5290 or else not Is_Entity_Name (Expression (N))
5291 or else not Comes_From_Source (Entity (Expression (N)))
5292 or else not Is_Array_Type (Exp_Typ)
5293 or else not Aliased_Present (N))
5295 if Is_Itype (Exp_Typ) then
5297 -- Within an initialization procedure, a selected component
5298 -- denotes a component of the enclosing record, and it appears as
5299 -- an actual in a call to its own initialization procedure. If
5300 -- this component depends on the outer discriminant, we must
5301 -- generate the proper actual subtype for it.
5303 if Nkind (Exp) = N_Selected_Component
5304 and then Within_Init_Proc
5307 Decl : constant Node_Id :=
5308 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5310 if Present (Decl) then
5311 Insert_Action (N, Decl);
5312 T := Defining_Identifier (Decl);
5318 -- No need to generate a new subtype
5325 T := Make_Temporary (Loc, 'T');
5328 Make_Subtype_Declaration (Loc,
5329 Defining_Identifier => T,
5330 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5332 -- This type is marked as an itype even though it has an explicit
5333 -- declaration since otherwise Is_Generic_Actual_Type can get
5334 -- set, resulting in the generation of spurious errors. (See
5335 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5338 Set_Associated_Node_For_Itype (T, Exp);
5341 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5343 -- Nothing needs to be done for private types with unknown discriminants
5344 -- if the underlying type is not an unconstrained composite type or it
5345 -- is an unchecked union.
5347 elsif Is_Private_Type (Unc_Type)
5348 and then Has_Unknown_Discriminants (Unc_Type)
5349 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5350 or else Is_Constrained (Underlying_Type (Unc_Type))
5351 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5355 -- Case of derived type with unknown discriminants where the parent type
5356 -- also has unknown discriminants.
5358 elsif Is_Record_Type (Unc_Type)
5359 and then not Is_Class_Wide_Type (Unc_Type)
5360 and then Has_Unknown_Discriminants (Unc_Type)
5361 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5363 -- Nothing to be done if no underlying record view available
5365 -- If this is a limited type derived from a type with unknown
5366 -- discriminants, do not expand either, so that subsequent expansion
5367 -- of the call can add build-in-place parameters to call.
5369 if No (Underlying_Record_View (Unc_Type))
5370 or else Is_Limited_Type (Unc_Type)
5374 -- Otherwise use the Underlying_Record_View to create the proper
5375 -- constrained subtype for an object of a derived type with unknown
5379 Remove_Side_Effects (Exp);
5380 Rewrite (Subtype_Indic,
5381 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5384 -- Renamings of class-wide interface types require no equivalent
5385 -- constrained type declarations because we only need to reference
5386 -- the tag component associated with the interface. The same is
5387 -- presumably true for class-wide types in general, so this test
5388 -- is broadened to include all class-wide renamings, which also
5389 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5390 -- (Is this really correct, or are there some cases of class-wide
5391 -- renamings that require action in this procedure???)
5394 and then Nkind (N) = N_Object_Renaming_Declaration
5395 and then Is_Class_Wide_Type (Unc_Type)
5399 -- In Ada 95 nothing to be done if the type of the expression is limited
5400 -- because in this case the expression cannot be copied, and its use can
5401 -- only be by reference.
5403 -- In Ada 2005 the context can be an object declaration whose expression
5404 -- is a function that returns in place. If the nominal subtype has
5405 -- unknown discriminants, the call still provides constraints on the
5406 -- object, and we have to create an actual subtype from it.
5408 -- If the type is class-wide, the expression is dynamically tagged and
5409 -- we do not create an actual subtype either. Ditto for an interface.
5410 -- For now this applies only if the type is immutably limited, and the
5411 -- function being called is build-in-place. This will have to be revised
5412 -- when build-in-place functions are generalized to other types.
5414 elsif Is_Limited_View (Exp_Typ)
5416 (Is_Class_Wide_Type (Exp_Typ)
5417 or else Is_Interface (Exp_Typ)
5418 or else not Has_Unknown_Discriminants (Exp_Typ)
5419 or else not Is_Composite_Type (Unc_Type))
5423 -- For limited objects initialized with build in place function calls,
5424 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5425 -- node in the expression initializing the object, which breaks the
5426 -- circuitry that detects and adds the additional arguments to the
5429 elsif Is_Build_In_Place_Function_Call (Exp) then
5433 Remove_Side_Effects (Exp);
5434 Rewrite (Subtype_Indic,
5435 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5437 end Expand_Subtype_From_Expr;
5439 ---------------------------------------------
5440 -- Expression_Contains_Primitives_Calls_Of --
5441 ---------------------------------------------
5443 function Expression_Contains_Primitives_Calls_Of
5445 Typ : Entity_Id) return Boolean
5447 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5449 Calls_OK : Boolean := False;
5450 -- This flag is set to True when expression Expr contains at least one
5451 -- call to a nondispatching primitive function of Typ.
5453 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5454 -- Search for nondispatching calls to primitive functions of type Typ
5456 ----------------------------
5457 -- Search_Primitive_Calls --
5458 ----------------------------
5460 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5461 Disp_Typ : Entity_Id;
5465 -- Detect a function call that could denote a nondispatching
5466 -- primitive of the input type.
5468 if Nkind (N) = N_Function_Call
5469 and then Is_Entity_Name (Name (N))
5471 Subp := Entity (Name (N));
5473 -- Do not consider function calls with a controlling argument, as
5474 -- those are always dispatching calls.
5476 if Is_Dispatching_Operation (Subp)
5477 and then No (Controlling_Argument (N))
5479 Disp_Typ := Find_Dispatching_Type (Subp);
5481 -- To qualify as a suitable primitive, the dispatching type of
5482 -- the function must be the input type.
5484 if Present (Disp_Typ)
5485 and then Unique_Entity (Disp_Typ) = U_Typ
5489 -- There is no need to continue the traversal, as one such
5498 end Search_Primitive_Calls;
5500 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5502 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5505 Search_Calls (Expr);
5507 end Expression_Contains_Primitives_Calls_Of;
5509 ----------------------
5510 -- Finalize_Address --
5511 ----------------------
5513 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5514 Btyp : constant Entity_Id := Base_Type (Typ);
5515 Utyp : Entity_Id := Typ;
5518 -- Handle protected class-wide or task class-wide types
5520 if Is_Class_Wide_Type (Utyp) then
5521 if Is_Concurrent_Type (Root_Type (Utyp)) then
5522 Utyp := Root_Type (Utyp);
5524 elsif Is_Private_Type (Root_Type (Utyp))
5525 and then Present (Full_View (Root_Type (Utyp)))
5526 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5528 Utyp := Full_View (Root_Type (Utyp));
5532 -- Handle private types
5534 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5535 Utyp := Full_View (Utyp);
5538 -- Handle protected and task types
5540 if Is_Concurrent_Type (Utyp)
5541 and then Present (Corresponding_Record_Type (Utyp))
5543 Utyp := Corresponding_Record_Type (Utyp);
5546 Utyp := Underlying_Type (Base_Type (Utyp));
5548 -- Deal with untagged derivation of private views. If the parent is
5549 -- now known to be protected, the finalization routine is the one
5550 -- defined on the corresponding record of the ancestor (corresponding
5551 -- records do not automatically inherit operations, but maybe they
5554 if Is_Untagged_Derivation (Btyp) then
5555 if Is_Protected_Type (Btyp) then
5556 Utyp := Corresponding_Record_Type (Root_Type (Btyp));
5559 Utyp := Underlying_Type (Root_Type (Btyp));
5561 if Is_Protected_Type (Utyp) then
5562 Utyp := Corresponding_Record_Type (Utyp);
5567 -- If the underlying_type is a subtype, we are dealing with the
5568 -- completion of a private type. We need to access the base type and
5569 -- generate a conversion to it.
5571 if Utyp /= Base_Type (Utyp) then
5572 pragma Assert (Is_Private_Type (Typ));
5574 Utyp := Base_Type (Utyp);
5577 -- When dealing with an internally built full view for a type with
5578 -- unknown discriminants, use the original record type.
5580 if Is_Underlying_Record_View (Utyp) then
5581 Utyp := Etype (Utyp);
5584 return TSS (Utyp, TSS_Finalize_Address);
5585 end Finalize_Address;
5587 ------------------------
5588 -- Find_Interface_ADT --
5589 ------------------------
5591 function Find_Interface_ADT
5593 Iface : Entity_Id) return Elmt_Id
5596 Typ : Entity_Id := T;
5599 pragma Assert (Is_Interface (Iface));
5601 -- Handle private types
5603 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5604 Typ := Full_View (Typ);
5607 -- Handle access types
5609 if Is_Access_Type (Typ) then
5610 Typ := Designated_Type (Typ);
5613 -- Handle task and protected types implementing interfaces
5615 if Is_Concurrent_Type (Typ) then
5616 Typ := Corresponding_Record_Type (Typ);
5620 (not Is_Class_Wide_Type (Typ)
5621 and then Ekind (Typ) /= E_Incomplete_Type);
5623 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5624 return First_Elmt (Access_Disp_Table (Typ));
5627 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5629 and then Present (Related_Type (Node (ADT)))
5630 and then Related_Type (Node (ADT)) /= Iface
5631 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
5632 Use_Full_View => True)
5637 pragma Assert (Present (Related_Type (Node (ADT))));
5640 end Find_Interface_ADT;
5642 ------------------------
5643 -- Find_Interface_Tag --
5644 ------------------------
5646 function Find_Interface_Tag
5648 Iface : Entity_Id) return Entity_Id
5650 AI_Tag : Entity_Id := Empty;
5651 Found : Boolean := False;
5652 Typ : Entity_Id := T;
5654 procedure Find_Tag (Typ : Entity_Id);
5655 -- Internal subprogram used to recursively climb to the ancestors
5661 procedure Find_Tag (Typ : Entity_Id) is
5666 -- This routine does not handle the case in which the interface is an
5667 -- ancestor of Typ. That case is handled by the enclosing subprogram.
5669 pragma Assert (Typ /= Iface);
5671 -- Climb to the root type handling private types
5673 if Present (Full_View (Etype (Typ))) then
5674 if Full_View (Etype (Typ)) /= Typ then
5675 Find_Tag (Full_View (Etype (Typ)));
5678 elsif Etype (Typ) /= Typ then
5679 Find_Tag (Etype (Typ));
5682 -- Traverse the list of interfaces implemented by the type
5685 and then Present (Interfaces (Typ))
5686 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
5688 -- Skip the tag associated with the primary table
5690 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
5691 pragma Assert (Present (AI_Tag));
5693 AI_Elmt := First_Elmt (Interfaces (Typ));
5694 while Present (AI_Elmt) loop
5695 AI := Node (AI_Elmt);
5698 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
5704 AI_Tag := Next_Tag_Component (AI_Tag);
5705 Next_Elmt (AI_Elmt);
5710 -- Start of processing for Find_Interface_Tag
5713 pragma Assert (Is_Interface (Iface));
5715 -- Handle access types
5717 if Is_Access_Type (Typ) then
5718 Typ := Designated_Type (Typ);
5721 -- Handle class-wide types
5723 if Is_Class_Wide_Type (Typ) then
5724 Typ := Root_Type (Typ);
5727 -- Handle private types
5729 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5730 Typ := Full_View (Typ);
5733 -- Handle entities from the limited view
5735 if Ekind (Typ) = E_Incomplete_Type then
5736 pragma Assert (Present (Non_Limited_View (Typ)));
5737 Typ := Non_Limited_View (Typ);
5740 -- Handle task and protected types implementing interfaces
5742 if Is_Concurrent_Type (Typ) then
5743 Typ := Corresponding_Record_Type (Typ);
5746 -- If the interface is an ancestor of the type, then it shared the
5747 -- primary dispatch table.
5749 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5750 return First_Tag_Component (Typ);
5752 -- Otherwise we need to search for its associated tag component
5758 end Find_Interface_Tag;
5760 ---------------------------
5761 -- Find_Optional_Prim_Op --
5762 ---------------------------
5764 function Find_Optional_Prim_Op
5765 (T : Entity_Id; Name : Name_Id) return Entity_Id
5768 Typ : Entity_Id := T;
5772 if Is_Class_Wide_Type (Typ) then
5773 Typ := Root_Type (Typ);
5776 Typ := Underlying_Type (Typ);
5778 -- Loop through primitive operations
5780 Prim := First_Elmt (Primitive_Operations (Typ));
5781 while Present (Prim) loop
5784 -- We can retrieve primitive operations by name if it is an internal
5785 -- name. For equality we must check that both of its operands have
5786 -- the same type, to avoid confusion with user-defined equalities
5787 -- than may have a asymmetric signature.
5789 exit when Chars (Op) = Name
5792 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
5797 return Node (Prim); -- Empty if not found
5798 end Find_Optional_Prim_Op;
5800 ---------------------------
5801 -- Find_Optional_Prim_Op --
5802 ---------------------------
5804 function Find_Optional_Prim_Op
5806 Name : TSS_Name_Type) return Entity_Id
5808 Inher_Op : Entity_Id := Empty;
5809 Own_Op : Entity_Id := Empty;
5810 Prim_Elmt : Elmt_Id;
5811 Prim_Id : Entity_Id;
5812 Typ : Entity_Id := T;
5815 if Is_Class_Wide_Type (Typ) then
5816 Typ := Root_Type (Typ);
5819 Typ := Underlying_Type (Typ);
5821 -- This search is based on the assertion that the dispatching version
5822 -- of the TSS routine always precedes the real primitive.
5824 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5825 while Present (Prim_Elmt) loop
5826 Prim_Id := Node (Prim_Elmt);
5828 if Is_TSS (Prim_Id, Name) then
5829 if Present (Alias (Prim_Id)) then
5830 Inher_Op := Prim_Id;
5836 Next_Elmt (Prim_Elmt);
5839 if Present (Own_Op) then
5841 elsif Present (Inher_Op) then
5846 end Find_Optional_Prim_Op;
5852 function Find_Prim_Op
5853 (T : Entity_Id; Name : Name_Id) return Entity_Id
5855 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5858 raise Program_Error;
5868 function Find_Prim_Op
5870 Name : TSS_Name_Type) return Entity_Id
5872 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5875 raise Program_Error;
5881 ----------------------------
5882 -- Find_Protection_Object --
5883 ----------------------------
5885 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
5890 while Present (S) loop
5891 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
5892 and then Present (Protection_Object (S))
5894 return Protection_Object (S);
5900 -- If we do not find a Protection object in the scope chain, then
5901 -- something has gone wrong, most likely the object was never created.
5903 raise Program_Error;
5904 end Find_Protection_Object;
5906 --------------------------
5907 -- Find_Protection_Type --
5908 --------------------------
5910 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
5912 Typ : Entity_Id := Conc_Typ;
5915 if Is_Concurrent_Type (Typ) then
5916 Typ := Corresponding_Record_Type (Typ);
5919 -- Since restriction violations are not considered serious errors, the
5920 -- expander remains active, but may leave the corresponding record type
5921 -- malformed. In such cases, component _object is not available so do
5924 if not Analyzed (Typ) then
5928 Comp := First_Component (Typ);
5929 while Present (Comp) loop
5930 if Chars (Comp) = Name_uObject then
5931 return Base_Type (Etype (Comp));
5934 Next_Component (Comp);
5937 -- The corresponding record of a protected type should always have an
5940 raise Program_Error;
5941 end Find_Protection_Type;
5943 -----------------------
5944 -- Find_Hook_Context --
5945 -----------------------
5947 function Find_Hook_Context (N : Node_Id) return Node_Id is
5951 Wrapped_Node : Node_Id;
5952 -- Note: if we are in a transient scope, we want to reuse it as
5953 -- the context for actions insertion, if possible. But if N is itself
5954 -- part of the stored actions for the current transient scope,
5955 -- then we need to insert at the appropriate (inner) location in
5956 -- the not as an action on Node_To_Be_Wrapped.
5958 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
5961 -- When the node is inside a case/if expression, the lifetime of any
5962 -- temporary controlled object is extended. Find a suitable insertion
5963 -- node by locating the topmost case or if expressions.
5965 if In_Cond_Expr then
5968 while Present (Par) loop
5969 if Nkind_In (Original_Node (Par), N_Case_Expression,
5974 -- Prevent the search from going too far
5976 elsif Is_Body_Or_Package_Declaration (Par) then
5980 Par := Parent (Par);
5983 -- The topmost case or if expression is now recovered, but it may
5984 -- still not be the correct place to add generated code. Climb to
5985 -- find a parent that is part of a declarative or statement list,
5986 -- and is not a list of actuals in a call.
5989 while Present (Par) loop
5990 if Is_List_Member (Par)
5991 and then not Nkind_In (Par, N_Component_Association,
5992 N_Discriminant_Association,
5993 N_Parameter_Association,
5994 N_Pragma_Argument_Association)
5995 and then not Nkind_In (Parent (Par), N_Function_Call,
5996 N_Procedure_Call_Statement,
5997 N_Entry_Call_Statement)
6002 -- Prevent the search from going too far
6004 elsif Is_Body_Or_Package_Declaration (Par) then
6008 Par := Parent (Par);
6015 while Present (Par) loop
6017 -- Keep climbing past various operators
6019 if Nkind (Parent (Par)) in N_Op
6020 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
6022 Par := Parent (Par);
6030 -- The node may be located in a pragma in which case return the
6033 -- pragma Precondition (... and then Ctrl_Func_Call ...);
6035 -- Similar case occurs when the node is related to an object
6036 -- declaration or assignment:
6038 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
6040 -- Another case to consider is when the node is part of a return
6043 -- return ... and then Ctrl_Func_Call ...;
6045 -- Another case is when the node acts as a formal in a procedure
6048 -- Proc (... and then Ctrl_Func_Call ...);
6050 if Scope_Is_Transient then
6051 Wrapped_Node := Node_To_Be_Wrapped;
6053 Wrapped_Node := Empty;
6056 while Present (Par) loop
6057 if Par = Wrapped_Node
6058 or else Nkind_In (Par, N_Assignment_Statement,
6059 N_Object_Declaration,
6061 N_Procedure_Call_Statement,
6062 N_Simple_Return_Statement)
6066 -- Prevent the search from going too far
6068 elsif Is_Body_Or_Package_Declaration (Par) then
6072 Par := Parent (Par);
6075 -- Return the topmost short circuit operator
6079 end Find_Hook_Context;
6081 ------------------------------
6082 -- Following_Address_Clause --
6083 ------------------------------
6085 function Following_Address_Clause (D : Node_Id) return Node_Id is
6086 Id : constant Entity_Id := Defining_Identifier (D);
6090 function Check_Decls (D : Node_Id) return Node_Id;
6091 -- This internal function differs from the main function in that it
6092 -- gets called to deal with a following package private part, and
6093 -- it checks declarations starting with D (the main function checks
6094 -- declarations following D). If D is Empty, then Empty is returned.
6100 function Check_Decls (D : Node_Id) return Node_Id is
6105 while Present (Decl) loop
6106 if Nkind (Decl) = N_At_Clause
6107 and then Chars (Identifier (Decl)) = Chars (Id)
6111 elsif Nkind (Decl) = N_Attribute_Definition_Clause
6112 and then Chars (Decl) = Name_Address
6113 and then Chars (Name (Decl)) = Chars (Id)
6121 -- Otherwise not found, return Empty
6126 -- Start of processing for Following_Address_Clause
6129 -- If parser detected no address clause for the identifier in question,
6130 -- then the answer is a quick NO, without the need for a search.
6132 if not Get_Name_Table_Boolean1 (Chars (Id)) then
6136 -- Otherwise search current declarative unit
6138 Result := Check_Decls (Next (D));
6140 if Present (Result) then
6144 -- Check for possible package private part following
6148 if Nkind (Par) = N_Package_Specification
6149 and then Visible_Declarations (Par) = List_Containing (D)
6150 and then Present (Private_Declarations (Par))
6152 -- Private part present, check declarations there
6154 return Check_Decls (First (Private_Declarations (Par)));
6157 -- No private part, clause not found, return Empty
6161 end Following_Address_Clause;
6163 ----------------------
6164 -- Force_Evaluation --
6165 ----------------------
6167 procedure Force_Evaluation
6169 Name_Req : Boolean := False;
6170 Related_Id : Entity_Id := Empty;
6171 Is_Low_Bound : Boolean := False;
6172 Is_High_Bound : Boolean := False;
6173 Mode : Force_Evaluation_Mode := Relaxed)
6178 Name_Req => Name_Req,
6179 Variable_Ref => True,
6180 Renaming_Req => False,
6181 Related_Id => Related_Id,
6182 Is_Low_Bound => Is_Low_Bound,
6183 Is_High_Bound => Is_High_Bound,
6184 Check_Side_Effects =>
6185 Is_Static_Expression (Exp)
6186 or else Mode = Relaxed);
6187 end Force_Evaluation;
6189 ---------------------------------
6190 -- Fully_Qualified_Name_String --
6191 ---------------------------------
6193 function Fully_Qualified_Name_String
6195 Append_NUL : Boolean := True) return String_Id
6197 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6198 -- Compute recursively the qualified name without NUL at the end, adding
6199 -- it to the currently started string being generated
6201 ----------------------------------
6202 -- Internal_Full_Qualified_Name --
6203 ----------------------------------
6205 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6209 -- Deal properly with child units
6211 if Nkind (E) = N_Defining_Program_Unit_Name then
6212 Ent := Defining_Identifier (E);
6217 -- Compute qualification recursively (only "Standard" has no scope)
6219 if Present (Scope (Scope (Ent))) then
6220 Internal_Full_Qualified_Name (Scope (Ent));
6221 Store_String_Char (Get_Char_Code ('.'));
6224 -- Every entity should have a name except some expanded blocks
6225 -- don't bother about those.
6227 if Chars (Ent) = No_Name then
6231 -- Generates the entity name in upper case
6233 Get_Decoded_Name_String (Chars (Ent));
6235 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6237 end Internal_Full_Qualified_Name;
6239 -- Start of processing for Full_Qualified_Name
6243 Internal_Full_Qualified_Name (E);
6246 Store_String_Char (Get_Char_Code (ASCII.NUL));
6250 end Fully_Qualified_Name_String;
6252 ------------------------
6253 -- Generate_Poll_Call --
6254 ------------------------
6256 procedure Generate_Poll_Call (N : Node_Id) is
6258 -- No poll call if polling not active
6260 if not Polling_Required then
6263 -- Otherwise generate require poll call
6266 Insert_Before_And_Analyze (N,
6267 Make_Procedure_Call_Statement (Sloc (N),
6268 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
6270 end Generate_Poll_Call;
6272 ---------------------------------
6273 -- Get_Current_Value_Condition --
6274 ---------------------------------
6276 -- Note: the implementation of this procedure is very closely tied to the
6277 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6278 -- interpret Current_Value fields set by the Set procedure, so the two
6279 -- procedures need to be closely coordinated.
6281 procedure Get_Current_Value_Condition
6286 Loc : constant Source_Ptr := Sloc (Var);
6287 Ent : constant Entity_Id := Entity (Var);
6289 procedure Process_Current_Value_Condition
6292 -- N is an expression which holds either True (S = True) or False (S =
6293 -- False) in the condition. This procedure digs out the expression and
6294 -- if it refers to Ent, sets Op and Val appropriately.
6296 -------------------------------------
6297 -- Process_Current_Value_Condition --
6298 -------------------------------------
6300 procedure Process_Current_Value_Condition
6305 Prev_Cond : Node_Id;
6315 -- Deal with NOT operators, inverting sense
6317 while Nkind (Cond) = N_Op_Not loop
6318 Cond := Right_Opnd (Cond);
6322 -- Deal with conversions, qualifications, and expressions with
6325 while Nkind_In (Cond,
6327 N_Qualified_Expression,
6328 N_Expression_With_Actions)
6330 Cond := Expression (Cond);
6333 exit when Cond = Prev_Cond;
6336 -- Deal with AND THEN and AND cases
6338 if Nkind_In (Cond, N_And_Then, N_Op_And) then
6340 -- Don't ever try to invert a condition that is of the form of an
6341 -- AND or AND THEN (since we are not doing sufficiently general
6342 -- processing to allow this).
6344 if Sens = False then
6350 -- Recursively process AND and AND THEN branches
6352 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6354 if Op /= N_Empty then
6358 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6361 -- Case of relational operator
6363 elsif Nkind (Cond) in N_Op_Compare then
6366 -- Invert sense of test if inverted test
6368 if Sens = False then
6370 when N_Op_Eq => Op := N_Op_Ne;
6371 when N_Op_Ne => Op := N_Op_Eq;
6372 when N_Op_Lt => Op := N_Op_Ge;
6373 when N_Op_Gt => Op := N_Op_Le;
6374 when N_Op_Le => Op := N_Op_Gt;
6375 when N_Op_Ge => Op := N_Op_Lt;
6376 when others => raise Program_Error;
6380 -- Case of entity op value
6382 if Is_Entity_Name (Left_Opnd (Cond))
6383 and then Ent = Entity (Left_Opnd (Cond))
6384 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6386 Val := Right_Opnd (Cond);
6388 -- Case of value op entity
6390 elsif Is_Entity_Name (Right_Opnd (Cond))
6391 and then Ent = Entity (Right_Opnd (Cond))
6392 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6394 Val := Left_Opnd (Cond);
6396 -- We are effectively swapping operands
6399 when N_Op_Eq => null;
6400 when N_Op_Ne => null;
6401 when N_Op_Lt => Op := N_Op_Gt;
6402 when N_Op_Gt => Op := N_Op_Lt;
6403 when N_Op_Le => Op := N_Op_Ge;
6404 when N_Op_Ge => Op := N_Op_Le;
6405 when others => raise Program_Error;
6414 elsif Nkind_In (Cond,
6416 N_Qualified_Expression,
6417 N_Expression_With_Actions)
6419 Cond := Expression (Cond);
6421 -- Case of Boolean variable reference, return as though the
6422 -- reference had said var = True.
6425 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6426 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6428 if Sens = False then
6435 end Process_Current_Value_Condition;
6437 -- Start of processing for Get_Current_Value_Condition
6443 -- Immediate return, nothing doing, if this is not an object
6445 if Ekind (Ent) not in Object_Kind then
6449 -- Otherwise examine current value
6452 CV : constant Node_Id := Current_Value (Ent);
6457 -- If statement. Condition is known true in THEN section, known False
6458 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6460 if Nkind (CV) = N_If_Statement then
6462 -- Before start of IF statement
6464 if Loc < Sloc (CV) then
6467 -- After end of IF statement
6469 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6473 -- At this stage we know that we are within the IF statement, but
6474 -- unfortunately, the tree does not record the SLOC of the ELSE so
6475 -- we cannot use a simple SLOC comparison to distinguish between
6476 -- the then/else statements, so we have to climb the tree.
6483 while Parent (N) /= CV loop
6486 -- If we fall off the top of the tree, then that's odd, but
6487 -- perhaps it could occur in some error situation, and the
6488 -- safest response is simply to assume that the outcome of
6489 -- the condition is unknown. No point in bombing during an
6490 -- attempt to optimize things.
6497 -- Now we have N pointing to a node whose parent is the IF
6498 -- statement in question, so now we can tell if we are within
6499 -- the THEN statements.
6501 if Is_List_Member (N)
6502 and then List_Containing (N) = Then_Statements (CV)
6506 -- If the variable reference does not come from source, we
6507 -- cannot reliably tell whether it appears in the else part.
6508 -- In particular, if it appears in generated code for a node
6509 -- that requires finalization, it may be attached to a list
6510 -- that has not been yet inserted into the code. For now,
6511 -- treat it as unknown.
6513 elsif not Comes_From_Source (N) then
6516 -- Otherwise we must be in ELSIF or ELSE part
6523 -- ELSIF part. Condition is known true within the referenced
6524 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6525 -- and unknown before the ELSE part or after the IF statement.
6527 elsif Nkind (CV) = N_Elsif_Part then
6529 -- if the Elsif_Part had condition_actions, the elsif has been
6530 -- rewritten as a nested if, and the original elsif_part is
6531 -- detached from the tree, so there is no way to obtain useful
6532 -- information on the current value of the variable.
6533 -- Can this be improved ???
6535 if No (Parent (CV)) then
6541 -- If the tree has been otherwise rewritten there is nothing
6542 -- else to be done either.
6544 if Nkind (Stm) /= N_If_Statement then
6548 -- Before start of ELSIF part
6550 if Loc < Sloc (CV) then
6553 -- After end of IF statement
6555 elsif Loc >= Sloc (Stm) +
6556 Text_Ptr (UI_To_Int (End_Span (Stm)))
6561 -- Again we lack the SLOC of the ELSE, so we need to climb the
6562 -- tree to see if we are within the ELSIF part in question.
6569 while Parent (N) /= Stm loop
6572 -- If we fall off the top of the tree, then that's odd, but
6573 -- perhaps it could occur in some error situation, and the
6574 -- safest response is simply to assume that the outcome of
6575 -- the condition is unknown. No point in bombing during an
6576 -- attempt to optimize things.
6583 -- Now we have N pointing to a node whose parent is the IF
6584 -- statement in question, so see if is the ELSIF part we want.
6585 -- the THEN statements.
6590 -- Otherwise we must be in subsequent ELSIF or ELSE part
6597 -- Iteration scheme of while loop. The condition is known to be
6598 -- true within the body of the loop.
6600 elsif Nkind (CV) = N_Iteration_Scheme then
6602 Loop_Stmt : constant Node_Id := Parent (CV);
6605 -- Before start of body of loop
6607 if Loc < Sloc (Loop_Stmt) then
6610 -- After end of LOOP statement
6612 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
6615 -- We are within the body of the loop
6622 -- All other cases of Current_Value settings
6628 -- If we fall through here, then we have a reportable condition, Sens
6629 -- is True if the condition is true and False if it needs inverting.
6631 Process_Current_Value_Condition (Condition (CV), Sens);
6633 end Get_Current_Value_Condition;
6635 ---------------------
6636 -- Get_Stream_Size --
6637 ---------------------
6639 function Get_Stream_Size (E : Entity_Id) return Uint is
6641 -- If we have a Stream_Size clause for this type use it
6643 if Has_Stream_Size_Clause (E) then
6644 return Static_Integer (Expression (Stream_Size_Clause (E)));
6646 -- Otherwise the Stream_Size if the size of the type
6651 end Get_Stream_Size;
6653 ---------------------------
6654 -- Has_Access_Constraint --
6655 ---------------------------
6657 function Has_Access_Constraint (E : Entity_Id) return Boolean is
6659 T : constant Entity_Id := Etype (E);
6662 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
6663 Disc := First_Discriminant (T);
6664 while Present (Disc) loop
6665 if Is_Access_Type (Etype (Disc)) then
6669 Next_Discriminant (Disc);
6676 end Has_Access_Constraint;
6678 -----------------------------------------------------
6679 -- Has_Annotate_Pragma_For_External_Axiomatization --
6680 -----------------------------------------------------
6682 function Has_Annotate_Pragma_For_External_Axiomatization
6683 (E : Entity_Id) return Boolean
6685 function Is_Annotate_Pragma_For_External_Axiomatization
6686 (N : Node_Id) return Boolean;
6687 -- Returns whether N is
6688 -- pragma Annotate (GNATprove, External_Axiomatization);
6690 ----------------------------------------------------
6691 -- Is_Annotate_Pragma_For_External_Axiomatization --
6692 ----------------------------------------------------
6694 -- The general form of pragma Annotate is
6696 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
6697 -- ARG ::= NAME | EXPRESSION
6699 -- The first two arguments are by convention intended to refer to an
6700 -- external tool and a tool-specific function. These arguments are
6703 -- The following is used to annotate a package specification which
6704 -- GNATprove should treat specially, because the axiomatization of
6705 -- this unit is given by the user instead of being automatically
6708 -- pragma Annotate (GNATprove, External_Axiomatization);
6710 function Is_Annotate_Pragma_For_External_Axiomatization
6711 (N : Node_Id) return Boolean
6713 Name_GNATprove : constant String :=
6715 Name_External_Axiomatization : constant String :=
6716 "external_axiomatization";
6720 if Nkind (N) = N_Pragma
6721 and then Get_Pragma_Id (N) = Pragma_Annotate
6722 and then List_Length (Pragma_Argument_Associations (N)) = 2
6725 Arg1 : constant Node_Id :=
6726 First (Pragma_Argument_Associations (N));
6727 Arg2 : constant Node_Id := Next (Arg1);
6732 -- Fill in Name_Buffer with Name_GNATprove first, and then with
6733 -- Name_External_Axiomatization so that Name_Find returns the
6734 -- corresponding name. This takes care of all possible casings.
6737 Add_Str_To_Name_Buffer (Name_GNATprove);
6741 Add_Str_To_Name_Buffer (Name_External_Axiomatization);
6744 return Chars (Get_Pragma_Arg (Arg1)) = Nam1
6746 Chars (Get_Pragma_Arg (Arg2)) = Nam2;
6752 end Is_Annotate_Pragma_For_External_Axiomatization;
6757 Vis_Decls : List_Id;
6760 -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
6763 if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
6764 Decl := Parent (Parent (E));
6769 Vis_Decls := Visible_Declarations (Decl);
6771 N := First (Vis_Decls);
6772 while Present (N) loop
6774 -- Skip declarations generated by the frontend. Skip all pragmas
6775 -- that are not the desired Annotate pragma. Stop the search on
6776 -- the first non-pragma source declaration.
6778 if Comes_From_Source (N) then
6779 if Nkind (N) = N_Pragma then
6780 if Is_Annotate_Pragma_For_External_Axiomatization (N) then
6792 end Has_Annotate_Pragma_For_External_Axiomatization;
6794 --------------------
6795 -- Homonym_Number --
6796 --------------------
6798 function Homonym_Number (Subp : Entity_Id) return Pos is
6799 Hom : Entity_Id := Homonym (Subp);
6803 while Present (Hom) loop
6804 if Scope (Hom) = Scope (Subp) then
6808 Hom := Homonym (Hom);
6814 -----------------------------------
6815 -- In_Library_Level_Package_Body --
6816 -----------------------------------
6818 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
6820 -- First determine whether the entity appears at the library level, then
6821 -- look at the containing unit.
6823 if Is_Library_Level_Entity (Id) then
6825 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
6828 return Nkind (Unit (Container)) = N_Package_Body;
6833 end In_Library_Level_Package_Body;
6835 ------------------------------
6836 -- In_Unconditional_Context --
6837 ------------------------------
6839 function In_Unconditional_Context (Node : Node_Id) return Boolean is
6844 while Present (P) loop
6846 when N_Subprogram_Body => return True;
6847 when N_If_Statement => return False;
6848 when N_Loop_Statement => return False;
6849 when N_Case_Statement => return False;
6850 when others => P := Parent (P);
6855 end In_Unconditional_Context;
6861 procedure Insert_Action
6862 (Assoc_Node : Node_Id;
6863 Ins_Action : Node_Id;
6864 Spec_Expr_OK : Boolean := False)
6867 if Present (Ins_Action) then
6869 (Assoc_Node => Assoc_Node,
6870 Ins_Actions => New_List (Ins_Action),
6871 Spec_Expr_OK => Spec_Expr_OK);
6875 -- Version with check(s) suppressed
6877 procedure Insert_Action
6878 (Assoc_Node : Node_Id;
6879 Ins_Action : Node_Id;
6880 Suppress : Check_Id;
6881 Spec_Expr_OK : Boolean := False)
6885 (Assoc_Node => Assoc_Node,
6886 Ins_Actions => New_List (Ins_Action),
6887 Suppress => Suppress,
6888 Spec_Expr_OK => Spec_Expr_OK);
6891 -------------------------
6892 -- Insert_Action_After --
6893 -------------------------
6895 procedure Insert_Action_After
6896 (Assoc_Node : Node_Id;
6897 Ins_Action : Node_Id)
6900 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
6901 end Insert_Action_After;
6903 --------------------
6904 -- Insert_Actions --
6905 --------------------
6907 procedure Insert_Actions
6908 (Assoc_Node : Node_Id;
6909 Ins_Actions : List_Id;
6910 Spec_Expr_OK : Boolean := False)
6915 Wrapped_Node : Node_Id := Empty;
6918 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
6922 -- Insert the action when the context is "Handling of Default and Per-
6923 -- Object Expressions" only when requested by the caller.
6925 if Spec_Expr_OK then
6928 -- Ignore insert of actions from inside default expression (or other
6929 -- similar "spec expression") in the special spec-expression analyze
6930 -- mode. Any insertions at this point have no relevance, since we are
6931 -- only doing the analyze to freeze the types of any static expressions.
6932 -- See section "Handling of Default and Per-Object Expressions" in the
6933 -- spec of package Sem for further details.
6935 elsif In_Spec_Expression then
6939 -- If the action derives from stuff inside a record, then the actions
6940 -- are attached to the current scope, to be inserted and analyzed on
6941 -- exit from the scope. The reason for this is that we may also be
6942 -- generating freeze actions at the same time, and they must eventually
6943 -- be elaborated in the correct order.
6945 if Is_Record_Type (Current_Scope)
6946 and then not Is_Frozen (Current_Scope)
6948 if No (Scope_Stack.Table
6949 (Scope_Stack.Last).Pending_Freeze_Actions)
6951 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
6956 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
6962 -- We now intend to climb up the tree to find the right point to
6963 -- insert the actions. We start at Assoc_Node, unless this node is a
6964 -- subexpression in which case we start with its parent. We do this for
6965 -- two reasons. First it speeds things up. Second, if Assoc_Node is
6966 -- itself one of the special nodes like N_And_Then, then we assume that
6967 -- an initial request to insert actions for such a node does not expect
6968 -- the actions to get deposited in the node for later handling when the
6969 -- node is expanded, since clearly the node is being dealt with by the
6970 -- caller. Note that in the subexpression case, N is always the child we
6973 -- N_Raise_xxx_Error is an annoying special case, it is a statement
6974 -- if it has type Standard_Void_Type, and a subexpression otherwise.
6975 -- Procedure calls, and similarly procedure attribute references, are
6978 if Nkind (Assoc_Node) in N_Subexpr
6979 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
6980 or else Etype (Assoc_Node) /= Standard_Void_Type)
6981 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
6982 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
6983 or else not Is_Procedure_Attribute_Name
6984 (Attribute_Name (Assoc_Node)))
6987 P := Parent (Assoc_Node);
6989 -- Nonsubexpression case. Note that N is initially Empty in this case
6990 -- (N is only guaranteed non-Empty in the subexpr case).
6997 -- Capture root of the transient scope
6999 if Scope_Is_Transient then
7000 Wrapped_Node := Node_To_Be_Wrapped;
7004 pragma Assert (Present (P));
7006 -- Make sure that inserted actions stay in the transient scope
7008 if Present (Wrapped_Node) and then N = Wrapped_Node then
7009 Store_Before_Actions_In_Scope (Ins_Actions);
7015 -- Case of right operand of AND THEN or OR ELSE. Put the actions
7016 -- in the Actions field of the right operand. They will be moved
7017 -- out further when the AND THEN or OR ELSE operator is expanded.
7018 -- Nothing special needs to be done for the left operand since
7019 -- in that case the actions are executed unconditionally.
7021 when N_Short_Circuit =>
7022 if N = Right_Opnd (P) then
7024 -- We are now going to either append the actions to the
7025 -- actions field of the short-circuit operation. We will
7026 -- also analyze the actions now.
7028 -- This analysis is really too early, the proper thing would
7029 -- be to just park them there now, and only analyze them if
7030 -- we find we really need them, and to it at the proper
7031 -- final insertion point. However attempting to this proved
7032 -- tricky, so for now we just kill current values before and
7033 -- after the analyze call to make sure we avoid peculiar
7034 -- optimizations from this out of order insertion.
7036 Kill_Current_Values;
7038 -- If P has already been expanded, we can't park new actions
7039 -- on it, so we need to expand them immediately, introducing
7040 -- an Expression_With_Actions. N can't be an expression
7041 -- with actions, or else then the actions would have been
7042 -- inserted at an inner level.
7044 if Analyzed (P) then
7045 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
7047 Make_Expression_With_Actions (Sloc (N),
7048 Actions => Ins_Actions,
7049 Expression => Relocate_Node (N)));
7050 Analyze_And_Resolve (N);
7052 elsif Present (Actions (P)) then
7053 Insert_List_After_And_Analyze
7054 (Last (Actions (P)), Ins_Actions);
7056 Set_Actions (P, Ins_Actions);
7057 Analyze_List (Actions (P));
7060 Kill_Current_Values;
7065 -- Then or Else dependent expression of an if expression. Add
7066 -- actions to Then_Actions or Else_Actions field as appropriate.
7067 -- The actions will be moved further out when the if is expanded.
7069 when N_If_Expression =>
7071 ThenX : constant Node_Id := Next (First (Expressions (P)));
7072 ElseX : constant Node_Id := Next (ThenX);
7075 -- If the enclosing expression is already analyzed, as
7076 -- is the case for nested elaboration checks, insert the
7077 -- conditional further out.
7079 if Analyzed (P) then
7082 -- Actions belong to the then expression, temporarily place
7083 -- them as Then_Actions of the if expression. They will be
7084 -- moved to the proper place later when the if expression
7087 elsif N = ThenX then
7088 if Present (Then_Actions (P)) then
7089 Insert_List_After_And_Analyze
7090 (Last (Then_Actions (P)), Ins_Actions);
7092 Set_Then_Actions (P, Ins_Actions);
7093 Analyze_List (Then_Actions (P));
7098 -- Actions belong to the else expression, temporarily place
7099 -- them as Else_Actions of the if expression. They will be
7100 -- moved to the proper place later when the if expression
7103 elsif N = ElseX then
7104 if Present (Else_Actions (P)) then
7105 Insert_List_After_And_Analyze
7106 (Last (Else_Actions (P)), Ins_Actions);
7108 Set_Else_Actions (P, Ins_Actions);
7109 Analyze_List (Else_Actions (P));
7114 -- Actions belong to the condition. In this case they are
7115 -- unconditionally executed, and so we can continue the
7116 -- search for the proper insert point.
7123 -- Alternative of case expression, we place the action in the
7124 -- Actions field of the case expression alternative, this will
7125 -- be handled when the case expression is expanded.
7127 when N_Case_Expression_Alternative =>
7128 if Present (Actions (P)) then
7129 Insert_List_After_And_Analyze
7130 (Last (Actions (P)), Ins_Actions);
7132 Set_Actions (P, Ins_Actions);
7133 Analyze_List (Actions (P));
7138 -- Case of appearing within an Expressions_With_Actions node. When
7139 -- the new actions come from the expression of the expression with
7140 -- actions, they must be added to the existing actions. The other
7141 -- alternative is when the new actions are related to one of the
7142 -- existing actions of the expression with actions, and should
7143 -- never reach here: if actions are inserted on a statement
7144 -- within the Actions of an expression with actions, or on some
7145 -- subexpression of such a statement, then the outermost proper
7146 -- insertion point is right before the statement, and we should
7147 -- never climb up as far as the N_Expression_With_Actions itself.
7149 when N_Expression_With_Actions =>
7150 if N = Expression (P) then
7151 if Is_Empty_List (Actions (P)) then
7152 Append_List_To (Actions (P), Ins_Actions);
7153 Analyze_List (Actions (P));
7155 Insert_List_After_And_Analyze
7156 (Last (Actions (P)), Ins_Actions);
7162 raise Program_Error;
7165 -- Case of appearing in the condition of a while expression or
7166 -- elsif. We insert the actions into the Condition_Actions field.
7167 -- They will be moved further out when the while loop or elsif
7171 | N_Iteration_Scheme
7173 if N = Condition (P) then
7174 if Present (Condition_Actions (P)) then
7175 Insert_List_After_And_Analyze
7176 (Last (Condition_Actions (P)), Ins_Actions);
7178 Set_Condition_Actions (P, Ins_Actions);
7180 -- Set the parent of the insert actions explicitly. This
7181 -- is not a syntactic field, but we need the parent field
7182 -- set, in particular so that freeze can understand that
7183 -- it is dealing with condition actions, and properly
7184 -- insert the freezing actions.
7186 Set_Parent (Ins_Actions, P);
7187 Analyze_List (Condition_Actions (P));
7193 -- Statements, declarations, pragmas, representation clauses
7198 N_Procedure_Call_Statement
7199 | N_Statement_Other_Than_Procedure_Call
7205 -- Representation_Clause
7208 | N_Attribute_Definition_Clause
7209 | N_Enumeration_Representation_Clause
7210 | N_Record_Representation_Clause
7214 | N_Abstract_Subprogram_Declaration
7216 | N_Exception_Declaration
7217 | N_Exception_Renaming_Declaration
7218 | N_Expression_Function
7219 | N_Formal_Abstract_Subprogram_Declaration
7220 | N_Formal_Concrete_Subprogram_Declaration
7221 | N_Formal_Object_Declaration
7222 | N_Formal_Type_Declaration
7223 | N_Full_Type_Declaration
7224 | N_Function_Instantiation
7225 | N_Generic_Function_Renaming_Declaration
7226 | N_Generic_Package_Declaration
7227 | N_Generic_Package_Renaming_Declaration
7228 | N_Generic_Procedure_Renaming_Declaration
7229 | N_Generic_Subprogram_Declaration
7230 | N_Implicit_Label_Declaration
7231 | N_Incomplete_Type_Declaration
7232 | N_Number_Declaration
7233 | N_Object_Declaration
7234 | N_Object_Renaming_Declaration
7236 | N_Package_Body_Stub
7237 | N_Package_Declaration
7238 | N_Package_Instantiation
7239 | N_Package_Renaming_Declaration
7240 | N_Private_Extension_Declaration
7241 | N_Private_Type_Declaration
7242 | N_Procedure_Instantiation
7244 | N_Protected_Body_Stub
7245 | N_Single_Task_Declaration
7247 | N_Subprogram_Body_Stub
7248 | N_Subprogram_Declaration
7249 | N_Subprogram_Renaming_Declaration
7250 | N_Subtype_Declaration
7254 -- Use clauses can appear in lists of declarations
7256 | N_Use_Package_Clause
7259 -- Freeze entity behaves like a declaration or statement
7262 | N_Freeze_Generic_Entity
7264 -- Do not insert here if the item is not a list member (this
7265 -- happens for example with a triggering statement, and the
7266 -- proper approach is to insert before the entire select).
7268 if not Is_List_Member (P) then
7271 -- Do not insert if parent of P is an N_Component_Association
7272 -- node (i.e. we are in the context of an N_Aggregate or
7273 -- N_Extension_Aggregate node. In this case we want to insert
7274 -- before the entire aggregate.
7276 elsif Nkind (Parent (P)) = N_Component_Association then
7279 -- Do not insert if the parent of P is either an N_Variant node
7280 -- or an N_Record_Definition node, meaning in either case that
7281 -- P is a member of a component list, and that therefore the
7282 -- actions should be inserted outside the complete record
7285 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
7288 -- Do not insert freeze nodes within the loop generated for
7289 -- an aggregate, because they may be elaborated too late for
7290 -- subsequent use in the back end: within a package spec the
7291 -- loop is part of the elaboration procedure and is only
7292 -- elaborated during the second pass.
7294 -- If the loop comes from source, or the entity is local to the
7295 -- loop itself it must remain within.
7297 elsif Nkind (Parent (P)) = N_Loop_Statement
7298 and then not Comes_From_Source (Parent (P))
7299 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7301 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7305 -- Otherwise we can go ahead and do the insertion
7307 elsif P = Wrapped_Node then
7308 Store_Before_Actions_In_Scope (Ins_Actions);
7312 Insert_List_Before_And_Analyze (P, Ins_Actions);
7316 -- the expansion of Task and protected type declarations can
7317 -- create declarations for temporaries which, like other actions
7318 -- are inserted and analyzed before the current declaraation.
7319 -- However, the current scope is the synchronized type, and
7320 -- for unnesting it is critical that the proper scope for these
7321 -- generated entities be the enclosing one.
7323 when N_Task_Type_Declaration
7324 | N_Protected_Type_Declaration =>
7326 Push_Scope (Scope (Current_Scope));
7327 Insert_List_Before_And_Analyze (P, Ins_Actions);
7331 -- A special case, N_Raise_xxx_Error can act either as a statement
7332 -- or a subexpression. We tell the difference by looking at the
7333 -- Etype. It is set to Standard_Void_Type in the statement case.
7335 when N_Raise_xxx_Error =>
7336 if Etype (P) = Standard_Void_Type then
7337 if P = Wrapped_Node then
7338 Store_Before_Actions_In_Scope (Ins_Actions);
7340 Insert_List_Before_And_Analyze (P, Ins_Actions);
7345 -- In the subexpression case, keep climbing
7351 -- If a component association appears within a loop created for
7352 -- an array aggregate, attach the actions to the association so
7353 -- they can be subsequently inserted within the loop. For other
7354 -- component associations insert outside of the aggregate. For
7355 -- an association that will generate a loop, its Loop_Actions
7356 -- attribute is already initialized (see exp_aggr.adb).
7358 -- The list of Loop_Actions can in turn generate additional ones,
7359 -- that are inserted before the associated node. If the associated
7360 -- node is outside the aggregate, the new actions are collected
7361 -- at the end of the Loop_Actions, to respect the order in which
7362 -- they are to be elaborated.
7364 when N_Component_Association
7365 | N_Iterated_Component_Association
7367 if Nkind (Parent (P)) = N_Aggregate
7368 and then Present (Loop_Actions (P))
7370 if Is_Empty_List (Loop_Actions (P)) then
7371 Set_Loop_Actions (P, Ins_Actions);
7372 Analyze_List (Ins_Actions);
7378 -- Check whether these actions were generated by a
7379 -- declaration that is part of the Loop_Actions for
7380 -- the component_association.
7383 while Present (Decl) loop
7384 exit when Parent (Decl) = P
7385 and then Is_List_Member (Decl)
7387 List_Containing (Decl) = Loop_Actions (P);
7388 Decl := Parent (Decl);
7391 if Present (Decl) then
7392 Insert_List_Before_And_Analyze
7393 (Decl, Ins_Actions);
7395 Insert_List_After_And_Analyze
7396 (Last (Loop_Actions (P)), Ins_Actions);
7407 -- Special case: an attribute denoting a procedure call
7409 when N_Attribute_Reference =>
7410 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7411 if P = Wrapped_Node then
7412 Store_Before_Actions_In_Scope (Ins_Actions);
7414 Insert_List_Before_And_Analyze (P, Ins_Actions);
7419 -- In the subexpression case, keep climbing
7425 -- Special case: a marker
7428 | N_Variable_Reference_Marker
7430 if Is_List_Member (P) then
7431 Insert_List_Before_And_Analyze (P, Ins_Actions);
7435 -- A contract node should not belong to the tree
7438 raise Program_Error;
7440 -- For all other node types, keep climbing tree
7442 when N_Abortable_Part
7443 | N_Accept_Alternative
7444 | N_Access_Definition
7445 | N_Access_Function_Definition
7446 | N_Access_Procedure_Definition
7447 | N_Access_To_Object_Definition
7450 | N_Aspect_Specification
7452 | N_Case_Statement_Alternative
7453 | N_Character_Literal
7454 | N_Compilation_Unit
7455 | N_Compilation_Unit_Aux
7456 | N_Component_Clause
7457 | N_Component_Declaration
7458 | N_Component_Definition
7460 | N_Constrained_Array_Definition
7461 | N_Decimal_Fixed_Point_Definition
7462 | N_Defining_Character_Literal
7463 | N_Defining_Identifier
7464 | N_Defining_Operator_Symbol
7465 | N_Defining_Program_Unit_Name
7466 | N_Delay_Alternative
7468 | N_Delta_Constraint
7469 | N_Derived_Type_Definition
7471 | N_Digits_Constraint
7472 | N_Discriminant_Association
7473 | N_Discriminant_Specification
7475 | N_Entry_Body_Formal_Part
7476 | N_Entry_Call_Alternative
7477 | N_Entry_Declaration
7478 | N_Entry_Index_Specification
7479 | N_Enumeration_Type_Definition
7481 | N_Exception_Handler
7483 | N_Explicit_Dereference
7484 | N_Extension_Aggregate
7485 | N_Floating_Point_Definition
7486 | N_Formal_Decimal_Fixed_Point_Definition
7487 | N_Formal_Derived_Type_Definition
7488 | N_Formal_Discrete_Type_Definition
7489 | N_Formal_Floating_Point_Definition
7490 | N_Formal_Modular_Type_Definition
7491 | N_Formal_Ordinary_Fixed_Point_Definition
7492 | N_Formal_Package_Declaration
7493 | N_Formal_Private_Type_Definition
7494 | N_Formal_Incomplete_Type_Definition
7495 | N_Formal_Signed_Integer_Type_Definition
7497 | N_Function_Specification
7498 | N_Generic_Association
7499 | N_Handled_Sequence_Of_Statements
7502 | N_Index_Or_Discriminant_Constraint
7503 | N_Indexed_Component
7505 | N_Iterator_Specification
7508 | N_Loop_Parameter_Specification
7510 | N_Modular_Type_Definition
7536 | N_Op_Shift_Right_Arithmetic
7540 | N_Ordinary_Fixed_Point_Definition
7542 | N_Package_Specification
7543 | N_Parameter_Association
7544 | N_Parameter_Specification
7545 | N_Pop_Constraint_Error_Label
7546 | N_Pop_Program_Error_Label
7547 | N_Pop_Storage_Error_Label
7548 | N_Pragma_Argument_Association
7549 | N_Procedure_Specification
7550 | N_Protected_Definition
7551 | N_Push_Constraint_Error_Label
7552 | N_Push_Program_Error_Label
7553 | N_Push_Storage_Error_Label
7554 | N_Qualified_Expression
7555 | N_Quantified_Expression
7556 | N_Raise_Expression
7558 | N_Range_Constraint
7560 | N_Real_Range_Specification
7561 | N_Record_Definition
7563 | N_SCIL_Dispatch_Table_Tag_Init
7564 | N_SCIL_Dispatching_Call
7565 | N_SCIL_Membership_Test
7566 | N_Selected_Component
7567 | N_Signed_Integer_Type_Definition
7568 | N_Single_Protected_Declaration
7571 | N_Subtype_Indication
7575 | N_Terminate_Alternative
7576 | N_Triggering_Alternative
7578 | N_Unchecked_Expression
7579 | N_Unchecked_Type_Conversion
7580 | N_Unconstrained_Array_Definition
7585 | N_Validate_Unchecked_Conversion
7591 -- If we fall through above tests, keep climbing tree
7595 if Nkind (Parent (N)) = N_Subunit then
7597 -- This is the proper body corresponding to a stub. Insertion must
7598 -- be done at the point of the stub, which is in the declarative
7599 -- part of the parent unit.
7601 P := Corresponding_Stub (Parent (N));
7609 -- Version with check(s) suppressed
7611 procedure Insert_Actions
7612 (Assoc_Node : Node_Id;
7613 Ins_Actions : List_Id;
7614 Suppress : Check_Id;
7615 Spec_Expr_OK : Boolean := False)
7618 if Suppress = All_Checks then
7620 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
7622 Scope_Suppress.Suppress := (others => True);
7623 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7624 Scope_Suppress.Suppress := Sva;
7629 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
7631 Scope_Suppress.Suppress (Suppress) := True;
7632 Insert_Actions (Assoc_Node, Ins_Actions, Spec_Expr_OK);
7633 Scope_Suppress.Suppress (Suppress) := Svg;
7638 --------------------------
7639 -- Insert_Actions_After --
7640 --------------------------
7642 procedure Insert_Actions_After
7643 (Assoc_Node : Node_Id;
7644 Ins_Actions : List_Id)
7647 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
7648 Store_After_Actions_In_Scope (Ins_Actions);
7650 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
7652 end Insert_Actions_After;
7654 ------------------------
7655 -- Insert_Declaration --
7656 ------------------------
7658 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
7662 pragma Assert (Nkind (N) in N_Subexpr);
7664 -- Climb until we find a procedure or a package
7668 pragma Assert (Present (Parent (P)));
7671 if Is_List_Member (P) then
7672 exit when Nkind_In (Parent (P), N_Package_Specification,
7675 -- Special handling for handled sequence of statements, we must
7676 -- insert in the statements not the exception handlers!
7678 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
7679 P := First (Statements (Parent (P)));
7685 -- Now do the insertion
7687 Insert_Before (P, Decl);
7689 end Insert_Declaration;
7691 ---------------------------------
7692 -- Insert_Library_Level_Action --
7693 ---------------------------------
7695 procedure Insert_Library_Level_Action (N : Node_Id) is
7696 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7699 Push_Scope (Cunit_Entity (Current_Sem_Unit));
7700 -- And not Main_Unit as previously. If the main unit is a body,
7701 -- the scope needed to analyze the actions is the entity of the
7702 -- corresponding declaration.
7704 if No (Actions (Aux)) then
7705 Set_Actions (Aux, New_List (N));
7707 Append (N, Actions (Aux));
7712 end Insert_Library_Level_Action;
7714 ----------------------------------
7715 -- Insert_Library_Level_Actions --
7716 ----------------------------------
7718 procedure Insert_Library_Level_Actions (L : List_Id) is
7719 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7722 if Is_Non_Empty_List (L) then
7723 Push_Scope (Cunit_Entity (Main_Unit));
7724 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
7726 if No (Actions (Aux)) then
7727 Set_Actions (Aux, L);
7730 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
7735 end Insert_Library_Level_Actions;
7737 ----------------------
7738 -- Inside_Init_Proc --
7739 ----------------------
7741 function Inside_Init_Proc return Boolean is
7742 Proc : constant Entity_Id := Enclosing_Init_Proc;
7745 return Proc /= Empty;
7746 end Inside_Init_Proc;
7748 ----------------------------
7749 -- Is_All_Null_Statements --
7750 ----------------------------
7752 function Is_All_Null_Statements (L : List_Id) return Boolean is
7757 while Present (Stm) loop
7758 if Nkind (Stm) /= N_Null_Statement then
7766 end Is_All_Null_Statements;
7768 --------------------------------------------------
7769 -- Is_Displacement_Of_Object_Or_Function_Result --
7770 --------------------------------------------------
7772 function Is_Displacement_Of_Object_Or_Function_Result
7773 (Obj_Id : Entity_Id) return Boolean
7775 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
7776 -- Determine whether node N denotes a controlled function call
7778 function Is_Controlled_Indexing (N : Node_Id) return Boolean;
7779 -- Determine whether node N denotes a generalized indexing form which
7780 -- involves a controlled result.
7782 function Is_Displace_Call (N : Node_Id) return Boolean;
7783 -- Determine whether node N denotes a call to Ada.Tags.Displace
7785 function Is_Source_Object (N : Node_Id) return Boolean;
7786 -- Determine whether a particular node denotes a source object
7788 function Strip (N : Node_Id) return Node_Id;
7789 -- Examine arbitrary node N by stripping various indirections and return
7792 ---------------------------------
7793 -- Is_Controlled_Function_Call --
7794 ---------------------------------
7796 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
7800 -- When a function call appears in Object.Operation format, the
7801 -- original representation has several possible forms depending on
7802 -- the availability and form of actual parameters:
7804 -- Obj.Func N_Selected_Component
7805 -- Obj.Func (Actual) N_Indexed_Component
7806 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
7807 -- N_Selected_Component
7809 Expr := Original_Node (N);
7811 if Nkind (Expr) = N_Function_Call then
7812 Expr := Name (Expr);
7814 -- "Obj.Func (Actual)" case
7816 elsif Nkind (Expr) = N_Indexed_Component then
7817 Expr := Prefix (Expr);
7819 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
7821 elsif Nkind (Expr) = N_Selected_Component then
7822 Expr := Selector_Name (Expr);
7830 Nkind (Expr) in N_Has_Entity
7831 and then Present (Entity (Expr))
7832 and then Ekind (Entity (Expr)) = E_Function
7833 and then Needs_Finalization (Etype (Entity (Expr)));
7834 end Is_Controlled_Function_Call;
7836 ----------------------------
7837 -- Is_Controlled_Indexing --
7838 ----------------------------
7840 function Is_Controlled_Indexing (N : Node_Id) return Boolean is
7841 Expr : constant Node_Id := Original_Node (N);
7845 Nkind (Expr) = N_Indexed_Component
7846 and then Present (Generalized_Indexing (Expr))
7847 and then Needs_Finalization (Etype (Expr));
7848 end Is_Controlled_Indexing;
7850 ----------------------
7851 -- Is_Displace_Call --
7852 ----------------------
7854 function Is_Displace_Call (N : Node_Id) return Boolean is
7855 Call : constant Node_Id := Strip (N);
7860 and then Nkind (Call) = N_Function_Call
7861 and then Nkind (Name (Call)) in N_Has_Entity
7862 and then Is_RTE (Entity (Name (Call)), RE_Displace);
7863 end Is_Displace_Call;
7865 ----------------------
7866 -- Is_Source_Object --
7867 ----------------------
7869 function Is_Source_Object (N : Node_Id) return Boolean is
7870 Obj : constant Node_Id := Strip (N);
7875 and then Comes_From_Source (Obj)
7876 and then Nkind (Obj) in N_Has_Entity
7877 and then Is_Object (Entity (Obj));
7878 end Is_Source_Object;
7884 function Strip (N : Node_Id) return Node_Id is
7890 if Nkind (Result) = N_Explicit_Dereference then
7891 Result := Prefix (Result);
7893 elsif Nkind_In (Result, N_Type_Conversion,
7894 N_Unchecked_Type_Conversion)
7896 Result := Expression (Result);
7908 Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
7909 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7910 Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
7911 Orig_Expr : Node_Id;
7913 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
7918 -- Obj : CW_Type := Function_Call (...);
7920 -- is rewritten into:
7922 -- Temp : ... := Function_Call (...)'reference;
7923 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
7925 -- where the return type of the function and the class-wide type require
7926 -- dispatch table pointer displacement.
7930 -- Obj : CW_Type := Container (...);
7932 -- is rewritten into:
7934 -- Temp : ... := Function_Call (Container, ...)'reference;
7935 -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
7937 -- where the container element type and the class-wide type require
7938 -- dispatch table pointer dispacement.
7942 -- Obj : CW_Type := Src_Obj;
7944 -- is rewritten into:
7946 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7948 -- where the type of the source object and the class-wide type require
7949 -- dispatch table pointer displacement.
7951 if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
7952 and then Is_Class_Wide_Type (Obj_Typ)
7953 and then Is_Displace_Call (Renamed_Object (Obj_Id))
7954 and then Nkind (Orig_Decl) = N_Object_Declaration
7955 and then Comes_From_Source (Orig_Decl)
7957 Orig_Expr := Expression (Orig_Decl);
7960 Is_Controlled_Function_Call (Orig_Expr)
7961 or else Is_Controlled_Indexing (Orig_Expr)
7962 or else Is_Source_Object (Orig_Expr);
7966 end Is_Displacement_Of_Object_Or_Function_Result;
7968 ------------------------------
7969 -- Is_Finalizable_Transient --
7970 ------------------------------
7972 function Is_Finalizable_Transient
7974 Rel_Node : Node_Id) return Boolean
7976 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
7977 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7979 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
7980 -- Determine whether transient object Trans_Id is initialized either
7981 -- by a function call which returns an access type or simply renames
7984 function Initialized_By_Aliased_BIP_Func_Call
7985 (Trans_Id : Entity_Id) return Boolean;
7986 -- Determine whether transient object Trans_Id is initialized by a
7987 -- build-in-place function call where the BIPalloc parameter is of
7988 -- value 1 and BIPaccess is not null. This case creates an aliasing
7989 -- between the returned value and the value denoted by BIPaccess.
7992 (Trans_Id : Entity_Id;
7993 First_Stmt : Node_Id) return Boolean;
7994 -- Determine whether transient object Trans_Id has been renamed or
7995 -- aliased through 'reference in the statement list starting from
7998 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
7999 -- Determine whether transient object Trans_Id is allocated on the heap
8001 function Is_Iterated_Container
8002 (Trans_Id : Entity_Id;
8003 First_Stmt : Node_Id) return Boolean;
8004 -- Determine whether transient object Trans_Id denotes a container which
8005 -- is in the process of being iterated in the statement list starting
8008 ---------------------------
8009 -- Initialized_By_Access --
8010 ---------------------------
8012 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
8013 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8018 and then Nkind (Expr) /= N_Reference
8019 and then Is_Access_Type (Etype (Expr));
8020 end Initialized_By_Access;
8022 ------------------------------------------
8023 -- Initialized_By_Aliased_BIP_Func_Call --
8024 ------------------------------------------
8026 function Initialized_By_Aliased_BIP_Func_Call
8027 (Trans_Id : Entity_Id) return Boolean
8029 Call : Node_Id := Expression (Parent (Trans_Id));
8032 -- Build-in-place calls usually appear in 'reference format
8034 if Nkind (Call) = N_Reference then
8035 Call := Prefix (Call);
8038 Call := Unqual_Conv (Call);
8040 if Is_Build_In_Place_Function_Call (Call) then
8042 Access_Nam : Name_Id := No_Name;
8043 Access_OK : Boolean := False;
8045 Alloc_Nam : Name_Id := No_Name;
8046 Alloc_OK : Boolean := False;
8048 Func_Id : Entity_Id;
8052 -- Examine all parameter associations of the function call
8054 Param := First (Parameter_Associations (Call));
8055 while Present (Param) loop
8056 if Nkind (Param) = N_Parameter_Association
8057 and then Nkind (Selector_Name (Param)) = N_Identifier
8059 Actual := Explicit_Actual_Parameter (Param);
8060 Formal := Selector_Name (Param);
8062 -- Construct the names of formals BIPaccess and BIPalloc
8063 -- using the function name retrieved from an arbitrary
8066 if Access_Nam = No_Name
8067 and then Alloc_Nam = No_Name
8068 and then Present (Entity (Formal))
8070 Func_Id := Scope (Entity (Formal));
8073 New_External_Name (Chars (Func_Id),
8074 BIP_Formal_Suffix (BIP_Object_Access));
8077 New_External_Name (Chars (Func_Id),
8078 BIP_Formal_Suffix (BIP_Alloc_Form));
8081 -- A match for BIPaccess => Temp has been found
8083 if Chars (Formal) = Access_Nam
8084 and then Nkind (Actual) /= N_Null
8089 -- A match for BIPalloc => 1 has been found
8091 if Chars (Formal) = Alloc_Nam
8092 and then Nkind (Actual) = N_Integer_Literal
8093 and then Intval (Actual) = Uint_1
8102 return Access_OK and Alloc_OK;
8107 end Initialized_By_Aliased_BIP_Func_Call;
8114 (Trans_Id : Entity_Id;
8115 First_Stmt : Node_Id) return Boolean
8117 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
8118 -- Given an object renaming declaration, retrieve the entity of the
8119 -- renamed name. Return Empty if the renamed name is anything other
8120 -- than a variable or a constant.
8122 -------------------------
8123 -- Find_Renamed_Object --
8124 -------------------------
8126 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
8127 Ren_Obj : Node_Id := Empty;
8129 function Find_Object (N : Node_Id) return Traverse_Result;
8130 -- Try to detect an object which is either a constant or a
8137 function Find_Object (N : Node_Id) return Traverse_Result is
8139 -- Stop the search once a constant or a variable has been
8142 if Nkind (N) = N_Identifier
8143 and then Present (Entity (N))
8144 and then Ekind_In (Entity (N), E_Constant, E_Variable)
8146 Ren_Obj := Entity (N);
8153 procedure Search is new Traverse_Proc (Find_Object);
8157 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
8159 -- Start of processing for Find_Renamed_Object
8162 -- Actions related to dispatching calls may appear as renamings of
8163 -- tags. Do not process this type of renaming because it does not
8164 -- use the actual value of the object.
8166 if not Is_RTE (Typ, RE_Tag_Ptr) then
8167 Search (Name (Ren_Decl));
8171 end Find_Renamed_Object;
8176 Ren_Obj : Entity_Id;
8179 -- Start of processing for Is_Aliased
8182 -- A controlled transient object is not considered aliased when it
8183 -- appears inside an expression_with_actions node even when there are
8184 -- explicit aliases of it:
8187 -- Trans_Id : Ctrl_Typ ...; -- transient object
8188 -- Alias : ... := Trans_Id; -- object is aliased
8189 -- Val : constant Boolean :=
8190 -- ... Alias ...; -- aliasing ends
8191 -- <finalize Trans_Id> -- object safe to finalize
8194 -- Expansion ensures that all aliases are encapsulated in the actions
8195 -- list and do not leak to the expression by forcing the evaluation
8196 -- of the expression.
8198 if Nkind (Rel_Node) = N_Expression_With_Actions then
8201 -- Otherwise examine the statements after the controlled transient
8202 -- object and look for various forms of aliasing.
8206 while Present (Stmt) loop
8207 if Nkind (Stmt) = N_Object_Declaration then
8208 Expr := Expression (Stmt);
8210 -- Aliasing of the form:
8211 -- Obj : ... := Trans_Id'reference;
8214 and then Nkind (Expr) = N_Reference
8215 and then Nkind (Prefix (Expr)) = N_Identifier
8216 and then Entity (Prefix (Expr)) = Trans_Id
8221 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
8222 Ren_Obj := Find_Renamed_Object (Stmt);
8224 -- Aliasing of the form:
8225 -- Obj : ... renames ... Trans_Id ...;
8227 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
8243 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
8244 Expr : constant Node_Id := Expression (Parent (Trans_Id));
8247 Is_Access_Type (Etype (Trans_Id))
8248 and then Present (Expr)
8249 and then Nkind (Expr) = N_Allocator;
8252 ---------------------------
8253 -- Is_Iterated_Container --
8254 ---------------------------
8256 function Is_Iterated_Container
8257 (Trans_Id : Entity_Id;
8258 First_Stmt : Node_Id) return Boolean
8268 -- It is not possible to iterate over containers in non-Ada 2012 code
8270 if Ada_Version < Ada_2012 then
8274 Typ := Etype (Trans_Id);
8276 -- Handle access type created for secondary stack use
8278 if Is_Access_Type (Typ) then
8279 Typ := Designated_Type (Typ);
8282 -- Look for aspect Default_Iterator. It may be part of a type
8283 -- declaration for a container, or inherited from a base type
8286 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8288 if Present (Aspect) then
8289 Iter := Entity (Aspect);
8291 -- Examine the statements following the container object and
8292 -- look for a call to the default iterate routine where the
8293 -- first parameter is the transient. Such a call appears as:
8295 -- It : Access_To_CW_Iterator :=
8296 -- Iterate (Tran_Id.all, ...)'reference;
8299 while Present (Stmt) loop
8301 -- Detect an object declaration which is initialized by a
8302 -- secondary stack function call.
8304 if Nkind (Stmt) = N_Object_Declaration
8305 and then Present (Expression (Stmt))
8306 and then Nkind (Expression (Stmt)) = N_Reference
8307 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8309 Call := Prefix (Expression (Stmt));
8311 -- The call must invoke the default iterate routine of
8312 -- the container and the transient object must appear as
8313 -- the first actual parameter. Skip any calls whose names
8314 -- are not entities.
8316 if Is_Entity_Name (Name (Call))
8317 and then Entity (Name (Call)) = Iter
8318 and then Present (Parameter_Associations (Call))
8320 Param := First (Parameter_Associations (Call));
8322 if Nkind (Param) = N_Explicit_Dereference
8323 and then Entity (Prefix (Param)) = Trans_Id
8335 end Is_Iterated_Container;
8339 Desig : Entity_Id := Obj_Typ;
8341 -- Start of processing for Is_Finalizable_Transient
8344 -- Handle access types
8346 if Is_Access_Type (Desig) then
8347 Desig := Available_View (Designated_Type (Desig));
8351 Ekind_In (Obj_Id, E_Constant, E_Variable)
8352 and then Needs_Finalization (Desig)
8353 and then Requires_Transient_Scope (Desig)
8354 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8356 -- Do not consider a transient object that was already processed
8358 and then not Is_Finalized_Transient (Obj_Id)
8360 -- Do not consider renamed or 'reference-d transient objects because
8361 -- the act of renaming extends the object's lifetime.
8363 and then not Is_Aliased (Obj_Id, Decl)
8365 -- Do not consider transient objects allocated on the heap since
8366 -- they are attached to a finalization master.
8368 and then not Is_Allocated (Obj_Id)
8370 -- If the transient object is a pointer, check that it is not
8371 -- initialized by a function that returns a pointer or acts as a
8372 -- renaming of another pointer.
8375 (not Is_Access_Type (Obj_Typ)
8376 or else not Initialized_By_Access (Obj_Id))
8378 -- Do not consider transient objects which act as indirect aliases
8379 -- of build-in-place function results.
8381 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8383 -- Do not consider conversions of tags to class-wide types
8385 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8387 -- Do not consider iterators because those are treated as normal
8388 -- controlled objects and are processed by the usual finalization
8389 -- machinery. This avoids the double finalization of an iterator.
8391 and then not Is_Iterator (Desig)
8393 -- Do not consider containers in the context of iterator loops. Such
8394 -- transient objects must exist for as long as the loop is around,
8395 -- otherwise any operation carried out by the iterator will fail.
8397 and then not Is_Iterated_Container (Obj_Id, Decl);
8398 end Is_Finalizable_Transient;
8400 ---------------------------------
8401 -- Is_Fully_Repped_Tagged_Type --
8402 ---------------------------------
8404 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8405 U : constant Entity_Id := Underlying_Type (T);
8409 if No (U) or else not Is_Tagged_Type (U) then
8411 elsif Has_Discriminants (U) then
8413 elsif not Has_Specified_Layout (U) then
8417 -- Here we have a tagged type, see if it has any component (other than
8418 -- tag and parent) with no component_clause. If so, we return False.
8420 Comp := First_Component (U);
8421 while Present (Comp) loop
8422 if not Is_Tag (Comp)
8423 and then Chars (Comp) /= Name_uParent
8424 and then No (Component_Clause (Comp))
8428 Next_Component (Comp);
8432 -- All components have clauses
8435 end Is_Fully_Repped_Tagged_Type;
8437 ----------------------------------
8438 -- Is_Library_Level_Tagged_Type --
8439 ----------------------------------
8441 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8443 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8444 end Is_Library_Level_Tagged_Type;
8446 --------------------------
8447 -- Is_Non_BIP_Func_Call --
8448 --------------------------
8450 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8452 -- The expected call is of the format
8454 -- Func_Call'reference
8457 Nkind (Expr) = N_Reference
8458 and then Nkind (Prefix (Expr)) = N_Function_Call
8459 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8460 end Is_Non_BIP_Func_Call;
8462 ----------------------------------
8463 -- Is_Possibly_Unaligned_Object --
8464 ----------------------------------
8466 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8467 T : constant Entity_Id := Etype (N);
8470 -- If renamed object, apply test to underlying object
8472 if Is_Entity_Name (N)
8473 and then Is_Object (Entity (N))
8474 and then Present (Renamed_Object (Entity (N)))
8476 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8479 -- Tagged and controlled types and aliased types are always aligned, as
8480 -- are concurrent types.
8483 or else Has_Controlled_Component (T)
8484 or else Is_Concurrent_Type (T)
8485 or else Is_Tagged_Type (T)
8486 or else Is_Controlled (T)
8491 -- If this is an element of a packed array, may be unaligned
8493 if Is_Ref_To_Bit_Packed_Array (N) then
8497 -- Case of indexed component reference: test whether prefix is unaligned
8499 if Nkind (N) = N_Indexed_Component then
8500 return Is_Possibly_Unaligned_Object (Prefix (N));
8502 -- Case of selected component reference
8504 elsif Nkind (N) = N_Selected_Component then
8506 P : constant Node_Id := Prefix (N);
8507 C : constant Entity_Id := Entity (Selector_Name (N));
8512 -- If component reference is for an array with nonstatic bounds,
8513 -- then it is always aligned: we can only process unaligned arrays
8514 -- with static bounds (more precisely compile time known bounds).
8516 if Is_Array_Type (T)
8517 and then not Compile_Time_Known_Bounds (T)
8522 -- If component is aliased, it is definitely properly aligned
8524 if Is_Aliased (C) then
8528 -- If component is for a type implemented as a scalar, and the
8529 -- record is packed, and the component is other than the first
8530 -- component of the record, then the component may be unaligned.
8532 if Is_Packed (Etype (P))
8533 and then Represented_As_Scalar (Etype (C))
8534 and then First_Entity (Scope (C)) /= C
8539 -- Compute maximum possible alignment for T
8541 -- If alignment is known, then that settles things
8543 if Known_Alignment (T) then
8544 M := UI_To_Int (Alignment (T));
8546 -- If alignment is not known, tentatively set max alignment
8549 M := Ttypes.Maximum_Alignment;
8551 -- We can reduce this if the Esize is known since the default
8552 -- alignment will never be more than the smallest power of 2
8553 -- that does not exceed this Esize value.
8555 if Known_Esize (T) then
8556 S := UI_To_Int (Esize (T));
8558 while (M / 2) >= S loop
8564 -- The following code is historical, it used to be present but it
8565 -- is too cautious, because the front-end does not know the proper
8566 -- default alignments for the target. Also, if the alignment is
8567 -- not known, the front end can't know in any case. If a copy is
8568 -- needed, the back-end will take care of it. This whole section
8569 -- including this comment can be removed later ???
8571 -- If the component reference is for a record that has a specified
8572 -- alignment, and we either know it is too small, or cannot tell,
8573 -- then the component may be unaligned.
8575 -- What is the following commented out code ???
8577 -- if Known_Alignment (Etype (P))
8578 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
8579 -- and then M > Alignment (Etype (P))
8584 -- Case of component clause present which may specify an
8585 -- unaligned position.
8587 if Present (Component_Clause (C)) then
8589 -- Otherwise we can do a test to make sure that the actual
8590 -- start position in the record, and the length, are both
8591 -- consistent with the required alignment. If not, we know
8592 -- that we are unaligned.
8595 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8601 -- For a component inherited in a record extension, the
8602 -- clause is inherited but position and size are not set.
8604 if Is_Base_Type (Etype (P))
8605 and then Is_Tagged_Type (Etype (P))
8606 and then Present (Original_Record_Component (Comp))
8608 Comp := Original_Record_Component (Comp);
8611 if Component_Bit_Offset (Comp) mod Align_In_Bits /= 0
8612 or else Esize (Comp) mod Align_In_Bits /= 0
8619 -- Otherwise, for a component reference, test prefix
8621 return Is_Possibly_Unaligned_Object (P);
8624 -- If not a component reference, must be aligned
8629 end Is_Possibly_Unaligned_Object;
8631 ---------------------------------
8632 -- Is_Possibly_Unaligned_Slice --
8633 ---------------------------------
8635 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
8637 -- Go to renamed object
8639 if Is_Entity_Name (N)
8640 and then Is_Object (Entity (N))
8641 and then Present (Renamed_Object (Entity (N)))
8643 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
8646 -- The reference must be a slice
8648 if Nkind (N) /= N_Slice then
8652 -- If it is a slice, then look at the array type being sliced
8655 Sarr : constant Node_Id := Prefix (N);
8656 -- Prefix of the slice, i.e. the array being sliced
8658 Styp : constant Entity_Id := Etype (Prefix (N));
8659 -- Type of the array being sliced
8665 -- The problems arise if the array object that is being sliced
8666 -- is a component of a record or array, and we cannot guarantee
8667 -- the alignment of the array within its containing object.
8669 -- To investigate this, we look at successive prefixes to see
8670 -- if we have a worrisome indexed or selected component.
8674 -- Case of array is part of an indexed component reference
8676 if Nkind (Pref) = N_Indexed_Component then
8677 Ptyp := Etype (Prefix (Pref));
8679 -- The only problematic case is when the array is packed, in
8680 -- which case we really know nothing about the alignment of
8681 -- individual components.
8683 if Is_Bit_Packed_Array (Ptyp) then
8687 -- Case of array is part of a selected component reference
8689 elsif Nkind (Pref) = N_Selected_Component then
8690 Ptyp := Etype (Prefix (Pref));
8692 -- We are definitely in trouble if the record in question
8693 -- has an alignment, and either we know this alignment is
8694 -- inconsistent with the alignment of the slice, or we don't
8695 -- know what the alignment of the slice should be. But this
8696 -- really matters only if the target has strict alignment.
8698 if Target_Strict_Alignment
8699 and then Known_Alignment (Ptyp)
8700 and then (Unknown_Alignment (Styp)
8701 or else Alignment (Styp) > Alignment (Ptyp))
8706 -- We are in potential trouble if the record type is packed.
8707 -- We could special case when we know that the array is the
8708 -- first component, but that's not such a simple case ???
8710 if Is_Packed (Ptyp) then
8714 -- We are in trouble if there is a component clause, and
8715 -- either we do not know the alignment of the slice, or
8716 -- the alignment of the slice is inconsistent with the
8717 -- bit position specified by the component clause.
8720 Field : constant Entity_Id := Entity (Selector_Name (Pref));
8722 if Present (Component_Clause (Field))
8724 (Unknown_Alignment (Styp)
8726 (Component_Bit_Offset (Field) mod
8727 (System_Storage_Unit * Alignment (Styp))) /= 0)
8733 -- For cases other than selected or indexed components we know we
8734 -- are OK, since no issues arise over alignment.
8740 -- We processed an indexed component or selected component
8741 -- reference that looked safe, so keep checking prefixes.
8743 Pref := Prefix (Pref);
8746 end Is_Possibly_Unaligned_Slice;
8748 -------------------------------
8749 -- Is_Related_To_Func_Return --
8750 -------------------------------
8752 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
8753 Expr : constant Node_Id := Related_Expression (Id);
8757 and then Nkind (Expr) = N_Explicit_Dereference
8758 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
8759 end Is_Related_To_Func_Return;
8761 --------------------------------
8762 -- Is_Ref_To_Bit_Packed_Array --
8763 --------------------------------
8765 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
8770 if Is_Entity_Name (N)
8771 and then Is_Object (Entity (N))
8772 and then Present (Renamed_Object (Entity (N)))
8774 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
8777 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8778 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
8781 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
8784 if Result and then Nkind (N) = N_Indexed_Component then
8785 Expr := First (Expressions (N));
8786 while Present (Expr) loop
8787 Force_Evaluation (Expr);
8797 end Is_Ref_To_Bit_Packed_Array;
8799 --------------------------------
8800 -- Is_Ref_To_Bit_Packed_Slice --
8801 --------------------------------
8803 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
8805 if Nkind (N) = N_Type_Conversion then
8806 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
8808 elsif Is_Entity_Name (N)
8809 and then Is_Object (Entity (N))
8810 and then Present (Renamed_Object (Entity (N)))
8812 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
8814 elsif Nkind (N) = N_Slice
8815 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
8819 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8820 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
8825 end Is_Ref_To_Bit_Packed_Slice;
8827 -----------------------
8828 -- Is_Renamed_Object --
8829 -----------------------
8831 function Is_Renamed_Object (N : Node_Id) return Boolean is
8832 Pnod : constant Node_Id := Parent (N);
8833 Kind : constant Node_Kind := Nkind (Pnod);
8835 if Kind = N_Object_Renaming_Declaration then
8837 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
8838 return Is_Renamed_Object (Pnod);
8842 end Is_Renamed_Object;
8844 --------------------------------------
8845 -- Is_Secondary_Stack_BIP_Func_Call --
8846 --------------------------------------
8848 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
8849 Alloc_Nam : Name_Id := No_Name;
8851 Call : Node_Id := Expr;
8856 -- Build-in-place calls usually appear in 'reference format. Note that
8857 -- the accessibility check machinery may add an extra 'reference due to
8858 -- side effect removal.
8860 while Nkind (Call) = N_Reference loop
8861 Call := Prefix (Call);
8864 Call := Unqual_Conv (Call);
8866 if Is_Build_In_Place_Function_Call (Call) then
8868 -- Examine all parameter associations of the function call
8870 Param := First (Parameter_Associations (Call));
8871 while Present (Param) loop
8872 if Nkind (Param) = N_Parameter_Association then
8873 Formal := Selector_Name (Param);
8874 Actual := Explicit_Actual_Parameter (Param);
8876 -- Construct the name of formal BIPalloc. It is much easier to
8877 -- extract the name of the function using an arbitrary formal's
8878 -- scope rather than the Name field of Call.
8880 if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
8883 (Chars (Scope (Entity (Formal))),
8884 BIP_Formal_Suffix (BIP_Alloc_Form));
8887 -- A match for BIPalloc => 2 has been found
8889 if Chars (Formal) = Alloc_Nam
8890 and then Nkind (Actual) = N_Integer_Literal
8891 and then Intval (Actual) = Uint_2
8902 end Is_Secondary_Stack_BIP_Func_Call;
8904 -------------------------------------
8905 -- Is_Tag_To_Class_Wide_Conversion --
8906 -------------------------------------
8908 function Is_Tag_To_Class_Wide_Conversion
8909 (Obj_Id : Entity_Id) return Boolean
8911 Expr : constant Node_Id := Expression (Parent (Obj_Id));
8915 Is_Class_Wide_Type (Etype (Obj_Id))
8916 and then Present (Expr)
8917 and then Nkind (Expr) = N_Unchecked_Type_Conversion
8918 and then Etype (Expression (Expr)) = RTE (RE_Tag);
8919 end Is_Tag_To_Class_Wide_Conversion;
8921 ----------------------------
8922 -- Is_Untagged_Derivation --
8923 ----------------------------
8925 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
8927 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
8929 (Is_Private_Type (T) and then Present (Full_View (T))
8930 and then not Is_Tagged_Type (Full_View (T))
8931 and then Is_Derived_Type (Full_View (T))
8932 and then Etype (Full_View (T)) /= T);
8933 end Is_Untagged_Derivation;
8935 ------------------------------------
8936 -- Is_Untagged_Private_Derivation --
8937 ------------------------------------
8939 function Is_Untagged_Private_Derivation
8940 (Priv_Typ : Entity_Id;
8941 Full_Typ : Entity_Id) return Boolean
8946 and then Is_Untagged_Derivation (Priv_Typ)
8947 and then Is_Private_Type (Etype (Priv_Typ))
8948 and then Present (Full_Typ)
8949 and then Is_Itype (Full_Typ);
8950 end Is_Untagged_Private_Derivation;
8952 ------------------------------
8953 -- Is_Verifiable_DIC_Pragma --
8954 ------------------------------
8956 function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
8957 Args : constant List_Id := Pragma_Argument_Associations (Prag);
8960 -- To qualify as verifiable, a DIC pragma must have a non-null argument
8964 and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
8965 end Is_Verifiable_DIC_Pragma;
8967 ---------------------------
8968 -- Is_Volatile_Reference --
8969 ---------------------------
8971 function Is_Volatile_Reference (N : Node_Id) return Boolean is
8973 -- Only source references are to be treated as volatile, internally
8974 -- generated stuff cannot have volatile external effects.
8976 if not Comes_From_Source (N) then
8979 -- Never true for reference to a type
8981 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
8984 -- Never true for a compile time known constant
8986 elsif Compile_Time_Known_Value (N) then
8989 -- True if object reference with volatile type
8991 elsif Is_Volatile_Object (N) then
8994 -- True if reference to volatile entity
8996 elsif Is_Entity_Name (N) then
8997 return Treat_As_Volatile (Entity (N));
8999 -- True for slice of volatile array
9001 elsif Nkind (N) = N_Slice then
9002 return Is_Volatile_Reference (Prefix (N));
9004 -- True if volatile component
9006 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
9007 if (Is_Entity_Name (Prefix (N))
9008 and then Has_Volatile_Components (Entity (Prefix (N))))
9009 or else (Present (Etype (Prefix (N)))
9010 and then Has_Volatile_Components (Etype (Prefix (N))))
9014 return Is_Volatile_Reference (Prefix (N));
9022 end Is_Volatile_Reference;
9024 --------------------
9025 -- Kill_Dead_Code --
9026 --------------------
9028 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
9029 W : Boolean := Warn;
9030 -- Set False if warnings suppressed
9034 Remove_Warning_Messages (N);
9036 -- Update the internal structures of the ABE mechanism in case the
9037 -- dead node is an elaboration scenario.
9039 Kill_Elaboration_Scenario (N);
9041 -- Generate warning if appropriate
9045 -- We suppress the warning if this code is under control of an
9046 -- if statement, whose condition is a simple identifier, and
9047 -- either we are in an instance, or warnings off is set for this
9048 -- identifier. The reason for killing it in the instance case is
9049 -- that it is common and reasonable for code to be deleted in
9050 -- instances for various reasons.
9052 -- Could we use Is_Statically_Unevaluated here???
9054 if Nkind (Parent (N)) = N_If_Statement then
9056 C : constant Node_Id := Condition (Parent (N));
9058 if Nkind (C) = N_Identifier
9061 or else (Present (Entity (C))
9062 and then Has_Warnings_Off (Entity (C))))
9069 -- Generate warning if not suppressed
9073 ("?t?this code can never be executed and has been deleted!",
9078 -- Recurse into block statements and bodies to process declarations
9081 if Nkind (N) = N_Block_Statement
9082 or else Nkind (N) = N_Subprogram_Body
9083 or else Nkind (N) = N_Package_Body
9085 Kill_Dead_Code (Declarations (N), False);
9086 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
9088 if Nkind (N) = N_Subprogram_Body then
9089 Set_Is_Eliminated (Defining_Entity (N));
9092 elsif Nkind (N) = N_Package_Declaration then
9093 Kill_Dead_Code (Visible_Declarations (Specification (N)));
9094 Kill_Dead_Code (Private_Declarations (Specification (N)));
9096 -- ??? After this point, Delete_Tree has been called on all
9097 -- declarations in Specification (N), so references to entities
9098 -- therein look suspicious.
9101 E : Entity_Id := First_Entity (Defining_Entity (N));
9104 while Present (E) loop
9105 if Ekind (E) = E_Operator then
9106 Set_Is_Eliminated (E);
9113 -- Recurse into composite statement to kill individual statements in
9114 -- particular instantiations.
9116 elsif Nkind (N) = N_If_Statement then
9117 Kill_Dead_Code (Then_Statements (N));
9118 Kill_Dead_Code (Elsif_Parts (N));
9119 Kill_Dead_Code (Else_Statements (N));
9121 elsif Nkind (N) = N_Loop_Statement then
9122 Kill_Dead_Code (Statements (N));
9124 elsif Nkind (N) = N_Case_Statement then
9128 Alt := First (Alternatives (N));
9129 while Present (Alt) loop
9130 Kill_Dead_Code (Statements (Alt));
9135 elsif Nkind (N) = N_Case_Statement_Alternative then
9136 Kill_Dead_Code (Statements (N));
9138 -- Deal with dead instances caused by deleting instantiations
9140 elsif Nkind (N) in N_Generic_Instantiation then
9141 Remove_Dead_Instance (N);
9146 -- Case where argument is a list of nodes to be killed
9148 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
9155 if Is_Non_Empty_List (L) then
9157 while Present (N) loop
9158 Kill_Dead_Code (N, W);
9165 ------------------------
9166 -- Known_Non_Negative --
9167 ------------------------
9169 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
9171 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
9176 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
9179 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
9182 end Known_Non_Negative;
9184 -----------------------------
9185 -- Make_CW_Equivalent_Type --
9186 -----------------------------
9188 -- Create a record type used as an equivalent of any member of the class
9189 -- which takes its size from exp.
9191 -- Generate the following code:
9193 -- type Equiv_T is record
9194 -- _parent : T (List of discriminant constraints taken from Exp);
9195 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
9198 -- ??? Note that this type does not guarantee same alignment as all
9201 -- Note: for the freezing circuitry, this looks like a record extension,
9202 -- and so we need to make sure that the scalar storage order is the same
9203 -- as that of the parent type. (This does not change anything for the
9204 -- representation of the extension part.)
9206 function Make_CW_Equivalent_Type
9208 E : Node_Id) return Entity_Id
9210 Loc : constant Source_Ptr := Sloc (E);
9211 Root_Typ : constant Entity_Id := Root_Type (T);
9212 Root_Utyp : constant Entity_Id := Underlying_Type (Root_Typ);
9213 List_Def : constant List_Id := Empty_List;
9214 Comp_List : constant List_Id := New_List;
9215 Equiv_Type : Entity_Id;
9216 Range_Type : Entity_Id;
9217 Str_Type : Entity_Id;
9218 Constr_Root : Entity_Id;
9222 -- If the root type is already constrained, there are no discriminants
9223 -- in the expression.
9225 if not Has_Discriminants (Root_Typ)
9226 or else Is_Constrained (Root_Typ)
9228 Constr_Root := Root_Typ;
9230 -- At this point in the expansion, nonlimited view of the type
9231 -- must be available, otherwise the error will be reported later.
9233 if From_Limited_With (Constr_Root)
9234 and then Present (Non_Limited_View (Constr_Root))
9236 Constr_Root := Non_Limited_View (Constr_Root);
9240 Constr_Root := Make_Temporary (Loc, 'R');
9242 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9244 Append_To (List_Def,
9245 Make_Subtype_Declaration (Loc,
9246 Defining_Identifier => Constr_Root,
9247 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9250 -- Generate the range subtype declaration
9252 Range_Type := Make_Temporary (Loc, 'G');
9254 if not Is_Interface (Root_Typ) then
9256 -- subtype rg__xx is
9257 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
9260 Make_Op_Subtract (Loc,
9262 Make_Attribute_Reference (Loc,
9264 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9265 Attribute_Name => Name_Size),
9267 Make_Attribute_Reference (Loc,
9268 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9269 Attribute_Name => Name_Object_Size));
9271 -- subtype rg__xx is
9272 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
9275 Make_Attribute_Reference (Loc,
9277 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9278 Attribute_Name => Name_Size);
9281 Set_Paren_Count (Sizexpr, 1);
9283 Append_To (List_Def,
9284 Make_Subtype_Declaration (Loc,
9285 Defining_Identifier => Range_Type,
9286 Subtype_Indication =>
9287 Make_Subtype_Indication (Loc,
9288 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9289 Constraint => Make_Range_Constraint (Loc,
9292 Low_Bound => Make_Integer_Literal (Loc, 1),
9294 Make_Op_Divide (Loc,
9295 Left_Opnd => Sizexpr,
9296 Right_Opnd => Make_Integer_Literal (Loc,
9297 Intval => System_Storage_Unit)))))));
9299 -- subtype str__nn is Storage_Array (rg__x);
9301 Str_Type := Make_Temporary (Loc, 'S');
9302 Append_To (List_Def,
9303 Make_Subtype_Declaration (Loc,
9304 Defining_Identifier => Str_Type,
9305 Subtype_Indication =>
9306 Make_Subtype_Indication (Loc,
9307 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9309 Make_Index_Or_Discriminant_Constraint (Loc,
9311 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9313 -- type Equiv_T is record
9314 -- [ _parent : Tnn; ]
9318 Equiv_Type := Make_Temporary (Loc, 'T');
9319 Set_Ekind (Equiv_Type, E_Record_Type);
9320 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9322 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9323 -- treatment for this type. In particular, even though _parent's type
9324 -- is a controlled type or contains controlled components, we do not
9325 -- want to set Has_Controlled_Component on it to avoid making it gain
9326 -- an unwanted _controller component.
9328 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9330 -- A class-wide equivalent type does not require initialization
9332 Set_Suppress_Initialization (Equiv_Type);
9334 if not Is_Interface (Root_Typ) then
9335 Append_To (Comp_List,
9336 Make_Component_Declaration (Loc,
9337 Defining_Identifier =>
9338 Make_Defining_Identifier (Loc, Name_uParent),
9339 Component_Definition =>
9340 Make_Component_Definition (Loc,
9341 Aliased_Present => False,
9342 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9344 Set_Reverse_Storage_Order
9345 (Equiv_Type, Reverse_Storage_Order (Base_Type (Root_Utyp)));
9346 Set_Reverse_Bit_Order
9347 (Equiv_Type, Reverse_Bit_Order (Base_Type (Root_Utyp)));
9350 Append_To (Comp_List,
9351 Make_Component_Declaration (Loc,
9352 Defining_Identifier => Make_Temporary (Loc, 'C'),
9353 Component_Definition =>
9354 Make_Component_Definition (Loc,
9355 Aliased_Present => False,
9356 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9358 Append_To (List_Def,
9359 Make_Full_Type_Declaration (Loc,
9360 Defining_Identifier => Equiv_Type,
9362 Make_Record_Definition (Loc,
9364 Make_Component_List (Loc,
9365 Component_Items => Comp_List,
9366 Variant_Part => Empty))));
9368 -- Suppress all checks during the analysis of the expanded code to avoid
9369 -- the generation of spurious warnings under ZFP run-time.
9371 Insert_Actions (E, List_Def, Suppress => All_Checks);
9373 end Make_CW_Equivalent_Type;
9375 -------------------------
9376 -- Make_Invariant_Call --
9377 -------------------------
9379 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9380 Loc : constant Source_Ptr := Sloc (Expr);
9381 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9383 Proc_Id : Entity_Id;
9386 pragma Assert (Has_Invariants (Typ));
9388 Proc_Id := Invariant_Procedure (Typ);
9389 pragma Assert (Present (Proc_Id));
9391 -- Ignore the invariant if that policy is in effect
9393 if Invariants_Ignored (Typ) then
9394 return Make_Null_Statement (Loc);
9397 Make_Procedure_Call_Statement (Loc,
9398 Name => New_Occurrence_Of (Proc_Id, Loc),
9399 Parameter_Associations => New_List (Relocate_Node (Expr)));
9401 end Make_Invariant_Call;
9403 ------------------------
9404 -- Make_Literal_Range --
9405 ------------------------
9407 function Make_Literal_Range
9409 Literal_Typ : Entity_Id) return Node_Id
9411 Lo : constant Node_Id :=
9412 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9413 Index : constant Entity_Id := Etype (Lo);
9414 Length_Expr : constant Node_Id :=
9415 Make_Op_Subtract (Loc,
9417 Make_Integer_Literal (Loc,
9418 Intval => String_Literal_Length (Literal_Typ)),
9419 Right_Opnd => Make_Integer_Literal (Loc, 1));
9424 Set_Analyzed (Lo, False);
9426 if Is_Integer_Type (Index) then
9429 Left_Opnd => New_Copy_Tree (Lo),
9430 Right_Opnd => Length_Expr);
9433 Make_Attribute_Reference (Loc,
9434 Attribute_Name => Name_Val,
9435 Prefix => New_Occurrence_Of (Index, Loc),
9436 Expressions => New_List (
9439 Make_Attribute_Reference (Loc,
9440 Attribute_Name => Name_Pos,
9441 Prefix => New_Occurrence_Of (Index, Loc),
9442 Expressions => New_List (New_Copy_Tree (Lo))),
9443 Right_Opnd => Length_Expr)));
9450 end Make_Literal_Range;
9452 --------------------------
9453 -- Make_Non_Empty_Check --
9454 --------------------------
9456 function Make_Non_Empty_Check
9458 N : Node_Id) return Node_Id
9464 Make_Attribute_Reference (Loc,
9465 Attribute_Name => Name_Length,
9466 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9468 Make_Integer_Literal (Loc, 0));
9469 end Make_Non_Empty_Check;
9471 -------------------------
9472 -- Make_Predicate_Call --
9473 -------------------------
9475 -- WARNING: This routine manages Ghost regions. Return statements must be
9476 -- replaced by gotos which jump to the end of the routine and restore the
9479 function Make_Predicate_Call
9482 Mem : Boolean := False) return Node_Id
9484 Loc : constant Source_Ptr := Sloc (Expr);
9486 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9487 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
9488 -- Save the Ghost-related attributes to restore on exit
9491 Func_Id : Entity_Id;
9494 Func_Id := Predicate_Function (Typ);
9495 pragma Assert (Present (Func_Id));
9497 -- The related type may be subject to pragma Ghost. Set the mode now to
9498 -- ensure that the call is properly marked as Ghost.
9500 Set_Ghost_Mode (Typ);
9502 -- Call special membership version if requested and available
9504 if Mem and then Present (Predicate_Function_M (Typ)) then
9505 Func_Id := Predicate_Function_M (Typ);
9508 -- Case of calling normal predicate function
9510 -- If the type is tagged, the expression may be class-wide, in which
9511 -- case it has to be converted to its root type, given that the
9512 -- generated predicate function is not dispatching. The conversion is
9513 -- type-safe and does not need validation, which matters when private
9514 -- extensions are involved.
9516 if Is_Tagged_Type (Typ) then
9518 Make_Function_Call (Loc,
9519 Name => New_Occurrence_Of (Func_Id, Loc),
9520 Parameter_Associations =>
9521 New_List (OK_Convert_To (Typ, Relocate_Node (Expr))));
9524 Make_Function_Call (Loc,
9525 Name => New_Occurrence_Of (Func_Id, Loc),
9526 Parameter_Associations => New_List (Relocate_Node (Expr)));
9529 Restore_Ghost_Region (Saved_GM, Saved_IGR);
9532 end Make_Predicate_Call;
9534 --------------------------
9535 -- Make_Predicate_Check --
9536 --------------------------
9538 function Make_Predicate_Check
9540 Expr : Node_Id) return Node_Id
9542 Loc : constant Source_Ptr := Sloc (Expr);
9544 procedure Add_Failure_Expression (Args : List_Id);
9545 -- Add the failure expression of pragma Predicate_Failure (if any) to
9548 ----------------------------
9549 -- Add_Failure_Expression --
9550 ----------------------------
9552 procedure Add_Failure_Expression (Args : List_Id) is
9553 function Failure_Expression return Node_Id;
9554 pragma Inline (Failure_Expression);
9555 -- Find aspect or pragma Predicate_Failure that applies to type Typ
9556 -- and return its expression. Return Empty if no such annotation is
9559 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean;
9560 pragma Inline (Is_OK_PF_Aspect);
9561 -- Determine whether aspect Asp is a suitable Predicate_Failure
9562 -- aspect that applies to type Typ.
9564 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean;
9565 pragma Inline (Is_OK_PF_Pragma);
9566 -- Determine whether pragma Prag is a suitable Predicate_Failure
9567 -- pragma that applies to type Typ.
9569 procedure Replace_Subtype_Reference (N : Node_Id);
9570 -- Replace the current instance of type Typ denoted by N with
9573 ------------------------
9574 -- Failure_Expression --
9575 ------------------------
9577 function Failure_Expression return Node_Id is
9581 -- The management of the rep item chain involves "inheritance" of
9582 -- parent type chains. If a parent [sub]type is already subject to
9583 -- pragma Predicate_Failure, then the pragma will also appear in
9584 -- the chain of the child [sub]type, which in turn may possess a
9585 -- pragma of its own. Avoid order-dependent issues by inspecting
9586 -- the rep item chain directly. Note that routine Get_Pragma may
9587 -- return a parent pragma.
9589 Item := First_Rep_Item (Typ);
9590 while Present (Item) loop
9592 -- Predicate_Failure appears as an aspect
9594 if Nkind (Item) = N_Aspect_Specification
9595 and then Is_OK_PF_Aspect (Item)
9597 return Expression (Item);
9599 -- Predicate_Failure appears as a pragma
9601 elsif Nkind (Item) = N_Pragma
9602 and then Is_OK_PF_Pragma (Item)
9606 (Next (First (Pragma_Argument_Associations (Item))));
9609 Item := Next_Rep_Item (Item);
9613 end Failure_Expression;
9615 ---------------------
9616 -- Is_OK_PF_Aspect --
9617 ---------------------
9619 function Is_OK_PF_Aspect (Asp : Node_Id) return Boolean is
9621 -- To qualify, the aspect must apply to the type subjected to the
9625 Chars (Identifier (Asp)) = Name_Predicate_Failure
9626 and then Present (Entity (Asp))
9627 and then Entity (Asp) = Typ;
9628 end Is_OK_PF_Aspect;
9630 ---------------------
9631 -- Is_OK_PF_Pragma --
9632 ---------------------
9634 function Is_OK_PF_Pragma (Prag : Node_Id) return Boolean is
9635 Args : constant List_Id := Pragma_Argument_Associations (Prag);
9639 -- Nothing to do when the pragma does not denote Predicate_Failure
9641 if Pragma_Name (Prag) /= Name_Predicate_Failure then
9644 -- Nothing to do when the pragma lacks arguments, in which case it
9647 elsif No (Args) or else Is_Empty_List (Args) then
9651 Typ_Arg := Get_Pragma_Arg (First (Args));
9653 -- To qualify, the local name argument of the pragma must denote
9654 -- the type subjected to the predicate check.
9657 Is_Entity_Name (Typ_Arg)
9658 and then Present (Entity (Typ_Arg))
9659 and then Entity (Typ_Arg) = Typ;
9660 end Is_OK_PF_Pragma;
9662 --------------------------------
9663 -- Replace_Subtype_Reference --
9664 --------------------------------
9666 procedure Replace_Subtype_Reference (N : Node_Id) is
9668 Rewrite (N, New_Copy_Tree (Expr));
9670 -- We want to treat the node as if it comes from source, so that
9671 -- ASIS will not ignore it.
9673 Set_Comes_From_Source (N, True);
9674 end Replace_Subtype_Reference;
9676 procedure Replace_Subtype_References is
9677 new Replace_Type_References_Generic (Replace_Subtype_Reference);
9681 PF_Expr : constant Node_Id := Failure_Expression;
9684 -- Start of processing for Add_Failure_Expression
9687 if Present (PF_Expr) then
9689 -- Replace any occurrences of the current instance of the type
9690 -- with the object subjected to the predicate check.
9692 Expr := New_Copy_Tree (PF_Expr);
9693 Replace_Subtype_References (Expr, Typ);
9695 -- The failure expression appears as the third argument of the
9699 Make_Pragma_Argument_Association (Loc,
9700 Expression => Expr));
9702 end Add_Failure_Expression;
9709 -- Start of processing for Make_Predicate_Check
9712 -- If predicate checks are suppressed, then return a null statement. For
9713 -- this call, we check only the scope setting. If the caller wants to
9714 -- check a specific entity's setting, they must do it manually.
9716 if Predicate_Checks_Suppressed (Empty) then
9717 return Make_Null_Statement (Loc);
9720 -- Do not generate a check within an internal subprogram (stream
9721 -- functions and the like, including predicate functions).
9723 if Within_Internal_Subprogram then
9724 return Make_Null_Statement (Loc);
9727 -- Compute proper name to use, we need to get this right so that the
9728 -- right set of check policies apply to the Check pragma we are making.
9730 if Has_Dynamic_Predicate_Aspect (Typ) then
9731 Nam := Name_Dynamic_Predicate;
9732 elsif Has_Static_Predicate_Aspect (Typ) then
9733 Nam := Name_Static_Predicate;
9735 Nam := Name_Predicate;
9739 Make_Pragma_Argument_Association (Loc,
9740 Expression => Make_Identifier (Loc, Nam)),
9741 Make_Pragma_Argument_Association (Loc,
9742 Expression => Make_Predicate_Call (Typ, Expr)));
9744 -- If the subtype is subject to pragma Predicate_Failure, add the
9745 -- failure expression as an additional parameter.
9747 Add_Failure_Expression (Args);
9751 Chars => Name_Check,
9752 Pragma_Argument_Associations => Args);
9753 end Make_Predicate_Check;
9755 ----------------------------
9756 -- Make_Subtype_From_Expr --
9757 ----------------------------
9759 -- 1. If Expr is an unconstrained array expression, creates
9760 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
9762 -- 2. If Expr is a unconstrained discriminated type expression, creates
9763 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
9765 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
9767 function Make_Subtype_From_Expr
9769 Unc_Typ : Entity_Id;
9770 Related_Id : Entity_Id := Empty) return Node_Id
9772 List_Constr : constant List_Id := New_List;
9773 Loc : constant Source_Ptr := Sloc (E);
9776 Full_Subtyp : Entity_Id;
9777 High_Bound : Entity_Id;
9778 Index_Typ : Entity_Id;
9779 Low_Bound : Entity_Id;
9780 Priv_Subtyp : Entity_Id;
9784 if Is_Private_Type (Unc_Typ)
9785 and then Has_Unknown_Discriminants (Unc_Typ)
9787 -- The caller requests a unique external name for both the private
9788 -- and the full subtype.
9790 if Present (Related_Id) then
9792 Make_Defining_Identifier (Loc,
9793 Chars => New_External_Name (Chars (Related_Id), 'C'));
9795 Make_Defining_Identifier (Loc,
9796 Chars => New_External_Name (Chars (Related_Id), 'P'));
9799 Full_Subtyp := Make_Temporary (Loc, 'C');
9800 Priv_Subtyp := Make_Temporary (Loc, 'P');
9803 -- Prepare the subtype completion. Use the base type to find the
9804 -- underlying type because the type may be a generic actual or an
9805 -- explicit subtype.
9807 Utyp := Underlying_Type (Base_Type (Unc_Typ));
9810 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
9811 Set_Parent (Full_Exp, Parent (E));
9814 Make_Subtype_Declaration (Loc,
9815 Defining_Identifier => Full_Subtyp,
9816 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
9818 -- Define the dummy private subtype
9820 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
9821 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
9822 Set_Scope (Priv_Subtyp, Full_Subtyp);
9823 Set_Is_Constrained (Priv_Subtyp);
9824 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
9825 Set_Is_Itype (Priv_Subtyp);
9826 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
9828 if Is_Tagged_Type (Priv_Subtyp) then
9830 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
9831 Set_Direct_Primitive_Operations (Priv_Subtyp,
9832 Direct_Primitive_Operations (Unc_Typ));
9835 Set_Full_View (Priv_Subtyp, Full_Subtyp);
9837 return New_Occurrence_Of (Priv_Subtyp, Loc);
9839 elsif Is_Array_Type (Unc_Typ) then
9840 Index_Typ := First_Index (Unc_Typ);
9841 for J in 1 .. Number_Dimensions (Unc_Typ) loop
9843 -- Capture the bounds of each index constraint in case the context
9844 -- is an object declaration of an unconstrained type initialized
9845 -- by a function call:
9847 -- Obj : Unconstr_Typ := Func_Call;
9849 -- This scenario requires secondary scope management and the index
9850 -- constraint cannot depend on the temporary used to capture the
9851 -- result of the function call.
9854 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
9855 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
9856 -- Obj : S := Temp.all;
9857 -- SS_Release; -- Temp is gone at this point, bounds of S are
9861 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
9863 Low_Bound := Make_Temporary (Loc, 'B');
9865 Make_Object_Declaration (Loc,
9866 Defining_Identifier => Low_Bound,
9867 Object_Definition =>
9868 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
9869 Constant_Present => True,
9871 Make_Attribute_Reference (Loc,
9872 Prefix => Duplicate_Subexpr_No_Checks (E),
9873 Attribute_Name => Name_First,
9874 Expressions => New_List (
9875 Make_Integer_Literal (Loc, J)))));
9878 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
9880 High_Bound := Make_Temporary (Loc, 'B');
9882 Make_Object_Declaration (Loc,
9883 Defining_Identifier => High_Bound,
9884 Object_Definition =>
9885 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
9886 Constant_Present => True,
9888 Make_Attribute_Reference (Loc,
9889 Prefix => Duplicate_Subexpr_No_Checks (E),
9890 Attribute_Name => Name_Last,
9891 Expressions => New_List (
9892 Make_Integer_Literal (Loc, J)))));
9894 Append_To (List_Constr,
9896 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
9897 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
9899 Index_Typ := Next_Index (Index_Typ);
9902 elsif Is_Class_Wide_Type (Unc_Typ) then
9904 CW_Subtype : Entity_Id;
9905 EQ_Typ : Entity_Id := Empty;
9908 -- A class-wide equivalent type is not needed on VM targets
9909 -- because the VM back-ends handle the class-wide object
9910 -- initialization itself (and doesn't need or want the
9911 -- additional intermediate type to handle the assignment).
9913 if Expander_Active and then Tagged_Type_Expansion then
9915 -- If this is the class-wide type of a completion that is a
9916 -- record subtype, set the type of the class-wide type to be
9917 -- the full base type, for use in the expanded code for the
9918 -- equivalent type. Should this be done earlier when the
9919 -- completion is analyzed ???
9921 if Is_Private_Type (Etype (Unc_Typ))
9923 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
9925 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
9928 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
9931 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
9932 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
9933 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
9935 return New_Occurrence_Of (CW_Subtype, Loc);
9938 -- Indefinite record type with discriminants
9941 D := First_Discriminant (Unc_Typ);
9942 while Present (D) loop
9943 Append_To (List_Constr,
9944 Make_Selected_Component (Loc,
9945 Prefix => Duplicate_Subexpr_No_Checks (E),
9946 Selector_Name => New_Occurrence_Of (D, Loc)));
9948 Next_Discriminant (D);
9953 Make_Subtype_Indication (Loc,
9954 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
9956 Make_Index_Or_Discriminant_Constraint (Loc,
9957 Constraints => List_Constr));
9958 end Make_Subtype_From_Expr;
9964 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
9966 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
9967 -- avoid deep indentation of code.
9969 -- NOTE: Routines which deal with discriminant mapping operate on the
9970 -- [underlying/record] full view of various types because those views
9971 -- contain all discriminants and stored constraints.
9973 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
9974 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
9975 -- overriding chain starting from Prim whose dispatching type is parent
9976 -- type Par_Typ and add a mapping between the result and primitive Prim.
9978 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
9979 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
9980 -- the inheritance or overriding chain of subprogram Subp. Return Empty
9981 -- if no such primitive is available.
9983 function Build_Chain
9984 (Par_Typ : Entity_Id;
9985 Deriv_Typ : Entity_Id) return Elist_Id;
9986 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
9987 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
9988 -- list has the form:
9992 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
9994 -- Note that Par_Typ is not part of the resulting derivation chain
9996 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
9997 -- Return the view of type Typ which could potentially contains either
9998 -- the discriminants or stored constraints of the type.
10000 function Find_Discriminant_Value
10001 (Discr : Entity_Id;
10002 Par_Typ : Entity_Id;
10003 Deriv_Typ : Entity_Id;
10004 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
10005 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
10006 -- in the derivation chain starting from parent type Par_Typ leading to
10007 -- derived type Deriv_Typ. The returned value is one of the following:
10009 -- * An entity which is either a discriminant or a nondiscriminant
10010 -- name, and renames/constraints Discr.
10012 -- * An expression which constraints Discr
10014 -- Typ_Elmt is an element of the derivation chain created by routine
10015 -- Build_Chain and denotes the current ancestor being examined.
10017 procedure Map_Discriminants
10018 (Par_Typ : Entity_Id;
10019 Deriv_Typ : Entity_Id);
10020 -- Map each discriminant of type Par_Typ to a meaningful constraint
10021 -- from the point of view of type Deriv_Typ.
10023 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
10024 -- Map each primitive of type Par_Typ to a corresponding primitive of
10027 -------------------
10028 -- Add_Primitive --
10029 -------------------
10031 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
10032 Par_Prim : Entity_Id;
10035 -- Inspect the inheritance chain through the Alias attribute and the
10036 -- overriding chain through the Overridden_Operation looking for an
10037 -- ancestor primitive with the appropriate dispatching type.
10040 while Present (Par_Prim) loop
10041 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
10042 Par_Prim := Ancestor_Primitive (Par_Prim);
10045 -- Create a mapping of the form:
10047 -- parent type primitive -> derived type primitive
10049 if Present (Par_Prim) then
10050 Type_Map.Set (Par_Prim, Prim);
10054 ------------------------
10055 -- Ancestor_Primitive --
10056 ------------------------
10058 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
10059 Inher_Prim : constant Entity_Id := Alias (Subp);
10060 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
10063 -- The current subprogram overrides an ancestor primitive
10065 if Present (Over_Prim) then
10068 -- The current subprogram is an internally generated alias of an
10069 -- inherited ancestor primitive.
10071 elsif Present (Inher_Prim) then
10074 -- Otherwise the current subprogram is the root of the inheritance or
10075 -- overriding chain.
10080 end Ancestor_Primitive;
10086 function Build_Chain
10087 (Par_Typ : Entity_Id;
10088 Deriv_Typ : Entity_Id) return Elist_Id
10090 Anc_Typ : Entity_Id;
10092 Curr_Typ : Entity_Id;
10095 Chain := New_Elmt_List;
10097 -- Add the derived type to the derivation chain
10099 Prepend_Elmt (Deriv_Typ, Chain);
10101 -- Examine all ancestors starting from the derived type climbing
10102 -- towards parent type Par_Typ.
10104 Curr_Typ := Deriv_Typ;
10106 -- Handle the case where the current type is a record which
10107 -- derives from a subtype.
10109 -- subtype Sub_Typ is Par_Typ ...
10110 -- type Deriv_Typ is Sub_Typ ...
10112 if Ekind (Curr_Typ) = E_Record_Type
10113 and then Present (Parent_Subtype (Curr_Typ))
10115 Anc_Typ := Parent_Subtype (Curr_Typ);
10117 -- Handle the case where the current type is a record subtype of
10118 -- another subtype.
10120 -- subtype Sub_Typ1 is Par_Typ ...
10121 -- subtype Sub_Typ2 is Sub_Typ1 ...
10123 elsif Ekind (Curr_Typ) = E_Record_Subtype
10124 and then Present (Cloned_Subtype (Curr_Typ))
10126 Anc_Typ := Cloned_Subtype (Curr_Typ);
10128 -- Otherwise use the direct parent type
10131 Anc_Typ := Etype (Curr_Typ);
10134 -- Use the first subtype when dealing with itypes
10136 if Is_Itype (Anc_Typ) then
10137 Anc_Typ := First_Subtype (Anc_Typ);
10140 -- Work with the view which contains the discriminants and stored
10143 Anc_Typ := Discriminated_View (Anc_Typ);
10145 -- Stop the climb when either the parent type has been reached or
10146 -- there are no more ancestors left to examine.
10148 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
10150 Prepend_Unique_Elmt (Anc_Typ, Chain);
10151 Curr_Typ := Anc_Typ;
10157 ------------------------
10158 -- Discriminated_View --
10159 ------------------------
10161 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
10167 -- Use the [underlying] full view when dealing with private types
10168 -- because the view contains all inherited discriminants or stored
10171 if Is_Private_Type (T) then
10172 if Present (Underlying_Full_View (T)) then
10173 T := Underlying_Full_View (T);
10175 elsif Present (Full_View (T)) then
10176 T := Full_View (T);
10180 -- Use the underlying record view when the type is an extenstion of
10181 -- a parent type with unknown discriminants because the view contains
10182 -- all inherited discriminants or stored constraints.
10184 if Ekind (T) = E_Record_Type
10185 and then Present (Underlying_Record_View (T))
10187 T := Underlying_Record_View (T);
10191 end Discriminated_View;
10193 -----------------------------
10194 -- Find_Discriminant_Value --
10195 -----------------------------
10197 function Find_Discriminant_Value
10198 (Discr : Entity_Id;
10199 Par_Typ : Entity_Id;
10200 Deriv_Typ : Entity_Id;
10201 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
10203 Discr_Pos : constant Uint := Discriminant_Number (Discr);
10204 Typ : constant Entity_Id := Node (Typ_Elmt);
10206 function Find_Constraint_Value
10207 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
10208 -- Given constraint Constr, find what it denotes. This is either:
10210 -- * An entity which is either a discriminant or a name
10214 ---------------------------
10215 -- Find_Constraint_Value --
10216 ---------------------------
10218 function Find_Constraint_Value
10219 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
10222 if Nkind (Constr) in N_Entity then
10224 -- The constraint denotes a discriminant of the curren type
10225 -- which renames the ancestor discriminant:
10228 -- type Typ (D1 : ...; DN : ...) is
10229 -- new Anc (Discr => D1) with ...
10232 if Ekind (Constr) = E_Discriminant then
10234 -- The discriminant belongs to derived type Deriv_Typ. This
10235 -- is the final value for the ancestor discriminant as the
10236 -- derivations chain has been fully exhausted.
10238 if Typ = Deriv_Typ then
10241 -- Otherwise the discriminant may be renamed or constrained
10242 -- at a lower level. Continue looking down the derivation
10247 Find_Discriminant_Value
10249 Par_Typ => Par_Typ,
10250 Deriv_Typ => Deriv_Typ,
10251 Typ_Elmt => Next_Elmt (Typ_Elmt));
10254 -- Otherwise the constraint denotes a reference to some name
10255 -- which results in a Girder discriminant:
10259 -- type Typ (D1 : ...; DN : ...) is
10260 -- new Anc (Discr => Name) with ...
10263 -- Return the name as this is the proper constraint of the
10270 -- The constraint denotes a reference to a name
10272 elsif Is_Entity_Name (Constr) then
10273 return Find_Constraint_Value (Entity (Constr));
10275 -- Otherwise the current constraint is an expression which yields
10276 -- a Girder discriminant:
10278 -- type Typ (D1 : ...; DN : ...) is
10279 -- new Anc (Discr => <expression>) with ...
10282 -- Return the expression as this is the proper constraint of the
10288 end Find_Constraint_Value;
10292 Constrs : constant Elist_Id := Stored_Constraint (Typ);
10294 Constr_Elmt : Elmt_Id;
10296 Typ_Discr : Entity_Id;
10298 -- Start of processing for Find_Discriminant_Value
10301 -- The algorithm for finding the value of a discriminant works as
10302 -- follows. First, it recreates the derivation chain from Par_Typ
10303 -- to Deriv_Typ as a list:
10305 -- Par_Typ (shown for completeness)
10307 -- Ancestor_N <-- head of chain
10311 -- Deriv_Typ <-- tail of chain
10313 -- The algorithm then traces the fate of a parent discriminant down
10314 -- the derivation chain. At each derivation level, the discriminant
10315 -- may be either inherited or constrained.
10317 -- 1) Discriminant is inherited: there are two cases, depending on
10318 -- which type is inheriting.
10320 -- 1.1) Deriv_Typ is inheriting:
10322 -- type Ancestor (D_1 : ...) is tagged ...
10323 -- type Deriv_Typ is new Ancestor ...
10325 -- In this case the inherited discriminant is the final value of
10326 -- the parent discriminant because the end of the derivation chain
10327 -- has been reached.
10329 -- 1.2) Some other type is inheriting:
10331 -- type Ancestor_1 (D_1 : ...) is tagged ...
10332 -- type Ancestor_2 is new Ancestor_1 ...
10334 -- In this case the algorithm continues to trace the fate of the
10335 -- inherited discriminant down the derivation chain because it may
10336 -- be further inherited or constrained.
10338 -- 2) Discriminant is constrained: there are three cases, depending
10339 -- on what the constraint is.
10341 -- 2.1) The constraint is another discriminant (aka renaming):
10343 -- type Ancestor_1 (D_1 : ...) is tagged ...
10344 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
10346 -- In this case the constraining discriminant becomes the one to
10347 -- track down the derivation chain. The algorithm already knows
10348 -- that D_2 constrains D_1, therefore if the algorithm finds the
10349 -- value of D_2, then this would also be the value for D_1.
10351 -- 2.2) The constraint is a name (aka Girder):
10354 -- type Ancestor_1 (D_1 : ...) is tagged ...
10355 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
10357 -- In this case the name is the final value of D_1 because the
10358 -- discriminant cannot be further constrained.
10360 -- 2.3) The constraint is an expression (aka Girder):
10362 -- type Ancestor_1 (D_1 : ...) is tagged ...
10363 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10365 -- Similar to 2.2, the expression is the final value of D_1
10369 -- When a derived type constrains its parent type, all constaints
10370 -- appear in the Stored_Constraint list. Examine the list looking
10371 -- for a positional match.
10373 if Present (Constrs) then
10374 Constr_Elmt := First_Elmt (Constrs);
10375 while Present (Constr_Elmt) loop
10377 -- The position of the current constraint matches that of the
10378 -- ancestor discriminant.
10380 if Pos = Discr_Pos then
10381 return Find_Constraint_Value (Node (Constr_Elmt));
10384 Next_Elmt (Constr_Elmt);
10388 -- Otherwise the derived type does not constraint its parent type in
10389 -- which case it inherits the parent discriminants.
10392 Typ_Discr := First_Discriminant (Typ);
10393 while Present (Typ_Discr) loop
10395 -- The position of the current discriminant matches that of the
10396 -- ancestor discriminant.
10398 if Pos = Discr_Pos then
10399 return Find_Constraint_Value (Typ_Discr);
10402 Next_Discriminant (Typ_Discr);
10407 -- A discriminant must always have a corresponding value. This is
10408 -- either another discriminant, a name, or an expression. If this
10409 -- point is reached, them most likely the derivation chain employs
10410 -- the wrong views of types.
10412 pragma Assert (False);
10415 end Find_Discriminant_Value;
10417 -----------------------
10418 -- Map_Discriminants --
10419 -----------------------
10421 procedure Map_Discriminants
10422 (Par_Typ : Entity_Id;
10423 Deriv_Typ : Entity_Id)
10425 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10428 Discr_Val : Node_Or_Entity_Id;
10431 -- Examine each discriminant of parent type Par_Typ and find a
10432 -- suitable value for it from the point of view of derived type
10435 if Has_Discriminants (Par_Typ) then
10436 Discr := First_Discriminant (Par_Typ);
10437 while Present (Discr) loop
10439 Find_Discriminant_Value
10441 Par_Typ => Par_Typ,
10442 Deriv_Typ => Deriv_Typ,
10443 Typ_Elmt => First_Elmt (Deriv_Chain));
10445 -- Create a mapping of the form:
10447 -- parent type discriminant -> value
10449 Type_Map.Set (Discr, Discr_Val);
10451 Next_Discriminant (Discr);
10454 end Map_Discriminants;
10456 --------------------
10457 -- Map_Primitives --
10458 --------------------
10460 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
10461 Deriv_Prim : Entity_Id;
10462 Par_Prim : Entity_Id;
10463 Par_Prims : Elist_Id;
10464 Prim_Elmt : Elmt_Id;
10467 -- Inspect the primitives of the derived type and determine whether
10468 -- they relate to the primitives of the parent type. If there is a
10469 -- meaningful relation, create a mapping of the form:
10471 -- parent type primitive -> perived type primitive
10473 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
10474 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
10475 while Present (Prim_Elmt) loop
10476 Deriv_Prim := Node (Prim_Elmt);
10478 if Is_Subprogram (Deriv_Prim)
10479 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
10481 Add_Primitive (Deriv_Prim, Par_Typ);
10484 Next_Elmt (Prim_Elmt);
10488 -- If the parent operation is an interface operation, the overriding
10489 -- indicator is not present. Instead, we get from the interface
10490 -- operation the primitive of the current type that implements it.
10492 if Is_Interface (Par_Typ) then
10493 Par_Prims := Collect_Primitive_Operations (Par_Typ);
10495 if Present (Par_Prims) then
10496 Prim_Elmt := First_Elmt (Par_Prims);
10498 while Present (Prim_Elmt) loop
10499 Par_Prim := Node (Prim_Elmt);
10501 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
10503 if Present (Deriv_Prim) then
10504 Type_Map.Set (Par_Prim, Deriv_Prim);
10507 Next_Elmt (Prim_Elmt);
10511 end Map_Primitives;
10513 -- Start of processing for Map_Types
10516 -- Nothing to do if there are no types to work with
10518 if No (Parent_Type) or else No (Derived_Type) then
10521 -- Nothing to do if the mapping already exists
10523 elsif Type_Map.Get (Parent_Type) = Derived_Type then
10526 -- Nothing to do if both types are not tagged. Note that untagged types
10527 -- do not have primitive operations and their discriminants are already
10528 -- handled by gigi.
10530 elsif not Is_Tagged_Type (Parent_Type)
10531 or else not Is_Tagged_Type (Derived_Type)
10536 -- Create a mapping of the form
10538 -- parent type -> derived type
10540 -- to prevent any subsequent attempts to produce the same relations
10542 Type_Map.Set (Parent_Type, Derived_Type);
10544 -- Create mappings of the form
10546 -- parent type discriminant -> derived type discriminant
10548 -- parent type discriminant -> constraint
10550 -- Note that mapping of discriminants breaks privacy because it needs to
10551 -- work with those views which contains the discriminants and any stored
10555 (Par_Typ => Discriminated_View (Parent_Type),
10556 Deriv_Typ => Discriminated_View (Derived_Type));
10558 -- Create mappings of the form
10560 -- parent type primitive -> derived type primitive
10563 (Par_Typ => Parent_Type,
10564 Deriv_Typ => Derived_Type);
10567 ----------------------------
10568 -- Matching_Standard_Type --
10569 ----------------------------
10571 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
10572 pragma Assert (Is_Scalar_Type (Typ));
10573 Siz : constant Uint := Esize (Typ);
10576 -- Floating-point cases
10578 if Is_Floating_Point_Type (Typ) then
10579 if Siz <= Esize (Standard_Short_Float) then
10580 return Standard_Short_Float;
10581 elsif Siz <= Esize (Standard_Float) then
10582 return Standard_Float;
10583 elsif Siz <= Esize (Standard_Long_Float) then
10584 return Standard_Long_Float;
10585 elsif Siz <= Esize (Standard_Long_Long_Float) then
10586 return Standard_Long_Long_Float;
10588 raise Program_Error;
10591 -- Integer cases (includes fixed-point types)
10593 -- Unsigned integer cases (includes normal enumeration types)
10595 elsif Is_Unsigned_Type (Typ) then
10596 if Siz <= Esize (Standard_Short_Short_Unsigned) then
10597 return Standard_Short_Short_Unsigned;
10598 elsif Siz <= Esize (Standard_Short_Unsigned) then
10599 return Standard_Short_Unsigned;
10600 elsif Siz <= Esize (Standard_Unsigned) then
10601 return Standard_Unsigned;
10602 elsif Siz <= Esize (Standard_Long_Unsigned) then
10603 return Standard_Long_Unsigned;
10604 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
10605 return Standard_Long_Long_Unsigned;
10607 raise Program_Error;
10610 -- Signed integer cases
10613 if Siz <= Esize (Standard_Short_Short_Integer) then
10614 return Standard_Short_Short_Integer;
10615 elsif Siz <= Esize (Standard_Short_Integer) then
10616 return Standard_Short_Integer;
10617 elsif Siz <= Esize (Standard_Integer) then
10618 return Standard_Integer;
10619 elsif Siz <= Esize (Standard_Long_Integer) then
10620 return Standard_Long_Integer;
10621 elsif Siz <= Esize (Standard_Long_Long_Integer) then
10622 return Standard_Long_Long_Integer;
10624 raise Program_Error;
10627 end Matching_Standard_Type;
10629 -----------------------------
10630 -- May_Generate_Large_Temp --
10631 -----------------------------
10633 -- At the current time, the only types that we return False for (i.e. where
10634 -- we decide we know they cannot generate large temps) are ones where we
10635 -- know the size is 256 bits or less at compile time, and we are still not
10636 -- doing a thorough job on arrays and records ???
10638 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
10640 if not Size_Known_At_Compile_Time (Typ) then
10643 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
10646 elsif Is_Array_Type (Typ)
10647 and then Present (Packed_Array_Impl_Type (Typ))
10649 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
10651 -- We could do more here to find other small types ???
10656 end May_Generate_Large_Temp;
10658 --------------------------------------------
10659 -- Needs_Conditional_Null_Excluding_Check --
10660 --------------------------------------------
10662 function Needs_Conditional_Null_Excluding_Check
10663 (Typ : Entity_Id) return Boolean
10667 Is_Array_Type (Typ) and then Can_Never_Be_Null (Component_Type (Typ));
10668 end Needs_Conditional_Null_Excluding_Check;
10670 ----------------------------
10671 -- Needs_Constant_Address --
10672 ----------------------------
10674 function Needs_Constant_Address
10676 Typ : Entity_Id) return Boolean
10679 -- If we have no initialization of any kind, then we don't need to place
10680 -- any restrictions on the address clause, because the object will be
10681 -- elaborated after the address clause is evaluated. This happens if the
10682 -- declaration has no initial expression, or the type has no implicit
10683 -- initialization, or the object is imported.
10685 -- The same holds for all initialized scalar types and all access types.
10686 -- Packed bit arrays of size up to 64 are represented using a modular
10687 -- type with an initialization (to zero) and can be processed like other
10688 -- initialized scalar types.
10690 -- If the type is controlled, code to attach the object to a
10691 -- finalization chain is generated at the point of declaration, and
10692 -- therefore the elaboration of the object cannot be delayed: the
10693 -- address expression must be a constant.
10695 if No (Expression (Decl))
10696 and then not Needs_Finalization (Typ)
10698 (not Has_Non_Null_Base_Init_Proc (Typ)
10699 or else Is_Imported (Defining_Identifier (Decl)))
10703 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
10704 or else Is_Access_Type (Typ)
10706 (Is_Bit_Packed_Array (Typ)
10707 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
10712 -- Otherwise, we require the address clause to be constant because
10713 -- the call to the initialization procedure (or the attach code) has
10714 -- to happen at the point of the declaration.
10716 -- Actually the IP call has been moved to the freeze actions anyway,
10717 -- so maybe we can relax this restriction???
10721 end Needs_Constant_Address;
10723 ----------------------------
10724 -- New_Class_Wide_Subtype --
10725 ----------------------------
10727 function New_Class_Wide_Subtype
10728 (CW_Typ : Entity_Id;
10729 N : Node_Id) return Entity_Id
10731 Res : constant Entity_Id := Create_Itype (E_Void, N);
10733 -- Capture relevant attributes of the class-wide subtype which must be
10734 -- restored after the copy.
10736 Res_Chars : constant Name_Id := Chars (Res);
10737 Res_Is_CGE : constant Boolean := Is_Checked_Ghost_Entity (Res);
10738 Res_Is_IGE : constant Boolean := Is_Ignored_Ghost_Entity (Res);
10739 Res_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Res);
10740 Res_Scope : constant Entity_Id := Scope (Res);
10743 Copy_Node (CW_Typ, Res);
10745 -- Restore the relevant attributes of the class-wide subtype
10747 Set_Chars (Res, Res_Chars);
10748 Set_Is_Checked_Ghost_Entity (Res, Res_Is_CGE);
10749 Set_Is_Ignored_Ghost_Entity (Res, Res_Is_IGE);
10750 Set_Is_Ignored_Ghost_Node (Res, Res_Is_IGN);
10751 Set_Scope (Res, Res_Scope);
10753 -- Decorate the class-wide subtype
10755 Set_Associated_Node_For_Itype (Res, N);
10756 Set_Comes_From_Source (Res, False);
10757 Set_Ekind (Res, E_Class_Wide_Subtype);
10758 Set_Etype (Res, Base_Type (CW_Typ));
10759 Set_Freeze_Node (Res, Empty);
10760 Set_Is_Frozen (Res, False);
10761 Set_Is_Itype (Res);
10762 Set_Is_Public (Res, False);
10763 Set_Next_Entity (Res, Empty);
10764 Set_Prev_Entity (Res, Empty);
10765 Set_Sloc (Res, Sloc (N));
10767 Set_Public_Status (Res);
10770 end New_Class_Wide_Subtype;
10772 --------------------------------
10773 -- Non_Limited_Designated_Type --
10774 ---------------------------------
10776 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
10777 Desig : constant Entity_Id := Designated_Type (T);
10779 if Has_Non_Limited_View (Desig) then
10780 return Non_Limited_View (Desig);
10784 end Non_Limited_Designated_Type;
10786 -----------------------------------
10787 -- OK_To_Do_Constant_Replacement --
10788 -----------------------------------
10790 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
10791 ES : constant Entity_Id := Scope (E);
10795 -- Do not replace statically allocated objects, because they may be
10796 -- modified outside the current scope.
10798 if Is_Statically_Allocated (E) then
10801 -- Do not replace aliased or volatile objects, since we don't know what
10802 -- else might change the value.
10804 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
10807 -- Debug flag -gnatdM disconnects this optimization
10809 elsif Debug_Flag_MM then
10812 -- Otherwise check scopes
10815 CS := Current_Scope;
10818 -- If we are in right scope, replacement is safe
10823 -- Packages do not affect the determination of safety
10825 elsif Ekind (CS) = E_Package then
10826 exit when CS = Standard_Standard;
10829 -- Blocks do not affect the determination of safety
10831 elsif Ekind (CS) = E_Block then
10834 -- Loops do not affect the determination of safety. Note that we
10835 -- kill all current values on entry to a loop, so we are just
10836 -- talking about processing within a loop here.
10838 elsif Ekind (CS) = E_Loop then
10841 -- Otherwise, the reference is dubious, and we cannot be sure that
10842 -- it is safe to do the replacement.
10851 end OK_To_Do_Constant_Replacement;
10853 ------------------------------------
10854 -- Possible_Bit_Aligned_Component --
10855 ------------------------------------
10857 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
10859 -- Do not process an unanalyzed node because it is not yet decorated and
10860 -- most checks performed below will fail.
10862 if not Analyzed (N) then
10866 -- There are never alignment issues in CodePeer mode
10868 if CodePeer_Mode then
10874 -- Case of indexed component
10876 when N_Indexed_Component =>
10878 P : constant Node_Id := Prefix (N);
10879 Ptyp : constant Entity_Id := Etype (P);
10882 -- If we know the component size and it is not larger than 64,
10883 -- then we are definitely OK. The back end does the assignment
10884 -- of misaligned small objects correctly.
10886 if Known_Static_Component_Size (Ptyp)
10887 and then Component_Size (Ptyp) <= 64
10891 -- Otherwise, we need to test the prefix, to see if we are
10892 -- indexing from a possibly unaligned component.
10895 return Possible_Bit_Aligned_Component (P);
10899 -- Case of selected component
10901 when N_Selected_Component =>
10903 P : constant Node_Id := Prefix (N);
10904 Comp : constant Entity_Id := Entity (Selector_Name (N));
10907 -- This is the crucial test: if the component itself causes
10908 -- trouble, then we can stop and return True.
10910 if Component_May_Be_Bit_Aligned (Comp) then
10913 -- Otherwise, we need to test the prefix, to see if we are
10914 -- selecting from a possibly unaligned component.
10917 return Possible_Bit_Aligned_Component (P);
10921 -- For a slice, test the prefix, if that is possibly misaligned,
10922 -- then for sure the slice is.
10925 return Possible_Bit_Aligned_Component (Prefix (N));
10927 -- For an unchecked conversion, check whether the expression may
10930 when N_Unchecked_Type_Conversion =>
10931 return Possible_Bit_Aligned_Component (Expression (N));
10933 -- If we have none of the above, it means that we have fallen off the
10934 -- top testing prefixes recursively, and we now have a stand alone
10935 -- object, where we don't have a problem, unless this is a renaming,
10936 -- in which case we need to look into the renamed object.
10939 if Is_Entity_Name (N)
10940 and then Present (Renamed_Object (Entity (N)))
10943 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
10948 end Possible_Bit_Aligned_Component;
10950 -----------------------------------------------
10951 -- Process_Statements_For_Controlled_Objects --
10952 -----------------------------------------------
10954 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
10955 Loc : constant Source_Ptr := Sloc (N);
10957 function Are_Wrapped (L : List_Id) return Boolean;
10958 -- Determine whether list L contains only one statement which is a block
10960 function Wrap_Statements_In_Block
10962 Scop : Entity_Id := Current_Scope) return Node_Id;
10963 -- Given a list of statements L, wrap it in a block statement and return
10964 -- the generated node. Scop is either the current scope or the scope of
10965 -- the context (if applicable).
10971 function Are_Wrapped (L : List_Id) return Boolean is
10972 Stmt : constant Node_Id := First (L);
10976 and then No (Next (Stmt))
10977 and then Nkind (Stmt) = N_Block_Statement;
10980 ------------------------------
10981 -- Wrap_Statements_In_Block --
10982 ------------------------------
10984 function Wrap_Statements_In_Block
10986 Scop : Entity_Id := Current_Scope) return Node_Id
10988 Block_Id : Entity_Id;
10989 Block_Nod : Node_Id;
10990 Iter_Loop : Entity_Id;
10994 Make_Block_Statement (Loc,
10995 Declarations => No_List,
10996 Handled_Statement_Sequence =>
10997 Make_Handled_Sequence_Of_Statements (Loc,
11000 -- Create a label for the block in case the block needs to manage the
11001 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
11003 Add_Block_Identifier (Block_Nod, Block_Id);
11005 -- When wrapping the statements of an iterator loop, check whether
11006 -- the loop requires secondary stack management and if so, propagate
11007 -- the appropriate flags to the block. This ensures that the cursor
11008 -- is properly cleaned up at each iteration of the loop.
11010 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
11012 if Present (Iter_Loop) then
11013 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
11015 -- Secondary stack reclamation is suppressed when the associated
11016 -- iterator loop contains a return statement which uses the stack.
11018 Set_Sec_Stack_Needed_For_Return
11019 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
11023 end Wrap_Statements_In_Block;
11029 -- Start of processing for Process_Statements_For_Controlled_Objects
11032 -- Whenever a non-handled statement list is wrapped in a block, the
11033 -- block must be explicitly analyzed to redecorate all entities in the
11034 -- list and ensure that a finalizer is properly built.
11037 when N_Conditional_Entry_Call
11040 | N_Selective_Accept
11042 -- Check the "then statements" for elsif parts and if statements
11044 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
11045 and then not Is_Empty_List (Then_Statements (N))
11046 and then not Are_Wrapped (Then_Statements (N))
11047 and then Requires_Cleanup_Actions
11048 (L => Then_Statements (N),
11049 Lib_Level => False,
11050 Nested_Constructs => False)
11052 Block := Wrap_Statements_In_Block (Then_Statements (N));
11053 Set_Then_Statements (N, New_List (Block));
11058 -- Check the "else statements" for conditional entry calls, if
11059 -- statements and selective accepts.
11061 if Nkind_In (N, N_Conditional_Entry_Call,
11063 N_Selective_Accept)
11064 and then not Is_Empty_List (Else_Statements (N))
11065 and then not Are_Wrapped (Else_Statements (N))
11066 and then Requires_Cleanup_Actions
11067 (L => Else_Statements (N),
11068 Lib_Level => False,
11069 Nested_Constructs => False)
11071 Block := Wrap_Statements_In_Block (Else_Statements (N));
11072 Set_Else_Statements (N, New_List (Block));
11077 when N_Abortable_Part
11078 | N_Accept_Alternative
11079 | N_Case_Statement_Alternative
11080 | N_Delay_Alternative
11081 | N_Entry_Call_Alternative
11082 | N_Exception_Handler
11084 | N_Triggering_Alternative
11086 if not Is_Empty_List (Statements (N))
11087 and then not Are_Wrapped (Statements (N))
11088 and then Requires_Cleanup_Actions
11089 (L => Statements (N),
11090 Lib_Level => False,
11091 Nested_Constructs => False)
11093 if Nkind (N) = N_Loop_Statement
11094 and then Present (Identifier (N))
11097 Wrap_Statements_In_Block
11098 (L => Statements (N),
11099 Scop => Entity (Identifier (N)));
11101 Block := Wrap_Statements_In_Block (Statements (N));
11104 Set_Statements (N, New_List (Block));
11108 -- Could be e.g. a loop that was transformed into a block or null
11109 -- statement. Do nothing for terminate alternatives.
11111 when N_Block_Statement
11113 | N_Terminate_Alternative
11118 raise Program_Error;
11120 end Process_Statements_For_Controlled_Objects;
11126 function Power_Of_Two (N : Node_Id) return Nat is
11127 Typ : constant Entity_Id := Etype (N);
11128 pragma Assert (Is_Integer_Type (Typ));
11130 Siz : constant Nat := UI_To_Int (Esize (Typ));
11134 if not Compile_Time_Known_Value (N) then
11138 Val := Expr_Value (N);
11139 for J in 1 .. Siz - 1 loop
11140 if Val = Uint_2 ** J then
11149 ----------------------
11150 -- Remove_Init_Call --
11151 ----------------------
11153 function Remove_Init_Call
11155 Rep_Clause : Node_Id) return Node_Id
11157 Par : constant Node_Id := Parent (Var);
11158 Typ : constant Entity_Id := Etype (Var);
11160 Init_Proc : Entity_Id;
11161 -- Initialization procedure for Typ
11163 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
11164 -- Look for init call for Var starting at From and scanning the
11165 -- enclosing list until Rep_Clause or the end of the list is reached.
11167 ----------------------------
11168 -- Find_Init_Call_In_List --
11169 ----------------------------
11171 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
11172 Init_Call : Node_Id;
11176 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
11177 if Nkind (Init_Call) = N_Procedure_Call_Statement
11178 and then Is_Entity_Name (Name (Init_Call))
11179 and then Entity (Name (Init_Call)) = Init_Proc
11188 end Find_Init_Call_In_List;
11190 Init_Call : Node_Id;
11192 -- Start of processing for Find_Init_Call
11195 if Present (Initialization_Statements (Var)) then
11196 Init_Call := Initialization_Statements (Var);
11197 Set_Initialization_Statements (Var, Empty);
11199 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
11201 -- No init proc for the type, so obviously no call to be found
11206 -- We might be able to handle other cases below by just properly
11207 -- setting Initialization_Statements at the point where the init proc
11208 -- call is generated???
11210 Init_Proc := Base_Init_Proc (Typ);
11212 -- First scan the list containing the declaration of Var
11214 Init_Call := Find_Init_Call_In_List (From => Next (Par));
11216 -- If not found, also look on Var's freeze actions list, if any,
11217 -- since the init call may have been moved there (case of an address
11218 -- clause applying to Var).
11220 if No (Init_Call) and then Present (Freeze_Node (Var)) then
11222 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
11225 -- If the initialization call has actuals that use the secondary
11226 -- stack, the call may have been wrapped into a temporary block, in
11227 -- which case the block itself has to be removed.
11229 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
11231 Blk : constant Node_Id := Next (Par);
11234 (Find_Init_Call_In_List
11235 (First (Statements (Handled_Statement_Sequence (Blk)))))
11243 if Present (Init_Call) then
11244 Remove (Init_Call);
11247 end Remove_Init_Call;
11249 -------------------------
11250 -- Remove_Side_Effects --
11251 -------------------------
11253 procedure Remove_Side_Effects
11255 Name_Req : Boolean := False;
11256 Renaming_Req : Boolean := False;
11257 Variable_Ref : Boolean := False;
11258 Related_Id : Entity_Id := Empty;
11259 Is_Low_Bound : Boolean := False;
11260 Is_High_Bound : Boolean := False;
11261 Check_Side_Effects : Boolean := True)
11263 function Build_Temporary
11266 Related_Nod : Node_Id := Empty) return Entity_Id;
11267 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
11268 -- is present (xxx is taken from the Chars field of Related_Nod),
11269 -- otherwise it generates an internal temporary. The created temporary
11270 -- entity is marked as internal.
11272 ---------------------
11273 -- Build_Temporary --
11274 ---------------------
11276 function Build_Temporary
11279 Related_Nod : Node_Id := Empty) return Entity_Id
11281 Temp_Id : Entity_Id;
11282 Temp_Nam : Name_Id;
11285 -- The context requires an external symbol
11287 if Present (Related_Id) then
11288 if Is_Low_Bound then
11289 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
11290 else pragma Assert (Is_High_Bound);
11291 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
11294 Temp_Id := Make_Defining_Identifier (Loc, Temp_Nam);
11296 -- Otherwise generate an internal temporary
11299 Temp_Id := Make_Temporary (Loc, Id, Related_Nod);
11302 Set_Is_Internal (Temp_Id);
11305 end Build_Temporary;
11309 Loc : constant Source_Ptr := Sloc (Exp);
11310 Exp_Type : constant Entity_Id := Etype (Exp);
11311 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
11312 Def_Id : Entity_Id;
11315 Ptr_Typ_Decl : Node_Id;
11316 Ref_Type : Entity_Id;
11319 -- Start of processing for Remove_Side_Effects
11322 -- Handle cases in which there is nothing to do. In GNATprove mode,
11323 -- removal of side effects is useful for the light expansion of
11324 -- renamings. This removal should only occur when not inside a
11325 -- generic and not doing a preanalysis.
11327 if not Expander_Active
11328 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
11332 -- Cannot generate temporaries if the invocation to remove side effects
11333 -- was issued too early and the type of the expression is not resolved
11334 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
11335 -- Remove_Side_Effects).
11337 elsif No (Exp_Type)
11338 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11342 -- Nothing to do if prior expansion determined that a function call does
11343 -- not require side effect removal.
11345 elsif Nkind (Exp) = N_Function_Call
11346 and then No_Side_Effect_Removal (Exp)
11350 -- No action needed for side-effect free expressions
11352 elsif Check_Side_Effects
11353 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11357 -- Generating C code we cannot remove side effect of function returning
11358 -- class-wide types since there is no secondary stack (required to use
11361 elsif Modify_Tree_For_C
11362 and then Nkind (Exp) = N_Function_Call
11363 and then Is_Class_Wide_Type (Etype (Exp))
11368 -- The remaining processing is done with all checks suppressed
11370 -- Note: from now on, don't use return statements, instead do a goto
11371 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11373 Scope_Suppress.Suppress := (others => True);
11375 -- If this is an elementary or a small not-by-reference record type, and
11376 -- we need to capture the value, just make a constant; this is cheap and
11377 -- objects of both kinds of types can be bit aligned, so it might not be
11378 -- possible to generate a reference to them. Likewise if this is not a
11379 -- name reference, except for a type conversion, because we would enter
11380 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11381 -- type has predicates (and type conversions need a specific treatment
11382 -- anyway, see below). Also do it if we have a volatile reference and
11383 -- Name_Req is not set (see comments for Side_Effect_Free).
11385 if (Is_Elementary_Type (Exp_Type)
11386 or else (Is_Record_Type (Exp_Type)
11387 and then Known_Static_RM_Size (Exp_Type)
11388 and then RM_Size (Exp_Type) <= 64
11389 and then not Has_Discriminants (Exp_Type)
11390 and then not Is_By_Reference_Type (Exp_Type)))
11391 and then (Variable_Ref
11392 or else (not Is_Name_Reference (Exp)
11393 and then Nkind (Exp) /= N_Type_Conversion)
11394 or else (not Name_Req
11395 and then Is_Volatile_Reference (Exp)))
11397 Def_Id := Build_Temporary (Loc, 'R', Exp);
11398 Set_Etype (Def_Id, Exp_Type);
11399 Res := New_Occurrence_Of (Def_Id, Loc);
11401 -- If the expression is a packed reference, it must be reanalyzed and
11402 -- expanded, depending on context. This is the case for actuals where
11403 -- a constraint check may capture the actual before expansion of the
11404 -- call is complete.
11406 if Nkind (Exp) = N_Indexed_Component
11407 and then Is_Packed (Etype (Prefix (Exp)))
11409 Set_Analyzed (Exp, False);
11410 Set_Analyzed (Prefix (Exp), False);
11414 -- Rnn : Exp_Type renames Expr;
11416 -- In GNATprove mode, we prefer to use renamings for intermediate
11417 -- variables to definition of constants, due to the implicit move
11418 -- operation that such a constant definition causes as part of the
11419 -- support in GNATprove for ownership pointers. Hence, we generate
11420 -- a renaming for a reference to an object of a nonscalar type.
11423 or else (GNATprove_Mode
11424 and then Is_Object_Reference (Exp)
11425 and then not Is_Scalar_Type (Exp_Type))
11428 Make_Object_Renaming_Declaration (Loc,
11429 Defining_Identifier => Def_Id,
11430 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11431 Name => Relocate_Node (Exp));
11434 -- Rnn : constant Exp_Type := Expr;
11438 Make_Object_Declaration (Loc,
11439 Defining_Identifier => Def_Id,
11440 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11441 Constant_Present => True,
11442 Expression => Relocate_Node (Exp));
11444 Set_Assignment_OK (E);
11447 Insert_Action (Exp, E);
11449 -- If the expression has the form v.all then we can just capture the
11450 -- pointer, and then do an explicit dereference on the result, but
11451 -- this is not right if this is a volatile reference.
11453 elsif Nkind (Exp) = N_Explicit_Dereference
11454 and then not Is_Volatile_Reference (Exp)
11456 Def_Id := Build_Temporary (Loc, 'R', Exp);
11458 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
11460 Insert_Action (Exp,
11461 Make_Object_Declaration (Loc,
11462 Defining_Identifier => Def_Id,
11463 Object_Definition =>
11464 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
11465 Constant_Present => True,
11466 Expression => Relocate_Node (Prefix (Exp))));
11468 -- Similar processing for an unchecked conversion of an expression of
11469 -- the form v.all, where we want the same kind of treatment.
11471 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11472 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
11474 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11477 -- If this is a type conversion, leave the type conversion and remove
11478 -- the side effects in the expression. This is important in several
11479 -- circumstances: for change of representations, and also when this is a
11480 -- view conversion to a smaller object, where gigi can end up creating
11481 -- its own temporary of the wrong size.
11483 elsif Nkind (Exp) = N_Type_Conversion then
11484 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11486 -- Generating C code the type conversion of an access to constrained
11487 -- array type into an access to unconstrained array type involves
11488 -- initializing a fat pointer and the expression must be free of
11489 -- side effects to safely compute its bounds.
11491 if Modify_Tree_For_C
11492 and then Is_Access_Type (Etype (Exp))
11493 and then Is_Array_Type (Designated_Type (Etype (Exp)))
11494 and then not Is_Constrained (Designated_Type (Etype (Exp)))
11496 Def_Id := Build_Temporary (Loc, 'R', Exp);
11497 Set_Etype (Def_Id, Exp_Type);
11498 Res := New_Occurrence_Of (Def_Id, Loc);
11500 Insert_Action (Exp,
11501 Make_Object_Declaration (Loc,
11502 Defining_Identifier => Def_Id,
11503 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11504 Constant_Present => True,
11505 Expression => Relocate_Node (Exp)));
11510 -- If this is an unchecked conversion that Gigi can't handle, make
11511 -- a copy or a use a renaming to capture the value.
11513 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11514 and then not Safe_Unchecked_Type_Conversion (Exp)
11516 if CW_Or_Has_Controlled_Part (Exp_Type) then
11518 -- Use a renaming to capture the expression, rather than create
11519 -- a controlled temporary.
11521 Def_Id := Build_Temporary (Loc, 'R', Exp);
11522 Res := New_Occurrence_Of (Def_Id, Loc);
11524 Insert_Action (Exp,
11525 Make_Object_Renaming_Declaration (Loc,
11526 Defining_Identifier => Def_Id,
11527 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11528 Name => Relocate_Node (Exp)));
11531 Def_Id := Build_Temporary (Loc, 'R', Exp);
11532 Set_Etype (Def_Id, Exp_Type);
11533 Res := New_Occurrence_Of (Def_Id, Loc);
11536 Make_Object_Declaration (Loc,
11537 Defining_Identifier => Def_Id,
11538 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11539 Constant_Present => not Is_Variable (Exp),
11540 Expression => Relocate_Node (Exp));
11542 Set_Assignment_OK (E);
11543 Insert_Action (Exp, E);
11546 -- For expressions that denote names, we can use a renaming scheme.
11547 -- This is needed for correctness in the case of a volatile object of
11548 -- a nonvolatile type because the Make_Reference call of the "default"
11549 -- approach would generate an illegal access value (an access value
11550 -- cannot designate such an object - see Analyze_Reference).
11552 elsif Is_Name_Reference (Exp)
11554 -- We skip using this scheme if we have an object of a volatile
11555 -- type and we do not have Name_Req set true (see comments for
11556 -- Side_Effect_Free).
11558 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
11560 Def_Id := Build_Temporary (Loc, 'R', Exp);
11561 Res := New_Occurrence_Of (Def_Id, Loc);
11563 Insert_Action (Exp,
11564 Make_Object_Renaming_Declaration (Loc,
11565 Defining_Identifier => Def_Id,
11566 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11567 Name => Relocate_Node (Exp)));
11569 -- If this is a packed reference, or a selected component with
11570 -- a nonstandard representation, a reference to the temporary
11571 -- will be replaced by a copy of the original expression (see
11572 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
11573 -- elaborated by gigi, and is of course not to be replaced in-line
11574 -- by the expression it renames, which would defeat the purpose of
11575 -- removing the side effect.
11577 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
11578 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
11582 Set_Is_Renaming_Of_Object (Def_Id, False);
11585 -- Avoid generating a variable-sized temporary, by generating the
11586 -- reference just for the function call. The transformation could be
11587 -- refined to apply only when the array component is constrained by a
11590 elsif Nkind (Exp) = N_Selected_Component
11591 and then Nkind (Prefix (Exp)) = N_Function_Call
11592 and then Is_Array_Type (Exp_Type)
11594 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11597 -- Otherwise we generate a reference to the expression
11600 -- An expression which is in SPARK mode is considered side effect
11601 -- free if the resulting value is captured by a variable or a
11605 and then Nkind (Parent (Exp)) = N_Object_Declaration
11609 -- When generating C code we cannot consider side effect free object
11610 -- declarations that have discriminants and are initialized by means
11611 -- of a function call since on this target there is no secondary
11612 -- stack to store the return value and the expander may generate an
11613 -- extra call to the function to compute the discriminant value. In
11614 -- addition, for targets that have secondary stack, the expansion of
11615 -- functions with side effects involves the generation of an access
11616 -- type to capture the return value stored in the secondary stack;
11617 -- by contrast when generating C code such expansion generates an
11618 -- internal object declaration (no access type involved) which must
11619 -- be identified here to avoid entering into a never-ending loop
11620 -- generating internal object declarations.
11622 elsif Modify_Tree_For_C
11623 and then Nkind (Parent (Exp)) = N_Object_Declaration
11625 (Nkind (Exp) /= N_Function_Call
11626 or else not Has_Discriminants (Exp_Type)
11627 or else Is_Internal_Name
11628 (Chars (Defining_Identifier (Parent (Exp)))))
11633 -- Special processing for function calls that return a limited type.
11634 -- We need to build a declaration that will enable build-in-place
11635 -- expansion of the call. This is not done if the context is already
11636 -- an object declaration, to prevent infinite recursion.
11638 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
11639 -- to accommodate functions returning limited objects by reference.
11641 if Ada_Version >= Ada_2005
11642 and then Nkind (Exp) = N_Function_Call
11643 and then Is_Limited_View (Etype (Exp))
11644 and then Nkind (Parent (Exp)) /= N_Object_Declaration
11647 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
11652 Make_Object_Declaration (Loc,
11653 Defining_Identifier => Obj,
11654 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11655 Expression => Relocate_Node (Exp));
11657 Insert_Action (Exp, Decl);
11658 Set_Etype (Obj, Exp_Type);
11659 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
11664 Def_Id := Build_Temporary (Loc, 'R', Exp);
11666 -- The regular expansion of functions with side effects involves the
11667 -- generation of an access type to capture the return value found on
11668 -- the secondary stack. Since SPARK (and why) cannot process access
11669 -- types, use a different approach which ignores the secondary stack
11670 -- and "copies" the returned object.
11671 -- When generating C code, no need for a 'reference since the
11672 -- secondary stack is not supported.
11674 if GNATprove_Mode or Modify_Tree_For_C then
11675 Res := New_Occurrence_Of (Def_Id, Loc);
11676 Ref_Type := Exp_Type;
11678 -- Regular expansion utilizing an access type and 'reference
11682 Make_Explicit_Dereference (Loc,
11683 Prefix => New_Occurrence_Of (Def_Id, Loc));
11686 -- type Ann is access all <Exp_Type>;
11688 Ref_Type := Make_Temporary (Loc, 'A');
11691 Make_Full_Type_Declaration (Loc,
11692 Defining_Identifier => Ref_Type,
11694 Make_Access_To_Object_Definition (Loc,
11695 All_Present => True,
11696 Subtype_Indication =>
11697 New_Occurrence_Of (Exp_Type, Loc)));
11699 Insert_Action (Exp, Ptr_Typ_Decl);
11703 if Nkind (E) = N_Explicit_Dereference then
11704 New_Exp := Relocate_Node (Prefix (E));
11707 E := Relocate_Node (E);
11709 -- Do not generate a 'reference in SPARK mode or C generation
11710 -- since the access type is not created in the first place.
11712 if GNATprove_Mode or Modify_Tree_For_C then
11715 -- Otherwise generate reference, marking the value as non-null
11716 -- since we know it cannot be null and we don't want a check.
11719 New_Exp := Make_Reference (Loc, E);
11720 Set_Is_Known_Non_Null (Def_Id);
11724 if Is_Delayed_Aggregate (E) then
11726 -- The expansion of nested aggregates is delayed until the
11727 -- enclosing aggregate is expanded. As aggregates are often
11728 -- qualified, the predicate applies to qualified expressions as
11729 -- well, indicating that the enclosing aggregate has not been
11730 -- expanded yet. At this point the aggregate is part of a
11731 -- stand-alone declaration, and must be fully expanded.
11733 if Nkind (E) = N_Qualified_Expression then
11734 Set_Expansion_Delayed (Expression (E), False);
11735 Set_Analyzed (Expression (E), False);
11737 Set_Expansion_Delayed (E, False);
11740 Set_Analyzed (E, False);
11743 -- Generating C code of object declarations that have discriminants
11744 -- and are initialized by means of a function call we propagate the
11745 -- discriminants of the parent type to the internally built object.
11746 -- This is needed to avoid generating an extra call to the called
11749 -- For example, if we generate here the following declaration, it
11750 -- will be expanded later adding an extra call to evaluate the value
11751 -- of the discriminant (needed to compute the size of the object).
11753 -- type Rec (D : Integer) is ...
11754 -- Obj : constant Rec := SomeFunc;
11756 if Modify_Tree_For_C
11757 and then Nkind (Parent (Exp)) = N_Object_Declaration
11758 and then Has_Discriminants (Exp_Type)
11759 and then Nkind (Exp) = N_Function_Call
11761 Insert_Action (Exp,
11762 Make_Object_Declaration (Loc,
11763 Defining_Identifier => Def_Id,
11764 Object_Definition => New_Copy_Tree
11765 (Object_Definition (Parent (Exp))),
11766 Constant_Present => True,
11767 Expression => New_Exp));
11769 Insert_Action (Exp,
11770 Make_Object_Declaration (Loc,
11771 Defining_Identifier => Def_Id,
11772 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
11773 Constant_Present => True,
11774 Expression => New_Exp));
11778 -- Preserve the Assignment_OK flag in all copies, since at least one
11779 -- copy may be used in a context where this flag must be set (otherwise
11780 -- why would the flag be set in the first place).
11782 Set_Assignment_OK (Res, Assignment_OK (Exp));
11784 -- Preserve the Do_Range_Check flag in all copies
11786 Set_Do_Range_Check (Res, Do_Range_Check (Exp));
11788 -- Finally rewrite the original expression and we are done
11790 Rewrite (Exp, Res);
11791 Analyze_And_Resolve (Exp, Exp_Type);
11794 Scope_Suppress := Svg_Suppress;
11795 end Remove_Side_Effects;
11797 ------------------------
11798 -- Replace_References --
11799 ------------------------
11801 procedure Replace_References
11803 Par_Typ : Entity_Id;
11804 Deriv_Typ : Entity_Id;
11805 Par_Obj : Entity_Id := Empty;
11806 Deriv_Obj : Entity_Id := Empty)
11808 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
11809 -- Determine whether node Ref denotes some component of Deriv_Obj
11811 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
11812 -- Substitute a reference to an entity with the corresponding value
11813 -- stored in table Type_Map.
11815 function Type_Of_Formal
11817 Actual : Node_Id) return Entity_Id;
11818 -- Find the type of the formal parameter which corresponds to actual
11819 -- parameter Actual in subprogram call Call.
11821 ----------------------
11822 -- Is_Deriv_Obj_Ref --
11823 ----------------------
11825 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
11826 Par : constant Node_Id := Parent (Ref);
11829 -- Detect the folowing selected component form:
11831 -- Deriv_Obj.(something)
11834 Nkind (Par) = N_Selected_Component
11835 and then Is_Entity_Name (Prefix (Par))
11836 and then Entity (Prefix (Par)) = Deriv_Obj;
11837 end Is_Deriv_Obj_Ref;
11843 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
11844 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
11845 -- Reset the Controlling_Argument of all function calls that
11846 -- encapsulate node From_Arg.
11848 ----------------------------------
11849 -- Remove_Controlling_Arguments --
11850 ----------------------------------
11852 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
11857 while Present (Par) loop
11858 if Nkind (Par) = N_Function_Call
11859 and then Present (Controlling_Argument (Par))
11861 Set_Controlling_Argument (Par, Empty);
11863 -- Prevent the search from going too far
11865 elsif Is_Body_Or_Package_Declaration (Par) then
11869 Par := Parent (Par);
11871 end Remove_Controlling_Arguments;
11875 Context : constant Node_Id := Parent (Ref);
11876 Loc : constant Source_Ptr := Sloc (Ref);
11877 Ref_Id : Entity_Id;
11878 Result : Traverse_Result;
11881 -- The new reference which is intended to substitute the old one
11884 -- The reference designated for replacement. In certain cases this
11885 -- may be a node other than Ref.
11887 Val : Node_Or_Entity_Id;
11888 -- The corresponding value of Ref from the type map
11890 -- Start of processing for Replace_Ref
11893 -- Assume that the input reference is to be replaced and that the
11894 -- traversal should examine the children of the reference.
11899 -- The input denotes a meaningful reference
11901 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
11902 Ref_Id := Entity (Ref);
11903 Val := Type_Map.Get (Ref_Id);
11905 -- The reference has a corresponding value in the type map, a
11906 -- substitution is possible.
11908 if Present (Val) then
11910 -- The reference denotes a discriminant
11912 if Ekind (Ref_Id) = E_Discriminant then
11913 if Nkind (Val) in N_Entity then
11915 -- The value denotes another discriminant. Replace as
11918 -- _object.Discr -> _object.Val
11920 if Ekind (Val) = E_Discriminant then
11921 New_Ref := New_Occurrence_Of (Val, Loc);
11923 -- Otherwise the value denotes the entity of a name which
11924 -- constraints the discriminant. Replace as follows:
11926 -- _object.Discr -> Val
11929 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11931 New_Ref := New_Occurrence_Of (Val, Loc);
11932 Old_Ref := Parent (Old_Ref);
11935 -- Otherwise the value denotes an arbitrary expression which
11936 -- constraints the discriminant. Replace as follows:
11938 -- _object.Discr -> Val
11941 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11943 New_Ref := New_Copy_Tree (Val);
11944 Old_Ref := Parent (Old_Ref);
11947 -- Otherwise the reference denotes a primitive. Replace as
11950 -- Primitive -> Val
11953 pragma Assert (Nkind (Val) in N_Entity);
11954 New_Ref := New_Occurrence_Of (Val, Loc);
11957 -- The reference mentions the _object parameter of the parent
11958 -- type's DIC or type invariant procedure. Replace as follows:
11960 -- _object -> _object
11962 elsif Present (Par_Obj)
11963 and then Present (Deriv_Obj)
11964 and then Ref_Id = Par_Obj
11966 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
11968 -- The type of the _object parameter is class-wide when the
11969 -- expression comes from an assertion pragma that applies to
11970 -- an abstract parent type or an interface. The class-wide type
11971 -- facilitates the preanalysis of the expression by treating
11972 -- calls to abstract primitives that mention the current
11973 -- instance of the type as dispatching. Once the calls are
11974 -- remapped to invoke overriding or inherited primitives, the
11975 -- calls no longer need to be dispatching. Examine all function
11976 -- calls that encapsulate the _object parameter and reset their
11977 -- Controlling_Argument attribute.
11979 if Is_Class_Wide_Type (Etype (Par_Obj))
11980 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
11982 Remove_Controlling_Arguments (Old_Ref);
11985 -- The reference to _object acts as an actual parameter in a
11986 -- subprogram call which may be invoking a primitive of the
11989 -- Primitive (... _object ...);
11991 -- The parent type primitive may not be overridden nor
11992 -- inherited when it is declared after the derived type
11995 -- type Parent is tagged private;
11996 -- type Child is new Parent with private;
11997 -- procedure Primitive (Obj : Parent);
11999 -- In this scenario the _object parameter is converted to the
12000 -- parent type. Due to complications with partial/full views
12001 -- and view swaps, the parent type is taken from the formal
12002 -- parameter of the subprogram being called.
12004 if Nkind_In (Context, N_Function_Call,
12005 N_Procedure_Call_Statement)
12006 and then No (Type_Map.Get (Entity (Name (Context))))
12009 Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
12011 -- Do not process the generated type conversion because
12012 -- both the parent type and the derived type are in the
12013 -- Type_Map table. This will clobber the type conversion
12014 -- by resetting its subtype mark.
12019 -- Otherwise there is nothing to replace
12025 if Present (New_Ref) then
12026 Rewrite (Old_Ref, New_Ref);
12028 -- Update the return type when the context of the reference
12029 -- acts as the name of a function call. Note that the update
12030 -- should not be performed when the reference appears as an
12031 -- actual in the call.
12033 if Nkind (Context) = N_Function_Call
12034 and then Name (Context) = Old_Ref
12036 Set_Etype (Context, Etype (Val));
12041 -- Reanalyze the reference due to potential replacements
12043 if Nkind (Old_Ref) in N_Has_Etype then
12044 Set_Analyzed (Old_Ref, False);
12050 procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
12052 --------------------
12053 -- Type_Of_Formal --
12054 --------------------
12056 function Type_Of_Formal
12058 Actual : Node_Id) return Entity_Id
12064 -- Examine the list of actual and formal parameters in parallel
12066 A := First (Parameter_Associations (Call));
12067 F := First_Formal (Entity (Name (Call)));
12068 while Present (A) and then Present (F) loop
12077 -- The actual parameter must always have a corresponding formal
12079 pragma Assert (False);
12082 end Type_Of_Formal;
12084 -- Start of processing for Replace_References
12087 -- Map the attributes of the parent type to the proper corresponding
12088 -- attributes of the derived type.
12091 (Parent_Type => Par_Typ,
12092 Derived_Type => Deriv_Typ);
12094 -- Inspect the input expression and perform substitutions where
12097 Replace_Refs (Expr);
12098 end Replace_References;
12100 -----------------------------
12101 -- Replace_Type_References --
12102 -----------------------------
12104 procedure Replace_Type_References
12107 Obj_Id : Entity_Id)
12109 procedure Replace_Type_Ref (N : Node_Id);
12110 -- Substitute a single reference of the current instance of type Typ
12111 -- with a reference to Obj_Id.
12113 ----------------------
12114 -- Replace_Type_Ref --
12115 ----------------------
12117 procedure Replace_Type_Ref (N : Node_Id) is
12119 -- Decorate the reference to Typ even though it may be rewritten
12120 -- further down. This is done for two reasons:
12122 -- * ASIS has all necessary semantic information in the original
12125 -- * Routines which examine properties of the Original_Node have
12126 -- some semantic information.
12128 if Nkind (N) = N_Identifier then
12129 Set_Entity (N, Typ);
12130 Set_Etype (N, Typ);
12132 elsif Nkind (N) = N_Selected_Component then
12133 Analyze (Prefix (N));
12134 Set_Entity (Selector_Name (N), Typ);
12135 Set_Etype (Selector_Name (N), Typ);
12138 -- Perform the following substitution:
12142 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
12143 Set_Comes_From_Source (N, True);
12144 end Replace_Type_Ref;
12146 procedure Replace_Type_Refs is
12147 new Replace_Type_References_Generic (Replace_Type_Ref);
12149 -- Start of processing for Replace_Type_References
12152 Replace_Type_Refs (Expr, Typ);
12153 end Replace_Type_References;
12155 ---------------------------
12156 -- Represented_As_Scalar --
12157 ---------------------------
12159 function Represented_As_Scalar (T : Entity_Id) return Boolean is
12160 UT : constant Entity_Id := Underlying_Type (T);
12162 return Is_Scalar_Type (UT)
12163 or else (Is_Bit_Packed_Array (UT)
12164 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
12165 end Represented_As_Scalar;
12167 ------------------------------
12168 -- Requires_Cleanup_Actions --
12169 ------------------------------
12171 function Requires_Cleanup_Actions
12173 Lib_Level : Boolean) return Boolean
12175 At_Lib_Level : constant Boolean :=
12177 and then Nkind_In (N, N_Package_Body,
12178 N_Package_Specification);
12179 -- N is at the library level if the top-most context is a package and
12180 -- the path taken to reach N does not include nonpackage constructs.
12184 when N_Accept_Statement
12185 | N_Block_Statement
12189 | N_Subprogram_Body
12193 Requires_Cleanup_Actions
12194 (L => Declarations (N),
12195 Lib_Level => At_Lib_Level,
12196 Nested_Constructs => True)
12198 (Present (Handled_Statement_Sequence (N))
12200 Requires_Cleanup_Actions
12202 Statements (Handled_Statement_Sequence (N)),
12203 Lib_Level => At_Lib_Level,
12204 Nested_Constructs => True));
12206 -- Extended return statements are the same as the above, except that
12207 -- there is no Declarations field. We do not want to clean up the
12208 -- Return_Object_Declarations.
12210 when N_Extended_Return_Statement =>
12212 Present (Handled_Statement_Sequence (N))
12213 and then Requires_Cleanup_Actions
12215 Statements (Handled_Statement_Sequence (N)),
12216 Lib_Level => At_Lib_Level,
12217 Nested_Constructs => True);
12219 when N_Package_Specification =>
12221 Requires_Cleanup_Actions
12222 (L => Visible_Declarations (N),
12223 Lib_Level => At_Lib_Level,
12224 Nested_Constructs => True)
12226 Requires_Cleanup_Actions
12227 (L => Private_Declarations (N),
12228 Lib_Level => At_Lib_Level,
12229 Nested_Constructs => True);
12232 raise Program_Error;
12234 end Requires_Cleanup_Actions;
12236 ------------------------------
12237 -- Requires_Cleanup_Actions --
12238 ------------------------------
12240 function Requires_Cleanup_Actions
12242 Lib_Level : Boolean;
12243 Nested_Constructs : Boolean) return Boolean
12247 Obj_Id : Entity_Id;
12248 Obj_Typ : Entity_Id;
12249 Pack_Id : Entity_Id;
12253 if No (L) or else Is_Empty_List (L) then
12258 while Present (Decl) loop
12260 -- Library-level tagged types
12262 if Nkind (Decl) = N_Full_Type_Declaration then
12263 Typ := Defining_Identifier (Decl);
12265 -- Ignored Ghost types do not need any cleanup actions because
12266 -- they will not appear in the final tree.
12268 if Is_Ignored_Ghost_Entity (Typ) then
12271 elsif Is_Tagged_Type (Typ)
12272 and then Is_Library_Level_Entity (Typ)
12273 and then Convention (Typ) = Convention_Ada
12274 and then Present (Access_Disp_Table (Typ))
12275 and then RTE_Available (RE_Unregister_Tag)
12276 and then not Is_Abstract_Type (Typ)
12277 and then not No_Run_Time_Mode
12282 -- Regular object declarations
12284 elsif Nkind (Decl) = N_Object_Declaration then
12285 Obj_Id := Defining_Identifier (Decl);
12286 Obj_Typ := Base_Type (Etype (Obj_Id));
12287 Expr := Expression (Decl);
12289 -- Bypass any form of processing for objects which have their
12290 -- finalization disabled. This applies only to objects at the
12293 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12296 -- Finalization of transient objects are treated separately in
12297 -- order to handle sensitive cases. These include:
12299 -- * Aggregate expansion
12300 -- * If, case, and expression with actions expansion
12301 -- * Transient scopes
12303 -- If one of those contexts has marked the transient object as
12304 -- ignored, do not generate finalization actions for it.
12306 elsif Is_Finalized_Transient (Obj_Id)
12307 or else Is_Ignored_Transient (Obj_Id)
12311 -- Ignored Ghost objects do not need any cleanup actions because
12312 -- they will not appear in the final tree.
12314 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12317 -- The object is of the form:
12318 -- Obj : [constant] Typ [:= Expr];
12320 -- Do not process tag-to-class-wide conversions because they do
12321 -- not yield an object. Do not process the incomplete view of a
12322 -- deferred constant. Note that an object initialized by means
12323 -- of a build-in-place function call may appear as a deferred
12324 -- constant after expansion activities. These kinds of objects
12325 -- must be finalized.
12327 elsif not Is_Imported (Obj_Id)
12328 and then Needs_Finalization (Obj_Typ)
12329 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
12330 and then not (Ekind (Obj_Id) = E_Constant
12331 and then not Has_Completion (Obj_Id)
12332 and then No (BIP_Initialization_Call (Obj_Id)))
12336 -- The object is of the form:
12337 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
12339 -- Obj : Access_Typ :=
12340 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
12342 elsif Is_Access_Type (Obj_Typ)
12343 and then Needs_Finalization
12344 (Available_View (Designated_Type (Obj_Typ)))
12345 and then Present (Expr)
12347 (Is_Secondary_Stack_BIP_Func_Call (Expr)
12349 (Is_Non_BIP_Func_Call (Expr)
12350 and then not Is_Related_To_Func_Return (Obj_Id)))
12354 -- Processing for "hook" objects generated for transient objects
12355 -- declared inside an Expression_With_Actions.
12357 elsif Is_Access_Type (Obj_Typ)
12358 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12359 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12360 N_Object_Declaration
12364 -- Processing for intermediate results of if expressions where
12365 -- one of the alternatives uses a controlled function call.
12367 elsif Is_Access_Type (Obj_Typ)
12368 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12369 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12370 N_Defining_Identifier
12371 and then Present (Expr)
12372 and then Nkind (Expr) = N_Null
12376 -- Simple protected objects which use type System.Tasking.
12377 -- Protected_Objects.Protection to manage their locks should be
12378 -- treated as controlled since they require manual cleanup.
12380 elsif Ekind (Obj_Id) = E_Variable
12381 and then (Is_Simple_Protected_Type (Obj_Typ)
12382 or else Has_Simple_Protected_Object (Obj_Typ))
12387 -- Specific cases of object renamings
12389 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
12390 Obj_Id := Defining_Identifier (Decl);
12391 Obj_Typ := Base_Type (Etype (Obj_Id));
12393 -- Bypass any form of processing for objects which have their
12394 -- finalization disabled. This applies only to objects at the
12397 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12400 -- Ignored Ghost object renamings do not need any cleanup actions
12401 -- because they will not appear in the final tree.
12403 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12406 -- Return object of a build-in-place function. This case is
12407 -- recognized and marked by the expansion of an extended return
12408 -- statement (see Expand_N_Extended_Return_Statement).
12410 elsif Needs_Finalization (Obj_Typ)
12411 and then Is_Return_Object (Obj_Id)
12412 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12416 -- Detect a case where a source object has been initialized by
12417 -- a controlled function call or another object which was later
12418 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
12420 -- Obj1 : CW_Type := Src_Obj;
12421 -- Obj2 : CW_Type := Function_Call (...);
12423 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
12424 -- Tmp : ... := Function_Call (...)'reference;
12425 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
12427 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
12431 -- Inspect the freeze node of an access-to-controlled type and look
12432 -- for a delayed finalization master. This case arises when the
12433 -- freeze actions are inserted at a later time than the expansion of
12434 -- the context. Since Build_Finalizer is never called on a single
12435 -- construct twice, the master will be ultimately left out and never
12436 -- finalized. This is also needed for freeze actions of designated
12437 -- types themselves, since in some cases the finalization master is
12438 -- associated with a designated type's freeze node rather than that
12439 -- of the access type (see handling for freeze actions in
12440 -- Build_Finalization_Master).
12442 elsif Nkind (Decl) = N_Freeze_Entity
12443 and then Present (Actions (Decl))
12445 Typ := Entity (Decl);
12447 -- Freeze nodes for ignored Ghost types do not need cleanup
12448 -- actions because they will never appear in the final tree.
12450 if Is_Ignored_Ghost_Entity (Typ) then
12453 elsif ((Is_Access_Type (Typ)
12454 and then not Is_Access_Subprogram_Type (Typ)
12455 and then Needs_Finalization
12456 (Available_View (Designated_Type (Typ))))
12457 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
12458 and then Requires_Cleanup_Actions
12459 (Actions (Decl), Lib_Level, Nested_Constructs)
12464 -- Nested package declarations
12466 elsif Nested_Constructs
12467 and then Nkind (Decl) = N_Package_Declaration
12469 Pack_Id := Defining_Entity (Decl);
12471 -- Do not inspect an ignored Ghost package because all code found
12472 -- within will not appear in the final tree.
12474 if Is_Ignored_Ghost_Entity (Pack_Id) then
12477 elsif Ekind (Pack_Id) /= E_Generic_Package
12478 and then Requires_Cleanup_Actions
12479 (Specification (Decl), Lib_Level)
12484 -- Nested package bodies
12486 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
12488 -- Do not inspect an ignored Ghost package body because all code
12489 -- found within will not appear in the final tree.
12491 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
12494 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
12495 and then Requires_Cleanup_Actions (Decl, Lib_Level)
12500 elsif Nkind (Decl) = N_Block_Statement
12503 -- Handle a rare case caused by a controlled transient object
12504 -- created as part of a record init proc. The variable is wrapped
12505 -- in a block, but the block is not associated with a transient
12510 -- Handle the case where the original context has been wrapped in
12511 -- a block to avoid interference between exception handlers and
12512 -- At_End handlers. Treat the block as transparent and process its
12515 or else Is_Finalization_Wrapper (Decl))
12517 if Requires_Cleanup_Actions (Decl, Lib_Level) then
12526 end Requires_Cleanup_Actions;
12528 ------------------------------------
12529 -- Safe_Unchecked_Type_Conversion --
12530 ------------------------------------
12532 -- Note: this function knows quite a bit about the exact requirements of
12533 -- Gigi with respect to unchecked type conversions, and its code must be
12534 -- coordinated with any changes in Gigi in this area.
12536 -- The above requirements should be documented in Sinfo ???
12538 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
12543 Pexp : constant Node_Id := Parent (Exp);
12546 -- If the expression is the RHS of an assignment or object declaration
12547 -- we are always OK because there will always be a target.
12549 -- Object renaming declarations, (generated for view conversions of
12550 -- actuals in inlined calls), like object declarations, provide an
12551 -- explicit type, and are safe as well.
12553 if (Nkind (Pexp) = N_Assignment_Statement
12554 and then Expression (Pexp) = Exp)
12555 or else Nkind_In (Pexp, N_Object_Declaration,
12556 N_Object_Renaming_Declaration)
12560 -- If the expression is the prefix of an N_Selected_Component we should
12561 -- also be OK because GCC knows to look inside the conversion except if
12562 -- the type is discriminated. We assume that we are OK anyway if the
12563 -- type is not set yet or if it is controlled since we can't afford to
12564 -- introduce a temporary in this case.
12566 elsif Nkind (Pexp) = N_Selected_Component
12567 and then Prefix (Pexp) = Exp
12569 if No (Etype (Pexp)) then
12573 not Has_Discriminants (Etype (Pexp))
12574 or else Is_Constrained (Etype (Pexp));
12578 -- Set the output type, this comes from Etype if it is set, otherwise we
12579 -- take it from the subtype mark, which we assume was already fully
12582 if Present (Etype (Exp)) then
12583 Otyp := Etype (Exp);
12585 Otyp := Entity (Subtype_Mark (Exp));
12588 -- The input type always comes from the expression, and we assume this
12589 -- is indeed always analyzed, so we can simply get the Etype.
12591 Ityp := Etype (Expression (Exp));
12593 -- Initialize alignments to unknown so far
12598 -- Replace a concurrent type by its corresponding record type and each
12599 -- type by its underlying type and do the tests on those. The original
12600 -- type may be a private type whose completion is a concurrent type, so
12601 -- find the underlying type first.
12603 if Present (Underlying_Type (Otyp)) then
12604 Otyp := Underlying_Type (Otyp);
12607 if Present (Underlying_Type (Ityp)) then
12608 Ityp := Underlying_Type (Ityp);
12611 if Is_Concurrent_Type (Otyp) then
12612 Otyp := Corresponding_Record_Type (Otyp);
12615 if Is_Concurrent_Type (Ityp) then
12616 Ityp := Corresponding_Record_Type (Ityp);
12619 -- If the base types are the same, we know there is no problem since
12620 -- this conversion will be a noop.
12622 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
12625 -- Same if this is an upwards conversion of an untagged type, and there
12626 -- are no constraints involved (could be more general???)
12628 elsif Etype (Ityp) = Otyp
12629 and then not Is_Tagged_Type (Ityp)
12630 and then not Has_Discriminants (Ityp)
12631 and then No (First_Rep_Item (Base_Type (Ityp)))
12635 -- If the expression has an access type (object or subprogram) we assume
12636 -- that the conversion is safe, because the size of the target is safe,
12637 -- even if it is a record (which might be treated as having unknown size
12640 elsif Is_Access_Type (Ityp) then
12643 -- If the size of output type is known at compile time, there is never
12644 -- a problem. Note that unconstrained records are considered to be of
12645 -- known size, but we can't consider them that way here, because we are
12646 -- talking about the actual size of the object.
12648 -- We also make sure that in addition to the size being known, we do not
12649 -- have a case which might generate an embarrassingly large temp in
12650 -- stack checking mode.
12652 elsif Size_Known_At_Compile_Time (Otyp)
12654 (not Stack_Checking_Enabled
12655 or else not May_Generate_Large_Temp (Otyp))
12656 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
12660 -- If either type is tagged, then we know the alignment is OK so Gigi
12661 -- will be able to use pointer punning.
12663 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
12666 -- If either type is a limited record type, we cannot do a copy, so say
12667 -- safe since there's nothing else we can do.
12669 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
12672 -- Conversions to and from packed array types are always ignored and
12675 elsif Is_Packed_Array_Impl_Type (Otyp)
12676 or else Is_Packed_Array_Impl_Type (Ityp)
12681 -- The only other cases known to be safe is if the input type's
12682 -- alignment is known to be at least the maximum alignment for the
12683 -- target or if both alignments are known and the output type's
12684 -- alignment is no stricter than the input's. We can use the component
12685 -- type alignment for an array if a type is an unpacked array type.
12687 if Present (Alignment_Clause (Otyp)) then
12688 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
12690 elsif Is_Array_Type (Otyp)
12691 and then Present (Alignment_Clause (Component_Type (Otyp)))
12693 Oalign := Expr_Value (Expression (Alignment_Clause
12694 (Component_Type (Otyp))));
12697 if Present (Alignment_Clause (Ityp)) then
12698 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
12700 elsif Is_Array_Type (Ityp)
12701 and then Present (Alignment_Clause (Component_Type (Ityp)))
12703 Ialign := Expr_Value (Expression (Alignment_Clause
12704 (Component_Type (Ityp))));
12707 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
12710 elsif Ialign /= No_Uint
12711 and then Oalign /= No_Uint
12712 and then Ialign <= Oalign
12716 -- Otherwise, Gigi cannot handle this and we must make a temporary
12721 end Safe_Unchecked_Type_Conversion;
12723 ---------------------------------
12724 -- Set_Current_Value_Condition --
12725 ---------------------------------
12727 -- Note: the implementation of this procedure is very closely tied to the
12728 -- implementation of Get_Current_Value_Condition. Here we set required
12729 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
12730 -- them, so they must have a consistent view.
12732 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
12734 procedure Set_Entity_Current_Value (N : Node_Id);
12735 -- If N is an entity reference, where the entity is of an appropriate
12736 -- kind, then set the current value of this entity to Cnode, unless
12737 -- there is already a definite value set there.
12739 procedure Set_Expression_Current_Value (N : Node_Id);
12740 -- If N is of an appropriate form, sets an appropriate entry in current
12741 -- value fields of relevant entities. Multiple entities can be affected
12742 -- in the case of an AND or AND THEN.
12744 ------------------------------
12745 -- Set_Entity_Current_Value --
12746 ------------------------------
12748 procedure Set_Entity_Current_Value (N : Node_Id) is
12750 if Is_Entity_Name (N) then
12752 Ent : constant Entity_Id := Entity (N);
12755 -- Don't capture if not safe to do so
12757 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
12761 -- Here we have a case where the Current_Value field may need
12762 -- to be set. We set it if it is not already set to a compile
12763 -- time expression value.
12765 -- Note that this represents a decision that one condition
12766 -- blots out another previous one. That's certainly right if
12767 -- they occur at the same level. If the second one is nested,
12768 -- then the decision is neither right nor wrong (it would be
12769 -- equally OK to leave the outer one in place, or take the new
12770 -- inner one. Really we should record both, but our data
12771 -- structures are not that elaborate.
12773 if Nkind (Current_Value (Ent)) not in N_Subexpr then
12774 Set_Current_Value (Ent, Cnode);
12778 end Set_Entity_Current_Value;
12780 ----------------------------------
12781 -- Set_Expression_Current_Value --
12782 ----------------------------------
12784 procedure Set_Expression_Current_Value (N : Node_Id) is
12790 -- Loop to deal with (ignore for now) any NOT operators present. The
12791 -- presence of NOT operators will be handled properly when we call
12792 -- Get_Current_Value_Condition.
12794 while Nkind (Cond) = N_Op_Not loop
12795 Cond := Right_Opnd (Cond);
12798 -- For an AND or AND THEN, recursively process operands
12800 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
12801 Set_Expression_Current_Value (Left_Opnd (Cond));
12802 Set_Expression_Current_Value (Right_Opnd (Cond));
12806 -- Check possible relational operator
12808 if Nkind (Cond) in N_Op_Compare then
12809 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
12810 Set_Entity_Current_Value (Left_Opnd (Cond));
12811 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
12812 Set_Entity_Current_Value (Right_Opnd (Cond));
12815 elsif Nkind_In (Cond,
12817 N_Qualified_Expression,
12818 N_Expression_With_Actions)
12820 Set_Expression_Current_Value (Expression (Cond));
12822 -- Check possible boolean variable reference
12825 Set_Entity_Current_Value (Cond);
12827 end Set_Expression_Current_Value;
12829 -- Start of processing for Set_Current_Value_Condition
12832 Set_Expression_Current_Value (Condition (Cnode));
12833 end Set_Current_Value_Condition;
12835 --------------------------
12836 -- Set_Elaboration_Flag --
12837 --------------------------
12839 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
12840 Loc : constant Source_Ptr := Sloc (N);
12841 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
12845 if Present (Ent) then
12847 -- Nothing to do if at the compilation unit level, because in this
12848 -- case the flag is set by the binder generated elaboration routine.
12850 if Nkind (Parent (N)) = N_Compilation_Unit then
12853 -- Here we do need to generate an assignment statement
12856 Check_Restriction (No_Elaboration_Code, N);
12859 Make_Assignment_Statement (Loc,
12860 Name => New_Occurrence_Of (Ent, Loc),
12861 Expression => Make_Integer_Literal (Loc, Uint_1));
12863 -- Mark the assignment statement as elaboration code. This allows
12864 -- the early call region mechanism (see Sem_Elab) to properly
12865 -- ignore such assignments even though they are nonpreelaborable
12868 Set_Is_Elaboration_Code (Asn);
12870 if Nkind (Parent (N)) = N_Subunit then
12871 Insert_After (Corresponding_Stub (Parent (N)), Asn);
12873 Insert_After (N, Asn);
12878 -- Kill current value indication. This is necessary because the
12879 -- tests of this flag are inserted out of sequence and must not
12880 -- pick up bogus indications of the wrong constant value.
12882 Set_Current_Value (Ent, Empty);
12884 -- If the subprogram is in the current declarative part and
12885 -- 'access has been applied to it, generate an elaboration
12886 -- check at the beginning of the declarations of the body.
12888 if Nkind (N) = N_Subprogram_Body
12889 and then Address_Taken (Spec_Id)
12891 Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function)
12894 Loc : constant Source_Ptr := Sloc (N);
12895 Decls : constant List_Id := Declarations (N);
12899 -- No need to generate this check if first entry in the
12900 -- declaration list is a raise of Program_Error now.
12903 and then Nkind (First (Decls)) = N_Raise_Program_Error
12908 -- Otherwise generate the check
12911 Make_Raise_Program_Error (Loc,
12914 Left_Opnd => New_Occurrence_Of (Ent, Loc),
12915 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
12916 Reason => PE_Access_Before_Elaboration);
12919 Set_Declarations (N, New_List (Chk));
12921 Prepend (Chk, Decls);
12929 end Set_Elaboration_Flag;
12931 ----------------------------
12932 -- Set_Renamed_Subprogram --
12933 ----------------------------
12935 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
12937 -- If input node is an identifier, we can just reset it
12939 if Nkind (N) = N_Identifier then
12940 Set_Chars (N, Chars (E));
12943 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
12947 CS : constant Boolean := Comes_From_Source (N);
12949 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
12951 Set_Comes_From_Source (N, CS);
12952 Set_Analyzed (N, True);
12955 end Set_Renamed_Subprogram;
12957 ----------------------
12958 -- Side_Effect_Free --
12959 ----------------------
12961 function Side_Effect_Free
12963 Name_Req : Boolean := False;
12964 Variable_Ref : Boolean := False) return Boolean
12966 Typ : constant Entity_Id := Etype (N);
12967 -- Result type of the expression
12969 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
12970 -- The argument N is a construct where the Prefix is dereferenced if it
12971 -- is an access type and the result is a variable. The call returns True
12972 -- if the construct is side effect free (not considering side effects in
12973 -- other than the prefix which are to be tested by the caller).
12975 function Within_In_Parameter (N : Node_Id) return Boolean;
12976 -- Determines if N is a subcomponent of a composite in-parameter. If so,
12977 -- N is not side-effect free when the actual is global and modifiable
12978 -- indirectly from within a subprogram, because it may be passed by
12979 -- reference. The front-end must be conservative here and assume that
12980 -- this may happen with any array or record type. On the other hand, we
12981 -- cannot create temporaries for all expressions for which this
12982 -- condition is true, for various reasons that might require clearing up
12983 -- ??? For example, discriminant references that appear out of place, or
12984 -- spurious type errors with class-wide expressions. As a result, we
12985 -- limit the transformation to loop bounds, which is so far the only
12986 -- case that requires it.
12988 -----------------------------
12989 -- Safe_Prefixed_Reference --
12990 -----------------------------
12992 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
12994 -- If prefix is not side effect free, definitely not safe
12996 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
12999 -- If the prefix is of an access type that is not access-to-constant,
13000 -- then this construct is a variable reference, which means it is to
13001 -- be considered to have side effects if Variable_Ref is set True.
13003 elsif Is_Access_Type (Etype (Prefix (N)))
13004 and then not Is_Access_Constant (Etype (Prefix (N)))
13005 and then Variable_Ref
13007 -- Exception is a prefix that is the result of a previous removal
13008 -- of side effects.
13010 return Is_Entity_Name (Prefix (N))
13011 and then not Comes_From_Source (Prefix (N))
13012 and then Ekind (Entity (Prefix (N))) = E_Constant
13013 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
13015 -- If the prefix is an explicit dereference then this construct is a
13016 -- variable reference, which means it is to be considered to have
13017 -- side effects if Variable_Ref is True.
13019 -- We do NOT exclude dereferences of access-to-constant types because
13020 -- we handle them as constant view of variables.
13022 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
13023 and then Variable_Ref
13027 -- Note: The following test is the simplest way of solving a complex
13028 -- problem uncovered by the following test (Side effect on loop bound
13029 -- that is a subcomponent of a global variable:
13031 -- with Text_Io; use Text_Io;
13032 -- procedure Tloop is
13035 -- V : Natural := 4;
13036 -- S : String (1..5) := (others => 'a');
13043 -- with procedure Action;
13044 -- procedure Loop_G (Arg : X; Msg : String)
13046 -- procedure Loop_G (Arg : X; Msg : String) is
13048 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
13049 -- & Natural'Image (Arg.V));
13050 -- for Index in 1 .. Arg.V loop
13051 -- Text_Io.Put_Line
13052 -- (Natural'Image (Index) & " " & Arg.S (Index));
13053 -- if Index > 2 then
13057 -- Put_Line ("end loop_g " & Msg);
13060 -- procedure Loop1 is new Loop_G (Modi);
13061 -- procedure Modi is
13064 -- Loop1 (X1, "from modi");
13068 -- Loop1 (X1, "initial");
13071 -- The output of the above program should be:
13073 -- begin loop_g initial will loop till: 4
13077 -- begin loop_g from modi will loop till: 1
13079 -- end loop_g from modi
13081 -- begin loop_g from modi will loop till: 1
13083 -- end loop_g from modi
13084 -- end loop_g initial
13086 -- If a loop bound is a subcomponent of a global variable, a
13087 -- modification of that variable within the loop may incorrectly
13088 -- affect the execution of the loop.
13090 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
13091 and then Within_In_Parameter (Prefix (N))
13092 and then Variable_Ref
13096 -- All other cases are side effect free
13101 end Safe_Prefixed_Reference;
13103 -------------------------
13104 -- Within_In_Parameter --
13105 -------------------------
13107 function Within_In_Parameter (N : Node_Id) return Boolean is
13109 if not Comes_From_Source (N) then
13112 elsif Is_Entity_Name (N) then
13113 return Ekind (Entity (N)) = E_In_Parameter;
13115 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
13116 return Within_In_Parameter (Prefix (N));
13121 end Within_In_Parameter;
13123 -- Start of processing for Side_Effect_Free
13126 -- If volatile reference, always consider it to have side effects
13128 if Is_Volatile_Reference (N) then
13132 -- Note on checks that could raise Constraint_Error. Strictly, if we
13133 -- take advantage of 11.6, these checks do not count as side effects.
13134 -- However, we would prefer to consider that they are side effects,
13135 -- since the back end CSE does not work very well on expressions which
13136 -- can raise Constraint_Error. On the other hand if we don't consider
13137 -- them to be side effect free, then we get some awkward expansions
13138 -- in -gnato mode, resulting in code insertions at a point where we
13139 -- do not have a clear model for performing the insertions.
13141 -- Special handling for entity names
13143 if Is_Entity_Name (N) then
13145 -- A type reference is always side effect free
13147 if Is_Type (Entity (N)) then
13150 -- Variables are considered to be a side effect if Variable_Ref
13151 -- is set or if we have a volatile reference and Name_Req is off.
13152 -- If Name_Req is True then we can't help returning a name which
13153 -- effectively allows multiple references in any case.
13155 elsif Is_Variable (N, Use_Original_Node => False) then
13156 return not Variable_Ref
13157 and then (not Is_Volatile_Reference (N) or else Name_Req);
13159 -- Any other entity (e.g. a subtype name) is definitely side
13166 -- A value known at compile time is always side effect free
13168 elsif Compile_Time_Known_Value (N) then
13171 -- A variable renaming is not side-effect free, because the renaming
13172 -- will function like a macro in the front-end in some cases, and an
13173 -- assignment can modify the component designated by N, so we need to
13174 -- create a temporary for it.
13176 -- The guard testing for Entity being present is needed at least in
13177 -- the case of rewritten predicate expressions, and may well also be
13178 -- appropriate elsewhere. Obviously we can't go testing the entity
13179 -- field if it does not exist, so it's reasonable to say that this is
13180 -- not the renaming case if it does not exist.
13182 elsif Is_Entity_Name (Original_Node (N))
13183 and then Present (Entity (Original_Node (N)))
13184 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
13185 and then Ekind (Entity (Original_Node (N))) /= E_Constant
13188 RO : constant Node_Id :=
13189 Renamed_Object (Entity (Original_Node (N)));
13192 -- If the renamed object is an indexed component, or an
13193 -- explicit dereference, then the designated object could
13194 -- be modified by an assignment.
13196 if Nkind_In (RO, N_Indexed_Component,
13197 N_Explicit_Dereference)
13201 -- A selected component must have a safe prefix
13203 elsif Nkind (RO) = N_Selected_Component then
13204 return Safe_Prefixed_Reference (RO);
13206 -- In all other cases, designated object cannot be changed so
13207 -- we are side effect free.
13214 -- Remove_Side_Effects generates an object renaming declaration to
13215 -- capture the expression of a class-wide expression. In VM targets
13216 -- the frontend performs no expansion for dispatching calls to
13217 -- class- wide types since they are handled by the VM. Hence, we must
13218 -- locate here if this node corresponds to a previous invocation of
13219 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
13221 elsif not Tagged_Type_Expansion
13222 and then not Comes_From_Source (N)
13223 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
13224 and then Is_Class_Wide_Type (Typ)
13228 -- Generating C the type conversion of an access to constrained array
13229 -- type into an access to unconstrained array type involves initializing
13230 -- a fat pointer and the expression cannot be assumed to be free of side
13231 -- effects since it must referenced several times to compute its bounds.
13233 elsif Modify_Tree_For_C
13234 and then Nkind (N) = N_Type_Conversion
13235 and then Is_Access_Type (Typ)
13236 and then Is_Array_Type (Designated_Type (Typ))
13237 and then not Is_Constrained (Designated_Type (Typ))
13242 -- For other than entity names and compile time known values,
13243 -- check the node kind for special processing.
13247 -- An attribute reference is side effect free if its expressions
13248 -- are side effect free and its prefix is side effect free or
13249 -- is an entity reference.
13251 -- Is this right? what about x'first where x is a variable???
13253 when N_Attribute_Reference =>
13254 Attribute_Reference : declare
13256 function Side_Effect_Free_Attribute
13257 (Attribute_Name : Name_Id) return Boolean;
13258 -- Returns True if evaluation of the given attribute is
13259 -- considered side-effect free (independent of prefix and
13262 --------------------------------
13263 -- Side_Effect_Free_Attribute --
13264 --------------------------------
13266 function Side_Effect_Free_Attribute
13267 (Attribute_Name : Name_Id) return Boolean
13270 case Attribute_Name is
13277 | Name_Wide_Wide_Image
13279 -- CodePeer doesn't want to see replicated copies of
13282 return not CodePeer_Mode;
13287 end Side_Effect_Free_Attribute;
13289 -- Start of processing for Attribute_Reference
13293 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13294 and then Side_Effect_Free_Attribute (Attribute_Name (N))
13295 and then (Is_Entity_Name (Prefix (N))
13296 or else Side_Effect_Free
13297 (Prefix (N), Name_Req, Variable_Ref));
13298 end Attribute_Reference;
13300 -- A binary operator is side effect free if and both operands are
13301 -- side effect free. For this purpose binary operators include
13302 -- membership tests and short circuit forms.
13305 | N_Membership_Test
13308 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
13310 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13312 -- An explicit dereference is side effect free only if it is
13313 -- a side effect free prefixed reference.
13315 when N_Explicit_Dereference =>
13316 return Safe_Prefixed_Reference (N);
13318 -- An expression with action is side effect free if its expression
13319 -- is side effect free and it has no actions.
13321 when N_Expression_With_Actions =>
13323 Is_Empty_List (Actions (N))
13324 and then Side_Effect_Free
13325 (Expression (N), Name_Req, Variable_Ref);
13327 -- A call to _rep_to_pos is side effect free, since we generate
13328 -- this pure function call ourselves. Moreover it is critically
13329 -- important to make this exception, since otherwise we can have
13330 -- discriminants in array components which don't look side effect
13331 -- free in the case of an array whose index type is an enumeration
13332 -- type with an enumeration rep clause.
13334 -- All other function calls are not side effect free
13336 when N_Function_Call =>
13338 Nkind (Name (N)) = N_Identifier
13339 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
13340 and then Side_Effect_Free
13341 (First (Parameter_Associations (N)),
13342 Name_Req, Variable_Ref);
13344 -- An IF expression is side effect free if it's of a scalar type, and
13345 -- all its components are all side effect free (conditions and then
13346 -- actions and else actions). We restrict to scalar types, since it
13347 -- is annoying to deal with things like (if A then B else C)'First
13348 -- where the type involved is a string type.
13350 when N_If_Expression =>
13352 Is_Scalar_Type (Typ)
13353 and then Side_Effect_Free
13354 (Expressions (N), Name_Req, Variable_Ref);
13356 -- An indexed component is side effect free if it is a side
13357 -- effect free prefixed reference and all the indexing
13358 -- expressions are side effect free.
13360 when N_Indexed_Component =>
13362 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
13363 and then Safe_Prefixed_Reference (N);
13365 -- A type qualification, type conversion, or unchecked expression is
13366 -- side effect free if the expression is side effect free.
13368 when N_Qualified_Expression
13369 | N_Type_Conversion
13370 | N_Unchecked_Expression
13372 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
13374 -- A selected component is side effect free only if it is a side
13375 -- effect free prefixed reference.
13377 when N_Selected_Component =>
13378 return Safe_Prefixed_Reference (N);
13380 -- A range is side effect free if the bounds are side effect free
13383 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
13385 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
13387 -- A slice is side effect free if it is a side effect free
13388 -- prefixed reference and the bounds are side effect free.
13392 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
13393 and then Safe_Prefixed_Reference (N);
13395 -- A unary operator is side effect free if the operand
13396 -- is side effect free.
13399 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
13401 -- An unchecked type conversion is side effect free only if it
13402 -- is safe and its argument is side effect free.
13404 when N_Unchecked_Type_Conversion =>
13406 Safe_Unchecked_Type_Conversion (N)
13407 and then Side_Effect_Free
13408 (Expression (N), Name_Req, Variable_Ref);
13410 -- A literal is side effect free
13412 when N_Character_Literal
13413 | N_Integer_Literal
13419 -- We consider that anything else has side effects. This is a bit
13420 -- crude, but we are pretty close for most common cases, and we
13421 -- are certainly correct (i.e. we never return True when the
13422 -- answer should be False).
13427 end Side_Effect_Free;
13429 -- A list is side effect free if all elements of the list are side
13432 function Side_Effect_Free
13434 Name_Req : Boolean := False;
13435 Variable_Ref : Boolean := False) return Boolean
13440 if L = No_List or else L = Error_List then
13445 while Present (N) loop
13446 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
13455 end Side_Effect_Free;
13457 ----------------------------------
13458 -- Silly_Boolean_Array_Not_Test --
13459 ----------------------------------
13461 -- This procedure implements an odd and silly test. We explicitly check
13462 -- for the case where the 'First of the component type is equal to the
13463 -- 'Last of this component type, and if this is the case, we make sure
13464 -- that constraint error is raised. The reason is that the NOT is bound
13465 -- to cause CE in this case, and we will not otherwise catch it.
13467 -- No such check is required for AND and OR, since for both these cases
13468 -- False op False = False, and True op True = True. For the XOR case,
13469 -- see Silly_Boolean_Array_Xor_Test.
13471 -- Believe it or not, this was reported as a bug. Note that nearly always,
13472 -- the test will evaluate statically to False, so the code will be
13473 -- statically removed, and no extra overhead caused.
13475 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
13476 Loc : constant Source_Ptr := Sloc (N);
13477 CT : constant Entity_Id := Component_Type (T);
13480 -- The check we install is
13482 -- constraint_error when
13483 -- component_type'first = component_type'last
13484 -- and then array_type'Length /= 0)
13486 -- We need the last guard because we don't want to raise CE for empty
13487 -- arrays since no out of range values result. (Empty arrays with a
13488 -- component type of True .. True -- very useful -- even the ACATS
13489 -- does not test that marginal case).
13492 Make_Raise_Constraint_Error (Loc,
13494 Make_And_Then (Loc,
13498 Make_Attribute_Reference (Loc,
13499 Prefix => New_Occurrence_Of (CT, Loc),
13500 Attribute_Name => Name_First),
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, Right_Opnd (N))),
13508 Reason => CE_Range_Check_Failed));
13509 end Silly_Boolean_Array_Not_Test;
13511 ----------------------------------
13512 -- Silly_Boolean_Array_Xor_Test --
13513 ----------------------------------
13515 -- This procedure implements an odd and silly test. We explicitly check
13516 -- for the XOR case where the component type is True .. True, since this
13517 -- will raise constraint error. A special check is required since CE
13518 -- will not be generated otherwise (cf Expand_Packed_Not).
13520 -- No such check is required for AND and OR, since for both these cases
13521 -- False op False = False, and True op True = True, and no check is
13522 -- required for the case of False .. False, since False xor False = False.
13523 -- See also Silly_Boolean_Array_Not_Test
13525 procedure Silly_Boolean_Array_Xor_Test
13530 Loc : constant Source_Ptr := Sloc (N);
13531 CT : constant Entity_Id := Component_Type (T);
13534 -- The check we install is
13536 -- constraint_error when
13537 -- Boolean (component_type'First)
13538 -- and then Boolean (component_type'Last)
13539 -- and then array_type'Length /= 0)
13541 -- We need the last guard because we don't want to raise CE for empty
13542 -- arrays since no out of range values result (Empty arrays with a
13543 -- component type of True .. True -- very useful -- even the ACATS
13544 -- does not test that marginal case).
13547 Make_Raise_Constraint_Error (Loc,
13549 Make_And_Then (Loc,
13551 Make_And_Then (Loc,
13553 Convert_To (Standard_Boolean,
13554 Make_Attribute_Reference (Loc,
13555 Prefix => New_Occurrence_Of (CT, Loc),
13556 Attribute_Name => Name_First)),
13559 Convert_To (Standard_Boolean,
13560 Make_Attribute_Reference (Loc,
13561 Prefix => New_Occurrence_Of (CT, Loc),
13562 Attribute_Name => Name_Last))),
13564 Right_Opnd => Make_Non_Empty_Check (Loc, R)),
13565 Reason => CE_Range_Check_Failed));
13566 end Silly_Boolean_Array_Xor_Test;
13568 --------------------------
13569 -- Target_Has_Fixed_Ops --
13570 --------------------------
13572 Integer_Sized_Small : Ureal;
13573 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
13574 -- called (we don't want to compute it more than once).
13576 Long_Integer_Sized_Small : Ureal;
13577 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
13578 -- is called (we don't want to compute it more than once)
13580 First_Time_For_THFO : Boolean := True;
13581 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
13583 function Target_Has_Fixed_Ops
13584 (Left_Typ : Entity_Id;
13585 Right_Typ : Entity_Id;
13586 Result_Typ : Entity_Id) return Boolean
13588 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
13589 -- Return True if the given type is a fixed-point type with a small
13590 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
13591 -- an absolute value less than 1.0. This is currently limited to
13592 -- fixed-point types that map to Integer or Long_Integer.
13594 ------------------------
13595 -- Is_Fractional_Type --
13596 ------------------------
13598 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
13600 if Esize (Typ) = Standard_Integer_Size then
13601 return Small_Value (Typ) = Integer_Sized_Small;
13603 elsif Esize (Typ) = Standard_Long_Integer_Size then
13604 return Small_Value (Typ) = Long_Integer_Sized_Small;
13609 end Is_Fractional_Type;
13611 -- Start of processing for Target_Has_Fixed_Ops
13614 -- Return False if Fractional_Fixed_Ops_On_Target is false
13616 if not Fractional_Fixed_Ops_On_Target then
13620 -- Here the target has Fractional_Fixed_Ops, if first time, compute
13621 -- standard constants used by Is_Fractional_Type.
13623 if First_Time_For_THFO then
13624 First_Time_For_THFO := False;
13626 Integer_Sized_Small :=
13629 Den => UI_From_Int (Standard_Integer_Size - 1),
13632 Long_Integer_Sized_Small :=
13635 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
13639 -- Return True if target supports fixed-by-fixed multiply/divide for
13640 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
13641 -- and result types are equivalent fractional types.
13643 return Is_Fractional_Type (Base_Type (Left_Typ))
13644 and then Is_Fractional_Type (Base_Type (Right_Typ))
13645 and then Is_Fractional_Type (Base_Type (Result_Typ))
13646 and then Esize (Left_Typ) = Esize (Right_Typ)
13647 and then Esize (Left_Typ) = Esize (Result_Typ);
13648 end Target_Has_Fixed_Ops;
13650 -------------------
13651 -- Type_Map_Hash --
13652 -------------------
13654 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
13656 return Type_Map_Header (Id mod Type_Map_Size);
13659 ------------------------------------------
13660 -- Type_May_Have_Bit_Aligned_Components --
13661 ------------------------------------------
13663 function Type_May_Have_Bit_Aligned_Components
13664 (Typ : Entity_Id) return Boolean
13667 -- Array type, check component type
13669 if Is_Array_Type (Typ) then
13671 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
13673 -- Record type, check components
13675 elsif Is_Record_Type (Typ) then
13680 E := First_Component_Or_Discriminant (Typ);
13681 while Present (E) loop
13682 -- This is the crucial test: if the component itself causes
13683 -- trouble, then we can stop and return True.
13685 if Component_May_Be_Bit_Aligned (E) then
13689 -- Otherwise, we need to test its type, to see if it may
13690 -- itself contain a troublesome component.
13692 if Type_May_Have_Bit_Aligned_Components (Etype (E)) then
13696 Next_Component_Or_Discriminant (E);
13702 -- Type other than array or record is always OK
13707 end Type_May_Have_Bit_Aligned_Components;
13709 -------------------------------
13710 -- Update_Primitives_Mapping --
13711 -------------------------------
13713 procedure Update_Primitives_Mapping
13714 (Inher_Id : Entity_Id;
13715 Subp_Id : Entity_Id)
13719 (Parent_Type => Find_Dispatching_Type (Inher_Id),
13720 Derived_Type => Find_Dispatching_Type (Subp_Id));
13721 end Update_Primitives_Mapping;
13723 ----------------------------------
13724 -- Within_Case_Or_If_Expression --
13725 ----------------------------------
13727 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
13731 -- Locate an enclosing case or if expression. Note that these constructs
13732 -- can be expanded into Expression_With_Actions, hence the test of the
13736 while Present (Par) loop
13737 if Nkind_In (Original_Node (Par), N_Case_Expression,
13742 -- Prevent the search from going too far
13744 elsif Is_Body_Or_Package_Declaration (Par) then
13748 Par := Parent (Par);
13752 end Within_Case_Or_If_Expression;
13754 --------------------------------
13755 -- Within_Internal_Subprogram --
13756 --------------------------------
13758 function Within_Internal_Subprogram return Boolean is
13762 S := Current_Scope;
13763 while Present (S) and then not Is_Subprogram (S) loop
13768 and then Get_TSS_Name (S) /= TSS_Null
13769 and then not Is_Predicate_Function (S)
13770 and then not Is_Predicate_Function_M (S);
13771 end Within_Internal_Subprogram;