1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Casing; use Casing;
29 with Checks; use Checks;
30 with Debug; use Debug;
31 with Einfo; use Einfo;
32 with Elists; use Elists;
33 with Errout; use Errout;
34 with Exp_Aggr; use Exp_Aggr;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch7; use Exp_Ch7;
37 with Exp_Ch11; use Exp_Ch11;
38 with Ghost; use Ghost;
39 with Inline; use Inline;
40 with Itypes; use Itypes;
42 with Nlists; use Nlists;
43 with Nmake; use Nmake;
45 with Restrict; use Restrict;
46 with Rident; use Rident;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Ch3; use Sem_Ch3;
50 with Sem_Ch6; use Sem_Ch6;
51 with Sem_Ch8; use Sem_Ch8;
52 with Sem_Ch12; use Sem_Ch12;
53 with Sem_Ch13; use Sem_Ch13;
54 with Sem_Disp; use Sem_Disp;
55 with Sem_Eval; use Sem_Eval;
56 with Sem_Res; use Sem_Res;
57 with Sem_Type; use Sem_Type;
58 with Sem_Util; use Sem_Util;
59 with Snames; use Snames;
60 with Stand; use Stand;
61 with Stringt; use Stringt;
62 with Targparm; use Targparm;
63 with Tbuild; use Tbuild;
64 with Ttypes; use Ttypes;
65 with Urealp; use Urealp;
66 with Validsw; use Validsw;
68 with GNAT.HTable; use GNAT.HTable;
70 package body Exp_Util is
72 ---------------------------------------------------------
73 -- Handling of inherited class-wide pre/postconditions --
74 ---------------------------------------------------------
76 -- Following AI12-0113, the expression for a class-wide condition is
77 -- transformed for a subprogram that inherits it, by replacing calls
78 -- to primitive operations of the original controlling type into the
79 -- corresponding overriding operations of the derived type. The following
80 -- hash table manages this mapping, and is expanded on demand whenever
81 -- such inherited expression needs to be constructed.
83 -- The mapping is also used to check whether an inherited operation has
84 -- a condition that depends on overridden operations. For such an
85 -- operation we must create a wrapper that is then treated as a normal
86 -- overriding. In SPARK mode such operations are illegal.
88 -- For a given root type there may be several type extensions with their
89 -- own overriding operations, so at various times a given operation of
90 -- the root will be mapped into different overridings. The root type is
91 -- also mapped into the current type extension to indicate that its
92 -- operations are mapped into the overriding operations of that current
95 -- The contents of the map are as follows:
99 -- Discriminant (Entity_Id) Discriminant (Entity_Id)
100 -- Discriminant (Entity_Id) Non-discriminant name (Entity_Id)
101 -- Discriminant (Entity_Id) Expression (Node_Id)
102 -- Primitive subprogram (Entity_Id) Primitive subprogram (Entity_Id)
103 -- Type (Entity_Id) Type (Entity_Id)
105 Type_Map_Size : constant := 511;
107 subtype Type_Map_Header is Integer range 0 .. Type_Map_Size - 1;
108 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header;
110 package Type_Map is new GNAT.HTable.Simple_HTable
111 (Header_Num => Type_Map_Header,
113 Element => Node_Or_Entity_Id,
115 Hash => Type_Map_Hash,
118 -----------------------
119 -- Local Subprograms --
120 -----------------------
122 function Build_Task_Array_Image
126 Dyn : Boolean := False) return Node_Id;
127 -- Build function to generate the image string for a task that is an array
128 -- component, concatenating the images of each index. To avoid storage
129 -- leaks, the string is built with successive slice assignments. The flag
130 -- Dyn indicates whether this is called for the initialization procedure of
131 -- an array of tasks, or for the name of a dynamically created task that is
132 -- assigned to an indexed component.
134 function Build_Task_Image_Function
138 Res : Entity_Id) return Node_Id;
139 -- Common processing for Task_Array_Image and Task_Record_Image. Build
140 -- function body that computes image.
142 procedure Build_Task_Image_Prefix
151 -- Common processing for Task_Array_Image and Task_Record_Image. Create
152 -- local variables and assign prefix of name to result string.
154 function Build_Task_Record_Image
157 Dyn : Boolean := False) return Node_Id;
158 -- Build function to generate the image string for a task that is a record
159 -- component. Concatenate name of variable with that of selector. The flag
160 -- Dyn indicates whether this is called for the initialization procedure of
161 -- record with task components, or for a dynamically created task that is
162 -- assigned to a selected component.
164 procedure Evaluate_Slice_Bounds (Slice : Node_Id);
165 -- Force evaluation of bounds of a slice, which may be given by a range
166 -- or by a subtype indication with or without a constraint.
168 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id;
169 -- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which
170 -- defines the Default_Initial_Condition pragma of type Typ. This is either
171 -- Typ itself or a parent type when the pragma is inherited.
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/non-zero semantics or non-standard 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 -- Build_Allocate_Deallocate_Proc --
478 ------------------------------------
480 procedure Build_Allocate_Deallocate_Proc
482 Is_Allocate : Boolean)
484 function Find_Object (E : Node_Id) return Node_Id;
485 -- Given an arbitrary expression of an allocator, try to find an object
486 -- reference in it, otherwise return the original expression.
488 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
489 -- Determine whether subprogram Subp denotes a custom allocate or
496 function Find_Object (E : Node_Id) return Node_Id is
500 pragma Assert (Is_Allocate);
504 if Nkind (Expr) = N_Explicit_Dereference then
505 Expr := Prefix (Expr);
507 elsif Nkind (Expr) = N_Qualified_Expression then
508 Expr := Expression (Expr);
510 elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
512 -- When interface class-wide types are involved in allocation,
513 -- the expander introduces several levels of address arithmetic
514 -- to perform dispatch table displacement. In this scenario the
515 -- object appears as:
517 -- Tag_Ptr (Base_Address (<object>'Address))
519 -- Detect this case and utilize the whole expression as the
520 -- "object" since it now points to the proper dispatch table.
522 if Is_RTE (Etype (Expr), RE_Tag_Ptr) then
525 -- Continue to strip the object
528 Expr := Expression (Expr);
539 ---------------------------------
540 -- Is_Allocate_Deallocate_Proc --
541 ---------------------------------
543 function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
545 -- Look for a subprogram body with only one statement which is a
546 -- call to Allocate_Any_Controlled / Deallocate_Any_Controlled.
548 if Ekind (Subp) = E_Procedure
549 and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
552 HSS : constant Node_Id :=
553 Handled_Statement_Sequence (Parent (Parent (Subp)));
557 if Present (Statements (HSS))
558 and then Nkind (First (Statements (HSS))) =
559 N_Procedure_Call_Statement
561 Proc := Entity (Name (First (Statements (HSS))));
564 Is_RTE (Proc, RE_Allocate_Any_Controlled)
565 or else Is_RTE (Proc, RE_Deallocate_Any_Controlled);
571 end Is_Allocate_Deallocate_Proc;
575 Desig_Typ : Entity_Id;
579 Proc_To_Call : Node_Id := Empty;
582 -- Start of processing for Build_Allocate_Deallocate_Proc
585 -- Obtain the attributes of the allocation / deallocation
587 if Nkind (N) = N_Free_Statement then
588 Expr := Expression (N);
589 Ptr_Typ := Base_Type (Etype (Expr));
590 Proc_To_Call := Procedure_To_Call (N);
593 if Nkind (N) = N_Object_Declaration then
594 Expr := Expression (N);
599 -- In certain cases an allocator with a qualified expression may
600 -- be relocated and used as the initialization expression of a
604 -- Obj : Ptr_Typ := new Desig_Typ'(...);
607 -- Tmp : Ptr_Typ := new Desig_Typ'(...);
608 -- Obj : Ptr_Typ := Tmp;
610 -- Since the allocator is always marked as analyzed to avoid infinite
611 -- expansion, it will never be processed by this routine given that
612 -- the designated type needs finalization actions. Detect this case
613 -- and complete the expansion of the allocator.
615 if Nkind (Expr) = N_Identifier
616 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
617 and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
619 Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
623 -- The allocator may have been rewritten into something else in which
624 -- case the expansion performed by this routine does not apply.
626 if Nkind (Expr) /= N_Allocator then
630 Ptr_Typ := Base_Type (Etype (Expr));
631 Proc_To_Call := Procedure_To_Call (Expr);
634 Pool_Id := Associated_Storage_Pool (Ptr_Typ);
635 Desig_Typ := Available_View (Designated_Type (Ptr_Typ));
637 -- Handle concurrent types
639 if Is_Concurrent_Type (Desig_Typ)
640 and then Present (Corresponding_Record_Type (Desig_Typ))
642 Desig_Typ := Corresponding_Record_Type (Desig_Typ);
645 -- Do not process allocations / deallocations without a pool
650 -- Do not process allocations on / deallocations from the secondary
653 elsif Is_RTE (Pool_Id, RE_SS_Pool) then
656 -- Optimize the case where we are using the default Global_Pool_Object,
657 -- and we don't need the heavy finalization machinery.
659 elsif Pool_Id = RTE (RE_Global_Pool_Object)
660 and then not Needs_Finalization (Desig_Typ)
664 -- Do not replicate the machinery if the allocator / free has already
665 -- been expanded and has a custom Allocate / Deallocate.
667 elsif Present (Proc_To_Call)
668 and then Is_Allocate_Deallocate_Proc (Proc_To_Call)
673 -- Finalization actions are required when the object to be allocated or
674 -- deallocated needs these actions and the associated access type is not
675 -- subject to pragma No_Heap_Finalization.
678 Needs_Finalization (Desig_Typ)
679 and then not No_Heap_Finalization (Ptr_Typ);
683 -- Certain run-time configurations and targets do not provide support
684 -- for controlled types.
686 if Restriction_Active (No_Finalization) then
689 -- Do nothing if the access type may never allocate / deallocate
692 elsif No_Pool_Assigned (Ptr_Typ) then
696 -- The allocation / deallocation of a controlled object must be
697 -- chained on / detached from a finalization master.
699 pragma Assert (Present (Finalization_Master (Ptr_Typ)));
701 -- The only other kind of allocation / deallocation supported by this
702 -- routine is on / from a subpool.
704 elsif Nkind (Expr) = N_Allocator
705 and then No (Subpool_Handle_Name (Expr))
711 Loc : constant Source_Ptr := Sloc (N);
712 Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
713 Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
714 Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
715 Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
718 Fin_Addr_Id : Entity_Id;
719 Fin_Mas_Act : Node_Id;
720 Fin_Mas_Id : Entity_Id;
721 Proc_To_Call : Entity_Id;
722 Subpool : Node_Id := Empty;
725 -- Step 1: Construct all the actuals for the call to library routine
726 -- Allocate_Any_Controlled / Deallocate_Any_Controlled.
730 Actuals := New_List (New_Occurrence_Of (Pool_Id, Loc));
736 if Nkind (Expr) = N_Allocator then
737 Subpool := Subpool_Handle_Name (Expr);
740 -- If a subpool is present it can be an arbitrary name, so make
741 -- the actual by copying the tree.
743 if Present (Subpool) then
744 Append_To (Actuals, New_Copy_Tree (Subpool, New_Sloc => Loc));
746 Append_To (Actuals, Make_Null (Loc));
749 -- c) Finalization master
752 Fin_Mas_Id := Finalization_Master (Ptr_Typ);
753 Fin_Mas_Act := New_Occurrence_Of (Fin_Mas_Id, Loc);
755 -- Handle the case where the master is actually a pointer to a
756 -- master. This case arises in build-in-place functions.
758 if Is_Access_Type (Etype (Fin_Mas_Id)) then
759 Append_To (Actuals, Fin_Mas_Act);
762 Make_Attribute_Reference (Loc,
763 Prefix => Fin_Mas_Act,
764 Attribute_Name => Name_Unrestricted_Access));
767 Append_To (Actuals, Make_Null (Loc));
770 -- d) Finalize_Address
772 -- Primitive Finalize_Address is never generated in CodePeer mode
773 -- since it contains an Unchecked_Conversion.
775 if Needs_Fin and then not CodePeer_Mode then
776 Fin_Addr_Id := Finalize_Address (Desig_Typ);
777 pragma Assert (Present (Fin_Addr_Id));
780 Make_Attribute_Reference (Loc,
781 Prefix => New_Occurrence_Of (Fin_Addr_Id, Loc),
782 Attribute_Name => Name_Unrestricted_Access));
784 Append_To (Actuals, Make_Null (Loc));
792 Append_To (Actuals, New_Occurrence_Of (Addr_Id, Loc));
793 Append_To (Actuals, New_Occurrence_Of (Size_Id, Loc));
795 if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then
796 Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc));
798 -- For deallocation of class-wide types we obtain the value of
799 -- alignment from the Type Specific Record of the deallocated object.
800 -- This is needed because the frontend expansion of class-wide types
801 -- into equivalent types confuses the back end.
807 -- ... because 'Alignment applied to class-wide types is expanded
808 -- into the code that reads the value of alignment from the TSD
809 -- (see Expand_N_Attribute_Reference)
812 Unchecked_Convert_To (RTE (RE_Storage_Offset),
813 Make_Attribute_Reference (Loc,
815 Make_Explicit_Dereference (Loc, Relocate_Node (Expr)),
816 Attribute_Name => Name_Alignment)));
822 Is_Controlled : declare
823 Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
830 Temp := Find_Object (Expression (Expr));
835 -- Processing for allocations where the expression is a subtype
839 and then Is_Entity_Name (Temp)
840 and then Is_Type (Entity (Temp))
845 (Needs_Finalization (Entity (Temp))), Loc);
847 -- The allocation / deallocation of a class-wide object relies
848 -- on a runtime check to determine whether the object is truly
849 -- controlled or not. Depending on this check, the finalization
850 -- machinery will request or reclaim extra storage reserved for
853 elsif Is_Class_Wide_Type (Desig_Typ) then
855 -- Detect a special case where interface class-wide types
856 -- are involved as the object appears as:
858 -- Tag_Ptr (Base_Address (<object>'Address))
860 -- The expression already yields the proper tag, generate:
864 if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
866 Make_Explicit_Dereference (Loc,
867 Prefix => Relocate_Node (Temp));
869 -- In the default case, obtain the tag of the object about
870 -- to be allocated / deallocated. Generate:
876 Make_Attribute_Reference (Loc,
877 Prefix => Relocate_Node (Temp),
878 Attribute_Name => Name_Tag);
882 -- Needs_Finalization (<Param>)
885 Make_Function_Call (Loc,
887 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
888 Parameter_Associations => New_List (Param));
890 -- Processing for generic actuals
892 elsif Is_Generic_Actual_Type (Desig_Typ) then
894 New_Occurrence_Of (Boolean_Literals
895 (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
897 -- The object does not require any specialized checks, it is
898 -- known to be controlled.
901 Flag_Expr := New_Occurrence_Of (Standard_True, Loc);
904 -- Create the temporary which represents the finalization state
905 -- of the expression. Generate:
907 -- F : constant Boolean := <Flag_Expr>;
910 Make_Object_Declaration (Loc,
911 Defining_Identifier => Flag_Id,
912 Constant_Present => True,
914 New_Occurrence_Of (Standard_Boolean, Loc),
915 Expression => Flag_Expr));
917 Append_To (Actuals, New_Occurrence_Of (Flag_Id, Loc));
920 -- The object is not controlled
923 Append_To (Actuals, New_Occurrence_Of (Standard_False, Loc));
930 New_Occurrence_Of (Boolean_Literals (Present (Subpool)), Loc));
933 -- Step 2: Build a wrapper Allocate / Deallocate which internally
934 -- calls Allocate_Any_Controlled / Deallocate_Any_Controlled.
936 -- Select the proper routine to call
939 Proc_To_Call := RTE (RE_Allocate_Any_Controlled);
941 Proc_To_Call := RTE (RE_Deallocate_Any_Controlled);
944 -- Create a custom Allocate / Deallocate routine which has identical
945 -- profile to that of System.Storage_Pools.
948 Make_Subprogram_Body (Loc,
953 Make_Procedure_Specification (Loc,
954 Defining_Unit_Name => Proc_Id,
955 Parameter_Specifications => New_List (
957 -- P : Root_Storage_Pool
959 Make_Parameter_Specification (Loc,
960 Defining_Identifier => Make_Temporary (Loc, 'P'),
962 New_Occurrence_Of (RTE (RE_Root_Storage_Pool), Loc)),
966 Make_Parameter_Specification (Loc,
967 Defining_Identifier => Addr_Id,
968 Out_Present => Is_Allocate,
970 New_Occurrence_Of (RTE (RE_Address), Loc)),
974 Make_Parameter_Specification (Loc,
975 Defining_Identifier => Size_Id,
977 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)),
981 Make_Parameter_Specification (Loc,
982 Defining_Identifier => Alig_Id,
984 New_Occurrence_Of (RTE (RE_Storage_Count), Loc)))),
986 Declarations => No_List,
988 Handled_Statement_Sequence =>
989 Make_Handled_Sequence_Of_Statements (Loc,
990 Statements => New_List (
991 Make_Procedure_Call_Statement (Loc,
993 New_Occurrence_Of (Proc_To_Call, Loc),
994 Parameter_Associations => Actuals)))),
995 Suppress => All_Checks);
997 -- The newly generated Allocate / Deallocate becomes the default
998 -- procedure to call when the back end processes the allocation /
1002 Set_Procedure_To_Call (Expr, Proc_Id);
1004 Set_Procedure_To_Call (N, Proc_Id);
1007 end Build_Allocate_Deallocate_Proc;
1009 -------------------------------
1010 -- Build_Abort_Undefer_Block --
1011 -------------------------------
1013 function Build_Abort_Undefer_Block
1016 Context : Node_Id) return Node_Id
1018 Exceptions_OK : constant Boolean :=
1019 not Restriction_Active (No_Exception_Propagation);
1027 -- The block should be generated only when undeferring abort in the
1028 -- context of a potential exception.
1030 pragma Assert (Abort_Allowed and Exceptions_OK);
1036 -- Abort_Undefer_Direct;
1039 AUD := RTE (RE_Abort_Undefer_Direct);
1042 Make_Handled_Sequence_Of_Statements (Loc,
1043 Statements => Stmts,
1044 At_End_Proc => New_Occurrence_Of (AUD, Loc));
1047 Make_Block_Statement (Loc,
1048 Handled_Statement_Sequence => HSS);
1049 Set_Is_Abort_Block (Blk);
1051 Add_Block_Identifier (Blk, Blk_Id);
1052 Expand_At_End_Handler (HSS, Blk_Id);
1054 -- Present the Abort_Undefer_Direct function to the back end to inline
1055 -- the call to the routine.
1057 Add_Inlined_Body (AUD, Context);
1060 end Build_Abort_Undefer_Block;
1062 ---------------------------------
1063 -- Build_Class_Wide_Expression --
1064 ---------------------------------
1066 procedure Build_Class_Wide_Expression
1069 Par_Subp : Entity_Id;
1070 Adjust_Sloc : Boolean;
1071 Needs_Wrapper : out Boolean)
1073 function Replace_Entity (N : Node_Id) return Traverse_Result;
1074 -- Replace reference to formal of inherited operation or to primitive
1075 -- operation of root type, with corresponding entity for derived type,
1076 -- when constructing the class-wide condition of an overriding
1079 --------------------
1080 -- Replace_Entity --
1081 --------------------
1083 function Replace_Entity (N : Node_Id) return Traverse_Result is
1088 Adjust_Inherited_Pragma_Sloc (N);
1091 if Nkind (N) = N_Identifier
1092 and then Present (Entity (N))
1094 (Is_Formal (Entity (N)) or else Is_Subprogram (Entity (N)))
1096 (Nkind (Parent (N)) /= N_Attribute_Reference
1097 or else Attribute_Name (Parent (N)) /= Name_Class)
1099 -- The replacement does not apply to dispatching calls within the
1100 -- condition, but only to calls whose static tag is that of the
1103 if Is_Subprogram (Entity (N))
1104 and then Nkind (Parent (N)) = N_Function_Call
1105 and then Present (Controlling_Argument (Parent (N)))
1110 -- Determine whether entity has a renaming
1112 New_E := Type_Map.Get (Entity (N));
1114 if Present (New_E) then
1115 Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
1117 -- If the entity is an overridden primitive and we are not
1118 -- in proof mode, we must build a wrapper for the current
1119 -- inherited operation.
1121 if Is_Subprogram (New_E)
1122 and then not GNATprove_Mode
1124 Needs_Wrapper := True;
1128 -- Check that there are no calls left to abstract operations if
1129 -- the current subprogram is not abstract.
1131 if Nkind (Parent (N)) = N_Function_Call
1132 and then N = Name (Parent (N))
1134 if not Is_Abstract_Subprogram (Subp)
1135 and then Is_Abstract_Subprogram (Entity (N))
1137 Error_Msg_Sloc := Sloc (Current_Scope);
1138 -- Error_Msg_Node_1 := Entity (N);
1139 Error_Msg_Node_2 := Subp;
1140 if Comes_From_Source (Subp) then
1142 ("cannot call abstract subprogram& in inherited "
1143 & "condition for&#", Subp, Entity (N));
1146 ("cannot call abstract subprogram& in inherited "
1147 & "condition for inherited&#", Subp, Entity (N));
1150 -- In SPARK mode, reject an inherited condition for an
1151 -- inherited operation if it contains a call to an overriding
1152 -- operation, because this implies that the pre/postconditions
1153 -- of the inherited operation have changed silently.
1155 elsif SPARK_Mode = On
1156 and then Warn_On_Suspicious_Contract
1157 and then Present (Alias (Subp))
1158 and then Present (New_E)
1159 and then Comes_From_Source (New_E)
1162 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
1164 Error_Msg_Sloc := Sloc (New_E);
1165 Error_Msg_Node_2 := Subp;
1167 ("\overriding of&# forces overriding of&",
1168 Parent (Subp), New_E);
1172 -- Update type of function call node, which should be the same as
1173 -- the function's return type.
1175 if Is_Subprogram (Entity (N))
1176 and then Nkind (Parent (N)) = N_Function_Call
1178 Set_Etype (Parent (N), Etype (Entity (N)));
1181 -- The whole expression will be reanalyzed
1183 elsif Nkind (N) in N_Has_Etype then
1184 Set_Analyzed (N, False);
1190 procedure Replace_Condition_Entities is
1191 new Traverse_Proc (Replace_Entity);
1195 Par_Formal : Entity_Id;
1196 Subp_Formal : Entity_Id;
1198 -- Start of processing for Build_Class_Wide_Expression
1201 Needs_Wrapper := False;
1203 -- Add mapping from old formals to new formals
1205 Par_Formal := First_Formal (Par_Subp);
1206 Subp_Formal := First_Formal (Subp);
1208 while Present (Par_Formal) and then Present (Subp_Formal) loop
1209 Type_Map.Set (Par_Formal, Subp_Formal);
1210 Next_Formal (Par_Formal);
1211 Next_Formal (Subp_Formal);
1214 Replace_Condition_Entities (Prag);
1215 end Build_Class_Wide_Expression;
1217 --------------------
1218 -- Build_DIC_Call --
1219 --------------------
1221 function Build_DIC_Call
1224 Typ : Entity_Id) return Node_Id
1226 Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
1227 Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
1231 Make_Procedure_Call_Statement (Loc,
1232 Name => New_Occurrence_Of (Proc_Id, Loc),
1233 Parameter_Associations => New_List (
1234 Make_Unchecked_Type_Conversion (Loc,
1235 Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
1236 Expression => New_Occurrence_Of (Obj_Id, Loc))));
1239 ------------------------------
1240 -- Build_DIC_Procedure_Body --
1241 ------------------------------
1243 -- WARNING: This routine manages Ghost regions. Return statements must be
1244 -- replaced by gotos which jump to the end of the routine and restore the
1247 procedure Build_DIC_Procedure_Body
1249 For_Freeze : Boolean := False)
1251 procedure Add_DIC_Check
1252 (DIC_Prag : Node_Id;
1254 Stmts : in out List_Id);
1255 -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
1256 -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
1257 -- is added to list Stmts.
1259 procedure Add_Inherited_DIC
1260 (DIC_Prag : Node_Id;
1261 Par_Typ : Entity_Id;
1262 Deriv_Typ : Entity_Id;
1263 Stmts : in out List_Id);
1264 -- Add a runtime check to verify the assertion expression of inherited
1265 -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
1266 -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
1267 -- pragma. All generated code is added to list Stmts.
1269 procedure Add_Inherited_Tagged_DIC
1270 (DIC_Prag : Node_Id;
1271 Par_Typ : Entity_Id;
1272 Deriv_Typ : Entity_Id;
1273 Stmts : in out List_Id);
1274 -- Add a runtime check to verify assertion expression DIC_Expr of
1275 -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
1276 -- postcondition-like runtime semantics to the check. Par_Typ is the
1277 -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
1278 -- derived type inheriting the DIC pragma. All generated code is added
1281 procedure Add_Own_DIC
1282 (DIC_Prag : Node_Id;
1283 DIC_Typ : Entity_Id;
1284 Stmts : in out List_Id);
1285 -- Add a runtime check to verify the assertion expression of pragma
1286 -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
1287 -- is added to list Stmts.
1293 procedure Add_DIC_Check
1294 (DIC_Prag : Node_Id;
1296 Stmts : in out List_Id)
1298 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1299 Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
1302 -- The DIC pragma is ignored, nothing left to do
1304 if Is_Ignored (DIC_Prag) then
1307 -- Otherwise the DIC expression must be checked at run time.
1310 -- pragma Check (<Nam>, <DIC_Expr>);
1313 Append_New_To (Stmts,
1315 Pragma_Identifier =>
1316 Make_Identifier (Loc, Name_Check),
1318 Pragma_Argument_Associations => New_List (
1319 Make_Pragma_Argument_Association (Loc,
1320 Expression => Make_Identifier (Loc, Nam)),
1322 Make_Pragma_Argument_Association (Loc,
1323 Expression => DIC_Expr))));
1327 -----------------------
1328 -- Add_Inherited_DIC --
1329 -----------------------
1331 procedure Add_Inherited_DIC
1332 (DIC_Prag : Node_Id;
1333 Par_Typ : Entity_Id;
1334 Deriv_Typ : Entity_Id;
1335 Stmts : in out List_Id)
1337 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1338 Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
1339 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1340 Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
1341 Loc : constant Source_Ptr := Sloc (DIC_Prag);
1344 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1346 -- Verify the inherited DIC assertion expression by calling the DIC
1347 -- procedure of the parent type.
1350 -- <Par_Typ>DIC (Par_Typ (_object));
1352 Append_New_To (Stmts,
1353 Make_Procedure_Call_Statement (Loc,
1354 Name => New_Occurrence_Of (Par_Proc, Loc),
1355 Parameter_Associations => New_List (
1357 (Typ => Etype (Par_Obj),
1358 Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
1359 end Add_Inherited_DIC;
1361 ------------------------------
1362 -- Add_Inherited_Tagged_DIC --
1363 ------------------------------
1365 procedure Add_Inherited_Tagged_DIC
1366 (DIC_Prag : Node_Id;
1367 Par_Typ : Entity_Id;
1368 Deriv_Typ : Entity_Id;
1369 Stmts : in out List_Id)
1371 Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
1372 DIC_Args : constant List_Id :=
1373 Pragma_Argument_Associations (DIC_Prag);
1374 DIC_Arg : constant Node_Id := First (DIC_Args);
1375 DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
1376 Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
1381 -- The processing of an inherited DIC assertion expression starts off
1382 -- with a copy of the original parent expression where all references
1383 -- to the parent type have already been replaced with references to
1384 -- the _object formal parameter of the parent type's DIC procedure.
1386 pragma Assert (Present (DIC_Expr));
1387 Expr := New_Copy_Tree (DIC_Expr);
1389 -- Perform the following substitutions:
1391 -- * Replace a reference to the _object parameter of the parent
1392 -- type's DIC procedure with a reference to the _object parameter
1393 -- of the derived types' DIC procedure.
1395 -- * Replace a reference to a discriminant of the parent type with
1396 -- a suitable value from the point of view of the derived type.
1398 -- * Replace a call to an overridden parent primitive with a call
1399 -- to the overriding derived type primitive.
1401 -- * Replace a call to an inherited parent primitive with a call to
1402 -- the internally-generated inherited derived type primitive.
1404 -- Note that primitives defined in the private part are automatically
1405 -- handled by the overriding/inheritance mechanism and do not require
1406 -- an extra replacement pass.
1408 pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
1413 Deriv_Typ => Deriv_Typ,
1414 Par_Obj => First_Formal (Par_Proc),
1415 Deriv_Obj => First_Formal (Deriv_Proc));
1417 -- Once the DIC assertion expression is fully processed, add a check
1418 -- to the statements of the DIC procedure.
1421 (DIC_Prag => DIC_Prag,
1424 end Add_Inherited_Tagged_DIC;
1430 procedure Add_Own_DIC
1431 (DIC_Prag : Node_Id;
1432 DIC_Typ : Entity_Id;
1433 Stmts : in out List_Id)
1435 DIC_Args : constant List_Id :=
1436 Pragma_Argument_Associations (DIC_Prag);
1437 DIC_Arg : constant Node_Id := First (DIC_Args);
1438 DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
1439 DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
1440 DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
1441 Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
1443 procedure Preanalyze_Own_DIC_For_ASIS;
1444 -- Preanalyze the original DIC expression of an aspect or a source
1447 ---------------------------------
1448 -- Preanalyze_Own_DIC_For_ASIS --
1449 ---------------------------------
1451 procedure Preanalyze_Own_DIC_For_ASIS is
1452 Expr : Node_Id := Empty;
1455 -- The DIC pragma is a source construct, preanalyze the original
1456 -- expression of the pragma.
1458 if Comes_From_Source (DIC_Prag) then
1461 -- Otherwise preanalyze the expression of the corresponding aspect
1463 elsif Present (DIC_Asp) then
1464 Expr := Expression (DIC_Asp);
1467 -- The expression must be subjected to the same substitutions as
1468 -- the copy used in the generation of the runtime check.
1470 if Present (Expr) then
1471 Replace_Type_References
1476 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1478 end Preanalyze_Own_DIC_For_ASIS;
1482 Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
1486 -- Start of processing for Add_Own_DIC
1489 Expr := New_Copy_Tree (DIC_Expr);
1491 -- Perform the following substitution:
1493 -- * Replace the current instance of DIC_Typ with a reference to
1494 -- the _object formal parameter of the DIC procedure.
1496 Replace_Type_References
1501 -- Preanalyze the DIC expression to detect errors and at the same
1502 -- time capture the visibility of the proper package part.
1504 Set_Parent (Expr, Typ_Decl);
1505 Preanalyze_Assert_Expression (Expr, Any_Boolean);
1507 -- Save a copy of the expression with all replacements and analysis
1508 -- already taken place in case a derived type inherits the pragma.
1509 -- The copy will be used as the foundation of the derived type's own
1510 -- version of the DIC assertion expression.
1512 if Is_Tagged_Type (DIC_Typ) then
1513 Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
1516 -- If the pragma comes from an aspect specification, replace the
1517 -- saved expression because all type references must be substituted
1518 -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
1521 if Present (DIC_Asp) then
1522 Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
1525 -- Preanalyze the original DIC expression for ASIS
1528 Preanalyze_Own_DIC_For_ASIS;
1531 -- Once the DIC assertion expression is fully processed, add a check
1532 -- to the statements of the DIC procedure.
1535 (DIC_Prag => DIC_Prag,
1542 Loc : constant Source_Ptr := Sloc (Typ);
1544 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1545 -- Save the Ghost mode to restore on exit
1548 DIC_Typ : Entity_Id;
1549 Dummy_1 : Entity_Id;
1550 Dummy_2 : Entity_Id;
1551 Proc_Body : Node_Id;
1552 Proc_Body_Id : Entity_Id;
1553 Proc_Decl : Node_Id;
1554 Proc_Id : Entity_Id;
1555 Stmts : List_Id := No_List;
1557 Build_Body : Boolean := False;
1558 -- Flag set when the type requires a DIC procedure body to be built
1560 Work_Typ : Entity_Id;
1563 -- Start of processing for Build_DIC_Procedure_Body
1566 Work_Typ := Base_Type (Typ);
1568 -- Do not process class-wide types as these are Itypes, but lack a first
1569 -- subtype (see below).
1571 if Is_Class_Wide_Type (Work_Typ) then
1574 -- Do not process the underlying full view of a private type. There is
1575 -- no way to get back to the partial view, plus the body will be built
1576 -- by the full view or the base type.
1578 elsif Is_Underlying_Full_View (Work_Typ) then
1581 -- Use the first subtype when dealing with various base types
1583 elsif Is_Itype (Work_Typ) then
1584 Work_Typ := First_Subtype (Work_Typ);
1586 -- The input denotes the corresponding record type of a protected or a
1587 -- task type. Work with the concurrent type because the corresponding
1588 -- record type may not be visible to clients of the type.
1590 elsif Ekind (Work_Typ) = E_Record_Type
1591 and then Is_Concurrent_Record_Type (Work_Typ)
1593 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
1596 -- The working type may be subject to pragma Ghost. Set the mode now to
1597 -- ensure that the DIC procedure is properly marked as Ghost.
1599 Set_Ghost_Mode (Work_Typ);
1601 -- The working type must be either define a DIC pragma of its own or
1602 -- inherit one from a parent type.
1604 pragma Assert (Has_DIC (Work_Typ));
1606 -- Recover the type which defines the DIC pragma. This is either the
1607 -- working type itself or a parent type when the pragma is inherited.
1609 DIC_Typ := Find_DIC_Type (Work_Typ);
1610 pragma Assert (Present (DIC_Typ));
1612 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
1613 pragma Assert (Present (DIC_Prag));
1615 -- Nothing to do if pragma DIC appears without an argument or its sole
1616 -- argument is "null".
1618 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
1622 -- The working type may lack a DIC procedure declaration. This may be
1623 -- due to several reasons:
1625 -- * The working type's own DIC pragma does not contain a verifiable
1626 -- assertion expression. In this case there is no need to build a
1627 -- DIC procedure because there is nothing to check.
1629 -- * The working type derives from a parent type. In this case a DIC
1630 -- procedure should be built only when the inherited DIC pragma has
1631 -- a verifiable assertion expression.
1633 Proc_Id := DIC_Procedure (Work_Typ);
1635 -- Build a DIC procedure declaration when the working type derives from
1638 if No (Proc_Id) then
1639 Build_DIC_Procedure_Declaration (Work_Typ);
1640 Proc_Id := DIC_Procedure (Work_Typ);
1643 -- At this point there should be a DIC procedure declaration
1645 pragma Assert (Present (Proc_Id));
1646 Proc_Decl := Unit_Declaration_Node (Proc_Id);
1648 -- Nothing to do if the DIC procedure already has a body
1650 if Present (Corresponding_Body (Proc_Decl)) then
1654 -- Emulate the environment of the DIC procedure by installing its scope
1655 -- and formal parameters.
1657 Push_Scope (Proc_Id);
1658 Install_Formals (Proc_Id);
1660 -- The working type defines its own DIC pragma. Replace the current
1661 -- instance of the working type with the formal of the DIC procedure.
1662 -- Note that there is no need to consider inherited DIC pragmas from
1663 -- parent types because the working type's DIC pragma "hides" all
1664 -- inherited DIC pragmas.
1666 if Has_Own_DIC (Work_Typ) then
1667 pragma Assert (DIC_Typ = Work_Typ);
1670 (DIC_Prag => DIC_Prag,
1676 -- Otherwise the working type inherits a DIC pragma from a parent type.
1677 -- This processing is carried out when the type is frozen because the
1678 -- state of all parent discriminants is known at that point. Note that
1679 -- it is semantically sound to delay the creation of the DIC procedure
1680 -- body till the freeze point. If the type has a DIC pragma of its own,
1681 -- then the DIC procedure body would have already been constructed at
1682 -- the end of the visible declarations and all parent DIC pragmas are
1683 -- effectively "hidden" and irrelevant.
1685 elsif For_Freeze then
1686 pragma Assert (Has_Inherited_DIC (Work_Typ));
1687 pragma Assert (DIC_Typ /= Work_Typ);
1689 -- The working type is tagged. The verification of the assertion
1690 -- expression is subject to the same semantics as class-wide pre-
1691 -- and postconditions.
1693 if Is_Tagged_Type (Work_Typ) then
1694 Add_Inherited_Tagged_DIC
1695 (DIC_Prag => DIC_Prag,
1697 Deriv_Typ => Work_Typ,
1700 -- Otherwise the working type is not tagged. Verify the assertion
1701 -- expression of the inherited DIC pragma by directly calling the
1702 -- DIC procedure of the parent type.
1706 (DIC_Prag => DIC_Prag,
1708 Deriv_Typ => Work_Typ,
1719 -- Produce an empty completing body in the following cases:
1720 -- * Assertions are disabled
1721 -- * The DIC Assertion_Policy is Ignore
1722 -- * Pragma DIC appears without an argument
1723 -- * Pragma DIC appears with argument "null"
1726 Stmts := New_List (Make_Null_Statement (Loc));
1730 -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
1733 -- end <Work_Typ>DIC;
1736 Make_Subprogram_Body (Loc,
1738 Copy_Subprogram_Spec (Parent (Proc_Id)),
1739 Declarations => Empty_List,
1740 Handled_Statement_Sequence =>
1741 Make_Handled_Sequence_Of_Statements (Loc,
1742 Statements => Stmts));
1743 Proc_Body_Id := Defining_Entity (Proc_Body);
1745 -- Perform minor decoration in case the body is not analyzed
1747 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
1748 Set_Etype (Proc_Body_Id, Standard_Void_Type);
1749 Set_Scope (Proc_Body_Id, Current_Scope);
1751 -- Link both spec and body to avoid generating duplicates
1753 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
1754 Set_Corresponding_Spec (Proc_Body, Proc_Id);
1756 -- The body should not be inserted into the tree when the context
1757 -- is ASIS or a generic unit because it is not part of the template.
1758 -- Note that the body must still be generated in order to resolve the
1759 -- DIC assertion expression.
1761 if ASIS_Mode or Inside_A_Generic then
1764 -- Semi-insert the body into the tree for GNATprove by setting its
1765 -- Parent field. This allows for proper upstream tree traversals.
1767 elsif GNATprove_Mode then
1768 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
1770 -- Otherwise the body is part of the freezing actions of the working
1774 Append_Freeze_Action (Work_Typ, Proc_Body);
1779 Restore_Ghost_Mode (Saved_GM);
1780 end Build_DIC_Procedure_Body;
1782 -------------------------------------
1783 -- Build_DIC_Procedure_Declaration --
1784 -------------------------------------
1786 -- WARNING: This routine manages Ghost regions. Return statements must be
1787 -- replaced by gotos which jump to the end of the routine and restore the
1790 procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is
1791 Loc : constant Source_Ptr := Sloc (Typ);
1793 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1794 -- Save the Ghost mode to restore on exit
1797 DIC_Typ : Entity_Id;
1798 Proc_Decl : Node_Id;
1799 Proc_Id : Entity_Id;
1802 CRec_Typ : Entity_Id;
1803 -- The corresponding record type of Full_Typ
1805 Full_Base : Entity_Id;
1806 -- The base type of Full_Typ
1808 Full_Typ : Entity_Id;
1809 -- The full view of working type
1812 -- The _object formal parameter of the DIC procedure
1814 Priv_Typ : Entity_Id;
1815 -- The partial view of working type
1817 Work_Typ : Entity_Id;
1821 Work_Typ := Base_Type (Typ);
1823 -- Do not process class-wide types as these are Itypes, but lack a first
1824 -- subtype (see below).
1826 if Is_Class_Wide_Type (Work_Typ) then
1829 -- Do not process the underlying full view of a private type. There is
1830 -- no way to get back to the partial view, plus the body will be built
1831 -- by the full view or the base type.
1833 elsif Is_Underlying_Full_View (Work_Typ) then
1836 -- Use the first subtype when dealing with various base types
1838 elsif Is_Itype (Work_Typ) then
1839 Work_Typ := First_Subtype (Work_Typ);
1841 -- The input denotes the corresponding record type of a protected or a
1842 -- task type. Work with the concurrent type because the corresponding
1843 -- record type may not be visible to clients of the type.
1845 elsif Ekind (Work_Typ) = E_Record_Type
1846 and then Is_Concurrent_Record_Type (Work_Typ)
1848 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
1851 -- The working type may be subject to pragma Ghost. Set the mode now to
1852 -- ensure that the DIC procedure is properly marked as Ghost.
1854 Set_Ghost_Mode (Work_Typ);
1856 -- The type must be either subject to a DIC pragma or inherit one from a
1859 pragma Assert (Has_DIC (Work_Typ));
1861 -- Recover the type which defines the DIC pragma. This is either the
1862 -- working type itself or a parent type when the pragma is inherited.
1864 DIC_Typ := Find_DIC_Type (Work_Typ);
1865 pragma Assert (Present (DIC_Typ));
1867 DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
1868 pragma Assert (Present (DIC_Prag));
1870 -- Nothing to do if pragma DIC appears without an argument or its sole
1871 -- argument is "null".
1873 if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
1876 -- Nothing to do if the type already has a DIC procedure
1878 elsif Present (DIC_Procedure (Work_Typ)) then
1883 Make_Defining_Identifier (Loc,
1885 New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
1887 -- Perform minor decoration in case the declaration is not analyzed
1889 Set_Ekind (Proc_Id, E_Procedure);
1890 Set_Etype (Proc_Id, Standard_Void_Type);
1891 Set_Scope (Proc_Id, Current_Scope);
1893 Set_Is_DIC_Procedure (Proc_Id);
1894 Set_DIC_Procedure (Work_Typ, Proc_Id);
1896 -- The DIC procedure requires debug info when the assertion expression
1897 -- is subject to Source Coverage Obligations.
1899 if Opt.Generate_SCO then
1900 Set_Needs_Debug_Info (Proc_Id);
1903 -- Obtain all views of the input type
1905 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
1907 -- Associate the DIC procedure and various relevant flags with all views
1909 Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
1910 Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
1911 Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ);
1912 Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
1914 -- The declaration of the DIC procedure must be inserted after the
1915 -- declaration of the partial view as this allows for proper external
1918 if Present (Priv_Typ) then
1919 Typ_Decl := Declaration_Node (Priv_Typ);
1921 -- Derived types with the full view as parent do not have a partial
1922 -- view. Insert the DIC procedure after the derived type.
1925 Typ_Decl := Declaration_Node (Full_Typ);
1928 -- The type should have a declarative node
1930 pragma Assert (Present (Typ_Decl));
1932 -- Create the formal parameter which emulates the variable-like behavior
1933 -- of the type's current instance.
1935 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
1937 -- Perform minor decoration in case the declaration is not analyzed
1939 Set_Ekind (Obj_Id, E_In_Parameter);
1940 Set_Etype (Obj_Id, Work_Typ);
1941 Set_Scope (Obj_Id, Proc_Id);
1943 Set_First_Entity (Proc_Id, Obj_Id);
1946 -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
1949 Make_Subprogram_Declaration (Loc,
1951 Make_Procedure_Specification (Loc,
1952 Defining_Unit_Name => Proc_Id,
1953 Parameter_Specifications => New_List (
1954 Make_Parameter_Specification (Loc,
1955 Defining_Identifier => Obj_Id,
1957 New_Occurrence_Of (Work_Typ, Loc)))));
1959 -- The declaration should not be inserted into the tree when the context
1960 -- is ASIS or a generic unit because it is not part of the template.
1962 if ASIS_Mode or Inside_A_Generic then
1965 -- Semi-insert the declaration into the tree for GNATprove by setting
1966 -- its Parent field. This allows for proper upstream tree traversals.
1968 elsif GNATprove_Mode then
1969 Set_Parent (Proc_Decl, Parent (Typ_Decl));
1971 -- Otherwise insert the declaration
1974 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
1978 Restore_Ghost_Mode (Saved_GM);
1979 end Build_DIC_Procedure_Declaration;
1981 ------------------------------------
1982 -- Build_Invariant_Procedure_Body --
1983 ------------------------------------
1985 -- WARNING: This routine manages Ghost regions. Return statements must be
1986 -- replaced by gotos which jump to the end of the routine and restore the
1989 procedure Build_Invariant_Procedure_Body
1991 Partial_Invariant : Boolean := False)
1993 Loc : constant Source_Ptr := Sloc (Typ);
1995 Pragmas_Seen : Elist_Id := No_Elist;
1996 -- This list contains all invariant pragmas processed so far. The list
1997 -- is used to avoid generating redundant invariant checks.
1999 Produced_Check : Boolean := False;
2000 -- This flag tracks whether the type has produced at least one invariant
2001 -- check. The flag is used as a sanity check at the end of the routine.
2003 -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
2004 -- intentionally unnested to avoid deep indentation of code.
2006 -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
2007 -- they emit checks, loops (for arrays) and case statements (for record
2008 -- variant parts) only when there are invariants to verify. This keeps
2009 -- the body of the invariant procedure free of useless code.
2011 procedure Add_Array_Component_Invariants
2014 Checks : in out List_Id);
2015 -- Generate an invariant check for each component of array type T.
2016 -- Obj_Id denotes the entity of the _object formal parameter of the
2017 -- invariant procedure. All created checks are added to list Checks.
2019 procedure Add_Inherited_Invariants
2021 Priv_Typ : Entity_Id;
2022 Full_Typ : Entity_Id;
2024 Checks : in out List_Id);
2025 -- Generate an invariant check for each inherited class-wide invariant
2026 -- coming from all parent types of type T. Priv_Typ and Full_Typ denote
2027 -- the partial and full view of the parent type. Obj_Id denotes the
2028 -- entity of the _object formal parameter of the invariant procedure.
2029 -- All created checks are added to list Checks.
2031 procedure Add_Interface_Invariants
2034 Checks : in out List_Id);
2035 -- Generate an invariant check for each inherited class-wide invariant
2036 -- coming from all interfaces implemented by type T. Obj_Id denotes the
2037 -- entity of the _object formal parameter of the invariant procedure.
2038 -- All created checks are added to list Checks.
2040 procedure Add_Invariant_Check
2043 Checks : in out List_Id;
2044 Inherited : Boolean := False);
2045 -- Subsidiary to all Add_xxx_Invariant routines. Add a runtime check to
2046 -- verify assertion expression Expr of pragma Prag. All generated code
2047 -- is added to list Checks. Flag Inherited should be set when the pragma
2048 -- is inherited from a parent or interface type.
2050 procedure Add_Own_Invariants
2053 Checks : in out List_Id;
2054 Priv_Item : Node_Id := Empty);
2055 -- Generate an invariant check for each invariant found for type T.
2056 -- Obj_Id denotes the entity of the _object formal parameter of the
2057 -- invariant procedure. All created checks are added to list Checks.
2058 -- Priv_Item denotes the first rep item of the private type.
2060 procedure Add_Parent_Invariants
2063 Checks : in out List_Id);
2064 -- Generate an invariant check for each inherited class-wide invariant
2065 -- coming from all parent types of type T. Obj_Id denotes the entity of
2066 -- the _object formal parameter of the invariant procedure. All created
2067 -- checks are added to list Checks.
2069 procedure Add_Record_Component_Invariants
2072 Checks : in out List_Id);
2073 -- Generate an invariant check for each component of record type T.
2074 -- Obj_Id denotes the entity of the _object formal parameter of the
2075 -- invariant procedure. All created checks are added to list Checks.
2077 ------------------------------------
2078 -- Add_Array_Component_Invariants --
2079 ------------------------------------
2081 procedure Add_Array_Component_Invariants
2084 Checks : in out List_Id)
2086 Comp_Typ : constant Entity_Id := Component_Type (T);
2087 Dims : constant Pos := Number_Dimensions (T);
2089 procedure Process_Array_Component
2091 Comp_Checks : in out List_Id);
2092 -- Generate an invariant check for an array component identified by
2093 -- the indices in list Indices. All created checks are added to list
2096 procedure Process_One_Dimension
2099 Dim_Checks : in out List_Id);
2100 -- Generate a loop over the Nth dimension Dim of an array type. List
2101 -- Indices contains all array indices for the dimension. All created
2102 -- checks are added to list Dim_Checks.
2104 -----------------------------
2105 -- Process_Array_Component --
2106 -----------------------------
2108 procedure Process_Array_Component
2110 Comp_Checks : in out List_Id)
2112 Proc_Id : Entity_Id;
2115 if Has_Invariants (Comp_Typ) then
2117 -- In GNATprove mode, the component invariants are checked by
2118 -- other means. They should not be added to the array type
2119 -- invariant procedure, so that the procedure can be used to
2120 -- check the array type invariants if any.
2122 if GNATprove_Mode then
2126 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2128 -- The component type should have an invariant procedure
2129 -- if it has invariants of its own or inherits class-wide
2130 -- invariants from parent or interface types.
2132 pragma Assert (Present (Proc_Id));
2135 -- <Comp_Typ>Invariant (_object (<Indices>));
2137 -- Note that the invariant procedure may have a null body if
2138 -- assertions are disabled or Assertion_Policy Ignore is in
2141 if not Has_Null_Body (Proc_Id) then
2142 Append_New_To (Comp_Checks,
2143 Make_Procedure_Call_Statement (Loc,
2145 New_Occurrence_Of (Proc_Id, Loc),
2146 Parameter_Associations => New_List (
2147 Make_Indexed_Component (Loc,
2148 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2149 Expressions => New_Copy_List (Indices)))));
2153 Produced_Check := True;
2155 end Process_Array_Component;
2157 ---------------------------
2158 -- Process_One_Dimension --
2159 ---------------------------
2161 procedure Process_One_Dimension
2164 Dim_Checks : in out List_Id)
2166 Comp_Checks : List_Id := No_List;
2170 -- Generate the invariant checks for the array component after all
2171 -- dimensions have produced their respective loops.
2174 Process_Array_Component
2175 (Indices => Indices,
2176 Comp_Checks => Dim_Checks);
2178 -- Otherwise create a loop for the current dimension
2181 -- Create a new loop variable for each dimension
2184 Make_Defining_Identifier (Loc,
2185 Chars => New_External_Name ('I', Dim));
2186 Append_To (Indices, New_Occurrence_Of (Index, Loc));
2188 Process_One_Dimension
2191 Dim_Checks => Comp_Checks);
2194 -- for I<Dim> in _object'Range (<Dim>) loop
2198 -- Note that the invariant procedure may have a null body if
2199 -- assertions are disabled or Assertion_Policy Ignore is in
2202 if Present (Comp_Checks) then
2203 Append_New_To (Dim_Checks,
2204 Make_Implicit_Loop_Statement (T,
2205 Identifier => Empty,
2207 Make_Iteration_Scheme (Loc,
2208 Loop_Parameter_Specification =>
2209 Make_Loop_Parameter_Specification (Loc,
2210 Defining_Identifier => Index,
2211 Discrete_Subtype_Definition =>
2212 Make_Attribute_Reference (Loc,
2214 New_Occurrence_Of (Obj_Id, Loc),
2215 Attribute_Name => Name_Range,
2216 Expressions => New_List (
2217 Make_Integer_Literal (Loc, Dim))))),
2218 Statements => Comp_Checks));
2221 end Process_One_Dimension;
2223 -- Start of processing for Add_Array_Component_Invariants
2226 Process_One_Dimension
2228 Indices => New_List,
2229 Dim_Checks => Checks);
2230 end Add_Array_Component_Invariants;
2232 ------------------------------
2233 -- Add_Inherited_Invariants --
2234 ------------------------------
2236 procedure Add_Inherited_Invariants
2238 Priv_Typ : Entity_Id;
2239 Full_Typ : Entity_Id;
2241 Checks : in out List_Id)
2243 Deriv_Typ : Entity_Id;
2246 Prag_Expr : Node_Id;
2247 Prag_Expr_Arg : Node_Id;
2249 Prag_Typ_Arg : Node_Id;
2251 Par_Proc : Entity_Id;
2252 -- The "partial" invariant procedure of Par_Typ
2254 Par_Typ : Entity_Id;
2255 -- The suitable view of the parent type used in the substitution of
2259 if not Present (Priv_Typ) and then not Present (Full_Typ) then
2263 -- When the type inheriting the class-wide invariant is a concurrent
2264 -- type, use the corresponding record type because it contains all
2265 -- primitive operations of the concurrent type and allows for proper
2268 if Is_Concurrent_Type (T) then
2269 Deriv_Typ := Corresponding_Record_Type (T);
2274 pragma Assert (Present (Deriv_Typ));
2276 -- Determine which rep item chain to use. Precedence is given to that
2277 -- of the parent type's partial view since it usually carries all the
2278 -- class-wide invariants.
2280 if Present (Priv_Typ) then
2281 Prag := First_Rep_Item (Priv_Typ);
2283 Prag := First_Rep_Item (Full_Typ);
2286 while Present (Prag) loop
2287 if Nkind (Prag) = N_Pragma
2288 and then Pragma_Name (Prag) = Name_Invariant
2290 -- Nothing to do if the pragma was already processed
2292 if Contains (Pragmas_Seen, Prag) then
2295 -- Nothing to do when the caller requests the processing of all
2296 -- inherited class-wide invariants, but the pragma does not
2297 -- fall in this category.
2299 elsif not Class_Present (Prag) then
2303 -- Extract the arguments of the invariant pragma
2305 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2306 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2307 Prag_Expr := Expression_Copy (Prag_Expr_Arg);
2308 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2310 -- The pragma applies to the partial view of the parent type
2312 if Present (Priv_Typ)
2313 and then Entity (Prag_Typ) = Priv_Typ
2315 Par_Typ := Priv_Typ;
2317 -- The pragma applies to the full view of the parent type
2319 elsif Present (Full_Typ)
2320 and then Entity (Prag_Typ) = Full_Typ
2322 Par_Typ := Full_Typ;
2324 -- Otherwise the pragma does not belong to the parent type and
2325 -- should not be considered.
2331 -- Perform the following substitutions:
2333 -- * Replace a reference to the _object parameter of the
2334 -- parent type's partial invariant procedure with a
2335 -- reference to the _object parameter of the derived
2336 -- type's full invariant procedure.
2338 -- * Replace a reference to a discriminant of the parent type
2339 -- with a suitable value from the point of view of the
2342 -- * Replace a call to an overridden parent primitive with a
2343 -- call to the overriding derived type primitive.
2345 -- * Replace a call to an inherited parent primitive with a
2346 -- call to the internally-generated inherited derived type
2349 Expr := New_Copy_Tree (Prag_Expr);
2351 -- The parent type must have a "partial" invariant procedure
2352 -- because class-wide invariants are captured exclusively by
2355 Par_Proc := Partial_Invariant_Procedure (Par_Typ);
2356 pragma Assert (Present (Par_Proc));
2361 Deriv_Typ => Deriv_Typ,
2362 Par_Obj => First_Formal (Par_Proc),
2363 Deriv_Obj => Obj_Id);
2365 Add_Invariant_Check (Prag, Expr, Checks, Inherited => True);
2368 Next_Rep_Item (Prag);
2370 end Add_Inherited_Invariants;
2372 ------------------------------
2373 -- Add_Interface_Invariants --
2374 ------------------------------
2376 procedure Add_Interface_Invariants
2379 Checks : in out List_Id)
2381 Iface_Elmt : Elmt_Id;
2385 -- Generate an invariant check for each class-wide invariant coming
2386 -- from all interfaces implemented by type T.
2388 if Is_Tagged_Type (T) then
2389 Collect_Interfaces (T, Ifaces);
2391 -- Process the class-wide invariants of all implemented interfaces
2393 Iface_Elmt := First_Elmt (Ifaces);
2394 while Present (Iface_Elmt) loop
2396 -- The Full_Typ parameter is intentionally left Empty because
2397 -- interfaces are treated as the partial view of a private type
2398 -- in order to achieve uniformity with the general case.
2400 Add_Inherited_Invariants
2402 Priv_Typ => Node (Iface_Elmt),
2407 Next_Elmt (Iface_Elmt);
2410 end Add_Interface_Invariants;
2412 -------------------------
2413 -- Add_Invariant_Check --
2414 -------------------------
2416 procedure Add_Invariant_Check
2419 Checks : in out List_Id;
2420 Inherited : Boolean := False)
2422 Args : constant List_Id := Pragma_Argument_Associations (Prag);
2423 Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
2424 Ploc : constant Source_Ptr := Sloc (Prag);
2425 Str_Arg : constant Node_Id := Next (Next (First (Args)));
2431 -- The invariant is ignored, nothing left to do
2433 if Is_Ignored (Prag) then
2436 -- Otherwise the invariant is checked. Build a pragma Check to verify
2437 -- the expression at run time.
2441 Make_Pragma_Argument_Association (Ploc,
2442 Expression => Make_Identifier (Ploc, Nam)),
2443 Make_Pragma_Argument_Association (Ploc,
2444 Expression => Expr));
2446 -- Handle the String argument (if any)
2448 if Present (Str_Arg) then
2449 Str := Strval (Get_Pragma_Arg (Str_Arg));
2451 -- When inheriting an invariant, modify the message from
2452 -- "failed invariant" to "failed inherited invariant".
2455 String_To_Name_Buffer (Str);
2457 if Name_Buffer (1 .. 16) = "failed invariant" then
2458 Insert_Str_In_Name_Buffer ("inherited ", 8);
2459 Str := String_From_Name_Buffer;
2464 Make_Pragma_Argument_Association (Ploc,
2465 Expression => Make_String_Literal (Ploc, Str)));
2469 -- pragma Check (<Nam>, <Expr>, <Str>);
2471 Append_New_To (Checks,
2473 Chars => Name_Check,
2474 Pragma_Argument_Associations => Assoc));
2477 -- Output an info message when inheriting an invariant and the
2478 -- listing option is enabled.
2480 if Inherited and Opt.List_Inherited_Aspects then
2481 Error_Msg_Sloc := Sloc (Prag);
2483 ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
2486 -- Add the pragma to the list of processed pragmas
2488 Append_New_Elmt (Prag, Pragmas_Seen);
2489 Produced_Check := True;
2490 end Add_Invariant_Check;
2492 ---------------------------
2493 -- Add_Parent_Invariants --
2494 ---------------------------
2496 procedure Add_Parent_Invariants
2499 Checks : in out List_Id)
2501 Dummy_1 : Entity_Id;
2502 Dummy_2 : Entity_Id;
2504 Curr_Typ : Entity_Id;
2505 -- The entity of the current type being examined
2507 Full_Typ : Entity_Id;
2508 -- The full view of Par_Typ
2510 Par_Typ : Entity_Id;
2511 -- The entity of the parent type
2513 Priv_Typ : Entity_Id;
2514 -- The partial view of Par_Typ
2517 -- Do not process array types because they cannot have true parent
2518 -- types. This also prevents the generation of a duplicate invariant
2519 -- check when the input type is an array base type because its Etype
2520 -- denotes the first subtype, both of which share the same component
2523 if Is_Array_Type (T) then
2527 -- Climb the parent type chain
2531 -- Do not consider subtypes as they inherit the invariants
2532 -- from their base types.
2534 Par_Typ := Base_Type (Etype (Curr_Typ));
2536 -- Stop the climb once the root of the parent chain is
2539 exit when Curr_Typ = Par_Typ;
2541 -- Process the class-wide invariants of the parent type
2543 Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
2545 -- Process the elements of an array type
2547 if Is_Array_Type (Full_Typ) then
2548 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
2550 -- Process the components of a record type
2552 elsif Ekind (Full_Typ) = E_Record_Type then
2553 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
2556 Add_Inherited_Invariants
2558 Priv_Typ => Priv_Typ,
2559 Full_Typ => Full_Typ,
2563 Curr_Typ := Par_Typ;
2565 end Add_Parent_Invariants;
2567 ------------------------
2568 -- Add_Own_Invariants --
2569 ------------------------
2571 procedure Add_Own_Invariants
2574 Checks : in out List_Id;
2575 Priv_Item : Node_Id := Empty)
2577 ASIS_Expr : Node_Id;
2581 Prag_Expr : Node_Id;
2582 Prag_Expr_Arg : Node_Id;
2584 Prag_Typ_Arg : Node_Id;
2587 if not Present (T) then
2591 Prag := First_Rep_Item (T);
2592 while Present (Prag) loop
2593 if Nkind (Prag) = N_Pragma
2594 and then Pragma_Name (Prag) = Name_Invariant
2596 -- Stop the traversal of the rep item chain once a specific
2597 -- item is encountered.
2599 if Present (Priv_Item) and then Prag = Priv_Item then
2603 -- Nothing to do if the pragma was already processed
2605 if Contains (Pragmas_Seen, Prag) then
2609 -- Extract the arguments of the invariant pragma
2611 Prag_Typ_Arg := First (Pragma_Argument_Associations (Prag));
2612 Prag_Expr_Arg := Next (Prag_Typ_Arg);
2613 Prag_Expr := Get_Pragma_Arg (Prag_Expr_Arg);
2614 Prag_Typ := Get_Pragma_Arg (Prag_Typ_Arg);
2615 Prag_Asp := Corresponding_Aspect (Prag);
2617 -- Verify the pragma belongs to T, otherwise the pragma applies
2618 -- to a parent type in which case it will be processed later by
2619 -- Add_Parent_Invariants or Add_Interface_Invariants.
2621 if Entity (Prag_Typ) /= T then
2625 Expr := New_Copy_Tree (Prag_Expr);
2627 -- Substitute all references to type T with references to the
2628 -- _object formal parameter.
2630 Replace_Type_References (Expr, T, Obj_Id);
2632 -- Preanalyze the invariant expression to detect errors and at
2633 -- the same time capture the visibility of the proper package
2636 Set_Parent (Expr, Parent (Prag_Expr));
2637 Preanalyze_Assert_Expression (Expr, Any_Boolean);
2639 -- Save a copy of the expression when T is tagged to detect
2640 -- errors and capture the visibility of the proper package part
2641 -- for the generation of inherited type invariants.
2643 if Is_Tagged_Type (T) then
2644 Set_Expression_Copy (Prag_Expr_Arg, New_Copy_Tree (Expr));
2647 -- If the pragma comes from an aspect specification, replace
2648 -- the saved expression because all type references must be
2649 -- substituted for the call to Preanalyze_Spec_Expression in
2650 -- Check_Aspect_At_xxx routines.
2652 if Present (Prag_Asp) then
2653 Set_Entity (Identifier (Prag_Asp), New_Copy_Tree (Expr));
2656 -- Analyze the original invariant expression for ASIS
2661 if Comes_From_Source (Prag) then
2662 ASIS_Expr := Prag_Expr;
2663 elsif Present (Prag_Asp) then
2664 ASIS_Expr := Expression (Prag_Asp);
2667 if Present (ASIS_Expr) then
2668 Replace_Type_References (ASIS_Expr, T, Obj_Id);
2669 Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean);
2673 Add_Invariant_Check (Prag, Expr, Checks);
2676 Next_Rep_Item (Prag);
2678 end Add_Own_Invariants;
2680 -------------------------------------
2681 -- Add_Record_Component_Invariants --
2682 -------------------------------------
2684 procedure Add_Record_Component_Invariants
2687 Checks : in out List_Id)
2689 procedure Process_Component_List
2690 (Comp_List : Node_Id;
2691 CL_Checks : in out List_Id);
2692 -- Generate invariant checks for all record components found in
2693 -- component list Comp_List, including variant parts. All created
2694 -- checks are added to list CL_Checks.
2696 procedure Process_Record_Component
2697 (Comp_Id : Entity_Id;
2698 Comp_Checks : in out List_Id);
2699 -- Generate an invariant check for a record component identified by
2700 -- Comp_Id. All created checks are added to list Comp_Checks.
2702 ----------------------------
2703 -- Process_Component_List --
2704 ----------------------------
2706 procedure Process_Component_List
2707 (Comp_List : Node_Id;
2708 CL_Checks : in out List_Id)
2712 Var_Alts : List_Id := No_List;
2713 Var_Checks : List_Id := No_List;
2714 Var_Stmts : List_Id;
2716 Produced_Variant_Check : Boolean := False;
2717 -- This flag tracks whether the component has produced at least
2718 -- one invariant check.
2721 -- Traverse the component items
2723 Comp := First (Component_Items (Comp_List));
2724 while Present (Comp) loop
2725 if Nkind (Comp) = N_Component_Declaration then
2727 -- Generate the component invariant check
2729 Process_Record_Component
2730 (Comp_Id => Defining_Entity (Comp),
2731 Comp_Checks => CL_Checks);
2737 -- Traverse the variant part
2739 if Present (Variant_Part (Comp_List)) then
2740 Var := First (Variants (Variant_Part (Comp_List)));
2741 while Present (Var) loop
2742 Var_Checks := No_List;
2744 -- Generate invariant checks for all components and variant
2745 -- parts that qualify.
2747 Process_Component_List
2748 (Comp_List => Component_List (Var),
2749 CL_Checks => Var_Checks);
2751 -- The components of the current variant produced at least
2752 -- one invariant check.
2754 if Present (Var_Checks) then
2755 Var_Stmts := Var_Checks;
2756 Produced_Variant_Check := True;
2758 -- Otherwise there are either no components with invariants,
2759 -- assertions are disabled, or Assertion_Policy Ignore is in
2763 Var_Stmts := New_List (Make_Null_Statement (Loc));
2766 Append_New_To (Var_Alts,
2767 Make_Case_Statement_Alternative (Loc,
2769 New_Copy_List (Discrete_Choices (Var)),
2770 Statements => Var_Stmts));
2775 -- Create a case statement which verifies the invariant checks
2776 -- of a particular component list depending on the discriminant
2777 -- values only when there is at least one real invariant check.
2779 if Produced_Variant_Check then
2780 Append_New_To (CL_Checks,
2781 Make_Case_Statement (Loc,
2783 Make_Selected_Component (Loc,
2784 Prefix => New_Occurrence_Of (Obj_Id, Loc),
2787 (Entity (Name (Variant_Part (Comp_List))), Loc)),
2788 Alternatives => Var_Alts));
2791 end Process_Component_List;
2793 ------------------------------
2794 -- Process_Record_Component --
2795 ------------------------------
2797 procedure Process_Record_Component
2798 (Comp_Id : Entity_Id;
2799 Comp_Checks : in out List_Id)
2801 Comp_Typ : constant Entity_Id := Etype (Comp_Id);
2802 Proc_Id : Entity_Id;
2804 Produced_Component_Check : Boolean := False;
2805 -- This flag tracks whether the component has produced at least
2806 -- one invariant check.
2809 -- Nothing to do for internal component _parent. Note that it is
2810 -- not desirable to check whether the component comes from source
2811 -- because protected type components are relocated to an internal
2812 -- corresponding record, but still need processing.
2814 if Chars (Comp_Id) = Name_uParent then
2818 -- Verify the invariant of the component. Note that an access
2819 -- type may have an invariant when it acts as the full view of a
2820 -- private type and the invariant appears on the partial view. In
2821 -- this case verify the access value itself.
2823 if Has_Invariants (Comp_Typ) then
2825 -- In GNATprove mode, the component invariants are checked by
2826 -- other means. They should not be added to the record type
2827 -- invariant procedure, so that the procedure can be used to
2828 -- check the record type invariants if any.
2830 if GNATprove_Mode then
2834 Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
2836 -- The component type should have an invariant procedure
2837 -- if it has invariants of its own or inherits class-wide
2838 -- invariants from parent or interface types.
2840 pragma Assert (Present (Proc_Id));
2843 -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
2845 -- Note that the invariant procedure may have a null body if
2846 -- assertions are disabled or Assertion_Policy Ignore is in
2849 if not Has_Null_Body (Proc_Id) then
2850 Append_New_To (Comp_Checks,
2851 Make_Procedure_Call_Statement (Loc,
2853 New_Occurrence_Of (Proc_Id, Loc),
2854 Parameter_Associations => New_List (
2855 Make_Selected_Component (Loc,
2857 Unchecked_Convert_To
2858 (T, New_Occurrence_Of (Obj_Id, Loc)),
2860 New_Occurrence_Of (Comp_Id, Loc)))));
2864 Produced_Check := True;
2865 Produced_Component_Check := True;
2868 if Produced_Component_Check and then Has_Unchecked_Union (T) then
2870 ("invariants cannot be checked on components of "
2871 & "unchecked_union type &?", Comp_Id, T);
2873 end Process_Record_Component;
2880 -- Start of processing for Add_Record_Component_Invariants
2883 -- An untagged derived type inherits the components of its parent
2884 -- type. In order to avoid creating redundant invariant checks, do
2885 -- not process the components now. Instead wait until the ultimate
2886 -- parent of the untagged derivation chain is reached.
2888 if not Is_Untagged_Derivation (T) then
2889 Def := Type_Definition (Parent (T));
2891 if Nkind (Def) = N_Derived_Type_Definition then
2892 Def := Record_Extension_Part (Def);
2895 pragma Assert (Nkind (Def) = N_Record_Definition);
2896 Comps := Component_List (Def);
2898 if Present (Comps) then
2899 Process_Component_List
2900 (Comp_List => Comps,
2901 CL_Checks => Checks);
2904 end Add_Record_Component_Invariants;
2908 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
2909 -- Save the Ghost mode to restore on exit
2912 Priv_Item : Node_Id;
2913 Proc_Body : Node_Id;
2914 Proc_Body_Id : Entity_Id;
2915 Proc_Decl : Node_Id;
2916 Proc_Id : Entity_Id;
2917 Stmts : List_Id := No_List;
2919 CRec_Typ : Entity_Id := Empty;
2920 -- The corresponding record type of Full_Typ
2922 Full_Proc : Entity_Id := Empty;
2923 -- The entity of the "full" invariant procedure
2925 Full_Typ : Entity_Id := Empty;
2926 -- The full view of the working type
2928 Obj_Id : Entity_Id := Empty;
2929 -- The _object formal parameter of the invariant procedure
2931 Part_Proc : Entity_Id := Empty;
2932 -- The entity of the "partial" invariant procedure
2934 Priv_Typ : Entity_Id := Empty;
2935 -- The partial view of the working type
2937 Work_Typ : Entity_Id := Empty;
2940 -- Start of processing for Build_Invariant_Procedure_Body
2945 -- The input type denotes the implementation base type of a constrained
2946 -- array type. Work with the first subtype as all invariant pragmas are
2947 -- on its rep item chain.
2949 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
2950 Work_Typ := First_Subtype (Work_Typ);
2952 -- The input type denotes the corresponding record type of a protected
2953 -- or task type. Work with the concurrent type because the corresponding
2954 -- record type may not be visible to clients of the type.
2956 elsif Ekind (Work_Typ) = E_Record_Type
2957 and then Is_Concurrent_Record_Type (Work_Typ)
2959 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
2962 -- The working type may be subject to pragma Ghost. Set the mode now to
2963 -- ensure that the invariant procedure is properly marked as Ghost.
2965 Set_Ghost_Mode (Work_Typ);
2967 -- The type must either have invariants of its own, inherit class-wide
2968 -- invariants from parent types or interfaces, or be an array or record
2969 -- type whose components have invariants.
2971 pragma Assert (Has_Invariants (Work_Typ));
2973 -- Interfaces are treated as the partial view of a private type in order
2974 -- to achieve uniformity with the general case.
2976 if Is_Interface (Work_Typ) then
2977 Priv_Typ := Work_Typ;
2979 -- Otherwise obtain both views of the type
2982 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
2985 -- The caller requests a body for the partial invariant procedure
2987 if Partial_Invariant then
2988 Full_Proc := Invariant_Procedure (Work_Typ);
2989 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
2991 -- The "full" invariant procedure body was already created
2993 if Present (Full_Proc)
2995 (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
2997 -- This scenario happens only when the type is an untagged
2998 -- derivation from a private parent and the underlying full
2999 -- view was processed before the partial view.
3002 (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
3004 -- Nothing to do because the processing of the underlying full
3005 -- view already checked the invariants of the partial view.
3010 -- Create a declaration for the "partial" invariant procedure if it
3011 -- is not available.
3013 if No (Proc_Id) then
3014 Build_Invariant_Procedure_Declaration
3016 Partial_Invariant => True);
3018 Proc_Id := Partial_Invariant_Procedure (Work_Typ);
3021 -- The caller requests a body for the "full" invariant procedure
3024 Proc_Id := Invariant_Procedure (Work_Typ);
3025 Part_Proc := Partial_Invariant_Procedure (Work_Typ);
3027 -- Create a declaration for the "full" invariant procedure if it is
3030 if No (Proc_Id) then
3031 Build_Invariant_Procedure_Declaration (Work_Typ);
3032 Proc_Id := Invariant_Procedure (Work_Typ);
3036 -- At this point there should be an invariant procedure declaration
3038 pragma Assert (Present (Proc_Id));
3039 Proc_Decl := Unit_Declaration_Node (Proc_Id);
3041 -- Nothing to do if the invariant procedure already has a body
3043 if Present (Corresponding_Body (Proc_Decl)) then
3047 -- Emulate the environment of the invariant procedure by installing its
3048 -- scope and formal parameters. Note that this is not needed, but having
3049 -- the scope installed helps with the detection of invariant-related
3052 Push_Scope (Proc_Id);
3053 Install_Formals (Proc_Id);
3055 Obj_Id := First_Formal (Proc_Id);
3056 pragma Assert (Present (Obj_Id));
3058 -- The "partial" invariant procedure verifies the invariants of the
3059 -- partial view only.
3061 if Partial_Invariant then
3062 pragma Assert (Present (Priv_Typ));
3069 -- Otherwise the "full" invariant procedure verifies the invariants of
3070 -- the full view, all array or record components, as well as class-wide
3071 -- invariants inherited from parent types or interfaces. In addition, it
3072 -- indirectly verifies the invariants of the partial view by calling the
3073 -- "partial" invariant procedure.
3076 pragma Assert (Present (Full_Typ));
3078 -- Check the invariants of the partial view by calling the "partial"
3079 -- invariant procedure. Generate:
3081 -- <Work_Typ>Partial_Invariant (_object);
3083 if Present (Part_Proc) then
3084 Append_New_To (Stmts,
3085 Make_Procedure_Call_Statement (Loc,
3086 Name => New_Occurrence_Of (Part_Proc, Loc),
3087 Parameter_Associations => New_List (
3088 New_Occurrence_Of (Obj_Id, Loc))));
3090 Produced_Check := True;
3095 -- Derived subtypes do not have a partial view
3097 if Present (Priv_Typ) then
3099 -- The processing of the "full" invariant procedure intentionally
3100 -- skips the partial view because a) this may result in changes of
3101 -- visibility and b) lead to duplicate checks. However, when the
3102 -- full view is the underlying full view of an untagged derived
3103 -- type whose parent type is private, partial invariants appear on
3104 -- the rep item chain of the partial view only.
3106 -- package Pack_1 is
3107 -- type Root ... is private;
3109 -- <full view of Root>
3113 -- package Pack_2 is
3114 -- type Child is new Pack_1.Root with Type_Invariant => ...;
3115 -- <underlying full view of Child>
3118 -- As a result, the processing of the full view must also consider
3119 -- all invariants of the partial view.
3121 if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
3124 -- Otherwise the invariants of the partial view are ignored
3127 -- Note that the rep item chain is shared between the partial
3128 -- and full views of a type. To avoid processing the invariants
3129 -- of the partial view, signal the logic to stop when the first
3130 -- rep item of the partial view has been reached.
3132 Priv_Item := First_Rep_Item (Priv_Typ);
3134 -- Ignore the invariants of the partial view by eliminating the
3141 -- Process the invariants of the full view and in certain cases those
3142 -- of the partial view. This also handles any invariants on array or
3143 -- record components.
3149 Priv_Item => Priv_Item);
3155 Priv_Item => Priv_Item);
3157 -- Process the elements of an array type
3159 if Is_Array_Type (Full_Typ) then
3160 Add_Array_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3162 -- Process the components of a record type
3164 elsif Ekind (Full_Typ) = E_Record_Type then
3165 Add_Record_Component_Invariants (Full_Typ, Obj_Id, Stmts);
3167 -- Process the components of a corresponding record
3169 elsif Present (CRec_Typ) then
3170 Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Stmts);
3173 -- Process the inherited class-wide invariants of all parent types.
3174 -- This also handles any invariants on record components.
3176 Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
3178 -- Process the inherited class-wide invariants of all implemented
3181 Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
3186 -- At this point there should be at least one invariant check. If this
3187 -- is not the case, then the invariant-related flags were not properly
3188 -- set, or there is a missing invariant procedure on one of the array
3189 -- or record components.
3191 pragma Assert (Produced_Check);
3193 -- Account for the case where assertions are disabled or all invariant
3194 -- checks are subject to Assertion_Policy Ignore. Produce a completing
3198 Stmts := New_List (Make_Null_Statement (Loc));
3202 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>) is
3205 -- end <Work_Typ>[Partial_]Invariant;
3208 Make_Subprogram_Body (Loc,
3210 Copy_Subprogram_Spec (Parent (Proc_Id)),
3211 Declarations => Empty_List,
3212 Handled_Statement_Sequence =>
3213 Make_Handled_Sequence_Of_Statements (Loc,
3214 Statements => Stmts));
3215 Proc_Body_Id := Defining_Entity (Proc_Body);
3217 -- Perform minor decoration in case the body is not analyzed
3219 Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
3220 Set_Etype (Proc_Body_Id, Standard_Void_Type);
3221 Set_Scope (Proc_Body_Id, Current_Scope);
3223 -- Link both spec and body to avoid generating duplicates
3225 Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
3226 Set_Corresponding_Spec (Proc_Body, Proc_Id);
3228 -- The body should not be inserted into the tree when the context is
3229 -- ASIS or a generic unit because it is not part of the template. Note
3230 -- that the body must still be generated in order to resolve the
3233 if ASIS_Mode or Inside_A_Generic then
3236 -- Semi-insert the body into the tree for GNATprove by setting its
3237 -- Parent field. This allows for proper upstream tree traversals.
3239 elsif GNATprove_Mode then
3240 Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
3242 -- Otherwise the body is part of the freezing actions of the type
3245 Append_Freeze_Action (Work_Typ, Proc_Body);
3249 Restore_Ghost_Mode (Saved_GM);
3250 end Build_Invariant_Procedure_Body;
3252 -------------------------------------------
3253 -- Build_Invariant_Procedure_Declaration --
3254 -------------------------------------------
3256 -- WARNING: This routine manages Ghost regions. Return statements must be
3257 -- replaced by gotos which jump to the end of the routine and restore the
3260 procedure Build_Invariant_Procedure_Declaration
3262 Partial_Invariant : Boolean := False)
3264 Loc : constant Source_Ptr := Sloc (Typ);
3266 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
3267 -- Save the Ghost mode to restore on exit
3269 Proc_Decl : Node_Id;
3270 Proc_Id : Entity_Id;
3274 CRec_Typ : Entity_Id;
3275 -- The corresponding record type of Full_Typ
3277 Full_Base : Entity_Id;
3278 -- The base type of Full_Typ
3280 Full_Typ : Entity_Id;
3281 -- The full view of working type
3284 -- The _object formal parameter of the invariant procedure
3286 Obj_Typ : Entity_Id;
3287 -- The type of the _object formal parameter
3289 Priv_Typ : Entity_Id;
3290 -- The partial view of working type
3292 Work_Typ : Entity_Id;
3298 -- The input type denotes the implementation base type of a constrained
3299 -- array type. Work with the first subtype as all invariant pragmas are
3300 -- on its rep item chain.
3302 if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
3303 Work_Typ := First_Subtype (Work_Typ);
3305 -- The input denotes the corresponding record type of a protected or a
3306 -- task type. Work with the concurrent type because the corresponding
3307 -- record type may not be visible to clients of the type.
3309 elsif Ekind (Work_Typ) = E_Record_Type
3310 and then Is_Concurrent_Record_Type (Work_Typ)
3312 Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
3315 -- The working type may be subject to pragma Ghost. Set the mode now to
3316 -- ensure that the invariant procedure is properly marked as Ghost.
3318 Set_Ghost_Mode (Work_Typ);
3320 -- The type must either have invariants of its own, inherit class-wide
3321 -- invariants from parent or interface types, or be an array or record
3322 -- type whose components have invariants.
3324 pragma Assert (Has_Invariants (Work_Typ));
3326 -- Nothing to do if the type already has a "partial" invariant procedure
3328 if Partial_Invariant then
3329 if Present (Partial_Invariant_Procedure (Work_Typ)) then
3333 -- Nothing to do if the type already has a "full" invariant procedure
3335 elsif Present (Invariant_Procedure (Work_Typ)) then
3339 -- The caller requests the declaration of the "partial" invariant
3342 if Partial_Invariant then
3343 Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
3345 -- Otherwise the caller requests the declaration of the "full" invariant
3349 Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
3352 Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
3354 -- Perform minor decoration in case the declaration is not analyzed
3356 Set_Ekind (Proc_Id, E_Procedure);
3357 Set_Etype (Proc_Id, Standard_Void_Type);
3358 Set_Scope (Proc_Id, Current_Scope);
3360 if Partial_Invariant then
3361 Set_Is_Partial_Invariant_Procedure (Proc_Id);
3362 Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
3364 Set_Is_Invariant_Procedure (Proc_Id);
3365 Set_Invariant_Procedure (Work_Typ, Proc_Id);
3368 -- The invariant procedure requires debug info when the invariants are
3369 -- subject to Source Coverage Obligations.
3371 if Opt.Generate_SCO then
3372 Set_Needs_Debug_Info (Proc_Id);
3375 -- Obtain all views of the input type
3377 Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
3379 -- Associate the invariant procedure with all views
3381 Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
3382 Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
3383 Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ);
3384 Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
3386 -- The declaration of the invariant procedure is inserted after the
3387 -- declaration of the partial view as this allows for proper external
3390 if Present (Priv_Typ) then
3391 Typ_Decl := Declaration_Node (Priv_Typ);
3393 -- Derived types with the full view as parent do not have a partial
3394 -- view. Insert the invariant procedure after the derived type.
3397 Typ_Decl := Declaration_Node (Full_Typ);
3400 -- The type should have a declarative node
3402 pragma Assert (Present (Typ_Decl));
3404 -- Create the formal parameter which emulates the variable-like behavior
3405 -- of the current type instance.
3407 Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
3409 -- When generating an invariant procedure declaration for an abstract
3410 -- type (including interfaces), use the class-wide type as the _object
3411 -- type. This has several desirable effects:
3413 -- * The invariant procedure does not become a primitive of the type.
3414 -- This eliminates the need to either special case the treatment of
3415 -- invariant procedures, or to make it a predefined primitive and
3416 -- force every derived type to potentially provide an empty body.
3418 -- * The invariant procedure does not need to be declared as abstract.
3419 -- This allows for a proper body, which in turn avoids redundant
3420 -- processing of the same invariants for types with multiple views.
3422 -- * The class-wide type allows for calls to abstract primitives
3423 -- within a nonabstract subprogram. The calls are treated as
3424 -- dispatching and require additional processing when they are
3425 -- remapped to call primitives of derived types. See routine
3426 -- Replace_References for details.
3428 if Is_Abstract_Type (Work_Typ) then
3429 Obj_Typ := Class_Wide_Type (Work_Typ);
3431 Obj_Typ := Work_Typ;
3434 -- Perform minor decoration in case the declaration is not analyzed
3436 Set_Ekind (Obj_Id, E_In_Parameter);
3437 Set_Etype (Obj_Id, Obj_Typ);
3438 Set_Scope (Obj_Id, Proc_Id);
3440 Set_First_Entity (Proc_Id, Obj_Id);
3443 -- procedure <Work_Typ>[Partial_]Invariant (_object : <Obj_Typ>);
3446 Make_Subprogram_Declaration (Loc,
3448 Make_Procedure_Specification (Loc,
3449 Defining_Unit_Name => Proc_Id,
3450 Parameter_Specifications => New_List (
3451 Make_Parameter_Specification (Loc,
3452 Defining_Identifier => Obj_Id,
3453 Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc)))));
3455 -- The declaration should not be inserted into the tree when the context
3456 -- is ASIS or a generic unit because it is not part of the template.
3458 if ASIS_Mode or Inside_A_Generic then
3461 -- Semi-insert the declaration into the tree for GNATprove by setting
3462 -- its Parent field. This allows for proper upstream tree traversals.
3464 elsif GNATprove_Mode then
3465 Set_Parent (Proc_Decl, Parent (Typ_Decl));
3467 -- Otherwise insert the declaration
3470 pragma Assert (Present (Typ_Decl));
3471 Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
3475 Restore_Ghost_Mode (Saved_GM);
3476 end Build_Invariant_Procedure_Declaration;
3478 --------------------------
3479 -- Build_Procedure_Form --
3480 --------------------------
3482 procedure Build_Procedure_Form (N : Node_Id) is
3483 Loc : constant Source_Ptr := Sloc (N);
3484 Subp : constant Entity_Id := Defining_Entity (N);
3486 Func_Formal : Entity_Id;
3487 Proc_Formals : List_Id;
3488 Proc_Decl : Node_Id;
3491 -- No action needed if this transformation was already done, or in case
3492 -- of subprogram renaming declarations.
3494 if Nkind (Specification (N)) = N_Procedure_Specification
3495 or else Nkind (N) = N_Subprogram_Renaming_Declaration
3500 -- Ditto when dealing with an expression function, where both the
3501 -- original expression and the generated declaration end up being
3504 if Rewritten_For_C (Subp) then
3508 Proc_Formals := New_List;
3510 -- Create a list of formal parameters with the same types as the
3513 Func_Formal := First_Formal (Subp);
3514 while Present (Func_Formal) loop
3515 Append_To (Proc_Formals,
3516 Make_Parameter_Specification (Loc,
3517 Defining_Identifier =>
3518 Make_Defining_Identifier (Loc, Chars (Func_Formal)),
3520 New_Occurrence_Of (Etype (Func_Formal), Loc)));
3522 Next_Formal (Func_Formal);
3525 -- Add an extra out parameter to carry the function result
3528 Name_Buffer (1 .. Name_Len) := "RESULT";
3529 Append_To (Proc_Formals,
3530 Make_Parameter_Specification (Loc,
3531 Defining_Identifier =>
3532 Make_Defining_Identifier (Loc, Chars => Name_Find),
3533 Out_Present => True,
3534 Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
3536 -- The new procedure declaration is inserted immediately after the
3537 -- function declaration. The processing in Build_Procedure_Body_Form
3538 -- relies on this order.
3541 Make_Subprogram_Declaration (Loc,
3543 Make_Procedure_Specification (Loc,
3544 Defining_Unit_Name =>
3545 Make_Defining_Identifier (Loc, Chars (Subp)),
3546 Parameter_Specifications => Proc_Formals));
3548 Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
3550 -- Entity of procedure must remain invisible so that it does not
3551 -- overload subsequent references to the original function.
3553 Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
3555 -- Mark the function as having a procedure form and link the function
3556 -- and its internally built procedure.
3558 Set_Rewritten_For_C (Subp);
3559 Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
3560 Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
3561 end Build_Procedure_Form;
3563 ------------------------
3564 -- Build_Runtime_Call --
3565 ------------------------
3567 function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
3569 -- If entity is not available, we can skip making the call (this avoids
3570 -- junk duplicated error messages in a number of cases).
3572 if not RTE_Available (RE) then
3573 return Make_Null_Statement (Loc);
3576 Make_Procedure_Call_Statement (Loc,
3577 Name => New_Occurrence_Of (RTE (RE), Loc));
3579 end Build_Runtime_Call;
3581 ------------------------
3582 -- Build_SS_Mark_Call --
3583 ------------------------
3585 function Build_SS_Mark_Call
3587 Mark : Entity_Id) return Node_Id
3591 -- Mark : constant Mark_Id := SS_Mark;
3594 Make_Object_Declaration (Loc,
3595 Defining_Identifier => Mark,
3596 Constant_Present => True,
3597 Object_Definition =>
3598 New_Occurrence_Of (RTE (RE_Mark_Id), Loc),
3600 Make_Function_Call (Loc,
3601 Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)));
3602 end Build_SS_Mark_Call;
3604 ---------------------------
3605 -- Build_SS_Release_Call --
3606 ---------------------------
3608 function Build_SS_Release_Call
3610 Mark : Entity_Id) return Node_Id
3614 -- SS_Release (Mark);
3617 Make_Procedure_Call_Statement (Loc,
3619 New_Occurrence_Of (RTE (RE_SS_Release), Loc),
3620 Parameter_Associations => New_List (
3621 New_Occurrence_Of (Mark, Loc)));
3622 end Build_SS_Release_Call;
3624 ----------------------------
3625 -- Build_Task_Array_Image --
3626 ----------------------------
3628 -- This function generates the body for a function that constructs the
3629 -- image string for a task that is an array component. The function is
3630 -- local to the init proc for the array type, and is called for each one
3631 -- of the components. The constructed image has the form of an indexed
3632 -- component, whose prefix is the outer variable of the array type.
3633 -- The n-dimensional array type has known indexes Index, Index2...
3635 -- Id_Ref is an indexed component form created by the enclosing init proc.
3636 -- Its successive indexes are Val1, Val2, ... which are the loop variables
3637 -- in the loops that call the individual task init proc on each component.
3639 -- The generated function has the following structure:
3641 -- function F return String is
3642 -- Pref : string renames Task_Name;
3643 -- T1 : String := Index1'Image (Val1);
3645 -- Tn : String := indexn'image (Valn);
3646 -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
3647 -- -- Len includes commas and the end parentheses.
3648 -- Res : String (1..Len);
3649 -- Pos : Integer := Pref'Length;
3652 -- Res (1 .. Pos) := Pref;
3654 -- Res (Pos) := '(';
3656 -- Res (Pos .. Pos + T1'Length - 1) := T1;
3657 -- Pos := Pos + T1'Length;
3658 -- Res (Pos) := '.';
3661 -- Res (Pos .. Pos + Tn'Length - 1) := Tn;
3662 -- Res (Len) := ')';
3667 -- Needless to say, multidimensional arrays of tasks are rare enough that
3668 -- the bulkiness of this code is not really a concern.
3670 function Build_Task_Array_Image
3674 Dyn : Boolean := False) return Node_Id
3676 Dims : constant Nat := Number_Dimensions (A_Type);
3677 -- Number of dimensions for array of tasks
3679 Temps : array (1 .. Dims) of Entity_Id;
3680 -- Array of temporaries to hold string for each index
3686 -- Total length of generated name
3689 -- Running index for substring assignments
3691 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
3692 -- Name of enclosing variable, prefix of resulting name
3695 -- String to hold result
3698 -- Value of successive indexes
3701 -- Expression to compute total size of string
3704 -- Entity for name at one index position
3706 Decls : constant List_Id := New_List;
3707 Stats : constant List_Id := New_List;
3710 -- For a dynamic task, the name comes from the target variable. For a
3711 -- static one it is a formal of the enclosing init proc.
3714 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
3716 Make_Object_Declaration (Loc,
3717 Defining_Identifier => Pref,
3718 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3720 Make_String_Literal (Loc,
3721 Strval => String_From_Name_Buffer)));
3725 Make_Object_Renaming_Declaration (Loc,
3726 Defining_Identifier => Pref,
3727 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
3728 Name => Make_Identifier (Loc, Name_uTask_Name)));
3731 Indx := First_Index (A_Type);
3732 Val := First (Expressions (Id_Ref));
3734 for J in 1 .. Dims loop
3735 T := Make_Temporary (Loc, 'T');
3739 Make_Object_Declaration (Loc,
3740 Defining_Identifier => T,
3741 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3743 Make_Attribute_Reference (Loc,
3744 Attribute_Name => Name_Image,
3745 Prefix => New_Occurrence_Of (Etype (Indx), Loc),
3746 Expressions => New_List (New_Copy_Tree (Val)))));
3752 Sum := Make_Integer_Literal (Loc, Dims + 1);
3758 Make_Attribute_Reference (Loc,
3759 Attribute_Name => Name_Length,
3760 Prefix => New_Occurrence_Of (Pref, Loc),
3761 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3763 for J in 1 .. Dims loop
3768 Make_Attribute_Reference (Loc,
3769 Attribute_Name => Name_Length,
3771 New_Occurrence_Of (Temps (J), Loc),
3772 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
3775 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
3777 Set_Character_Literal_Name (Char_Code (Character'Pos ('(')));
3780 Make_Assignment_Statement (Loc,
3782 Make_Indexed_Component (Loc,
3783 Prefix => New_Occurrence_Of (Res, Loc),
3784 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
3786 Make_Character_Literal (Loc,
3788 Char_Literal_Value => UI_From_Int (Character'Pos ('(')))));
3791 Make_Assignment_Statement (Loc,
3792 Name => New_Occurrence_Of (Pos, Loc),
3795 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3796 Right_Opnd => Make_Integer_Literal (Loc, 1))));
3798 for J in 1 .. Dims loop
3801 Make_Assignment_Statement (Loc,
3804 Prefix => New_Occurrence_Of (Res, Loc),
3807 Low_Bound => New_Occurrence_Of (Pos, Loc),
3809 Make_Op_Subtract (Loc,
3812 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3814 Make_Attribute_Reference (Loc,
3815 Attribute_Name => Name_Length,
3817 New_Occurrence_Of (Temps (J), Loc),
3819 New_List (Make_Integer_Literal (Loc, 1)))),
3820 Right_Opnd => Make_Integer_Literal (Loc, 1)))),
3822 Expression => New_Occurrence_Of (Temps (J), Loc)));
3826 Make_Assignment_Statement (Loc,
3827 Name => New_Occurrence_Of (Pos, Loc),
3830 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3832 Make_Attribute_Reference (Loc,
3833 Attribute_Name => Name_Length,
3834 Prefix => New_Occurrence_Of (Temps (J), Loc),
3836 New_List (Make_Integer_Literal (Loc, 1))))));
3838 Set_Character_Literal_Name (Char_Code (Character'Pos (',')));
3841 Make_Assignment_Statement (Loc,
3842 Name => Make_Indexed_Component (Loc,
3843 Prefix => New_Occurrence_Of (Res, Loc),
3844 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
3846 Make_Character_Literal (Loc,
3848 Char_Literal_Value => UI_From_Int (Character'Pos (',')))));
3851 Make_Assignment_Statement (Loc,
3852 Name => New_Occurrence_Of (Pos, Loc),
3855 Left_Opnd => New_Occurrence_Of (Pos, Loc),
3856 Right_Opnd => Make_Integer_Literal (Loc, 1))));
3860 Set_Character_Literal_Name (Char_Code (Character'Pos (')')));
3863 Make_Assignment_Statement (Loc,
3865 Make_Indexed_Component (Loc,
3866 Prefix => New_Occurrence_Of (Res, Loc),
3867 Expressions => New_List (New_Occurrence_Of (Len, Loc))),
3869 Make_Character_Literal (Loc,
3871 Char_Literal_Value => UI_From_Int (Character'Pos (')')))));
3872 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
3873 end Build_Task_Array_Image;
3875 ----------------------------
3876 -- Build_Task_Image_Decls --
3877 ----------------------------
3879 function Build_Task_Image_Decls
3883 In_Init_Proc : Boolean := False) return List_Id
3885 Decls : constant List_Id := New_List;
3886 T_Id : Entity_Id := Empty;
3888 Expr : Node_Id := Empty;
3889 Fun : Node_Id := Empty;
3890 Is_Dyn : constant Boolean :=
3891 Nkind (Parent (Id_Ref)) = N_Assignment_Statement
3893 Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
3896 -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
3897 -- generate a dummy declaration only.
3899 if Restriction_Active (No_Implicit_Heap_Allocations)
3900 or else Global_Discard_Names
3902 T_Id := Make_Temporary (Loc, 'J');
3907 Make_Object_Declaration (Loc,
3908 Defining_Identifier => T_Id,
3909 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3911 Make_String_Literal (Loc,
3912 Strval => String_From_Name_Buffer)));
3915 if Nkind (Id_Ref) = N_Identifier
3916 or else Nkind (Id_Ref) = N_Defining_Identifier
3918 -- For a simple variable, the image of the task is built from
3919 -- the name of the variable. To avoid possible conflict with the
3920 -- anonymous type created for a single protected object, add a
3924 Make_Defining_Identifier (Loc,
3925 New_External_Name (Chars (Id_Ref), 'T', 1));
3927 Get_Name_String (Chars (Id_Ref));
3930 Make_String_Literal (Loc,
3931 Strval => String_From_Name_Buffer);
3933 elsif Nkind (Id_Ref) = N_Selected_Component then
3935 Make_Defining_Identifier (Loc,
3936 New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
3937 Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
3939 elsif Nkind (Id_Ref) = N_Indexed_Component then
3941 Make_Defining_Identifier (Loc,
3942 New_External_Name (Chars (A_Type), 'N'));
3944 Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
3948 if Present (Fun) then
3949 Append (Fun, Decls);
3950 Expr := Make_Function_Call (Loc,
3951 Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
3953 if not In_Init_Proc then
3954 Set_Uses_Sec_Stack (Defining_Entity (Fun));
3958 Decl := Make_Object_Declaration (Loc,
3959 Defining_Identifier => T_Id,
3960 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
3961 Constant_Present => True,
3962 Expression => Expr);
3964 Append (Decl, Decls);
3966 end Build_Task_Image_Decls;
3968 -------------------------------
3969 -- Build_Task_Image_Function --
3970 -------------------------------
3972 function Build_Task_Image_Function
3976 Res : Entity_Id) return Node_Id
3982 Make_Simple_Return_Statement (Loc,
3983 Expression => New_Occurrence_Of (Res, Loc)));
3985 Spec := Make_Function_Specification (Loc,
3986 Defining_Unit_Name => Make_Temporary (Loc, 'F'),
3987 Result_Definition => New_Occurrence_Of (Standard_String, Loc));
3989 -- Calls to 'Image use the secondary stack, which must be cleaned up
3990 -- after the task name is built.
3992 return Make_Subprogram_Body (Loc,
3993 Specification => Spec,
3994 Declarations => Decls,
3995 Handled_Statement_Sequence =>
3996 Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
3997 end Build_Task_Image_Function;
3999 -----------------------------
4000 -- Build_Task_Image_Prefix --
4001 -----------------------------
4003 procedure Build_Task_Image_Prefix
4005 Len : out Entity_Id;
4006 Res : out Entity_Id;
4007 Pos : out Entity_Id;
4014 Len := Make_Temporary (Loc, 'L', Sum);
4017 Make_Object_Declaration (Loc,
4018 Defining_Identifier => Len,
4019 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
4020 Expression => Sum));
4022 Res := Make_Temporary (Loc, 'R');
4025 Make_Object_Declaration (Loc,
4026 Defining_Identifier => Res,
4027 Object_Definition =>
4028 Make_Subtype_Indication (Loc,
4029 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4031 Make_Index_Or_Discriminant_Constraint (Loc,
4035 Low_Bound => Make_Integer_Literal (Loc, 1),
4036 High_Bound => New_Occurrence_Of (Len, Loc)))))));
4038 -- Indicate that the result is an internal temporary, so it does not
4039 -- receive a bogus initialization when declaration is expanded. This
4040 -- is both efficient, and prevents anomalies in the handling of
4041 -- dynamic objects on the secondary stack.
4043 Set_Is_Internal (Res);
4044 Pos := Make_Temporary (Loc, 'P');
4047 Make_Object_Declaration (Loc,
4048 Defining_Identifier => Pos,
4049 Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
4051 -- Pos := Prefix'Length;
4054 Make_Assignment_Statement (Loc,
4055 Name => New_Occurrence_Of (Pos, Loc),
4057 Make_Attribute_Reference (Loc,
4058 Attribute_Name => Name_Length,
4059 Prefix => New_Occurrence_Of (Prefix, Loc),
4060 Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
4062 -- Res (1 .. Pos) := Prefix;
4065 Make_Assignment_Statement (Loc,
4068 Prefix => New_Occurrence_Of (Res, Loc),
4071 Low_Bound => Make_Integer_Literal (Loc, 1),
4072 High_Bound => New_Occurrence_Of (Pos, Loc))),
4074 Expression => New_Occurrence_Of (Prefix, Loc)));
4077 Make_Assignment_Statement (Loc,
4078 Name => New_Occurrence_Of (Pos, Loc),
4081 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4082 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4083 end Build_Task_Image_Prefix;
4085 -----------------------------
4086 -- Build_Task_Record_Image --
4087 -----------------------------
4089 function Build_Task_Record_Image
4092 Dyn : Boolean := False) return Node_Id
4095 -- Total length of generated name
4098 -- Index into result
4101 -- String to hold result
4103 Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
4104 -- Name of enclosing variable, prefix of resulting name
4107 -- Expression to compute total size of string
4110 -- Entity for selector name
4112 Decls : constant List_Id := New_List;
4113 Stats : constant List_Id := New_List;
4116 -- For a dynamic task, the name comes from the target variable. For a
4117 -- static one it is a formal of the enclosing init proc.
4120 Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
4122 Make_Object_Declaration (Loc,
4123 Defining_Identifier => Pref,
4124 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4126 Make_String_Literal (Loc,
4127 Strval => String_From_Name_Buffer)));
4131 Make_Object_Renaming_Declaration (Loc,
4132 Defining_Identifier => Pref,
4133 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
4134 Name => Make_Identifier (Loc, Name_uTask_Name)));
4137 Sel := Make_Temporary (Loc, 'S');
4139 Get_Name_String (Chars (Selector_Name (Id_Ref)));
4142 Make_Object_Declaration (Loc,
4143 Defining_Identifier => Sel,
4144 Object_Definition => New_Occurrence_Of (Standard_String, Loc),
4146 Make_String_Literal (Loc,
4147 Strval => String_From_Name_Buffer)));
4149 Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
4155 Make_Attribute_Reference (Loc,
4156 Attribute_Name => Name_Length,
4158 New_Occurrence_Of (Pref, Loc),
4159 Expressions => New_List (Make_Integer_Literal (Loc, 1))));
4161 Build_Task_Image_Prefix (Loc, Len, Res, Pos, Pref, Sum, Decls, Stats);
4163 Set_Character_Literal_Name (Char_Code (Character'Pos ('.')));
4165 -- Res (Pos) := '.';
4168 Make_Assignment_Statement (Loc,
4169 Name => Make_Indexed_Component (Loc,
4170 Prefix => New_Occurrence_Of (Res, Loc),
4171 Expressions => New_List (New_Occurrence_Of (Pos, Loc))),
4173 Make_Character_Literal (Loc,
4175 Char_Literal_Value =>
4176 UI_From_Int (Character'Pos ('.')))));
4179 Make_Assignment_Statement (Loc,
4180 Name => New_Occurrence_Of (Pos, Loc),
4183 Left_Opnd => New_Occurrence_Of (Pos, Loc),
4184 Right_Opnd => Make_Integer_Literal (Loc, 1))));
4186 -- Res (Pos .. Len) := Selector;
4189 Make_Assignment_Statement (Loc,
4190 Name => Make_Slice (Loc,
4191 Prefix => New_Occurrence_Of (Res, Loc),
4194 Low_Bound => New_Occurrence_Of (Pos, Loc),
4195 High_Bound => New_Occurrence_Of (Len, Loc))),
4196 Expression => New_Occurrence_Of (Sel, Loc)));
4198 return Build_Task_Image_Function (Loc, Decls, Stats, Res);
4199 end Build_Task_Record_Image;
4201 ---------------------------------------
4202 -- Build_Transient_Object_Statements --
4203 ---------------------------------------
4205 procedure Build_Transient_Object_Statements
4206 (Obj_Decl : Node_Id;
4207 Fin_Call : out Node_Id;
4208 Hook_Assign : out Node_Id;
4209 Hook_Clear : out Node_Id;
4210 Hook_Decl : out Node_Id;
4211 Ptr_Decl : out Node_Id;
4212 Finalize_Obj : Boolean := True)
4214 Loc : constant Source_Ptr := Sloc (Obj_Decl);
4215 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
4216 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
4218 Desig_Typ : Entity_Id;
4219 Hook_Expr : Node_Id;
4220 Hook_Id : Entity_Id;
4222 Ptr_Typ : Entity_Id;
4225 -- Recover the type of the object
4227 Desig_Typ := Obj_Typ;
4229 if Is_Access_Type (Desig_Typ) then
4230 Desig_Typ := Available_View (Designated_Type (Desig_Typ));
4233 -- Create an access type which provides a reference to the transient
4234 -- object. Generate:
4236 -- type Ptr_Typ is access all Desig_Typ;
4238 Ptr_Typ := Make_Temporary (Loc, 'A');
4239 Set_Ekind (Ptr_Typ, E_General_Access_Type);
4240 Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
4243 Make_Full_Type_Declaration (Loc,
4244 Defining_Identifier => Ptr_Typ,
4246 Make_Access_To_Object_Definition (Loc,
4247 All_Present => True,
4248 Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
4250 -- Create a temporary check which acts as a hook to the transient
4251 -- object. Generate:
4253 -- Hook : Ptr_Typ := null;
4255 Hook_Id := Make_Temporary (Loc, 'T');
4256 Set_Ekind (Hook_Id, E_Variable);
4257 Set_Etype (Hook_Id, Ptr_Typ);
4260 Make_Object_Declaration (Loc,
4261 Defining_Identifier => Hook_Id,
4262 Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
4263 Expression => Make_Null (Loc));
4265 -- Mark the temporary as a hook. This signals the machinery in
4266 -- Build_Finalizer to recognize this special case.
4268 Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
4270 -- Hook the transient object to the temporary. Generate:
4272 -- Hook := Ptr_Typ (Obj_Id);
4274 -- Hool := Obj_Id'Unrestricted_Access;
4276 if Is_Access_Type (Obj_Typ) then
4278 Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
4281 Make_Attribute_Reference (Loc,
4282 Prefix => New_Occurrence_Of (Obj_Id, Loc),
4283 Attribute_Name => Name_Unrestricted_Access);
4287 Make_Assignment_Statement (Loc,
4288 Name => New_Occurrence_Of (Hook_Id, Loc),
4289 Expression => Hook_Expr);
4291 -- Crear the hook prior to finalizing the object. Generate:
4296 Make_Assignment_Statement (Loc,
4297 Name => New_Occurrence_Of (Hook_Id, Loc),
4298 Expression => Make_Null (Loc));
4300 -- Finalize the object. Generate:
4302 -- [Deep_]Finalize (Obj_Ref[.all]);
4304 if Finalize_Obj then
4305 Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
4307 if Is_Access_Type (Obj_Typ) then
4308 Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
4309 Set_Etype (Obj_Ref, Desig_Typ);
4314 (Obj_Ref => Obj_Ref,
4317 -- Otherwise finalize the hook. Generate:
4319 -- [Deep_]Finalize (Hook.all);
4325 Make_Explicit_Dereference (Loc,
4326 Prefix => New_Occurrence_Of (Hook_Id, Loc)),
4329 end Build_Transient_Object_Statements;
4331 -----------------------------
4332 -- Check_Float_Op_Overflow --
4333 -----------------------------
4335 procedure Check_Float_Op_Overflow (N : Node_Id) is
4337 -- Return if no check needed
4339 if not Is_Floating_Point_Type (Etype (N))
4340 or else not (Do_Overflow_Check (N) and then Check_Float_Overflow)
4342 -- In CodePeer_Mode, rely on the overflow check flag being set instead
4343 -- and do not expand the code for float overflow checking.
4345 or else CodePeer_Mode
4350 -- Otherwise we replace the expression by
4352 -- do Tnn : constant ftype := expression;
4353 -- constraint_error when not Tnn'Valid;
4357 Loc : constant Source_Ptr := Sloc (N);
4358 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
4359 Typ : constant Entity_Id := Etype (N);
4362 -- Turn off the Do_Overflow_Check flag, since we are doing that work
4363 -- right here. We also set the node as analyzed to prevent infinite
4364 -- recursion from repeating the operation in the expansion.
4366 Set_Do_Overflow_Check (N, False);
4367 Set_Analyzed (N, True);
4369 -- Do the rewrite to include the check
4372 Make_Expression_With_Actions (Loc,
4373 Actions => New_List (
4374 Make_Object_Declaration (Loc,
4375 Defining_Identifier => Tnn,
4376 Object_Definition => New_Occurrence_Of (Typ, Loc),
4377 Constant_Present => True,
4378 Expression => Relocate_Node (N)),
4379 Make_Raise_Constraint_Error (Loc,
4383 Make_Attribute_Reference (Loc,
4384 Prefix => New_Occurrence_Of (Tnn, Loc),
4385 Attribute_Name => Name_Valid)),
4386 Reason => CE_Overflow_Check_Failed)),
4387 Expression => New_Occurrence_Of (Tnn, Loc)));
4389 Analyze_And_Resolve (N, Typ);
4391 end Check_Float_Op_Overflow;
4393 ----------------------------------
4394 -- Component_May_Be_Bit_Aligned --
4395 ----------------------------------
4397 function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
4401 -- If no component clause, then everything is fine, since the back end
4402 -- never bit-misaligns by default, even if there is a pragma Packed for
4405 if No (Comp) or else No (Component_Clause (Comp)) then
4409 UT := Underlying_Type (Etype (Comp));
4411 -- It is only array and record types that cause trouble
4413 if not Is_Record_Type (UT) and then not Is_Array_Type (UT) then
4416 -- If we know that we have a small (64 bits or less) record or small
4417 -- bit-packed array, then everything is fine, since the back end can
4418 -- handle these cases correctly.
4420 elsif Esize (Comp) <= 64
4421 and then (Is_Record_Type (UT) or else Is_Bit_Packed_Array (UT))
4425 -- Otherwise if the component is not byte aligned, we know we have the
4426 -- nasty unaligned case.
4428 elsif Normalized_First_Bit (Comp) /= Uint_0
4429 or else Esize (Comp) mod System_Storage_Unit /= Uint_0
4433 -- If we are large and byte aligned, then OK at this level
4438 end Component_May_Be_Bit_Aligned;
4440 ----------------------------------------
4441 -- Containing_Package_With_Ext_Axioms --
4442 ----------------------------------------
4444 function Containing_Package_With_Ext_Axioms
4445 (E : Entity_Id) return Entity_Id
4448 -- E is the package or generic package which is externally axiomatized
4450 if Ekind_In (E, E_Generic_Package, E_Package)
4451 and then Has_Annotate_Pragma_For_External_Axiomatization (E)
4456 -- If E's scope is axiomatized, E is axiomatized
4458 if Present (Scope (E)) then
4460 First_Ax_Parent_Scope : constant Entity_Id :=
4461 Containing_Package_With_Ext_Axioms (Scope (E));
4463 if Present (First_Ax_Parent_Scope) then
4464 return First_Ax_Parent_Scope;
4469 -- Otherwise, if E is a package instance, it is axiomatized if the
4470 -- corresponding generic package is axiomatized.
4472 if Ekind (E) = E_Package then
4474 Par : constant Node_Id := Parent (E);
4478 if Nkind (Par) = N_Defining_Program_Unit_Name then
4479 Decl := Parent (Par);
4484 if Present (Generic_Parent (Decl)) then
4486 Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
4492 end Containing_Package_With_Ext_Axioms;
4494 -------------------------------
4495 -- Convert_To_Actual_Subtype --
4496 -------------------------------
4498 procedure Convert_To_Actual_Subtype (Exp : Entity_Id) is
4502 Act_ST := Get_Actual_Subtype (Exp);
4504 if Act_ST = Etype (Exp) then
4507 Rewrite (Exp, Convert_To (Act_ST, Relocate_Node (Exp)));
4508 Analyze_And_Resolve (Exp, Act_ST);
4510 end Convert_To_Actual_Subtype;
4512 -----------------------------------
4513 -- Corresponding_Runtime_Package --
4514 -----------------------------------
4516 function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
4517 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
4518 -- Return True if protected type T has one entry and the maximum queue
4521 --------------------------------
4522 -- Has_One_Entry_And_No_Queue --
4523 --------------------------------
4525 function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
4527 Is_First : Boolean := True;
4530 Item := First_Entity (T);
4531 while Present (Item) loop
4532 if Is_Entry (Item) then
4534 -- The protected type has more than one entry
4536 if not Is_First then
4540 -- The queue length is not one
4542 if not Restriction_Active (No_Entry_Queue)
4543 and then Get_Max_Queue_Length (Item) /= Uint_1
4555 end Has_One_Entry_And_No_Queue;
4559 Pkg_Id : RTU_Id := RTU_Null;
4561 -- Start of processing for Corresponding_Runtime_Package
4564 pragma Assert (Is_Concurrent_Type (Typ));
4566 if Ekind (Typ) in Protected_Kind then
4567 if Has_Entries (Typ)
4569 -- A protected type without entries that covers an interface and
4570 -- overrides the abstract routines with protected procedures is
4571 -- considered equivalent to a protected type with entries in the
4572 -- context of dispatching select statements. It is sufficient to
4573 -- check for the presence of an interface list in the declaration
4574 -- node to recognize this case.
4576 or else Present (Interface_List (Parent (Typ)))
4578 -- Protected types with interrupt handlers (when not using a
4579 -- restricted profile) are also considered equivalent to
4580 -- protected types with entries. The types which are used
4581 -- (Static_Interrupt_Protection and Dynamic_Interrupt_Protection)
4582 -- are derived from Protection_Entries.
4584 or else (Has_Attach_Handler (Typ) and then not Restricted_Profile)
4585 or else Has_Interrupt_Handler (Typ)
4588 or else Restriction_Active (No_Select_Statements) = False
4589 or else not Has_One_Entry_And_No_Queue (Typ)
4590 or else (Has_Attach_Handler (Typ)
4591 and then not Restricted_Profile)
4593 Pkg_Id := System_Tasking_Protected_Objects_Entries;
4595 Pkg_Id := System_Tasking_Protected_Objects_Single_Entry;
4599 Pkg_Id := System_Tasking_Protected_Objects;
4604 end Corresponding_Runtime_Package;
4606 -----------------------------------
4607 -- Current_Sem_Unit_Declarations --
4608 -----------------------------------
4610 function Current_Sem_Unit_Declarations return List_Id is
4611 U : Node_Id := Unit (Cunit (Current_Sem_Unit));
4615 -- If the current unit is a package body, locate the visible
4616 -- declarations of the package spec.
4618 if Nkind (U) = N_Package_Body then
4619 U := Unit (Library_Unit (Cunit (Current_Sem_Unit)));
4622 if Nkind (U) = N_Package_Declaration then
4623 U := Specification (U);
4624 Decls := Visible_Declarations (U);
4628 Set_Visible_Declarations (U, Decls);
4632 Decls := Declarations (U);
4636 Set_Declarations (U, Decls);
4641 end Current_Sem_Unit_Declarations;
4643 -----------------------
4644 -- Duplicate_Subexpr --
4645 -----------------------
4647 function Duplicate_Subexpr
4649 Name_Req : Boolean := False;
4650 Renaming_Req : Boolean := False) return Node_Id
4653 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4654 return New_Copy_Tree (Exp);
4655 end Duplicate_Subexpr;
4657 ---------------------------------
4658 -- Duplicate_Subexpr_No_Checks --
4659 ---------------------------------
4661 function Duplicate_Subexpr_No_Checks
4663 Name_Req : Boolean := False;
4664 Renaming_Req : Boolean := False;
4665 Related_Id : Entity_Id := Empty;
4666 Is_Low_Bound : Boolean := False;
4667 Is_High_Bound : Boolean := False) return Node_Id
4674 Name_Req => Name_Req,
4675 Renaming_Req => Renaming_Req,
4676 Related_Id => Related_Id,
4677 Is_Low_Bound => Is_Low_Bound,
4678 Is_High_Bound => Is_High_Bound);
4680 New_Exp := New_Copy_Tree (Exp);
4681 Remove_Checks (New_Exp);
4683 end Duplicate_Subexpr_No_Checks;
4685 -----------------------------------
4686 -- Duplicate_Subexpr_Move_Checks --
4687 -----------------------------------
4689 function Duplicate_Subexpr_Move_Checks
4691 Name_Req : Boolean := False;
4692 Renaming_Req : Boolean := False) return Node_Id
4697 Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
4698 New_Exp := New_Copy_Tree (Exp);
4699 Remove_Checks (Exp);
4701 end Duplicate_Subexpr_Move_Checks;
4703 --------------------
4704 -- Ensure_Defined --
4705 --------------------
4707 procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id) is
4711 -- An itype reference must only be created if this is a local itype, so
4712 -- that gigi can elaborate it on the proper objstack.
4714 if Is_Itype (Typ) and then Scope (Typ) = Current_Scope then
4715 IR := Make_Itype_Reference (Sloc (N));
4716 Set_Itype (IR, Typ);
4717 Insert_Action (N, IR);
4721 --------------------
4722 -- Entry_Names_OK --
4723 --------------------
4725 function Entry_Names_OK return Boolean is
4728 not Restricted_Profile
4729 and then not Global_Discard_Names
4730 and then not Restriction_Active (No_Implicit_Heap_Allocations)
4731 and then not Restriction_Active (No_Local_Allocators);
4738 procedure Evaluate_Name (Nam : Node_Id) is
4740 -- For an attribute reference or an indexed component, evaluate the
4741 -- prefix, which is itself a name, recursively, and then force the
4742 -- evaluation of all the subscripts (or attribute expressions).
4745 when N_Attribute_Reference
4746 | N_Indexed_Component
4748 Evaluate_Name (Prefix (Nam));
4754 E := First (Expressions (Nam));
4755 while Present (E) loop
4756 Force_Evaluation (E);
4758 if Original_Node (E) /= E then
4760 (E, Do_Range_Check (Original_Node (E)));
4767 -- For an explicit dereference, we simply force the evaluation of
4768 -- the name expression. The dereference provides a value that is the
4769 -- address for the renamed object, and it is precisely this value
4770 -- that we want to preserve.
4772 when N_Explicit_Dereference =>
4773 Force_Evaluation (Prefix (Nam));
4775 -- For a function call, we evaluate the call
4777 when N_Function_Call =>
4778 Force_Evaluation (Nam);
4780 -- For a qualified expression, we evaluate the underlying object
4781 -- name if any, otherwise we force the evaluation of the underlying
4784 when N_Qualified_Expression =>
4785 if Is_Object_Reference (Expression (Nam)) then
4786 Evaluate_Name (Expression (Nam));
4788 Force_Evaluation (Expression (Nam));
4791 -- For a selected component, we simply evaluate the prefix
4793 when N_Selected_Component =>
4794 Evaluate_Name (Prefix (Nam));
4796 -- For a slice, we evaluate the prefix, as for the indexed component
4797 -- case and then, if there is a range present, either directly or as
4798 -- the constraint of a discrete subtype indication, we evaluate the
4799 -- two bounds of this range.
4802 Evaluate_Name (Prefix (Nam));
4803 Evaluate_Slice_Bounds (Nam);
4805 -- For a type conversion, the expression of the conversion must be
4806 -- the name of an object, and we simply need to evaluate this name.
4808 when N_Type_Conversion =>
4809 Evaluate_Name (Expression (Nam));
4811 -- The remaining cases are direct name, operator symbol and character
4812 -- literal. In all these cases, we do nothing, since we want to
4813 -- reevaluate each time the renamed object is used.
4820 ---------------------------
4821 -- Evaluate_Slice_Bounds --
4822 ---------------------------
4824 procedure Evaluate_Slice_Bounds (Slice : Node_Id) is
4825 DR : constant Node_Id := Discrete_Range (Slice);
4830 if Nkind (DR) = N_Range then
4831 Force_Evaluation (Low_Bound (DR));
4832 Force_Evaluation (High_Bound (DR));
4834 elsif Nkind (DR) = N_Subtype_Indication then
4835 Constr := Constraint (DR);
4837 if Nkind (Constr) = N_Range_Constraint then
4838 Rexpr := Range_Expression (Constr);
4840 Force_Evaluation (Low_Bound (Rexpr));
4841 Force_Evaluation (High_Bound (Rexpr));
4844 end Evaluate_Slice_Bounds;
4846 ---------------------
4847 -- Evolve_And_Then --
4848 ---------------------
4850 procedure Evolve_And_Then (Cond : in out Node_Id; Cond1 : Node_Id) is
4856 Make_And_Then (Sloc (Cond1),
4858 Right_Opnd => Cond1);
4860 end Evolve_And_Then;
4862 --------------------
4863 -- Evolve_Or_Else --
4864 --------------------
4866 procedure Evolve_Or_Else (Cond : in out Node_Id; Cond1 : Node_Id) is
4872 Make_Or_Else (Sloc (Cond1),
4874 Right_Opnd => Cond1);
4878 -----------------------------------
4879 -- Exceptions_In_Finalization_OK --
4880 -----------------------------------
4882 function Exceptions_In_Finalization_OK return Boolean is
4885 not (Restriction_Active (No_Exception_Handlers) or else
4886 Restriction_Active (No_Exception_Propagation) or else
4887 Restriction_Active (No_Exceptions));
4888 end Exceptions_In_Finalization_OK;
4890 -----------------------------------------
4891 -- Expand_Static_Predicates_In_Choices --
4892 -----------------------------------------
4894 procedure Expand_Static_Predicates_In_Choices (N : Node_Id) is
4895 pragma Assert (Nkind_In (N, N_Case_Statement_Alternative, N_Variant));
4897 Choices : constant List_Id := Discrete_Choices (N);
4905 Choice := First (Choices);
4906 while Present (Choice) loop
4907 Next_C := Next (Choice);
4909 -- Check for name of subtype with static predicate
4911 if Is_Entity_Name (Choice)
4912 and then Is_Type (Entity (Choice))
4913 and then Has_Predicates (Entity (Choice))
4915 -- Loop through entries in predicate list, converting to choices
4916 -- and inserting in the list before the current choice. Note that
4917 -- if the list is empty, corresponding to a False predicate, then
4918 -- no choices are inserted.
4920 P := First (Static_Discrete_Predicate (Entity (Choice)));
4921 while Present (P) loop
4923 -- If low bound and high bounds are equal, copy simple choice
4925 if Expr_Value (Low_Bound (P)) = Expr_Value (High_Bound (P)) then
4926 C := New_Copy (Low_Bound (P));
4928 -- Otherwise copy a range
4934 -- Change Sloc to referencing choice (rather than the Sloc of
4935 -- the predicate declaration element itself).
4937 Set_Sloc (C, Sloc (Choice));
4938 Insert_Before (Choice, C);
4942 -- Delete the predicated entry
4947 -- Move to next choice to check
4951 end Expand_Static_Predicates_In_Choices;
4953 ------------------------------
4954 -- Expand_Subtype_From_Expr --
4955 ------------------------------
4957 -- This function is applicable for both static and dynamic allocation of
4958 -- objects which are constrained by an initial expression. Basically it
4959 -- transforms an unconstrained subtype indication into a constrained one.
4961 -- The expression may also be transformed in certain cases in order to
4962 -- avoid multiple evaluation. In the static allocation case, the general
4967 -- is transformed into
4969 -- Val : Constrained_Subtype_of_T := Maybe_Modified_Expr;
4971 -- Here are the main cases :
4973 -- <if Expr is a Slice>
4974 -- Val : T ([Index_Subtype (Expr)]) := Expr;
4976 -- <elsif Expr is a String Literal>
4977 -- Val : T (T'First .. T'First + Length (string literal) - 1) := Expr;
4979 -- <elsif Expr is Constrained>
4980 -- subtype T is Type_Of_Expr
4983 -- <elsif Expr is an entity_name>
4984 -- Val : T (constraints taken from Expr) := Expr;
4987 -- type Axxx is access all T;
4988 -- Rval : Axxx := Expr'ref;
4989 -- Val : T (constraints taken from Rval) := Rval.all;
4991 -- ??? note: when the Expression is allocated in the secondary stack
4992 -- we could use it directly instead of copying it by declaring
4993 -- Val : T (...) renames Rval.all
4995 procedure Expand_Subtype_From_Expr
4997 Unc_Type : Entity_Id;
4998 Subtype_Indic : Node_Id;
5000 Related_Id : Entity_Id := Empty)
5002 Loc : constant Source_Ptr := Sloc (N);
5003 Exp_Typ : constant Entity_Id := Etype (Exp);
5007 -- In general we cannot build the subtype if expansion is disabled,
5008 -- because internal entities may not have been defined. However, to
5009 -- avoid some cascaded errors, we try to continue when the expression is
5010 -- an array (or string), because it is safe to compute the bounds. It is
5011 -- in fact required to do so even in a generic context, because there
5012 -- may be constants that depend on the bounds of a string literal, both
5013 -- standard string types and more generally arrays of characters.
5015 -- In GNATprove mode, these extra subtypes are not needed
5017 if GNATprove_Mode then
5021 if not Expander_Active
5022 and then (No (Etype (Exp)) or else not Is_String_Type (Etype (Exp)))
5027 if Nkind (Exp) = N_Slice then
5029 Slice_Type : constant Entity_Id := Etype (First_Index (Exp_Typ));
5032 Rewrite (Subtype_Indic,
5033 Make_Subtype_Indication (Loc,
5034 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5036 Make_Index_Or_Discriminant_Constraint (Loc,
5037 Constraints => New_List
5038 (New_Occurrence_Of (Slice_Type, Loc)))));
5040 -- This subtype indication may be used later for constraint checks
5041 -- we better make sure that if a variable was used as a bound of
5042 -- of the original slice, its value is frozen.
5044 Evaluate_Slice_Bounds (Exp);
5047 elsif Ekind (Exp_Typ) = E_String_Literal_Subtype then
5048 Rewrite (Subtype_Indic,
5049 Make_Subtype_Indication (Loc,
5050 Subtype_Mark => New_Occurrence_Of (Unc_Type, Loc),
5052 Make_Index_Or_Discriminant_Constraint (Loc,
5053 Constraints => New_List (
5054 Make_Literal_Range (Loc,
5055 Literal_Typ => Exp_Typ)))));
5057 -- If the type of the expression is an internally generated type it
5058 -- may not be necessary to create a new subtype. However there are two
5059 -- exceptions: references to the current instances, and aliased array
5060 -- object declarations for which the back end has to create a template.
5062 elsif Is_Constrained (Exp_Typ)
5063 and then not Is_Class_Wide_Type (Unc_Type)
5065 (Nkind (N) /= N_Object_Declaration
5066 or else not Is_Entity_Name (Expression (N))
5067 or else not Comes_From_Source (Entity (Expression (N)))
5068 or else not Is_Array_Type (Exp_Typ)
5069 or else not Aliased_Present (N))
5071 if Is_Itype (Exp_Typ) then
5073 -- Within an initialization procedure, a selected component
5074 -- denotes a component of the enclosing record, and it appears as
5075 -- an actual in a call to its own initialization procedure. If
5076 -- this component depends on the outer discriminant, we must
5077 -- generate the proper actual subtype for it.
5079 if Nkind (Exp) = N_Selected_Component
5080 and then Within_Init_Proc
5083 Decl : constant Node_Id :=
5084 Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
5086 if Present (Decl) then
5087 Insert_Action (N, Decl);
5088 T := Defining_Identifier (Decl);
5094 -- No need to generate a new subtype
5101 T := Make_Temporary (Loc, 'T');
5104 Make_Subtype_Declaration (Loc,
5105 Defining_Identifier => T,
5106 Subtype_Indication => New_Occurrence_Of (Exp_Typ, Loc)));
5108 -- This type is marked as an itype even though it has an explicit
5109 -- declaration since otherwise Is_Generic_Actual_Type can get
5110 -- set, resulting in the generation of spurious errors. (See
5111 -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
5114 Set_Associated_Node_For_Itype (T, Exp);
5117 Rewrite (Subtype_Indic, New_Occurrence_Of (T, Loc));
5119 -- Nothing needs to be done for private types with unknown discriminants
5120 -- if the underlying type is not an unconstrained composite type or it
5121 -- is an unchecked union.
5123 elsif Is_Private_Type (Unc_Type)
5124 and then Has_Unknown_Discriminants (Unc_Type)
5125 and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
5126 or else Is_Constrained (Underlying_Type (Unc_Type))
5127 or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
5131 -- Case of derived type with unknown discriminants where the parent type
5132 -- also has unknown discriminants.
5134 elsif Is_Record_Type (Unc_Type)
5135 and then not Is_Class_Wide_Type (Unc_Type)
5136 and then Has_Unknown_Discriminants (Unc_Type)
5137 and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
5139 -- Nothing to be done if no underlying record view available
5141 -- If this is a limited type derived from a type with unknown
5142 -- discriminants, do not expand either, so that subsequent expansion
5143 -- of the call can add build-in-place parameters to call.
5145 if No (Underlying_Record_View (Unc_Type))
5146 or else Is_Limited_Type (Unc_Type)
5150 -- Otherwise use the Underlying_Record_View to create the proper
5151 -- constrained subtype for an object of a derived type with unknown
5155 Remove_Side_Effects (Exp);
5156 Rewrite (Subtype_Indic,
5157 Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
5160 -- Renamings of class-wide interface types require no equivalent
5161 -- constrained type declarations because we only need to reference
5162 -- the tag component associated with the interface. The same is
5163 -- presumably true for class-wide types in general, so this test
5164 -- is broadened to include all class-wide renamings, which also
5165 -- avoids cases of unbounded recursion in Remove_Side_Effects.
5166 -- (Is this really correct, or are there some cases of class-wide
5167 -- renamings that require action in this procedure???)
5170 and then Nkind (N) = N_Object_Renaming_Declaration
5171 and then Is_Class_Wide_Type (Unc_Type)
5175 -- In Ada 95 nothing to be done if the type of the expression is limited
5176 -- because in this case the expression cannot be copied, and its use can
5177 -- only be by reference.
5179 -- In Ada 2005 the context can be an object declaration whose expression
5180 -- is a function that returns in place. If the nominal subtype has
5181 -- unknown discriminants, the call still provides constraints on the
5182 -- object, and we have to create an actual subtype from it.
5184 -- If the type is class-wide, the expression is dynamically tagged and
5185 -- we do not create an actual subtype either. Ditto for an interface.
5186 -- For now this applies only if the type is immutably limited, and the
5187 -- function being called is build-in-place. This will have to be revised
5188 -- when build-in-place functions are generalized to other types.
5190 elsif Is_Limited_View (Exp_Typ)
5192 (Is_Class_Wide_Type (Exp_Typ)
5193 or else Is_Interface (Exp_Typ)
5194 or else not Has_Unknown_Discriminants (Exp_Typ)
5195 or else not Is_Composite_Type (Unc_Type))
5199 -- For limited objects initialized with build in place function calls,
5200 -- nothing to be done; otherwise we prematurely introduce an N_Reference
5201 -- node in the expression initializing the object, which breaks the
5202 -- circuitry that detects and adds the additional arguments to the
5205 elsif Is_Build_In_Place_Function_Call (Exp) then
5209 Remove_Side_Effects (Exp);
5210 Rewrite (Subtype_Indic,
5211 Make_Subtype_From_Expr (Exp, Unc_Type, Related_Id));
5213 end Expand_Subtype_From_Expr;
5215 ---------------------------------------------
5216 -- Expression_Contains_Primitives_Calls_Of --
5217 ---------------------------------------------
5219 function Expression_Contains_Primitives_Calls_Of
5221 Typ : Entity_Id) return Boolean
5223 U_Typ : constant Entity_Id := Unique_Entity (Typ);
5225 Calls_OK : Boolean := False;
5226 -- This flag is set to True when expression Expr contains at least one
5227 -- call to a nondispatching primitive function of Typ.
5229 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result;
5230 -- Search for nondispatching calls to primitive functions of type Typ
5232 ----------------------------
5233 -- Search_Primitive_Calls --
5234 ----------------------------
5236 function Search_Primitive_Calls (N : Node_Id) return Traverse_Result is
5237 Disp_Typ : Entity_Id;
5241 -- Detect a function call that could denote a nondispatching
5242 -- primitive of the input type.
5244 if Nkind (N) = N_Function_Call
5245 and then Is_Entity_Name (Name (N))
5247 Subp := Entity (Name (N));
5249 -- Do not consider function calls with a controlling argument, as
5250 -- those are always dispatching calls.
5252 if Is_Dispatching_Operation (Subp)
5253 and then No (Controlling_Argument (N))
5255 Disp_Typ := Find_Dispatching_Type (Subp);
5257 -- To qualify as a suitable primitive, the dispatching type of
5258 -- the function must be the input type.
5260 if Present (Disp_Typ)
5261 and then Unique_Entity (Disp_Typ) = U_Typ
5265 -- There is no need to continue the traversal, as one such
5274 end Search_Primitive_Calls;
5276 procedure Search_Calls is new Traverse_Proc (Search_Primitive_Calls);
5278 -- Start of processing for Expression_Contains_Primitives_Calls_Of_Type
5281 Search_Calls (Expr);
5283 end Expression_Contains_Primitives_Calls_Of;
5285 ----------------------
5286 -- Finalize_Address --
5287 ----------------------
5289 function Finalize_Address (Typ : Entity_Id) return Entity_Id is
5290 Utyp : Entity_Id := Typ;
5293 -- Handle protected class-wide or task class-wide types
5295 if Is_Class_Wide_Type (Utyp) then
5296 if Is_Concurrent_Type (Root_Type (Utyp)) then
5297 Utyp := Root_Type (Utyp);
5299 elsif Is_Private_Type (Root_Type (Utyp))
5300 and then Present (Full_View (Root_Type (Utyp)))
5301 and then Is_Concurrent_Type (Full_View (Root_Type (Utyp)))
5303 Utyp := Full_View (Root_Type (Utyp));
5307 -- Handle private types
5309 if Is_Private_Type (Utyp) and then Present (Full_View (Utyp)) then
5310 Utyp := Full_View (Utyp);
5313 -- Handle protected and task types
5315 if Is_Concurrent_Type (Utyp)
5316 and then Present (Corresponding_Record_Type (Utyp))
5318 Utyp := Corresponding_Record_Type (Utyp);
5321 Utyp := Underlying_Type (Base_Type (Utyp));
5323 -- Deal with untagged derivation of private views. If the parent is
5324 -- now known to be protected, the finalization routine is the one
5325 -- defined on the corresponding record of the ancestor (corresponding
5326 -- records do not automatically inherit operations, but maybe they
5329 if Is_Untagged_Derivation (Typ) then
5330 if Is_Protected_Type (Typ) then
5331 Utyp := Corresponding_Record_Type (Root_Type (Base_Type (Typ)));
5334 Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
5336 if Is_Protected_Type (Utyp) then
5337 Utyp := Corresponding_Record_Type (Utyp);
5342 -- If the underlying_type is a subtype, we are dealing with the
5343 -- completion of a private type. We need to access the base type and
5344 -- generate a conversion to it.
5346 if Utyp /= Base_Type (Utyp) then
5347 pragma Assert (Is_Private_Type (Typ));
5349 Utyp := Base_Type (Utyp);
5352 -- When dealing with an internally built full view for a type with
5353 -- unknown discriminants, use the original record type.
5355 if Is_Underlying_Record_View (Utyp) then
5356 Utyp := Etype (Utyp);
5359 return TSS (Utyp, TSS_Finalize_Address);
5360 end Finalize_Address;
5366 function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
5367 Curr_Typ : Entity_Id;
5368 -- The current type being examined in the parent hierarchy traversal
5370 DIC_Typ : Entity_Id;
5371 -- The type which carries the DIC pragma. This variable denotes the
5372 -- partial view when private types are involved.
5374 Par_Typ : Entity_Id;
5375 -- The parent type of the current type. This variable denotes the full
5376 -- view when private types are involved.
5379 -- The input type defines its own DIC pragma, therefore it is the owner
5381 if Has_Own_DIC (Typ) then
5384 -- Otherwise the DIC pragma is inherited from a parent type
5387 pragma Assert (Has_Inherited_DIC (Typ));
5389 -- Climb the parent chain
5393 -- Inspect the parent type. Do not consider subtypes as they
5394 -- inherit the DIC attributes from their base types.
5396 DIC_Typ := Base_Type (Etype (Curr_Typ));
5398 -- Look at the full view of a private type because the type may
5399 -- have a hidden parent introduced in the full view.
5403 if Is_Private_Type (Par_Typ)
5404 and then Present (Full_View (Par_Typ))
5406 Par_Typ := Full_View (Par_Typ);
5409 -- Stop the climb once the nearest parent type which defines a DIC
5410 -- pragma of its own is encountered or when the root of the parent
5411 -- chain is reached.
5413 exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
5415 Curr_Typ := Par_Typ;
5422 ------------------------
5423 -- Find_Interface_ADT --
5424 ------------------------
5426 function Find_Interface_ADT
5428 Iface : Entity_Id) return Elmt_Id
5431 Typ : Entity_Id := T;
5434 pragma Assert (Is_Interface (Iface));
5436 -- Handle private types
5438 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5439 Typ := Full_View (Typ);
5442 -- Handle access types
5444 if Is_Access_Type (Typ) then
5445 Typ := Designated_Type (Typ);
5448 -- Handle task and protected types implementing interfaces
5450 if Is_Concurrent_Type (Typ) then
5451 Typ := Corresponding_Record_Type (Typ);
5455 (not Is_Class_Wide_Type (Typ)
5456 and then Ekind (Typ) /= E_Incomplete_Type);
5458 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5459 return First_Elmt (Access_Disp_Table (Typ));
5462 ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
5464 and then Present (Related_Type (Node (ADT)))
5465 and then Related_Type (Node (ADT)) /= Iface
5466 and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
5467 Use_Full_View => True)
5472 pragma Assert (Present (Related_Type (Node (ADT))));
5475 end Find_Interface_ADT;
5477 ------------------------
5478 -- Find_Interface_Tag --
5479 ------------------------
5481 function Find_Interface_Tag
5483 Iface : Entity_Id) return Entity_Id
5486 Found : Boolean := False;
5487 Typ : Entity_Id := T;
5489 procedure Find_Tag (Typ : Entity_Id);
5490 -- Internal subprogram used to recursively climb to the ancestors
5496 procedure Find_Tag (Typ : Entity_Id) is
5501 -- This routine does not handle the case in which the interface is an
5502 -- ancestor of Typ. That case is handled by the enclosing subprogram.
5504 pragma Assert (Typ /= Iface);
5506 -- Climb to the root type handling private types
5508 if Present (Full_View (Etype (Typ))) then
5509 if Full_View (Etype (Typ)) /= Typ then
5510 Find_Tag (Full_View (Etype (Typ)));
5513 elsif Etype (Typ) /= Typ then
5514 Find_Tag (Etype (Typ));
5517 -- Traverse the list of interfaces implemented by the type
5520 and then Present (Interfaces (Typ))
5521 and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
5523 -- Skip the tag associated with the primary table
5525 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
5526 AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
5527 pragma Assert (Present (AI_Tag));
5529 AI_Elmt := First_Elmt (Interfaces (Typ));
5530 while Present (AI_Elmt) loop
5531 AI := Node (AI_Elmt);
5534 or else Is_Ancestor (Iface, AI, Use_Full_View => True)
5540 AI_Tag := Next_Tag_Component (AI_Tag);
5541 Next_Elmt (AI_Elmt);
5546 -- Start of processing for Find_Interface_Tag
5549 pragma Assert (Is_Interface (Iface));
5551 -- Handle access types
5553 if Is_Access_Type (Typ) then
5554 Typ := Designated_Type (Typ);
5557 -- Handle class-wide types
5559 if Is_Class_Wide_Type (Typ) then
5560 Typ := Root_Type (Typ);
5563 -- Handle private types
5565 if Has_Private_Declaration (Typ) and then Present (Full_View (Typ)) then
5566 Typ := Full_View (Typ);
5569 -- Handle entities from the limited view
5571 if Ekind (Typ) = E_Incomplete_Type then
5572 pragma Assert (Present (Non_Limited_View (Typ)));
5573 Typ := Non_Limited_View (Typ);
5576 -- Handle task and protected types implementing interfaces
5578 if Is_Concurrent_Type (Typ) then
5579 Typ := Corresponding_Record_Type (Typ);
5582 -- If the interface is an ancestor of the type, then it shared the
5583 -- primary dispatch table.
5585 if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
5586 pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
5587 return First_Tag_Component (Typ);
5589 -- Otherwise we need to search for its associated tag component
5593 pragma Assert (Found);
5596 end Find_Interface_Tag;
5598 ---------------------------
5599 -- Find_Optional_Prim_Op --
5600 ---------------------------
5602 function Find_Optional_Prim_Op
5603 (T : Entity_Id; Name : Name_Id) return Entity_Id
5606 Typ : Entity_Id := T;
5610 if Is_Class_Wide_Type (Typ) then
5611 Typ := Root_Type (Typ);
5614 Typ := Underlying_Type (Typ);
5616 -- Loop through primitive operations
5618 Prim := First_Elmt (Primitive_Operations (Typ));
5619 while Present (Prim) loop
5622 -- We can retrieve primitive operations by name if it is an internal
5623 -- name. For equality we must check that both of its operands have
5624 -- the same type, to avoid confusion with user-defined equalities
5625 -- than may have a non-symmetric signature.
5627 exit when Chars (Op) = Name
5630 or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
5635 return Node (Prim); -- Empty if not found
5636 end Find_Optional_Prim_Op;
5638 ---------------------------
5639 -- Find_Optional_Prim_Op --
5640 ---------------------------
5642 function Find_Optional_Prim_Op
5644 Name : TSS_Name_Type) return Entity_Id
5646 Inher_Op : Entity_Id := Empty;
5647 Own_Op : Entity_Id := Empty;
5648 Prim_Elmt : Elmt_Id;
5649 Prim_Id : Entity_Id;
5650 Typ : Entity_Id := T;
5653 if Is_Class_Wide_Type (Typ) then
5654 Typ := Root_Type (Typ);
5657 Typ := Underlying_Type (Typ);
5659 -- This search is based on the assertion that the dispatching version
5660 -- of the TSS routine always precedes the real primitive.
5662 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
5663 while Present (Prim_Elmt) loop
5664 Prim_Id := Node (Prim_Elmt);
5666 if Is_TSS (Prim_Id, Name) then
5667 if Present (Alias (Prim_Id)) then
5668 Inher_Op := Prim_Id;
5674 Next_Elmt (Prim_Elmt);
5677 if Present (Own_Op) then
5679 elsif Present (Inher_Op) then
5684 end Find_Optional_Prim_Op;
5690 function Find_Prim_Op
5691 (T : Entity_Id; Name : Name_Id) return Entity_Id
5693 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5696 raise Program_Error;
5706 function Find_Prim_Op
5708 Name : TSS_Name_Type) return Entity_Id
5710 Result : constant Entity_Id := Find_Optional_Prim_Op (T, Name);
5713 raise Program_Error;
5719 ----------------------------
5720 -- Find_Protection_Object --
5721 ----------------------------
5723 function Find_Protection_Object (Scop : Entity_Id) return Entity_Id is
5728 while Present (S) loop
5729 if Ekind_In (S, E_Entry, E_Entry_Family, E_Function, E_Procedure)
5730 and then Present (Protection_Object (S))
5732 return Protection_Object (S);
5738 -- If we do not find a Protection object in the scope chain, then
5739 -- something has gone wrong, most likely the object was never created.
5741 raise Program_Error;
5742 end Find_Protection_Object;
5744 --------------------------
5745 -- Find_Protection_Type --
5746 --------------------------
5748 function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
5750 Typ : Entity_Id := Conc_Typ;
5753 if Is_Concurrent_Type (Typ) then
5754 Typ := Corresponding_Record_Type (Typ);
5757 -- Since restriction violations are not considered serious errors, the
5758 -- expander remains active, but may leave the corresponding record type
5759 -- malformed. In such cases, component _object is not available so do
5762 if not Analyzed (Typ) then
5766 Comp := First_Component (Typ);
5767 while Present (Comp) loop
5768 if Chars (Comp) = Name_uObject then
5769 return Base_Type (Etype (Comp));
5772 Next_Component (Comp);
5775 -- The corresponding record of a protected type should always have an
5778 raise Program_Error;
5779 end Find_Protection_Type;
5781 -----------------------
5782 -- Find_Hook_Context --
5783 -----------------------
5785 function Find_Hook_Context (N : Node_Id) return Node_Id is
5789 Wrapped_Node : Node_Id;
5790 -- Note: if we are in a transient scope, we want to reuse it as
5791 -- the context for actions insertion, if possible. But if N is itself
5792 -- part of the stored actions for the current transient scope,
5793 -- then we need to insert at the appropriate (inner) location in
5794 -- the not as an action on Node_To_Be_Wrapped.
5796 In_Cond_Expr : constant Boolean := Within_Case_Or_If_Expression (N);
5799 -- When the node is inside a case/if expression, the lifetime of any
5800 -- temporary controlled object is extended. Find a suitable insertion
5801 -- node by locating the topmost case or if expressions.
5803 if In_Cond_Expr then
5806 while Present (Par) loop
5807 if Nkind_In (Original_Node (Par), N_Case_Expression,
5812 -- Prevent the search from going too far
5814 elsif Is_Body_Or_Package_Declaration (Par) then
5818 Par := Parent (Par);
5821 -- The topmost case or if expression is now recovered, but it may
5822 -- still not be the correct place to add generated code. Climb to
5823 -- find a parent that is part of a declarative or statement list,
5824 -- and is not a list of actuals in a call.
5827 while Present (Par) loop
5828 if Is_List_Member (Par)
5829 and then not Nkind_In (Par, N_Component_Association,
5830 N_Discriminant_Association,
5831 N_Parameter_Association,
5832 N_Pragma_Argument_Association)
5833 and then not Nkind_In (Parent (Par), N_Function_Call,
5834 N_Procedure_Call_Statement,
5835 N_Entry_Call_Statement)
5840 -- Prevent the search from going too far
5842 elsif Is_Body_Or_Package_Declaration (Par) then
5846 Par := Parent (Par);
5853 while Present (Par) loop
5855 -- Keep climbing past various operators
5857 if Nkind (Parent (Par)) in N_Op
5858 or else Nkind_In (Parent (Par), N_And_Then, N_Or_Else)
5860 Par := Parent (Par);
5868 -- The node may be located in a pragma in which case return the
5871 -- pragma Precondition (... and then Ctrl_Func_Call ...);
5873 -- Similar case occurs when the node is related to an object
5874 -- declaration or assignment:
5876 -- Obj [: Some_Typ] := ... and then Ctrl_Func_Call ...;
5878 -- Another case to consider is when the node is part of a return
5881 -- return ... and then Ctrl_Func_Call ...;
5883 -- Another case is when the node acts as a formal in a procedure
5886 -- Proc (... and then Ctrl_Func_Call ...);
5888 if Scope_Is_Transient then
5889 Wrapped_Node := Node_To_Be_Wrapped;
5891 Wrapped_Node := Empty;
5894 while Present (Par) loop
5895 if Par = Wrapped_Node
5896 or else Nkind_In (Par, N_Assignment_Statement,
5897 N_Object_Declaration,
5899 N_Procedure_Call_Statement,
5900 N_Simple_Return_Statement)
5904 -- Prevent the search from going too far
5906 elsif Is_Body_Or_Package_Declaration (Par) then
5910 Par := Parent (Par);
5913 -- Return the topmost short circuit operator
5917 end Find_Hook_Context;
5919 ------------------------------
5920 -- Following_Address_Clause --
5921 ------------------------------
5923 function Following_Address_Clause (D : Node_Id) return Node_Id is
5924 Id : constant Entity_Id := Defining_Identifier (D);
5928 function Check_Decls (D : Node_Id) return Node_Id;
5929 -- This internal function differs from the main function in that it
5930 -- gets called to deal with a following package private part, and
5931 -- it checks declarations starting with D (the main function checks
5932 -- declarations following D). If D is Empty, then Empty is returned.
5938 function Check_Decls (D : Node_Id) return Node_Id is
5943 while Present (Decl) loop
5944 if Nkind (Decl) = N_At_Clause
5945 and then Chars (Identifier (Decl)) = Chars (Id)
5949 elsif Nkind (Decl) = N_Attribute_Definition_Clause
5950 and then Chars (Decl) = Name_Address
5951 and then Chars (Name (Decl)) = Chars (Id)
5959 -- Otherwise not found, return Empty
5964 -- Start of processing for Following_Address_Clause
5967 -- If parser detected no address clause for the identifier in question,
5968 -- then the answer is a quick NO, without the need for a search.
5970 if not Get_Name_Table_Boolean1 (Chars (Id)) then
5974 -- Otherwise search current declarative unit
5976 Result := Check_Decls (Next (D));
5978 if Present (Result) then
5982 -- Check for possible package private part following
5986 if Nkind (Par) = N_Package_Specification
5987 and then Visible_Declarations (Par) = List_Containing (D)
5988 and then Present (Private_Declarations (Par))
5990 -- Private part present, check declarations there
5992 return Check_Decls (First (Private_Declarations (Par)));
5995 -- No private part, clause not found, return Empty
5999 end Following_Address_Clause;
6001 ----------------------
6002 -- Force_Evaluation --
6003 ----------------------
6005 procedure Force_Evaluation
6007 Name_Req : Boolean := False;
6008 Related_Id : Entity_Id := Empty;
6009 Is_Low_Bound : Boolean := False;
6010 Is_High_Bound : Boolean := False;
6011 Mode : Force_Evaluation_Mode := Relaxed)
6016 Name_Req => Name_Req,
6017 Variable_Ref => True,
6018 Renaming_Req => False,
6019 Related_Id => Related_Id,
6020 Is_Low_Bound => Is_Low_Bound,
6021 Is_High_Bound => Is_High_Bound,
6022 Check_Side_Effects =>
6023 Is_Static_Expression (Exp)
6024 or else Mode = Relaxed);
6025 end Force_Evaluation;
6027 ---------------------------------
6028 -- Fully_Qualified_Name_String --
6029 ---------------------------------
6031 function Fully_Qualified_Name_String
6033 Append_NUL : Boolean := True) return String_Id
6035 procedure Internal_Full_Qualified_Name (E : Entity_Id);
6036 -- Compute recursively the qualified name without NUL at the end, adding
6037 -- it to the currently started string being generated
6039 ----------------------------------
6040 -- Internal_Full_Qualified_Name --
6041 ----------------------------------
6043 procedure Internal_Full_Qualified_Name (E : Entity_Id) is
6047 -- Deal properly with child units
6049 if Nkind (E) = N_Defining_Program_Unit_Name then
6050 Ent := Defining_Identifier (E);
6055 -- Compute qualification recursively (only "Standard" has no scope)
6057 if Present (Scope (Scope (Ent))) then
6058 Internal_Full_Qualified_Name (Scope (Ent));
6059 Store_String_Char (Get_Char_Code ('.'));
6062 -- Every entity should have a name except some expanded blocks
6063 -- don't bother about those.
6065 if Chars (Ent) = No_Name then
6069 -- Generates the entity name in upper case
6071 Get_Decoded_Name_String (Chars (Ent));
6073 Store_String_Chars (Name_Buffer (1 .. Name_Len));
6075 end Internal_Full_Qualified_Name;
6077 -- Start of processing for Full_Qualified_Name
6081 Internal_Full_Qualified_Name (E);
6084 Store_String_Char (Get_Char_Code (ASCII.NUL));
6088 end Fully_Qualified_Name_String;
6090 ------------------------
6091 -- Generate_Poll_Call --
6092 ------------------------
6094 procedure Generate_Poll_Call (N : Node_Id) is
6096 -- No poll call if polling not active
6098 if not Polling_Required then
6101 -- Otherwise generate require poll call
6104 Insert_Before_And_Analyze (N,
6105 Make_Procedure_Call_Statement (Sloc (N),
6106 Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
6108 end Generate_Poll_Call;
6110 ---------------------------------
6111 -- Get_Current_Value_Condition --
6112 ---------------------------------
6114 -- Note: the implementation of this procedure is very closely tied to the
6115 -- implementation of Set_Current_Value_Condition. In the Get procedure, we
6116 -- interpret Current_Value fields set by the Set procedure, so the two
6117 -- procedures need to be closely coordinated.
6119 procedure Get_Current_Value_Condition
6124 Loc : constant Source_Ptr := Sloc (Var);
6125 Ent : constant Entity_Id := Entity (Var);
6127 procedure Process_Current_Value_Condition
6130 -- N is an expression which holds either True (S = True) or False (S =
6131 -- False) in the condition. This procedure digs out the expression and
6132 -- if it refers to Ent, sets Op and Val appropriately.
6134 -------------------------------------
6135 -- Process_Current_Value_Condition --
6136 -------------------------------------
6138 procedure Process_Current_Value_Condition
6143 Prev_Cond : Node_Id;
6153 -- Deal with NOT operators, inverting sense
6155 while Nkind (Cond) = N_Op_Not loop
6156 Cond := Right_Opnd (Cond);
6160 -- Deal with conversions, qualifications, and expressions with
6163 while Nkind_In (Cond,
6165 N_Qualified_Expression,
6166 N_Expression_With_Actions)
6168 Cond := Expression (Cond);
6171 exit when Cond = Prev_Cond;
6174 -- Deal with AND THEN and AND cases
6176 if Nkind_In (Cond, N_And_Then, N_Op_And) then
6178 -- Don't ever try to invert a condition that is of the form of an
6179 -- AND or AND THEN (since we are not doing sufficiently general
6180 -- processing to allow this).
6182 if Sens = False then
6188 -- Recursively process AND and AND THEN branches
6190 Process_Current_Value_Condition (Left_Opnd (Cond), True);
6192 if Op /= N_Empty then
6196 Process_Current_Value_Condition (Right_Opnd (Cond), True);
6199 -- Case of relational operator
6201 elsif Nkind (Cond) in N_Op_Compare then
6204 -- Invert sense of test if inverted test
6206 if Sens = False then
6208 when N_Op_Eq => Op := N_Op_Ne;
6209 when N_Op_Ne => Op := N_Op_Eq;
6210 when N_Op_Lt => Op := N_Op_Ge;
6211 when N_Op_Gt => Op := N_Op_Le;
6212 when N_Op_Le => Op := N_Op_Gt;
6213 when N_Op_Ge => Op := N_Op_Lt;
6214 when others => raise Program_Error;
6218 -- Case of entity op value
6220 if Is_Entity_Name (Left_Opnd (Cond))
6221 and then Ent = Entity (Left_Opnd (Cond))
6222 and then Compile_Time_Known_Value (Right_Opnd (Cond))
6224 Val := Right_Opnd (Cond);
6226 -- Case of value op entity
6228 elsif Is_Entity_Name (Right_Opnd (Cond))
6229 and then Ent = Entity (Right_Opnd (Cond))
6230 and then Compile_Time_Known_Value (Left_Opnd (Cond))
6232 Val := Left_Opnd (Cond);
6234 -- We are effectively swapping operands
6237 when N_Op_Eq => null;
6238 when N_Op_Ne => null;
6239 when N_Op_Lt => Op := N_Op_Gt;
6240 when N_Op_Gt => Op := N_Op_Lt;
6241 when N_Op_Le => Op := N_Op_Ge;
6242 when N_Op_Ge => Op := N_Op_Le;
6243 when others => raise Program_Error;
6252 elsif Nkind_In (Cond,
6254 N_Qualified_Expression,
6255 N_Expression_With_Actions)
6257 Cond := Expression (Cond);
6259 -- Case of Boolean variable reference, return as though the
6260 -- reference had said var = True.
6263 if Is_Entity_Name (Cond) and then Ent = Entity (Cond) then
6264 Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
6266 if Sens = False then
6273 end Process_Current_Value_Condition;
6275 -- Start of processing for Get_Current_Value_Condition
6281 -- Immediate return, nothing doing, if this is not an object
6283 if Ekind (Ent) not in Object_Kind then
6287 -- Otherwise examine current value
6290 CV : constant Node_Id := Current_Value (Ent);
6295 -- If statement. Condition is known true in THEN section, known False
6296 -- in any ELSIF or ELSE part, and unknown outside the IF statement.
6298 if Nkind (CV) = N_If_Statement then
6300 -- Before start of IF statement
6302 if Loc < Sloc (CV) then
6305 -- After end of IF statement
6307 elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
6311 -- At this stage we know that we are within the IF statement, but
6312 -- unfortunately, the tree does not record the SLOC of the ELSE so
6313 -- we cannot use a simple SLOC comparison to distinguish between
6314 -- the then/else statements, so we have to climb the tree.
6321 while Parent (N) /= CV loop
6324 -- If we fall off the top of the tree, then that's odd, but
6325 -- perhaps it could occur in some error situation, and the
6326 -- safest response is simply to assume that the outcome of
6327 -- the condition is unknown. No point in bombing during an
6328 -- attempt to optimize things.
6335 -- Now we have N pointing to a node whose parent is the IF
6336 -- statement in question, so now we can tell if we are within
6337 -- the THEN statements.
6339 if Is_List_Member (N)
6340 and then List_Containing (N) = Then_Statements (CV)
6344 -- If the variable reference does not come from source, we
6345 -- cannot reliably tell whether it appears in the else part.
6346 -- In particular, if it appears in generated code for a node
6347 -- that requires finalization, it may be attached to a list
6348 -- that has not been yet inserted into the code. For now,
6349 -- treat it as unknown.
6351 elsif not Comes_From_Source (N) then
6354 -- Otherwise we must be in ELSIF or ELSE part
6361 -- ELSIF part. Condition is known true within the referenced
6362 -- ELSIF, known False in any subsequent ELSIF or ELSE part,
6363 -- and unknown before the ELSE part or after the IF statement.
6365 elsif Nkind (CV) = N_Elsif_Part then
6367 -- if the Elsif_Part had condition_actions, the elsif has been
6368 -- rewritten as a nested if, and the original elsif_part is
6369 -- detached from the tree, so there is no way to obtain useful
6370 -- information on the current value of the variable.
6371 -- Can this be improved ???
6373 if No (Parent (CV)) then
6379 -- If the tree has been otherwise rewritten there is nothing
6380 -- else to be done either.
6382 if Nkind (Stm) /= N_If_Statement then
6386 -- Before start of ELSIF part
6388 if Loc < Sloc (CV) then
6391 -- After end of IF statement
6393 elsif Loc >= Sloc (Stm) +
6394 Text_Ptr (UI_To_Int (End_Span (Stm)))
6399 -- Again we lack the SLOC of the ELSE, so we need to climb the
6400 -- tree to see if we are within the ELSIF part in question.
6407 while Parent (N) /= Stm loop
6410 -- If we fall off the top of the tree, then that's odd, but
6411 -- perhaps it could occur in some error situation, and the
6412 -- safest response is simply to assume that the outcome of
6413 -- the condition is unknown. No point in bombing during an
6414 -- attempt to optimize things.
6421 -- Now we have N pointing to a node whose parent is the IF
6422 -- statement in question, so see if is the ELSIF part we want.
6423 -- the THEN statements.
6428 -- Otherwise we must be in subsequent ELSIF or ELSE part
6435 -- Iteration scheme of while loop. The condition is known to be
6436 -- true within the body of the loop.
6438 elsif Nkind (CV) = N_Iteration_Scheme then
6440 Loop_Stmt : constant Node_Id := Parent (CV);
6443 -- Before start of body of loop
6445 if Loc < Sloc (Loop_Stmt) then
6448 -- After end of LOOP statement
6450 elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
6453 -- We are within the body of the loop
6460 -- All other cases of Current_Value settings
6466 -- If we fall through here, then we have a reportable condition, Sens
6467 -- is True if the condition is true and False if it needs inverting.
6469 Process_Current_Value_Condition (Condition (CV), Sens);
6471 end Get_Current_Value_Condition;
6473 ---------------------
6474 -- Get_Stream_Size --
6475 ---------------------
6477 function Get_Stream_Size (E : Entity_Id) return Uint is
6479 -- If we have a Stream_Size clause for this type use it
6481 if Has_Stream_Size_Clause (E) then
6482 return Static_Integer (Expression (Stream_Size_Clause (E)));
6484 -- Otherwise the Stream_Size if the size of the type
6489 end Get_Stream_Size;
6491 ---------------------------
6492 -- Has_Access_Constraint --
6493 ---------------------------
6495 function Has_Access_Constraint (E : Entity_Id) return Boolean is
6497 T : constant Entity_Id := Etype (E);
6500 if Has_Per_Object_Constraint (E) and then Has_Discriminants (T) then
6501 Disc := First_Discriminant (T);
6502 while Present (Disc) loop
6503 if Is_Access_Type (Etype (Disc)) then
6507 Next_Discriminant (Disc);
6514 end Has_Access_Constraint;
6516 -----------------------------------------------------
6517 -- Has_Annotate_Pragma_For_External_Axiomatization --
6518 -----------------------------------------------------
6520 function Has_Annotate_Pragma_For_External_Axiomatization
6521 (E : Entity_Id) return Boolean
6523 function Is_Annotate_Pragma_For_External_Axiomatization
6524 (N : Node_Id) return Boolean;
6525 -- Returns whether N is
6526 -- pragma Annotate (GNATprove, External_Axiomatization);
6528 ----------------------------------------------------
6529 -- Is_Annotate_Pragma_For_External_Axiomatization --
6530 ----------------------------------------------------
6532 -- The general form of pragma Annotate is
6534 -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]);
6535 -- ARG ::= NAME | EXPRESSION
6537 -- The first two arguments are by convention intended to refer to an
6538 -- external tool and a tool-specific function. These arguments are
6541 -- The following is used to annotate a package specification which
6542 -- GNATprove should treat specially, because the axiomatization of
6543 -- this unit is given by the user instead of being automatically
6546 -- pragma Annotate (GNATprove, External_Axiomatization);
6548 function Is_Annotate_Pragma_For_External_Axiomatization
6549 (N : Node_Id) return Boolean
6551 Name_GNATprove : constant String :=
6553 Name_External_Axiomatization : constant String :=
6554 "external_axiomatization";
6558 if Nkind (N) = N_Pragma
6559 and then Get_Pragma_Id (N) = Pragma_Annotate
6560 and then List_Length (Pragma_Argument_Associations (N)) = 2
6563 Arg1 : constant Node_Id :=
6564 First (Pragma_Argument_Associations (N));
6565 Arg2 : constant Node_Id := Next (Arg1);
6570 -- Fill in Name_Buffer with Name_GNATprove first, and then with
6571 -- Name_External_Axiomatization so that Name_Find returns the
6572 -- corresponding name. This takes care of all possible casings.
6575 Add_Str_To_Name_Buffer (Name_GNATprove);
6579 Add_Str_To_Name_Buffer (Name_External_Axiomatization);
6582 return Chars (Get_Pragma_Arg (Arg1)) = Nam1
6584 Chars (Get_Pragma_Arg (Arg2)) = Nam2;
6590 end Is_Annotate_Pragma_For_External_Axiomatization;
6595 Vis_Decls : List_Id;
6598 -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization
6601 if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
6602 Decl := Parent (Parent (E));
6607 Vis_Decls := Visible_Declarations (Decl);
6609 N := First (Vis_Decls);
6610 while Present (N) loop
6612 -- Skip declarations generated by the frontend. Skip all pragmas
6613 -- that are not the desired Annotate pragma. Stop the search on
6614 -- the first non-pragma source declaration.
6616 if Comes_From_Source (N) then
6617 if Nkind (N) = N_Pragma then
6618 if Is_Annotate_Pragma_For_External_Axiomatization (N) then
6630 end Has_Annotate_Pragma_For_External_Axiomatization;
6632 --------------------
6633 -- Homonym_Number --
6634 --------------------
6636 function Homonym_Number (Subp : Entity_Id) return Nat is
6642 Hom := Homonym (Subp);
6643 while Present (Hom) loop
6644 if Scope (Hom) = Scope (Subp) then
6648 Hom := Homonym (Hom);
6654 -----------------------------------
6655 -- In_Library_Level_Package_Body --
6656 -----------------------------------
6658 function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
6660 -- First determine whether the entity appears at the library level, then
6661 -- look at the containing unit.
6663 if Is_Library_Level_Entity (Id) then
6665 Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
6668 return Nkind (Unit (Container)) = N_Package_Body;
6673 end In_Library_Level_Package_Body;
6675 ------------------------------
6676 -- In_Unconditional_Context --
6677 ------------------------------
6679 function In_Unconditional_Context (Node : Node_Id) return Boolean is
6684 while Present (P) loop
6686 when N_Subprogram_Body => return True;
6687 when N_If_Statement => return False;
6688 when N_Loop_Statement => return False;
6689 when N_Case_Statement => return False;
6690 when others => P := Parent (P);
6695 end In_Unconditional_Context;
6701 procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
6703 if Present (Ins_Action) then
6704 Insert_Actions (Assoc_Node, New_List (Ins_Action));
6708 -- Version with check(s) suppressed
6710 procedure Insert_Action
6711 (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
6714 Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
6717 -------------------------
6718 -- Insert_Action_After --
6719 -------------------------
6721 procedure Insert_Action_After
6722 (Assoc_Node : Node_Id;
6723 Ins_Action : Node_Id)
6726 Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
6727 end Insert_Action_After;
6729 --------------------
6730 -- Insert_Actions --
6731 --------------------
6733 procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
6737 Wrapped_Node : Node_Id := Empty;
6740 if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
6744 -- Ignore insert of actions from inside default expression (or other
6745 -- similar "spec expression") in the special spec-expression analyze
6746 -- mode. Any insertions at this point have no relevance, since we are
6747 -- only doing the analyze to freeze the types of any static expressions.
6748 -- See section "Handling of Default Expressions" in the spec of package
6749 -- Sem for further details.
6751 if In_Spec_Expression then
6755 -- If the action derives from stuff inside a record, then the actions
6756 -- are attached to the current scope, to be inserted and analyzed on
6757 -- exit from the scope. The reason for this is that we may also be
6758 -- generating freeze actions at the same time, and they must eventually
6759 -- be elaborated in the correct order.
6761 if Is_Record_Type (Current_Scope)
6762 and then not Is_Frozen (Current_Scope)
6764 if No (Scope_Stack.Table
6765 (Scope_Stack.Last).Pending_Freeze_Actions)
6767 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions :=
6772 Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions);
6778 -- We now intend to climb up the tree to find the right point to
6779 -- insert the actions. We start at Assoc_Node, unless this node is a
6780 -- subexpression in which case we start with its parent. We do this for
6781 -- two reasons. First it speeds things up. Second, if Assoc_Node is
6782 -- itself one of the special nodes like N_And_Then, then we assume that
6783 -- an initial request to insert actions for such a node does not expect
6784 -- the actions to get deposited in the node for later handling when the
6785 -- node is expanded, since clearly the node is being dealt with by the
6786 -- caller. Note that in the subexpression case, N is always the child we
6789 -- N_Raise_xxx_Error is an annoying special case, it is a statement
6790 -- if it has type Standard_Void_Type, and a subexpression otherwise.
6791 -- Procedure calls, and similarly procedure attribute references, are
6794 if Nkind (Assoc_Node) in N_Subexpr
6795 and then (Nkind (Assoc_Node) not in N_Raise_xxx_Error
6796 or else Etype (Assoc_Node) /= Standard_Void_Type)
6797 and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement
6798 and then (Nkind (Assoc_Node) /= N_Attribute_Reference
6799 or else not Is_Procedure_Attribute_Name
6800 (Attribute_Name (Assoc_Node)))
6803 P := Parent (Assoc_Node);
6805 -- Non-subexpression case. Note that N is initially Empty in this case
6806 -- (N is only guaranteed Non-Empty in the subexpr case).
6813 -- Capture root of the transient scope
6815 if Scope_Is_Transient then
6816 Wrapped_Node := Node_To_Be_Wrapped;
6820 pragma Assert (Present (P));
6822 -- Make sure that inserted actions stay in the transient scope
6824 if Present (Wrapped_Node) and then N = Wrapped_Node then
6825 Store_Before_Actions_In_Scope (Ins_Actions);
6831 -- Case of right operand of AND THEN or OR ELSE. Put the actions
6832 -- in the Actions field of the right operand. They will be moved
6833 -- out further when the AND THEN or OR ELSE operator is expanded.
6834 -- Nothing special needs to be done for the left operand since
6835 -- in that case the actions are executed unconditionally.
6837 when N_Short_Circuit =>
6838 if N = Right_Opnd (P) then
6840 -- We are now going to either append the actions to the
6841 -- actions field of the short-circuit operation. We will
6842 -- also analyze the actions now.
6844 -- This analysis is really too early, the proper thing would
6845 -- be to just park them there now, and only analyze them if
6846 -- we find we really need them, and to it at the proper
6847 -- final insertion point. However attempting to this proved
6848 -- tricky, so for now we just kill current values before and
6849 -- after the analyze call to make sure we avoid peculiar
6850 -- optimizations from this out of order insertion.
6852 Kill_Current_Values;
6854 -- If P has already been expanded, we can't park new actions
6855 -- on it, so we need to expand them immediately, introducing
6856 -- an Expression_With_Actions. N can't be an expression
6857 -- with actions, or else then the actions would have been
6858 -- inserted at an inner level.
6860 if Analyzed (P) then
6861 pragma Assert (Nkind (N) /= N_Expression_With_Actions);
6863 Make_Expression_With_Actions (Sloc (N),
6864 Actions => Ins_Actions,
6865 Expression => Relocate_Node (N)));
6866 Analyze_And_Resolve (N);
6868 elsif Present (Actions (P)) then
6869 Insert_List_After_And_Analyze
6870 (Last (Actions (P)), Ins_Actions);
6872 Set_Actions (P, Ins_Actions);
6873 Analyze_List (Actions (P));
6876 Kill_Current_Values;
6881 -- Then or Else dependent expression of an if expression. Add
6882 -- actions to Then_Actions or Else_Actions field as appropriate.
6883 -- The actions will be moved further out when the if is expanded.
6885 when N_If_Expression =>
6887 ThenX : constant Node_Id := Next (First (Expressions (P)));
6888 ElseX : constant Node_Id := Next (ThenX);
6891 -- If the enclosing expression is already analyzed, as
6892 -- is the case for nested elaboration checks, insert the
6893 -- conditional further out.
6895 if Analyzed (P) then
6898 -- Actions belong to the then expression, temporarily place
6899 -- them as Then_Actions of the if expression. They will be
6900 -- moved to the proper place later when the if expression
6903 elsif N = ThenX then
6904 if Present (Then_Actions (P)) then
6905 Insert_List_After_And_Analyze
6906 (Last (Then_Actions (P)), Ins_Actions);
6908 Set_Then_Actions (P, Ins_Actions);
6909 Analyze_List (Then_Actions (P));
6914 -- Actions belong to the else expression, temporarily place
6915 -- them as Else_Actions of the if expression. They will be
6916 -- moved to the proper place later when the if expression
6919 elsif N = ElseX then
6920 if Present (Else_Actions (P)) then
6921 Insert_List_After_And_Analyze
6922 (Last (Else_Actions (P)), Ins_Actions);
6924 Set_Else_Actions (P, Ins_Actions);
6925 Analyze_List (Else_Actions (P));
6930 -- Actions belong to the condition. In this case they are
6931 -- unconditionally executed, and so we can continue the
6932 -- search for the proper insert point.
6939 -- Alternative of case expression, we place the action in the
6940 -- Actions field of the case expression alternative, this will
6941 -- be handled when the case expression is expanded.
6943 when N_Case_Expression_Alternative =>
6944 if Present (Actions (P)) then
6945 Insert_List_After_And_Analyze
6946 (Last (Actions (P)), Ins_Actions);
6948 Set_Actions (P, Ins_Actions);
6949 Analyze_List (Actions (P));
6954 -- Case of appearing within an Expressions_With_Actions node. When
6955 -- the new actions come from the expression of the expression with
6956 -- actions, they must be added to the existing actions. The other
6957 -- alternative is when the new actions are related to one of the
6958 -- existing actions of the expression with actions, and should
6959 -- never reach here: if actions are inserted on a statement
6960 -- within the Actions of an expression with actions, or on some
6961 -- subexpression of such a statement, then the outermost proper
6962 -- insertion point is right before the statement, and we should
6963 -- never climb up as far as the N_Expression_With_Actions itself.
6965 when N_Expression_With_Actions =>
6966 if N = Expression (P) then
6967 if Is_Empty_List (Actions (P)) then
6968 Append_List_To (Actions (P), Ins_Actions);
6969 Analyze_List (Actions (P));
6971 Insert_List_After_And_Analyze
6972 (Last (Actions (P)), Ins_Actions);
6978 raise Program_Error;
6981 -- Case of appearing in the condition of a while expression or
6982 -- elsif. We insert the actions into the Condition_Actions field.
6983 -- They will be moved further out when the while loop or elsif
6987 | N_Iteration_Scheme
6989 if N = Condition (P) then
6990 if Present (Condition_Actions (P)) then
6991 Insert_List_After_And_Analyze
6992 (Last (Condition_Actions (P)), Ins_Actions);
6994 Set_Condition_Actions (P, Ins_Actions);
6996 -- Set the parent of the insert actions explicitly. This
6997 -- is not a syntactic field, but we need the parent field
6998 -- set, in particular so that freeze can understand that
6999 -- it is dealing with condition actions, and properly
7000 -- insert the freezing actions.
7002 Set_Parent (Ins_Actions, P);
7003 Analyze_List (Condition_Actions (P));
7009 -- Statements, declarations, pragmas, representation clauses
7014 N_Procedure_Call_Statement
7015 | N_Statement_Other_Than_Procedure_Call
7021 -- Representation_Clause
7024 | N_Attribute_Definition_Clause
7025 | N_Enumeration_Representation_Clause
7026 | N_Record_Representation_Clause
7030 | N_Abstract_Subprogram_Declaration
7032 | N_Exception_Declaration
7033 | N_Exception_Renaming_Declaration
7034 | N_Expression_Function
7035 | N_Formal_Abstract_Subprogram_Declaration
7036 | N_Formal_Concrete_Subprogram_Declaration
7037 | N_Formal_Object_Declaration
7038 | N_Formal_Type_Declaration
7039 | N_Full_Type_Declaration
7040 | N_Function_Instantiation
7041 | N_Generic_Function_Renaming_Declaration
7042 | N_Generic_Package_Declaration
7043 | N_Generic_Package_Renaming_Declaration
7044 | N_Generic_Procedure_Renaming_Declaration
7045 | N_Generic_Subprogram_Declaration
7046 | N_Implicit_Label_Declaration
7047 | N_Incomplete_Type_Declaration
7048 | N_Number_Declaration
7049 | N_Object_Declaration
7050 | N_Object_Renaming_Declaration
7052 | N_Package_Body_Stub
7053 | N_Package_Declaration
7054 | N_Package_Instantiation
7055 | N_Package_Renaming_Declaration
7056 | N_Private_Extension_Declaration
7057 | N_Private_Type_Declaration
7058 | N_Procedure_Instantiation
7060 | N_Protected_Body_Stub
7061 | N_Protected_Type_Declaration
7062 | N_Single_Task_Declaration
7064 | N_Subprogram_Body_Stub
7065 | N_Subprogram_Declaration
7066 | N_Subprogram_Renaming_Declaration
7067 | N_Subtype_Declaration
7070 | N_Task_Type_Declaration
7072 -- Use clauses can appear in lists of declarations
7074 | N_Use_Package_Clause
7077 -- Freeze entity behaves like a declaration or statement
7080 | N_Freeze_Generic_Entity
7082 -- Do not insert here if the item is not a list member (this
7083 -- happens for example with a triggering statement, and the
7084 -- proper approach is to insert before the entire select).
7086 if not Is_List_Member (P) then
7089 -- Do not insert if parent of P is an N_Component_Association
7090 -- node (i.e. we are in the context of an N_Aggregate or
7091 -- N_Extension_Aggregate node. In this case we want to insert
7092 -- before the entire aggregate.
7094 elsif Nkind (Parent (P)) = N_Component_Association then
7097 -- Do not insert if the parent of P is either an N_Variant node
7098 -- or an N_Record_Definition node, meaning in either case that
7099 -- P is a member of a component list, and that therefore the
7100 -- actions should be inserted outside the complete record
7103 elsif Nkind_In (Parent (P), N_Variant, N_Record_Definition) then
7106 -- Do not insert freeze nodes within the loop generated for
7107 -- an aggregate, because they may be elaborated too late for
7108 -- subsequent use in the back end: within a package spec the
7109 -- loop is part of the elaboration procedure and is only
7110 -- elaborated during the second pass.
7112 -- If the loop comes from source, or the entity is local to the
7113 -- loop itself it must remain within.
7115 elsif Nkind (Parent (P)) = N_Loop_Statement
7116 and then not Comes_From_Source (Parent (P))
7117 and then Nkind (First (Ins_Actions)) = N_Freeze_Entity
7119 Scope (Entity (First (Ins_Actions))) /= Current_Scope
7123 -- Otherwise we can go ahead and do the insertion
7125 elsif P = Wrapped_Node then
7126 Store_Before_Actions_In_Scope (Ins_Actions);
7130 Insert_List_Before_And_Analyze (P, Ins_Actions);
7134 -- A special case, N_Raise_xxx_Error can act either as a statement
7135 -- or a subexpression. We tell the difference by looking at the
7136 -- Etype. It is set to Standard_Void_Type in the statement case.
7138 when N_Raise_xxx_Error =>
7139 if Etype (P) = Standard_Void_Type then
7140 if P = Wrapped_Node then
7141 Store_Before_Actions_In_Scope (Ins_Actions);
7143 Insert_List_Before_And_Analyze (P, Ins_Actions);
7148 -- In the subexpression case, keep climbing
7154 -- If a component association appears within a loop created for
7155 -- an array aggregate, attach the actions to the association so
7156 -- they can be subsequently inserted within the loop. For other
7157 -- component associations insert outside of the aggregate. For
7158 -- an association that will generate a loop, its Loop_Actions
7159 -- attribute is already initialized (see exp_aggr.adb).
7161 -- The list of Loop_Actions can in turn generate additional ones,
7162 -- that are inserted before the associated node. If the associated
7163 -- node is outside the aggregate, the new actions are collected
7164 -- at the end of the Loop_Actions, to respect the order in which
7165 -- they are to be elaborated.
7167 when N_Component_Association
7168 | N_Iterated_Component_Association
7170 if Nkind (Parent (P)) = N_Aggregate
7171 and then Present (Loop_Actions (P))
7173 if Is_Empty_List (Loop_Actions (P)) then
7174 Set_Loop_Actions (P, Ins_Actions);
7175 Analyze_List (Ins_Actions);
7181 -- Check whether these actions were generated by a
7182 -- declaration that is part of the Loop_Actions for
7183 -- the component_association.
7186 while Present (Decl) loop
7187 exit when Parent (Decl) = P
7188 and then Is_List_Member (Decl)
7190 List_Containing (Decl) = Loop_Actions (P);
7191 Decl := Parent (Decl);
7194 if Present (Decl) then
7195 Insert_List_Before_And_Analyze
7196 (Decl, Ins_Actions);
7198 Insert_List_After_And_Analyze
7199 (Last (Loop_Actions (P)), Ins_Actions);
7210 -- Another special case, an attribute denoting a procedure call
7212 when N_Attribute_Reference =>
7213 if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
7214 if P = Wrapped_Node then
7215 Store_Before_Actions_In_Scope (Ins_Actions);
7217 Insert_List_Before_And_Analyze (P, Ins_Actions);
7222 -- In the subexpression case, keep climbing
7228 -- A contract node should not belong to the tree
7231 raise Program_Error;
7233 -- For all other node types, keep climbing tree
7235 when N_Abortable_Part
7236 | N_Accept_Alternative
7237 | N_Access_Definition
7238 | N_Access_Function_Definition
7239 | N_Access_Procedure_Definition
7240 | N_Access_To_Object_Definition
7243 | N_Aspect_Specification
7245 | N_Case_Statement_Alternative
7246 | N_Character_Literal
7247 | N_Compilation_Unit
7248 | N_Compilation_Unit_Aux
7249 | N_Component_Clause
7250 | N_Component_Declaration
7251 | N_Component_Definition
7253 | N_Constrained_Array_Definition
7254 | N_Decimal_Fixed_Point_Definition
7255 | N_Defining_Character_Literal
7256 | N_Defining_Identifier
7257 | N_Defining_Operator_Symbol
7258 | N_Defining_Program_Unit_Name
7259 | N_Delay_Alternative
7261 | N_Delta_Constraint
7262 | N_Derived_Type_Definition
7264 | N_Digits_Constraint
7265 | N_Discriminant_Association
7266 | N_Discriminant_Specification
7268 | N_Entry_Body_Formal_Part
7269 | N_Entry_Call_Alternative
7270 | N_Entry_Declaration
7271 | N_Entry_Index_Specification
7272 | N_Enumeration_Type_Definition
7274 | N_Exception_Handler
7276 | N_Explicit_Dereference
7277 | N_Extension_Aggregate
7278 | N_Floating_Point_Definition
7279 | N_Formal_Decimal_Fixed_Point_Definition
7280 | N_Formal_Derived_Type_Definition
7281 | N_Formal_Discrete_Type_Definition
7282 | N_Formal_Floating_Point_Definition
7283 | N_Formal_Modular_Type_Definition
7284 | N_Formal_Ordinary_Fixed_Point_Definition
7285 | N_Formal_Package_Declaration
7286 | N_Formal_Private_Type_Definition
7287 | N_Formal_Incomplete_Type_Definition
7288 | N_Formal_Signed_Integer_Type_Definition
7290 | N_Function_Specification
7291 | N_Generic_Association
7292 | N_Handled_Sequence_Of_Statements
7295 | N_Index_Or_Discriminant_Constraint
7296 | N_Indexed_Component
7298 | N_Iterator_Specification
7301 | N_Loop_Parameter_Specification
7303 | N_Modular_Type_Definition
7329 | N_Op_Shift_Right_Arithmetic
7333 | N_Ordinary_Fixed_Point_Definition
7335 | N_Package_Specification
7336 | N_Parameter_Association
7337 | N_Parameter_Specification
7338 | N_Pop_Constraint_Error_Label
7339 | N_Pop_Program_Error_Label
7340 | N_Pop_Storage_Error_Label
7341 | N_Pragma_Argument_Association
7342 | N_Procedure_Specification
7343 | N_Protected_Definition
7344 | N_Push_Constraint_Error_Label
7345 | N_Push_Program_Error_Label
7346 | N_Push_Storage_Error_Label
7347 | N_Qualified_Expression
7348 | N_Quantified_Expression
7349 | N_Raise_Expression
7351 | N_Range_Constraint
7353 | N_Real_Range_Specification
7354 | N_Record_Definition
7356 | N_SCIL_Dispatch_Table_Tag_Init
7357 | N_SCIL_Dispatching_Call
7358 | N_SCIL_Membership_Test
7359 | N_Selected_Component
7360 | N_Signed_Integer_Type_Definition
7361 | N_Single_Protected_Declaration
7364 | N_Subtype_Indication
7368 | N_Terminate_Alternative
7369 | N_Triggering_Alternative
7371 | N_Unchecked_Expression
7372 | N_Unchecked_Type_Conversion
7373 | N_Unconstrained_Array_Definition
7378 | N_Validate_Unchecked_Conversion
7384 -- If we fall through above tests, keep climbing tree
7388 if Nkind (Parent (N)) = N_Subunit then
7390 -- This is the proper body corresponding to a stub. Insertion must
7391 -- be done at the point of the stub, which is in the declarative
7392 -- part of the parent unit.
7394 P := Corresponding_Stub (Parent (N));
7402 -- Version with check(s) suppressed
7404 procedure Insert_Actions
7405 (Assoc_Node : Node_Id;
7406 Ins_Actions : List_Id;
7407 Suppress : Check_Id)
7410 if Suppress = All_Checks then
7412 Sva : constant Suppress_Array := Scope_Suppress.Suppress;
7414 Scope_Suppress.Suppress := (others => True);
7415 Insert_Actions (Assoc_Node, Ins_Actions);
7416 Scope_Suppress.Suppress := Sva;
7421 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
7423 Scope_Suppress.Suppress (Suppress) := True;
7424 Insert_Actions (Assoc_Node, Ins_Actions);
7425 Scope_Suppress.Suppress (Suppress) := Svg;
7430 --------------------------
7431 -- Insert_Actions_After --
7432 --------------------------
7434 procedure Insert_Actions_After
7435 (Assoc_Node : Node_Id;
7436 Ins_Actions : List_Id)
7439 if Scope_Is_Transient and then Assoc_Node = Node_To_Be_Wrapped then
7440 Store_After_Actions_In_Scope (Ins_Actions);
7442 Insert_List_After_And_Analyze (Assoc_Node, Ins_Actions);
7444 end Insert_Actions_After;
7446 ------------------------
7447 -- Insert_Declaration --
7448 ------------------------
7450 procedure Insert_Declaration (N : Node_Id; Decl : Node_Id) is
7454 pragma Assert (Nkind (N) in N_Subexpr);
7456 -- Climb until we find a procedure or a package
7460 pragma Assert (Present (Parent (P)));
7463 if Is_List_Member (P) then
7464 exit when Nkind_In (Parent (P), N_Package_Specification,
7467 -- Special handling for handled sequence of statements, we must
7468 -- insert in the statements not the exception handlers!
7470 if Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements then
7471 P := First (Statements (Parent (P)));
7477 -- Now do the insertion
7479 Insert_Before (P, Decl);
7481 end Insert_Declaration;
7483 ---------------------------------
7484 -- Insert_Library_Level_Action --
7485 ---------------------------------
7487 procedure Insert_Library_Level_Action (N : Node_Id) is
7488 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7491 Push_Scope (Cunit_Entity (Main_Unit));
7492 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
7494 if No (Actions (Aux)) then
7495 Set_Actions (Aux, New_List (N));
7497 Append (N, Actions (Aux));
7502 end Insert_Library_Level_Action;
7504 ----------------------------------
7505 -- Insert_Library_Level_Actions --
7506 ----------------------------------
7508 procedure Insert_Library_Level_Actions (L : List_Id) is
7509 Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
7512 if Is_Non_Empty_List (L) then
7513 Push_Scope (Cunit_Entity (Main_Unit));
7514 -- ??? should this be Current_Sem_Unit instead of Main_Unit?
7516 if No (Actions (Aux)) then
7517 Set_Actions (Aux, L);
7520 Insert_List_After_And_Analyze (Last (Actions (Aux)), L);
7525 end Insert_Library_Level_Actions;
7527 ----------------------
7528 -- Inside_Init_Proc --
7529 ----------------------
7531 function Inside_Init_Proc return Boolean is
7536 while Present (S) and then S /= Standard_Standard loop
7537 if Is_Init_Proc (S) then
7545 end Inside_Init_Proc;
7547 ----------------------------
7548 -- Is_All_Null_Statements --
7549 ----------------------------
7551 function Is_All_Null_Statements (L : List_Id) return Boolean is
7556 while Present (Stm) loop
7557 if Nkind (Stm) /= N_Null_Statement then
7565 end Is_All_Null_Statements;
7567 --------------------------------------------------
7568 -- Is_Displacement_Of_Object_Or_Function_Result --
7569 --------------------------------------------------
7571 function Is_Displacement_Of_Object_Or_Function_Result
7572 (Obj_Id : Entity_Id) return Boolean
7574 function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
7575 -- Determine if particular node denotes a controlled function call. The
7576 -- call may have been heavily expanded.
7578 function Is_Displace_Call (N : Node_Id) return Boolean;
7579 -- Determine whether a particular node is a call to Ada.Tags.Displace.
7580 -- The call might be nested within other actions such as conversions.
7582 function Is_Source_Object (N : Node_Id) return Boolean;
7583 -- Determine whether a particular node denotes a source object
7585 ---------------------------------
7586 -- Is_Controlled_Function_Call --
7587 ---------------------------------
7589 function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
7590 Expr : Node_Id := Original_Node (N);
7593 -- When a function call appears in Object.Operation format, the
7594 -- original representation has several possible forms depending on
7595 -- the availability and form of actual parameters:
7597 -- Obj.Func N_Selected_Component
7598 -- Obj.Func (Actual) N_Indexed_Component
7599 -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
7600 -- N_Selected_Component
7603 if Nkind (Expr) = N_Function_Call then
7604 Expr := Name (Expr);
7606 -- "Obj.Func (Actual)" case
7608 elsif Nkind (Expr) = N_Indexed_Component then
7609 Expr := Prefix (Expr);
7611 -- "Obj.Func" or "Obj.Func (Formal => Actual) case
7613 elsif Nkind (Expr) = N_Selected_Component then
7614 Expr := Selector_Name (Expr);
7622 Nkind (Expr) in N_Has_Entity
7623 and then Present (Entity (Expr))
7624 and then Ekind (Entity (Expr)) = E_Function
7625 and then Needs_Finalization (Etype (Entity (Expr)));
7626 end Is_Controlled_Function_Call;
7628 ----------------------
7629 -- Is_Displace_Call --
7630 ----------------------
7632 function Is_Displace_Call (N : Node_Id) return Boolean is
7633 Call : Node_Id := N;
7636 -- Strip various actions which may precede a call to Displace
7639 if Nkind (Call) = N_Explicit_Dereference then
7640 Call := Prefix (Call);
7642 elsif Nkind_In (Call, N_Type_Conversion,
7643 N_Unchecked_Type_Conversion)
7645 Call := Expression (Call);
7654 and then Nkind (Call) = N_Function_Call
7655 and then Is_RTE (Entity (Name (Call)), RE_Displace);
7656 end Is_Displace_Call;
7658 ----------------------
7659 -- Is_Source_Object --
7660 ----------------------
7662 function Is_Source_Object (N : Node_Id) return Boolean is
7666 and then Nkind (N) in N_Has_Entity
7667 and then Is_Object (Entity (N))
7668 and then Comes_From_Source (N);
7669 end Is_Source_Object;
7673 Decl : constant Node_Id := Parent (Obj_Id);
7674 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7675 Orig_Decl : constant Node_Id := Original_Node (Decl);
7677 -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
7682 -- Obj : CW_Type := Function_Call (...);
7686 -- Tmp : ... := Function_Call (...)'reference;
7687 -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
7689 -- where the return type of the function and the class-wide type require
7690 -- dispatch table pointer displacement.
7694 -- Obj : CW_Type := Src_Obj;
7698 -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
7700 -- where the type of the source object and the class-wide type require
7701 -- dispatch table pointer displacement.
7704 Nkind (Decl) = N_Object_Renaming_Declaration
7705 and then Nkind (Orig_Decl) = N_Object_Declaration
7706 and then Comes_From_Source (Orig_Decl)
7707 and then Is_Class_Wide_Type (Obj_Typ)
7708 and then Is_Displace_Call (Renamed_Object (Obj_Id))
7710 (Is_Controlled_Function_Call (Expression (Orig_Decl))
7711 or else Is_Source_Object (Expression (Orig_Decl)));
7712 end Is_Displacement_Of_Object_Or_Function_Result;
7714 ------------------------------
7715 -- Is_Finalizable_Transient --
7716 ------------------------------
7718 function Is_Finalizable_Transient
7720 Rel_Node : Node_Id) return Boolean
7722 Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
7723 Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
7725 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
7726 -- Determine whether transient object Trans_Id is initialized either
7727 -- by a function call which returns an access type or simply renames
7730 function Initialized_By_Aliased_BIP_Func_Call
7731 (Trans_Id : Entity_Id) return Boolean;
7732 -- Determine whether transient object Trans_Id is initialized by a
7733 -- build-in-place function call where the BIPalloc parameter is of
7734 -- value 1 and BIPaccess is not null. This case creates an aliasing
7735 -- between the returned value and the value denoted by BIPaccess.
7738 (Trans_Id : Entity_Id;
7739 First_Stmt : Node_Id) return Boolean;
7740 -- Determine whether transient object Trans_Id has been renamed or
7741 -- aliased through 'reference in the statement list starting from
7744 function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
7745 -- Determine whether transient object Trans_Id is allocated on the heap
7747 function Is_Iterated_Container
7748 (Trans_Id : Entity_Id;
7749 First_Stmt : Node_Id) return Boolean;
7750 -- Determine whether transient object Trans_Id denotes a container which
7751 -- is in the process of being iterated in the statement list starting
7754 ---------------------------
7755 -- Initialized_By_Access --
7756 ---------------------------
7758 function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
7759 Expr : constant Node_Id := Expression (Parent (Trans_Id));
7764 and then Nkind (Expr) /= N_Reference
7765 and then Is_Access_Type (Etype (Expr));
7766 end Initialized_By_Access;
7768 ------------------------------------------
7769 -- Initialized_By_Aliased_BIP_Func_Call --
7770 ------------------------------------------
7772 function Initialized_By_Aliased_BIP_Func_Call
7773 (Trans_Id : Entity_Id) return Boolean
7775 Call : Node_Id := Expression (Parent (Trans_Id));
7778 -- Build-in-place calls usually appear in 'reference format
7780 if Nkind (Call) = N_Reference then
7781 Call := Prefix (Call);
7784 if Is_Build_In_Place_Function_Call (Call) then
7786 Access_Nam : Name_Id := No_Name;
7787 Access_OK : Boolean := False;
7789 Alloc_Nam : Name_Id := No_Name;
7790 Alloc_OK : Boolean := False;
7792 Func_Id : Entity_Id;
7796 -- Examine all parameter associations of the function call
7798 Param := First (Parameter_Associations (Call));
7799 while Present (Param) loop
7800 if Nkind (Param) = N_Parameter_Association
7801 and then Nkind (Selector_Name (Param)) = N_Identifier
7803 Actual := Explicit_Actual_Parameter (Param);
7804 Formal := Selector_Name (Param);
7806 -- Construct the names of formals BIPaccess and BIPalloc
7807 -- using the function name retrieved from an arbitrary
7810 if Access_Nam = No_Name
7811 and then Alloc_Nam = No_Name
7812 and then Present (Entity (Formal))
7814 Func_Id := Scope (Entity (Formal));
7817 New_External_Name (Chars (Func_Id),
7818 BIP_Formal_Suffix (BIP_Object_Access));
7821 New_External_Name (Chars (Func_Id),
7822 BIP_Formal_Suffix (BIP_Alloc_Form));
7825 -- A match for BIPaccess => Temp has been found
7827 if Chars (Formal) = Access_Nam
7828 and then Nkind (Actual) /= N_Null
7833 -- A match for BIPalloc => 1 has been found
7835 if Chars (Formal) = Alloc_Nam
7836 and then Nkind (Actual) = N_Integer_Literal
7837 and then Intval (Actual) = Uint_1
7846 return Access_OK and Alloc_OK;
7851 end Initialized_By_Aliased_BIP_Func_Call;
7858 (Trans_Id : Entity_Id;
7859 First_Stmt : Node_Id) return Boolean
7861 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id;
7862 -- Given an object renaming declaration, retrieve the entity of the
7863 -- renamed name. Return Empty if the renamed name is anything other
7864 -- than a variable or a constant.
7866 -------------------------
7867 -- Find_Renamed_Object --
7868 -------------------------
7870 function Find_Renamed_Object (Ren_Decl : Node_Id) return Entity_Id is
7871 Ren_Obj : Node_Id := Empty;
7873 function Find_Object (N : Node_Id) return Traverse_Result;
7874 -- Try to detect an object which is either a constant or a
7881 function Find_Object (N : Node_Id) return Traverse_Result is
7883 -- Stop the search once a constant or a variable has been
7886 if Nkind (N) = N_Identifier
7887 and then Present (Entity (N))
7888 and then Ekind_In (Entity (N), E_Constant, E_Variable)
7890 Ren_Obj := Entity (N);
7897 procedure Search is new Traverse_Proc (Find_Object);
7901 Typ : constant Entity_Id := Etype (Defining_Identifier (Ren_Decl));
7903 -- Start of processing for Find_Renamed_Object
7906 -- Actions related to dispatching calls may appear as renamings of
7907 -- tags. Do not process this type of renaming because it does not
7908 -- use the actual value of the object.
7910 if not Is_RTE (Typ, RE_Tag_Ptr) then
7911 Search (Name (Ren_Decl));
7915 end Find_Renamed_Object;
7920 Ren_Obj : Entity_Id;
7923 -- Start of processing for Is_Aliased
7926 -- A controlled transient object is not considered aliased when it
7927 -- appears inside an expression_with_actions node even when there are
7928 -- explicit aliases of it:
7931 -- Trans_Id : Ctrl_Typ ...; -- transient object
7932 -- Alias : ... := Trans_Id; -- object is aliased
7933 -- Val : constant Boolean :=
7934 -- ... Alias ...; -- aliasing ends
7935 -- <finalize Trans_Id> -- object safe to finalize
7938 -- Expansion ensures that all aliases are encapsulated in the actions
7939 -- list and do not leak to the expression by forcing the evaluation
7940 -- of the expression.
7942 if Nkind (Rel_Node) = N_Expression_With_Actions then
7945 -- Otherwise examine the statements after the controlled transient
7946 -- object and look for various forms of aliasing.
7950 while Present (Stmt) loop
7951 if Nkind (Stmt) = N_Object_Declaration then
7952 Expr := Expression (Stmt);
7954 -- Aliasing of the form:
7955 -- Obj : ... := Trans_Id'reference;
7958 and then Nkind (Expr) = N_Reference
7959 and then Nkind (Prefix (Expr)) = N_Identifier
7960 and then Entity (Prefix (Expr)) = Trans_Id
7965 elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
7966 Ren_Obj := Find_Renamed_Object (Stmt);
7968 -- Aliasing of the form:
7969 -- Obj : ... renames ... Trans_Id ...;
7971 if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
7987 function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
7988 Expr : constant Node_Id := Expression (Parent (Trans_Id));
7991 Is_Access_Type (Etype (Trans_Id))
7992 and then Present (Expr)
7993 and then Nkind (Expr) = N_Allocator;
7996 ---------------------------
7997 -- Is_Iterated_Container --
7998 ---------------------------
8000 function Is_Iterated_Container
8001 (Trans_Id : Entity_Id;
8002 First_Stmt : Node_Id) return Boolean
8012 -- It is not possible to iterate over containers in non-Ada 2012 code
8014 if Ada_Version < Ada_2012 then
8018 Typ := Etype (Trans_Id);
8020 -- Handle access type created for secondary stack use
8022 if Is_Access_Type (Typ) then
8023 Typ := Designated_Type (Typ);
8026 -- Look for aspect Default_Iterator. It may be part of a type
8027 -- declaration for a container, or inherited from a base type
8030 Aspect := Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
8032 if Present (Aspect) then
8033 Iter := Entity (Aspect);
8035 -- Examine the statements following the container object and
8036 -- look for a call to the default iterate routine where the
8037 -- first parameter is the transient. Such a call appears as:
8039 -- It : Access_To_CW_Iterator :=
8040 -- Iterate (Tran_Id.all, ...)'reference;
8043 while Present (Stmt) loop
8045 -- Detect an object declaration which is initialized by a
8046 -- secondary stack function call.
8048 if Nkind (Stmt) = N_Object_Declaration
8049 and then Present (Expression (Stmt))
8050 and then Nkind (Expression (Stmt)) = N_Reference
8051 and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call
8053 Call := Prefix (Expression (Stmt));
8055 -- The call must invoke the default iterate routine of
8056 -- the container and the transient object must appear as
8057 -- the first actual parameter. Skip any calls whose names
8058 -- are not entities.
8060 if Is_Entity_Name (Name (Call))
8061 and then Entity (Name (Call)) = Iter
8062 and then Present (Parameter_Associations (Call))
8064 Param := First (Parameter_Associations (Call));
8066 if Nkind (Param) = N_Explicit_Dereference
8067 and then Entity (Prefix (Param)) = Trans_Id
8079 end Is_Iterated_Container;
8083 Desig : Entity_Id := Obj_Typ;
8085 -- Start of processing for Is_Finalizable_Transient
8088 -- Handle access types
8090 if Is_Access_Type (Desig) then
8091 Desig := Available_View (Designated_Type (Desig));
8095 Ekind_In (Obj_Id, E_Constant, E_Variable)
8096 and then Needs_Finalization (Desig)
8097 and then Requires_Transient_Scope (Desig)
8098 and then Nkind (Rel_Node) /= N_Simple_Return_Statement
8100 -- Do not consider a transient object that was already processed
8102 and then not Is_Finalized_Transient (Obj_Id)
8104 -- Do not consider renamed or 'reference-d transient objects because
8105 -- the act of renaming extends the object's lifetime.
8107 and then not Is_Aliased (Obj_Id, Decl)
8109 -- Do not consider transient objects allocated on the heap since
8110 -- they are attached to a finalization master.
8112 and then not Is_Allocated (Obj_Id)
8114 -- If the transient object is a pointer, check that it is not
8115 -- initialized by a function that returns a pointer or acts as a
8116 -- renaming of another pointer.
8119 (not Is_Access_Type (Obj_Typ)
8120 or else not Initialized_By_Access (Obj_Id))
8122 -- Do not consider transient objects which act as indirect aliases
8123 -- of build-in-place function results.
8125 and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
8127 -- Do not consider conversions of tags to class-wide types
8129 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
8131 -- Do not consider iterators because those are treated as normal
8132 -- controlled objects and are processed by the usual finalization
8133 -- machinery. This avoids the double finalization of an iterator.
8135 and then not Is_Iterator (Desig)
8137 -- Do not consider containers in the context of iterator loops. Such
8138 -- transient objects must exist for as long as the loop is around,
8139 -- otherwise any operation carried out by the iterator will fail.
8141 and then not Is_Iterated_Container (Obj_Id, Decl);
8142 end Is_Finalizable_Transient;
8144 ---------------------------------
8145 -- Is_Fully_Repped_Tagged_Type --
8146 ---------------------------------
8148 function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
8149 U : constant Entity_Id := Underlying_Type (T);
8153 if No (U) or else not Is_Tagged_Type (U) then
8155 elsif Has_Discriminants (U) then
8157 elsif not Has_Specified_Layout (U) then
8161 -- Here we have a tagged type, see if it has any unlayed out fields
8162 -- other than a possible tag and parent fields. If so, we return False.
8164 Comp := First_Component (U);
8165 while Present (Comp) loop
8166 if not Is_Tag (Comp)
8167 and then Chars (Comp) /= Name_uParent
8168 and then No (Component_Clause (Comp))
8172 Next_Component (Comp);
8176 -- All components are layed out
8179 end Is_Fully_Repped_Tagged_Type;
8181 ----------------------------------
8182 -- Is_Library_Level_Tagged_Type --
8183 ----------------------------------
8185 function Is_Library_Level_Tagged_Type (Typ : Entity_Id) return Boolean is
8187 return Is_Tagged_Type (Typ) and then Is_Library_Level_Entity (Typ);
8188 end Is_Library_Level_Tagged_Type;
8190 --------------------------
8191 -- Is_Non_BIP_Func_Call --
8192 --------------------------
8194 function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
8196 -- The expected call is of the format
8198 -- Func_Call'reference
8201 Nkind (Expr) = N_Reference
8202 and then Nkind (Prefix (Expr)) = N_Function_Call
8203 and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
8204 end Is_Non_BIP_Func_Call;
8206 ------------------------------------
8207 -- Is_Object_Access_BIP_Func_Call --
8208 ------------------------------------
8210 function Is_Object_Access_BIP_Func_Call
8212 Obj_Id : Entity_Id) return Boolean
8214 Access_Nam : Name_Id := No_Name;
8221 -- Build-in-place calls usually appear in 'reference format. Note that
8222 -- the accessibility check machinery may add an extra 'reference due to
8223 -- side effect removal.
8226 while Nkind (Call) = N_Reference loop
8227 Call := Prefix (Call);
8230 if Nkind_In (Call, N_Qualified_Expression,
8231 N_Unchecked_Type_Conversion)
8233 Call := Expression (Call);
8236 if Is_Build_In_Place_Function_Call (Call) then
8238 -- Examine all parameter associations of the function call
8240 Param := First (Parameter_Associations (Call));
8241 while Present (Param) loop
8242 if Nkind (Param) = N_Parameter_Association
8243 and then Nkind (Selector_Name (Param)) = N_Identifier
8245 Formal := Selector_Name (Param);
8246 Actual := Explicit_Actual_Parameter (Param);
8248 -- Construct the name of formal BIPaccess. It is much easier to
8249 -- extract the name of the function using an arbitrary formal's
8250 -- scope rather than the Name field of Call.
8252 if Access_Nam = No_Name and then Present (Entity (Formal)) then
8255 (Chars (Scope (Entity (Formal))),
8256 BIP_Formal_Suffix (BIP_Object_Access));
8259 -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been
8262 if Chars (Formal) = Access_Nam
8263 and then Nkind (Actual) = N_Attribute_Reference
8264 and then Attribute_Name (Actual) = Name_Unrestricted_Access
8265 and then Nkind (Prefix (Actual)) = N_Identifier
8266 and then Entity (Prefix (Actual)) = Obj_Id
8277 end Is_Object_Access_BIP_Func_Call;
8279 ----------------------------------
8280 -- Is_Possibly_Unaligned_Object --
8281 ----------------------------------
8283 function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
8284 T : constant Entity_Id := Etype (N);
8287 -- If renamed object, apply test to underlying object
8289 if Is_Entity_Name (N)
8290 and then Is_Object (Entity (N))
8291 and then Present (Renamed_Object (Entity (N)))
8293 return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
8296 -- Tagged and controlled types and aliased types are always aligned, as
8297 -- are concurrent types.
8300 or else Has_Controlled_Component (T)
8301 or else Is_Concurrent_Type (T)
8302 or else Is_Tagged_Type (T)
8303 or else Is_Controlled (T)
8308 -- If this is an element of a packed array, may be unaligned
8310 if Is_Ref_To_Bit_Packed_Array (N) then
8314 -- Case of indexed component reference: test whether prefix is unaligned
8316 if Nkind (N) = N_Indexed_Component then
8317 return Is_Possibly_Unaligned_Object (Prefix (N));
8319 -- Case of selected component reference
8321 elsif Nkind (N) = N_Selected_Component then
8323 P : constant Node_Id := Prefix (N);
8324 C : constant Entity_Id := Entity (Selector_Name (N));
8329 -- If component reference is for an array with non-static bounds,
8330 -- then it is always aligned: we can only process unaligned arrays
8331 -- with static bounds (more precisely compile time known bounds).
8333 if Is_Array_Type (T)
8334 and then not Compile_Time_Known_Bounds (T)
8339 -- If component is aliased, it is definitely properly aligned
8341 if Is_Aliased (C) then
8345 -- If component is for a type implemented as a scalar, and the
8346 -- record is packed, and the component is other than the first
8347 -- component of the record, then the component may be unaligned.
8349 if Is_Packed (Etype (P))
8350 and then Represented_As_Scalar (Etype (C))
8351 and then First_Entity (Scope (C)) /= C
8356 -- Compute maximum possible alignment for T
8358 -- If alignment is known, then that settles things
8360 if Known_Alignment (T) then
8361 M := UI_To_Int (Alignment (T));
8363 -- If alignment is not known, tentatively set max alignment
8366 M := Ttypes.Maximum_Alignment;
8368 -- We can reduce this if the Esize is known since the default
8369 -- alignment will never be more than the smallest power of 2
8370 -- that does not exceed this Esize value.
8372 if Known_Esize (T) then
8373 S := UI_To_Int (Esize (T));
8375 while (M / 2) >= S loop
8381 -- The following code is historical, it used to be present but it
8382 -- is too cautious, because the front-end does not know the proper
8383 -- default alignments for the target. Also, if the alignment is
8384 -- not known, the front end can't know in any case. If a copy is
8385 -- needed, the back-end will take care of it. This whole section
8386 -- including this comment can be removed later ???
8388 -- If the component reference is for a record that has a specified
8389 -- alignment, and we either know it is too small, or cannot tell,
8390 -- then the component may be unaligned.
8392 -- What is the following commented out code ???
8394 -- if Known_Alignment (Etype (P))
8395 -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
8396 -- and then M > Alignment (Etype (P))
8401 -- Case of component clause present which may specify an
8402 -- unaligned position.
8404 if Present (Component_Clause (C)) then
8406 -- Otherwise we can do a test to make sure that the actual
8407 -- start position in the record, and the length, are both
8408 -- consistent with the required alignment. If not, we know
8409 -- that we are unaligned.
8412 Align_In_Bits : constant Nat := M * System_Storage_Unit;
8414 if Component_Bit_Offset (C) mod Align_In_Bits /= 0
8415 or else Esize (C) mod Align_In_Bits /= 0
8422 -- Otherwise, for a component reference, test prefix
8424 return Is_Possibly_Unaligned_Object (P);
8427 -- If not a component reference, must be aligned
8432 end Is_Possibly_Unaligned_Object;
8434 ---------------------------------
8435 -- Is_Possibly_Unaligned_Slice --
8436 ---------------------------------
8438 function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
8440 -- Go to renamed object
8442 if Is_Entity_Name (N)
8443 and then Is_Object (Entity (N))
8444 and then Present (Renamed_Object (Entity (N)))
8446 return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
8449 -- The reference must be a slice
8451 if Nkind (N) /= N_Slice then
8455 -- We only need to worry if the target has strict alignment
8457 if not Target_Strict_Alignment then
8461 -- If it is a slice, then look at the array type being sliced
8464 Sarr : constant Node_Id := Prefix (N);
8465 -- Prefix of the slice, i.e. the array being sliced
8467 Styp : constant Entity_Id := Etype (Prefix (N));
8468 -- Type of the array being sliced
8474 -- The problems arise if the array object that is being sliced
8475 -- is a component of a record or array, and we cannot guarantee
8476 -- the alignment of the array within its containing object.
8478 -- To investigate this, we look at successive prefixes to see
8479 -- if we have a worrisome indexed or selected component.
8483 -- Case of array is part of an indexed component reference
8485 if Nkind (Pref) = N_Indexed_Component then
8486 Ptyp := Etype (Prefix (Pref));
8488 -- The only problematic case is when the array is packed, in
8489 -- which case we really know nothing about the alignment of
8490 -- individual components.
8492 if Is_Bit_Packed_Array (Ptyp) then
8496 -- Case of array is part of a selected component reference
8498 elsif Nkind (Pref) = N_Selected_Component then
8499 Ptyp := Etype (Prefix (Pref));
8501 -- We are definitely in trouble if the record in question
8502 -- has an alignment, and either we know this alignment is
8503 -- inconsistent with the alignment of the slice, or we don't
8504 -- know what the alignment of the slice should be.
8506 if Known_Alignment (Ptyp)
8507 and then (Unknown_Alignment (Styp)
8508 or else Alignment (Styp) > Alignment (Ptyp))
8513 -- We are in potential trouble if the record type is packed.
8514 -- We could special case when we know that the array is the
8515 -- first component, but that's not such a simple case ???
8517 if Is_Packed (Ptyp) then
8521 -- We are in trouble if there is a component clause, and
8522 -- either we do not know the alignment of the slice, or
8523 -- the alignment of the slice is inconsistent with the
8524 -- bit position specified by the component clause.
8527 Field : constant Entity_Id := Entity (Selector_Name (Pref));
8529 if Present (Component_Clause (Field))
8531 (Unknown_Alignment (Styp)
8533 (Component_Bit_Offset (Field) mod
8534 (System_Storage_Unit * Alignment (Styp))) /= 0)
8540 -- For cases other than selected or indexed components we know we
8541 -- are OK, since no issues arise over alignment.
8547 -- We processed an indexed component or selected component
8548 -- reference that looked safe, so keep checking prefixes.
8550 Pref := Prefix (Pref);
8553 end Is_Possibly_Unaligned_Slice;
8555 -------------------------------
8556 -- Is_Related_To_Func_Return --
8557 -------------------------------
8559 function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
8560 Expr : constant Node_Id := Related_Expression (Id);
8564 and then Nkind (Expr) = N_Explicit_Dereference
8565 and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
8566 end Is_Related_To_Func_Return;
8568 --------------------------------
8569 -- Is_Ref_To_Bit_Packed_Array --
8570 --------------------------------
8572 function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
8577 if Is_Entity_Name (N)
8578 and then Is_Object (Entity (N))
8579 and then Present (Renamed_Object (Entity (N)))
8581 return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
8584 if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8585 if Is_Bit_Packed_Array (Etype (Prefix (N))) then
8588 Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
8591 if Result and then Nkind (N) = N_Indexed_Component then
8592 Expr := First (Expressions (N));
8593 while Present (Expr) loop
8594 Force_Evaluation (Expr);
8604 end Is_Ref_To_Bit_Packed_Array;
8606 --------------------------------
8607 -- Is_Ref_To_Bit_Packed_Slice --
8608 --------------------------------
8610 function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
8612 if Nkind (N) = N_Type_Conversion then
8613 return Is_Ref_To_Bit_Packed_Slice (Expression (N));
8615 elsif Is_Entity_Name (N)
8616 and then Is_Object (Entity (N))
8617 and then Present (Renamed_Object (Entity (N)))
8619 return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
8621 elsif Nkind (N) = N_Slice
8622 and then Is_Bit_Packed_Array (Etype (Prefix (N)))
8626 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8627 return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
8632 end Is_Ref_To_Bit_Packed_Slice;
8634 -----------------------
8635 -- Is_Renamed_Object --
8636 -----------------------
8638 function Is_Renamed_Object (N : Node_Id) return Boolean is
8639 Pnod : constant Node_Id := Parent (N);
8640 Kind : constant Node_Kind := Nkind (Pnod);
8642 if Kind = N_Object_Renaming_Declaration then
8644 elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
8645 return Is_Renamed_Object (Pnod);
8649 end Is_Renamed_Object;
8651 --------------------------------------
8652 -- Is_Secondary_Stack_BIP_Func_Call --
8653 --------------------------------------
8655 function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is
8656 Alloc_Nam : Name_Id := No_Name;
8658 Call : Node_Id := Expr;
8663 -- Build-in-place calls usually appear in 'reference format. Note that
8664 -- the accessibility check machinery may add an extra 'reference due to
8665 -- side effect removal.
8667 while Nkind (Call) = N_Reference loop
8668 Call := Prefix (Call);
8671 if Nkind_In (Call, N_Qualified_Expression,
8672 N_Unchecked_Type_Conversion)
8674 Call := Expression (Call);
8677 if Is_Build_In_Place_Function_Call (Call) then
8679 -- Examine all parameter associations of the function call
8681 Param := First (Parameter_Associations (Call));
8682 while Present (Param) loop
8683 if Nkind (Param) = N_Parameter_Association
8684 and then Nkind (Selector_Name (Param)) = N_Identifier
8686 Formal := Selector_Name (Param);
8687 Actual := Explicit_Actual_Parameter (Param);
8689 -- Construct the name of formal BIPalloc. It is much easier to
8690 -- extract the name of the function using an arbitrary formal's
8691 -- scope rather than the Name field of Call.
8693 if Alloc_Nam = No_Name and then Present (Entity (Formal)) then
8696 (Chars (Scope (Entity (Formal))),
8697 BIP_Formal_Suffix (BIP_Alloc_Form));
8700 -- A match for BIPalloc => 2 has been found
8702 if Chars (Formal) = Alloc_Nam
8703 and then Nkind (Actual) = N_Integer_Literal
8704 and then Intval (Actual) = Uint_2
8715 end Is_Secondary_Stack_BIP_Func_Call;
8717 -------------------------------------
8718 -- Is_Tag_To_Class_Wide_Conversion --
8719 -------------------------------------
8721 function Is_Tag_To_Class_Wide_Conversion
8722 (Obj_Id : Entity_Id) return Boolean
8724 Expr : constant Node_Id := Expression (Parent (Obj_Id));
8728 Is_Class_Wide_Type (Etype (Obj_Id))
8729 and then Present (Expr)
8730 and then Nkind (Expr) = N_Unchecked_Type_Conversion
8731 and then Etype (Expression (Expr)) = RTE (RE_Tag);
8732 end Is_Tag_To_Class_Wide_Conversion;
8734 ----------------------------
8735 -- Is_Untagged_Derivation --
8736 ----------------------------
8738 function Is_Untagged_Derivation (T : Entity_Id) return Boolean is
8740 return (not Is_Tagged_Type (T) and then Is_Derived_Type (T))
8742 (Is_Private_Type (T) and then Present (Full_View (T))
8743 and then not Is_Tagged_Type (Full_View (T))
8744 and then Is_Derived_Type (Full_View (T))
8745 and then Etype (Full_View (T)) /= T);
8746 end Is_Untagged_Derivation;
8748 ------------------------------------
8749 -- Is_Untagged_Private_Derivation --
8750 ------------------------------------
8752 function Is_Untagged_Private_Derivation
8753 (Priv_Typ : Entity_Id;
8754 Full_Typ : Entity_Id) return Boolean
8759 and then Is_Untagged_Derivation (Priv_Typ)
8760 and then Is_Private_Type (Etype (Priv_Typ))
8761 and then Present (Full_Typ)
8762 and then Is_Itype (Full_Typ);
8763 end Is_Untagged_Private_Derivation;
8765 ---------------------------
8766 -- Is_Volatile_Reference --
8767 ---------------------------
8769 function Is_Volatile_Reference (N : Node_Id) return Boolean is
8771 -- Only source references are to be treated as volatile, internally
8772 -- generated stuff cannot have volatile external effects.
8774 if not Comes_From_Source (N) then
8777 -- Never true for reference to a type
8779 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
8782 -- Never true for a compile time known constant
8784 elsif Compile_Time_Known_Value (N) then
8787 -- True if object reference with volatile type
8789 elsif Is_Volatile_Object (N) then
8792 -- True if reference to volatile entity
8794 elsif Is_Entity_Name (N) then
8795 return Treat_As_Volatile (Entity (N));
8797 -- True for slice of volatile array
8799 elsif Nkind (N) = N_Slice then
8800 return Is_Volatile_Reference (Prefix (N));
8802 -- True if volatile component
8804 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
8805 if (Is_Entity_Name (Prefix (N))
8806 and then Has_Volatile_Components (Entity (Prefix (N))))
8807 or else (Present (Etype (Prefix (N)))
8808 and then Has_Volatile_Components (Etype (Prefix (N))))
8812 return Is_Volatile_Reference (Prefix (N));
8820 end Is_Volatile_Reference;
8822 --------------------
8823 -- Kill_Dead_Code --
8824 --------------------
8826 procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
8827 W : Boolean := Warn;
8828 -- Set False if warnings suppressed
8832 Remove_Warning_Messages (N);
8834 -- Generate warning if appropriate
8838 -- We suppress the warning if this code is under control of an
8839 -- if statement, whose condition is a simple identifier, and
8840 -- either we are in an instance, or warnings off is set for this
8841 -- identifier. The reason for killing it in the instance case is
8842 -- that it is common and reasonable for code to be deleted in
8843 -- instances for various reasons.
8845 -- Could we use Is_Statically_Unevaluated here???
8847 if Nkind (Parent (N)) = N_If_Statement then
8849 C : constant Node_Id := Condition (Parent (N));
8851 if Nkind (C) = N_Identifier
8854 or else (Present (Entity (C))
8855 and then Has_Warnings_Off (Entity (C))))
8862 -- Generate warning if not suppressed
8866 ("?t?this code can never be executed and has been deleted!",
8871 -- Recurse into block statements and bodies to process declarations
8874 if Nkind (N) = N_Block_Statement
8875 or else Nkind (N) = N_Subprogram_Body
8876 or else Nkind (N) = N_Package_Body
8878 Kill_Dead_Code (Declarations (N), False);
8879 Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
8881 if Nkind (N) = N_Subprogram_Body then
8882 Set_Is_Eliminated (Defining_Entity (N));
8885 elsif Nkind (N) = N_Package_Declaration then
8886 Kill_Dead_Code (Visible_Declarations (Specification (N)));
8887 Kill_Dead_Code (Private_Declarations (Specification (N)));
8889 -- ??? After this point, Delete_Tree has been called on all
8890 -- declarations in Specification (N), so references to entities
8891 -- therein look suspicious.
8894 E : Entity_Id := First_Entity (Defining_Entity (N));
8897 while Present (E) loop
8898 if Ekind (E) = E_Operator then
8899 Set_Is_Eliminated (E);
8906 -- Recurse into composite statement to kill individual statements in
8907 -- particular instantiations.
8909 elsif Nkind (N) = N_If_Statement then
8910 Kill_Dead_Code (Then_Statements (N));
8911 Kill_Dead_Code (Elsif_Parts (N));
8912 Kill_Dead_Code (Else_Statements (N));
8914 elsif Nkind (N) = N_Loop_Statement then
8915 Kill_Dead_Code (Statements (N));
8917 elsif Nkind (N) = N_Case_Statement then
8921 Alt := First (Alternatives (N));
8922 while Present (Alt) loop
8923 Kill_Dead_Code (Statements (Alt));
8928 elsif Nkind (N) = N_Case_Statement_Alternative then
8929 Kill_Dead_Code (Statements (N));
8931 -- Deal with dead instances caused by deleting instantiations
8933 elsif Nkind (N) in N_Generic_Instantiation then
8934 Remove_Dead_Instance (N);
8939 -- Case where argument is a list of nodes to be killed
8941 procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
8948 if Is_Non_Empty_List (L) then
8950 while Present (N) loop
8951 Kill_Dead_Code (N, W);
8958 ------------------------
8959 -- Known_Non_Negative --
8960 ------------------------
8962 function Known_Non_Negative (Opnd : Node_Id) return Boolean is
8964 if Is_OK_Static_Expression (Opnd) and then Expr_Value (Opnd) >= 0 then
8969 Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
8972 Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
8975 end Known_Non_Negative;
8977 -----------------------------
8978 -- Make_CW_Equivalent_Type --
8979 -----------------------------
8981 -- Create a record type used as an equivalent of any member of the class
8982 -- which takes its size from exp.
8984 -- Generate the following code:
8986 -- type Equiv_T is record
8987 -- _parent : T (List of discriminant constraints taken from Exp);
8988 -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
8991 -- ??? Note that this type does not guarantee same alignment as all
8994 function Make_CW_Equivalent_Type
8996 E : Node_Id) return Entity_Id
8998 Loc : constant Source_Ptr := Sloc (E);
8999 Root_Typ : constant Entity_Id := Root_Type (T);
9000 List_Def : constant List_Id := Empty_List;
9001 Comp_List : constant List_Id := New_List;
9002 Equiv_Type : Entity_Id;
9003 Range_Type : Entity_Id;
9004 Str_Type : Entity_Id;
9005 Constr_Root : Entity_Id;
9009 -- If the root type is already constrained, there are no discriminants
9010 -- in the expression.
9012 if not Has_Discriminants (Root_Typ)
9013 or else Is_Constrained (Root_Typ)
9015 Constr_Root := Root_Typ;
9017 -- At this point in the expansion, non-limited view of the type
9018 -- must be available, otherwise the error will be reported later.
9020 if From_Limited_With (Constr_Root)
9021 and then Present (Non_Limited_View (Constr_Root))
9023 Constr_Root := Non_Limited_View (Constr_Root);
9027 Constr_Root := Make_Temporary (Loc, 'R');
9029 -- subtype cstr__n is T (List of discr constraints taken from Exp)
9031 Append_To (List_Def,
9032 Make_Subtype_Declaration (Loc,
9033 Defining_Identifier => Constr_Root,
9034 Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
9037 -- Generate the range subtype declaration
9039 Range_Type := Make_Temporary (Loc, 'G');
9041 if not Is_Interface (Root_Typ) then
9043 -- subtype rg__xx is
9044 -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
9047 Make_Op_Subtract (Loc,
9049 Make_Attribute_Reference (Loc,
9051 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9052 Attribute_Name => Name_Size),
9054 Make_Attribute_Reference (Loc,
9055 Prefix => New_Occurrence_Of (Constr_Root, Loc),
9056 Attribute_Name => Name_Object_Size));
9058 -- subtype rg__xx is
9059 -- Storage_Offset range 1 .. Expr'size / Storage_Unit
9062 Make_Attribute_Reference (Loc,
9064 OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
9065 Attribute_Name => Name_Size);
9068 Set_Paren_Count (Sizexpr, 1);
9070 Append_To (List_Def,
9071 Make_Subtype_Declaration (Loc,
9072 Defining_Identifier => Range_Type,
9073 Subtype_Indication =>
9074 Make_Subtype_Indication (Loc,
9075 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
9076 Constraint => Make_Range_Constraint (Loc,
9079 Low_Bound => Make_Integer_Literal (Loc, 1),
9081 Make_Op_Divide (Loc,
9082 Left_Opnd => Sizexpr,
9083 Right_Opnd => Make_Integer_Literal (Loc,
9084 Intval => System_Storage_Unit)))))));
9086 -- subtype str__nn is Storage_Array (rg__x);
9088 Str_Type := Make_Temporary (Loc, 'S');
9089 Append_To (List_Def,
9090 Make_Subtype_Declaration (Loc,
9091 Defining_Identifier => Str_Type,
9092 Subtype_Indication =>
9093 Make_Subtype_Indication (Loc,
9094 Subtype_Mark => New_Occurrence_Of (RTE (RE_Storage_Array), Loc),
9096 Make_Index_Or_Discriminant_Constraint (Loc,
9098 New_List (New_Occurrence_Of (Range_Type, Loc))))));
9100 -- type Equiv_T is record
9101 -- [ _parent : Tnn; ]
9105 Equiv_Type := Make_Temporary (Loc, 'T');
9106 Set_Ekind (Equiv_Type, E_Record_Type);
9107 Set_Parent_Subtype (Equiv_Type, Constr_Root);
9109 -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
9110 -- treatment for this type. In particular, even though _parent's type
9111 -- is a controlled type or contains controlled components, we do not
9112 -- want to set Has_Controlled_Component on it to avoid making it gain
9113 -- an unwanted _controller component.
9115 Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
9117 -- A class-wide equivalent type does not require initialization
9119 Set_Suppress_Initialization (Equiv_Type);
9121 if not Is_Interface (Root_Typ) then
9122 Append_To (Comp_List,
9123 Make_Component_Declaration (Loc,
9124 Defining_Identifier =>
9125 Make_Defining_Identifier (Loc, Name_uParent),
9126 Component_Definition =>
9127 Make_Component_Definition (Loc,
9128 Aliased_Present => False,
9129 Subtype_Indication => New_Occurrence_Of (Constr_Root, Loc))));
9132 Append_To (Comp_List,
9133 Make_Component_Declaration (Loc,
9134 Defining_Identifier => Make_Temporary (Loc, 'C'),
9135 Component_Definition =>
9136 Make_Component_Definition (Loc,
9137 Aliased_Present => False,
9138 Subtype_Indication => New_Occurrence_Of (Str_Type, Loc))));
9140 Append_To (List_Def,
9141 Make_Full_Type_Declaration (Loc,
9142 Defining_Identifier => Equiv_Type,
9144 Make_Record_Definition (Loc,
9146 Make_Component_List (Loc,
9147 Component_Items => Comp_List,
9148 Variant_Part => Empty))));
9150 -- Suppress all checks during the analysis of the expanded code to avoid
9151 -- the generation of spurious warnings under ZFP run-time.
9153 Insert_Actions (E, List_Def, Suppress => All_Checks);
9155 end Make_CW_Equivalent_Type;
9157 -------------------------
9158 -- Make_Invariant_Call --
9159 -------------------------
9161 function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
9162 Loc : constant Source_Ptr := Sloc (Expr);
9163 Typ : constant Entity_Id := Base_Type (Etype (Expr));
9165 Proc_Id : Entity_Id;
9168 pragma Assert (Has_Invariants (Typ));
9170 Proc_Id := Invariant_Procedure (Typ);
9171 pragma Assert (Present (Proc_Id));
9174 Make_Procedure_Call_Statement (Loc,
9175 Name => New_Occurrence_Of (Proc_Id, Loc),
9176 Parameter_Associations => New_List (Relocate_Node (Expr)));
9177 end Make_Invariant_Call;
9179 ------------------------
9180 -- Make_Literal_Range --
9181 ------------------------
9183 function Make_Literal_Range
9185 Literal_Typ : Entity_Id) return Node_Id
9187 Lo : constant Node_Id :=
9188 New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
9189 Index : constant Entity_Id := Etype (Lo);
9192 Length_Expr : constant Node_Id :=
9193 Make_Op_Subtract (Loc,
9195 Make_Integer_Literal (Loc,
9196 Intval => String_Literal_Length (Literal_Typ)),
9198 Make_Integer_Literal (Loc, 1));
9201 Set_Analyzed (Lo, False);
9203 if Is_Integer_Type (Index) then
9206 Left_Opnd => New_Copy_Tree (Lo),
9207 Right_Opnd => Length_Expr);
9210 Make_Attribute_Reference (Loc,
9211 Attribute_Name => Name_Val,
9212 Prefix => New_Occurrence_Of (Index, Loc),
9213 Expressions => New_List (
9216 Make_Attribute_Reference (Loc,
9217 Attribute_Name => Name_Pos,
9218 Prefix => New_Occurrence_Of (Index, Loc),
9219 Expressions => New_List (New_Copy_Tree (Lo))),
9220 Right_Opnd => Length_Expr)));
9227 end Make_Literal_Range;
9229 --------------------------
9230 -- Make_Non_Empty_Check --
9231 --------------------------
9233 function Make_Non_Empty_Check
9235 N : Node_Id) return Node_Id
9241 Make_Attribute_Reference (Loc,
9242 Attribute_Name => Name_Length,
9243 Prefix => Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
9245 Make_Integer_Literal (Loc, 0));
9246 end Make_Non_Empty_Check;
9248 -------------------------
9249 -- Make_Predicate_Call --
9250 -------------------------
9252 -- WARNING: This routine manages Ghost regions. Return statements must be
9253 -- replaced by gotos which jump to the end of the routine and restore the
9256 function Make_Predicate_Call
9259 Mem : Boolean := False) return Node_Id
9261 Loc : constant Source_Ptr := Sloc (Expr);
9263 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
9264 -- Save the Ghost mode to restore on exit
9267 Func_Id : Entity_Id;
9270 pragma Assert (Present (Predicate_Function (Typ)));
9272 -- The related type may be subject to pragma Ghost. Set the mode now to
9273 -- ensure that the call is properly marked as Ghost.
9275 Set_Ghost_Mode (Typ);
9277 -- Call special membership version if requested and available
9279 if Mem and then Present (Predicate_Function_M (Typ)) then
9280 Func_Id := Predicate_Function_M (Typ);
9282 Func_Id := Predicate_Function (Typ);
9285 -- Case of calling normal predicate function
9288 Make_Function_Call (Loc,
9289 Name => New_Occurrence_Of (Func_Id, Loc),
9290 Parameter_Associations => New_List (Relocate_Node (Expr)));
9292 Restore_Ghost_Mode (Saved_GM);
9295 end Make_Predicate_Call;
9297 --------------------------
9298 -- Make_Predicate_Check --
9299 --------------------------
9301 function Make_Predicate_Check
9303 Expr : Node_Id) return Node_Id
9305 procedure Replace_Subtype_Reference (N : Node_Id);
9306 -- Replace current occurrences of the subtype to which a dynamic
9307 -- predicate applies, by the expression that triggers a predicate
9308 -- check. This is needed for aspect Predicate_Failure, for which
9309 -- we do not generate a wrapper procedure, but simply modify the
9310 -- expression for the pragma of the predicate check.
9312 --------------------------------
9313 -- Replace_Subtype_Reference --
9314 --------------------------------
9316 procedure Replace_Subtype_Reference (N : Node_Id) is
9318 Rewrite (N, New_Copy_Tree (Expr));
9320 -- We want to treat the node as if it comes from source, so
9321 -- that ASIS will not ignore it.
9323 Set_Comes_From_Source (N, True);
9324 end Replace_Subtype_Reference;
9326 procedure Replace_Subtype_References is
9327 new Replace_Type_References_Generic (Replace_Subtype_Reference);
9331 Loc : constant Source_Ptr := Sloc (Expr);
9333 Fail_Expr : Node_Id;
9336 -- Start of processing for Make_Predicate_Check
9339 -- If predicate checks are suppressed, then return a null statement. For
9340 -- this call, we check only the scope setting. If the caller wants to
9341 -- check a specific entity's setting, they must do it manually.
9343 if Predicate_Checks_Suppressed (Empty) then
9344 return Make_Null_Statement (Loc);
9347 -- Do not generate a check within an internal subprogram (stream
9348 -- functions and the like, including including predicate functions).
9350 if Within_Internal_Subprogram then
9351 return Make_Null_Statement (Loc);
9354 -- Compute proper name to use, we need to get this right so that the
9355 -- right set of check policies apply to the Check pragma we are making.
9357 if Has_Dynamic_Predicate_Aspect (Typ) then
9358 Nam := Name_Dynamic_Predicate;
9359 elsif Has_Static_Predicate_Aspect (Typ) then
9360 Nam := Name_Static_Predicate;
9362 Nam := Name_Predicate;
9365 Arg_List := New_List (
9366 Make_Pragma_Argument_Association (Loc,
9367 Expression => Make_Identifier (Loc, Nam)),
9368 Make_Pragma_Argument_Association (Loc,
9369 Expression => Make_Predicate_Call (Typ, Expr)));
9371 -- If subtype has Predicate_Failure defined, add the correponding
9372 -- expression as an additional pragma parameter, after replacing
9373 -- current instances with the expression being checked.
9375 if Has_Aspect (Typ, Aspect_Predicate_Failure) then
9378 (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure)));
9379 Replace_Subtype_References (Fail_Expr, Typ);
9381 Append_To (Arg_List,
9382 Make_Pragma_Argument_Association (Loc,
9383 Expression => Fail_Expr));
9388 Chars => Name_Check,
9389 Pragma_Argument_Associations => Arg_List);
9390 end Make_Predicate_Check;
9392 ----------------------------
9393 -- Make_Subtype_From_Expr --
9394 ----------------------------
9396 -- 1. If Expr is an unconstrained array expression, creates
9397 -- Unc_Type(Expr'first(1)..Expr'last(1),..., Expr'first(n)..Expr'last(n))
9399 -- 2. If Expr is a unconstrained discriminated type expression, creates
9400 -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n)
9402 -- 3. If Expr is class-wide, creates an implicit class-wide subtype
9404 function Make_Subtype_From_Expr
9406 Unc_Typ : Entity_Id;
9407 Related_Id : Entity_Id := Empty) return Node_Id
9409 List_Constr : constant List_Id := New_List;
9410 Loc : constant Source_Ptr := Sloc (E);
9413 Full_Subtyp : Entity_Id;
9414 High_Bound : Entity_Id;
9415 Index_Typ : Entity_Id;
9416 Low_Bound : Entity_Id;
9417 Priv_Subtyp : Entity_Id;
9421 if Is_Private_Type (Unc_Typ)
9422 and then Has_Unknown_Discriminants (Unc_Typ)
9424 -- The caller requests a unique external name for both the private
9425 -- and the full subtype.
9427 if Present (Related_Id) then
9429 Make_Defining_Identifier (Loc,
9430 Chars => New_External_Name (Chars (Related_Id), 'C'));
9432 Make_Defining_Identifier (Loc,
9433 Chars => New_External_Name (Chars (Related_Id), 'P'));
9436 Full_Subtyp := Make_Temporary (Loc, 'C');
9437 Priv_Subtyp := Make_Temporary (Loc, 'P');
9440 -- Prepare the subtype completion. Use the base type to find the
9441 -- underlying type because the type may be a generic actual or an
9442 -- explicit subtype.
9444 Utyp := Underlying_Type (Base_Type (Unc_Typ));
9447 Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
9448 Set_Parent (Full_Exp, Parent (E));
9451 Make_Subtype_Declaration (Loc,
9452 Defining_Identifier => Full_Subtyp,
9453 Subtype_Indication => Make_Subtype_From_Expr (Full_Exp, Utyp)));
9455 -- Define the dummy private subtype
9457 Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
9458 Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
9459 Set_Scope (Priv_Subtyp, Full_Subtyp);
9460 Set_Is_Constrained (Priv_Subtyp);
9461 Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
9462 Set_Is_Itype (Priv_Subtyp);
9463 Set_Associated_Node_For_Itype (Priv_Subtyp, E);
9465 if Is_Tagged_Type (Priv_Subtyp) then
9467 (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
9468 Set_Direct_Primitive_Operations (Priv_Subtyp,
9469 Direct_Primitive_Operations (Unc_Typ));
9472 Set_Full_View (Priv_Subtyp, Full_Subtyp);
9474 return New_Occurrence_Of (Priv_Subtyp, Loc);
9476 elsif Is_Array_Type (Unc_Typ) then
9477 Index_Typ := First_Index (Unc_Typ);
9478 for J in 1 .. Number_Dimensions (Unc_Typ) loop
9480 -- Capture the bounds of each index constraint in case the context
9481 -- is an object declaration of an unconstrained type initialized
9482 -- by a function call:
9484 -- Obj : Unconstr_Typ := Func_Call;
9486 -- This scenario requires secondary scope management and the index
9487 -- constraint cannot depend on the temporary used to capture the
9488 -- result of the function call.
9491 -- Temp : Unconstr_Typ_Ptr := Func_Call'reference;
9492 -- subtype S is Unconstr_Typ (Temp.all'First .. Temp.all'Last);
9493 -- Obj : S := Temp.all;
9494 -- SS_Release; -- Temp is gone at this point, bounds of S are
9498 -- Low_Bound : constant Base_Type (Index_Typ) := E'First (J);
9500 Low_Bound := Make_Temporary (Loc, 'B');
9502 Make_Object_Declaration (Loc,
9503 Defining_Identifier => Low_Bound,
9504 Object_Definition =>
9505 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
9506 Constant_Present => True,
9508 Make_Attribute_Reference (Loc,
9509 Prefix => Duplicate_Subexpr_No_Checks (E),
9510 Attribute_Name => Name_First,
9511 Expressions => New_List (
9512 Make_Integer_Literal (Loc, J)))));
9515 -- High_Bound : constant Base_Type (Index_Typ) := E'Last (J);
9517 High_Bound := Make_Temporary (Loc, 'B');
9519 Make_Object_Declaration (Loc,
9520 Defining_Identifier => High_Bound,
9521 Object_Definition =>
9522 New_Occurrence_Of (Base_Type (Etype (Index_Typ)), Loc),
9523 Constant_Present => True,
9525 Make_Attribute_Reference (Loc,
9526 Prefix => Duplicate_Subexpr_No_Checks (E),
9527 Attribute_Name => Name_Last,
9528 Expressions => New_List (
9529 Make_Integer_Literal (Loc, J)))));
9531 Append_To (List_Constr,
9533 Low_Bound => New_Occurrence_Of (Low_Bound, Loc),
9534 High_Bound => New_Occurrence_Of (High_Bound, Loc)));
9536 Index_Typ := Next_Index (Index_Typ);
9539 elsif Is_Class_Wide_Type (Unc_Typ) then
9541 CW_Subtype : Entity_Id;
9542 EQ_Typ : Entity_Id := Empty;
9545 -- A class-wide equivalent type is not needed on VM targets
9546 -- because the VM back-ends handle the class-wide object
9547 -- initialization itself (and doesn't need or want the
9548 -- additional intermediate type to handle the assignment).
9550 if Expander_Active and then Tagged_Type_Expansion then
9552 -- If this is the class-wide type of a completion that is a
9553 -- record subtype, set the type of the class-wide type to be
9554 -- the full base type, for use in the expanded code for the
9555 -- equivalent type. Should this be done earlier when the
9556 -- completion is analyzed ???
9558 if Is_Private_Type (Etype (Unc_Typ))
9560 Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
9562 Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
9565 EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
9568 CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
9569 Set_Equivalent_Type (CW_Subtype, EQ_Typ);
9570 Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
9572 return New_Occurrence_Of (CW_Subtype, Loc);
9575 -- Indefinite record type with discriminants
9578 D := First_Discriminant (Unc_Typ);
9579 while Present (D) loop
9580 Append_To (List_Constr,
9581 Make_Selected_Component (Loc,
9582 Prefix => Duplicate_Subexpr_No_Checks (E),
9583 Selector_Name => New_Occurrence_Of (D, Loc)));
9585 Next_Discriminant (D);
9590 Make_Subtype_Indication (Loc,
9591 Subtype_Mark => New_Occurrence_Of (Unc_Typ, Loc),
9593 Make_Index_Or_Discriminant_Constraint (Loc,
9594 Constraints => List_Constr));
9595 end Make_Subtype_From_Expr;
9601 procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id) is
9603 -- NOTE: Most of the routines in Map_Types are intentionally unnested to
9604 -- avoid deep indentation of code.
9606 -- NOTE: Routines which deal with discriminant mapping operate on the
9607 -- [underlying/record] full view of various types because those views
9608 -- contain all discriminants and stored constraints.
9610 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id);
9611 -- Subsidiary to Map_Primitives. Find a primitive in the inheritance or
9612 -- overriding chain starting from Prim whose dispatching type is parent
9613 -- type Par_Typ and add a mapping between the result and primitive Prim.
9615 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
9616 -- Subsidiary to Map_Primitives. Return the next ancestor primitive in
9617 -- the inheritance or overriding chain of subprogram Subp. Return Empty
9618 -- if no such primitive is available.
9620 function Build_Chain
9621 (Par_Typ : Entity_Id;
9622 Deriv_Typ : Entity_Id) return Elist_Id;
9623 -- Subsidiary to Map_Discriminants. Recreate the derivation chain from
9624 -- parent type Par_Typ leading down towards derived type Deriv_Typ. The
9625 -- list has the form:
9629 -- <Ancestor_N> -> <Ancestor_N-1> -> <Ancestor_1> -> Deriv_Typ
9631 -- Note that Par_Typ is not part of the resulting derivation chain
9633 function Discriminated_View (Typ : Entity_Id) return Entity_Id;
9634 -- Return the view of type Typ which could potentially contains either
9635 -- the discriminants or stored constraints of the type.
9637 function Find_Discriminant_Value
9639 Par_Typ : Entity_Id;
9640 Deriv_Typ : Entity_Id;
9641 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id;
9642 -- Subsidiary to Map_Discriminants. Find the value of discriminant Discr
9643 -- in the derivation chain starting from parent type Par_Typ leading to
9644 -- derived type Deriv_Typ. The returned value is one of the following:
9646 -- * An entity which is either a discriminant or a non-discriminant
9647 -- name, and renames/constraints Discr.
9649 -- * An expression which constraints Discr
9651 -- Typ_Elmt is an element of the derivation chain created by routine
9652 -- Build_Chain and denotes the current ancestor being examined.
9654 procedure Map_Discriminants
9655 (Par_Typ : Entity_Id;
9656 Deriv_Typ : Entity_Id);
9657 -- Map each discriminant of type Par_Typ to a meaningful constraint
9658 -- from the point of view of type Deriv_Typ.
9660 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id);
9661 -- Map each primitive of type Par_Typ to a corresponding primitive of
9668 procedure Add_Primitive (Prim : Entity_Id; Par_Typ : Entity_Id) is
9669 Par_Prim : Entity_Id;
9672 -- Inspect the inheritance chain through the Alias attribute and the
9673 -- overriding chain through the Overridden_Operation looking for an
9674 -- ancestor primitive with the appropriate dispatching type.
9677 while Present (Par_Prim) loop
9678 exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
9679 Par_Prim := Ancestor_Primitive (Par_Prim);
9682 -- Create a mapping of the form:
9684 -- parent type primitive -> derived type primitive
9686 if Present (Par_Prim) then
9687 Type_Map.Set (Par_Prim, Prim);
9691 ------------------------
9692 -- Ancestor_Primitive --
9693 ------------------------
9695 function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
9696 Inher_Prim : constant Entity_Id := Alias (Subp);
9697 Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
9700 -- The current subprogram overrides an ancestor primitive
9702 if Present (Over_Prim) then
9705 -- The current subprogram is an internally generated alias of an
9706 -- inherited ancestor primitive.
9708 elsif Present (Inher_Prim) then
9711 -- Otherwise the current subprogram is the root of the inheritance or
9712 -- overriding chain.
9717 end Ancestor_Primitive;
9723 function Build_Chain
9724 (Par_Typ : Entity_Id;
9725 Deriv_Typ : Entity_Id) return Elist_Id
9727 Anc_Typ : Entity_Id;
9729 Curr_Typ : Entity_Id;
9732 Chain := New_Elmt_List;
9734 -- Add the derived type to the derivation chain
9736 Prepend_Elmt (Deriv_Typ, Chain);
9738 -- Examine all ancestors starting from the derived type climbing
9739 -- towards parent type Par_Typ.
9741 Curr_Typ := Deriv_Typ;
9743 -- Handle the case where the current type is a record which
9744 -- derives from a subtype.
9746 -- subtype Sub_Typ is Par_Typ ...
9747 -- type Deriv_Typ is Sub_Typ ...
9749 if Ekind (Curr_Typ) = E_Record_Type
9750 and then Present (Parent_Subtype (Curr_Typ))
9752 Anc_Typ := Parent_Subtype (Curr_Typ);
9754 -- Handle the case where the current type is a record subtype of
9757 -- subtype Sub_Typ1 is Par_Typ ...
9758 -- subtype Sub_Typ2 is Sub_Typ1 ...
9760 elsif Ekind (Curr_Typ) = E_Record_Subtype
9761 and then Present (Cloned_Subtype (Curr_Typ))
9763 Anc_Typ := Cloned_Subtype (Curr_Typ);
9765 -- Otherwise use the direct parent type
9768 Anc_Typ := Etype (Curr_Typ);
9771 -- Use the first subtype when dealing with itypes
9773 if Is_Itype (Anc_Typ) then
9774 Anc_Typ := First_Subtype (Anc_Typ);
9777 -- Work with the view which contains the discriminants and stored
9780 Anc_Typ := Discriminated_View (Anc_Typ);
9782 -- Stop the climb when either the parent type has been reached or
9783 -- there are no more ancestors left to examine.
9785 exit when Anc_Typ = Curr_Typ or else Anc_Typ = Par_Typ;
9787 Prepend_Unique_Elmt (Anc_Typ, Chain);
9788 Curr_Typ := Anc_Typ;
9794 ------------------------
9795 -- Discriminated_View --
9796 ------------------------
9798 function Discriminated_View (Typ : Entity_Id) return Entity_Id is
9804 -- Use the [underlying] full view when dealing with private types
9805 -- because the view contains all inherited discriminants or stored
9808 if Is_Private_Type (T) then
9809 if Present (Underlying_Full_View (T)) then
9810 T := Underlying_Full_View (T);
9812 elsif Present (Full_View (T)) then
9817 -- Use the underlying record view when the type is an extenstion of
9818 -- a parent type with unknown discriminants because the view contains
9819 -- all inherited discriminants or stored constraints.
9821 if Ekind (T) = E_Record_Type
9822 and then Present (Underlying_Record_View (T))
9824 T := Underlying_Record_View (T);
9828 end Discriminated_View;
9830 -----------------------------
9831 -- Find_Discriminant_Value --
9832 -----------------------------
9834 function Find_Discriminant_Value
9836 Par_Typ : Entity_Id;
9837 Deriv_Typ : Entity_Id;
9838 Typ_Elmt : Elmt_Id) return Node_Or_Entity_Id
9840 Discr_Pos : constant Uint := Discriminant_Number (Discr);
9841 Typ : constant Entity_Id := Node (Typ_Elmt);
9843 function Find_Constraint_Value
9844 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id;
9845 -- Given constraint Constr, find what it denotes. This is either:
9847 -- * An entity which is either a discriminant or a name
9851 ---------------------------
9852 -- Find_Constraint_Value --
9853 ---------------------------
9855 function Find_Constraint_Value
9856 (Constr : Node_Or_Entity_Id) return Node_Or_Entity_Id
9859 if Nkind (Constr) in N_Entity then
9861 -- The constraint denotes a discriminant of the curren type
9862 -- which renames the ancestor discriminant:
9865 -- type Typ (D1 : ...; DN : ...) is
9866 -- new Anc (Discr => D1) with ...
9869 if Ekind (Constr) = E_Discriminant then
9871 -- The discriminant belongs to derived type Deriv_Typ. This
9872 -- is the final value for the ancestor discriminant as the
9873 -- derivations chain has been fully exhausted.
9875 if Typ = Deriv_Typ then
9878 -- Otherwise the discriminant may be renamed or constrained
9879 -- at a lower level. Continue looking down the derivation
9884 Find_Discriminant_Value
9887 Deriv_Typ => Deriv_Typ,
9888 Typ_Elmt => Next_Elmt (Typ_Elmt));
9891 -- Otherwise the constraint denotes a reference to some name
9892 -- which results in a Girder discriminant:
9896 -- type Typ (D1 : ...; DN : ...) is
9897 -- new Anc (Discr => Name) with ...
9900 -- Return the name as this is the proper constraint of the
9907 -- The constraint denotes a reference to a name
9909 elsif Is_Entity_Name (Constr) then
9910 return Find_Constraint_Value (Entity (Constr));
9912 -- Otherwise the current constraint is an expression which yields
9913 -- a Girder discriminant:
9915 -- type Typ (D1 : ...; DN : ...) is
9916 -- new Anc (Discr => <expression>) with ...
9919 -- Return the expression as this is the proper constraint of the
9925 end Find_Constraint_Value;
9929 Constrs : constant Elist_Id := Stored_Constraint (Typ);
9931 Constr_Elmt : Elmt_Id;
9933 Typ_Discr : Entity_Id;
9935 -- Start of processing for Find_Discriminant_Value
9938 -- The algorithm for finding the value of a discriminant works as
9939 -- follows. First, it recreates the derivation chain from Par_Typ
9940 -- to Deriv_Typ as a list:
9942 -- Par_Typ (shown for completeness)
9944 -- Ancestor_N <-- head of chain
9948 -- Deriv_Typ <-- tail of chain
9950 -- The algorithm then traces the fate of a parent discriminant down
9951 -- the derivation chain. At each derivation level, the discriminant
9952 -- may be either inherited or constrained.
9954 -- 1) Discriminant is inherited: there are two cases, depending on
9955 -- which type is inheriting.
9957 -- 1.1) Deriv_Typ is inheriting:
9959 -- type Ancestor (D_1 : ...) is tagged ...
9960 -- type Deriv_Typ is new Ancestor ...
9962 -- In this case the inherited discriminant is the final value of
9963 -- the parent discriminant because the end of the derivation chain
9964 -- has been reached.
9966 -- 1.2) Some other type is inheriting:
9968 -- type Ancestor_1 (D_1 : ...) is tagged ...
9969 -- type Ancestor_2 is new Ancestor_1 ...
9971 -- In this case the algorithm continues to trace the fate of the
9972 -- inherited discriminant down the derivation chain because it may
9973 -- be further inherited or constrained.
9975 -- 2) Discriminant is constrained: there are three cases, depending
9976 -- on what the constraint is.
9978 -- 2.1) The constraint is another discriminant (aka renaming):
9980 -- type Ancestor_1 (D_1 : ...) is tagged ...
9981 -- type Ancestor_2 (D_2 : ...) is new Ancestor_1 (D_1 => D_2) ...
9983 -- In this case the constraining discriminant becomes the one to
9984 -- track down the derivation chain. The algorithm already knows
9985 -- that D_2 constrains D_1, therefore if the algorithm finds the
9986 -- value of D_2, then this would also be the value for D_1.
9988 -- 2.2) The constraint is a name (aka Girder):
9991 -- type Ancestor_1 (D_1 : ...) is tagged ...
9992 -- type Ancestor_2 is new Ancestor_1 (D_1 => Name) ...
9994 -- In this case the name is the final value of D_1 because the
9995 -- discriminant cannot be further constrained.
9997 -- 2.3) The constraint is an expression (aka Girder):
9999 -- type Ancestor_1 (D_1 : ...) is tagged ...
10000 -- type Ancestor_2 is new Ancestor_1 (D_1 => 1 + 2) ...
10002 -- Similar to 2.2, the expression is the final value of D_1
10006 -- When a derived type constrains its parent type, all constaints
10007 -- appear in the Stored_Constraint list. Examine the list looking
10008 -- for a positional match.
10010 if Present (Constrs) then
10011 Constr_Elmt := First_Elmt (Constrs);
10012 while Present (Constr_Elmt) loop
10014 -- The position of the current constraint matches that of the
10015 -- ancestor discriminant.
10017 if Pos = Discr_Pos then
10018 return Find_Constraint_Value (Node (Constr_Elmt));
10021 Next_Elmt (Constr_Elmt);
10025 -- Otherwise the derived type does not constraint its parent type in
10026 -- which case it inherits the parent discriminants.
10029 Typ_Discr := First_Discriminant (Typ);
10030 while Present (Typ_Discr) loop
10032 -- The position of the current discriminant matches that of the
10033 -- ancestor discriminant.
10035 if Pos = Discr_Pos then
10036 return Find_Constraint_Value (Typ_Discr);
10039 Next_Discriminant (Typ_Discr);
10044 -- A discriminant must always have a corresponding value. This is
10045 -- either another discriminant, a name, or an expression. If this
10046 -- point is reached, them most likely the derivation chain employs
10047 -- the wrong views of types.
10049 pragma Assert (False);
10052 end Find_Discriminant_Value;
10054 -----------------------
10055 -- Map_Discriminants --
10056 -----------------------
10058 procedure Map_Discriminants
10059 (Par_Typ : Entity_Id;
10060 Deriv_Typ : Entity_Id)
10062 Deriv_Chain : constant Elist_Id := Build_Chain (Par_Typ, Deriv_Typ);
10065 Discr_Val : Node_Or_Entity_Id;
10068 -- Examine each discriminant of parent type Par_Typ and find a
10069 -- suitable value for it from the point of view of derived type
10072 if Has_Discriminants (Par_Typ) then
10073 Discr := First_Discriminant (Par_Typ);
10074 while Present (Discr) loop
10076 Find_Discriminant_Value
10078 Par_Typ => Par_Typ,
10079 Deriv_Typ => Deriv_Typ,
10080 Typ_Elmt => First_Elmt (Deriv_Chain));
10082 -- Create a mapping of the form:
10084 -- parent type discriminant -> value
10086 Type_Map.Set (Discr, Discr_Val);
10088 Next_Discriminant (Discr);
10091 end Map_Discriminants;
10093 --------------------
10094 -- Map_Primitives --
10095 --------------------
10097 procedure Map_Primitives (Par_Typ : Entity_Id; Deriv_Typ : Entity_Id) is
10098 Deriv_Prim : Entity_Id;
10099 Par_Prim : Entity_Id;
10100 Par_Prims : Elist_Id;
10101 Prim_Elmt : Elmt_Id;
10104 -- Inspect the primitives of the derived type and determine whether
10105 -- they relate to the primitives of the parent type. If there is a
10106 -- meaningful relation, create a mapping of the form:
10108 -- parent type primitive -> perived type primitive
10110 if Present (Direct_Primitive_Operations (Deriv_Typ)) then
10111 Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
10112 while Present (Prim_Elmt) loop
10113 Deriv_Prim := Node (Prim_Elmt);
10115 if Is_Subprogram (Deriv_Prim)
10116 and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
10118 Add_Primitive (Deriv_Prim, Par_Typ);
10121 Next_Elmt (Prim_Elmt);
10125 -- If the parent operation is an interface operation, the overriding
10126 -- indicator is not present. Instead, we get from the interface
10127 -- operation the primitive of the current type that implements it.
10129 if Is_Interface (Par_Typ) then
10130 Par_Prims := Collect_Primitive_Operations (Par_Typ);
10132 if Present (Par_Prims) then
10133 Prim_Elmt := First_Elmt (Par_Prims);
10135 while Present (Prim_Elmt) loop
10136 Par_Prim := Node (Prim_Elmt);
10138 Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
10140 if Present (Deriv_Prim) then
10141 Type_Map.Set (Par_Prim, Deriv_Prim);
10144 Next_Elmt (Prim_Elmt);
10148 end Map_Primitives;
10150 -- Start of processing for Map_Types
10153 -- Nothing to do if there are no types to work with
10155 if No (Parent_Type) or else No (Derived_Type) then
10158 -- Nothing to do if the mapping already exists
10160 elsif Type_Map.Get (Parent_Type) = Derived_Type then
10163 -- Nothing to do if both types are not tagged. Note that untagged types
10164 -- do not have primitive operations and their discriminants are already
10165 -- handled by gigi.
10167 elsif not Is_Tagged_Type (Parent_Type)
10168 or else not Is_Tagged_Type (Derived_Type)
10173 -- Create a mapping of the form
10175 -- parent type -> derived type
10177 -- to prevent any subsequent attempts to produce the same relations
10179 Type_Map.Set (Parent_Type, Derived_Type);
10181 -- Create mappings of the form
10183 -- parent type discriminant -> derived type discriminant
10185 -- parent type discriminant -> constraint
10187 -- Note that mapping of discriminants breaks privacy because it needs to
10188 -- work with those views which contains the discriminants and any stored
10192 (Par_Typ => Discriminated_View (Parent_Type),
10193 Deriv_Typ => Discriminated_View (Derived_Type));
10195 -- Create mappings of the form
10197 -- parent type primitive -> derived type primitive
10200 (Par_Typ => Parent_Type,
10201 Deriv_Typ => Derived_Type);
10204 ----------------------------
10205 -- Matching_Standard_Type --
10206 ----------------------------
10208 function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id is
10209 pragma Assert (Is_Scalar_Type (Typ));
10210 Siz : constant Uint := Esize (Typ);
10213 -- Floating-point cases
10215 if Is_Floating_Point_Type (Typ) then
10216 if Siz <= Esize (Standard_Short_Float) then
10217 return Standard_Short_Float;
10218 elsif Siz <= Esize (Standard_Float) then
10219 return Standard_Float;
10220 elsif Siz <= Esize (Standard_Long_Float) then
10221 return Standard_Long_Float;
10222 elsif Siz <= Esize (Standard_Long_Long_Float) then
10223 return Standard_Long_Long_Float;
10225 raise Program_Error;
10228 -- Integer cases (includes fixed-point types)
10230 -- Unsigned integer cases (includes normal enumeration types)
10232 elsif Is_Unsigned_Type (Typ) then
10233 if Siz <= Esize (Standard_Short_Short_Unsigned) then
10234 return Standard_Short_Short_Unsigned;
10235 elsif Siz <= Esize (Standard_Short_Unsigned) then
10236 return Standard_Short_Unsigned;
10237 elsif Siz <= Esize (Standard_Unsigned) then
10238 return Standard_Unsigned;
10239 elsif Siz <= Esize (Standard_Long_Unsigned) then
10240 return Standard_Long_Unsigned;
10241 elsif Siz <= Esize (Standard_Long_Long_Unsigned) then
10242 return Standard_Long_Long_Unsigned;
10244 raise Program_Error;
10247 -- Signed integer cases
10250 if Siz <= Esize (Standard_Short_Short_Integer) then
10251 return Standard_Short_Short_Integer;
10252 elsif Siz <= Esize (Standard_Short_Integer) then
10253 return Standard_Short_Integer;
10254 elsif Siz <= Esize (Standard_Integer) then
10255 return Standard_Integer;
10256 elsif Siz <= Esize (Standard_Long_Integer) then
10257 return Standard_Long_Integer;
10258 elsif Siz <= Esize (Standard_Long_Long_Integer) then
10259 return Standard_Long_Long_Integer;
10261 raise Program_Error;
10264 end Matching_Standard_Type;
10266 -----------------------------
10267 -- May_Generate_Large_Temp --
10268 -----------------------------
10270 -- At the current time, the only types that we return False for (i.e. where
10271 -- we decide we know they cannot generate large temps) are ones where we
10272 -- know the size is 256 bits or less at compile time, and we are still not
10273 -- doing a thorough job on arrays and records ???
10275 function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
10277 if not Size_Known_At_Compile_Time (Typ) then
10280 elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
10283 elsif Is_Array_Type (Typ)
10284 and then Present (Packed_Array_Impl_Type (Typ))
10286 return May_Generate_Large_Temp (Packed_Array_Impl_Type (Typ));
10288 -- We could do more here to find other small types ???
10293 end May_Generate_Large_Temp;
10295 ------------------------
10296 -- Needs_Finalization --
10297 ------------------------
10299 function Needs_Finalization (T : Entity_Id) return Boolean is
10300 function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
10301 -- If type is not frozen yet, check explicitly among its components,
10302 -- because the Has_Controlled_Component flag is not necessarily set.
10304 -----------------------------------
10305 -- Has_Some_Controlled_Component --
10306 -----------------------------------
10308 function Has_Some_Controlled_Component
10309 (Rec : Entity_Id) return Boolean
10314 if Has_Controlled_Component (Rec) then
10317 elsif not Is_Frozen (Rec) then
10318 if Is_Record_Type (Rec) then
10319 Comp := First_Entity (Rec);
10321 while Present (Comp) loop
10322 if not Is_Type (Comp)
10323 and then Needs_Finalization (Etype (Comp))
10328 Next_Entity (Comp);
10335 Is_Array_Type (Rec)
10336 and then Needs_Finalization (Component_Type (Rec));
10341 end Has_Some_Controlled_Component;
10343 -- Start of processing for Needs_Finalization
10346 -- Certain run-time configurations and targets do not provide support
10347 -- for controlled types.
10349 if Restriction_Active (No_Finalization) then
10352 -- C++ types are not considered controlled. It is assumed that the
10353 -- non-Ada side will handle their clean up.
10355 elsif Convention (T) = Convention_CPP then
10358 -- Never needs finalization if Disable_Controlled set
10360 elsif Disable_Controlled (T) then
10363 elsif Is_Class_Wide_Type (T) and then Disable_Controlled (Etype (T)) then
10367 -- Class-wide types are treated as controlled because derivations
10368 -- from the root type can introduce controlled components.
10371 Is_Class_Wide_Type (T)
10372 or else Is_Controlled (T)
10373 or else Has_Some_Controlled_Component (T)
10375 (Is_Concurrent_Type (T)
10376 and then Present (Corresponding_Record_Type (T))
10377 and then Needs_Finalization (Corresponding_Record_Type (T)));
10379 end Needs_Finalization;
10381 ----------------------------
10382 -- Needs_Constant_Address --
10383 ----------------------------
10385 function Needs_Constant_Address
10387 Typ : Entity_Id) return Boolean
10391 -- If we have no initialization of any kind, then we don't need to place
10392 -- any restrictions on the address clause, because the object will be
10393 -- elaborated after the address clause is evaluated. This happens if the
10394 -- declaration has no initial expression, or the type has no implicit
10395 -- initialization, or the object is imported.
10397 -- The same holds for all initialized scalar types and all access types.
10398 -- Packed bit arrays of size up to 64 are represented using a modular
10399 -- type with an initialization (to zero) and can be processed like other
10400 -- initialized scalar types.
10402 -- If the type is controlled, code to attach the object to a
10403 -- finalization chain is generated at the point of declaration, and
10404 -- therefore the elaboration of the object cannot be delayed: the
10405 -- address expression must be a constant.
10407 if No (Expression (Decl))
10408 and then not Needs_Finalization (Typ)
10410 (not Has_Non_Null_Base_Init_Proc (Typ)
10411 or else Is_Imported (Defining_Identifier (Decl)))
10415 elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
10416 or else Is_Access_Type (Typ)
10418 (Is_Bit_Packed_Array (Typ)
10419 and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ)))
10425 -- Otherwise, we require the address clause to be constant because
10426 -- the call to the initialization procedure (or the attach code) has
10427 -- to happen at the point of the declaration.
10429 -- Actually the IP call has been moved to the freeze actions anyway,
10430 -- so maybe we can relax this restriction???
10434 end Needs_Constant_Address;
10436 ----------------------------
10437 -- New_Class_Wide_Subtype --
10438 ----------------------------
10440 function New_Class_Wide_Subtype
10441 (CW_Typ : Entity_Id;
10442 N : Node_Id) return Entity_Id
10444 Res : constant Entity_Id := Create_Itype (E_Void, N);
10445 Res_Name : constant Name_Id := Chars (Res);
10446 Res_Scope : constant Entity_Id := Scope (Res);
10449 Copy_Node (CW_Typ, Res);
10450 Set_Comes_From_Source (Res, False);
10451 Set_Sloc (Res, Sloc (N));
10452 Set_Is_Itype (Res);
10453 Set_Associated_Node_For_Itype (Res, N);
10454 Set_Is_Public (Res, False); -- By default, may be changed below.
10455 Set_Public_Status (Res);
10456 Set_Chars (Res, Res_Name);
10457 Set_Scope (Res, Res_Scope);
10458 Set_Ekind (Res, E_Class_Wide_Subtype);
10459 Set_Next_Entity (Res, Empty);
10460 Set_Etype (Res, Base_Type (CW_Typ));
10461 Set_Is_Frozen (Res, False);
10462 Set_Freeze_Node (Res, Empty);
10464 end New_Class_Wide_Subtype;
10466 --------------------------------
10467 -- Non_Limited_Designated_Type --
10468 ---------------------------------
10470 function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
10471 Desig : constant Entity_Id := Designated_Type (T);
10473 if Has_Non_Limited_View (Desig) then
10474 return Non_Limited_View (Desig);
10478 end Non_Limited_Designated_Type;
10480 -----------------------------------
10481 -- OK_To_Do_Constant_Replacement --
10482 -----------------------------------
10484 function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
10485 ES : constant Entity_Id := Scope (E);
10489 -- Do not replace statically allocated objects, because they may be
10490 -- modified outside the current scope.
10492 if Is_Statically_Allocated (E) then
10495 -- Do not replace aliased or volatile objects, since we don't know what
10496 -- else might change the value.
10498 elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
10501 -- Debug flag -gnatdM disconnects this optimization
10503 elsif Debug_Flag_MM then
10506 -- Otherwise check scopes
10509 CS := Current_Scope;
10512 -- If we are in right scope, replacement is safe
10517 -- Packages do not affect the determination of safety
10519 elsif Ekind (CS) = E_Package then
10520 exit when CS = Standard_Standard;
10523 -- Blocks do not affect the determination of safety
10525 elsif Ekind (CS) = E_Block then
10528 -- Loops do not affect the determination of safety. Note that we
10529 -- kill all current values on entry to a loop, so we are just
10530 -- talking about processing within a loop here.
10532 elsif Ekind (CS) = E_Loop then
10535 -- Otherwise, the reference is dubious, and we cannot be sure that
10536 -- it is safe to do the replacement.
10545 end OK_To_Do_Constant_Replacement;
10547 ------------------------------------
10548 -- Possible_Bit_Aligned_Component --
10549 ------------------------------------
10551 function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
10553 -- Do not process an unanalyzed node because it is not yet decorated and
10554 -- most checks performed below will fail.
10556 if not Analyzed (N) then
10562 -- Case of indexed component
10564 when N_Indexed_Component =>
10566 P : constant Node_Id := Prefix (N);
10567 Ptyp : constant Entity_Id := Etype (P);
10570 -- If we know the component size and it is less than 64, then
10571 -- we are definitely OK. The back end always does assignment of
10572 -- misaligned small objects correctly.
10574 if Known_Static_Component_Size (Ptyp)
10575 and then Component_Size (Ptyp) <= 64
10579 -- Otherwise, we need to test the prefix, to see if we are
10580 -- indexing from a possibly unaligned component.
10583 return Possible_Bit_Aligned_Component (P);
10587 -- Case of selected component
10589 when N_Selected_Component =>
10591 P : constant Node_Id := Prefix (N);
10592 Comp : constant Entity_Id := Entity (Selector_Name (N));
10595 -- If there is no component clause, then we are in the clear
10596 -- since the back end will never misalign a large component
10597 -- unless it is forced to do so. In the clear means we need
10598 -- only the recursive test on the prefix.
10600 if Component_May_Be_Bit_Aligned (Comp) then
10603 return Possible_Bit_Aligned_Component (P);
10607 -- For a slice, test the prefix, if that is possibly misaligned,
10608 -- then for sure the slice is.
10611 return Possible_Bit_Aligned_Component (Prefix (N));
10613 -- For an unchecked conversion, check whether the expression may
10616 when N_Unchecked_Type_Conversion =>
10617 return Possible_Bit_Aligned_Component (Expression (N));
10619 -- If we have none of the above, it means that we have fallen off the
10620 -- top testing prefixes recursively, and we now have a stand alone
10621 -- object, where we don't have a problem, unless this is a renaming,
10622 -- in which case we need to look into the renamed object.
10625 if Is_Entity_Name (N)
10626 and then Present (Renamed_Object (Entity (N)))
10629 Possible_Bit_Aligned_Component (Renamed_Object (Entity (N)));
10634 end Possible_Bit_Aligned_Component;
10636 -----------------------------------------------
10637 -- Process_Statements_For_Controlled_Objects --
10638 -----------------------------------------------
10640 procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
10641 Loc : constant Source_Ptr := Sloc (N);
10643 function Are_Wrapped (L : List_Id) return Boolean;
10644 -- Determine whether list L contains only one statement which is a block
10646 function Wrap_Statements_In_Block
10648 Scop : Entity_Id := Current_Scope) return Node_Id;
10649 -- Given a list of statements L, wrap it in a block statement and return
10650 -- the generated node. Scop is either the current scope or the scope of
10651 -- the context (if applicable).
10657 function Are_Wrapped (L : List_Id) return Boolean is
10658 Stmt : constant Node_Id := First (L);
10662 and then No (Next (Stmt))
10663 and then Nkind (Stmt) = N_Block_Statement;
10666 ------------------------------
10667 -- Wrap_Statements_In_Block --
10668 ------------------------------
10670 function Wrap_Statements_In_Block
10672 Scop : Entity_Id := Current_Scope) return Node_Id
10674 Block_Id : Entity_Id;
10675 Block_Nod : Node_Id;
10676 Iter_Loop : Entity_Id;
10680 Make_Block_Statement (Loc,
10681 Declarations => No_List,
10682 Handled_Statement_Sequence =>
10683 Make_Handled_Sequence_Of_Statements (Loc,
10686 -- Create a label for the block in case the block needs to manage the
10687 -- secondary stack. A label allows for flag Uses_Sec_Stack to be set.
10689 Add_Block_Identifier (Block_Nod, Block_Id);
10691 -- When wrapping the statements of an iterator loop, check whether
10692 -- the loop requires secondary stack management and if so, propagate
10693 -- the appropriate flags to the block. This ensures that the cursor
10694 -- is properly cleaned up at each iteration of the loop.
10696 Iter_Loop := Find_Enclosing_Iterator_Loop (Scop);
10698 if Present (Iter_Loop) then
10699 Set_Uses_Sec_Stack (Block_Id, Uses_Sec_Stack (Iter_Loop));
10701 -- Secondary stack reclamation is suppressed when the associated
10702 -- iterator loop contains a return statement which uses the stack.
10704 Set_Sec_Stack_Needed_For_Return
10705 (Block_Id, Sec_Stack_Needed_For_Return (Iter_Loop));
10709 end Wrap_Statements_In_Block;
10715 -- Start of processing for Process_Statements_For_Controlled_Objects
10718 -- Whenever a non-handled statement list is wrapped in a block, the
10719 -- block must be explicitly analyzed to redecorate all entities in the
10720 -- list and ensure that a finalizer is properly built.
10723 when N_Conditional_Entry_Call
10726 | N_Selective_Accept
10728 -- Check the "then statements" for elsif parts and if statements
10730 if Nkind_In (N, N_Elsif_Part, N_If_Statement)
10731 and then not Is_Empty_List (Then_Statements (N))
10732 and then not Are_Wrapped (Then_Statements (N))
10733 and then Requires_Cleanup_Actions
10734 (Then_Statements (N), False, False)
10736 Block := Wrap_Statements_In_Block (Then_Statements (N));
10737 Set_Then_Statements (N, New_List (Block));
10742 -- Check the "else statements" for conditional entry calls, if
10743 -- statements and selective accepts.
10745 if Nkind_In (N, N_Conditional_Entry_Call,
10747 N_Selective_Accept)
10748 and then not Is_Empty_List (Else_Statements (N))
10749 and then not Are_Wrapped (Else_Statements (N))
10750 and then Requires_Cleanup_Actions
10751 (Else_Statements (N), False, False)
10753 Block := Wrap_Statements_In_Block (Else_Statements (N));
10754 Set_Else_Statements (N, New_List (Block));
10759 when N_Abortable_Part
10760 | N_Accept_Alternative
10761 | N_Case_Statement_Alternative
10762 | N_Delay_Alternative
10763 | N_Entry_Call_Alternative
10764 | N_Exception_Handler
10766 | N_Triggering_Alternative
10768 if not Is_Empty_List (Statements (N))
10769 and then not Are_Wrapped (Statements (N))
10770 and then Requires_Cleanup_Actions (Statements (N), False, False)
10772 if Nkind (N) = N_Loop_Statement
10773 and then Present (Identifier (N))
10776 Wrap_Statements_In_Block
10777 (L => Statements (N),
10778 Scop => Entity (Identifier (N)));
10780 Block := Wrap_Statements_In_Block (Statements (N));
10783 Set_Statements (N, New_List (Block));
10790 end Process_Statements_For_Controlled_Objects;
10796 function Power_Of_Two (N : Node_Id) return Nat is
10797 Typ : constant Entity_Id := Etype (N);
10798 pragma Assert (Is_Integer_Type (Typ));
10800 Siz : constant Nat := UI_To_Int (Esize (Typ));
10804 if not Compile_Time_Known_Value (N) then
10808 Val := Expr_Value (N);
10809 for J in 1 .. Siz - 1 loop
10810 if Val = Uint_2 ** J then
10819 ----------------------
10820 -- Remove_Init_Call --
10821 ----------------------
10823 function Remove_Init_Call
10825 Rep_Clause : Node_Id) return Node_Id
10827 Par : constant Node_Id := Parent (Var);
10828 Typ : constant Entity_Id := Etype (Var);
10830 Init_Proc : Entity_Id;
10831 -- Initialization procedure for Typ
10833 function Find_Init_Call_In_List (From : Node_Id) return Node_Id;
10834 -- Look for init call for Var starting at From and scanning the
10835 -- enclosing list until Rep_Clause or the end of the list is reached.
10837 ----------------------------
10838 -- Find_Init_Call_In_List --
10839 ----------------------------
10841 function Find_Init_Call_In_List (From : Node_Id) return Node_Id is
10842 Init_Call : Node_Id;
10846 while Present (Init_Call) and then Init_Call /= Rep_Clause loop
10847 if Nkind (Init_Call) = N_Procedure_Call_Statement
10848 and then Is_Entity_Name (Name (Init_Call))
10849 and then Entity (Name (Init_Call)) = Init_Proc
10858 end Find_Init_Call_In_List;
10860 Init_Call : Node_Id;
10862 -- Start of processing for Find_Init_Call
10865 if Present (Initialization_Statements (Var)) then
10866 Init_Call := Initialization_Statements (Var);
10867 Set_Initialization_Statements (Var, Empty);
10869 elsif not Has_Non_Null_Base_Init_Proc (Typ) then
10871 -- No init proc for the type, so obviously no call to be found
10876 -- We might be able to handle other cases below by just properly
10877 -- setting Initialization_Statements at the point where the init proc
10878 -- call is generated???
10880 Init_Proc := Base_Init_Proc (Typ);
10882 -- First scan the list containing the declaration of Var
10884 Init_Call := Find_Init_Call_In_List (From => Next (Par));
10886 -- If not found, also look on Var's freeze actions list, if any,
10887 -- since the init call may have been moved there (case of an address
10888 -- clause applying to Var).
10890 if No (Init_Call) and then Present (Freeze_Node (Var)) then
10892 Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
10895 -- If the initialization call has actuals that use the secondary
10896 -- stack, the call may have been wrapped into a temporary block, in
10897 -- which case the block itself has to be removed.
10899 if No (Init_Call) and then Nkind (Next (Par)) = N_Block_Statement then
10901 Blk : constant Node_Id := Next (Par);
10904 (Find_Init_Call_In_List
10905 (First (Statements (Handled_Statement_Sequence (Blk)))))
10913 if Present (Init_Call) then
10914 Remove (Init_Call);
10917 end Remove_Init_Call;
10919 -------------------------
10920 -- Remove_Side_Effects --
10921 -------------------------
10923 procedure Remove_Side_Effects
10925 Name_Req : Boolean := False;
10926 Renaming_Req : Boolean := False;
10927 Variable_Ref : Boolean := False;
10928 Related_Id : Entity_Id := Empty;
10929 Is_Low_Bound : Boolean := False;
10930 Is_High_Bound : Boolean := False;
10931 Check_Side_Effects : Boolean := True)
10933 function Build_Temporary
10936 Related_Nod : Node_Id := Empty) return Entity_Id;
10937 -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Nod
10938 -- is present (xxx is taken from the Chars field of Related_Nod),
10939 -- otherwise it generates an internal temporary.
10941 ---------------------
10942 -- Build_Temporary --
10943 ---------------------
10945 function Build_Temporary
10948 Related_Nod : Node_Id := Empty) return Entity_Id
10950 Temp_Nam : Name_Id;
10953 -- The context requires an external symbol
10955 if Present (Related_Id) then
10956 if Is_Low_Bound then
10957 Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
10958 else pragma Assert (Is_High_Bound);
10959 Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
10962 return Make_Defining_Identifier (Loc, Temp_Nam);
10964 -- Otherwise generate an internal temporary
10967 return Make_Temporary (Loc, Id, Related_Nod);
10969 end Build_Temporary;
10973 Loc : constant Source_Ptr := Sloc (Exp);
10974 Exp_Type : constant Entity_Id := Etype (Exp);
10975 Svg_Suppress : constant Suppress_Record := Scope_Suppress;
10976 Def_Id : Entity_Id;
10979 Ptr_Typ_Decl : Node_Id;
10980 Ref_Type : Entity_Id;
10983 -- Start of processing for Remove_Side_Effects
10986 -- Handle cases in which there is nothing to do. In GNATprove mode,
10987 -- removal of side effects is useful for the light expansion of
10988 -- renamings. This removal should only occur when not inside a
10989 -- generic and not doing a pre-analysis.
10991 if not Expander_Active
10992 and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
10996 -- Cannot generate temporaries if the invocation to remove side effects
10997 -- was issued too early and the type of the expression is not resolved
10998 -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
10999 -- Remove_Side_Effects).
11001 elsif No (Exp_Type)
11002 or else Ekind (Exp_Type) = E_Access_Attribute_Type
11006 -- Nothing to do if prior expansion determined that a function call does
11007 -- not require side effect removal.
11009 elsif Nkind (Exp) = N_Function_Call
11010 and then No_Side_Effect_Removal (Exp)
11014 -- No action needed for side-effect free expressions
11016 elsif Check_Side_Effects
11017 and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
11022 -- The remaining processing is done with all checks suppressed
11024 -- Note: from now on, don't use return statements, instead do a goto
11025 -- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
11027 Scope_Suppress.Suppress := (others => True);
11029 -- If this is an elementary or a small not by-reference record type, and
11030 -- we need to capture the value, just make a constant; this is cheap and
11031 -- objects of both kinds of types can be bit aligned, so it might not be
11032 -- possible to generate a reference to them. Likewise if this is not a
11033 -- name reference, except for a type conversion because we would enter
11034 -- an infinite recursion with Checks.Apply_Predicate_Check if the target
11035 -- type has predicates (and type conversions need a specific treatment
11036 -- anyway, see below). Also do it if we have a volatile reference and
11037 -- Name_Req is not set (see comments for Side_Effect_Free).
11039 if (Is_Elementary_Type (Exp_Type)
11040 or else (Is_Record_Type (Exp_Type)
11041 and then Known_Static_RM_Size (Exp_Type)
11042 and then RM_Size (Exp_Type) <= 64
11043 and then not Has_Discriminants (Exp_Type)
11044 and then not Is_By_Reference_Type (Exp_Type)))
11045 and then (Variable_Ref
11046 or else (not Is_Name_Reference (Exp)
11047 and then Nkind (Exp) /= N_Type_Conversion)
11048 or else (not Name_Req
11049 and then Is_Volatile_Reference (Exp)))
11051 Def_Id := Build_Temporary (Loc, 'R', Exp);
11052 Set_Etype (Def_Id, Exp_Type);
11053 Res := New_Occurrence_Of (Def_Id, Loc);
11055 -- If the expression is a packed reference, it must be reanalyzed and
11056 -- expanded, depending on context. This is the case for actuals where
11057 -- a constraint check may capture the actual before expansion of the
11058 -- call is complete.
11060 if Nkind (Exp) = N_Indexed_Component
11061 and then Is_Packed (Etype (Prefix (Exp)))
11063 Set_Analyzed (Exp, False);
11064 Set_Analyzed (Prefix (Exp), False);
11068 -- Rnn : Exp_Type renames Expr;
11070 if Renaming_Req then
11072 Make_Object_Renaming_Declaration (Loc,
11073 Defining_Identifier => Def_Id,
11074 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11075 Name => Relocate_Node (Exp));
11078 -- Rnn : constant Exp_Type := Expr;
11082 Make_Object_Declaration (Loc,
11083 Defining_Identifier => Def_Id,
11084 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11085 Constant_Present => True,
11086 Expression => Relocate_Node (Exp));
11088 Set_Assignment_OK (E);
11091 Insert_Action (Exp, E);
11093 -- If the expression has the form v.all then we can just capture the
11094 -- pointer, and then do an explicit dereference on the result, but
11095 -- this is not right if this is a volatile reference.
11097 elsif Nkind (Exp) = N_Explicit_Dereference
11098 and then not Is_Volatile_Reference (Exp)
11100 Def_Id := Build_Temporary (Loc, 'R', Exp);
11102 Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
11104 Insert_Action (Exp,
11105 Make_Object_Declaration (Loc,
11106 Defining_Identifier => Def_Id,
11107 Object_Definition =>
11108 New_Occurrence_Of (Etype (Prefix (Exp)), Loc),
11109 Constant_Present => True,
11110 Expression => Relocate_Node (Prefix (Exp))));
11112 -- Similar processing for an unchecked conversion of an expression of
11113 -- the form v.all, where we want the same kind of treatment.
11115 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11116 and then Nkind (Expression (Exp)) = N_Explicit_Dereference
11118 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11121 -- If this is a type conversion, leave the type conversion and remove
11122 -- the side effects in the expression. This is important in several
11123 -- circumstances: for change of representations, and also when this is a
11124 -- view conversion to a smaller object, where gigi can end up creating
11125 -- its own temporary of the wrong size.
11127 elsif Nkind (Exp) = N_Type_Conversion then
11128 Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
11130 -- Generating C code the type conversion of an access to constrained
11131 -- array type into an access to unconstrained array type involves
11132 -- initializing a fat pointer and the expression must be free of
11133 -- side effects to safely compute its bounds.
11135 if Modify_Tree_For_C
11136 and then Is_Access_Type (Etype (Exp))
11137 and then Is_Array_Type (Designated_Type (Etype (Exp)))
11138 and then not Is_Constrained (Designated_Type (Etype (Exp)))
11140 Def_Id := Build_Temporary (Loc, 'R', Exp);
11141 Set_Etype (Def_Id, Exp_Type);
11142 Res := New_Occurrence_Of (Def_Id, Loc);
11144 Insert_Action (Exp,
11145 Make_Object_Declaration (Loc,
11146 Defining_Identifier => Def_Id,
11147 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11148 Constant_Present => True,
11149 Expression => Relocate_Node (Exp)));
11154 -- If this is an unchecked conversion that Gigi can't handle, make
11155 -- a copy or a use a renaming to capture the value.
11157 elsif Nkind (Exp) = N_Unchecked_Type_Conversion
11158 and then not Safe_Unchecked_Type_Conversion (Exp)
11160 if CW_Or_Has_Controlled_Part (Exp_Type) then
11162 -- Use a renaming to capture the expression, rather than create
11163 -- a controlled temporary.
11165 Def_Id := Build_Temporary (Loc, 'R', Exp);
11166 Res := New_Occurrence_Of (Def_Id, Loc);
11168 Insert_Action (Exp,
11169 Make_Object_Renaming_Declaration (Loc,
11170 Defining_Identifier => Def_Id,
11171 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11172 Name => Relocate_Node (Exp)));
11175 Def_Id := Build_Temporary (Loc, 'R', Exp);
11176 Set_Etype (Def_Id, Exp_Type);
11177 Res := New_Occurrence_Of (Def_Id, Loc);
11180 Make_Object_Declaration (Loc,
11181 Defining_Identifier => Def_Id,
11182 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11183 Constant_Present => not Is_Variable (Exp),
11184 Expression => Relocate_Node (Exp));
11186 Set_Assignment_OK (E);
11187 Insert_Action (Exp, E);
11190 -- For expressions that denote names, we can use a renaming scheme.
11191 -- This is needed for correctness in the case of a volatile object of
11192 -- a non-volatile type because the Make_Reference call of the "default"
11193 -- approach would generate an illegal access value (an access value
11194 -- cannot designate such an object - see Analyze_Reference).
11196 elsif Is_Name_Reference (Exp)
11198 -- We skip using this scheme if we have an object of a volatile
11199 -- type and we do not have Name_Req set true (see comments for
11200 -- Side_Effect_Free).
11202 and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
11204 Def_Id := Build_Temporary (Loc, 'R', Exp);
11205 Res := New_Occurrence_Of (Def_Id, Loc);
11207 Insert_Action (Exp,
11208 Make_Object_Renaming_Declaration (Loc,
11209 Defining_Identifier => Def_Id,
11210 Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
11211 Name => Relocate_Node (Exp)));
11213 -- If this is a packed reference, or a selected component with
11214 -- a non-standard representation, a reference to the temporary
11215 -- will be replaced by a copy of the original expression (see
11216 -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be
11217 -- elaborated by gigi, and is of course not to be replaced in-line
11218 -- by the expression it renames, which would defeat the purpose of
11219 -- removing the side-effect.
11221 if Nkind_In (Exp, N_Selected_Component, N_Indexed_Component)
11222 and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
11226 Set_Is_Renaming_Of_Object (Def_Id, False);
11229 -- Avoid generating a variable-sized temporary, by generating the
11230 -- reference just for the function call. The transformation could be
11231 -- refined to apply only when the array component is constrained by a
11234 elsif Nkind (Exp) = N_Selected_Component
11235 and then Nkind (Prefix (Exp)) = N_Function_Call
11236 and then Is_Array_Type (Exp_Type)
11238 Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
11241 -- Otherwise we generate a reference to the expression
11244 -- An expression which is in SPARK mode is considered side effect
11245 -- free if the resulting value is captured by a variable or a
11249 and then Nkind (Parent (Exp)) = N_Object_Declaration
11253 -- When generating C code we cannot consider side effect free object
11254 -- declarations that have discriminants and are initialized by means
11255 -- of a function call since on this target there is no secondary
11256 -- stack to store the return value and the expander may generate an
11257 -- extra call to the function to compute the discriminant value. In
11258 -- addition, for targets that have secondary stack, the expansion of
11259 -- functions with side effects involves the generation of an access
11260 -- type to capture the return value stored in the secondary stack;
11261 -- by contrast when generating C code such expansion generates an
11262 -- internal object declaration (no access type involved) which must
11263 -- be identified here to avoid entering into a never-ending loop
11264 -- generating internal object declarations.
11266 elsif Modify_Tree_For_C
11267 and then Nkind (Parent (Exp)) = N_Object_Declaration
11269 (Nkind (Exp) /= N_Function_Call
11270 or else not Has_Discriminants (Exp_Type)
11271 or else Is_Internal_Name
11272 (Chars (Defining_Identifier (Parent (Exp)))))
11277 -- Special processing for function calls that return a limited type.
11278 -- We need to build a declaration that will enable build-in-place
11279 -- expansion of the call. This is not done if the context is already
11280 -- an object declaration, to prevent infinite recursion.
11282 -- This is relevant only in Ada 2005 mode. In Ada 95 programs we have
11283 -- to accommodate functions returning limited objects by reference.
11285 if Ada_Version >= Ada_2005
11286 and then Nkind (Exp) = N_Function_Call
11287 and then Is_Limited_View (Etype (Exp))
11288 and then Nkind (Parent (Exp)) /= N_Object_Declaration
11291 Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
11296 Make_Object_Declaration (Loc,
11297 Defining_Identifier => Obj,
11298 Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
11299 Expression => Relocate_Node (Exp));
11301 Insert_Action (Exp, Decl);
11302 Set_Etype (Obj, Exp_Type);
11303 Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
11308 Def_Id := Build_Temporary (Loc, 'R', Exp);
11310 -- The regular expansion of functions with side effects involves the
11311 -- generation of an access type to capture the return value found on
11312 -- the secondary stack. Since SPARK (and why) cannot process access
11313 -- types, use a different approach which ignores the secondary stack
11314 -- and "copies" the returned object.
11315 -- When generating C code, no need for a 'reference since the
11316 -- secondary stack is not supported.
11318 if GNATprove_Mode or Modify_Tree_For_C then
11319 Res := New_Occurrence_Of (Def_Id, Loc);
11320 Ref_Type := Exp_Type;
11322 -- Regular expansion utilizing an access type and 'reference
11326 Make_Explicit_Dereference (Loc,
11327 Prefix => New_Occurrence_Of (Def_Id, Loc));
11330 -- type Ann is access all <Exp_Type>;
11332 Ref_Type := Make_Temporary (Loc, 'A');
11335 Make_Full_Type_Declaration (Loc,
11336 Defining_Identifier => Ref_Type,
11338 Make_Access_To_Object_Definition (Loc,
11339 All_Present => True,
11340 Subtype_Indication =>
11341 New_Occurrence_Of (Exp_Type, Loc)));
11343 Insert_Action (Exp, Ptr_Typ_Decl);
11347 if Nkind (E) = N_Explicit_Dereference then
11348 New_Exp := Relocate_Node (Prefix (E));
11351 E := Relocate_Node (E);
11353 -- Do not generate a 'reference in SPARK mode or C generation
11354 -- since the access type is not created in the first place.
11356 if GNATprove_Mode or Modify_Tree_For_C then
11359 -- Otherwise generate reference, marking the value as non-null
11360 -- since we know it cannot be null and we don't want a check.
11363 New_Exp := Make_Reference (Loc, E);
11364 Set_Is_Known_Non_Null (Def_Id);
11368 if Is_Delayed_Aggregate (E) then
11370 -- The expansion of nested aggregates is delayed until the
11371 -- enclosing aggregate is expanded. As aggregates are often
11372 -- qualified, the predicate applies to qualified expressions as
11373 -- well, indicating that the enclosing aggregate has not been
11374 -- expanded yet. At this point the aggregate is part of a
11375 -- stand-alone declaration, and must be fully expanded.
11377 if Nkind (E) = N_Qualified_Expression then
11378 Set_Expansion_Delayed (Expression (E), False);
11379 Set_Analyzed (Expression (E), False);
11381 Set_Expansion_Delayed (E, False);
11384 Set_Analyzed (E, False);
11387 -- Generating C code of object declarations that have discriminants
11388 -- and are initialized by means of a function call we propagate the
11389 -- discriminants of the parent type to the internally built object.
11390 -- This is needed to avoid generating an extra call to the called
11393 -- For example, if we generate here the following declaration, it
11394 -- will be expanded later adding an extra call to evaluate the value
11395 -- of the discriminant (needed to compute the size of the object).
11397 -- type Rec (D : Integer) is ...
11398 -- Obj : constant Rec := SomeFunc;
11400 if Modify_Tree_For_C
11401 and then Nkind (Parent (Exp)) = N_Object_Declaration
11402 and then Has_Discriminants (Exp_Type)
11403 and then Nkind (Exp) = N_Function_Call
11405 Insert_Action (Exp,
11406 Make_Object_Declaration (Loc,
11407 Defining_Identifier => Def_Id,
11408 Object_Definition => New_Copy_Tree
11409 (Object_Definition (Parent (Exp))),
11410 Constant_Present => True,
11411 Expression => New_Exp));
11413 Insert_Action (Exp,
11414 Make_Object_Declaration (Loc,
11415 Defining_Identifier => Def_Id,
11416 Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
11417 Constant_Present => True,
11418 Expression => New_Exp));
11422 -- Preserve the Assignment_OK flag in all copies, since at least one
11423 -- copy may be used in a context where this flag must be set (otherwise
11424 -- why would the flag be set in the first place).
11426 Set_Assignment_OK (Res, Assignment_OK (Exp));
11428 -- Finally rewrite the original expression and we are done
11430 Rewrite (Exp, Res);
11431 Analyze_And_Resolve (Exp, Exp_Type);
11434 Scope_Suppress := Svg_Suppress;
11435 end Remove_Side_Effects;
11437 ------------------------
11438 -- Replace_References --
11439 ------------------------
11441 procedure Replace_References
11443 Par_Typ : Entity_Id;
11444 Deriv_Typ : Entity_Id;
11445 Par_Obj : Entity_Id := Empty;
11446 Deriv_Obj : Entity_Id := Empty)
11448 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean;
11449 -- Determine whether node Ref denotes some component of Deriv_Obj
11451 function Replace_Ref (Ref : Node_Id) return Traverse_Result;
11452 -- Substitute a reference to an entity with the corresponding value
11453 -- stored in table Type_Map.
11455 function Type_Of_Formal
11457 Actual : Node_Id) return Entity_Id;
11458 -- Find the type of the formal parameter which corresponds to actual
11459 -- parameter Actual in subprogram call Call.
11461 ----------------------
11462 -- Is_Deriv_Obj_Ref --
11463 ----------------------
11465 function Is_Deriv_Obj_Ref (Ref : Node_Id) return Boolean is
11466 Par : constant Node_Id := Parent (Ref);
11469 -- Detect the folowing selected component form:
11471 -- Deriv_Obj.(something)
11474 Nkind (Par) = N_Selected_Component
11475 and then Is_Entity_Name (Prefix (Par))
11476 and then Entity (Prefix (Par)) = Deriv_Obj;
11477 end Is_Deriv_Obj_Ref;
11483 function Replace_Ref (Ref : Node_Id) return Traverse_Result is
11484 procedure Remove_Controlling_Arguments (From_Arg : Node_Id);
11485 -- Reset the Controlling_Argument of all function calls that
11486 -- encapsulate node From_Arg.
11488 ----------------------------------
11489 -- Remove_Controlling_Arguments --
11490 ----------------------------------
11492 procedure Remove_Controlling_Arguments (From_Arg : Node_Id) is
11497 while Present (Par) loop
11498 if Nkind (Par) = N_Function_Call
11499 and then Present (Controlling_Argument (Par))
11501 Set_Controlling_Argument (Par, Empty);
11503 -- Prevent the search from going too far
11505 elsif Is_Body_Or_Package_Declaration (Par) then
11509 Par := Parent (Par);
11511 end Remove_Controlling_Arguments;
11515 Context : constant Node_Id := Parent (Ref);
11516 Loc : constant Source_Ptr := Sloc (Ref);
11517 Ref_Id : Entity_Id;
11518 Result : Traverse_Result;
11521 -- The new reference which is intended to substitute the old one
11524 -- The reference designated for replacement. In certain cases this
11525 -- may be a node other than Ref.
11527 Val : Node_Or_Entity_Id;
11528 -- The corresponding value of Ref from the type map
11530 -- Start of processing for Replace_Ref
11533 -- Assume that the input reference is to be replaced and that the
11534 -- traversal should examine the children of the reference.
11539 -- The input denotes a meaningful reference
11541 if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
11542 Ref_Id := Entity (Ref);
11543 Val := Type_Map.Get (Ref_Id);
11545 -- The reference has a corresponding value in the type map, a
11546 -- substitution is possible.
11548 if Present (Val) then
11550 -- The reference denotes a discriminant
11552 if Ekind (Ref_Id) = E_Discriminant then
11553 if Nkind (Val) in N_Entity then
11555 -- The value denotes another discriminant. Replace as
11558 -- _object.Discr -> _object.Val
11560 if Ekind (Val) = E_Discriminant then
11561 New_Ref := New_Occurrence_Of (Val, Loc);
11563 -- Otherwise the value denotes the entity of a name which
11564 -- constraints the discriminant. Replace as follows:
11566 -- _object.Discr -> Val
11569 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11571 New_Ref := New_Occurrence_Of (Val, Loc);
11572 Old_Ref := Parent (Old_Ref);
11575 -- Otherwise the value denotes an arbitrary expression which
11576 -- constraints the discriminant. Replace as follows:
11578 -- _object.Discr -> Val
11581 pragma Assert (Is_Deriv_Obj_Ref (Old_Ref));
11583 New_Ref := New_Copy_Tree (Val);
11584 Old_Ref := Parent (Old_Ref);
11587 -- Otherwise the reference denotes a primitive. Replace as
11590 -- Primitive -> Val
11593 pragma Assert (Nkind (Val) in N_Entity);
11594 New_Ref := New_Occurrence_Of (Val, Loc);
11597 -- The reference mentions the _object parameter of the parent
11598 -- type's DIC or type invariant procedure. Replace as follows:
11600 -- _object -> _object
11602 elsif Present (Par_Obj)
11603 and then Present (Deriv_Obj)
11604 and then Ref_Id = Par_Obj
11606 New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
11608 -- The type of the _object parameter is class-wide when the
11609 -- expression comes from an assertion pragma that applies to
11610 -- an abstract parent type or an interface. The class-wide type
11611 -- facilitates the preanalysis of the expression by treating
11612 -- calls to abstract primitives that mention the current
11613 -- instance of the type as dispatching. Once the calls are
11614 -- remapped to invoke overriding or inherited primitives, the
11615 -- calls no longer need to be dispatching. Examine all function
11616 -- calls that encapsulate the _object parameter and reset their
11617 -- Controlling_Argument attribute.
11619 if Is_Class_Wide_Type (Etype (Par_Obj))
11620 and then Is_Abstract_Type (Root_Type (Etype (Par_Obj)))
11622 Remove_Controlling_Arguments (Old_Ref);
11625 -- The reference to _object acts as an actual parameter in a
11626 -- subprogram call which may be invoking a primitive of the
11629 -- Primitive (... _object ...);
11631 -- The parent type primitive may not be overridden nor
11632 -- inherited when it is declared after the derived type
11635 -- type Parent is tagged private;
11636 -- type Child is new Parent with private;
11637 -- procedure Primitive (Obj : Parent);
11639 -- In this scenario the _object parameter is converted to the
11640 -- parent type. Due to complications with partial/full views
11641 -- and view swaps, the parent type is taken from the formal
11642 -- parameter of the subprogram being called.
11644 if Nkind_In (Context, N_Function_Call,
11645 N_Procedure_Call_Statement)
11646 and then No (Type_Map.Get (Entity (Name (Context))))
11649 Convert_To (Type_Of_Formal (Context, Old_Ref), New_Ref);
11651 -- Do not process the generated type conversion because
11652 -- both the parent type and the derived type are in the
11653 -- Type_Map table. This will clobber the type conversion
11654 -- by resetting its subtype mark.
11659 -- Otherwise there is nothing to replace
11665 if Present (New_Ref) then
11666 Rewrite (Old_Ref, New_Ref);
11668 -- Update the return type when the context of the reference
11669 -- acts as the name of a function call. Note that the update
11670 -- should not be performed when the reference appears as an
11671 -- actual in the call.
11673 if Nkind (Context) = N_Function_Call
11674 and then Name (Context) = Old_Ref
11676 Set_Etype (Context, Etype (Val));
11681 -- Reanalyze the reference due to potential replacements
11683 if Nkind (Old_Ref) in N_Has_Etype then
11684 Set_Analyzed (Old_Ref, False);
11690 procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
11692 --------------------
11693 -- Type_Of_Formal --
11694 --------------------
11696 function Type_Of_Formal
11698 Actual : Node_Id) return Entity_Id
11704 -- Examine the list of actual and formal parameters in parallel
11706 A := First (Parameter_Associations (Call));
11707 F := First_Formal (Entity (Name (Call)));
11708 while Present (A) and then Present (F) loop
11717 -- The actual parameter must always have a corresponding formal
11719 pragma Assert (False);
11722 end Type_Of_Formal;
11724 -- Start of processing for Replace_References
11727 -- Map the attributes of the parent type to the proper corresponding
11728 -- attributes of the derived type.
11731 (Parent_Type => Par_Typ,
11732 Derived_Type => Deriv_Typ);
11734 -- Inspect the input expression and perform substitutions where
11737 Replace_Refs (Expr);
11738 end Replace_References;
11740 -----------------------------
11741 -- Replace_Type_References --
11742 -----------------------------
11744 procedure Replace_Type_References
11747 Obj_Id : Entity_Id)
11749 procedure Replace_Type_Ref (N : Node_Id);
11750 -- Substitute a single reference of the current instance of type Typ
11751 -- with a reference to Obj_Id.
11753 ----------------------
11754 -- Replace_Type_Ref --
11755 ----------------------
11757 procedure Replace_Type_Ref (N : Node_Id) is
11759 -- Decorate the reference to Typ even though it may be rewritten
11760 -- further down. This is done for two reasons:
11762 -- * ASIS has all necessary semantic information in the original
11765 -- * Routines which examine properties of the Original_Node have
11766 -- some semantic information.
11768 if Nkind (N) = N_Identifier then
11769 Set_Entity (N, Typ);
11770 Set_Etype (N, Typ);
11772 elsif Nkind (N) = N_Selected_Component then
11773 Analyze (Prefix (N));
11774 Set_Entity (Selector_Name (N), Typ);
11775 Set_Etype (Selector_Name (N), Typ);
11778 -- Perform the following substitution:
11782 Rewrite (N, New_Occurrence_Of (Obj_Id, Sloc (N)));
11783 Set_Comes_From_Source (N, True);
11784 end Replace_Type_Ref;
11786 procedure Replace_Type_Refs is
11787 new Replace_Type_References_Generic (Replace_Type_Ref);
11789 -- Start of processing for Replace_Type_References
11792 Replace_Type_Refs (Expr, Typ);
11793 end Replace_Type_References;
11795 ---------------------------
11796 -- Represented_As_Scalar --
11797 ---------------------------
11799 function Represented_As_Scalar (T : Entity_Id) return Boolean is
11800 UT : constant Entity_Id := Underlying_Type (T);
11802 return Is_Scalar_Type (UT)
11803 or else (Is_Bit_Packed_Array (UT)
11804 and then Is_Scalar_Type (Packed_Array_Impl_Type (UT)));
11805 end Represented_As_Scalar;
11807 ------------------------------
11808 -- Requires_Cleanup_Actions --
11809 ------------------------------
11811 function Requires_Cleanup_Actions
11813 Lib_Level : Boolean) return Boolean
11815 At_Lib_Level : constant Boolean :=
11817 and then Nkind_In (N, N_Package_Body,
11818 N_Package_Specification);
11819 -- N is at the library level if the top-most context is a package and
11820 -- the path taken to reach N does not inlcude non-package constructs.
11824 when N_Accept_Statement
11825 | N_Block_Statement
11829 | N_Subprogram_Body
11833 Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
11835 (Present (Handled_Statement_Sequence (N))
11837 Requires_Cleanup_Actions
11838 (Statements (Handled_Statement_Sequence (N)),
11839 At_Lib_Level, True));
11841 when N_Package_Specification =>
11843 Requires_Cleanup_Actions
11844 (Visible_Declarations (N), At_Lib_Level, True)
11846 Requires_Cleanup_Actions
11847 (Private_Declarations (N), At_Lib_Level, True);
11852 end Requires_Cleanup_Actions;
11854 ------------------------------
11855 -- Requires_Cleanup_Actions --
11856 ------------------------------
11858 function Requires_Cleanup_Actions
11860 Lib_Level : Boolean;
11861 Nested_Constructs : Boolean) return Boolean
11865 Obj_Id : Entity_Id;
11866 Obj_Typ : Entity_Id;
11867 Pack_Id : Entity_Id;
11872 or else Is_Empty_List (L)
11878 while Present (Decl) loop
11880 -- Library-level tagged types
11882 if Nkind (Decl) = N_Full_Type_Declaration then
11883 Typ := Defining_Identifier (Decl);
11885 -- Ignored Ghost types do not need any cleanup actions because
11886 -- they will not appear in the final tree.
11888 if Is_Ignored_Ghost_Entity (Typ) then
11891 elsif Is_Tagged_Type (Typ)
11892 and then Is_Library_Level_Entity (Typ)
11893 and then Convention (Typ) = Convention_Ada
11894 and then Present (Access_Disp_Table (Typ))
11895 and then RTE_Available (RE_Unregister_Tag)
11896 and then not Is_Abstract_Type (Typ)
11897 and then not No_Run_Time_Mode
11902 -- Regular object declarations
11904 elsif Nkind (Decl) = N_Object_Declaration then
11905 Obj_Id := Defining_Identifier (Decl);
11906 Obj_Typ := Base_Type (Etype (Obj_Id));
11907 Expr := Expression (Decl);
11909 -- Bypass any form of processing for objects which have their
11910 -- finalization disabled. This applies only to objects at the
11913 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
11916 -- Finalization of transient objects are treated separately in
11917 -- order to handle sensitive cases. These include:
11919 -- * Aggregate expansion
11920 -- * If, case, and expression with actions expansion
11921 -- * Transient scopes
11923 -- If one of those contexts has marked the transient object as
11924 -- ignored, do not generate finalization actions for it.
11926 elsif Is_Finalized_Transient (Obj_Id)
11927 or else Is_Ignored_Transient (Obj_Id)
11931 -- Ignored Ghost objects do not need any cleanup actions because
11932 -- they will not appear in the final tree.
11934 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
11937 -- The expansion of iterator loops generates an object declaration
11938 -- where the Ekind is explicitly set to loop parameter. This is to
11939 -- ensure that the loop parameter behaves as a constant from user
11940 -- code point of view. Such object are never controlled and do not
11941 -- require cleanup actions. An iterator loop over a container of
11942 -- controlled objects does not produce such object declarations.
11944 elsif Ekind (Obj_Id) = E_Loop_Parameter then
11947 -- The object is of the form:
11948 -- Obj : [constant] Typ [:= Expr];
11950 -- Do not process tag-to-class-wide conversions because they do
11951 -- not yield an object. Do not process the incomplete view of a
11952 -- deferred constant. Note that an object initialized by means
11953 -- of a build-in-place function call may appear as a deferred
11954 -- constant after expansion activities. These kinds of objects
11955 -- must be finalized.
11957 elsif not Is_Imported (Obj_Id)
11958 and then Needs_Finalization (Obj_Typ)
11959 and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
11960 and then not (Ekind (Obj_Id) = E_Constant
11961 and then not Has_Completion (Obj_Id)
11962 and then No (BIP_Initialization_Call (Obj_Id)))
11966 -- The object is of the form:
11967 -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
11969 -- Obj : Access_Typ :=
11970 -- BIP_Function_Call (BIPalloc => 2, ...)'reference;
11972 elsif Is_Access_Type (Obj_Typ)
11973 and then Needs_Finalization
11974 (Available_View (Designated_Type (Obj_Typ)))
11975 and then Present (Expr)
11977 (Is_Secondary_Stack_BIP_Func_Call (Expr)
11979 (Is_Non_BIP_Func_Call (Expr)
11980 and then not Is_Related_To_Func_Return (Obj_Id)))
11984 -- Processing for "hook" objects generated for transient objects
11985 -- declared inside an Expression_With_Actions.
11987 elsif Is_Access_Type (Obj_Typ)
11988 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
11989 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
11990 N_Object_Declaration
11994 -- Processing for intermediate results of if expressions where
11995 -- one of the alternatives uses a controlled function call.
11997 elsif Is_Access_Type (Obj_Typ)
11998 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
11999 and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
12000 N_Defining_Identifier
12001 and then Present (Expr)
12002 and then Nkind (Expr) = N_Null
12006 -- Simple protected objects which use type System.Tasking.
12007 -- Protected_Objects.Protection to manage their locks should be
12008 -- treated as controlled since they require manual cleanup.
12010 elsif Ekind (Obj_Id) = E_Variable
12011 and then (Is_Simple_Protected_Type (Obj_Typ)
12012 or else Has_Simple_Protected_Object (Obj_Typ))
12017 -- Specific cases of object renamings
12019 elsif Nkind (Decl) = N_Object_Renaming_Declaration then
12020 Obj_Id := Defining_Identifier (Decl);
12021 Obj_Typ := Base_Type (Etype (Obj_Id));
12023 -- Bypass any form of processing for objects which have their
12024 -- finalization disabled. This applies only to objects at the
12027 if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
12030 -- Ignored Ghost object renamings do not need any cleanup actions
12031 -- because they will not appear in the final tree.
12033 elsif Is_Ignored_Ghost_Entity (Obj_Id) then
12036 -- Return object of a build-in-place function. This case is
12037 -- recognized and marked by the expansion of an extended return
12038 -- statement (see Expand_N_Extended_Return_Statement).
12040 elsif Needs_Finalization (Obj_Typ)
12041 and then Is_Return_Object (Obj_Id)
12042 and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
12046 -- Detect a case where a source object has been initialized by
12047 -- a controlled function call or another object which was later
12048 -- rewritten as a class-wide conversion of Ada.Tags.Displace.
12050 -- Obj1 : CW_Type := Src_Obj;
12051 -- Obj2 : CW_Type := Function_Call (...);
12053 -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
12054 -- Tmp : ... := Function_Call (...)'reference;
12055 -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp));
12057 elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then
12061 -- Inspect the freeze node of an access-to-controlled type and look
12062 -- for a delayed finalization master. This case arises when the
12063 -- freeze actions are inserted at a later time than the expansion of
12064 -- the context. Since Build_Finalizer is never called on a single
12065 -- construct twice, the master will be ultimately left out and never
12066 -- finalized. This is also needed for freeze actions of designated
12067 -- types themselves, since in some cases the finalization master is
12068 -- associated with a designated type's freeze node rather than that
12069 -- of the access type (see handling for freeze actions in
12070 -- Build_Finalization_Master).
12072 elsif Nkind (Decl) = N_Freeze_Entity
12073 and then Present (Actions (Decl))
12075 Typ := Entity (Decl);
12077 -- Freeze nodes for ignored Ghost types do not need cleanup
12078 -- actions because they will never appear in the final tree.
12080 if Is_Ignored_Ghost_Entity (Typ) then
12083 elsif ((Is_Access_Type (Typ)
12084 and then not Is_Access_Subprogram_Type (Typ)
12085 and then Needs_Finalization
12086 (Available_View (Designated_Type (Typ))))
12087 or else (Is_Type (Typ) and then Needs_Finalization (Typ)))
12088 and then Requires_Cleanup_Actions
12089 (Actions (Decl), Lib_Level, Nested_Constructs)
12094 -- Nested package declarations
12096 elsif Nested_Constructs
12097 and then Nkind (Decl) = N_Package_Declaration
12099 Pack_Id := Defining_Entity (Decl);
12101 -- Do not inspect an ignored Ghost package because all code found
12102 -- within will not appear in the final tree.
12104 if Is_Ignored_Ghost_Entity (Pack_Id) then
12107 elsif Ekind (Pack_Id) /= E_Generic_Package
12108 and then Requires_Cleanup_Actions
12109 (Specification (Decl), Lib_Level)
12114 -- Nested package bodies
12116 elsif Nested_Constructs and then Nkind (Decl) = N_Package_Body then
12118 -- Do not inspect an ignored Ghost package body because all code
12119 -- found within will not appear in the final tree.
12121 if Is_Ignored_Ghost_Entity (Defining_Entity (Decl)) then
12124 elsif Ekind (Corresponding_Spec (Decl)) /= E_Generic_Package
12125 and then Requires_Cleanup_Actions (Decl, Lib_Level)
12130 elsif Nkind (Decl) = N_Block_Statement
12133 -- Handle a rare case caused by a controlled transient object
12134 -- created as part of a record init proc. The variable is wrapped
12135 -- in a block, but the block is not associated with a transient
12140 -- Handle the case where the original context has been wrapped in
12141 -- a block to avoid interference between exception handlers and
12142 -- At_End handlers. Treat the block as transparent and process its
12145 or else Is_Finalization_Wrapper (Decl))
12147 if Requires_Cleanup_Actions (Decl, Lib_Level) then
12156 end Requires_Cleanup_Actions;
12158 ------------------------------------
12159 -- Safe_Unchecked_Type_Conversion --
12160 ------------------------------------
12162 -- Note: this function knows quite a bit about the exact requirements of
12163 -- Gigi with respect to unchecked type conversions, and its code must be
12164 -- coordinated with any changes in Gigi in this area.
12166 -- The above requirements should be documented in Sinfo ???
12168 function Safe_Unchecked_Type_Conversion (Exp : Node_Id) return Boolean is
12173 Pexp : constant Node_Id := Parent (Exp);
12176 -- If the expression is the RHS of an assignment or object declaration
12177 -- we are always OK because there will always be a target.
12179 -- Object renaming declarations, (generated for view conversions of
12180 -- actuals in inlined calls), like object declarations, provide an
12181 -- explicit type, and are safe as well.
12183 if (Nkind (Pexp) = N_Assignment_Statement
12184 and then Expression (Pexp) = Exp)
12185 or else Nkind_In (Pexp, N_Object_Declaration,
12186 N_Object_Renaming_Declaration)
12190 -- If the expression is the prefix of an N_Selected_Component we should
12191 -- also be OK because GCC knows to look inside the conversion except if
12192 -- the type is discriminated. We assume that we are OK anyway if the
12193 -- type is not set yet or if it is controlled since we can't afford to
12194 -- introduce a temporary in this case.
12196 elsif Nkind (Pexp) = N_Selected_Component
12197 and then Prefix (Pexp) = Exp
12199 if No (Etype (Pexp)) then
12203 not Has_Discriminants (Etype (Pexp))
12204 or else Is_Constrained (Etype (Pexp));
12208 -- Set the output type, this comes from Etype if it is set, otherwise we
12209 -- take it from the subtype mark, which we assume was already fully
12212 if Present (Etype (Exp)) then
12213 Otyp := Etype (Exp);
12215 Otyp := Entity (Subtype_Mark (Exp));
12218 -- The input type always comes from the expression, and we assume this
12219 -- is indeed always analyzed, so we can simply get the Etype.
12221 Ityp := Etype (Expression (Exp));
12223 -- Initialize alignments to unknown so far
12228 -- Replace a concurrent type by its corresponding record type and each
12229 -- type by its underlying type and do the tests on those. The original
12230 -- type may be a private type whose completion is a concurrent type, so
12231 -- find the underlying type first.
12233 if Present (Underlying_Type (Otyp)) then
12234 Otyp := Underlying_Type (Otyp);
12237 if Present (Underlying_Type (Ityp)) then
12238 Ityp := Underlying_Type (Ityp);
12241 if Is_Concurrent_Type (Otyp) then
12242 Otyp := Corresponding_Record_Type (Otyp);
12245 if Is_Concurrent_Type (Ityp) then
12246 Ityp := Corresponding_Record_Type (Ityp);
12249 -- If the base types are the same, we know there is no problem since
12250 -- this conversion will be a noop.
12252 if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
12255 -- Same if this is an upwards conversion of an untagged type, and there
12256 -- are no constraints involved (could be more general???)
12258 elsif Etype (Ityp) = Otyp
12259 and then not Is_Tagged_Type (Ityp)
12260 and then not Has_Discriminants (Ityp)
12261 and then No (First_Rep_Item (Base_Type (Ityp)))
12265 -- If the expression has an access type (object or subprogram) we assume
12266 -- that the conversion is safe, because the size of the target is safe,
12267 -- even if it is a record (which might be treated as having unknown size
12270 elsif Is_Access_Type (Ityp) then
12273 -- If the size of output type is known at compile time, there is never
12274 -- a problem. Note that unconstrained records are considered to be of
12275 -- known size, but we can't consider them that way here, because we are
12276 -- talking about the actual size of the object.
12278 -- We also make sure that in addition to the size being known, we do not
12279 -- have a case which might generate an embarrassingly large temp in
12280 -- stack checking mode.
12282 elsif Size_Known_At_Compile_Time (Otyp)
12284 (not Stack_Checking_Enabled
12285 or else not May_Generate_Large_Temp (Otyp))
12286 and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
12290 -- If either type is tagged, then we know the alignment is OK so Gigi
12291 -- will be able to use pointer punning.
12293 elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
12296 -- If either type is a limited record type, we cannot do a copy, so say
12297 -- safe since there's nothing else we can do.
12299 elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
12302 -- Conversions to and from packed array types are always ignored and
12305 elsif Is_Packed_Array_Impl_Type (Otyp)
12306 or else Is_Packed_Array_Impl_Type (Ityp)
12311 -- The only other cases known to be safe is if the input type's
12312 -- alignment is known to be at least the maximum alignment for the
12313 -- target or if both alignments are known and the output type's
12314 -- alignment is no stricter than the input's. We can use the component
12315 -- type alignment for an array if a type is an unpacked array type.
12317 if Present (Alignment_Clause (Otyp)) then
12318 Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
12320 elsif Is_Array_Type (Otyp)
12321 and then Present (Alignment_Clause (Component_Type (Otyp)))
12323 Oalign := Expr_Value (Expression (Alignment_Clause
12324 (Component_Type (Otyp))));
12327 if Present (Alignment_Clause (Ityp)) then
12328 Ialign := Expr_Value (Expression (Alignment_Clause (Ityp)));
12330 elsif Is_Array_Type (Ityp)
12331 and then Present (Alignment_Clause (Component_Type (Ityp)))
12333 Ialign := Expr_Value (Expression (Alignment_Clause
12334 (Component_Type (Ityp))));
12337 if Ialign /= No_Uint and then Ialign > Maximum_Alignment then
12340 elsif Ialign /= No_Uint
12341 and then Oalign /= No_Uint
12342 and then Ialign <= Oalign
12346 -- Otherwise, Gigi cannot handle this and we must make a temporary
12351 end Safe_Unchecked_Type_Conversion;
12353 ---------------------------------
12354 -- Set_Current_Value_Condition --
12355 ---------------------------------
12357 -- Note: the implementation of this procedure is very closely tied to the
12358 -- implementation of Get_Current_Value_Condition. Here we set required
12359 -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
12360 -- them, so they must have a consistent view.
12362 procedure Set_Current_Value_Condition (Cnode : Node_Id) is
12364 procedure Set_Entity_Current_Value (N : Node_Id);
12365 -- If N is an entity reference, where the entity is of an appropriate
12366 -- kind, then set the current value of this entity to Cnode, unless
12367 -- there is already a definite value set there.
12369 procedure Set_Expression_Current_Value (N : Node_Id);
12370 -- If N is of an appropriate form, sets an appropriate entry in current
12371 -- value fields of relevant entities. Multiple entities can be affected
12372 -- in the case of an AND or AND THEN.
12374 ------------------------------
12375 -- Set_Entity_Current_Value --
12376 ------------------------------
12378 procedure Set_Entity_Current_Value (N : Node_Id) is
12380 if Is_Entity_Name (N) then
12382 Ent : constant Entity_Id := Entity (N);
12385 -- Don't capture if not safe to do so
12387 if not Safe_To_Capture_Value (N, Ent, Cond => True) then
12391 -- Here we have a case where the Current_Value field may need
12392 -- to be set. We set it if it is not already set to a compile
12393 -- time expression value.
12395 -- Note that this represents a decision that one condition
12396 -- blots out another previous one. That's certainly right if
12397 -- they occur at the same level. If the second one is nested,
12398 -- then the decision is neither right nor wrong (it would be
12399 -- equally OK to leave the outer one in place, or take the new
12400 -- inner one. Really we should record both, but our data
12401 -- structures are not that elaborate.
12403 if Nkind (Current_Value (Ent)) not in N_Subexpr then
12404 Set_Current_Value (Ent, Cnode);
12408 end Set_Entity_Current_Value;
12410 ----------------------------------
12411 -- Set_Expression_Current_Value --
12412 ----------------------------------
12414 procedure Set_Expression_Current_Value (N : Node_Id) is
12420 -- Loop to deal with (ignore for now) any NOT operators present. The
12421 -- presence of NOT operators will be handled properly when we call
12422 -- Get_Current_Value_Condition.
12424 while Nkind (Cond) = N_Op_Not loop
12425 Cond := Right_Opnd (Cond);
12428 -- For an AND or AND THEN, recursively process operands
12430 if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
12431 Set_Expression_Current_Value (Left_Opnd (Cond));
12432 Set_Expression_Current_Value (Right_Opnd (Cond));
12436 -- Check possible relational operator
12438 if Nkind (Cond) in N_Op_Compare then
12439 if Compile_Time_Known_Value (Right_Opnd (Cond)) then
12440 Set_Entity_Current_Value (Left_Opnd (Cond));
12441 elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
12442 Set_Entity_Current_Value (Right_Opnd (Cond));
12445 elsif Nkind_In (Cond,
12447 N_Qualified_Expression,
12448 N_Expression_With_Actions)
12450 Set_Expression_Current_Value (Expression (Cond));
12452 -- Check possible boolean variable reference
12455 Set_Entity_Current_Value (Cond);
12457 end Set_Expression_Current_Value;
12459 -- Start of processing for Set_Current_Value_Condition
12462 Set_Expression_Current_Value (Condition (Cnode));
12463 end Set_Current_Value_Condition;
12465 --------------------------
12466 -- Set_Elaboration_Flag --
12467 --------------------------
12469 procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
12470 Loc : constant Source_Ptr := Sloc (N);
12471 Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
12475 if Present (Ent) then
12477 -- Nothing to do if at the compilation unit level, because in this
12478 -- case the flag is set by the binder generated elaboration routine.
12480 if Nkind (Parent (N)) = N_Compilation_Unit then
12483 -- Here we do need to generate an assignment statement
12486 Check_Restriction (No_Elaboration_Code, N);
12488 Make_Assignment_Statement (Loc,
12489 Name => New_Occurrence_Of (Ent, Loc),
12490 Expression => Make_Integer_Literal (Loc, Uint_1));
12492 if Nkind (Parent (N)) = N_Subunit then
12493 Insert_After (Corresponding_Stub (Parent (N)), Asn);
12495 Insert_After (N, Asn);
12500 -- Kill current value indication. This is necessary because the
12501 -- tests of this flag are inserted out of sequence and must not
12502 -- pick up bogus indications of the wrong constant value.
12504 Set_Current_Value (Ent, Empty);
12506 -- If the subprogram is in the current declarative part and
12507 -- 'access has been applied to it, generate an elaboration
12508 -- check at the beginning of the declarations of the body.
12510 if Nkind (N) = N_Subprogram_Body
12511 and then Address_Taken (Spec_Id)
12513 Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function)
12516 Loc : constant Source_Ptr := Sloc (N);
12517 Decls : constant List_Id := Declarations (N);
12521 -- No need to generate this check if first entry in the
12522 -- declaration list is a raise of Program_Error now.
12525 and then Nkind (First (Decls)) = N_Raise_Program_Error
12530 -- Otherwise generate the check
12533 Make_Raise_Program_Error (Loc,
12536 Left_Opnd => New_Occurrence_Of (Ent, Loc),
12537 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
12538 Reason => PE_Access_Before_Elaboration);
12541 Set_Declarations (N, New_List (Chk));
12543 Prepend (Chk, Decls);
12551 end Set_Elaboration_Flag;
12553 ----------------------------
12554 -- Set_Renamed_Subprogram --
12555 ----------------------------
12557 procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
12559 -- If input node is an identifier, we can just reset it
12561 if Nkind (N) = N_Identifier then
12562 Set_Chars (N, Chars (E));
12565 -- Otherwise we have to do a rewrite, preserving Comes_From_Source
12569 CS : constant Boolean := Comes_From_Source (N);
12571 Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
12573 Set_Comes_From_Source (N, CS);
12574 Set_Analyzed (N, True);
12577 end Set_Renamed_Subprogram;
12579 ----------------------
12580 -- Side_Effect_Free --
12581 ----------------------
12583 function Side_Effect_Free
12585 Name_Req : Boolean := False;
12586 Variable_Ref : Boolean := False) return Boolean
12588 Typ : constant Entity_Id := Etype (N);
12589 -- Result type of the expression
12591 function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
12592 -- The argument N is a construct where the Prefix is dereferenced if it
12593 -- is an access type and the result is a variable. The call returns True
12594 -- if the construct is side effect free (not considering side effects in
12595 -- other than the prefix which are to be tested by the caller).
12597 function Within_In_Parameter (N : Node_Id) return Boolean;
12598 -- Determines if N is a subcomponent of a composite in-parameter. If so,
12599 -- N is not side-effect free when the actual is global and modifiable
12600 -- indirectly from within a subprogram, because it may be passed by
12601 -- reference. The front-end must be conservative here and assume that
12602 -- this may happen with any array or record type. On the other hand, we
12603 -- cannot create temporaries for all expressions for which this
12604 -- condition is true, for various reasons that might require clearing up
12605 -- ??? For example, discriminant references that appear out of place, or
12606 -- spurious type errors with class-wide expressions. As a result, we
12607 -- limit the transformation to loop bounds, which is so far the only
12608 -- case that requires it.
12610 -----------------------------
12611 -- Safe_Prefixed_Reference --
12612 -----------------------------
12614 function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
12616 -- If prefix is not side effect free, definitely not safe
12618 if not Side_Effect_Free (Prefix (N), Name_Req, Variable_Ref) then
12621 -- If the prefix is of an access type that is not access-to-constant,
12622 -- then this construct is a variable reference, which means it is to
12623 -- be considered to have side effects if Variable_Ref is set True.
12625 elsif Is_Access_Type (Etype (Prefix (N)))
12626 and then not Is_Access_Constant (Etype (Prefix (N)))
12627 and then Variable_Ref
12629 -- Exception is a prefix that is the result of a previous removal
12630 -- of side-effects.
12632 return Is_Entity_Name (Prefix (N))
12633 and then not Comes_From_Source (Prefix (N))
12634 and then Ekind (Entity (Prefix (N))) = E_Constant
12635 and then Is_Internal_Name (Chars (Entity (Prefix (N))));
12637 -- If the prefix is an explicit dereference then this construct is a
12638 -- variable reference, which means it is to be considered to have
12639 -- side effects if Variable_Ref is True.
12641 -- We do NOT exclude dereferences of access-to-constant types because
12642 -- we handle them as constant view of variables.
12644 elsif Nkind (Prefix (N)) = N_Explicit_Dereference
12645 and then Variable_Ref
12649 -- Note: The following test is the simplest way of solving a complex
12650 -- problem uncovered by the following test (Side effect on loop bound
12651 -- that is a subcomponent of a global variable:
12653 -- with Text_Io; use Text_Io;
12654 -- procedure Tloop is
12657 -- V : Natural := 4;
12658 -- S : String (1..5) := (others => 'a');
12665 -- with procedure Action;
12666 -- procedure Loop_G (Arg : X; Msg : String)
12668 -- procedure Loop_G (Arg : X; Msg : String) is
12670 -- Put_Line ("begin loop_g " & Msg & " will loop till: "
12671 -- & Natural'Image (Arg.V));
12672 -- for Index in 1 .. Arg.V loop
12673 -- Text_Io.Put_Line
12674 -- (Natural'Image (Index) & " " & Arg.S (Index));
12675 -- if Index > 2 then
12679 -- Put_Line ("end loop_g " & Msg);
12682 -- procedure Loop1 is new Loop_G (Modi);
12683 -- procedure Modi is
12686 -- Loop1 (X1, "from modi");
12690 -- Loop1 (X1, "initial");
12693 -- The output of the above program should be:
12695 -- begin loop_g initial will loop till: 4
12699 -- begin loop_g from modi will loop till: 1
12701 -- end loop_g from modi
12703 -- begin loop_g from modi will loop till: 1
12705 -- end loop_g from modi
12706 -- end loop_g initial
12708 -- If a loop bound is a subcomponent of a global variable, a
12709 -- modification of that variable within the loop may incorrectly
12710 -- affect the execution of the loop.
12712 elsif Nkind (Parent (Parent (N))) = N_Loop_Parameter_Specification
12713 and then Within_In_Parameter (Prefix (N))
12714 and then Variable_Ref
12718 -- All other cases are side effect free
12723 end Safe_Prefixed_Reference;
12725 -------------------------
12726 -- Within_In_Parameter --
12727 -------------------------
12729 function Within_In_Parameter (N : Node_Id) return Boolean is
12731 if not Comes_From_Source (N) then
12734 elsif Is_Entity_Name (N) then
12735 return Ekind (Entity (N)) = E_In_Parameter;
12737 elsif Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
12738 return Within_In_Parameter (Prefix (N));
12743 end Within_In_Parameter;
12745 -- Start of processing for Side_Effect_Free
12748 -- If volatile reference, always consider it to have side effects
12750 if Is_Volatile_Reference (N) then
12754 -- Note on checks that could raise Constraint_Error. Strictly, if we
12755 -- take advantage of 11.6, these checks do not count as side effects.
12756 -- However, we would prefer to consider that they are side effects,
12757 -- since the back end CSE does not work very well on expressions which
12758 -- can raise Constraint_Error. On the other hand if we don't consider
12759 -- them to be side effect free, then we get some awkward expansions
12760 -- in -gnato mode, resulting in code insertions at a point where we
12761 -- do not have a clear model for performing the insertions.
12763 -- Special handling for entity names
12765 if Is_Entity_Name (N) then
12767 -- A type reference is always side effect free
12769 if Is_Type (Entity (N)) then
12772 -- Variables are considered to be a side effect if Variable_Ref
12773 -- is set or if we have a volatile reference and Name_Req is off.
12774 -- If Name_Req is True then we can't help returning a name which
12775 -- effectively allows multiple references in any case.
12777 elsif Is_Variable (N, Use_Original_Node => False) then
12778 return not Variable_Ref
12779 and then (not Is_Volatile_Reference (N) or else Name_Req);
12781 -- Any other entity (e.g. a subtype name) is definitely side
12788 -- A value known at compile time is always side effect free
12790 elsif Compile_Time_Known_Value (N) then
12793 -- A variable renaming is not side-effect free, because the renaming
12794 -- will function like a macro in the front-end in some cases, and an
12795 -- assignment can modify the component designated by N, so we need to
12796 -- create a temporary for it.
12798 -- The guard testing for Entity being present is needed at least in
12799 -- the case of rewritten predicate expressions, and may well also be
12800 -- appropriate elsewhere. Obviously we can't go testing the entity
12801 -- field if it does not exist, so it's reasonable to say that this is
12802 -- not the renaming case if it does not exist.
12804 elsif Is_Entity_Name (Original_Node (N))
12805 and then Present (Entity (Original_Node (N)))
12806 and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
12807 and then Ekind (Entity (Original_Node (N))) /= E_Constant
12810 RO : constant Node_Id :=
12811 Renamed_Object (Entity (Original_Node (N)));
12814 -- If the renamed object is an indexed component, or an
12815 -- explicit dereference, then the designated object could
12816 -- be modified by an assignment.
12818 if Nkind_In (RO, N_Indexed_Component,
12819 N_Explicit_Dereference)
12823 -- A selected component must have a safe prefix
12825 elsif Nkind (RO) = N_Selected_Component then
12826 return Safe_Prefixed_Reference (RO);
12828 -- In all other cases, designated object cannot be changed so
12829 -- we are side effect free.
12836 -- Remove_Side_Effects generates an object renaming declaration to
12837 -- capture the expression of a class-wide expression. In VM targets
12838 -- the frontend performs no expansion for dispatching calls to
12839 -- class- wide types since they are handled by the VM. Hence, we must
12840 -- locate here if this node corresponds to a previous invocation of
12841 -- Remove_Side_Effects to avoid a never ending loop in the frontend.
12843 elsif not Tagged_Type_Expansion
12844 and then not Comes_From_Source (N)
12845 and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
12846 and then Is_Class_Wide_Type (Typ)
12850 -- Generating C the type conversion of an access to constrained array
12851 -- type into an access to unconstrained array type involves initializing
12852 -- a fat pointer and the expression cannot be assumed to be free of side
12853 -- effects since it must referenced several times to compute its bounds.
12855 elsif Modify_Tree_For_C
12856 and then Nkind (N) = N_Type_Conversion
12857 and then Is_Access_Type (Typ)
12858 and then Is_Array_Type (Designated_Type (Typ))
12859 and then not Is_Constrained (Designated_Type (Typ))
12864 -- For other than entity names and compile time known values,
12865 -- check the node kind for special processing.
12869 -- An attribute reference is side effect free if its expressions
12870 -- are side effect free and its prefix is side effect free or
12871 -- is an entity reference.
12873 -- Is this right? what about x'first where x is a variable???
12875 when N_Attribute_Reference =>
12877 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
12878 and then Attribute_Name (N) /= Name_Input
12879 and then (Is_Entity_Name (Prefix (N))
12880 or else Side_Effect_Free
12881 (Prefix (N), Name_Req, Variable_Ref));
12883 -- A binary operator is side effect free if and both operands are
12884 -- side effect free. For this purpose binary operators include
12885 -- membership tests and short circuit forms.
12888 | N_Membership_Test
12891 return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
12893 Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
12895 -- An explicit dereference is side effect free only if it is
12896 -- a side effect free prefixed reference.
12898 when N_Explicit_Dereference =>
12899 return Safe_Prefixed_Reference (N);
12901 -- An expression with action is side effect free if its expression
12902 -- is side effect free and it has no actions.
12904 when N_Expression_With_Actions =>
12906 Is_Empty_List (Actions (N))
12907 and then Side_Effect_Free
12908 (Expression (N), Name_Req, Variable_Ref);
12910 -- A call to _rep_to_pos is side effect free, since we generate
12911 -- this pure function call ourselves. Moreover it is critically
12912 -- important to make this exception, since otherwise we can have
12913 -- discriminants in array components which don't look side effect
12914 -- free in the case of an array whose index type is an enumeration
12915 -- type with an enumeration rep clause.
12917 -- All other function calls are not side effect free
12919 when N_Function_Call =>
12921 Nkind (Name (N)) = N_Identifier
12922 and then Is_TSS (Name (N), TSS_Rep_To_Pos)
12923 and then Side_Effect_Free
12924 (First (Parameter_Associations (N)),
12925 Name_Req, Variable_Ref);
12927 -- An IF expression is side effect free if it's of a scalar type, and
12928 -- all its components are all side effect free (conditions and then
12929 -- actions and else actions). We restrict to scalar types, since it
12930 -- is annoying to deal with things like (if A then B else C)'First
12931 -- where the type involved is a string type.
12933 when N_If_Expression =>
12935 Is_Scalar_Type (Typ)
12936 and then Side_Effect_Free
12937 (Expressions (N), Name_Req, Variable_Ref);
12939 -- An indexed component is side effect free if it is a side
12940 -- effect free prefixed reference and all the indexing
12941 -- expressions are side effect free.
12943 when N_Indexed_Component =>
12945 Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
12946 and then Safe_Prefixed_Reference (N);
12948 -- A type qualification is side effect free if the expression
12949 -- is side effect free.
12951 when N_Qualified_Expression =>
12952 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
12954 -- A selected component is side effect free only if it is a side
12955 -- effect free prefixed reference.
12957 when N_Selected_Component =>
12958 return Safe_Prefixed_Reference (N);
12960 -- A range is side effect free if the bounds are side effect free
12963 return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref)
12965 Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref);
12967 -- A slice is side effect free if it is a side effect free
12968 -- prefixed reference and the bounds are side effect free.
12972 Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
12973 and then Safe_Prefixed_Reference (N);
12975 -- A type conversion is side effect free if the expression to be
12976 -- converted is side effect free.
12978 when N_Type_Conversion =>
12979 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
12981 -- A unary operator is side effect free if the operand
12982 -- is side effect free.
12985 return Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
12987 -- An unchecked type conversion is side effect free only if it
12988 -- is safe and its argument is side effect free.
12990 when N_Unchecked_Type_Conversion =>
12992 Safe_Unchecked_Type_Conversion (N)
12993 and then Side_Effect_Free
12994 (Expression (N), Name_Req, Variable_Ref);
12996 -- An unchecked expression is side effect free if its expression
12997 -- is side effect free.
12999 when N_Unchecked_Expression =>
13000 return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
13002 -- A literal is side effect free
13004 when N_Character_Literal
13005 | N_Integer_Literal
13011 -- We consider that anything else has side effects. This is a bit
13012 -- crude, but we are pretty close for most common cases, and we
13013 -- are certainly correct (i.e. we never return True when the
13014 -- answer should be False).
13019 end Side_Effect_Free;
13021 -- A list is side effect free if all elements of the list are side
13024 function Side_Effect_Free
13026 Name_Req : Boolean := False;
13027 Variable_Ref : Boolean := False) return Boolean
13032 if L = No_List or else L = Error_List then
13037 while Present (N) loop
13038 if not Side_Effect_Free (N, Name_Req, Variable_Ref) then
13047 end Side_Effect_Free;
13049 ----------------------------------
13050 -- Silly_Boolean_Array_Not_Test --
13051 ----------------------------------
13053 -- This procedure implements an odd and silly test. We explicitly check
13054 -- for the case where the 'First of the component type is equal to the
13055 -- 'Last of this component type, and if this is the case, we make sure
13056 -- that constraint error is raised. The reason is that the NOT is bound
13057 -- to cause CE in this case, and we will not otherwise catch it.
13059 -- No such check is required for AND and OR, since for both these cases
13060 -- False op False = False, and True op True = True. For the XOR case,
13061 -- see Silly_Boolean_Array_Xor_Test.
13063 -- Believe it or not, this was reported as a bug. Note that nearly always,
13064 -- the test will evaluate statically to False, so the code will be
13065 -- statically removed, and no extra overhead caused.
13067 procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
13068 Loc : constant Source_Ptr := Sloc (N);
13069 CT : constant Entity_Id := Component_Type (T);
13072 -- The check we install is
13074 -- constraint_error when
13075 -- component_type'first = component_type'last
13076 -- and then array_type'Length /= 0)
13078 -- We need the last guard because we don't want to raise CE for empty
13079 -- arrays since no out of range values result. (Empty arrays with a
13080 -- component type of True .. True -- very useful -- even the ACATS
13081 -- does not test that marginal case).
13084 Make_Raise_Constraint_Error (Loc,
13086 Make_And_Then (Loc,
13090 Make_Attribute_Reference (Loc,
13091 Prefix => New_Occurrence_Of (CT, Loc),
13092 Attribute_Name => Name_First),
13095 Make_Attribute_Reference (Loc,
13096 Prefix => New_Occurrence_Of (CT, Loc),
13097 Attribute_Name => Name_Last)),
13099 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
13100 Reason => CE_Range_Check_Failed));
13101 end Silly_Boolean_Array_Not_Test;
13103 ----------------------------------
13104 -- Silly_Boolean_Array_Xor_Test --
13105 ----------------------------------
13107 -- This procedure implements an odd and silly test. We explicitly check
13108 -- for the XOR case where the component type is True .. True, since this
13109 -- will raise constraint error. A special check is required since CE
13110 -- will not be generated otherwise (cf Expand_Packed_Not).
13112 -- No such check is required for AND and OR, since for both these cases
13113 -- False op False = False, and True op True = True, and no check is
13114 -- required for the case of False .. False, since False xor False = False.
13115 -- See also Silly_Boolean_Array_Not_Test
13117 procedure Silly_Boolean_Array_Xor_Test (N : Node_Id; T : Entity_Id) is
13118 Loc : constant Source_Ptr := Sloc (N);
13119 CT : constant Entity_Id := Component_Type (T);
13122 -- The check we install is
13124 -- constraint_error when
13125 -- Boolean (component_type'First)
13126 -- and then Boolean (component_type'Last)
13127 -- and then array_type'Length /= 0)
13129 -- We need the last guard because we don't want to raise CE for empty
13130 -- arrays since no out of range values result (Empty arrays with a
13131 -- component type of True .. True -- very useful -- even the ACATS
13132 -- does not test that marginal case).
13135 Make_Raise_Constraint_Error (Loc,
13137 Make_And_Then (Loc,
13139 Make_And_Then (Loc,
13141 Convert_To (Standard_Boolean,
13142 Make_Attribute_Reference (Loc,
13143 Prefix => New_Occurrence_Of (CT, Loc),
13144 Attribute_Name => Name_First)),
13147 Convert_To (Standard_Boolean,
13148 Make_Attribute_Reference (Loc,
13149 Prefix => New_Occurrence_Of (CT, Loc),
13150 Attribute_Name => Name_Last))),
13152 Right_Opnd => Make_Non_Empty_Check (Loc, Right_Opnd (N))),
13153 Reason => CE_Range_Check_Failed));
13154 end Silly_Boolean_Array_Xor_Test;
13156 --------------------------
13157 -- Target_Has_Fixed_Ops --
13158 --------------------------
13160 Integer_Sized_Small : Ureal;
13161 -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is
13162 -- called (we don't want to compute it more than once).
13164 Long_Integer_Sized_Small : Ureal;
13165 -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
13166 -- is called (we don't want to compute it more than once)
13168 First_Time_For_THFO : Boolean := True;
13169 -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
13171 function Target_Has_Fixed_Ops
13172 (Left_Typ : Entity_Id;
13173 Right_Typ : Entity_Id;
13174 Result_Typ : Entity_Id) return Boolean
13176 function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
13177 -- Return True if the given type is a fixed-point type with a small
13178 -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
13179 -- an absolute value less than 1.0. This is currently limited to
13180 -- fixed-point types that map to Integer or Long_Integer.
13182 ------------------------
13183 -- Is_Fractional_Type --
13184 ------------------------
13186 function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
13188 if Esize (Typ) = Standard_Integer_Size then
13189 return Small_Value (Typ) = Integer_Sized_Small;
13191 elsif Esize (Typ) = Standard_Long_Integer_Size then
13192 return Small_Value (Typ) = Long_Integer_Sized_Small;
13197 end Is_Fractional_Type;
13199 -- Start of processing for Target_Has_Fixed_Ops
13202 -- Return False if Fractional_Fixed_Ops_On_Target is false
13204 if not Fractional_Fixed_Ops_On_Target then
13208 -- Here the target has Fractional_Fixed_Ops, if first time, compute
13209 -- standard constants used by Is_Fractional_Type.
13211 if First_Time_For_THFO then
13212 First_Time_For_THFO := False;
13214 Integer_Sized_Small :=
13217 Den => UI_From_Int (Standard_Integer_Size - 1),
13220 Long_Integer_Sized_Small :=
13223 Den => UI_From_Int (Standard_Long_Integer_Size - 1),
13227 -- Return True if target supports fixed-by-fixed multiply/divide for
13228 -- fractional fixed-point types (see Is_Fractional_Type) and the operand
13229 -- and result types are equivalent fractional types.
13231 return Is_Fractional_Type (Base_Type (Left_Typ))
13232 and then Is_Fractional_Type (Base_Type (Right_Typ))
13233 and then Is_Fractional_Type (Base_Type (Result_Typ))
13234 and then Esize (Left_Typ) = Esize (Right_Typ)
13235 and then Esize (Left_Typ) = Esize (Result_Typ);
13236 end Target_Has_Fixed_Ops;
13238 -------------------
13239 -- Type_Map_Hash --
13240 -------------------
13242 function Type_Map_Hash (Id : Entity_Id) return Type_Map_Header is
13244 return Type_Map_Header (Id mod Type_Map_Size);
13247 ------------------------------------------
13248 -- Type_May_Have_Bit_Aligned_Components --
13249 ------------------------------------------
13251 function Type_May_Have_Bit_Aligned_Components
13252 (Typ : Entity_Id) return Boolean
13255 -- Array type, check component type
13257 if Is_Array_Type (Typ) then
13259 Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
13261 -- Record type, check components
13263 elsif Is_Record_Type (Typ) then
13268 E := First_Component_Or_Discriminant (Typ);
13269 while Present (E) loop
13270 if Component_May_Be_Bit_Aligned (E)
13271 or else Type_May_Have_Bit_Aligned_Components (Etype (E))
13276 Next_Component_Or_Discriminant (E);
13282 -- Type other than array or record is always OK
13287 end Type_May_Have_Bit_Aligned_Components;
13289 -------------------------------
13290 -- Update_Primitives_Mapping --
13291 -------------------------------
13293 procedure Update_Primitives_Mapping
13294 (Inher_Id : Entity_Id;
13295 Subp_Id : Entity_Id)
13299 (Parent_Type => Find_Dispatching_Type (Inher_Id),
13300 Derived_Type => Find_Dispatching_Type (Subp_Id));
13301 end Update_Primitives_Mapping;
13303 ----------------------------------
13304 -- Within_Case_Or_If_Expression --
13305 ----------------------------------
13307 function Within_Case_Or_If_Expression (N : Node_Id) return Boolean is
13311 -- Locate an enclosing case or if expression. Note that these constructs
13312 -- can be expanded into Expression_With_Actions, hence the test of the
13316 while Present (Par) loop
13317 if Nkind_In (Original_Node (Par), N_Case_Expression,
13322 -- Prevent the search from going too far
13324 elsif Is_Body_Or_Package_Declaration (Par) then
13328 Par := Parent (Par);
13332 end Within_Case_Or_If_Expression;
13334 --------------------------------
13335 -- Within_Internal_Subprogram --
13336 --------------------------------
13338 function Within_Internal_Subprogram return Boolean is
13342 S := Current_Scope;
13343 while Present (S) and then not Is_Subprogram (S) loop
13348 and then Get_TSS_Name (S) /= TSS_Null
13349 and then not Is_Predicate_Function (S)
13350 and then not Is_Predicate_Function_M (S);
13351 end Within_Internal_Subprogram;