1 -----------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 with Atree; use Atree;
30 with Casing; use Casing;
31 with Debug; use Debug;
32 with Errout; use Errout;
33 with Elists; use Elists;
34 with Exp_Util; use Exp_Util;
35 with Freeze; use Freeze;
37 with Lib.Xref; use Lib.Xref;
38 with Namet; use Namet;
39 with Nlists; use Nlists;
40 with Nmake; use Nmake;
41 with Output; use Output;
43 with Restrict; use Restrict;
44 with Scans; use Scans;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Eval; use Sem_Eval;
49 with Sem_Res; use Sem_Res;
50 with Sem_Type; use Sem_Type;
51 with Sinfo; use Sinfo;
52 with Sinput; use Sinput;
53 with Snames; use Snames;
54 with Stand; use Stand;
56 with Stringt; use Stringt;
57 with Targparm; use Targparm;
58 with Tbuild; use Tbuild;
59 with Ttypes; use Ttypes;
61 package body Sem_Util is
63 -----------------------
64 -- Local Subprograms --
65 -----------------------
67 function Build_Component_Subtype
72 -- This function builds the subtype for Build_Actual_Subtype_Of_Component
73 -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
74 -- Loc is the source location, T is the original subtype.
76 --------------------------------
77 -- Add_Access_Type_To_Process --
78 --------------------------------
80 procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id)
84 Ensure_Freeze_Node (E);
85 L := Access_Types_To_Process (Freeze_Node (E));
89 Set_Access_Types_To_Process (Freeze_Node (E), L);
93 end Add_Access_Type_To_Process;
95 -----------------------
96 -- Alignment_In_Bits --
97 -----------------------
99 function Alignment_In_Bits (E : Entity_Id) return Uint is
101 return Alignment (E) * System_Storage_Unit;
102 end Alignment_In_Bits;
104 -----------------------------------------
105 -- Apply_Compile_Time_Constraint_Error --
106 -----------------------------------------
108 procedure Apply_Compile_Time_Constraint_Error
111 Ent : Entity_Id := Empty;
112 Typ : Entity_Id := Empty;
113 Loc : Source_Ptr := No_Location;
114 Rep : Boolean := True)
116 Stat : constant Boolean := Is_Static_Expression (N);
126 if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc))
132 -- Now we replace the node by an N_Raise_Constraint_Error node
133 -- This does not need reanalyzing, so set it as analyzed now.
135 Rewrite (N, Make_Raise_Constraint_Error (Sloc (N)));
136 Set_Analyzed (N, True);
138 Set_Raises_Constraint_Error (N);
140 -- If the original expression was marked as static, the result is
141 -- still marked as static, but the Raises_Constraint_Error flag is
142 -- always set so that further static evaluation is not attempted.
145 Set_Is_Static_Expression (N);
147 end Apply_Compile_Time_Constraint_Error;
149 --------------------------
150 -- Build_Actual_Subtype --
151 --------------------------
153 function Build_Actual_Subtype
155 N : Node_Or_Entity_Id)
160 Loc : constant Source_Ptr := Sloc (N);
161 Constraints : List_Id;
167 Disc_Type : Entity_Id;
170 if Nkind (N) = N_Defining_Identifier then
171 Obj := New_Reference_To (N, Loc);
176 if Is_Array_Type (T) then
177 Constraints := New_List;
179 for J in 1 .. Number_Dimensions (T) loop
181 -- Build an array subtype declaration with the nominal
182 -- subtype and the bounds of the actual. Add the declaration
183 -- in front of the local declarations for the subprogram,for
184 -- analysis before any reference to the formal in the body.
187 Make_Attribute_Reference (Loc,
188 Prefix => Duplicate_Subexpr (Obj, Name_Req => True),
189 Attribute_Name => Name_First,
190 Expressions => New_List (
191 Make_Integer_Literal (Loc, J)));
194 Make_Attribute_Reference (Loc,
195 Prefix => Duplicate_Subexpr (Obj, Name_Req => True),
196 Attribute_Name => Name_Last,
197 Expressions => New_List (
198 Make_Integer_Literal (Loc, J)));
200 Append (Make_Range (Loc, Lo, Hi), Constraints);
203 -- If the type has unknown discriminants there is no constrained
206 elsif Has_Unknown_Discriminants (T) then
210 Constraints := New_List;
212 if Is_Private_Type (T) and then No (Full_View (T)) then
214 -- Type is a generic derived type. Inherit discriminants from
217 Disc_Type := Etype (Base_Type (T));
222 Discr := First_Discriminant (Disc_Type);
224 while Present (Discr) loop
225 Append_To (Constraints,
226 Make_Selected_Component (Loc,
227 Prefix => Duplicate_Subexpr (Obj),
228 Selector_Name => New_Occurrence_Of (Discr, Loc)));
229 Next_Discriminant (Discr);
234 Make_Defining_Identifier (Loc,
235 Chars => New_Internal_Name ('S'));
236 Set_Is_Internal (Subt);
239 Make_Subtype_Declaration (Loc,
240 Defining_Identifier => Subt,
241 Subtype_Indication =>
242 Make_Subtype_Indication (Loc,
243 Subtype_Mark => New_Reference_To (T, Loc),
245 Make_Index_Or_Discriminant_Constraint (Loc,
246 Constraints => Constraints)));
248 Mark_Rewrite_Insertion (Decl);
250 end Build_Actual_Subtype;
252 ---------------------------------------
253 -- Build_Actual_Subtype_Of_Component --
254 ---------------------------------------
256 function Build_Actual_Subtype_Of_Component
261 Loc : constant Source_Ptr := Sloc (N);
262 P : constant Node_Id := Prefix (N);
265 Indx_Type : Entity_Id;
267 Deaccessed_T : Entity_Id;
268 -- This is either a copy of T, or if T is an access type, then it is
269 -- the directly designated type of this access type.
271 function Build_Actual_Array_Constraint return List_Id;
272 -- If one or more of the bounds of the component depends on
273 -- discriminants, build actual constraint using the discriminants
276 function Build_Actual_Record_Constraint return List_Id;
277 -- Similar to previous one, for discriminated components constrained
278 -- by the discriminant of the enclosing object.
280 -----------------------------------
281 -- Build_Actual_Array_Constraint --
282 -----------------------------------
284 function Build_Actual_Array_Constraint return List_Id is
285 Constraints : List_Id := New_List;
293 Indx := First_Index (Deaccessed_T);
294 while Present (Indx) loop
295 Old_Lo := Type_Low_Bound (Etype (Indx));
296 Old_Hi := Type_High_Bound (Etype (Indx));
298 if Denotes_Discriminant (Old_Lo) then
300 Make_Selected_Component (Loc,
301 Prefix => New_Copy_Tree (P),
302 Selector_Name => New_Occurrence_Of (Entity (Old_Lo), Loc));
305 Lo := New_Copy_Tree (Old_Lo);
307 -- The new bound will be reanalyzed in the enclosing
308 -- declaration. For literal bounds that come from a type
309 -- declaration, the type of the context must be imposed, so
310 -- insure that analysis will take place. For non-universal
311 -- types this is not strictly necessary.
313 Set_Analyzed (Lo, False);
316 if Denotes_Discriminant (Old_Hi) then
318 Make_Selected_Component (Loc,
319 Prefix => New_Copy_Tree (P),
320 Selector_Name => New_Occurrence_Of (Entity (Old_Hi), Loc));
323 Hi := New_Copy_Tree (Old_Hi);
324 Set_Analyzed (Hi, False);
327 Append (Make_Range (Loc, Lo, Hi), Constraints);
332 end Build_Actual_Array_Constraint;
334 ------------------------------------
335 -- Build_Actual_Record_Constraint --
336 ------------------------------------
338 function Build_Actual_Record_Constraint return List_Id is
339 Constraints : List_Id := New_List;
344 D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
345 while Present (D) loop
347 if Denotes_Discriminant (Node (D)) then
348 D_Val := Make_Selected_Component (Loc,
349 Prefix => New_Copy_Tree (P),
350 Selector_Name => New_Occurrence_Of (Entity (Node (D)), Loc));
353 D_Val := New_Copy_Tree (Node (D));
356 Append (D_Val, Constraints);
361 end Build_Actual_Record_Constraint;
363 -- Start of processing for Build_Actual_Subtype_Of_Component
366 if Nkind (N) = N_Explicit_Dereference then
367 if Is_Composite_Type (T)
368 and then not Is_Constrained (T)
369 and then not (Is_Class_Wide_Type (T)
370 and then Is_Constrained (Root_Type (T)))
371 and then not Has_Unknown_Discriminants (T)
373 -- If the type of the dereference is already constrained, it
374 -- is an actual subtype.
376 if Is_Array_Type (Etype (N))
377 and then Is_Constrained (Etype (N))
381 Remove_Side_Effects (P);
382 return Build_Actual_Subtype (T, N);
389 if Ekind (T) = E_Access_Subtype then
390 Deaccessed_T := Designated_Type (T);
395 if Ekind (Deaccessed_T) = E_Array_Subtype then
397 Id := First_Index (Deaccessed_T);
398 Indx_Type := Underlying_Type (Etype (Id));
400 while Present (Id) loop
402 if Denotes_Discriminant (Type_Low_Bound (Indx_Type)) or else
403 Denotes_Discriminant (Type_High_Bound (Indx_Type))
405 Remove_Side_Effects (P);
407 Build_Component_Subtype (
408 Build_Actual_Array_Constraint, Loc, Base_Type (T));
414 elsif Is_Composite_Type (Deaccessed_T)
415 and then Has_Discriminants (Deaccessed_T)
416 and then not Has_Unknown_Discriminants (Deaccessed_T)
418 D := First_Elmt (Discriminant_Constraint (Deaccessed_T));
419 while Present (D) loop
421 if Denotes_Discriminant (Node (D)) then
422 Remove_Side_Effects (P);
424 Build_Component_Subtype (
425 Build_Actual_Record_Constraint, Loc, Base_Type (T));
432 -- If none of the above, the actual and nominal subtypes are the same.
436 end Build_Actual_Subtype_Of_Component;
438 -----------------------------
439 -- Build_Component_Subtype --
440 -----------------------------
442 function Build_Component_Subtype
453 Make_Defining_Identifier (Loc,
454 Chars => New_Internal_Name ('S'));
455 Set_Is_Internal (Subt);
458 Make_Subtype_Declaration (Loc,
459 Defining_Identifier => Subt,
460 Subtype_Indication =>
461 Make_Subtype_Indication (Loc,
462 Subtype_Mark => New_Reference_To (Base_Type (T), Loc),
464 Make_Index_Or_Discriminant_Constraint (Loc,
467 Mark_Rewrite_Insertion (Decl);
469 end Build_Component_Subtype;
471 --------------------------------------------
472 -- Build_Discriminal_Subtype_Of_Component --
473 --------------------------------------------
475 function Build_Discriminal_Subtype_Of_Component
479 Loc : constant Source_Ptr := Sloc (T);
483 function Build_Discriminal_Array_Constraint return List_Id;
484 -- If one or more of the bounds of the component depends on
485 -- discriminants, build actual constraint using the discriminants
488 function Build_Discriminal_Record_Constraint return List_Id;
489 -- Similar to previous one, for discriminated components constrained
490 -- by the discriminant of the enclosing object.
492 ----------------------------------------
493 -- Build_Discriminal_Array_Constraint --
494 ----------------------------------------
496 function Build_Discriminal_Array_Constraint return List_Id is
497 Constraints : List_Id := New_List;
505 Indx := First_Index (T);
506 while Present (Indx) loop
507 Old_Lo := Type_Low_Bound (Etype (Indx));
508 Old_Hi := Type_High_Bound (Etype (Indx));
510 if Denotes_Discriminant (Old_Lo) then
511 Lo := New_Occurrence_Of (Discriminal (Entity (Old_Lo)), Loc);
514 Lo := New_Copy_Tree (Old_Lo);
517 if Denotes_Discriminant (Old_Hi) then
518 Hi := New_Occurrence_Of (Discriminal (Entity (Old_Hi)), Loc);
521 Hi := New_Copy_Tree (Old_Hi);
524 Append (Make_Range (Loc, Lo, Hi), Constraints);
529 end Build_Discriminal_Array_Constraint;
531 -----------------------------------------
532 -- Build_Discriminal_Record_Constraint --
533 -----------------------------------------
535 function Build_Discriminal_Record_Constraint return List_Id is
536 Constraints : List_Id := New_List;
541 D := First_Elmt (Discriminant_Constraint (T));
542 while Present (D) loop
544 if Denotes_Discriminant (Node (D)) then
546 New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
549 D_Val := New_Copy_Tree (Node (D));
552 Append (D_Val, Constraints);
557 end Build_Discriminal_Record_Constraint;
559 -- Start of processing for Build_Discriminal_Subtype_Of_Component
562 if Ekind (T) = E_Array_Subtype then
564 Id := First_Index (T);
566 while Present (Id) loop
568 if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
569 Denotes_Discriminant (Type_High_Bound (Etype (Id)))
571 return Build_Component_Subtype
572 (Build_Discriminal_Array_Constraint, Loc, T);
578 elsif Ekind (T) = E_Record_Subtype
579 and then Has_Discriminants (T)
580 and then not Has_Unknown_Discriminants (T)
582 D := First_Elmt (Discriminant_Constraint (T));
583 while Present (D) loop
585 if Denotes_Discriminant (Node (D)) then
586 return Build_Component_Subtype
587 (Build_Discriminal_Record_Constraint, Loc, T);
594 -- If none of the above, the actual and nominal subtypes are the same.
598 end Build_Discriminal_Subtype_Of_Component;
600 ------------------------------
601 -- Build_Elaboration_Entity --
602 ------------------------------
604 procedure Build_Elaboration_Entity (N : Node_Id; Spec_Id : Entity_Id) is
605 Loc : constant Source_Ptr := Sloc (N);
606 Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
609 Elab_Ent : Entity_Id;
612 -- Ignore if already constructed
614 if Present (Elaboration_Entity (Spec_Id)) then
618 -- Construct name of elaboration entity as xxx_E, where xxx
619 -- is the unit name with dots replaced by double underscore.
620 -- We have to manually construct this name, since it will
621 -- be elaborated in the outer scope, and thus will not have
622 -- the unit name automatically prepended.
624 Get_Name_String (Unit_Name (Unum));
626 -- Replace the %s by _E
628 Name_Buffer (Name_Len - 1 .. Name_Len) := "_E";
630 -- Replace dots by double underscore
633 while P < Name_Len - 2 loop
634 if Name_Buffer (P) = '.' then
635 Name_Buffer (P + 2 .. Name_Len + 1) :=
636 Name_Buffer (P + 1 .. Name_Len);
637 Name_Len := Name_Len + 1;
638 Name_Buffer (P) := '_';
639 Name_Buffer (P + 1) := '_';
646 -- Create elaboration flag
649 Make_Defining_Identifier (Loc, Chars => Name_Find);
650 Set_Elaboration_Entity (Spec_Id, Elab_Ent);
652 if No (Declarations (Aux_Decls_Node (N))) then
653 Set_Declarations (Aux_Decls_Node (N), New_List);
657 Make_Object_Declaration (Loc,
658 Defining_Identifier => Elab_Ent,
660 New_Occurrence_Of (Standard_Boolean, Loc),
662 New_Occurrence_Of (Standard_False, Loc));
664 Append_To (Declarations (Aux_Decls_Node (N)), Decl);
667 -- Reset True_Constant indication, since we will indeed
668 -- assign a value to the variable in the binder main.
670 Set_Is_True_Constant (Elab_Ent, False);
672 -- We do not want any further qualification of the name (if we did
673 -- not do this, we would pick up the name of the generic package
674 -- in the case of a library level generic instantiation).
676 Set_Has_Qualified_Name (Elab_Ent);
677 Set_Has_Fully_Qualified_Name (Elab_Ent);
678 end Build_Elaboration_Entity;
680 --------------------------
681 -- Check_Fully_Declared --
682 --------------------------
684 procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
686 if Ekind (T) = E_Incomplete_Type then
688 ("premature usage of incomplete}", N, First_Subtype (T));
690 elsif Has_Private_Component (T)
691 and then not Is_Generic_Type (Root_Type (T))
692 and then not In_Default_Expression
695 ("premature usage of incomplete}", N, First_Subtype (T));
697 end Check_Fully_Declared;
699 ------------------------------------------
700 -- Check_Potentially_Blocking_Operation --
701 ------------------------------------------
703 procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
705 Loc : constant Source_Ptr := Sloc (N);
708 -- N is one of the potentially blocking operations listed in
709 -- 9.5.1 (8). When using the Ravenscar profile, raise Program_Error
710 -- before N if the context is a protected action. Otherwise, only issue
711 -- a warning, since some users are relying on blocking operations
712 -- inside protected objects.
713 -- Indirect blocking through a subprogram call
714 -- cannot be diagnosed statically without interprocedural analysis,
715 -- so we do not attempt to do it here.
717 S := Scope (Current_Scope);
719 while Present (S) and then S /= Standard_Standard loop
720 if Is_Protected_Type (S) then
721 if Restricted_Profile then
723 Make_Raise_Statement (Loc,
724 Name => New_Occurrence_Of (Standard_Program_Error, Loc)));
725 Error_Msg_N ("potentially blocking operation, " &
726 " Program Error will be raised at run time?", N);
730 ("potentially blocking operation in protected operation?", N);
738 end Check_Potentially_Blocking_Operation;
744 procedure Check_VMS (Construct : Node_Id) is
746 if not OpenVMS_On_Target then
748 ("this construct is allowed only in Open'V'M'S", Construct);
752 ----------------------------------
753 -- Collect_Primitive_Operations --
754 ----------------------------------
756 function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
757 B_Type : constant Entity_Id := Base_Type (T);
758 B_Decl : constant Node_Id := Original_Node (Parent (B_Type));
759 B_Scope : Entity_Id := Scope (B_Type);
763 Formal_Derived : Boolean := False;
767 -- For tagged types, the primitive operations are collected as they
768 -- are declared, and held in an explicit list which is simply returned.
770 if Is_Tagged_Type (B_Type) then
771 return Primitive_Operations (B_Type);
773 -- An untagged generic type that is a derived type inherits the
774 -- primitive operations of its parent type. Other formal types only
775 -- have predefined operators, which are not explicitly represented.
777 elsif Is_Generic_Type (B_Type) then
778 if Nkind (B_Decl) = N_Formal_Type_Declaration
779 and then Nkind (Formal_Type_Definition (B_Decl))
780 = N_Formal_Derived_Type_Definition
782 Formal_Derived := True;
784 return New_Elmt_List;
788 Op_List := New_Elmt_List;
790 if B_Scope = Standard_Standard then
791 if B_Type = Standard_String then
792 Append_Elmt (Standard_Op_Concat, Op_List);
794 elsif B_Type = Standard_Wide_String then
795 Append_Elmt (Standard_Op_Concatw, Op_List);
801 elsif (Is_Package (B_Scope)
803 Parent (Declaration_Node (First_Subtype (T))))
806 or else Is_Derived_Type (B_Type)
808 -- The primitive operations appear after the base type, except
809 -- if the derivation happens within the private part of B_Scope
810 -- and the type is a private type, in which case both the type
811 -- and some primitive operations may appear before the base
812 -- type, and the list of candidates starts after the type.
814 if In_Open_Scopes (B_Scope)
815 and then Scope (T) = B_Scope
816 and then In_Private_Part (B_Scope)
818 Id := Next_Entity (T);
820 Id := Next_Entity (B_Type);
823 while Present (Id) loop
825 -- Note that generic formal subprograms are not
826 -- considered to be primitive operations and thus
827 -- are never inherited.
829 if Is_Overloadable (Id)
830 and then Nkind (Parent (Parent (Id)))
831 /= N_Formal_Subprogram_Declaration
835 if Base_Type (Etype (Id)) = B_Type then
838 Formal := First_Formal (Id);
839 while Present (Formal) loop
840 if Base_Type (Etype (Formal)) = B_Type then
844 elsif Ekind (Etype (Formal)) = E_Anonymous_Access_Type
846 (Designated_Type (Etype (Formal))) = B_Type
852 Next_Formal (Formal);
856 -- For a formal derived type, the only primitives are the
857 -- ones inherited from the parent type. Operations appearing
858 -- in the package declaration are not primitive for it.
861 and then (not Formal_Derived
862 or else Present (Alias (Id)))
864 Append_Elmt (Id, Op_List);
870 -- For a type declared in System, some of its operations
871 -- may appear in the target-specific extension to System.
874 and then Chars (B_Scope) = Name_System
875 and then Scope (B_Scope) = Standard_Standard
876 and then Present_System_Aux
878 B_Scope := System_Aux_Id;
879 Id := First_Entity (System_Aux_Id);
887 end Collect_Primitive_Operations;
889 -----------------------------------
890 -- Compile_Time_Constraint_Error --
891 -----------------------------------
893 function Compile_Time_Constraint_Error
896 Ent : Entity_Id := Empty;
897 Loc : Source_Ptr := No_Location)
900 Msgc : String (1 .. Msg'Length + 2);
907 -- A static constraint error in an instance body is not a fatal error.
908 -- we choose to inhibit the message altogether, because there is no
909 -- obvious node (for now) on which to post it. On the other hand the
910 -- offending node must be replaced with a constraint_error in any case.
912 -- No messages are generated if we already posted an error on this node
914 if not Error_Posted (N) then
916 -- Make all such messages unconditional
918 Msgc (1 .. Msg'Length) := Msg;
919 Msgc (Msg'Length + 1) := '!';
920 Msgl := Msg'Length + 1;
922 -- Message is a warning, even in Ada 95 case
924 if Msg (Msg'Length) = '?' then
927 -- In Ada 83, all messages are warnings. In the private part and
928 -- the body of an instance, constraint_checks are only warnings.
930 elsif Ada_83 and then Comes_From_Source (N) then
936 elsif In_Instance_Not_Visible then
941 Warn_On_Instance := True;
943 -- Otherwise we have a real error message (Ada 95 static case)
949 -- Should we generate a warning? The answer is not quite yes. The
950 -- very annoying exception occurs in the case of a short circuit
951 -- operator where the left operand is static and decisive. Climb
952 -- parents to see if that is the case we have here.
960 if (Nkind (P) = N_And_Then
961 and then Compile_Time_Known_Value (Left_Opnd (P))
962 and then Is_False (Expr_Value (Left_Opnd (P))))
963 or else (Nkind (P) = N_Or_Else
964 and then Compile_Time_Known_Value (Left_Opnd (P))
965 and then Is_True (Expr_Value (Left_Opnd (P))))
970 elsif Nkind (P) = N_Component_Association
971 and then Nkind (Parent (P)) = N_Aggregate
976 exit when Nkind (P) not in N_Subexpr;
981 if Present (Ent) then
982 Error_Msg_NE (Msgc (1 .. Msgl), N, Ent);
984 Error_Msg_NE (Msgc (1 .. Msgl), N, Etype (N));
988 if Inside_Init_Proc then
990 ("\& will be raised for objects of this type!?",
991 N, Standard_Constraint_Error);
994 ("\& will be raised at run time!?",
995 N, Standard_Constraint_Error);
999 ("\static expression raises&!",
1000 N, Standard_Constraint_Error);
1006 end Compile_Time_Constraint_Error;
1008 -----------------------
1009 -- Conditional_Delay --
1010 -----------------------
1012 procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id) is
1014 if Has_Delayed_Freeze (Old_Ent) and then not Is_Frozen (Old_Ent) then
1015 Set_Has_Delayed_Freeze (New_Ent);
1017 end Conditional_Delay;
1019 --------------------
1020 -- Current_Entity --
1021 --------------------
1023 -- The currently visible definition for a given identifier is the
1024 -- one most chained at the start of the visibility chain, i.e. the
1025 -- one that is referenced by the Node_Id value of the name of the
1026 -- given identifier.
1028 function Current_Entity (N : Node_Id) return Entity_Id is
1030 return Get_Name_Entity_Id (Chars (N));
1033 -----------------------------
1034 -- Current_Entity_In_Scope --
1035 -----------------------------
1037 function Current_Entity_In_Scope (N : Node_Id) return Entity_Id is
1039 CS : constant Entity_Id := Current_Scope;
1041 Transient_Case : constant Boolean := Scope_Is_Transient;
1044 E := Get_Name_Entity_Id (Chars (N));
1047 and then Scope (E) /= CS
1048 and then (not Transient_Case or else Scope (E) /= Scope (CS))
1054 end Current_Entity_In_Scope;
1060 function Current_Scope return Entity_Id is
1062 if Scope_Stack.Last = -1 then
1063 return Standard_Standard;
1066 C : constant Entity_Id :=
1067 Scope_Stack.Table (Scope_Stack.Last).Entity;
1072 return Standard_Standard;
1078 ------------------------
1079 -- Current_Subprogram --
1080 ------------------------
1082 function Current_Subprogram return Entity_Id is
1083 Scop : constant Entity_Id := Current_Scope;
1086 if Ekind (Scop) = E_Function
1088 Ekind (Scop) = E_Procedure
1090 Ekind (Scop) = E_Generic_Function
1092 Ekind (Scop) = E_Generic_Procedure
1097 return Enclosing_Subprogram (Scop);
1099 end Current_Subprogram;
1101 ---------------------
1102 -- Defining_Entity --
1103 ---------------------
1105 function Defining_Entity (N : Node_Id) return Entity_Id is
1106 K : constant Node_Kind := Nkind (N);
1107 Err : Entity_Id := Empty;
1112 N_Subprogram_Declaration |
1113 N_Abstract_Subprogram_Declaration |
1115 N_Package_Declaration |
1116 N_Subprogram_Renaming_Declaration |
1117 N_Subprogram_Body_Stub |
1118 N_Generic_Subprogram_Declaration |
1119 N_Generic_Package_Declaration |
1120 N_Formal_Subprogram_Declaration
1122 return Defining_Entity (Specification (N));
1125 N_Component_Declaration |
1126 N_Defining_Program_Unit_Name |
1127 N_Discriminant_Specification |
1129 N_Entry_Declaration |
1130 N_Entry_Index_Specification |
1131 N_Exception_Declaration |
1132 N_Exception_Renaming_Declaration |
1133 N_Formal_Object_Declaration |
1134 N_Formal_Package_Declaration |
1135 N_Formal_Type_Declaration |
1136 N_Full_Type_Declaration |
1137 N_Implicit_Label_Declaration |
1138 N_Incomplete_Type_Declaration |
1139 N_Loop_Parameter_Specification |
1140 N_Number_Declaration |
1141 N_Object_Declaration |
1142 N_Object_Renaming_Declaration |
1143 N_Package_Body_Stub |
1144 N_Parameter_Specification |
1145 N_Private_Extension_Declaration |
1146 N_Private_Type_Declaration |
1148 N_Protected_Body_Stub |
1149 N_Protected_Type_Declaration |
1150 N_Single_Protected_Declaration |
1151 N_Single_Task_Declaration |
1152 N_Subtype_Declaration |
1155 N_Task_Type_Declaration
1157 return Defining_Identifier (N);
1160 return Defining_Entity (Proper_Body (N));
1163 N_Function_Instantiation |
1164 N_Function_Specification |
1165 N_Generic_Function_Renaming_Declaration |
1166 N_Generic_Package_Renaming_Declaration |
1167 N_Generic_Procedure_Renaming_Declaration |
1169 N_Package_Instantiation |
1170 N_Package_Renaming_Declaration |
1171 N_Package_Specification |
1172 N_Procedure_Instantiation |
1173 N_Procedure_Specification
1176 Nam : constant Node_Id := Defining_Unit_Name (N);
1179 if Nkind (Nam) in N_Entity then
1182 -- For Error, make up a name and attach to declaration
1183 -- so we can continue semantic analysis
1185 elsif Nam = Error then
1187 Make_Defining_Identifier (Sloc (N),
1188 Chars => New_Internal_Name ('T'));
1189 Set_Defining_Unit_Name (N, Err);
1192 -- If not an entity, get defining identifier
1195 return Defining_Identifier (Nam);
1199 when N_Block_Statement =>
1200 return Entity (Identifier (N));
1203 raise Program_Error;
1206 end Defining_Entity;
1208 --------------------------
1209 -- Denotes_Discriminant --
1210 --------------------------
1212 function Denotes_Discriminant (N : Node_Id) return Boolean is
1214 return Is_Entity_Name (N)
1215 and then Present (Entity (N))
1216 and then Ekind (Entity (N)) = E_Discriminant;
1217 end Denotes_Discriminant;
1219 -----------------------------
1220 -- Depends_On_Discriminant --
1221 -----------------------------
1223 function Depends_On_Discriminant (N : Node_Id) return Boolean is
1228 Get_Index_Bounds (N, L, H);
1229 return Denotes_Discriminant (L) or else Denotes_Discriminant (H);
1230 end Depends_On_Discriminant;
1232 -------------------------
1233 -- Designate_Same_Unit --
1234 -------------------------
1236 function Designate_Same_Unit
1241 K1 : Node_Kind := Nkind (Name1);
1242 K2 : Node_Kind := Nkind (Name2);
1244 function Prefix_Node (N : Node_Id) return Node_Id;
1245 -- Returns the parent unit name node of a defining program unit name
1246 -- or the prefix if N is a selected component or an expanded name.
1248 function Select_Node (N : Node_Id) return Node_Id;
1249 -- Returns the defining identifier node of a defining program unit
1250 -- name or the selector node if N is a selected component or an
1253 function Prefix_Node (N : Node_Id) return Node_Id is
1255 if Nkind (N) = N_Defining_Program_Unit_Name then
1263 function Select_Node (N : Node_Id) return Node_Id is
1265 if Nkind (N) = N_Defining_Program_Unit_Name then
1266 return Defining_Identifier (N);
1269 return Selector_Name (N);
1273 -- Start of processing for Designate_Next_Unit
1276 if (K1 = N_Identifier or else
1277 K1 = N_Defining_Identifier)
1279 (K2 = N_Identifier or else
1280 K2 = N_Defining_Identifier)
1282 return Chars (Name1) = Chars (Name2);
1285 (K1 = N_Expanded_Name or else
1286 K1 = N_Selected_Component or else
1287 K1 = N_Defining_Program_Unit_Name)
1289 (K2 = N_Expanded_Name or else
1290 K2 = N_Selected_Component or else
1291 K2 = N_Defining_Program_Unit_Name)
1294 (Chars (Select_Node (Name1)) = Chars (Select_Node (Name2)))
1296 Designate_Same_Unit (Prefix_Node (Name1), Prefix_Node (Name2));
1301 end Designate_Same_Unit;
1303 ----------------------------
1304 -- Enclosing_Generic_Body --
1305 ----------------------------
1307 function Enclosing_Generic_Body
1318 while Present (P) loop
1319 if Nkind (P) = N_Package_Body
1320 or else Nkind (P) = N_Subprogram_Body
1322 Spec := Corresponding_Spec (P);
1324 if Present (Spec) then
1325 Decl := Unit_Declaration_Node (Spec);
1327 if Nkind (Decl) = N_Generic_Package_Declaration
1328 or else Nkind (Decl) = N_Generic_Subprogram_Declaration
1339 end Enclosing_Generic_Body;
1341 -------------------------------
1342 -- Enclosing_Lib_Unit_Entity --
1343 -------------------------------
1345 function Enclosing_Lib_Unit_Entity return Entity_Id is
1346 Unit_Entity : Entity_Id := Current_Scope;
1349 -- Look for enclosing library unit entity by following scope links.
1350 -- Equivalent to, but faster than indexing through the scope stack.
1352 while (Present (Scope (Unit_Entity))
1353 and then Scope (Unit_Entity) /= Standard_Standard)
1354 and not Is_Child_Unit (Unit_Entity)
1356 Unit_Entity := Scope (Unit_Entity);
1360 end Enclosing_Lib_Unit_Entity;
1362 -----------------------------
1363 -- Enclosing_Lib_Unit_Node --
1364 -----------------------------
1366 function Enclosing_Lib_Unit_Node (N : Node_Id) return Node_Id is
1367 Current_Node : Node_Id := N;
1370 while Present (Current_Node)
1371 and then Nkind (Current_Node) /= N_Compilation_Unit
1373 Current_Node := Parent (Current_Node);
1376 if Nkind (Current_Node) /= N_Compilation_Unit then
1380 return Current_Node;
1381 end Enclosing_Lib_Unit_Node;
1383 --------------------------
1384 -- Enclosing_Subprogram --
1385 --------------------------
1387 function Enclosing_Subprogram (E : Entity_Id) return Entity_Id is
1388 Dynamic_Scope : constant Entity_Id := Enclosing_Dynamic_Scope (E);
1391 if Dynamic_Scope = Standard_Standard then
1394 elsif Ekind (Dynamic_Scope) = E_Subprogram_Body then
1395 return Corresponding_Spec (Parent (Parent (Dynamic_Scope)));
1397 elsif Ekind (Dynamic_Scope) = E_Block then
1398 return Enclosing_Subprogram (Dynamic_Scope);
1400 elsif Ekind (Dynamic_Scope) = E_Task_Type then
1401 return Get_Task_Body_Procedure (Dynamic_Scope);
1403 elsif Convention (Dynamic_Scope) = Convention_Protected then
1404 return Protected_Body_Subprogram (Dynamic_Scope);
1407 return Dynamic_Scope;
1409 end Enclosing_Subprogram;
1411 ------------------------
1412 -- Ensure_Freeze_Node --
1413 ------------------------
1415 procedure Ensure_Freeze_Node (E : Entity_Id) is
1419 if No (Freeze_Node (E)) then
1420 FN := Make_Freeze_Entity (Sloc (E));
1421 Set_Has_Delayed_Freeze (E);
1422 Set_Freeze_Node (E, FN);
1423 Set_Access_Types_To_Process (FN, No_Elist);
1424 Set_TSS_Elist (FN, No_Elist);
1427 end Ensure_Freeze_Node;
1433 procedure Enter_Name (Def_Id : Node_Id) is
1434 C : constant Entity_Id := Current_Entity (Def_Id);
1435 E : constant Entity_Id := Current_Entity_In_Scope (Def_Id);
1436 S : constant Entity_Id := Current_Scope;
1439 Generate_Definition (Def_Id);
1441 -- Add new name to current scope declarations. Check for duplicate
1442 -- declaration, which may or may not be a genuine error.
1446 -- Case of previous entity entered because of a missing declaration
1447 -- or else a bad subtype indication. Best is to use the new entity,
1448 -- and make the previous one invisible.
1450 if Etype (E) = Any_Type then
1451 Set_Is_Immediately_Visible (E, False);
1453 -- Case of renaming declaration constructed for package instances.
1454 -- if there is an explicit declaration with the same identifier,
1455 -- the renaming is not immediately visible any longer, but remains
1456 -- visible through selected component notation.
1458 elsif Nkind (Parent (E)) = N_Package_Renaming_Declaration
1459 and then not Comes_From_Source (E)
1461 Set_Is_Immediately_Visible (E, False);
1463 -- The new entity may be the package renaming, which has the same
1464 -- same name as a generic formal which has been seen already.
1466 elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration
1467 and then not Comes_From_Source (Def_Id)
1469 Set_Is_Immediately_Visible (E, False);
1471 -- For a fat pointer corresponding to a remote access to subprogram,
1472 -- we use the same identifier as the RAS type, so that the proper
1473 -- name appears in the stub. This type is only retrieved through
1474 -- the RAS type and never by visibility, and is not added to the
1475 -- visibility list (see below).
1477 elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
1478 and then Present (Corresponding_Remote_Type (Def_Id))
1482 -- A controller component for a type extension overrides the
1483 -- inherited component.
1485 elsif Chars (E) = Name_uController then
1488 -- Case of an implicit operation or derived literal. The new entity
1489 -- hides the implicit one, which is removed from all visibility,
1490 -- i.e. the entity list of its scope, and homonym chain of its name.
1492 elsif (Is_Overloadable (E) and then Present (Alias (E)))
1493 or else Is_Internal (E)
1494 or else (Ekind (E) = E_Enumeration_Literal
1495 and then Is_Derived_Type (Etype (E)))
1499 Prev_Vis : Entity_Id;
1502 -- If E is an implicit declaration, it cannot be the first
1503 -- entity in the scope.
1505 Prev := First_Entity (Current_Scope);
1507 while Next_Entity (Prev) /= E loop
1511 Set_Next_Entity (Prev, Next_Entity (E));
1513 if No (Next_Entity (Prev)) then
1514 Set_Last_Entity (Current_Scope, Prev);
1517 if E = Current_Entity (E) then
1520 Prev_Vis := Current_Entity (E);
1521 while Homonym (Prev_Vis) /= E loop
1522 Prev_Vis := Homonym (Prev_Vis);
1526 if Present (Prev_Vis) then
1528 -- Skip E in the visibility chain
1530 Set_Homonym (Prev_Vis, Homonym (E));
1533 Set_Name_Entity_Id (Chars (E), Homonym (E));
1537 -- This section of code could use a comment ???
1539 elsif Present (Etype (E))
1540 and then Is_Concurrent_Type (Etype (E))
1545 -- In the body or private part of an instance, a type extension
1546 -- may introduce a component with the same name as that of an
1547 -- actual. The legality rule is not enforced, but the semantics
1548 -- of the full type with two components of the same name are not
1549 -- clear at this point ???
1551 elsif In_Instance_Not_Visible then
1554 -- When compiling a package body, some child units may have become
1555 -- visible. They cannot conflict with local entities that hide them.
1557 elsif Is_Child_Unit (E)
1558 and then In_Open_Scopes (Scope (E))
1559 and then not Is_Immediately_Visible (E)
1563 -- Conversely, with front-end inlining we may compile the parent
1564 -- body first, and a child unit subsequently. The context is now
1565 -- the parent spec, and body entities are not visible.
1567 elsif Is_Child_Unit (Def_Id)
1568 and then Is_Package_Body_Entity (E)
1569 and then not In_Package_Body (Current_Scope)
1573 -- Case of genuine duplicate declaration
1576 Error_Msg_Sloc := Sloc (E);
1578 -- If the previous declaration is an incomplete type declaration
1579 -- this may be an attempt to complete it with a private type.
1580 -- The following avoids confusing cascaded errors.
1582 if Nkind (Parent (E)) = N_Incomplete_Type_Declaration
1583 and then Nkind (Parent (Def_Id)) = N_Private_Type_Declaration
1586 ("incomplete type cannot be completed" &
1587 " with a private declaration",
1589 Set_Is_Immediately_Visible (E, False);
1590 Set_Full_View (E, Def_Id);
1592 elsif Ekind (E) = E_Discriminant
1593 and then Present (Scope (Def_Id))
1594 and then Scope (Def_Id) /= Current_Scope
1596 -- An inherited component of a record conflicts with
1597 -- a new discriminant. The discriminant is inserted first
1598 -- in the scope, but the error should be posted on it, not
1599 -- on the component.
1601 Error_Msg_Sloc := Sloc (Def_Id);
1602 Error_Msg_N ("& conflicts with declaration#", E);
1605 -- If the name of the unit appears in its own context clause,
1606 -- a dummy package with the name has already been created, and
1607 -- the error emitted. Try to continue quietly.
1609 elsif Error_Posted (E)
1610 and then Sloc (E) = No_Location
1611 and then Nkind (Parent (E)) = N_Package_Specification
1612 and then Current_Scope = Standard_Standard
1614 Set_Scope (Def_Id, Current_Scope);
1618 Error_Msg_N ("& conflicts with declaration#", Def_Id);
1620 -- Avoid cascaded messages with duplicate components in
1623 if Ekind (E) = E_Component
1624 or else Ekind (E) = E_Discriminant
1630 if Nkind (Parent (Parent (Def_Id)))
1631 = N_Generic_Subprogram_Declaration
1633 Defining_Entity (Specification (Parent (Parent (Def_Id))))
1635 Error_Msg_N ("\generic units cannot be overloaded", Def_Id);
1638 -- If entity is in standard, then we are in trouble, because
1639 -- it means that we have a library package with a duplicated
1640 -- name. That's hard to recover from, so abort!
1642 if S = Standard_Standard then
1643 raise Unrecoverable_Error;
1645 -- Otherwise we continue with the declaration. Having two
1646 -- identical declarations should not cause us too much trouble!
1654 -- If we fall through, declaration is OK , or OK enough to continue
1656 -- If Def_Id is a discriminant or a record component we are in the
1657 -- midst of inheriting components in a derived record definition.
1658 -- Preserve their Ekind and Etype.
1660 if Ekind (Def_Id) = E_Discriminant
1661 or else Ekind (Def_Id) = E_Component
1665 -- If a type is already set, leave it alone (happens whey a type
1666 -- declaration is reanalyzed following a call to the optimizer)
1668 elsif Present (Etype (Def_Id)) then
1671 -- Otherwise, the kind E_Void insures that premature uses of the entity
1672 -- will be detected. Any_Type insures that no cascaded errors will occur
1675 Set_Ekind (Def_Id, E_Void);
1676 Set_Etype (Def_Id, Any_Type);
1679 -- Inherited discriminants and components in derived record types are
1680 -- immediately visible. Itypes are not.
1682 if Ekind (Def_Id) = E_Discriminant
1683 or else Ekind (Def_Id) = E_Component
1684 or else (No (Corresponding_Remote_Type (Def_Id))
1685 and then not Is_Itype (Def_Id))
1687 Set_Is_Immediately_Visible (Def_Id);
1688 Set_Current_Entity (Def_Id);
1691 Set_Homonym (Def_Id, C);
1692 Append_Entity (Def_Id, S);
1693 Set_Public_Status (Def_Id);
1695 -- Warn if new entity hides an old one
1698 and then Length_Of_Name (Chars (C)) /= 1
1699 and then Present (C)
1700 and then Comes_From_Source (C)
1701 and then Comes_From_Source (Def_Id)
1702 and then In_Extended_Main_Source_Unit (Def_Id)
1704 Error_Msg_Sloc := Sloc (C);
1705 Error_Msg_N ("declaration hides &#?", Def_Id);
1710 -------------------------------------
1711 -- Find_Corresponding_Discriminant --
1712 -------------------------------------
1714 function Find_Corresponding_Discriminant
1719 Par_Disc : Entity_Id;
1720 Old_Disc : Entity_Id;
1721 New_Disc : Entity_Id;
1724 Par_Disc := Original_Record_Component (Original_Discriminant (Id));
1725 Old_Disc := First_Discriminant (Scope (Par_Disc));
1727 if Is_Class_Wide_Type (Typ) then
1728 New_Disc := First_Discriminant (Root_Type (Typ));
1730 New_Disc := First_Discriminant (Typ);
1733 while Present (Old_Disc) and then Present (New_Disc) loop
1734 if Old_Disc = Par_Disc then
1737 Next_Discriminant (Old_Disc);
1738 Next_Discriminant (New_Disc);
1742 -- Should always find it
1744 raise Program_Error;
1745 end Find_Corresponding_Discriminant;
1751 function First_Actual (Node : Node_Id) return Node_Id is
1755 if No (Parameter_Associations (Node)) then
1759 N := First (Parameter_Associations (Node));
1761 if Nkind (N) = N_Parameter_Association then
1762 return First_Named_Actual (Node);
1768 -------------------------
1769 -- Full_Qualified_Name --
1770 -------------------------
1772 function Full_Qualified_Name (E : Entity_Id) return String_Id is
1776 function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
1777 -- Compute recursively the qualified name without NUL at the end.
1779 function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
1780 Ent : Entity_Id := E;
1781 Parent_Name : String_Id := No_String;
1784 -- Deals properly with child units
1786 if Nkind (Ent) = N_Defining_Program_Unit_Name then
1787 Ent := Defining_Identifier (Ent);
1790 -- Compute recursively the qualification. Only "Standard" has no
1793 if Present (Scope (Scope (Ent))) then
1794 Parent_Name := Internal_Full_Qualified_Name (Scope (Ent));
1797 -- Every entity should have a name except some expanded blocks
1798 -- don't bother about those.
1800 if Chars (Ent) = No_Name then
1804 -- Add a period between Name and qualification
1806 if Parent_Name /= No_String then
1807 Start_String (Parent_Name);
1808 Store_String_Char (Get_Char_Code ('.'));
1814 -- Generates the entity name in upper case
1816 Get_Name_String (Chars (Ent));
1818 Store_String_Chars (Name_Buffer (1 .. Name_Len));
1820 end Internal_Full_Qualified_Name;
1823 Res := Internal_Full_Qualified_Name (E);
1824 Store_String_Char (Get_Char_Code (ASCII.nul));
1826 end Full_Qualified_Name;
1828 -----------------------
1829 -- Gather_Components --
1830 -----------------------
1832 procedure Gather_Components
1834 Comp_List : Node_Id;
1835 Governed_By : List_Id;
1837 Report_Errors : out Boolean)
1841 Discrete_Choice : Node_Id;
1842 Comp_Item : Node_Id;
1844 Discrim : Entity_Id;
1845 Discrim_Name : Node_Id;
1846 Discrim_Value : Node_Id;
1849 Report_Errors := False;
1851 if No (Comp_List) or else Null_Present (Comp_List) then
1854 elsif Present (Component_Items (Comp_List)) then
1855 Comp_Item := First (Component_Items (Comp_List));
1861 while Present (Comp_Item) loop
1863 -- Skip the tag of a tagged record, as well as all items
1864 -- that are not user components (anonymous types, rep clauses,
1865 -- Parent field, controller field).
1867 if Nkind (Comp_Item) = N_Component_Declaration
1868 and then Chars (Defining_Identifier (Comp_Item)) /= Name_uTag
1869 and then Chars (Defining_Identifier (Comp_Item)) /= Name_uParent
1870 and then Chars (Defining_Identifier (Comp_Item)) /= Name_uController
1872 Append_Elmt (Defining_Identifier (Comp_Item), Into);
1878 if No (Variant_Part (Comp_List)) then
1881 Discrim_Name := Name (Variant_Part (Comp_List));
1882 Variant := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
1885 -- Look for the discriminant that governs this variant part.
1886 -- The discriminant *must* be in the Governed_By List
1888 Assoc := First (Governed_By);
1889 Find_Constraint : loop
1890 Discrim := First (Choices (Assoc));
1891 exit Find_Constraint when Chars (Discrim_Name) = Chars (Discrim)
1892 or else (Present (Corresponding_Discriminant (Entity (Discrim)))
1894 Chars (Corresponding_Discriminant (Entity (Discrim)))
1895 = Chars (Discrim_Name))
1896 or else Chars (Original_Record_Component (Entity (Discrim)))
1897 = Chars (Discrim_Name);
1899 if No (Next (Assoc)) then
1900 if not Is_Constrained (Typ)
1901 and then Is_Derived_Type (Typ)
1902 and then Present (Girder_Constraint (Typ))
1905 -- If the type is a tagged type with inherited discriminants,
1906 -- use the girder constraint on the parent in order to find
1907 -- the values of discriminants that are otherwise hidden by an
1908 -- explicit constraint. Renamed discriminants are handled in
1916 D := First_Discriminant (Etype (Typ));
1917 C := First_Elmt (Girder_Constraint (Typ));
1920 and then Present (C)
1922 if Chars (Discrim_Name) = Chars (D) then
1924 Make_Component_Association (Sloc (Typ),
1926 (New_Occurrence_Of (D, Sloc (Typ))),
1927 Duplicate_Subexpr (Node (C)));
1928 exit Find_Constraint;
1931 D := Next_Discriminant (D);
1938 if No (Next (Assoc)) then
1939 Error_Msg_NE (" missing value for discriminant&",
1940 First (Governed_By), Discrim_Name);
1941 Report_Errors := True;
1946 end loop Find_Constraint;
1948 Discrim_Value := Expression (Assoc);
1950 if not Is_OK_Static_Expression (Discrim_Value) then
1952 ("value for discriminant & must be static", Discrim_Value, Discrim);
1953 Report_Errors := True;
1957 Search_For_Discriminant_Value : declare
1963 UI_Discrim_Value : constant Uint := Expr_Value (Discrim_Value);
1966 Find_Discrete_Value : while Present (Variant) loop
1967 Discrete_Choice := First (Discrete_Choices (Variant));
1968 while Present (Discrete_Choice) loop
1970 exit Find_Discrete_Value when
1971 Nkind (Discrete_Choice) = N_Others_Choice;
1973 Get_Index_Bounds (Discrete_Choice, Low, High);
1975 UI_Low := Expr_Value (Low);
1976 UI_High := Expr_Value (High);
1978 exit Find_Discrete_Value when
1979 UI_Low <= UI_Discrim_Value
1981 UI_High >= UI_Discrim_Value;
1983 Next (Discrete_Choice);
1986 Next_Non_Pragma (Variant);
1987 end loop Find_Discrete_Value;
1988 end Search_For_Discriminant_Value;
1990 if No (Variant) then
1992 ("value of discriminant & is out of range", Discrim_Value, Discrim);
1993 Report_Errors := True;
1997 -- If we have found the corresponding choice, recursively add its
1998 -- components to the Into list.
2000 Gather_Components (Empty,
2001 Component_List (Variant), Governed_By, Into, Report_Errors);
2002 end Gather_Components;
2004 ------------------------
2005 -- Get_Actual_Subtype --
2006 ------------------------
2008 function Get_Actual_Subtype (N : Node_Id) return Entity_Id is
2009 Typ : constant Entity_Id := Etype (N);
2010 Utyp : Entity_Id := Underlying_Type (Typ);
2015 if not Present (Utyp) then
2019 -- If what we have is an identifier that references a subprogram
2020 -- formal, or a variable or constant object, then we get the actual
2021 -- subtype from the referenced entity if one has been built.
2023 if Nkind (N) = N_Identifier
2025 (Is_Formal (Entity (N))
2026 or else Ekind (Entity (N)) = E_Constant
2027 or else Ekind (Entity (N)) = E_Variable)
2028 and then Present (Actual_Subtype (Entity (N)))
2030 return Actual_Subtype (Entity (N));
2032 -- Actual subtype of unchecked union is always itself. We never need
2033 -- the "real" actual subtype. If we did, we couldn't get it anyway
2034 -- because the discriminant is not available. The restrictions on
2035 -- Unchecked_Union are designed to make sure that this is OK.
2037 elsif Is_Unchecked_Union (Utyp) then
2040 -- Here for the unconstrained case, we must find actual subtype
2041 -- No actual subtype is available, so we must build it on the fly.
2043 -- Checking the type, not the underlying type, for constrainedness
2044 -- seems to be necessary. Maybe all the tests should be on the type???
2046 elsif (not Is_Constrained (Typ))
2047 and then (Is_Array_Type (Utyp)
2048 or else (Is_Record_Type (Utyp)
2049 and then Has_Discriminants (Utyp)))
2050 and then not Has_Unknown_Discriminants (Utyp)
2051 and then not (Ekind (Utyp) = E_String_Literal_Subtype)
2053 -- Nothing to do if in default expression
2055 if In_Default_Expression then
2058 -- Else build the actual subtype
2061 Decl := Build_Actual_Subtype (Typ, N);
2062 Atyp := Defining_Identifier (Decl);
2064 -- If Build_Actual_Subtype generated a new declaration then use it
2068 -- The actual subtype is an Itype, so analyze the declaration,
2069 -- but do not attach it to the tree, to get the type defined.
2071 Set_Parent (Decl, N);
2072 Set_Is_Itype (Atyp);
2073 Analyze (Decl, Suppress => All_Checks);
2074 Set_Associated_Node_For_Itype (Atyp, N);
2075 Set_Has_Delayed_Freeze (Atyp, False);
2077 -- We need to freeze the actual subtype immediately. This is
2078 -- needed, because otherwise this Itype will not get frozen
2079 -- at all, and it is always safe to freeze on creation because
2080 -- any associated types must be frozen at this point.
2082 Freeze_Itype (Atyp, N);
2085 -- Otherwise we did not build a declaration, so return original
2092 -- For all remaining cases, the actual subtype is the same as
2093 -- the nominal type.
2098 end Get_Actual_Subtype;
2100 -------------------------------------
2101 -- Get_Actual_Subtype_If_Available --
2102 -------------------------------------
2104 function Get_Actual_Subtype_If_Available (N : Node_Id) return Entity_Id is
2105 Typ : constant Entity_Id := Etype (N);
2108 -- If what we have is an identifier that references a subprogram
2109 -- formal, or a variable or constant object, then we get the actual
2110 -- subtype from the referenced entity if one has been built.
2112 if Nkind (N) = N_Identifier
2114 (Is_Formal (Entity (N))
2115 or else Ekind (Entity (N)) = E_Constant
2116 or else Ekind (Entity (N)) = E_Variable)
2117 and then Present (Actual_Subtype (Entity (N)))
2119 return Actual_Subtype (Entity (N));
2121 -- Otherwise the Etype of N is returned unchanged
2126 end Get_Actual_Subtype_If_Available;
2128 -------------------------------
2129 -- Get_Default_External_Name --
2130 -------------------------------
2132 function Get_Default_External_Name (E : Node_Or_Entity_Id) return Node_Id is
2134 Get_Decoded_Name_String (Chars (E));
2136 if Opt.External_Name_Imp_Casing = Uppercase then
2137 Set_Casing (All_Upper_Case);
2139 Set_Casing (All_Lower_Case);
2143 Make_String_Literal (Sloc (E),
2144 Strval => String_From_Name_Buffer);
2146 end Get_Default_External_Name;
2148 ---------------------------
2149 -- Get_Enum_Lit_From_Pos --
2150 ---------------------------
2152 function Get_Enum_Lit_From_Pos
2159 P : constant Nat := UI_To_Int (Pos);
2162 -- In the case where the literal is either of type Wide_Character
2163 -- or Character or of a type derived from them, there needs to be
2164 -- some special handling since there is no explicit chain of
2165 -- literals to search. Instead, an N_Character_Literal node is
2166 -- created with the appropriate Char_Code and Chars fields.
2168 if Root_Type (T) = Standard_Character
2169 or else Root_Type (T) = Standard_Wide_Character
2171 Set_Character_Literal_Name (Char_Code (P));
2173 Make_Character_Literal (Loc,
2175 Char_Literal_Value => Char_Code (P));
2177 -- For all other cases, we have a complete table of literals, and
2178 -- we simply iterate through the chain of literal until the one
2179 -- with the desired position value is found.
2183 Lit := First_Literal (Base_Type (T));
2184 for J in 1 .. P loop
2188 return New_Occurrence_Of (Lit, Loc);
2190 end Get_Enum_Lit_From_Pos;
2192 ----------------------
2193 -- Get_Index_Bounds --
2194 ----------------------
2196 procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
2197 Kind : constant Node_Kind := Nkind (N);
2201 if Kind = N_Range then
2203 H := High_Bound (N);
2205 elsif Kind = N_Subtype_Indication then
2206 R := Range_Expression (Constraint (N));
2214 L := Low_Bound (Range_Expression (Constraint (N)));
2215 H := High_Bound (Range_Expression (Constraint (N)));
2218 elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
2219 if Error_Posted (Scalar_Range (Entity (N))) then
2223 elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
2224 Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
2227 L := Low_Bound (Scalar_Range (Entity (N)));
2228 H := High_Bound (Scalar_Range (Entity (N)));
2232 -- N is an expression, indicating a range with one value.
2237 end Get_Index_Bounds;
2239 ------------------------
2240 -- Get_Name_Entity_Id --
2241 ------------------------
2243 function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id is
2245 return Entity_Id (Get_Name_Table_Info (Id));
2246 end Get_Name_Entity_Id;
2248 ---------------------------
2249 -- Get_Referenced_Object --
2250 ---------------------------
2252 function Get_Referenced_Object (N : Node_Id) return Node_Id is
2256 while Is_Entity_Name (R)
2257 and then Present (Renamed_Object (Entity (R)))
2259 R := Renamed_Object (Entity (R));
2263 end Get_Referenced_Object;
2265 -------------------------
2266 -- Get_Subprogram_Body --
2267 -------------------------
2269 function Get_Subprogram_Body (E : Entity_Id) return Node_Id is
2273 Decl := Unit_Declaration_Node (E);
2275 if Nkind (Decl) = N_Subprogram_Body then
2278 else -- Nkind (Decl) = N_Subprogram_Declaration
2280 if Present (Corresponding_Body (Decl)) then
2281 return Unit_Declaration_Node (Corresponding_Body (Decl));
2283 else -- imported subprogram.
2287 end Get_Subprogram_Body;
2289 -----------------------------
2290 -- Get_Task_Body_Procedure --
2291 -----------------------------
2293 function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is
2295 return Task_Body_Procedure (Declaration_Node (Root_Type (E)));
2296 end Get_Task_Body_Procedure;
2298 --------------------
2299 -- Has_Infinities --
2300 --------------------
2302 function Has_Infinities (E : Entity_Id) return Boolean is
2305 Is_Floating_Point_Type (E)
2306 and then Nkind (Scalar_Range (E)) = N_Range
2307 and then Includes_Infinities (Scalar_Range (E));
2310 ---------------------------
2311 -- Has_Private_Component --
2312 ---------------------------
2314 function Has_Private_Component (Type_Id : Entity_Id) return Boolean is
2315 Btype : Entity_Id := Base_Type (Type_Id);
2316 Component : Entity_Id;
2319 if Error_Posted (Type_Id)
2320 or else Error_Posted (Btype)
2325 if Is_Class_Wide_Type (Btype) then
2326 Btype := Root_Type (Btype);
2329 if Is_Private_Type (Btype) then
2331 UT : constant Entity_Id := Underlying_Type (Btype);
2335 if No (Full_View (Btype)) then
2336 return not Is_Generic_Type (Btype)
2337 and then not Is_Generic_Type (Root_Type (Btype));
2340 return not Is_Generic_Type (Root_Type (Full_View (Btype)));
2344 return not Is_Frozen (UT) and then Has_Private_Component (UT);
2347 elsif Is_Array_Type (Btype) then
2348 return Has_Private_Component (Component_Type (Btype));
2350 elsif Is_Record_Type (Btype) then
2352 Component := First_Component (Btype);
2353 while Present (Component) loop
2355 if Has_Private_Component (Etype (Component)) then
2359 Next_Component (Component);
2364 elsif Is_Protected_Type (Btype)
2365 and then Present (Corresponding_Record_Type (Btype))
2367 return Has_Private_Component (Corresponding_Record_Type (Btype));
2372 end Has_Private_Component;
2374 --------------------------
2375 -- Has_Tagged_Component --
2376 --------------------------
2378 function Has_Tagged_Component (Typ : Entity_Id) return Boolean is
2382 if Is_Private_Type (Typ)
2383 and then Present (Underlying_Type (Typ))
2385 return Has_Tagged_Component (Underlying_Type (Typ));
2387 elsif Is_Array_Type (Typ) then
2388 return Has_Tagged_Component (Component_Type (Typ));
2390 elsif Is_Tagged_Type (Typ) then
2393 elsif Is_Record_Type (Typ) then
2394 Comp := First_Component (Typ);
2396 while Present (Comp) loop
2397 if Has_Tagged_Component (Etype (Comp)) then
2401 Comp := Next_Component (Typ);
2409 end Has_Tagged_Component;
2415 function In_Instance return Boolean is
2416 S : Entity_Id := Current_Scope;
2420 and then S /= Standard_Standard
2422 if (Ekind (S) = E_Function
2423 or else Ekind (S) = E_Package
2424 or else Ekind (S) = E_Procedure)
2425 and then Is_Generic_Instance (S)
2436 ----------------------
2437 -- In_Instance_Body --
2438 ----------------------
2440 function In_Instance_Body return Boolean is
2441 S : Entity_Id := Current_Scope;
2445 and then S /= Standard_Standard
2447 if (Ekind (S) = E_Function
2448 or else Ekind (S) = E_Procedure)
2449 and then Is_Generic_Instance (S)
2453 elsif Ekind (S) = E_Package
2454 and then In_Package_Body (S)
2455 and then Is_Generic_Instance (S)
2464 end In_Instance_Body;
2466 -----------------------------
2467 -- In_Instance_Not_Visible --
2468 -----------------------------
2470 function In_Instance_Not_Visible return Boolean is
2471 S : Entity_Id := Current_Scope;
2475 and then S /= Standard_Standard
2477 if (Ekind (S) = E_Function
2478 or else Ekind (S) = E_Procedure)
2479 and then Is_Generic_Instance (S)
2483 elsif Ekind (S) = E_Package
2484 and then (In_Package_Body (S) or else In_Private_Part (S))
2485 and then Is_Generic_Instance (S)
2494 end In_Instance_Not_Visible;
2496 ------------------------------
2497 -- In_Instance_Visible_Part --
2498 ------------------------------
2500 function In_Instance_Visible_Part return Boolean is
2501 S : Entity_Id := Current_Scope;
2505 and then S /= Standard_Standard
2507 if Ekind (S) = E_Package
2508 and then Is_Generic_Instance (S)
2509 and then not In_Package_Body (S)
2510 and then not In_Private_Part (S)
2519 end In_Instance_Visible_Part;
2521 --------------------------------------
2522 -- In_Subprogram_Or_Concurrent_Unit --
2523 --------------------------------------
2525 function In_Subprogram_Or_Concurrent_Unit return Boolean is
2530 -- Use scope chain to check successively outer scopes
2536 if K in Subprogram_Kind
2537 or else K in Concurrent_Kind
2538 or else K = E_Generic_Procedure
2539 or else K = E_Generic_Function
2543 elsif E = Standard_Standard then
2550 end In_Subprogram_Or_Concurrent_Unit;
2552 ---------------------
2553 -- In_Visible_Part --
2554 ---------------------
2556 function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is
2559 Is_Package (Scope_Id)
2560 and then In_Open_Scopes (Scope_Id)
2561 and then not In_Package_Body (Scope_Id)
2562 and then not In_Private_Part (Scope_Id);
2563 end In_Visible_Part;
2569 function Is_AAMP_Float (E : Entity_Id) return Boolean is
2571 pragma Assert (Is_Type (E));
2573 return AAMP_On_Target
2574 and then Is_Floating_Point_Type (E)
2575 and then E = Base_Type (E);
2578 -------------------------
2579 -- Is_Actual_Parameter --
2580 -------------------------
2582 function Is_Actual_Parameter (N : Node_Id) return Boolean is
2583 PK : constant Node_Kind := Nkind (Parent (N));
2587 when N_Parameter_Association =>
2588 return N = Explicit_Actual_Parameter (Parent (N));
2590 when N_Function_Call | N_Procedure_Call_Statement =>
2591 return Is_List_Member (N)
2593 List_Containing (N) = Parameter_Associations (Parent (N));
2598 end Is_Actual_Parameter;
2600 ---------------------
2601 -- Is_Aliased_View --
2602 ---------------------
2604 function Is_Aliased_View (Obj : Node_Id) return Boolean is
2608 if Is_Entity_Name (Obj) then
2610 -- Shouldn't we check that we really have an object here?
2611 -- If we do, then a-caldel.adb blows up mysteriously ???
2615 return Is_Aliased (E)
2616 or else (Present (Renamed_Object (E))
2617 and then Is_Aliased_View (Renamed_Object (E)))
2619 or else ((Is_Formal (E)
2620 or else Ekind (E) = E_Generic_In_Out_Parameter
2621 or else Ekind (E) = E_Generic_In_Parameter)
2622 and then Is_Tagged_Type (Etype (E)))
2624 or else ((Ekind (E) = E_Task_Type or else
2625 Ekind (E) = E_Protected_Type)
2626 and then In_Open_Scopes (E))
2628 -- Current instance of type
2630 or else (Is_Type (E) and then E = Current_Scope)
2631 or else (Is_Incomplete_Or_Private_Type (E)
2632 and then Full_View (E) = Current_Scope);
2634 elsif Nkind (Obj) = N_Selected_Component then
2635 return Is_Aliased (Entity (Selector_Name (Obj)));
2637 elsif Nkind (Obj) = N_Indexed_Component then
2638 return Has_Aliased_Components (Etype (Prefix (Obj)))
2640 (Is_Access_Type (Etype (Prefix (Obj)))
2642 Has_Aliased_Components
2643 (Designated_Type (Etype (Prefix (Obj)))));
2645 elsif Nkind (Obj) = N_Unchecked_Type_Conversion
2646 or else Nkind (Obj) = N_Type_Conversion
2648 return Is_Tagged_Type (Etype (Obj))
2649 or else Is_Aliased_View (Expression (Obj));
2651 elsif Nkind (Obj) = N_Explicit_Dereference then
2652 return Nkind (Original_Node (Obj)) /= N_Function_Call;
2657 end Is_Aliased_View;
2659 ----------------------
2660 -- Is_Atomic_Object --
2661 ----------------------
2663 function Is_Atomic_Object (N : Node_Id) return Boolean is
2665 function Object_Has_Atomic_Components (N : Node_Id) return Boolean;
2666 -- Determines if given object has atomic components
2668 function Is_Atomic_Prefix (N : Node_Id) return Boolean;
2669 -- If prefix is an implicit dereference, examine designated type.
2671 function Is_Atomic_Prefix (N : Node_Id) return Boolean is
2673 if Is_Access_Type (Etype (N)) then
2675 Has_Atomic_Components (Designated_Type (Etype (N)));
2677 return Object_Has_Atomic_Components (N);
2679 end Is_Atomic_Prefix;
2681 function Object_Has_Atomic_Components (N : Node_Id) return Boolean is
2683 if Has_Atomic_Components (Etype (N))
2684 or else Is_Atomic (Etype (N))
2688 elsif Is_Entity_Name (N)
2689 and then (Has_Atomic_Components (Entity (N))
2690 or else Is_Atomic (Entity (N)))
2694 elsif Nkind (N) = N_Indexed_Component
2695 or else Nkind (N) = N_Selected_Component
2697 return Is_Atomic_Prefix (Prefix (N));
2702 end Object_Has_Atomic_Components;
2704 -- Start of processing for Is_Atomic_Object
2707 if Is_Atomic (Etype (N))
2708 or else (Is_Entity_Name (N) and then Is_Atomic (Entity (N)))
2712 elsif Nkind (N) = N_Indexed_Component
2713 or else Nkind (N) = N_Selected_Component
2715 return Is_Atomic_Prefix (Prefix (N));
2720 end Is_Atomic_Object;
2722 ----------------------------------------------
2723 -- Is_Dependent_Component_Of_Mutable_Object --
2724 ----------------------------------------------
2726 function Is_Dependent_Component_Of_Mutable_Object
2731 Prefix_Type : Entity_Id;
2732 P_Aliased : Boolean := False;
2735 function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean;
2736 -- Returns True if and only if Comp has a constrained subtype
2737 -- that depends on a discriminant.
2739 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
2740 -- Returns True if and only if Comp is declared within a variant part.
2742 ------------------------------
2743 -- Has_Dependent_Constraint --
2744 ------------------------------
2746 function Has_Dependent_Constraint (Comp : Entity_Id) return Boolean is
2747 Comp_Decl : constant Node_Id := Parent (Comp);
2748 Subt_Indic : constant Node_Id := Subtype_Indication (Comp_Decl);
2753 if Nkind (Subt_Indic) = N_Subtype_Indication then
2754 Constr := Constraint (Subt_Indic);
2756 if Nkind (Constr) = N_Index_Or_Discriminant_Constraint then
2757 Assn := First (Constraints (Constr));
2758 while Present (Assn) loop
2759 case Nkind (Assn) is
2760 when N_Subtype_Indication |
2764 if Depends_On_Discriminant (Assn) then
2768 when N_Discriminant_Association =>
2769 if Depends_On_Discriminant (Expression (Assn)) then
2784 end Has_Dependent_Constraint;
2786 --------------------------------
2787 -- Is_Declared_Within_Variant --
2788 --------------------------------
2790 function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean is
2791 Comp_Decl : constant Node_Id := Parent (Comp);
2792 Comp_List : constant Node_Id := Parent (Comp_Decl);
2795 return Nkind (Parent (Comp_List)) = N_Variant;
2796 end Is_Declared_Within_Variant;
2798 -- Start of processing for Is_Dependent_Component_Of_Mutable_Object
2801 if Is_Variable (Object) then
2803 if Nkind (Object) = N_Selected_Component then
2804 P := Prefix (Object);
2805 Prefix_Type := Etype (P);
2807 if Is_Entity_Name (P) then
2809 if Ekind (Entity (P)) = E_Generic_In_Out_Parameter then
2810 Prefix_Type := Base_Type (Prefix_Type);
2813 if Is_Aliased (Entity (P)) then
2818 -- Check for prefix being an aliased component ???
2822 if Is_Access_Type (Prefix_Type)
2823 or else Nkind (P) = N_Explicit_Dereference
2829 Original_Record_Component (Entity (Selector_Name (Object)));
2831 if not Is_Constrained (Prefix_Type)
2832 and then not Is_Indefinite_Subtype (Prefix_Type)
2833 and then (Is_Declared_Within_Variant (Comp)
2834 or else Has_Dependent_Constraint (Comp))
2835 and then not P_Aliased
2841 Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
2845 elsif Nkind (Object) = N_Indexed_Component
2846 or else Nkind (Object) = N_Slice
2848 return Is_Dependent_Component_Of_Mutable_Object (Prefix (Object));
2853 end Is_Dependent_Component_Of_Mutable_Object;
2859 function Is_False (U : Uint) return Boolean is
2864 ---------------------------
2865 -- Is_Fixed_Model_Number --
2866 ---------------------------
2868 function Is_Fixed_Model_Number (U : Ureal; T : Entity_Id) return Boolean is
2869 S : constant Ureal := Small_Value (T);
2870 M : Urealp.Save_Mark;
2875 R := (U = UR_Trunc (U / S) * S);
2878 end Is_Fixed_Model_Number;
2880 -------------------------------
2881 -- Is_Fully_Initialized_Type --
2882 -------------------------------
2884 function Is_Fully_Initialized_Type (Typ : Entity_Id) return Boolean is
2886 if Is_Scalar_Type (Typ) then
2889 elsif Is_Access_Type (Typ) then
2892 elsif Is_Array_Type (Typ) then
2893 if Is_Fully_Initialized_Type (Component_Type (Typ)) then
2897 -- An interesting case, if we have a constrained type one of whose
2898 -- bounds is known to be null, then there are no elements to be
2899 -- initialized, so all the elements are initialized!
2901 if Is_Constrained (Typ) then
2904 Indx_Typ : Entity_Id;
2908 Indx := First_Index (Typ);
2909 while Present (Indx) loop
2911 if Etype (Indx) = Any_Type then
2914 -- If index is a range, use directly.
2916 elsif Nkind (Indx) = N_Range then
2917 Lbd := Low_Bound (Indx);
2918 Hbd := High_Bound (Indx);
2921 Indx_Typ := Etype (Indx);
2923 if Is_Private_Type (Indx_Typ) then
2924 Indx_Typ := Full_View (Indx_Typ);
2927 if No (Indx_Typ) then
2930 Lbd := Type_Low_Bound (Indx_Typ);
2931 Hbd := Type_High_Bound (Indx_Typ);
2935 if Compile_Time_Known_Value (Lbd)
2936 and then Compile_Time_Known_Value (Hbd)
2938 if Expr_Value (Hbd) < Expr_Value (Lbd) then
2950 elsif Is_Record_Type (Typ) then
2955 Ent := First_Entity (Typ);
2957 while Present (Ent) loop
2958 if Ekind (Ent) = E_Component
2959 and then (No (Parent (Ent))
2960 or else No (Expression (Parent (Ent))))
2961 and then not Is_Fully_Initialized_Type (Etype (Ent))
2972 elsif Is_Concurrent_Type (Typ) then
2975 elsif Is_Private_Type (Typ) then
2977 U : constant Entity_Id := Underlying_Type (Typ);
2983 return Is_Fully_Initialized_Type (U);
2990 end Is_Fully_Initialized_Type;
2992 ----------------------------
2993 -- Is_Inherited_Operation --
2994 ----------------------------
2996 function Is_Inherited_Operation (E : Entity_Id) return Boolean is
2997 Kind : constant Node_Kind := Nkind (Parent (E));
3000 pragma Assert (Is_Overloadable (E));
3001 return Kind = N_Full_Type_Declaration
3002 or else Kind = N_Private_Extension_Declaration
3003 or else Kind = N_Subtype_Declaration
3004 or else (Ekind (E) = E_Enumeration_Literal
3005 and then Is_Derived_Type (Etype (E)));
3006 end Is_Inherited_Operation;
3008 -----------------------------
3009 -- Is_Library_Level_Entity --
3010 -----------------------------
3012 function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
3014 return Enclosing_Dynamic_Scope (E) = Standard_Standard;
3015 end Is_Library_Level_Entity;
3017 ---------------------------------
3018 -- Is_Local_Variable_Reference --
3019 ---------------------------------
3021 function Is_Local_Variable_Reference (Expr : Node_Id) return Boolean is
3023 if not Is_Entity_Name (Expr) then
3028 Ent : constant Entity_Id := Entity (Expr);
3029 Sub : constant Entity_Id := Enclosing_Subprogram (Ent);
3032 if Ekind (Ent) /= E_Variable
3034 Ekind (Ent) /= E_In_Out_Parameter
3039 return Present (Sub) and then Sub = Current_Subprogram;
3043 end Is_Local_Variable_Reference;
3045 -------------------------
3046 -- Is_Object_Reference --
3047 -------------------------
3049 function Is_Object_Reference (N : Node_Id) return Boolean is
3051 if Is_Entity_Name (N) then
3052 return Is_Object (Entity (N));
3056 when N_Indexed_Component | N_Slice =>
3059 -- In Ada95, a function call is a constant object.
3061 when N_Function_Call =>
3064 when N_Selected_Component =>
3065 return Is_Object_Reference (Selector_Name (N));
3067 when N_Explicit_Dereference =>
3070 -- An unchecked type conversion is considered to be an object if
3071 -- the operand is an object (this construction arises only as a
3072 -- result of expansion activities).
3074 when N_Unchecked_Type_Conversion =>
3081 end Is_Object_Reference;
3083 -----------------------------------
3084 -- Is_OK_Variable_For_Out_Formal --
3085 -----------------------------------
3087 function Is_OK_Variable_For_Out_Formal (AV : Node_Id) return Boolean is
3089 Note_Possible_Modification (AV);
3091 -- We must reject parenthesized variable names. The check for
3092 -- Comes_From_Source is present because there are currently
3093 -- cases where the compiler violates this rule (e.g. passing
3094 -- a task object to its controlled Initialize routine).
3096 if Paren_Count (AV) > 0 and then Comes_From_Source (AV) then
3099 -- A variable is always allowed
3101 elsif Is_Variable (AV) then
3104 -- Unchecked conversions are allowed only if they come from the
3105 -- generated code, which sometimes uses unchecked conversions for
3106 -- out parameters in cases where code generation is unaffected.
3107 -- We tell source unchecked conversions by seeing if they are
3108 -- rewrites of an original UC function call, or of an explicit
3109 -- conversion of a function call.
3111 elsif Nkind (AV) = N_Unchecked_Type_Conversion then
3112 if Nkind (Original_Node (AV)) = N_Function_Call then
3115 elsif Comes_From_Source (AV)
3116 and then Nkind (Original_Node (Expression (AV))) = N_Function_Call
3124 -- Normal type conversions are allowed if argument is a variable
3126 elsif Nkind (AV) = N_Type_Conversion then
3127 if Is_Variable (Expression (AV))
3128 and then Paren_Count (Expression (AV)) = 0
3130 Note_Possible_Modification (Expression (AV));
3133 -- We also allow a non-parenthesized expression that raises
3134 -- constraint error if it rewrites what used to be a variable
3136 elsif Raises_Constraint_Error (Expression (AV))
3137 and then Paren_Count (Expression (AV)) = 0
3138 and then Is_Variable (Original_Node (Expression (AV)))
3142 -- Type conversion of something other than a variable
3148 -- If this node is rewritten, then test the original form, if that is
3149 -- OK, then we consider the rewritten node OK (for example, if the
3150 -- original node is a conversion, then Is_Variable will not be true
3151 -- but we still want to allow the conversion if it converts a variable.
3153 elsif Original_Node (AV) /= AV then
3154 return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
3156 -- All other non-variables are rejected
3161 end Is_OK_Variable_For_Out_Formal;
3163 -----------------------------
3164 -- Is_RCI_Pkg_Spec_Or_Body --
3165 -----------------------------
3167 function Is_RCI_Pkg_Spec_Or_Body (Cunit : Node_Id) return Boolean is
3169 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean;
3170 -- Return True if the unit of Cunit is an RCI package declaration
3172 ---------------------------
3173 -- Is_RCI_Pkg_Decl_Cunit --
3174 ---------------------------
3176 function Is_RCI_Pkg_Decl_Cunit (Cunit : Node_Id) return Boolean is
3177 The_Unit : constant Node_Id := Unit (Cunit);
3180 if Nkind (The_Unit) /= N_Package_Declaration then
3183 return Is_Remote_Call_Interface (Defining_Entity (The_Unit));
3184 end Is_RCI_Pkg_Decl_Cunit;
3186 -- Start of processing for Is_RCI_Pkg_Spec_Or_Body
3189 return Is_RCI_Pkg_Decl_Cunit (Cunit)
3191 (Nkind (Unit (Cunit)) = N_Package_Body
3192 and then Is_RCI_Pkg_Decl_Cunit (Library_Unit (Cunit)));
3193 end Is_RCI_Pkg_Spec_Or_Body;
3195 -----------------------------------------
3196 -- Is_Remote_Access_To_Class_Wide_Type --
3197 -----------------------------------------
3199 function Is_Remote_Access_To_Class_Wide_Type
3205 function Comes_From_Limited_Private_Type_Declaration
3208 -- Check if the original declaration is a limited private one and
3209 -- if all the derivations have been using private extensions.
3211 -------------------------------------------------
3212 -- Comes_From_Limited_Private_Type_Declaration --
3213 -------------------------------------------------
3215 function Comes_From_Limited_Private_Type_Declaration (E : in Entity_Id)
3218 N : constant Node_Id := Declaration_Node (E);
3220 if Nkind (N) = N_Private_Type_Declaration
3221 and then Limited_Present (N)
3226 if Nkind (N) = N_Private_Extension_Declaration then
3227 return Comes_From_Limited_Private_Type_Declaration (Etype (E));
3231 end Comes_From_Limited_Private_Type_Declaration;
3233 -- Start of processing for Is_Remote_Access_To_Class_Wide_Type
3236 if not (Is_Remote_Call_Interface (E)
3237 or else Is_Remote_Types (E))
3238 or else Ekind (E) /= E_General_Access_Type
3243 D := Designated_Type (E);
3245 if Ekind (D) /= E_Class_Wide_Type then
3249 return Comes_From_Limited_Private_Type_Declaration
3250 (Defining_Identifier (Parent (D)));
3251 end Is_Remote_Access_To_Class_Wide_Type;
3253 -----------------------------------------
3254 -- Is_Remote_Access_To_Subprogram_Type --
3255 -----------------------------------------
3257 function Is_Remote_Access_To_Subprogram_Type
3262 return (Ekind (E) = E_Access_Subprogram_Type
3263 or else (Ekind (E) = E_Record_Type
3264 and then Present (Corresponding_Remote_Type (E))))
3265 and then (Is_Remote_Call_Interface (E)
3266 or else Is_Remote_Types (E));
3267 end Is_Remote_Access_To_Subprogram_Type;
3269 --------------------
3270 -- Is_Remote_Call --
3271 --------------------
3273 function Is_Remote_Call (N : Node_Id) return Boolean is
3275 if Nkind (N) /= N_Procedure_Call_Statement
3276 and then Nkind (N) /= N_Function_Call
3278 -- An entry call cannot be remote
3282 elsif Nkind (Name (N)) in N_Has_Entity
3283 and then Is_Remote_Call_Interface (Entity (Name (N)))
3285 -- A subprogram declared in the spec of a RCI package is remote
3289 elsif Nkind (Name (N)) = N_Explicit_Dereference
3290 and then Is_Remote_Access_To_Subprogram_Type
3291 (Etype (Prefix (Name (N))))
3293 -- The dereference of a RAS is a remote call
3297 elsif Present (Controlling_Argument (N))
3298 and then Is_Remote_Access_To_Class_Wide_Type
3299 (Etype (Controlling_Argument (N)))
3301 -- Any primitive operation call with a controlling argument of
3302 -- a RACW type is a remote call.
3307 -- All other calls are local calls
3312 ----------------------
3313 -- Is_Selector_Name --
3314 ----------------------
3316 function Is_Selector_Name (N : Node_Id) return Boolean is
3319 if not Is_List_Member (N) then
3321 P : constant Node_Id := Parent (N);
3322 K : constant Node_Kind := Nkind (P);
3326 (K = N_Expanded_Name or else
3327 K = N_Generic_Association or else
3328 K = N_Parameter_Association or else
3329 K = N_Selected_Component)
3330 and then Selector_Name (P) = N;
3335 L : constant List_Id := List_Containing (N);
3336 P : constant Node_Id := Parent (L);
3339 return (Nkind (P) = N_Discriminant_Association
3340 and then Selector_Names (P) = L)
3342 (Nkind (P) = N_Component_Association
3343 and then Choices (P) = L);
3346 end Is_Selector_Name;
3352 function Is_Statement (N : Node_Id) return Boolean is
3355 Nkind (N) in N_Statement_Other_Than_Procedure_Call
3356 or else Nkind (N) = N_Procedure_Call_Statement;
3363 function Is_Transfer (N : Node_Id) return Boolean is
3364 Kind : constant Node_Kind := Nkind (N);
3367 if Kind = N_Return_Statement
3369 Kind = N_Goto_Statement
3371 Kind = N_Raise_Statement
3373 Kind = N_Requeue_Statement
3377 elsif (Kind = N_Exit_Statement or else Kind in N_Raise_xxx_Error)
3378 and then No (Condition (N))
3382 elsif Kind = N_Procedure_Call_Statement
3383 and then Is_Entity_Name (Name (N))
3384 and then Present (Entity (Name (N)))
3385 and then No_Return (Entity (Name (N)))
3389 elsif Nkind (Original_Node (N)) = N_Raise_Statement then
3401 function Is_True (U : Uint) return Boolean is
3410 function Is_Variable (N : Node_Id) return Boolean is
3412 Orig_Node : constant Node_Id := Original_Node (N);
3413 -- We do the test on the original node, since this is basically a
3414 -- test of syntactic categories, so it must not be disturbed by
3415 -- whatever rewriting might have occurred. For example, an aggregate,
3416 -- which is certainly NOT a variable, could be turned into a variable
3419 function In_Protected_Function (E : Entity_Id) return Boolean;
3420 -- Within a protected function, the private components of the
3421 -- enclosing protected type are constants. A function nested within
3422 -- a (protected) procedure is not itself protected.
3424 function Is_Variable_Prefix (P : Node_Id) return Boolean;
3425 -- Prefixes can involve implicit dereferences, in which case we
3426 -- must test for the case of a reference of a constant access
3427 -- type, which can never be a variable.
3429 function In_Protected_Function (E : Entity_Id) return Boolean is
3430 Prot : constant Entity_Id := Scope (E);
3434 if not Is_Protected_Type (Prot) then
3439 while Present (S) and then S /= Prot loop
3441 if Ekind (S) = E_Function
3442 and then Scope (S) = Prot
3452 end In_Protected_Function;
3454 function Is_Variable_Prefix (P : Node_Id) return Boolean is
3456 if Is_Access_Type (Etype (P)) then
3457 return not Is_Access_Constant (Root_Type (Etype (P)));
3459 return Is_Variable (P);
3461 end Is_Variable_Prefix;
3463 -- Start of processing for Is_Variable
3466 -- Definitely OK if Assignment_OK is set. Since this is something that
3467 -- only gets set for expanded nodes, the test is on N, not Orig_Node.
3469 if Nkind (N) in N_Subexpr and then Assignment_OK (N) then
3472 -- Normally we go to the original node, but there is one exception
3473 -- where we use the rewritten node, namely when it is an explicit
3474 -- dereference. The generated code may rewrite a prefix which is an
3475 -- access type with an explicit dereference. The dereference is a
3476 -- variable, even though the original node may not be (since it could
3477 -- be a constant of the access type).
3479 elsif Nkind (N) = N_Explicit_Dereference
3480 and then Nkind (Orig_Node) /= N_Explicit_Dereference
3481 and then Is_Access_Type (Etype (Orig_Node))
3483 return Is_Variable_Prefix (Original_Node (Prefix (N)));
3485 -- All remaining checks use the original node
3487 elsif Is_Entity_Name (Orig_Node) then
3489 E : constant Entity_Id := Entity (Orig_Node);
3490 K : constant Entity_Kind := Ekind (E);
3493 return (K = E_Variable
3494 and then Nkind (Parent (E)) /= N_Exception_Handler)
3495 or else (K = E_Component
3496 and then not In_Protected_Function (E))
3497 or else K = E_Out_Parameter
3498 or else K = E_In_Out_Parameter
3499 or else K = E_Generic_In_Out_Parameter
3501 -- Current instance of type:
3503 or else (Is_Type (E) and then In_Open_Scopes (E))
3504 or else (Is_Incomplete_Or_Private_Type (E)
3505 and then In_Open_Scopes (Full_View (E)));
3509 case Nkind (Orig_Node) is
3510 when N_Indexed_Component | N_Slice =>
3511 return Is_Variable_Prefix (Prefix (Orig_Node));
3513 when N_Selected_Component =>
3514 return Is_Variable_Prefix (Prefix (Orig_Node))
3515 and then Is_Variable (Selector_Name (Orig_Node));
3517 -- For an explicit dereference, we must check whether the type
3518 -- is ACCESS CONSTANT, since if it is, then it is not a variable.
3520 when N_Explicit_Dereference =>
3521 return Is_Access_Type (Etype (Prefix (Orig_Node)))
3523 Is_Access_Constant (Root_Type (Etype (Prefix (Orig_Node))));
3525 -- The type conversion is the case where we do not deal with the
3526 -- context dependent special case of an actual parameter. Thus
3527 -- the type conversion is only considered a variable for the
3528 -- purposes of this routine if the target type is tagged. However,
3529 -- a type conversion is considered to be a variable if it does not
3530 -- come from source (this deals for example with the conversions
3531 -- of expressions to their actual subtypes).
3533 when N_Type_Conversion =>
3534 return Is_Variable (Expression (Orig_Node))
3536 (not Comes_From_Source (Orig_Node)
3538 (Is_Tagged_Type (Etype (Subtype_Mark (Orig_Node)))
3540 Is_Tagged_Type (Etype (Expression (Orig_Node)))));
3542 -- GNAT allows an unchecked type conversion as a variable. This
3543 -- only affects the generation of internal expanded code, since
3544 -- calls to instantiations of Unchecked_Conversion are never
3545 -- considered variables (since they are function calls).
3546 -- This is also true for expression actions.
3548 when N_Unchecked_Type_Conversion =>
3549 return Is_Variable (Expression (Orig_Node));
3557 ------------------------
3558 -- Is_Volatile_Object --
3559 ------------------------
3561 function Is_Volatile_Object (N : Node_Id) return Boolean is
3563 function Object_Has_Volatile_Components (N : Node_Id) return Boolean;
3564 -- Determines if given object has volatile components
3566 function Is_Volatile_Prefix (N : Node_Id) return Boolean;
3567 -- If prefix is an implicit dereference, examine designated type.
3569 function Is_Volatile_Prefix (N : Node_Id) return Boolean is
3571 if Is_Access_Type (Etype (N)) then
3572 return Has_Volatile_Components (Designated_Type (Etype (N)));
3574 return Object_Has_Volatile_Components (N);
3576 end Is_Volatile_Prefix;
3578 function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
3580 if Is_Volatile (Etype (N))
3581 or else Has_Volatile_Components (Etype (N))
3585 elsif Is_Entity_Name (N)
3586 and then (Has_Volatile_Components (Entity (N))
3587 or else Is_Volatile (Entity (N)))
3591 elsif Nkind (N) = N_Indexed_Component
3592 or else Nkind (N) = N_Selected_Component
3594 return Is_Volatile_Prefix (Prefix (N));
3599 end Object_Has_Volatile_Components;
3601 -- Start of processing for Is_Volatile_Object
3604 if Is_Volatile (Etype (N))
3605 or else (Is_Entity_Name (N) and then Is_Volatile (Entity (N)))
3609 elsif Nkind (N) = N_Indexed_Component
3610 or else Nkind (N) = N_Selected_Component
3612 return Is_Volatile_Prefix (Prefix (N));
3617 end Is_Volatile_Object;
3619 --------------------------
3620 -- Kill_Size_Check_Code --
3621 --------------------------
3623 procedure Kill_Size_Check_Code (E : Entity_Id) is
3625 if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
3626 and then Present (Size_Check_Code (E))
3628 Remove (Size_Check_Code (E));
3629 Set_Size_Check_Code (E, Empty);
3631 end Kill_Size_Check_Code;
3633 -------------------------
3634 -- New_External_Entity --
3635 -------------------------
3637 function New_External_Entity
3638 (Kind : Entity_Kind;
3639 Scope_Id : Entity_Id;
3640 Sloc_Value : Source_Ptr;
3641 Related_Id : Entity_Id;
3643 Suffix_Index : Nat := 0;
3644 Prefix : Character := ' ')
3647 N : constant Entity_Id :=
3648 Make_Defining_Identifier (Sloc_Value,
3650 (Chars (Related_Id), Suffix, Suffix_Index, Prefix));
3653 Set_Ekind (N, Kind);
3654 Set_Is_Internal (N, True);
3655 Append_Entity (N, Scope_Id);
3656 Set_Public_Status (N);
3658 if Kind in Type_Kind then
3659 Init_Size_Align (N);
3663 end New_External_Entity;
3665 -------------------------
3666 -- New_Internal_Entity --
3667 -------------------------
3669 function New_Internal_Entity
3670 (Kind : Entity_Kind;
3671 Scope_Id : Entity_Id;
3672 Sloc_Value : Source_Ptr;
3673 Id_Char : Character)
3676 N : constant Entity_Id :=
3677 Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
3680 Set_Ekind (N, Kind);
3681 Set_Is_Internal (N, True);
3682 Append_Entity (N, Scope_Id);
3684 if Kind in Type_Kind then
3685 Init_Size_Align (N);
3689 end New_Internal_Entity;
3695 function Next_Actual (Actual_Id : Node_Id) return Node_Id is
3699 -- If we are pointing at a positional parameter, it is a member of
3700 -- a node list (the list of parameters), and the next parameter
3701 -- is the next node on the list, unless we hit a parameter
3702 -- association, in which case we shift to using the chain whose
3703 -- head is the First_Named_Actual in the parent, and then is
3704 -- threaded using the Next_Named_Actual of the Parameter_Association.
3705 -- All this fiddling is because the original node list is in the
3706 -- textual call order, and what we need is the declaration order.
3708 if Is_List_Member (Actual_Id) then
3709 N := Next (Actual_Id);
3711 if Nkind (N) = N_Parameter_Association then
3712 return First_Named_Actual (Parent (Actual_Id));
3718 return Next_Named_Actual (Parent (Actual_Id));
3722 procedure Next_Actual (Actual_Id : in out Node_Id) is
3724 Actual_Id := Next_Actual (Actual_Id);
3727 -----------------------
3728 -- Normalize_Actuals --
3729 -----------------------
3731 -- Chain actuals according to formals of subprogram. If there are
3732 -- no named associations, the chain is simply the list of Parameter
3733 -- Associations, since the order is the same as the declaration order.
3734 -- If there are named associations, then the First_Named_Actual field
3735 -- in the N_Procedure_Call_Statement node or N_Function_Call node
3736 -- points to the Parameter_Association node for the parameter that
3737 -- comes first in declaration order. The remaining named parameters
3738 -- are then chained in declaration order using Next_Named_Actual.
3740 -- This routine also verifies that the number of actuals is compatible
3741 -- with the number and default values of formals, but performs no type
3742 -- checking (type checking is done by the caller).
3744 -- If the matching succeeds, Success is set to True, and the caller
3745 -- proceeds with type-checking. If the match is unsuccessful, then
3746 -- Success is set to False, and the caller attempts a different
3747 -- interpretation, if there is one.
3749 -- If the flag Report is on, the call is not overloaded, and a failure
3750 -- to match can be reported here, rather than in the caller.
3752 procedure Normalize_Actuals
3756 Success : out Boolean)
3758 Actuals : constant List_Id := Parameter_Associations (N);
3759 Actual : Node_Id := Empty;
3761 Last : Node_Id := Empty;
3762 First_Named : Node_Id := Empty;
3765 Formals_To_Match : Integer := 0;
3766 Actuals_To_Match : Integer := 0;
3768 procedure Chain (A : Node_Id);
3769 -- Add named actual at the proper place in the list, using the
3770 -- Next_Named_Actual link.
3772 function Reporting return Boolean;
3773 -- Determines if an error is to be reported. To report an error, we
3774 -- need Report to be True, and also we do not report errors caused
3775 -- by calls to Init_Proc's that occur within other Init_Proc's. Such
3776 -- errors must always be cascaded errors, since if all the types are
3777 -- declared correctly, the compiler will certainly build decent calls!
3779 procedure Chain (A : Node_Id) is
3783 -- Call node points to first actual in list.
3785 Set_First_Named_Actual (N, Explicit_Actual_Parameter (A));
3788 Set_Next_Named_Actual (Last, Explicit_Actual_Parameter (A));
3792 Set_Next_Named_Actual (Last, Empty);
3795 function Reporting return Boolean is
3800 elsif not Within_Init_Proc then
3803 elsif Chars (Entity (Name (N))) = Name_uInit_Proc then
3811 -- Start of processing for Normalize_Actuals
3814 if Is_Access_Type (S) then
3816 -- The name in the call is a function call that returns an access
3817 -- to subprogram. The designated type has the list of formals.
3819 Formal := First_Formal (Designated_Type (S));
3821 Formal := First_Formal (S);
3824 while Present (Formal) loop
3825 Formals_To_Match := Formals_To_Match + 1;
3826 Next_Formal (Formal);
3829 -- Find if there is a named association, and verify that no positional
3830 -- associations appear after named ones.
3832 if Present (Actuals) then
3833 Actual := First (Actuals);
3836 while Present (Actual)
3837 and then Nkind (Actual) /= N_Parameter_Association
3839 Actuals_To_Match := Actuals_To_Match + 1;
3843 if No (Actual) and Actuals_To_Match = Formals_To_Match then
3845 -- Most common case: positional notation, no defaults
3850 elsif Actuals_To_Match > Formals_To_Match then
3852 -- Too many actuals: will not work.
3855 Error_Msg_N ("too many arguments in call", N);
3862 First_Named := Actual;
3864 while Present (Actual) loop
3865 if Nkind (Actual) /= N_Parameter_Association then
3867 ("positional parameters not allowed after named ones", Actual);
3872 Actuals_To_Match := Actuals_To_Match + 1;
3878 if Present (Actuals) then
3879 Actual := First (Actuals);
3882 Formal := First_Formal (S);
3884 while Present (Formal) loop
3886 -- Match the formals in order. If the corresponding actual
3887 -- is positional, nothing to do. Else scan the list of named
3888 -- actuals to find the one with the right name.
3891 and then Nkind (Actual) /= N_Parameter_Association
3894 Actuals_To_Match := Actuals_To_Match - 1;
3895 Formals_To_Match := Formals_To_Match - 1;
3898 -- For named parameters, search the list of actuals to find
3899 -- one that matches the next formal name.
3901 Actual := First_Named;
3904 while Present (Actual) loop
3905 if Chars (Selector_Name (Actual)) = Chars (Formal) then
3908 Actuals_To_Match := Actuals_To_Match - 1;
3909 Formals_To_Match := Formals_To_Match - 1;
3917 if Ekind (Formal) /= E_In_Parameter
3918 or else No (Default_Value (Formal))
3921 if Comes_From_Source (S)
3922 and then Is_Overloadable (S)
3924 Error_Msg_Name_1 := Chars (S);
3925 Error_Msg_Sloc := Sloc (S);
3927 ("missing argument for parameter & " &
3928 "in call to % declared #", N, Formal);
3931 ("missing argument for parameter &", N, Formal);
3939 Formals_To_Match := Formals_To_Match - 1;
3944 Next_Formal (Formal);
3947 if Formals_To_Match = 0 and then Actuals_To_Match = 0 then
3954 -- Find some superfluous named actual that did not get
3955 -- attached to the list of associations.
3957 Actual := First (Actuals);
3959 while Present (Actual) loop
3961 if Nkind (Actual) = N_Parameter_Association
3962 and then Actual /= Last
3963 and then No (Next_Named_Actual (Actual))
3965 Error_Msg_N ("Unmatched actual in call", Actual);
3976 end Normalize_Actuals;
3978 --------------------------------
3979 -- Note_Possible_Modification --
3980 --------------------------------
3982 procedure Note_Possible_Modification (N : Node_Id) is
3986 procedure Set_Ref (E : Entity_Id; N : Node_Id);
3987 -- Internal routine to note modification on entity E by node N
3989 procedure Set_Ref (E : Entity_Id; N : Node_Id) is
3991 Set_Not_Source_Assigned (E, False);
3992 Set_Is_True_Constant (E, False);
3993 Generate_Reference (E, N, 'm');
3996 -- Start of processing for Note_Possible_Modification
3999 -- Loop to find referenced entity, if there is one
4003 -- Test for node rewritten as dereference (e.g. accept parameter)
4005 if Nkind (Exp) = N_Explicit_Dereference
4006 and then Is_Entity_Name (Original_Node (Exp))
4008 Set_Ref (Entity (Original_Node (Exp)), Original_Node (Exp));
4011 elsif Is_Entity_Name (Exp) then
4012 Ent := Entity (Exp);
4014 if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
4015 and then Present (Renamed_Object (Ent))
4017 Exp := Renamed_Object (Ent);
4024 elsif Nkind (Exp) = N_Type_Conversion
4025 or else Nkind (Exp) = N_Unchecked_Type_Conversion
4027 Exp := Expression (Exp);
4029 elsif Nkind (Exp) = N_Slice
4030 or else Nkind (Exp) = N_Indexed_Component
4031 or else Nkind (Exp) = N_Selected_Component
4033 Exp := Prefix (Exp);
4039 end Note_Possible_Modification;
4041 -------------------------
4042 -- Object_Access_Level --
4043 -------------------------
4045 function Object_Access_Level (Obj : Node_Id) return Uint is
4048 -- Returns the static accessibility level of the view denoted
4049 -- by Obj. Note that the value returned is the result of a
4050 -- call to Scope_Depth. Only scope depths associated with
4051 -- dynamic scopes can actually be returned. Since only
4052 -- relative levels matter for accessibility checking, the fact
4053 -- that the distance between successive levels of accessibility
4054 -- is not always one is immaterial (invariant: if level(E2) is
4055 -- deeper than level(E1), then Scope_Depth(E1) < Scope_Depth(E2)).
4058 if Is_Entity_Name (Obj) then
4061 -- If E is a type then it denotes a current instance.
4062 -- For this case we add one to the normal accessibility
4063 -- level of the type to ensure that current instances
4064 -- are treated as always being deeper than than the level
4065 -- of any visible named access type (see 3.10.2(21)).
4068 return Type_Access_Level (E) + 1;
4070 elsif Present (Renamed_Object (E)) then
4071 return Object_Access_Level (Renamed_Object (E));
4073 -- Similarly, if E is a component of the current instance of a
4074 -- protected type, any instance of it is assumed to be at a deeper
4075 -- level than the type. For a protected object (whose type is an
4076 -- anonymous protected type) its components are at the same level
4077 -- as the type itself.
4079 elsif not Is_Overloadable (E)
4080 and then Ekind (Scope (E)) = E_Protected_Type
4081 and then Comes_From_Source (Scope (E))
4083 return Type_Access_Level (Scope (E)) + 1;
4086 return Scope_Depth (Enclosing_Dynamic_Scope (E));
4089 elsif Nkind (Obj) = N_Selected_Component then
4090 if Is_Access_Type (Etype (Prefix (Obj))) then
4091 return Type_Access_Level (Etype (Prefix (Obj)));
4093 return Object_Access_Level (Prefix (Obj));
4096 elsif Nkind (Obj) = N_Indexed_Component then
4097 if Is_Access_Type (Etype (Prefix (Obj))) then
4098 return Type_Access_Level (Etype (Prefix (Obj)));
4100 return Object_Access_Level (Prefix (Obj));
4103 elsif Nkind (Obj) = N_Explicit_Dereference then
4105 -- If the prefix is a selected access discriminant then
4106 -- we make a recursive call on the prefix, which will
4107 -- in turn check the level of the prefix object of
4108 -- the selected discriminant.
4110 if Nkind (Prefix (Obj)) = N_Selected_Component
4111 and then Ekind (Etype (Prefix (Obj))) = E_Anonymous_Access_Type
4113 Ekind (Entity (Selector_Name (Prefix (Obj)))) = E_Discriminant
4115 return Object_Access_Level (Prefix (Obj));
4117 return Type_Access_Level (Etype (Prefix (Obj)));
4120 elsif Nkind (Obj) = N_Type_Conversion then
4121 return Object_Access_Level (Expression (Obj));
4123 -- Function results are objects, so we get either the access level
4124 -- of the function or, in the case of an indirect call, the level of
4125 -- of the access-to-subprogram type.
4127 elsif Nkind (Obj) = N_Function_Call then
4128 if Is_Entity_Name (Name (Obj)) then
4129 return Subprogram_Access_Level (Entity (Name (Obj)));
4131 return Type_Access_Level (Etype (Prefix (Name (Obj))));
4134 -- For convenience we handle qualified expressions, even though
4135 -- they aren't technically object names.
4137 elsif Nkind (Obj) = N_Qualified_Expression then
4138 return Object_Access_Level (Expression (Obj));
4140 -- Otherwise return the scope level of Standard.
4141 -- (If there are cases that fall through
4142 -- to this point they will be treated as
4143 -- having global accessibility for now. ???)
4146 return Scope_Depth (Standard_Standard);
4148 end Object_Access_Level;
4150 -----------------------
4151 -- Private_Component --
4152 -----------------------
4154 function Private_Component (Type_Id : Entity_Id) return Entity_Id is
4155 Ancestor : constant Entity_Id := Base_Type (Type_Id);
4157 function Trace_Components
4161 -- Recursive function that does the work, and checks against circular
4162 -- definition for each subcomponent type.
4164 ----------------------
4165 -- Trace_Components --
4166 ----------------------
4168 function Trace_Components
4170 Check : Boolean) return Entity_Id
4172 Btype : constant Entity_Id := Base_Type (T);
4173 Component : Entity_Id;
4175 Candidate : Entity_Id := Empty;
4178 if Check and then Btype = Ancestor then
4179 Error_Msg_N ("circular type definition", Type_Id);
4183 if Is_Private_Type (Btype)
4184 and then not Is_Generic_Type (Btype)
4188 elsif Is_Array_Type (Btype) then
4189 return Trace_Components (Component_Type (Btype), True);
4191 elsif Is_Record_Type (Btype) then
4192 Component := First_Entity (Btype);
4193 while Present (Component) loop
4195 -- skip anonymous types generated by constrained components.
4197 if not Is_Type (Component) then
4198 P := Trace_Components (Etype (Component), True);
4201 if P = Any_Type then
4209 Next_Entity (Component);
4217 end Trace_Components;
4219 -- Start of processing for Private_Component
4222 return Trace_Components (Type_Id, False);
4223 end Private_Component;
4225 -----------------------
4226 -- Process_End_Label --
4227 -----------------------
4229 procedure Process_End_Label (N : Node_Id; Typ : Character) is
4234 Label_Ref : Boolean;
4235 -- Set True if reference to end label itself is required
4238 -- Gets set to the operator symbol or identifier that references
4239 -- the entity Ent. For the child unit case, this is the identifier
4240 -- from the designator. For other cases, this is simply Endl.
4243 -- This is the entity for the construct to which the End_Label applies
4245 procedure Generate_Parent_Ref (N : Node_Id);
4246 -- N is an identifier node that appears as a parent unit reference
4247 -- in the case where Ent is a child unit. This procedure generates
4248 -- an appropriate cross-reference entry.
4250 procedure Generate_Parent_Ref (N : Node_Id) is
4251 Parent_Ent : Entity_Id;
4254 -- Search up scope stack. The reason we do this is that normal
4255 -- visibility analysis would not work for two reasons. First in
4256 -- some subunit cases, the entry for the parent unit may not be
4257 -- visible, and in any case there can be a local entity that
4258 -- hides the scope entity.
4260 Parent_Ent := Current_Scope;
4261 while Present (Parent_Ent) loop
4262 if Chars (Parent_Ent) = Chars (N) then
4264 -- Generate the reference. We do NOT consider this as a
4265 -- reference for unreferenced symbol purposes, but we do
4266 -- force a cross-reference even if the end line does not
4267 -- come from source (the caller already generated the
4268 -- appropriate Typ for this situation).
4271 (Parent_Ent, N, 'r', Set_Ref => False, Force => True);
4272 Style.Check_Identifier (N, Parent_Ent);
4276 Parent_Ent := Scope (Parent_Ent);
4279 -- Fall through means entity was not found -- that's odd, but
4280 -- the appropriate thing is simply to ignore and not generate
4281 -- any cross-reference for this entry.
4284 end Generate_Parent_Ref;
4286 -- Start of processing for Process_End_Label
4289 -- If no node, ignore. This happens in some error situations,
4290 -- and also for some internally generated structures where no
4291 -- end label references are required in any case.
4297 -- Nothing to do if no End_Label, happens for internally generated
4298 -- constructs where we don't want an end label reference anyway.
4299 -- Also nothing to do if Endl is a string literal, which means
4300 -- there was some prior error (bad operator symbol)
4302 Endl := End_Label (N);
4304 if No (Endl) or else Nkind (Endl) = N_String_Literal then
4308 -- Reference node is not in extended main source unit
4310 if not In_Extended_Main_Source_Unit (N) then
4312 -- Generally we do not collect references except for the
4313 -- extended main source unit. The one exception is the 'e'
4314 -- entry for a package spec, where it is useful for a client
4315 -- to have the ending information to define scopes.
4323 -- For this case, we can ignore any parent references,
4324 -- but we need the package name itself for the 'e' entry.
4326 if Nkind (Endl) = N_Designator then
4327 Endl := Identifier (Endl);
4331 -- Reference is in extended main source unit
4336 -- For designator, generate references for the parent entries
4338 if Nkind (Endl) = N_Designator then
4340 -- Generate references for the prefix if the END line comes
4341 -- from source (otherwise we do not need these references)
4343 if Comes_From_Source (Endl) then
4345 while Nkind (Nam) = N_Selected_Component loop
4346 Generate_Parent_Ref (Selector_Name (Nam));
4347 Nam := Prefix (Nam);
4350 Generate_Parent_Ref (Nam);
4353 Endl := Identifier (Endl);
4357 -- Locate the entity to which the end label applies. Most of the
4358 -- time this is simply the current scope containing the construct.
4360 Ent := Current_Scope;
4362 if Chars (Ent) = Chars (Endl) then
4365 -- But in the case of single tasks and single protected objects,
4366 -- the current scope is the anonymous task or protected type and
4367 -- what we want is the object. There is no direct link so what we
4368 -- do is search ahead in the entity chain for the object with the
4369 -- matching type and name. In practice it is almost certain to be
4370 -- the very next entity on the chain, so this is not inefficient.
4373 Ctyp := Etype (Ent);
4377 -- If we don't find the entry we are looking for, that's
4378 -- odd, perhaps results from some error condition? Anyway
4379 -- the appropriate thing is just to abandon the attempt.
4384 -- Exit if we find the entity we are looking for
4386 elsif Etype (Ent) = Ctyp
4387 and then Chars (Ent) = Chars (Endl)
4394 -- If label was really there, then generate a normal reference
4395 -- and then adjust the location in the end label to point past
4396 -- the name (which should almost always be the semicolon).
4400 if Comes_From_Source (Endl) then
4402 -- If a label reference is required, then do the style check
4403 -- and generate a normal cross-reference entry for the label
4406 Style.Check_Identifier (Endl, Ent);
4407 Generate_Reference (Ent, Endl, 'r', Set_Ref => False);
4410 -- Set the location to point past the label (normally this will
4411 -- mean the semicolon immediately following the label). This is
4412 -- done for the sake of the 'e' or 't' entry generated below.
4414 Get_Decoded_Name_String (Chars (Endl));
4415 Set_Sloc (Endl, Sloc (Endl) + Source_Ptr (Name_Len));
4418 -- Now generate the e/t reference
4420 Generate_Reference (Ent, Endl, Typ, Set_Ref => False, Force => True);
4422 -- Restore Sloc, in case modified above, since we have an identifier
4423 -- and the normal Sloc should be left set in the tree.
4425 Set_Sloc (Endl, Loc);
4426 end Process_End_Label;
4432 -- We do the conversion to get the value of the real string by using
4433 -- the scanner, see Sinput for details on use of the internal source
4434 -- buffer for scanning internal strings.
4436 function Real_Convert (S : String) return Node_Id is
4437 Save_Src : constant Source_Buffer_Ptr := Source;
4441 Source := Internal_Source_Ptr;
4444 for J in S'Range loop
4445 Source (Source_Ptr (J)) := S (J);
4448 Source (S'Length + 1) := EOF;
4450 if Source (Scan_Ptr) = '-' then
4452 Scan_Ptr := Scan_Ptr + 1;
4460 Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
4467 ------------------------------
4468 -- Requires_Transient_Scope --
4469 ------------------------------
4471 -- A transient scope is required when variable-sized temporaries are
4472 -- allocated in the primary or secondary stack, or when finalization
4473 -- actions must be generated before the next instruction
4475 function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
4476 Typ : constant Entity_Id := Underlying_Type (Id);
4479 -- This is a private type which is not completed yet. This can only
4480 -- happen in a default expression (of a formal parameter or of a
4481 -- record component). Do not expand transient scope in this case
4486 elsif Typ = Standard_Void_Type then
4489 -- The back-end has trouble allocating variable-size temporaries so
4490 -- we generate them in the front-end and need a transient scope to
4491 -- reclaim them properly
4493 elsif not Size_Known_At_Compile_Time (Typ) then
4496 -- Unconstrained discriminated records always require a variable
4497 -- length temporary, since the length may depend on the variant.
4499 elsif Is_Record_Type (Typ)
4500 and then Has_Discriminants (Typ)
4501 and then not Is_Constrained (Typ)
4505 -- Functions returning tagged types may dispatch on result so their
4506 -- returned value is allocated on the secondary stack. Controlled
4507 -- type temporaries need finalization.
4509 elsif Is_Tagged_Type (Typ)
4510 or else Has_Controlled_Component (Typ)
4514 -- Unconstrained array types are returned on the secondary stack
4516 elsif Is_Array_Type (Typ) then
4517 return not Is_Constrained (Typ);
4521 end Requires_Transient_Scope;
4523 --------------------------
4524 -- Reset_Analyzed_Flags --
4525 --------------------------
4527 procedure Reset_Analyzed_Flags (N : Node_Id) is
4529 function Clear_Analyzed
4531 return Traverse_Result;
4532 -- Function used to reset Analyzed flags in tree. Note that we do
4533 -- not reset Analyzed flags in entities, since there is no need to
4534 -- renalalyze entities, and indeed, it is wrong to do so, since it
4535 -- can result in generating auxiliary stuff more than once.
4537 function Clear_Analyzed
4539 return Traverse_Result
4542 if not Has_Extension (N) then
4543 Set_Analyzed (N, False);
4549 function Reset_Analyzed is
4550 new Traverse_Func (Clear_Analyzed);
4552 Discard : Traverse_Result;
4554 -- Start of processing for Reset_Analyzed_Flags
4557 Discard := Reset_Analyzed (N);
4558 end Reset_Analyzed_Flags;
4564 function Same_Name (N1, N2 : Node_Id) return Boolean is
4565 K1 : constant Node_Kind := Nkind (N1);
4566 K2 : constant Node_Kind := Nkind (N2);
4569 if (K1 = N_Identifier or else K1 = N_Defining_Identifier)
4570 and then (K2 = N_Identifier or else K2 = N_Defining_Identifier)
4572 return Chars (N1) = Chars (N2);
4574 elsif (K1 = N_Selected_Component or else K1 = N_Expanded_Name)
4575 and then (K2 = N_Selected_Component or else K2 = N_Expanded_Name)
4577 return Same_Name (Selector_Name (N1), Selector_Name (N2))
4578 and then Same_Name (Prefix (N1), Prefix (N2));
4589 function Same_Type (T1, T2 : Entity_Id) return Boolean is
4594 elsif not Is_Constrained (T1)
4595 and then not Is_Constrained (T2)
4596 and then Base_Type (T1) = Base_Type (T2)
4600 -- For now don't bother with case of identical constraints, to be
4601 -- fiddled with later on perhaps (this is only used for optimization
4602 -- purposes, so it is not critical to do a best possible job)
4609 ------------------------
4610 -- Scope_Is_Transient --
4611 ------------------------
4613 function Scope_Is_Transient return Boolean is
4615 return Scope_Stack.Table (Scope_Stack.Last).Is_Transient;
4616 end Scope_Is_Transient;
4622 function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is
4627 while Scop /= Standard_Standard loop
4628 Scop := Scope (Scop);
4630 if Scop = Scope2 then
4638 --------------------------
4639 -- Scope_Within_Or_Same --
4640 --------------------------
4642 function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is
4647 while Scop /= Standard_Standard loop
4648 if Scop = Scope2 then
4651 Scop := Scope (Scop);
4656 end Scope_Within_Or_Same;
4658 ------------------------
4659 -- Set_Current_Entity --
4660 ------------------------
4662 -- The given entity is to be set as the currently visible definition
4663 -- of its associated name (i.e. the Node_Id associated with its name).
4664 -- All we have to do is to get the name from the identifier, and
4665 -- then set the associated Node_Id to point to the given entity.
4667 procedure Set_Current_Entity (E : Entity_Id) is
4669 Set_Name_Entity_Id (Chars (E), E);
4670 end Set_Current_Entity;
4672 ---------------------------------
4673 -- Set_Entity_With_Style_Check --
4674 ---------------------------------
4676 procedure Set_Entity_With_Style_Check (N : Node_Id; Val : Entity_Id) is
4677 Val_Actual : Entity_Id;
4681 Set_Entity (N, Val);
4684 and then not Suppress_Style_Checks (Val)
4685 and then not In_Instance
4687 if Nkind (N) = N_Identifier then
4690 elsif Nkind (N) = N_Expanded_Name then
4691 Nod := Selector_Name (N);
4699 -- A special situation arises for derived operations, where we want
4700 -- to do the check against the parent (since the Sloc of the derived
4701 -- operation points to the derived type declaration itself).
4703 while not Comes_From_Source (Val_Actual)
4704 and then Nkind (Val_Actual) in N_Entity
4705 and then (Ekind (Val_Actual) = E_Enumeration_Literal
4706 or else Ekind (Val_Actual) = E_Function
4707 or else Ekind (Val_Actual) = E_Generic_Function
4708 or else Ekind (Val_Actual) = E_Procedure
4709 or else Ekind (Val_Actual) = E_Generic_Procedure)
4710 and then Present (Alias (Val_Actual))
4712 Val_Actual := Alias (Val_Actual);
4715 -- Renaming declarations for generic actuals do not come from source,
4716 -- and have a different name from that of the entity they rename, so
4717 -- there is no style check to perform here.
4719 if Chars (Nod) = Chars (Val_Actual) then
4720 Style.Check_Identifier (Nod, Val_Actual);
4725 Set_Entity (N, Val);
4726 end Set_Entity_With_Style_Check;
4728 ------------------------
4729 -- Set_Name_Entity_Id --
4730 ------------------------
4732 procedure Set_Name_Entity_Id (Id : Name_Id; Val : Entity_Id) is
4734 Set_Name_Table_Info (Id, Int (Val));
4735 end Set_Name_Entity_Id;
4737 ---------------------
4738 -- Set_Next_Actual --
4739 ---------------------
4741 procedure Set_Next_Actual (Ass1_Id : Node_Id; Ass2_Id : Node_Id) is
4743 if Nkind (Parent (Ass1_Id)) = N_Parameter_Association then
4744 Set_First_Named_Actual (Parent (Ass1_Id), Ass2_Id);
4746 end Set_Next_Actual;
4748 -----------------------
4749 -- Set_Public_Status --
4750 -----------------------
4752 procedure Set_Public_Status (Id : Entity_Id) is
4753 S : constant Entity_Id := Current_Scope;
4756 if S = Standard_Standard
4757 or else (Is_Public (S)
4758 and then (Ekind (S) = E_Package
4759 or else Is_Record_Type (S)
4760 or else Ekind (S) = E_Void))
4764 -- The bounds of an entry family declaration can generate object
4765 -- declarations that are visible to the back-end, e.g. in the
4766 -- the declaration of a composite type that contains tasks.
4769 and then Is_Concurrent_Type (S)
4770 and then not Has_Completion (S)
4771 and then Nkind (Parent (Id)) = N_Object_Declaration
4775 end Set_Public_Status;
4777 ----------------------------
4778 -- Set_Scope_Is_Transient --
4779 ----------------------------
4781 procedure Set_Scope_Is_Transient (V : Boolean := True) is
4783 Scope_Stack.Table (Scope_Stack.Last).Is_Transient := V;
4784 end Set_Scope_Is_Transient;
4790 procedure Set_Size_Info (T1, T2 : Entity_Id) is
4792 -- We copy Esize, but not RM_Size, since in general RM_Size is
4793 -- subtype specific and does not get inherited by all subtypes.
4795 Set_Esize (T1, Esize (T2));
4796 Set_Has_Biased_Representation (T1, Has_Biased_Representation (T2));
4798 if Is_Discrete_Or_Fixed_Point_Type (T1)
4800 Is_Discrete_Or_Fixed_Point_Type (T2)
4802 Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
4805 Set_Alignment (T1, Alignment (T2));
4808 --------------------
4809 -- Static_Integer --
4810 --------------------
4812 function Static_Integer (N : Node_Id) return Uint is
4814 Analyze_And_Resolve (N, Any_Integer);
4817 or else Error_Posted (N)
4818 or else Etype (N) = Any_Type
4823 if Is_Static_Expression (N) then
4824 if not Raises_Constraint_Error (N) then
4825 return Expr_Value (N);
4830 elsif Etype (N) = Any_Type then
4834 Error_Msg_N ("static integer expression required here", N);
4839 --------------------------
4840 -- Statically_Different --
4841 --------------------------
4843 function Statically_Different (E1, E2 : Node_Id) return Boolean is
4844 R1 : constant Node_Id := Get_Referenced_Object (E1);
4845 R2 : constant Node_Id := Get_Referenced_Object (E2);
4848 return Is_Entity_Name (R1)
4849 and then Is_Entity_Name (R2)
4850 and then Entity (R1) /= Entity (R2)
4851 and then not Is_Formal (Entity (R1))
4852 and then not Is_Formal (Entity (R2));
4853 end Statically_Different;
4855 -----------------------------
4856 -- Subprogram_Access_Level --
4857 -----------------------------
4859 function Subprogram_Access_Level (Subp : Entity_Id) return Uint is
4861 if Present (Alias (Subp)) then
4862 return Subprogram_Access_Level (Alias (Subp));
4864 return Scope_Depth (Enclosing_Dynamic_Scope (Subp));
4866 end Subprogram_Access_Level;
4872 procedure Trace_Scope (N : Node_Id; E : Entity_Id; Msg : String) is
4874 if Debug_Flag_W then
4875 for J in 0 .. Scope_Stack.Last loop
4880 Write_Name (Chars (E));
4881 Write_Str (" line ");
4882 Write_Int (Int (Get_Logical_Line_Number (Sloc (N))));
4887 -----------------------
4888 -- Transfer_Entities --
4889 -----------------------
4891 procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is
4892 Ent : Entity_Id := First_Entity (From);
4899 if (Last_Entity (To)) = Empty then
4900 Set_First_Entity (To, Ent);
4902 Set_Next_Entity (Last_Entity (To), Ent);
4905 Set_Last_Entity (To, Last_Entity (From));
4907 while Present (Ent) loop
4908 Set_Scope (Ent, To);
4910 if not Is_Public (Ent) then
4911 Set_Public_Status (Ent);
4914 and then Ekind (Ent) = E_Record_Subtype
4917 -- The components of the propagated Itype must be public
4924 Comp := First_Entity (Ent);
4926 while Present (Comp) loop
4927 Set_Is_Public (Comp);
4937 Set_First_Entity (From, Empty);
4938 Set_Last_Entity (From, Empty);
4939 end Transfer_Entities;
4941 -----------------------
4942 -- Type_Access_Level --
4943 -----------------------
4945 function Type_Access_Level (Typ : Entity_Id) return Uint is
4946 Btyp : Entity_Id := Base_Type (Typ);
4949 -- If the type is an anonymous access type we treat it as being
4950 -- declared at the library level to ensure that names such as
4951 -- X.all'access don't fail static accessibility checks.
4953 if Ekind (Btyp) in Access_Kind then
4954 if Ekind (Btyp) = E_Anonymous_Access_Type then
4955 return Scope_Depth (Standard_Standard);
4958 Btyp := Root_Type (Btyp);
4961 return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
4962 end Type_Access_Level;
4964 --------------------------
4965 -- Unit_Declaration_Node --
4966 --------------------------
4968 function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is
4969 N : Node_Id := Parent (Unit_Id);
4972 -- Predefined operators do not have a full function declaration.
4974 if Ekind (Unit_Id) = E_Operator then
4978 while Nkind (N) /= N_Abstract_Subprogram_Declaration
4979 and then Nkind (N) /= N_Formal_Package_Declaration
4980 and then Nkind (N) /= N_Formal_Subprogram_Declaration
4981 and then Nkind (N) /= N_Function_Instantiation
4982 and then Nkind (N) /= N_Generic_Package_Declaration
4983 and then Nkind (N) /= N_Generic_Subprogram_Declaration
4984 and then Nkind (N) /= N_Package_Declaration
4985 and then Nkind (N) /= N_Package_Body
4986 and then Nkind (N) /= N_Package_Instantiation
4987 and then Nkind (N) /= N_Package_Renaming_Declaration
4988 and then Nkind (N) /= N_Procedure_Instantiation
4989 and then Nkind (N) /= N_Subprogram_Declaration
4990 and then Nkind (N) /= N_Subprogram_Body
4991 and then Nkind (N) /= N_Subprogram_Body_Stub
4992 and then Nkind (N) /= N_Subprogram_Renaming_Declaration
4993 and then Nkind (N) /= N_Task_Body
4994 and then Nkind (N) /= N_Task_Type_Declaration
4995 and then Nkind (N) not in N_Generic_Renaming_Declaration
4998 pragma Assert (Present (N));
5002 end Unit_Declaration_Node;
5004 ----------------------
5005 -- Within_Init_Proc --
5006 ----------------------
5008 function Within_Init_Proc return Boolean is
5013 while not Is_Overloadable (S) loop
5014 if S = Standard_Standard then
5021 return Chars (S) = Name_uInit_Proc;
5022 end Within_Init_Proc;
5028 procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id) is
5029 Found_Type : constant Entity_Id := First_Subtype (Etype (Expr));
5030 Expec_Type : constant Entity_Id := First_Subtype (Expected_Type);
5032 function Has_One_Matching_Field return Boolean;
5033 -- Determines whether Expec_Type is a record type with a single
5034 -- component or discriminant whose type matches the found type or
5035 -- is a one dimensional array whose component type matches the
5038 function Has_One_Matching_Field return Boolean is
5042 if Is_Array_Type (Expec_Type)
5043 and then Number_Dimensions (Expec_Type) = 1
5045 Covers (Etype (Component_Type (Expec_Type)), Found_Type)
5049 elsif not Is_Record_Type (Expec_Type) then
5053 E := First_Entity (Expec_Type);
5059 elsif (Ekind (E) /= E_Discriminant
5060 and then Ekind (E) /= E_Component)
5061 or else (Chars (E) = Name_uTag
5062 or else Chars (E) = Name_uParent)
5071 if not Covers (Etype (E), Found_Type) then
5074 elsif Present (Next_Entity (E)) then
5081 end Has_One_Matching_Field;
5083 -- Start of processing for Wrong_Type
5086 -- Don't output message if either type is Any_Type, or if a message
5087 -- has already been posted for this node. We need to do the latter
5088 -- check explicitly (it is ordinarily done in Errout), because we
5089 -- are using ! to force the output of the error messages.
5091 if Expec_Type = Any_Type
5092 or else Found_Type = Any_Type
5093 or else Error_Posted (Expr)
5097 -- In an instance, there is an ongoing problem with completion of
5098 -- type derived from private types. Their structure is what Gigi
5099 -- expects, but the Etype is the parent type rather than the
5100 -- derived private type itself. Do not flag error in this case. The
5101 -- private completion is an entity without a parent, like an Itype.
5102 -- Similarly, full and partial views may be incorrect in the instance.
5103 -- There is no simple way to insure that it is consistent ???
5105 elsif In_Instance then
5107 if Etype (Etype (Expr)) = Etype (Expected_Type)
5108 and then No (Parent (Expected_Type))
5114 -- An interesting special check. If the expression is parenthesized
5115 -- and its type corresponds to the type of the sole component of the
5116 -- expected record type, or to the component type of the expected one
5117 -- dimensional array type, then assume we have a bad aggregate attempt.
5119 if Nkind (Expr) in N_Subexpr
5120 and then Paren_Count (Expr) /= 0
5121 and then Has_One_Matching_Field
5123 Error_Msg_N ("positional aggregate cannot have one component", Expr);
5125 -- Another special check, if we are looking for a pool-specific access
5126 -- type and we found an E_Access_Attribute_Type, then we have the case
5127 -- of an Access attribute being used in a context which needs a pool-
5128 -- specific type, which is never allowed. The one extra check we make
5129 -- is that the expected designated type covers the Found_Type.
5131 elsif Is_Access_Type (Expec_Type)
5132 and then Ekind (Found_Type) = E_Access_Attribute_Type
5133 and then Ekind (Base_Type (Expec_Type)) /= E_General_Access_Type
5134 and then Ekind (Base_Type (Expec_Type)) /= E_Anonymous_Access_Type
5136 (Designated_Type (Expec_Type), Designated_Type (Found_Type))
5138 Error_Msg_N ("result must be general access type!", Expr);
5139 Error_Msg_NE ("add ALL to }!", Expr, Expec_Type);
5141 -- If the expected type is an anonymous access type, as for access
5142 -- parameters and discriminants, the error is on the designated types.
5144 elsif Ekind (Expec_Type) = E_Anonymous_Access_Type then
5145 if Comes_From_Source (Expec_Type) then
5146 Error_Msg_NE ("expected}!", Expr, Expec_Type);
5149 ("expected an access type with designated}",
5150 Expr, Designated_Type (Expec_Type));
5153 if Is_Access_Type (Found_Type)
5154 and then not Comes_From_Source (Found_Type)
5157 ("found an access type with designated}!",
5158 Expr, Designated_Type (Found_Type));
5160 if From_With_Type (Found_Type) then
5161 Error_Msg_NE ("found incomplete}!", Expr, Found_Type);
5163 ("\possibly missing with_clause on&", Expr,
5164 Scope (Found_Type));
5166 Error_Msg_NE ("found}!", Expr, Found_Type);
5170 -- Normal case of one type found, some other type expected
5173 -- If the names of the two types are the same, see if some
5174 -- number of levels of qualification will help. Don't try
5175 -- more than three levels, and if we get to standard, it's
5176 -- no use (and probably represents an error in the compiler)
5177 -- Also do not bother with internal scope names.
5180 Expec_Scope : Entity_Id;
5181 Found_Scope : Entity_Id;
5184 Expec_Scope := Expec_Type;
5185 Found_Scope := Found_Type;
5187 for Levels in Int range 0 .. 3 loop
5188 if Chars (Expec_Scope) /= Chars (Found_Scope) then
5189 Error_Msg_Qual_Level := Levels;
5193 Expec_Scope := Scope (Expec_Scope);
5194 Found_Scope := Scope (Found_Scope);
5196 exit when Expec_Scope = Standard_Standard
5198 Found_Scope = Standard_Standard
5200 not Comes_From_Source (Expec_Scope)
5202 not Comes_From_Source (Found_Scope);
5206 Error_Msg_NE ("expected}!", Expr, Expec_Type);
5208 if Is_Entity_Name (Expr)
5209 and then Is_Package (Entity (Expr))
5211 Error_Msg_N ("found package name!", Expr);
5213 elsif Is_Entity_Name (Expr)
5215 (Ekind (Entity (Expr)) = E_Procedure
5217 Ekind (Entity (Expr)) = E_Generic_Procedure)
5219 Error_Msg_N ("found procedure name instead of function!", Expr);
5221 -- catch common error: a prefix or infix operator which is not
5222 -- directly visible because the type isn't.
5224 elsif Nkind (Expr) in N_Op
5225 and then Is_Overloaded (Expr)
5226 and then not Is_Immediately_Visible (Expec_Type)
5227 and then not Is_Potentially_Use_Visible (Expec_Type)
5228 and then not In_Use (Expec_Type)
5229 and then Has_Compatible_Type (Right_Opnd (Expr), Expec_Type)
5232 "operator of the type is not directly visible!", Expr);
5235 Error_Msg_NE ("found}!", Expr, Found_Type);
5238 Error_Msg_Qual_Level := 0;